diff options
author | gilzoide <gilzoide@gmail.com> | 2024-05-04 07:38:56 -0300 |
---|---|---|
committer | gilzoide <gilzoide@gmail.com> | 2024-05-04 08:13:16 -0300 |
commit | 02b80cef1ad56565e181ddd30142bd9ddfc10d74 (patch) | |
tree | 11b5a5437f8c112beb8bdc39c172a2ff53a34571 /sources/s7/s7.c | |
parent | 0b16bff33cea484c03adc9304623b81629392722 (diff) | |
download | gamejam-slgj-2024-02b80cef1ad56565e181ddd30142bd9ddfc10d74.tar.gz gamejam-slgj-2024-02b80cef1ad56565e181ddd30142bd9ddfc10d74.tar.bz2 gamejam-slgj-2024-02b80cef1ad56565e181ddd30142bd9ddfc10d74.zip |
Expand tabs into 8 spaces in s7 source code
This makes the code correctly aligned in any editors
Diffstat (limited to 'sources/s7/s7.c')
-rw-r--r-- | sources/s7/s7.c | 60330 |
1 files changed, 30165 insertions, 30165 deletions
diff --git a/sources/s7/s7.c b/sources/s7/s7.c index a13d857..f432698 100644 --- a/sources/s7/s7.c +++ b/sources/s7/s7.c @@ -550,7 +550,7 @@ typedef block_t vdims_t; typedef enum {TOKEN_EOF, TOKEN_LEFT_PAREN, TOKEN_RIGHT_PAREN, TOKEN_DOT, TOKEN_ATOM, TOKEN_QUOTE, TOKEN_DOUBLE_QUOTE, TOKEN_BACK_QUOTE, - TOKEN_COMMA, TOKEN_AT_MARK, TOKEN_SHARP_CONST, TOKEN_VECTOR, TOKEN_BYTE_VECTOR, TOKEN_INT_VECTOR, TOKEN_FLOAT_VECTOR} token_t; + TOKEN_COMMA, TOKEN_AT_MARK, TOKEN_SHARP_CONST, TOKEN_VECTOR, TOKEN_BYTE_VECTOR, TOKEN_INT_VECTOR, TOKEN_FLOAT_VECTOR} token_t; typedef enum {NO_ARTICLE, INDEFINITE_ARTICLE} article_t; typedef enum {DWIND_INIT, DWIND_BODY, DWIND_FINISH} dwind_t; @@ -587,11 +587,11 @@ typedef struct { } port_t; typedef enum {o_d_v, o_d_vd, o_d_vdd, o_d_vid, o_d_id, o_d_7pi, o_d_7pii, o_d_7piid, o_d_7piii, o_d_7piiid, - o_d_ip, o_d_pd, o_d_7pid, o_d, o_d_d, o_d_dd, o_d_7dd, o_d_ddd, o_d_dddd, - o_i_i, o_i_7i, o_i_ii, o_i_7ii, o_i_iii, o_i_7pi, o_i_7pii, o_i_7piii, o_d_p, - o_b_p, o_b_7p, o_b_pp, o_b_7pp, o_b_pp_unchecked, o_b_pi, o_b_ii, o_b_7ii, o_b_dd, - o_p, o_p_p, o_p_ii, o_p_d, o_p_dd, o_i_7d, o_i_7p, o_d_7d, o_p_pp, o_p_ppp, o_p_pi, o_p_pi_unchecked, - o_p_ppi, o_p_i, o_p_pii, o_p_pip, o_p_pip_unchecked, o_p_piip, o_b_i, o_b_d} opt_func_t; + o_d_ip, o_d_pd, o_d_7pid, o_d, o_d_d, o_d_dd, o_d_7dd, o_d_ddd, o_d_dddd, + o_i_i, o_i_7i, o_i_ii, o_i_7ii, o_i_iii, o_i_7pi, o_i_7pii, o_i_7piii, o_d_p, + o_b_p, o_b_7p, o_b_pp, o_b_7pp, o_b_pp_unchecked, o_b_pi, o_b_ii, o_b_7ii, o_b_dd, + o_p, o_p_p, o_p_ii, o_p_d, o_p_dd, o_i_7d, o_i_7p, o_d_7d, o_p_pp, o_p_ppp, o_p_pi, o_p_pi_unchecked, + o_p_ppi, o_p_i, o_p_pii, o_p_pip, o_p_pip_unchecked, o_p_piip, o_b_i, o_b_d} opt_func_t; typedef struct opt_funcs_t { opt_func_t typ; @@ -799,13 +799,13 @@ typedef struct s7_cell { s7_double real_value; struct { /* ratios */ - s7_int numerator; - s7_int denominator; + s7_int numerator; + s7_int denominator; } fraction_value; struct { /* complex numbers */ - s7_double rl; - s7_double im; + s7_double rl; + s7_double im; } complex_value; #if WITH_GMP @@ -843,16 +843,16 @@ typedef struct s7_cell { struct { /* vectors */ s7_int length; union { - s7_pointer *objects; - s7_int *ints; - s7_double *floats; - uint8_t *bytes; + s7_pointer *objects; + s7_int *ints; + s7_double *floats; + uint8_t *bytes; } elements; block_t *block; s7_pointer (*vget)(s7_scheme *sc, s7_pointer vec, s7_int loc); union { - s7_pointer (*vset)(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val); - s7_pointer fset; + s7_pointer (*vset)(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val); + s7_pointer fset; } setv; } vector; @@ -874,13 +874,13 @@ typedef struct s7_cell { struct { /* iterators */ s7_pointer obj, cur; union { - s7_int loc; - s7_pointer lcur; + s7_int loc; + s7_pointer lcur; } lc; union { - s7_int len; - s7_pointer slow; - hash_entry_t *hcur; + s7_int len; + s7_pointer slow; + hash_entry_t *hcur; } lw; s7_pointer (*next)(s7_scheme *sc, s7_pointer iterator); } iter; @@ -895,13 +895,13 @@ typedef struct s7_cell { s7_pointer car, cdr, opt1; union { - s7_pointer opt2; - s7_int n; + s7_pointer opt2; + s7_int n; } o2; union { - s7_pointer opt3; - s7_int n; - uint8_t opt_type; + s7_pointer opt3; + s7_int n; + uint8_t opt_type; } o3; } cons; @@ -947,14 +947,14 @@ typedef struct s7_cell { s7_pointer slots, nxt; int64_t id; /* id of rootlet is -1 */ union { - struct { - s7_pointer function; /* *function* (symbol) if this is a funclet */ - uint32_t line, file; /* *function* location if it is known */ - } efnc; - struct { - s7_pointer dox1, dox2; /* do loop variables */ - } dox; - s7_int key; /* sc->baffle_ctr type */ + struct { + s7_pointer function; /* *function* (symbol) if this is a funclet */ + uint32_t line, file; /* *function* location if it is known */ + } efnc; + struct { + s7_pointer dox1, dox2; /* do loop variables */ + } dox; + s7_int key; /* sc->baffle_ctr type */ } edat; } envr; @@ -1459,14 +1459,14 @@ static FILE *old_fopen(const char *pathname, const char *mode) {return(fopen(pat static size_t local_fwrite(const void *ptr, size_t size, size_t nmemb, FILE *stream) { error_nr(cur_sc, cur_sc->io_error_symbol, - set_elist_1(cur_sc, wrap_string(cur_sc, "writing a file is not allowed in this version of s7", 51))); + set_elist_1(cur_sc, wrap_string(cur_sc, "writing a file is not allowed in this version of s7", 51))); } static FILE *local_fopen(const char *pathname, const char *mode) { if ((mode[0] == 'w') || (mode[0] == 'a')) error_nr(cur_sc, cur_sc->io_error_symbol, - set_elist_1(cur_sc, wrap_string(cur_sc, "opening a file is not allowed in this version of s7", 51))); + set_elist_1(cur_sc, wrap_string(cur_sc, "opening a file is not allowed in this version of s7", 51))); return(old_fopen(pathname, mode)); } #endif @@ -1584,10 +1584,10 @@ static inline void liberate(s7_scheme *sc, block_t *p) else { if (block_data(p)) - { - free(block_data(p)); - block_data(p) = NULL; - } + { + free(block_data(p)); + block_data(p) = NULL; + } block_next(p) = (struct block_t *)sc->block_lists[BLOCK_LIST]; sc->block_lists[BLOCK_LIST] = p; } @@ -1636,11 +1636,11 @@ static inline char *permalloc(s7_scheme *sc, size_t len) if (next_k > ALLOC_STRING_SIZE) { if (len >= ALLOC_MAX_STRING) - { - result = (char *)Malloc(len); - add_saved_pointer(sc, result); - return(result); - } + { + result = (char *)Malloc(len); + add_saved_pointer(sc, result); + return(result); + } sc->alloc_string_cells = (char *)Malloc(ALLOC_STRING_SIZE); /* get a new block */ add_saved_pointer(sc, sc->alloc_string_cells); sc->alloc_string_k = 0; @@ -1658,37 +1658,37 @@ static Inline block_t *inline_mallocate(s7_scheme *sc, size_t bytes) { int32_t index; if (bytes <= 8) /* presetting a version of intlen_bits with 3's gave only a small speed-up */ - index = 3; + index = 3; else - { - if (bytes <= 256) - index = intlen_bits[bytes - 1]; - else index = (bytes <= 65536) ? (8 + intlen_bits[(bytes - 1) >> 8]) : TOP_BLOCK_LIST; /* expansion to (1 << 17) made no difference */ - } + { + if (bytes <= 256) + index = intlen_bits[bytes - 1]; + else index = (bytes <= 65536) ? (8 + intlen_bits[(bytes - 1) >> 8]) : TOP_BLOCK_LIST; /* expansion to (1 << 17) made no difference */ + } p = sc->block_lists[index]; if (p) - sc->block_lists[index] = (block_t *)block_next(p); + sc->block_lists[index] = (block_t *)block_next(p); else - { - if (index < (TOP_BLOCK_LIST - 1)) - { - p = sc->block_lists[index + 1]; - if (p) - { - /* we are "borrowing" a block from the next larger bin -- this saves space but costs a bit of time. - * in a tauto run repeating every call 1000 times, the old form ends up at 129M and 31.1 secs, - * whereas the borrowing form ends at 116M and 31.5 secs, but most of my tests show a slight - * speed-up, probably because grabbing a block here is faster than making a new one. - * Worst case is tlet: 8 slower in callgrind. - */ - sc->block_lists[index + 1] = (block_t *)block_next(p); - block_set_size(p, bytes); - return(p); - }} - p = mallocate_block(sc); - block_data(p) = (index < TOP_BLOCK_LIST) ? (void *)permalloc(sc, (size_t)(1 << index)) : Malloc(bytes); - block_set_index(p, index); - }} + { + if (index < (TOP_BLOCK_LIST - 1)) + { + p = sc->block_lists[index + 1]; + if (p) + { + /* we are "borrowing" a block from the next larger bin -- this saves space but costs a bit of time. + * in a tauto run repeating every call 1000 times, the old form ends up at 129M and 31.1 secs, + * whereas the borrowing form ends at 116M and 31.5 secs, but most of my tests show a slight + * speed-up, probably because grabbing a block here is faster than making a new one. + * Worst case is tlet: 8 slower in callgrind. + */ + sc->block_lists[index + 1] = (block_t *)block_next(p); + block_set_size(p, bytes); + return(p); + }} + p = mallocate_block(sc); + block_data(p) = (index < TOP_BLOCK_LIST) ? (void *)permalloc(sc, (size_t)(1 << index)) : Malloc(bytes); + block_set_index(p, index); + }} else p = mallocate_block(sc); block_set_size(p, bytes); return(p); @@ -1702,9 +1702,9 @@ static block_t *callocate(s7_scheme *sc, size_t bytes) if ((block_data(p)) && (block_index(p) != BLOCK_LIST)) { if ((bytes & (~0x3f)) > 0) - memclr64((void *)block_data(p), bytes & (~0x3f)); + memclr64((void *)block_data(p), bytes & (~0x3f)); if ((bytes & 0x3f) > 0) - memclr((void *)((uint8_t *)block_data(p) + (bytes & (~0x3f))), bytes & 0x3f); + memclr((void *)((uint8_t *)block_data(p) + (bytes & (~0x3f))), bytes & 0x3f); } return(p); } @@ -3222,7 +3222,7 @@ static s7_pointer slot_expression(s7_pointer p) \ #define pair_set_syntax_op(p, X) do {set_optimize_op(p, X); set_syntactic_pair(p);} while (0) #define symbol_syntax_op_checked(p) ((is_syntactic_pair(p)) ? optimize_op(p) : symbol_syntax_op(car(p))) #define symbol_syntax_op(p) syntax_opcode(global_value(p)) -#define is_syntax_or_qq(p) ((is_syntax(p)) || ((p) == sc->quasiquote_function)) /* qq is from s7_define_macro -> T_C_MACRO */ +#define is_syntax_or_qq(p) ((is_syntax(p)) || ((p) == sc->quasiquote_function)) /* qq is from s7_define_macro -> T_C_MACRO */ #define let_id(p) (T_Let(p))->object.envr.id #define let_set_id(p, Id) (T_Let(p))->object.envr.id = Id @@ -3681,13 +3681,13 @@ static void set_type_1(s7_pointer p, uint64_t f, const char *func, int32_t line) fprintf(stderr, "%d: set invalid type, %p type to %" PRIx64 "\n", __LINE__, p, (int64_t)(f)); else { - if (((full_type(p) & T_IMMUTABLE) != 0) && ((full_type(p) != (uint64_t)(f)))) - { - fprintf(stderr, "%s[%d]: set immutable %p type %d to %" ld64 "\n", __func__, __LINE__, p, unchecked_type(p), (int64_t)(f)); - abort(); - } - if (((full_type(p) & T_UNHEAP) != 0) && (((f) & T_UNHEAP) == 0)) - fprintf(stderr, "%s[%d]: clearing unheap in set type!\n", __func__, __LINE__); + if (((full_type(p) & T_IMMUTABLE) != 0) && ((full_type(p) != (uint64_t)(f)))) + { + fprintf(stderr, "%s[%d]: set immutable %p type %d to %" ld64 "\n", __func__, __LINE__, p, unchecked_type(p), (int64_t)(f)); + abort(); + } + if (((full_type(p) & T_UNHEAP) != 0) && (((f) & T_UNHEAP) == 0)) + fprintf(stderr, "%s[%d]: clearing unheap in set type!\n", __func__, __LINE__); } full_type(p) = f; } @@ -3879,11 +3879,11 @@ static void try_to_call_gc(s7_scheme *sc); * does not return it to the free list: a memory leak. */ #if (!S7_DEBUGGING) -#define new_cell(Sc, Obj, Type) \ - do { \ +#define new_cell(Sc, Obj, Type) \ + do { \ if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \ Obj = (*(--(Sc->free_heap_top))); \ - set_full_type(Obj, Type); \ + set_full_type(Obj, Type); \ } while (0) #define new_cell_no_check(Sc, Obj, Type) do {Obj = (*(--(Sc->free_heap_top))); set_full_type(Obj, Type);} while (0) @@ -3892,20 +3892,20 @@ static void try_to_call_gc(s7_scheme *sc); */ #else -#define new_cell(Sc, Obj, Type) \ - do { \ +#define new_cell(Sc, Obj, Type) \ + do { \ if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc); \ - Obj = (*(--(Sc->free_heap_top))); \ - Obj->debugger_bits = 0; Obj->gc_func = NULL; Obj->gc_line = 0; \ - set_full_type(Obj, Type); \ + Obj = (*(--(Sc->free_heap_top))); \ + Obj->debugger_bits = 0; Obj->gc_func = NULL; Obj->gc_line = 0; \ + set_full_type(Obj, Type); \ } while (0) -#define new_cell_no_check(Sc, Obj, Type) \ - do { \ - Obj = (*(--(Sc->free_heap_top))); \ +#define new_cell_no_check(Sc, Obj, Type) \ + do { \ + Obj = (*(--(Sc->free_heap_top))); \ if (Sc->free_heap_top < Sc->free_heap) {fprintf(stderr, "%s[%d]: free heap exhausted\n", __func__, __LINE__); abort();}\ - Obj->debugger_bits = 0; Obj->gc_func = NULL; Obj->gc_line = 0; \ - set_full_type(Obj, Type); \ + Obj->debugger_bits = 0; Obj->gc_func = NULL; Obj->gc_line = 0; \ + set_full_type(Obj, Type); \ } while (0) #endif @@ -3929,7 +3929,7 @@ static void try_to_call_gc(s7_scheme *sc); #endif #define make_complex(Sc, R, I) \ ({ s7_double _im_; _im_ = (I); ((_im_ == 0.0) ? make_real(Sc, R) : \ - ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, _im_); _C_;}) ); }) + ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, _im_); _C_;}) ); }) #define real_to_double(Sc, X, Caller) ({ s7_pointer _x_; _x_ = (X); ((type(_x_) == T_REAL) ? real(_x_) : s7_number_to_real_with_caller(Sc, _x_, Caller)); }) #define rational_to_double(Sc, X) ({ s7_pointer _x_; _x_ = (X); ((type(_x_) == T_INTEGER) ? (s7_double)integer(_x_) : fraction(_x_)); }) @@ -4006,7 +4006,7 @@ static void local_memset(void *s, uint8_t val, size_t n) int64_t ival = val | (val << 8) | (val << 16) | (((uint64_t)val) << 24); /* uint64_t casts make gcc/clang/fsanitize happy */ ival = (((uint64_t)ival) << 32) | ival; if ((n8 & 0x3) == 0) - while (n8 > 0) {LOOP_4(*s1++ = ival); n8 -= 4;} + while (n8 > 0) {LOOP_4(*s1++ = ival); n8 -= 4;} else do {*s1++ = ival;} while (--n8 > 0); n &= 7; s2 = (uint8_t *)s1; @@ -4588,24 +4588,24 @@ static const char* op_names[NUM_OPS] = static bool is_h_optimized(s7_pointer p) { return((is_optimized(p)) && - (op_has_hop(p)) && - (optimize_op(p) < FIRST_UNHOPPABLE_OP) && /* was OP_S? */ - (optimize_op(p) > OP_GC_PROTECT)); + (op_has_hop(p)) && + (optimize_op(p) < FIRST_UNHOPPABLE_OP) && /* was OP_S? */ + (optimize_op(p) > OP_GC_PROTECT)); } /* if this changes, remember to change lint.scm */ typedef enum {SL_NO_FIELD=0, SL_STACK_TOP, SL_STACK_SIZE, SL_STACKTRACE_DEFAULTS, SL_HEAP_SIZE, SL_FREE_HEAP_SIZE, SL_GC_FREED, SL_GC_PROTECTED_OBJECTS, SL_GC_TOTAL_FREED, SL_GC_INFO, SL_FILE_NAMES, SL_FILENAMES, SL_ROOTLET_SIZE, SL_C_TYPES, SL_SAFETY, SL_UNDEFINED_IDENTIFIER_WARNINGS, SL_UNDEFINED_CONSTANT_WARNINGS, SL_GC_STATS, SL_MAX_HEAP_SIZE, - SL_MAX_PORT_DATA_SIZE, SL_MAX_STACK_SIZE, SL_CPU_TIME, SL_CATCHES, SL_STACK, SL_MAJOR_VERSION, SL_MINOR_VERSION, - SL_MAX_STRING_LENGTH, SL_MAX_FORMAT_LENGTH, SL_MAX_LIST_LENGTH, SL_MAX_VECTOR_LENGTH, SL_MAX_VECTOR_DIMENSIONS, - SL_DEFAULT_HASH_TABLE_LENGTH, SL_INITIAL_STRING_PORT_LENGTH, SL_DEFAULT_RATIONALIZE_ERROR, - SL_DEFAULT_RANDOM_STATE, SL_EQUIVALENT_FLOAT_EPSILON, SL_HASH_TABLE_FLOAT_EPSILON, SL_PRINT_LENGTH, - SL_BIGNUM_PRECISION, SL_MEMORY_USAGE, SL_FLOAT_FORMAT_PRECISION, SL_HISTORY, SL_HISTORY_ENABLED, - SL_HISTORY_SIZE, SL_PROFILE, SL_PROFILE_INFO, SL_PROFILE_PREFIX, SL_AUTOLOADING, SL_ACCEPT_ALL_KEYWORD_ARGUMENTS, - SL_MUFFLE_WARNINGS, SL_MOST_POSITIVE_FIXNUM, SL_MOST_NEGATIVE_FIXNUM, SL_OUTPUT_FILE_PORT_DATA_SIZE, SL_DEBUG, SL_VERSION, - SL_GC_TEMPS_SIZE, SL_GC_RESIZE_HEAP_FRACTION, SL_GC_RESIZE_HEAP_BY_4_FRACTION, SL_OPENLETS, SL_EXPANSIONS, - SL_NUMBER_SEPARATOR, SL_NUM_FIELDS} s7_starlet_t; + SL_MAX_PORT_DATA_SIZE, SL_MAX_STACK_SIZE, SL_CPU_TIME, SL_CATCHES, SL_STACK, SL_MAJOR_VERSION, SL_MINOR_VERSION, + SL_MAX_STRING_LENGTH, SL_MAX_FORMAT_LENGTH, SL_MAX_LIST_LENGTH, SL_MAX_VECTOR_LENGTH, SL_MAX_VECTOR_DIMENSIONS, + SL_DEFAULT_HASH_TABLE_LENGTH, SL_INITIAL_STRING_PORT_LENGTH, SL_DEFAULT_RATIONALIZE_ERROR, + SL_DEFAULT_RANDOM_STATE, SL_EQUIVALENT_FLOAT_EPSILON, SL_HASH_TABLE_FLOAT_EPSILON, SL_PRINT_LENGTH, + SL_BIGNUM_PRECISION, SL_MEMORY_USAGE, SL_FLOAT_FORMAT_PRECISION, SL_HISTORY, SL_HISTORY_ENABLED, + SL_HISTORY_SIZE, SL_PROFILE, SL_PROFILE_INFO, SL_PROFILE_PREFIX, SL_AUTOLOADING, SL_ACCEPT_ALL_KEYWORD_ARGUMENTS, + SL_MUFFLE_WARNINGS, SL_MOST_POSITIVE_FIXNUM, SL_MOST_NEGATIVE_FIXNUM, SL_OUTPUT_FILE_PORT_DATA_SIZE, SL_DEBUG, SL_VERSION, + SL_GC_TEMPS_SIZE, SL_GC_RESIZE_HEAP_FRACTION, SL_GC_RESIZE_HEAP_BY_4_FRACTION, SL_OPENLETS, SL_EXPANSIONS, + SL_NUMBER_SEPARATOR, SL_NUM_FIELDS} s7_starlet_t; static const char *s7_starlet_names[SL_NUM_FIELDS] = {"no-field", "stack-top", "stack-size", "stacktrace-defaults", "heap-size", "free-heap-size", @@ -4668,16 +4668,16 @@ bool s7_is_valid(s7_scheme *sc, s7_pointer arg) old_segv = signal(SIGSEGV, segv); #endif if ((unchecked_type(arg) > T_FREE) && - (unchecked_type(arg) < NUM_TYPES)) - { - if (!in_heap(arg)) - result = true; - else - { - int64_t loc = heap_location(sc, arg); - if ((loc >= 0) && (loc < sc->heap_size)) - result = (sc->heap[loc] == arg); - }} + (unchecked_type(arg) < NUM_TYPES)) + { + if (!in_heap(arg)) + result = true; + else + { + int64_t loc = heap_location(sc, arg); + if ((loc >= 0) && (loc < sc->heap_size)) + result = (sc->heap[loc] == arg); + }} #if TRAP_SEGFAULT signal(SIGSEGV, old_segv); } @@ -4687,12 +4687,12 @@ bool s7_is_valid(s7_scheme *sc, s7_pointer arg) return(result); } -#define safe_print(Code) \ - do { \ +#define safe_print(Code) \ + do { \ bool old_open = sc->has_openlets, old_stop = sc->stop_at_error; \ sc->has_openlets = false; \ - sc->stop_at_error = false; \ - Code; \ + sc->stop_at_error = false; \ + Code; \ sc->stop_at_error = old_stop; \ sc->has_openlets = old_open; \ } while (0) @@ -4709,7 +4709,7 @@ void s7_show_history(s7_scheme *sc) s7_pointer p = cdr(sc->cur_code); fprintf(stderr, "history:\n"); for (int32_t i = 0; i < size; i++, p = cdr(p)) /* stepper "i" is not redundant */ - safe_print(fprintf(stderr, "%d: %s\n", i, display_truncated(car(p)))); + safe_print(fprintf(stderr, "%d: %s\n", i, display_truncated(car(p)))); fprintf(stderr, "\n"); } #else @@ -4728,196 +4728,196 @@ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) char str[900]; str[0] = '\0'; - catstrs(str, 900, /* if debugging, all of these bits are being watched, so we need to access them directly */ - /* bit 8 (the first 8 bits (after the 8 type bits) are easy...) */ - ((full_typ & T_MULTIFORM) != 0) ? ((is_any_closure(obj)) ? - (((full_typ & T_ONE_FORM) != 0) ? " closure-one-form-has-fx" : " closure-multiform") : - " ?0?") : "", - /* bit 9 */ - ((full_typ & T_SYNTACTIC) != 0) ? (((is_pair(obj)) || (is_syntax(obj)) || (is_normal_symbol(obj))) ? - " syntactic" : - " ?1?") : "", - /* bit 10 */ - ((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) ? ((is_pair(obj)) ? " simple-args|in-use" : - ((is_any_closure(obj)) ? " closure-one-form" : - " ?2?")) : "", - /* bit 11 */ - ((full_typ & T_OPTIMIZED) != 0) ? ((is_c_function(obj)) ? " scope-safe" : - ((is_pair(obj)) ? " optimized" : - " ?3?")) : "", - /* bit 12 */ - ((full_typ & T_SAFE_CLOSURE) != 0) ? (((has_closure_let(obj)) || (is_pair(obj))) ? " safe-closure" : " ?4?") : "", - /* bit 13 */ - ((full_typ & T_DONT_EVAL_ARGS) != 0) ? (((is_any_macro(obj)) || (is_syntax(obj))) ? " dont-eval-args" : " ?5?") : "", - /* bit 14 */ - ((full_typ & T_EXPANSION) != 0) ? (((is_normal_symbol(obj)) || (is_either_macro(obj))) ? " expansion" : " ?6?") : "", - /* bit 15 */ - ((full_typ & T_MULTIPLE_VALUE) != 0) ? ((is_symbol(obj)) ? " matched" : - ((is_pair(obj)) ? " values|matched" : - " ?7?")) : "", - /* bit 16 */ - ((full_typ & T_GLOBAL) != 0) ? ((is_pair(obj)) ? " unsafe-do" : - (((is_symbol(obj)) || (is_syntax(obj))) ? " global" : - ((is_let(obj)) ? " dox_slot1" : - " ?8?"))) : "", - /* bit 17 */ - ((full_typ & T_COLLECTED) != 0) ? " collected" : "", - /* bit 18 */ - ((full_typ & T_LOCATION) != 0) ? ((is_pair(obj)) ? " line-number" : - ((is_input_port(obj)) ? " loader-port" : - ((is_let(obj)) ? " with-let" : - ((is_any_procedure(obj)) ? " simple-defaults" : - ((is_slot(obj)) ? " has-setter" : - " ?10?"))))) : "", - /* bit 19 */ - ((full_typ & T_SHARED) != 0) ? ((is_sequence(obj)) ? " shared" : " ?11?") : "", - /* bit 20 */ - ((full_typ & T_LOCAL) != 0) ? ((is_normal_symbol(obj)) ? " local" : - ((is_pair(obj)) ? " high-c" : - " ?12?")) : "", - /* bit 21 */ - ((full_typ & T_SAFE_PROCEDURE) != 0) ? ((is_applicable(obj)) ? " safe-procedure" : " ?13?") : "", - /* bit 22 */ - ((full_typ & T_CHECKED) != 0) ? (((is_pair(obj)) || (is_slot(obj))) ? " checked" : - ((is_symbol(obj)) ? " all-integer" : - " ?14?")) : "", - /* bit 23 */ - ((full_typ & T_UNSAFE) != 0) ? ((is_symbol(obj)) ? " clean-symbol" : - ((is_slot(obj)) ? " has-stepper" : - ((is_pair(obj)) ? " unsafely-opt|no-float-opt" : - ((is_let(obj)) ? " dox-slot2" : - " ?15?")))) : "", - /* bit 24 */ - ((full_typ & T_IMMUTABLE) != 0) ? " immutable" : "", - /* bit 25 */ - ((full_typ & T_SETTER) != 0) ? ((is_normal_symbol(obj)) ? " setter" : - ((is_pair(obj)) ? " allow-other-keys|no-int-opt" : - ((is_slot(obj)) ? " has-expression" : - ((is_c_function_star(obj)) ? " allow-other-keys" : - ((is_let(obj)) ? " let-removed-from-heap" : - " ?17?"))))) : "", - /* bit 26 */ - ((full_typ & T_MUTABLE) != 0) ? ((is_number(obj)) ? " mutable" : - ((is_symbol(obj)) ? " has-keyword" : - ((is_let(obj)) ? " ref-fallback" : - ((is_iterator(obj)) ? " mark-sequence" : - ((is_slot(obj)) ? " step-end" : - ((is_pair(obj)) ? " no-opt" : - " ?18?")))))) : "", - /* bit 27 */ - ((full_typ & T_SAFE_STEPPER) != 0) ? ((is_let(obj)) ? " set-fallback" : - ((is_slot(obj)) ? " safe-stepper" : - ((is_c_function(obj)) ? " maybe-safe" : - ((is_number(obj)) ? " print-name" : - ((is_pair(obj)) ? " direct-opt" : - ((is_hash_table(obj)) ? " weak-hash" : - ((is_any_macro(obj)) ? " pair-macro-set" : - ((is_symbol(obj)) ? " all-float" : - " ?19?")))))))) : "", - /* bit 28, for c_function case see sc->apply */ - ((full_typ & T_COPY_ARGS) != 0) ? (((is_pair(obj)) || (is_any_macro(obj)) || (is_syntax(obj)) || - (is_any_closure(obj)) || (is_c_function(obj))) ? " copy-args" : - " ?20?") : "", - /* bit 29 */ - ((full_typ & T_GENSYM) != 0) ? ((is_let(obj)) ? " funclet" : - ((is_normal_symbol(obj)) ? " gensym" : - ((is_string(obj)) ? " documented-symbol" : - ((is_hash_table(obj)) ? " hash-chosen" : - ((is_pair(obj)) ? " fx-treed" : - ((is_any_vector(obj)) ? " subvector" : - ((is_slot(obj)) ? " has-pending-value" : - ((is_any_closure(obj)) ? " unknopt" : - " ?21?")))))))) : "", - /* bit 30 [pair and symbol free here] */ - ((full_typ & T_HAS_METHODS) != 0) ? (((is_let(obj)) || (is_c_object(obj)) || (is_any_closure(obj)) || - (is_any_macro(obj)) || (is_c_pointer(obj))) ? " has-methods" : - " ?22?") : "", - /* bit 31 */ - ((full_typ & T_ITER_OK) != 0) ? ((is_iterator(obj)) ? " iter-ok" : - ((is_pair(obj)) ? " loop-end-possible" : - ((is_slot(obj)) ? " in-rootlet" : - ((is_c_function(obj)) ? " bool-function" : - ((is_symbol(obj)) ? " symbol-from-symbol" : - " ?23?"))))) : "", - /* bit 24+24 */ - ((full_typ & T_FULL_SYMCONS) != 0) ? ((is_symbol(obj)) ? " possibly-constant" : - ((is_any_procedure(obj)) ? " has-let-arg" : - ((is_hash_table(obj)) ? " has-value-type" : - ((is_pair(obj)) ? " int-optable" : - ((is_let(obj)) ? " unlet" : - ((is_t_vector(obj)) ? " symbol-table" : - " ?24?")))))) : "", - /* bit 25+24 */ - ((full_typ & T_FULL_HAS_LET_FILE) != 0) ? ((is_let(obj)) ? " has-let-file" : - ((is_t_vector(obj)) ? " typed-vector" : - ((is_hash_table(obj)) ? " typed-hash-table" : - ((is_c_function(obj)) ? " has-bool-setter" : - ((is_slot(obj)) ? " rest-slot" : - (((is_pair(obj)) || (is_closure_star(obj))) ? " no-defaults" : - " ?25?")))))) : "", - /* bit 26+24 */ - ((full_typ & T_FULL_DEFINER) != 0) ? ((is_normal_symbol(obj)) ? " definer" : - ((is_pair(obj)) ? " has-fx" : - ((is_slot(obj)) ? " slot-defaults" : - ((is_iterator(obj)) ? " weak-hash-iterator" : - ((is_hash_table(obj)) ? " has-key-type" : - ((is_let(obj)) ? " maclet" : - ((is_c_function(obj)) ? " func-definer" : - ((is_syntax(obj)) ? " syntax-definer" : - " ?26?")))))))) : "", - /* bit 27+24 */ - ((full_typ & T_FULL_BINDER) != 0) ? ((is_pair(obj)) ? " tree-collected" : - ((is_hash_table(obj)) ? " simple-values" : - ((is_normal_symbol(obj)) ? " binder" : - ((is_c_function(obj)) ? " safe-args" : - ((is_syntax(obj)) ? " syntax-binder" : - " ?27?"))))) : "", - /* bit 28+24 */ - ((full_typ & T_VERY_SAFE_CLOSURE) != 0) ? (((is_pair(obj)) || (is_any_closure(obj))) ? " very-safe-closure" : - ((is_let(obj)) ? " baffle-let" : - " ?28?")) : "", - /* bit 29+24 */ - ((full_typ & T_CYCLIC) != 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) || - (is_any_closure(obj))) ? " cyclic" : " ?29?") : "", - /* bit 30+24 */ - ((full_typ & T_CYCLIC_SET) != 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) || - (is_any_closure(obj))) ? " cyclic-set" : " ?30?") : "", - /* bit 31+24 */ - ((full_typ & T_KEYWORD) != 0) ? ((is_symbol(obj)) ? " keyword" : - ((is_pair(obj)) ? " fx-treeable" : - " ?31?")) : "", - /* bit 32+24 */ - ((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) ? ((is_t_vector(obj)) ? " simple-elements" : - ((is_hash_table(obj)) ? " simple-keys" : - ((is_normal_symbol(obj)) ? " safe-setter" : - ((is_pair(obj)) ? " float-optable" : - ((typ >= T_C_MACRO) ? " function-simple-elements" : - " 32?"))))) : "", - /* bit 33+24 */ - ((full_typ & T_FULL_CASE_KEY) != 0) ? ((is_symbol(obj)) ? " case-key" : - ((is_pair(obj)) ? " opt1-func-listed" : - " ?33?")) : "", - /* bit 34+24 free */ - /* bit 35+24 */ - ((full_typ & T_FULL_UNKNOPT) != 0) ? ((is_pair(obj)) ? " unknopt" : " ?35?") : "", - /* bit 36+24 */ - ((full_typ & T_FULL_SAFETY_CHECKED) != 0) ? ((is_pair(obj)) ? " safety-checked" : " ?36?") : "", - /* bit 37+24 */ - ((full_typ & T_FULL_HAS_FN) != 0) ? ((is_pair(obj)) ? " has-fn" : " ?37") : "", - /* bit 62 */ - ((full_typ & T_UNHEAP) != 0) ? " unheap" : "", - /* bit 63 */ - ((full_typ & T_GC_MARK) != 0) ? " gc-marked" : "", - - ((full_typ & UNUSED_BITS) != 0) ? " unused bits set?" : "", - ((is_symbol(obj)) && (((uint8_t)(symbol_type(obj) & 0xff) >= NUM_TYPES) || ((symbol_type(obj) & ~0xffff) != 0))) ? " bad-symbol-type" : "", - NULL); + catstrs(str, 900, /* if debugging, all of these bits are being watched, so we need to access them directly */ + /* bit 8 (the first 8 bits (after the 8 type bits) are easy...) */ + ((full_typ & T_MULTIFORM) != 0) ? ((is_any_closure(obj)) ? + (((full_typ & T_ONE_FORM) != 0) ? " closure-one-form-has-fx" : " closure-multiform") : + " ?0?") : "", + /* bit 9 */ + ((full_typ & T_SYNTACTIC) != 0) ? (((is_pair(obj)) || (is_syntax(obj)) || (is_normal_symbol(obj))) ? + " syntactic" : + " ?1?") : "", + /* bit 10 */ + ((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) ? ((is_pair(obj)) ? " simple-args|in-use" : + ((is_any_closure(obj)) ? " closure-one-form" : + " ?2?")) : "", + /* bit 11 */ + ((full_typ & T_OPTIMIZED) != 0) ? ((is_c_function(obj)) ? " scope-safe" : + ((is_pair(obj)) ? " optimized" : + " ?3?")) : "", + /* bit 12 */ + ((full_typ & T_SAFE_CLOSURE) != 0) ? (((has_closure_let(obj)) || (is_pair(obj))) ? " safe-closure" : " ?4?") : "", + /* bit 13 */ + ((full_typ & T_DONT_EVAL_ARGS) != 0) ? (((is_any_macro(obj)) || (is_syntax(obj))) ? " dont-eval-args" : " ?5?") : "", + /* bit 14 */ + ((full_typ & T_EXPANSION) != 0) ? (((is_normal_symbol(obj)) || (is_either_macro(obj))) ? " expansion" : " ?6?") : "", + /* bit 15 */ + ((full_typ & T_MULTIPLE_VALUE) != 0) ? ((is_symbol(obj)) ? " matched" : + ((is_pair(obj)) ? " values|matched" : + " ?7?")) : "", + /* bit 16 */ + ((full_typ & T_GLOBAL) != 0) ? ((is_pair(obj)) ? " unsafe-do" : + (((is_symbol(obj)) || (is_syntax(obj))) ? " global" : + ((is_let(obj)) ? " dox_slot1" : + " ?8?"))) : "", + /* bit 17 */ + ((full_typ & T_COLLECTED) != 0) ? " collected" : "", + /* bit 18 */ + ((full_typ & T_LOCATION) != 0) ? ((is_pair(obj)) ? " line-number" : + ((is_input_port(obj)) ? " loader-port" : + ((is_let(obj)) ? " with-let" : + ((is_any_procedure(obj)) ? " simple-defaults" : + ((is_slot(obj)) ? " has-setter" : + " ?10?"))))) : "", + /* bit 19 */ + ((full_typ & T_SHARED) != 0) ? ((is_sequence(obj)) ? " shared" : " ?11?") : "", + /* bit 20 */ + ((full_typ & T_LOCAL) != 0) ? ((is_normal_symbol(obj)) ? " local" : + ((is_pair(obj)) ? " high-c" : + " ?12?")) : "", + /* bit 21 */ + ((full_typ & T_SAFE_PROCEDURE) != 0) ? ((is_applicable(obj)) ? " safe-procedure" : " ?13?") : "", + /* bit 22 */ + ((full_typ & T_CHECKED) != 0) ? (((is_pair(obj)) || (is_slot(obj))) ? " checked" : + ((is_symbol(obj)) ? " all-integer" : + " ?14?")) : "", + /* bit 23 */ + ((full_typ & T_UNSAFE) != 0) ? ((is_symbol(obj)) ? " clean-symbol" : + ((is_slot(obj)) ? " has-stepper" : + ((is_pair(obj)) ? " unsafely-opt|no-float-opt" : + ((is_let(obj)) ? " dox-slot2" : + " ?15?")))) : "", + /* bit 24 */ + ((full_typ & T_IMMUTABLE) != 0) ? " immutable" : "", + /* bit 25 */ + ((full_typ & T_SETTER) != 0) ? ((is_normal_symbol(obj)) ? " setter" : + ((is_pair(obj)) ? " allow-other-keys|no-int-opt" : + ((is_slot(obj)) ? " has-expression" : + ((is_c_function_star(obj)) ? " allow-other-keys" : + ((is_let(obj)) ? " let-removed-from-heap" : + " ?17?"))))) : "", + /* bit 26 */ + ((full_typ & T_MUTABLE) != 0) ? ((is_number(obj)) ? " mutable" : + ((is_symbol(obj)) ? " has-keyword" : + ((is_let(obj)) ? " ref-fallback" : + ((is_iterator(obj)) ? " mark-sequence" : + ((is_slot(obj)) ? " step-end" : + ((is_pair(obj)) ? " no-opt" : + " ?18?")))))) : "", + /* bit 27 */ + ((full_typ & T_SAFE_STEPPER) != 0) ? ((is_let(obj)) ? " set-fallback" : + ((is_slot(obj)) ? " safe-stepper" : + ((is_c_function(obj)) ? " maybe-safe" : + ((is_number(obj)) ? " print-name" : + ((is_pair(obj)) ? " direct-opt" : + ((is_hash_table(obj)) ? " weak-hash" : + ((is_any_macro(obj)) ? " pair-macro-set" : + ((is_symbol(obj)) ? " all-float" : + " ?19?")))))))) : "", + /* bit 28, for c_function case see sc->apply */ + ((full_typ & T_COPY_ARGS) != 0) ? (((is_pair(obj)) || (is_any_macro(obj)) || (is_syntax(obj)) || + (is_any_closure(obj)) || (is_c_function(obj))) ? " copy-args" : + " ?20?") : "", + /* bit 29 */ + ((full_typ & T_GENSYM) != 0) ? ((is_let(obj)) ? " funclet" : + ((is_normal_symbol(obj)) ? " gensym" : + ((is_string(obj)) ? " documented-symbol" : + ((is_hash_table(obj)) ? " hash-chosen" : + ((is_pair(obj)) ? " fx-treed" : + ((is_any_vector(obj)) ? " subvector" : + ((is_slot(obj)) ? " has-pending-value" : + ((is_any_closure(obj)) ? " unknopt" : + " ?21?")))))))) : "", + /* bit 30 [pair and symbol free here] */ + ((full_typ & T_HAS_METHODS) != 0) ? (((is_let(obj)) || (is_c_object(obj)) || (is_any_closure(obj)) || + (is_any_macro(obj)) || (is_c_pointer(obj))) ? " has-methods" : + " ?22?") : "", + /* bit 31 */ + ((full_typ & T_ITER_OK) != 0) ? ((is_iterator(obj)) ? " iter-ok" : + ((is_pair(obj)) ? " loop-end-possible" : + ((is_slot(obj)) ? " in-rootlet" : + ((is_c_function(obj)) ? " bool-function" : + ((is_symbol(obj)) ? " symbol-from-symbol" : + " ?23?"))))) : "", + /* bit 24+24 */ + ((full_typ & T_FULL_SYMCONS) != 0) ? ((is_symbol(obj)) ? " possibly-constant" : + ((is_any_procedure(obj)) ? " has-let-arg" : + ((is_hash_table(obj)) ? " has-value-type" : + ((is_pair(obj)) ? " int-optable" : + ((is_let(obj)) ? " unlet" : + ((is_t_vector(obj)) ? " symbol-table" : + " ?24?")))))) : "", + /* bit 25+24 */ + ((full_typ & T_FULL_HAS_LET_FILE) != 0) ? ((is_let(obj)) ? " has-let-file" : + ((is_t_vector(obj)) ? " typed-vector" : + ((is_hash_table(obj)) ? " typed-hash-table" : + ((is_c_function(obj)) ? " has-bool-setter" : + ((is_slot(obj)) ? " rest-slot" : + (((is_pair(obj)) || (is_closure_star(obj))) ? " no-defaults" : + " ?25?")))))) : "", + /* bit 26+24 */ + ((full_typ & T_FULL_DEFINER) != 0) ? ((is_normal_symbol(obj)) ? " definer" : + ((is_pair(obj)) ? " has-fx" : + ((is_slot(obj)) ? " slot-defaults" : + ((is_iterator(obj)) ? " weak-hash-iterator" : + ((is_hash_table(obj)) ? " has-key-type" : + ((is_let(obj)) ? " maclet" : + ((is_c_function(obj)) ? " func-definer" : + ((is_syntax(obj)) ? " syntax-definer" : + " ?26?")))))))) : "", + /* bit 27+24 */ + ((full_typ & T_FULL_BINDER) != 0) ? ((is_pair(obj)) ? " tree-collected" : + ((is_hash_table(obj)) ? " simple-values" : + ((is_normal_symbol(obj)) ? " binder" : + ((is_c_function(obj)) ? " safe-args" : + ((is_syntax(obj)) ? " syntax-binder" : + " ?27?"))))) : "", + /* bit 28+24 */ + ((full_typ & T_VERY_SAFE_CLOSURE) != 0) ? (((is_pair(obj)) || (is_any_closure(obj))) ? " very-safe-closure" : + ((is_let(obj)) ? " baffle-let" : + " ?28?")) : "", + /* bit 29+24 */ + ((full_typ & T_CYCLIC) != 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) || + (is_any_closure(obj))) ? " cyclic" : " ?29?") : "", + /* bit 30+24 */ + ((full_typ & T_CYCLIC_SET) != 0) ? (((is_simple_sequence(obj)) || (t_structure_p[type(obj)]) || + (is_any_closure(obj))) ? " cyclic-set" : " ?30?") : "", + /* bit 31+24 */ + ((full_typ & T_KEYWORD) != 0) ? ((is_symbol(obj)) ? " keyword" : + ((is_pair(obj)) ? " fx-treeable" : + " ?31?")) : "", + /* bit 32+24 */ + ((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) ? ((is_t_vector(obj)) ? " simple-elements" : + ((is_hash_table(obj)) ? " simple-keys" : + ((is_normal_symbol(obj)) ? " safe-setter" : + ((is_pair(obj)) ? " float-optable" : + ((typ >= T_C_MACRO) ? " function-simple-elements" : + " 32?"))))) : "", + /* bit 33+24 */ + ((full_typ & T_FULL_CASE_KEY) != 0) ? ((is_symbol(obj)) ? " case-key" : + ((is_pair(obj)) ? " opt1-func-listed" : + " ?33?")) : "", + /* bit 34+24 free */ + /* bit 35+24 */ + ((full_typ & T_FULL_UNKNOPT) != 0) ? ((is_pair(obj)) ? " unknopt" : " ?35?") : "", + /* bit 36+24 */ + ((full_typ & T_FULL_SAFETY_CHECKED) != 0) ? ((is_pair(obj)) ? " safety-checked" : " ?36?") : "", + /* bit 37+24 */ + ((full_typ & T_FULL_HAS_FN) != 0) ? ((is_pair(obj)) ? " has-fn" : " ?37") : "", + /* bit 62 */ + ((full_typ & T_UNHEAP) != 0) ? " unheap" : "", + /* bit 63 */ + ((full_typ & T_GC_MARK) != 0) ? " gc-marked" : "", + + ((full_typ & UNUSED_BITS) != 0) ? " unused bits set?" : "", + ((is_symbol(obj)) && (((uint8_t)(symbol_type(obj) & 0xff) >= NUM_TYPES) || ((symbol_type(obj) & ~0xffff) != 0))) ? " bad-symbol-type" : "", + NULL); buf = (char *)Malloc(1024); snprintf(buf, 1024, "type: %s? (%d), opt_op: %d %s, flags: #x%" PRIx64 "%s", - type_name(sc, obj, NO_ARTICLE), typ, - unchecked_optimize_op(obj), (unchecked_optimize_op(obj) < NUM_OPS) ? op_names[unchecked_optimize_op(obj)] : "", full_typ, - str); + type_name(sc, obj, NO_ARTICLE), typ, + unchecked_optimize_op(obj), (unchecked_optimize_op(obj) < NUM_OPS) ? op_names[unchecked_optimize_op(obj)] : "", full_typ, + str); return(buf); } @@ -5019,9 +5019,9 @@ static bool has_odd_bits(s7_pointer obj) if (is_symbol(obj)) { if ((uint8_t)(symbol_type(obj) & 0xff) >= NUM_TYPES) - return(true); + return(true); if ((symbol_type(obj) & ~0xffff) != 0) /* boolean function bool type and *s7*_let field id */ - return(true); + return(true); } if ((signed_type(obj) == 0) && ((full_typ & T_GC_MARK) != 0)) return(true); @@ -5040,16 +5040,16 @@ void s7_show_let(s7_scheme *sc) /* debugging convenience */ for (s7_pointer olet = sc->curlet; olet; olet = let_outlet(olet)) { if (olet == sc->owlet) - fprintf(stderr, "(owlet): "); + fprintf(stderr, "(owlet): "); else - if (olet == sc->rootlet) - fprintf(stderr, "(rootlet): "); - else - if (is_funclet(olet)) - fprintf(stderr, "(%s funclet): ", display(funclet_function(olet))); - else - if (olet == sc->shadow_rootlet) - fprintf(stderr, "(shadow rootlet): "); + if (olet == sc->rootlet) + fprintf(stderr, "(rootlet): "); + else + if (is_funclet(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)); } } @@ -5091,46 +5091,46 @@ static char* show_debugger_bits(s7_pointer p) char *bits_str = (char *)Malloc(512); int64_t bits = p->debugger_bits; snprintf(bits_str, 512, " %s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s%s", - ((bits & OPT1_SET) != 0) ? " opt1_set" : "", - ((bits & OPT1_FAST) != 0) ? " opt1_fast" : "", - ((bits & OPT1_CFUNC) != 0) ? " opt1_cfunc" : "", - ((bits & OPT1_CLAUSE) != 0) ? " opt1_clause" : "", - ((bits & OPT1_LAMBDA) != 0) ? " opt1_lambda" : "", - ((bits & OPT1_SYM) != 0) ? " opt1_sym" : "", - ((bits & OPT1_PAIR) != 0) ? " opt1_pair" : "", - ((bits & OPT1_CON) != 0) ? " opt1_con" : "", - ((bits & OPT1_ANY) != 0) ? " opt1_any" : "", - ((bits & OPT1_HASH) != 0) ? " opt1_hash" : "", - - ((bits & OPT2_SET) != 0) ? " opt2_set" : "", - ((bits & OPT2_KEY) != 0) ? " opt2_any" : "", - ((bits & OPT2_SLOW) != 0) ? " opt2_slow" : "", - ((bits & OPT2_SYM) != 0) ? " opt2_sym" : "", - ((bits & OPT2_PAIR) != 0) ? " opt2_pair" : "", - ((bits & OPT2_CON) != 0) ? " opt2_con" : "", - ((bits & OPT2_FX) != 0) ? " opt2_fx" : "", - ((bits & OPT2_FN) != 0) ? " opt2_fn" : "", - ((bits & OPT2_LAMBDA) != 0) ? " opt2_lambda" : "", - ((bits & OPT2_DIRECT) != 0) ? " opt2_direct" : "", - ((bits & OPT2_NAME) != 0) ? " opt2_raw_name" : "", - ((bits & OPT2_INT) != 0) ? " opt2_int" : "", - - ((bits & OPT3_SET) != 0) ? " opt3_set" : "", - ((bits & OPT3_ARGLEN) != 0) ? " opt3_arglen" : "", - ((bits & OPT3_SYM) != 0) ? " opt3_sym" : "", - ((bits & OPT3_CON) != 0) ? " opt3_con" : "", - ((bits & OPT3_AND) != 0) ? " opt3_pair " : "", - ((bits & OPT3_ANY) != 0) ? " opt3_any " : "", - ((bits & OPT3_LET) != 0) ? " opt3_let " : "", - ((bits & OPT3_BYTE) != 0) ? " opt3_byte " : "", - ((bits & OPT3_DIRECT) != 0) ? " opt3_direct" : "", - ((bits & OPT3_LOCATION) != 0) ? " opt3_location" : "", - ((bits & OPT3_LEN) != 0) ? " opt3_len" : "", - ((bits & OPT3_INT) != 0) ? " opt3_int" : "", - - ((bits & L_HIT) != 0) ? " let_set" : "", - ((bits & L_FUNC) != 0) ? " let_func" : "", - ((bits & L_DOX) != 0) ? " let_dox" : ""); + ((bits & OPT1_SET) != 0) ? " opt1_set" : "", + ((bits & OPT1_FAST) != 0) ? " opt1_fast" : "", + ((bits & OPT1_CFUNC) != 0) ? " opt1_cfunc" : "", + ((bits & OPT1_CLAUSE) != 0) ? " opt1_clause" : "", + ((bits & OPT1_LAMBDA) != 0) ? " opt1_lambda" : "", + ((bits & OPT1_SYM) != 0) ? " opt1_sym" : "", + ((bits & OPT1_PAIR) != 0) ? " opt1_pair" : "", + ((bits & OPT1_CON) != 0) ? " opt1_con" : "", + ((bits & OPT1_ANY) != 0) ? " opt1_any" : "", + ((bits & OPT1_HASH) != 0) ? " opt1_hash" : "", + + ((bits & OPT2_SET) != 0) ? " opt2_set" : "", + ((bits & OPT2_KEY) != 0) ? " opt2_any" : "", + ((bits & OPT2_SLOW) != 0) ? " opt2_slow" : "", + ((bits & OPT2_SYM) != 0) ? " opt2_sym" : "", + ((bits & OPT2_PAIR) != 0) ? " opt2_pair" : "", + ((bits & OPT2_CON) != 0) ? " opt2_con" : "", + ((bits & OPT2_FX) != 0) ? " opt2_fx" : "", + ((bits & OPT2_FN) != 0) ? " opt2_fn" : "", + ((bits & OPT2_LAMBDA) != 0) ? " opt2_lambda" : "", + ((bits & OPT2_DIRECT) != 0) ? " opt2_direct" : "", + ((bits & OPT2_NAME) != 0) ? " opt2_raw_name" : "", + ((bits & OPT2_INT) != 0) ? " opt2_int" : "", + + ((bits & OPT3_SET) != 0) ? " opt3_set" : "", + ((bits & OPT3_ARGLEN) != 0) ? " opt3_arglen" : "", + ((bits & OPT3_SYM) != 0) ? " opt3_sym" : "", + ((bits & OPT3_CON) != 0) ? " opt3_con" : "", + ((bits & OPT3_AND) != 0) ? " opt3_pair " : "", + ((bits & OPT3_ANY) != 0) ? " opt3_any " : "", + ((bits & OPT3_LET) != 0) ? " opt3_let " : "", + ((bits & OPT3_BYTE) != 0) ? " opt3_byte " : "", + ((bits & OPT3_DIRECT) != 0) ? " opt3_direct" : "", + ((bits & OPT3_LOCATION) != 0) ? " opt3_location" : "", + ((bits & OPT3_LEN) != 0) ? " opt3_len" : "", + ((bits & OPT3_INT) != 0) ? " opt3_int" : "", + + ((bits & L_HIT) != 0) ? " let_set" : "", + ((bits & L_FUNC) != 0) ? " let_func" : "", + ((bits & L_DOX) != 0) ? " let_dox" : ""); return(bits_str); } @@ -5145,22 +5145,22 @@ static s7_pointer check_ref_one(s7_pointer p, uint8_t expected_type, const char { uint8_t typ = unchecked_type(p); if (typ != expected_type) - { - if ((!func1) || (typ != T_FREE)) - { - fprintf(stderr, "%s%s[%d]: not %s, but %s (%s)%s\n", - bold_text, - func, line, checked_type_name(cur_sc, expected_type), checked_type_name(cur_sc, typ), object_raw_type_to_string(p), - unbold_text); - if (cur_sc->stop_at_error) abort(); - } - else - if ((strcmp(func, func1) != 0) && - ((!func2) || (strcmp(func, func2) != 0))) - { - fprintf(stderr, "%s%s[%d]: free cell, not %s%s\n", bold_text, func, line, checked_type_name(cur_sc, expected_type), unbold_text); - if (cur_sc->stop_at_error) abort(); - }}} + { + if ((!func1) || (typ != T_FREE)) + { + fprintf(stderr, "%s%s[%d]: not %s, but %s (%s)%s\n", + bold_text, + func, line, checked_type_name(cur_sc, expected_type), checked_type_name(cur_sc, typ), object_raw_type_to_string(p), + unbold_text); + if (cur_sc->stop_at_error) abort(); + } + else + if ((strcmp(func, func1) != 0) && + ((!func2) || (strcmp(func, func2) != 0))) + { + fprintf(stderr, "%s%s[%d]: free cell, not %s%s\n", bold_text, func, line, checked_type_name(cur_sc, expected_type), unbold_text); + if (cur_sc->stop_at_error) abort(); + }}} return(p); } @@ -5199,7 +5199,7 @@ static s7_pointer check_ref_two(s7_pointer p, uint8_t expected_type, int32_t oth { uint8_t typ = unchecked_type(p); if ((typ != expected_type) && (typ != other_type)) - return(check_ref_one(p, expected_type, func, line, func1, func2)); + return(check_ref_one(p, expected_type, func, line, func1, func2)); } return(p); } @@ -5336,22 +5336,22 @@ static void print_gc_info(s7_scheme *sc, s7_pointer obj, const char *func, int32 fprintf(stderr, "%s from %s[%d]: %p type is %d?\n", __func__, func, line, obj, unchecked_type(obj)); else { - s7_int free_type = full_type(obj); - char *bits; - char fline[128]; - full_type(obj) = obj->alloc_type; /* not set_full_type here! it clobbers existing alloc/free info */ - sc->printing_gc_info = true; - bits = describe_type_bits(sc, obj); /* this func called in type macro */ - sc->printing_gc_info = false; - full_type(obj) = free_type; - if (obj->explicit_free_line > 0) - snprintf(fline, 128, ", freed at %d, ", obj->explicit_free_line); - fprintf(stderr, "%s%p is free (%s[%d], alloc type: %s %" ld64 " #x%" PRIx64 " (%s)), alloc: %s[%d], %sgc: %s[%d], gc: %d%s", - bold_text, obj, func, line, s7_type_names[obj->alloc_type & 0xff], obj->alloc_type, obj->alloc_type, - bits, obj->alloc_func, obj->alloc_line, - (obj->explicit_free_line > 0) ? fline : "", obj->gc_func, obj->gc_line, obj->uses, unbold_text); - fprintf(stderr, "\n"); - free(bits); + s7_int free_type = full_type(obj); + char *bits; + char fline[128]; + full_type(obj) = obj->alloc_type; /* not set_full_type here! it clobbers existing alloc/free info */ + sc->printing_gc_info = true; + bits = describe_type_bits(sc, obj); /* this func called in type macro */ + sc->printing_gc_info = false; + full_type(obj) = free_type; + if (obj->explicit_free_line > 0) + snprintf(fline, 128, ", freed at %d, ", obj->explicit_free_line); + fprintf(stderr, "%s%p is free (%s[%d], alloc type: %s %" ld64 " #x%" PRIx64 " (%s)), alloc: %s[%d], %sgc: %s[%d], gc: %d%s", + bold_text, obj, func, line, s7_type_names[obj->alloc_type & 0xff], obj->alloc_type, obj->alloc_type, + bits, obj->alloc_func, obj->alloc_line, + (obj->explicit_free_line > 0) ? fline : "", obj->gc_func, obj->gc_line, obj->uses, unbold_text); + fprintf(stderr, "\n"); + free(bits); } if (sc->stop_at_error) abort(); } @@ -5366,8 +5366,8 @@ static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line) else if (unchecked_type(p) >= NUM_TYPES) { - fprintf(stderr, "%s%s[%d]: attempt to use messed up cell (type: %d)%s\n", bold_text, func, line, unchecked_type(p), unbold_text); - if (cur_sc->stop_at_error) abort(); + fprintf(stderr, "%s%s[%d]: attempt to use messed up cell (type: %d)%s\n", bold_text, func, line, unchecked_type(p), unbold_text); + if (cur_sc->stop_at_error) abort(); } if (unchecked_type(p) == T_FREE) { @@ -5407,15 +5407,15 @@ static s7_pointer check_ref_key(s7_pointer p, const char *func, int32_t line) if (strcmp(func, "new_symbol") != 0) { if (global_value(p) != p) - { - fprintf(stderr, "%s%s[%d]: keyword %s value is not itself (type: %s)%s\n", - bold_text, func, line, display(p), s7_type_names[unchecked_type(global_value(p))], unbold_text); - if (cur_sc->stop_at_error) abort(); - } + { + fprintf(stderr, "%s%s[%d]: keyword %s value is not itself (type: %s)%s\n", + bold_text, func, line, display(p), s7_type_names[unchecked_type(global_value(p))], unbold_text); + if (cur_sc->stop_at_error) abort(); + } if (in_heap(keyword_symbol_unchecked(p))) - fprintf(stderr, "%s%s[%d]: keyword %s symbol is in the heap%s\n", bold_text, func, line, display(p), unbold_text); + fprintf(stderr, "%s%s[%d]: keyword %s symbol is in the heap%s\n", bold_text, func, line, display(p), unbold_text); if (has_odd_bits(p)) - {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(cur_sc, p)); free(s);} + {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(cur_sc, p)); free(s);} } return(p); } @@ -5511,8 +5511,8 @@ static void show_opt1_bits(s7_pointer p, const char *func, int32_t line, uint64_ { char *bits = show_debugger_bits(p); fprintf(stderr, "%s%s[%d]%s: opt1: %p->%p wants %s, debugger bits are %" PRIx64 "%s but expects %" ld64, - bold_text, func, line, unbold_text, - p, p->object.cons.opt1, opt1_role_name(role), p->debugger_bits, bits, (s7_int)role); + bold_text, func, line, unbold_text, + p, p->object.cons.opt1, opt1_role_name(role), p->debugger_bits, bits, (s7_int)role); free(bits); } @@ -5540,9 +5540,9 @@ static s7_pointer set_opt1_1(s7_pointer p, s7_pointer x, uint64_t role, const ch ((p->debugger_bits & OPT1_MASK) == OPT1_LAMBDA) && (role != OPT1_CFUNC)) fprintf(stderr, "%s[%d]: opt1_lambda -> %s, op: %s, x: %s,\n %s\n", - func, line, opt1_role_name(role), - (is_optimized(x)) ? op_names[optimize_op(x)] : "unopt", - display(x), display(p)); + func, line, opt1_role_name(role), + (is_optimized(x)) ? op_names[optimize_op(x)] : "unopt", + display(x), display(p)); p->object.cons.opt1 = x; base_opt1(p, role); return(x); @@ -5568,24 +5568,24 @@ static void show_opt2_bits(s7_pointer p, const char *func, int32_t line, uint64_ { char *bits = show_debugger_bits(p); fprintf(stderr, "%s%s[%d]%s: %s opt2: %p->%p wants %s, debugger bits are %" PRIx64 "%s but expects %" ld64 " %s", - bold_text, func, line, unbold_text, - display(p), p, p->object.cons.o2.opt2, opt2_role_name(role), p->debugger_bits, bits, (s7_int)role, opt2_role_name(role)); + bold_text, func, line, unbold_text, + display(p), p, p->object.cons.o2.opt2, opt2_role_name(role), p->debugger_bits, bits, (s7_int)role, opt2_role_name(role)); free(bits); } static bool f_call_func_mismatch(const char *func) { return((!safe_strcmp(func, "check_and")) && /* these reflect set_fx|unchecked where the destination checks for null fx_proc */ - (!safe_strcmp(func, "check_or")) && - (!safe_strcmp(func, "eval")) && - (!safe_strcmp(func, "set_any_c_np")) && - (!safe_strcmp(func, "set_any_closure_np")) && - (!safe_strcmp(func, "optimize_func_two_args")) && - (!safe_strcmp(func, "optimize_func_many_args")) && - (!safe_strcmp(func, "optimize_func_three_args")) && - (!safe_strcmp(func, "fx_c_ff")) && - (!safe_strcmp(func, "op_map_for_each_fa")) && - (!safe_strcmp(func, "op_map_for_each_faa"))); + (!safe_strcmp(func, "check_or")) && + (!safe_strcmp(func, "eval")) && + (!safe_strcmp(func, "set_any_c_np")) && + (!safe_strcmp(func, "set_any_closure_np")) && + (!safe_strcmp(func, "optimize_func_two_args")) && + (!safe_strcmp(func, "optimize_func_many_args")) && + (!safe_strcmp(func, "optimize_func_three_args")) && + (!safe_strcmp(func, "fx_c_ff")) && + (!safe_strcmp(func, "op_map_for_each_fa")) && + (!safe_strcmp(func, "op_map_for_each_faa"))); } static void check_opt2_bits(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line) @@ -5627,10 +5627,10 @@ static void set_opt2_1(s7_scheme *sc, s7_pointer p, s7_pointer x, uint64_t role, (x == NULL) && (f_call_func_mismatch(func))) fprintf(stderr, "%s[%d]: set fx_proc for %s to null (%s%s%s)\n", func, line, - string_value(object_to_string_truncated(sc, p)), - ((is_h_optimized(car(p))) && (is_safe_c_op(optimize_op(car(p))))) ? bold_text : "", - op_names[optimize_op(car(p))], - ((is_h_optimized(car(p))) && (is_safe_c_op(optimize_op(car(p))))) ? unbold_text : ""); + string_value(object_to_string_truncated(sc, p)), + ((is_h_optimized(car(p))) && (is_safe_c_op(optimize_op(car(p))))) ? bold_text : "", + op_names[optimize_op(car(p))], + ((is_h_optimized(car(p))) && (is_safe_c_op(optimize_op(car(p))))) ? unbold_text : ""); if ((role != OPT2_FX) && (role != OPT2_DIRECT) && (has_fx(p))) /* sometimes opt2_direct just specializes fx */ { fprintf(stderr, "%s[%d]: overwrite has_fx: %s %s\n", func, line, opt2_role_name(role), display_truncated(p)); @@ -5787,8 +5787,8 @@ static void print_debugging_state(s7_scheme *sc, s7_pointer obj, s7_pointer port b = mallocate(sc, len); str = (char *)block_data(b); nlen = snprintf(str, len, - "\n<%s %s,\n alloc: %s[%d] %s, %d uses>", excl_name, current_bits, - obj->alloc_func, obj->alloc_line, allocated_bits, obj->uses); + "\n<%s %s,\n alloc: %s[%d] %s, %d uses>", excl_name, current_bits, + obj->alloc_func, obj->alloc_line, allocated_bits, obj->uses); free(current_bits); free(allocated_bits); if (is_null(port)) @@ -5979,7 +5979,7 @@ static const char *make_type_name(s7_scheme *sc, const char *name, article_t art i = 1; sc->typnam[0] = 'a'; if ((name[0] == 'a') || (name[0] == 'e') || (name[0] == 'i') || (name[0] == 'o') || (name[0] == 'u')) - sc->typnam[i++] = 'n'; + sc->typnam[i++] = 'n'; sc->typnam[i++] = ' '; } else i = 0; @@ -6059,8 +6059,8 @@ static s7_pointer find_let(s7_scheme *sc, s7_pointer obj) return(c_object_let(obj)); case T_C_POINTER: if ((is_let(c_pointer_info(obj))) && - (c_pointer_info(obj) != sc->rootlet)) - return(c_pointer_info(obj)); + (c_pointer_info(obj) != sc->rootlet)) + return(c_pointer_info(obj)); case T_CONTINUATION: case T_GOTO: case T_C_MACRO: case T_C_FUNCTION_STAR: case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: return(sc->rootlet); @@ -6101,15 +6101,15 @@ static const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article) case T_OUTPUT_PORT: return(make_type_name(sc, (is_file_port(arg)) ? "output file port" : ((is_string_port(arg)) ? "output string port" : "output port"), article)); case T_LET: if (has_active_methods(sc, arg)) - { - s7_pointer class_name = find_method(sc, arg, sc->class_name_symbol); - if (is_symbol(class_name)) - return(make_type_name(sc, symbol_name(class_name), article)); - } + { + s7_pointer class_name = find_method(sc, arg, sc->class_name_symbol); + if (is_symbol(class_name)) + return(make_type_name(sc, symbol_name(class_name), article)); + } default: { - const char *str = type_name_from_type(unchecked_type(arg), article); - if (str) return(str); + const char *str = type_name_from_type(unchecked_type(arg), article); + if (str) return(str); }} return("messed up object"); } @@ -6120,7 +6120,7 @@ static s7_pointer object_type_name(s7_scheme *sc, s7_pointer x) if (has_active_methods(sc, x)) { s7_pointer p = find_method_with_let(sc, x, sc->class_name_symbol); - if (is_symbol(p)) return(symbol_name_cell(p)); + if (is_symbol(p)) return(symbol_name_cell(p)); } typ = type(x); if (typ < NUM_TYPES) @@ -6191,11 +6191,11 @@ s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, s7_int arg_n if (arg_n > 0) { set_wlist_4(cdr(sc->out_of_range_info), wrap_string(sc, caller, safe_strlen(caller)), - wrap_integer(sc, arg_n), arg, wrap_string(sc, descr, safe_strlen(descr))); + wrap_integer(sc, arg_n), arg, wrap_string(sc, descr, safe_strlen(descr))); error_nr(sc, sc->out_of_range_symbol, sc->out_of_range_info); } set_wlist_3(cdr(sc->sole_arg_out_of_range_info), wrap_string(sc, caller, safe_strlen(caller)), - arg, wrap_string(sc, descr, safe_strlen(descr))); + arg, wrap_string(sc, descr, safe_strlen(descr))); error_nr(sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info); return(sc->out_of_range_symbol); } @@ -6208,7 +6208,7 @@ static noreturn void wrong_number_of_arguments_error_nr(s7_scheme *sc, const cha s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args) { error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_2(sc, wrap_string(sc, caller, safe_strlen(caller)), args)); /* "caller" includes the format directives */ + set_elist_2(sc, wrap_string(sc, caller, safe_strlen(caller)), args)); /* "caller" includes the format directives */ return(sc->wrong_number_of_args_symbol); } @@ -6241,11 +6241,11 @@ static s7_pointer missing_method_class_name(s7_scheme *sc, s7_pointer obj) static noreturn void missing_method_error_nr(s7_scheme *sc, s7_pointer method, s7_pointer obj) { error_nr(sc, sc->missing_method_symbol, - set_elist_4(sc, wrap_string(sc, "~S method is not defined in ~A ~A", 33), method, - (is_c_object(obj)) ? c_object_scheme_name(sc, obj) : + set_elist_4(sc, wrap_string(sc, "~S method is not defined in ~A ~A", 33), method, + (is_c_object(obj)) ? c_object_scheme_name(sc, obj) : (((is_let(obj)) && (is_openlet(obj))) ? missing_method_class_name(sc, obj) : s7_make_string_wrapper(sc, type_name(sc, obj, NO_ARTICLE))), - object_to_string_truncated(sc, obj))); + object_to_string_truncated(sc, obj))); } static noreturn void immutable_object_error_nr(s7_scheme *sc, s7_pointer info) {error_nr(sc, sc->immutable_error_symbol, info);} @@ -6259,11 +6259,11 @@ s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method) } /* if a method is shadowing a built-in like abs, it should expect the same args as abs and behave the same -- no multiple values etc */ -#define check_method(Sc, Obj, Method, Args) \ - { \ - s7_pointer func; \ - if ((has_active_methods(Sc, Obj)) && \ - ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \ +#define check_method(Sc, Obj, Method, Args) \ + { \ + s7_pointer func; \ + if ((has_active_methods(Sc, Obj)) && \ + ((func = find_method_with_let(Sc, Obj, Method)) != Sc->undefined)) \ return(s7_apply_function(Sc, func, Args)); \ } @@ -6275,12 +6275,12 @@ static s7_pointer apply_boolean_method(s7_scheme *sc, s7_pointer obj, s7_pointer } /* this is a macro mainly to simplify the Checker handling */ -#define check_boolean_method(Sc, Checker, Method, Args) \ - { \ - s7_pointer p = car(Args); \ - if (Checker(p)) return(Sc->T); \ - if (!has_active_methods(Sc, p)) return(Sc->F); \ - return(apply_boolean_method(Sc, p, Method)); \ +#define check_boolean_method(Sc, Checker, Method, Args) \ + { \ + s7_pointer p = car(Args); \ + if (Checker(p)) return(Sc->T); \ + if (!has_active_methods(Sc, p)) return(Sc->F); \ + return(apply_boolean_method(Sc, p, Method)); \ } static s7_pointer apply_method_closure(s7_scheme *sc, s7_pointer func, s7_pointer args); @@ -6310,7 +6310,7 @@ static s7_pointer mutable_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_point } static s7_pointer mutable_method_or_bust_ppp(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer typ, int32_t num) + s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer typ, int32_t num) { return(mutable_method_or_bust(sc, obj, method, set_qlist_3(sc, x1, x2, x3), typ, num)); /* was list_3, plist_3 not safe */ } @@ -6328,14 +6328,14 @@ static s7_pointer method_or_bust_pp(s7_scheme *sc, s7_pointer obj, s7_pointer me } static s7_pointer method_or_bust_ppp(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer typ, int32_t num) + s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer typ, int32_t num) { if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); return(find_and_apply_method(sc, obj, method, set_qlist_3(sc, x1, x2, x3))); /* was list_3, plist not safe */ } static s7_pointer method_or_bust_with_type_and_loc_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_pointer x2, s7_pointer typ, int32_t num) + s7_pointer x1, s7_pointer x2, s7_pointer typ, int32_t num) { int32_t loc = sc->error_argnum + num; sc->error_argnum = 0; @@ -6344,14 +6344,14 @@ static s7_pointer method_or_bust_with_type_and_loc_pp(s7_scheme *sc, s7_pointer } static s7_pointer method_or_bust_with_type_pi(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_int x2, s7_pointer typ, int32_t num) + s7_pointer x1, s7_int x2, s7_pointer typ, int32_t num) { if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, make_integer(sc, x2)))); } static s7_pointer method_or_bust_with_type_pf(s7_scheme *sc, s7_pointer obj, s7_pointer method, - s7_pointer x1, s7_double x2, s7_pointer typ, int32_t num) + s7_pointer x1, s7_double x2, s7_pointer typ, int32_t num) { if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, num, obj, typ); return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, make_real(sc, x2)))); @@ -6484,17 +6484,17 @@ static s7_pointer g_is_immutable(s7_scheme *sc, s7_pointer args) { if (is_keyword(p)) return(sc->T); if (is_pair(cdr(args))) - { - s7_pointer e = cadr(args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->is_immutable_symbol, 2, e, a_let_string); - if (e == sc->rootlet) - slot = global_slot(p); - else slot = lookup_slot_from((is_keyword(p)) ? keyword_symbol(p) : p, e); - } + { + s7_pointer e = cadr(args); + if (!is_let(e)) + wrong_type_error_nr(sc, sc->is_immutable_symbol, 2, e, a_let_string); + if (e == sc->rootlet) + slot = global_slot(p); + else slot = lookup_slot_from((is_keyword(p)) ? keyword_symbol(p) : p, e); + } else slot = s7_slot(sc, p); if (is_slot(slot)) /* might be #<undefined> */ - return(make_boolean(sc, is_immutable_slot(slot))); + return(make_boolean(sc, is_immutable_slot(slot))); } else if ((is_pair(cdr(args))) && (!is_let(cadr(args)))) /* (immutable? 1 2) */ @@ -6512,7 +6512,7 @@ s7_pointer s7_immutable(s7_pointer p) if (is_keyword(p)) return(p); slot = s7_slot(cur_sc, p); /* ouch! we need the s7_scheme* argument */ if (is_slot(slot)) - set_immutable_slot(slot); + set_immutable_slot(slot); /* symbol is not set immutable (as below) */ } else set_immutable(p); @@ -6527,19 +6527,19 @@ static s7_pointer g_immutable(s7_scheme *sc, s7_pointer args) if (is_symbol(p)) { if (is_pair(cdr(args))) - { - s7_pointer e = cadr(args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->immutable_symbol, 2, e, a_let_string); - slot = symbol_to_local_slot(sc, (is_keyword(p)) ? keyword_symbol(p) : p, e); /* different from immutable? */ - } + { + s7_pointer e = cadr(args); + if (!is_let(e)) + wrong_type_error_nr(sc, sc->immutable_symbol, 2, e, a_let_string); + slot = symbol_to_local_slot(sc, (is_keyword(p)) ? keyword_symbol(p) : p, e); /* different from immutable? */ + } else - { - if (is_keyword(p)) return(p); - slot = s7_slot(sc, p); - } + { + if (is_keyword(p)) return(p); + slot = s7_slot(sc, p); + } if (is_slot(slot)) - set_immutable_slot(slot); + set_immutable_slot(slot); return(p); /* symbol is not set immutable ? */ } if ((is_pair(cdr(args))) && (!is_let(cadr(args)))) /* (immutable! 1 2) */ @@ -6569,7 +6569,7 @@ static s7_int gc_protect_2(s7_scheme *sc, s7_pointer x, int32_t line) { already_warned = true; fprintf(stderr, "s7_gc_protect has protected more than 8192 values? (line: %d, code: %s, loc: %" ld64 ")\n", - line, string_value(s7_object_to_string(sc, current_code(sc), false)), loc); + line, string_value(s7_object_to_string(sc, current_code(sc), false)), loc); if ((S7_DEBUGGING) && (sc->stop_at_error)) abort(); } return(loc); @@ -6613,7 +6613,7 @@ void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc) if (loc < sc->protected_objects_size) { if (vector_element(sc->protected_objects, loc) != sc->unused) - sc->protected_objects_free_list[++sc->protected_objects_free_list_loc] = loc; + sc->protected_objects_free_list[++sc->protected_objects_free_list_loc] = loc; else if (S7_DEBUGGING) fprintf(stderr, "redundant gc_unprotect_at location %" ld64 "\n", loc); vector_element(sc->protected_objects, loc) = sc->unused; } @@ -6656,7 +6656,7 @@ static void process_iterator(s7_scheme *unused_sc, s7_pointer s1) s7_pointer h = iterator_sequence(s1); clear_weak_hash_iterator(s1); if (unchecked_type(h) == T_HASH_TABLE) - weak_hash_iters(h)--; + weak_hash_iters(h)--; } } @@ -6667,10 +6667,10 @@ static void process_multivector(s7_scheme *sc, s7_pointer s1) (info != sc->wrap_only)) { if (vector_elements_should_be_freed(info)) /* a kludge for foreign code convenience */ - { - free(any_vector_elements(s1)); - vector_elements_should_be_freed(info) = false; - } + { + free(any_vector_elements(s1)); + vector_elements_should_be_freed(info) = false; + } liberate(sc, info); vector_set_dimension_info(s1, NULL); } @@ -6710,15 +6710,15 @@ static void process_input_port(s7_scheme *sc, s7_pointer s1) if (!port_is_closed(s1)) { if (is_file_port(s1)) - { - if (port_file(s1)) - { - fclose(port_file(s1)); - port_file(s1) = NULL; - }} + { + if (port_file(s1)) + { + fclose(port_file(s1)); + port_file(s1) = NULL; + }} else - if (is_function_port(s1)) - close_input_function(sc, s1); + if (is_function_port(s1)) + close_input_function(sc, s1); } if (port_needs_free(s1)) free_port_data(sc, s1); @@ -6741,10 +6741,10 @@ static void process_output_port(s7_scheme *sc, s7_pointer s1) { port_needs_free(s1) = false; if (port_data_block(s1)) - { - liberate(sc, port_data_block(s1)); - port_data_block(s1) = NULL; - }} + { + liberate(sc, port_data_block(s1)); + port_data_block(s1) = NULL; + }} } static void process_continuation(s7_scheme *sc, s7_pointer s1) @@ -6820,20 +6820,20 @@ static void sweep(s7_scheme *sc) s7_int i, j; gc_list_t *gp; - #define process_gc_list(Code) \ - if (gp->loc > 0) \ - { \ - for (i = 0, j = 0; i < gp->loc; i++) \ - { \ - s7_pointer s1 = gp->list[i]; \ - if (is_free_and_clear(s1)) \ - { \ - Code; \ - } \ - else gp->list[j++] = s1; \ - } \ - gp->loc = j; \ - } \ + #define process_gc_list(Code) \ + if (gp->loc > 0) \ + { \ + for (i = 0, j = 0; i < gp->loc; i++) \ + { \ + s7_pointer s1 = gp->list[i]; \ + if (is_free_and_clear(s1)) \ + { \ + Code; \ + } \ + else gp->list[j++] = s1; \ + } \ + gp->loc = j; \ + } \ gp = sc->strings; process_gc_list(liberate(sc, string_block(s1))) @@ -6858,18 +6858,18 @@ static void sweep(s7_scheme *sc) if (gp->loc > 0) { for (i = 0, j = 0; i < gp->loc; i++) - { - s7_pointer s1 = gp->list[i]; - if (is_free_and_clear(s1)) - free_hash_table(sc, s1); - else - { - if ((is_weak_hash_table(s1)) && - (weak_hash_iters(s1) == 0) && - (hash_table_entries(s1) > 0)) - cull_weak_hash_table(sc, s1); - gp->list[j++] = s1; - }} + { + s7_pointer s1 = gp->list[i]; + if (is_free_and_clear(s1)) + free_hash_table(sc, s1); + else + { + if ((is_weak_hash_table(s1)) && + (weak_hash_iters(s1) == 0) && + (hash_table_entries(s1) > 0)) + cull_weak_hash_table(sc, s1); + gp->list[j++] = s1; + }} gp->loc = j; } @@ -6880,11 +6880,11 @@ static void sweep(s7_scheme *sc) if (gp->loc > 0) { for (i = 0, j = 0; i < gp->loc; i++) - { - s7_pointer s1 = gp->list[i]; - if (!is_free_and_clear(s1)) - gp->list[j++] = s1; - } + { + s7_pointer s1 = gp->list[i]; + if (!is_free_and_clear(s1)) + gp->list[j++] = s1; + } gp->loc = j; } @@ -6904,18 +6904,18 @@ static void sweep(s7_scheme *sc) if (gp->loc > 0) { for (i = 0, j = 0; i < gp->loc; i++) - { - s7_pointer s1 = gp->list[i]; - if (!is_free_and_clear(s1)) - { - if (is_free_and_clear(c_pointer_weak1(s1))) - c_pointer_weak1(s1) = sc->F; - if (is_free_and_clear(c_pointer_weak2(s1))) - c_pointer_weak2(s1) = sc->F; - if ((c_pointer_weak1(s1) != sc->F) || - (c_pointer_weak2(s1) != sc->F)) - gp->list[j++] = s1; - }} + { + s7_pointer s1 = gp->list[i]; + if (!is_free_and_clear(s1)) + { + if (is_free_and_clear(c_pointer_weak1(s1))) + c_pointer_weak1(s1) = sc->F; + if (is_free_and_clear(c_pointer_weak2(s1))) + c_pointer_weak2(s1) = sc->F; + if ((c_pointer_weak1(s1) != sc->F) || + (c_pointer_weak2(s1) != sc->F)) + gp->list[j++] = s1; + }} gp->loc = j; } @@ -7037,10 +7037,10 @@ static void add_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter) { s7_pointer x = sc->setters[i]; if (car(x) == p) - { - unchecked_set_cdr(x, setter); - return; - }} + { + unchecked_set_cdr(x, setter); + return; + }} if (sc->setters_loc == sc->setters_size) { sc->setters_size *= 2; @@ -7059,8 +7059,8 @@ static void mark_symbol_vector(s7_pointer p, s7_int len) { s7_pointer *e = vector_elements(p); for (s7_int i = 0; i < len; i++) - if ((is_symbol(e[i])) && (is_gensym(e[i]))) /* need is_symbol: make-vector + set! vector-typer symbol? where init is not a symbol */ - set_mark(e[i]); + if ((is_symbol(e[i])) && (is_gensym(e[i]))) /* need is_symbol: make-vector + set! vector-typer symbol? where init is not a symbol */ + set_mark(e[i]); } } @@ -7111,8 +7111,8 @@ static void mark_let(s7_pointer let) if ((has_dox_slot2(x)) && (is_slot(let_dox_slot2(x)))) mark_slot(let_dox_slot2(x)); /* it can happen (call/cc related) that let_dox_slot2 is a slot but invalid, but in that case has_dox_slot2 will not be set(?) */ for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (!is_marked(y)) /* slot value might be the enclosing let */ - mark_slot(y); + if (!is_marked(y)) /* slot value might be the enclosing let */ + mark_slot(y); } } @@ -7124,9 +7124,9 @@ static void gc_owlet_mark(s7_pointer tp) { s7_pointer p = tp; do { - set_mark(p); - gc_mark(car(p)); /* does this need to be gc_owlet_mark? I can't find a case */ - p = cdr(p); + set_mark(p); + gc_mark(car(p)); /* does this need to be gc_owlet_mark? I can't find a case */ + p = cdr(p); } while ((is_pair(p)) && (p != tp) && ((!in_heap(p)) || (!is_marked(p)))); /* ((full_type(p) & (TYPE_MASK | T_GC_MARK)) == T_PAIR) is much slower */ gc_mark(p); } @@ -7142,11 +7142,11 @@ static void mark_owlet(s7_scheme *sc) { for (s7_pointer p1 = sc->eval_history1, p2 = sc->eval_history2, p3 = sc->history_pairs; ; p2 = cdr(p2), p3 = cdr(p3)) { - gc_owlet_mark(car(p1)); - gc_owlet_mark(car(p2)); - gc_owlet_mark(car(p3)); - p1 = cdr(p1); - if (p1 == sc->eval_history1) break; /* these are circular lists */ + gc_owlet_mark(car(p1)); + gc_owlet_mark(car(p2)); + gc_owlet_mark(car(p3)); + p1 = cdr(p1); + if (p1 == sc->eval_history1) break; /* these are circular lists */ }} #endif /* sc->error_type and friends are slots in owlet */ @@ -7326,29 +7326,29 @@ static void mark_hash_table(s7_pointer p) hash_entry_t **last = (hash_entry_t **)(entries + len); if ((is_weak_hash_table(p)) && - (weak_hash_iters(p) == 0)) - while (entries < last) - { - hash_entry_t *xp; - for (xp = *entries++; xp; xp = hash_entry_next(xp)) - gc_mark(hash_entry_value(xp)); - for (xp = *entries++; xp; xp = hash_entry_next(xp)) - gc_mark(hash_entry_value(xp)); - } + (weak_hash_iters(p) == 0)) + while (entries < last) + { + hash_entry_t *xp; + for (xp = *entries++; xp; xp = hash_entry_next(xp)) + gc_mark(hash_entry_value(xp)); + for (xp = *entries++; xp; xp = hash_entry_next(xp)) + gc_mark(hash_entry_value(xp)); + } else - while (entries < last) /* counting entries here was slightly faster */ - { - hash_entry_t *xp; - for (xp = *entries++; xp; xp = hash_entry_next(xp)) - { - gc_mark(hash_entry_key(xp)); - gc_mark(hash_entry_value(xp)); - } - for (xp = *entries++; xp; xp = hash_entry_next(xp)) - { - gc_mark(hash_entry_key(xp)); - gc_mark(hash_entry_value(xp)); - }}} + while (entries < last) /* counting entries here was slightly faster */ + { + hash_entry_t *xp; + for (xp = *entries++; xp; xp = hash_entry_next(xp)) + { + gc_mark(hash_entry_key(xp)); + gc_mark(hash_entry_value(xp)); + } + for (xp = *entries++; xp; xp = hash_entry_next(xp)) + { + gc_mark(hash_entry_key(xp)); + gc_mark(hash_entry_value(xp)); + }}} } static void mark_iterator(s7_pointer p) @@ -7584,9 +7584,9 @@ static int64_t gc(s7_scheme *sc) for (i = 1; i < NUM_SAFE_LISTS; i++) /* see tgen.scm -- we can't just check sc->current_safe_list */ if ((is_pair(sc->safe_lists[i])) && - (list_is_in_use(sc->safe_lists[i]))) /* safe_lists are semipermanent, so we have to mark contents by hand */ + (list_is_in_use(sc->safe_lists[i]))) /* safe_lists are semipermanent, so we have to mark contents by hand */ for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p)) - gc_mark(car(p)); + gc_mark(car(p)); for (i = 0; i < sc->setters_loc; i++) gc_mark(cdr(sc->setters[i])); @@ -7599,7 +7599,7 @@ static int64_t gc(s7_scheme *sc) { set_mark(sc->rec_stack); for (i = 0; i < sc->rec_loc; i++) - gc_mark(sc->rec_els[i]); + gc_mark(sc->rec_els[i]); } mark_vector(sc->protected_objects); mark_vector(sc->protected_setters); @@ -7627,17 +7627,17 @@ static int64_t gc(s7_scheme *sc) { profile_data_t *pd = sc->profile_data; for (i = 0; i < pd->top; i++) - if ((pd->funcs[i]) && (is_gensym(pd->funcs[i]))) - set_mark(pd->funcs[i]); + if ((pd->funcs[i]) && (is_gensym(pd->funcs[i]))) + set_mark(pd->funcs[i]); } { gc_list_t *gp = sc->opt1_funcs; for (i = 0; i < gp->loc; i++) { - s7_pointer s1 = T_Pair(gp->list[i]); - if ((is_marked(s1)) && (!is_marked(opt1_any(s1)))) /* opt1_lambda, but op_unknown* can change to opt1_cfunc etc */ - gc_mark(opt1_any(s1)); /* not set_mark -- need to protect let/body/args as well */ + s7_pointer s1 = T_Pair(gp->list[i]); + if ((is_marked(s1)) && (!is_marked(opt1_any(s1)))) /* opt1_lambda, but op_unknown* can change to opt1_cfunc etc */ + gc_mark(opt1_any(s1)); /* not set_mark -- need to protect let/body/args as well */ }} /* free up all unmarked objects */ @@ -7648,16 +7648,16 @@ static int64_t gc(s7_scheme *sc) s7_pointer *heap_top = (s7_pointer *)(sc->heap + sc->heap_size); #if S7_DEBUGGING - #define gc_object(Tp) \ - p = (*Tp++); \ - if (signed_type(p) > 0) \ - { \ - p->debugger_bits = 0; p->gc_func = func; p->gc_line = line; \ + #define gc_object(Tp) \ + p = (*Tp++); \ + if (signed_type(p) > 0) \ + { \ + p->debugger_bits = 0; p->gc_func = func; p->gc_line = line; \ if (has_odd_bits(p)) {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(sc, p)); free(s);} \ - if (!in_heap(p)) {char *s; fprintf(stderr, "not in heap: %s\n", s = describe_type_bits(sc, p)); free(s);} \ - clear_type(p); \ - (*fp++) = p; \ - } \ + if (!in_heap(p)) {char *s; fprintf(stderr, "not in heap: %s\n", s = describe_type_bits(sc, p)); free(s);} \ + clear_type(p); \ + (*fp++) = p; \ + } \ else if (signed_type(p) < 0) clear_mark(p); #else #define gc_object(Tp) p = (*Tp++); if (signed_type(p) > 0) {clear_type(p); (*fp++) = p;} else if (signed_type(p) < 0) clear_mark(p); @@ -7671,11 +7671,11 @@ static int64_t gc(s7_scheme *sc) #endif while (tp < heap_top) /* != here or ^ makes no difference, and going to 64 (from 32) doesn't matter */ { - s7_pointer p; - LOOP_8(gc_object(tp)); - LOOP_8(gc_object(tp)); - LOOP_8(gc_object(tp)); - LOOP_8(gc_object(tp)); + s7_pointer p; + LOOP_8(gc_object(tp)); + LOOP_8(gc_object(tp)); + LOOP_8(gc_object(tp)); + LOOP_8(gc_object(tp)); } /* I tried using pthreads here, since there is no need for a lock in this loop, but the *fp++ part needs to * be local to each thread, then merged at the end. In my timing tests, the current version was faster. @@ -7696,10 +7696,10 @@ static int64_t gc(s7_scheme *sc) #if (!MS_WINDOWS) #if S7_DEBUGGING s7_warn(sc, 512, "%s[%d]: gc freed %" ld64 "/%" ld64 " (free: %" p64 "), time: %f\n", func, line, - sc->gc_freed, sc->heap_size, (intptr_t)(sc->free_heap_top - sc->free_heap), (double)(sc->gc_end - sc->gc_start) / ticks_per_second()); + sc->gc_freed, sc->heap_size, (intptr_t)(sc->free_heap_top - sc->free_heap), (double)(sc->gc_end - sc->gc_start) / ticks_per_second()); #else s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 " (free: %" p64 "), time: %f\n", - sc->gc_freed, sc->heap_size, (intptr_t)(sc->free_heap_top - sc->free_heap), (double)(sc->gc_end - sc->gc_start) / ticks_per_second()); + sc->gc_freed, sc->heap_size, (intptr_t)(sc->free_heap_top - sc->free_heap), (double)(sc->gc_end - sc->gc_start) / ticks_per_second()); #endif #else s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 "\n", sc->gc_freed, sc->heap_size); @@ -7709,8 +7709,8 @@ static int64_t gc(s7_scheme *sc) { s7_int num, len = vector_length(sc->protected_objects); /* allocated at startup */ for (i = 0, num = 0; i < len; i++) - if (vector_element(sc->protected_objects, i) != sc->unused) - num++; + if (vector_element(sc->protected_objects, i) != sc->unused) + num++; s7_warn(sc, 256, "gc-protected-objects: %" ld64 " in use of %" ld64 "\n", num, len); } sc->previous_free_heap_top = sc->free_heap_top; @@ -7745,17 +7745,17 @@ static void resize_heap_to(s7_scheme *sc, int64_t size) #if (S7_DEBUGGING) && (!MS_WINDOWS) if (show_gc_stats(sc)) s7_warn(sc, 512, "%s from %s[%d]: old: %" ld64 " / %" ld64 ", new: %" ld64 ", fraction: %.3f -> %" ld64 "\n", - __func__, func, line, old_free, old_size, size, sc->gc_resize_heap_fraction, (int64_t)(floor(sc->heap_size * sc->gc_resize_heap_fraction))); + __func__, func, line, old_free, old_size, size, sc->gc_resize_heap_fraction, (int64_t)(floor(sc->heap_size * sc->gc_resize_heap_fraction))); #endif if (size == 0) { if ((old_free < old_size * sc->gc_resize_heap_by_4_fraction) && - (sc->max_heap_size > (sc->heap_size * 4))) - sc->heap_size *= 4; /* *8 if < 1M (or whatever) doesn't make much difference */ + (sc->max_heap_size > (sc->heap_size * 4))) + sc->heap_size *= 4; /* *8 if < 1M (or whatever) doesn't make much difference */ else sc->heap_size *= 2; if (sc->gc_resize_heap_fraction > .4) - sc->gc_resize_heap_fraction *= .95; + sc->gc_resize_heap_fraction *= .95; } else if (size > sc->heap_size) @@ -7766,9 +7766,9 @@ static void resize_heap_to(s7_scheme *sc, int64_t size) if (((2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell))) >= SIZE_MAX) { /* can this happen in 64-bit land? SIZE_MAX is unsigned int in 32-bit, unsigned long in 64 bit = UINTPTR_MAX = 18446744073709551615UL */ s7_warn(sc, 256, "heap size requested, %" ld64 " => %" ld64 " bytes, is greater than size_t: %u\n", - sc->heap_size, - (2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell)), - SIZE_MAX); + sc->heap_size, + (2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell)), + SIZE_MAX); sc->heap_size = old_size + 64000; } #endif @@ -7778,7 +7778,7 @@ static void resize_heap_to(s7_scheme *sc, int64_t size) else /* can this happen? */ { s7_warn(sc, 256, "heap reallocation failed! tried to get %" ld64 " bytes (will retry with a smaller amount)\n", - (int64_t)(sc->heap_size * sizeof(s7_cell *))); + (int64_t)(sc->heap_size * sizeof(s7_cell *))); sc->heap_size = old_size + 64000; sc->heap = (s7_cell **)Realloc(sc->heap, sc->heap_size * sizeof(s7_cell *)); } @@ -7792,10 +7792,10 @@ static void resize_heap_to(s7_scheme *sc, int64_t size) s7_pointer p = cells; for (int64_t k = old_size; k < sc->heap_size;) { - LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); - LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); - LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); - LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); + LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); + LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); + LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); + LOOP_8(sc->heap[k++] = p; (*sc->free_heap_top++) = p++); }} hp = (heap_block_t *)Malloc(sizeof(heap_block_t)); hp->start = (intptr_t)cells; @@ -7808,16 +7808,16 @@ static void resize_heap_to(s7_scheme *sc, int64_t size) if (show_heap_stats(sc)) { if (size != 0) - s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ", requested %" ld64 ")\n", - sc->heap_size, old_free, old_size, size); + s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ", requested %" ld64 ")\n", + sc->heap_size, old_free, old_size, size); else s7_warn(sc, 512, "heap grows to %" ld64 " (old free/size: %" ld64 "/%" ld64 ", %.3f)\n", - sc->heap_size, old_free, old_size, sc->gc_resize_heap_fraction); + sc->heap_size, old_free, old_size, sc->gc_resize_heap_fraction); } if (sc->heap_size >= sc->max_heap_size) error_nr(sc, make_symbol(sc, "heap-too-big", 12), - set_elist_3(sc, wrap_string(sc, "heap has grown past (*s7* 'max-heap-size): ~D > ~D", 50), - wrap_integer(sc, sc->max_heap_size), - wrap_integer(sc, sc->heap_size))); + set_elist_3(sc, wrap_string(sc, "heap has grown past (*s7* 'max-heap-size): ~D > ~D", 50), + wrap_integer(sc, sc->max_heap_size), + wrap_integer(sc, sc->heap_size))); } @@ -7837,14 +7837,14 @@ static void try_to_call_gc(s7_scheme *sc) else { if ((sc->gc_resize_heap_fraction > 0.5) && (sc->heap_size >= 4194304)) - sc->gc_resize_heap_fraction = 0.5; + sc->gc_resize_heap_fraction = 0.5; #if S7_DEBUGGING gc(sc, func, line); /* not call_gc! */ #else gc(sc); #endif if ((int64_t)(sc->free_heap_top - sc->free_heap) < (sc->heap_size * sc->gc_resize_heap_fraction)) /* changed 21-Jul-22 */ - resize_heap(sc); + resize_heap(sc); } } /* originally I tried to mark each temporary value until I was done with it, but that way madness lies... By delaying @@ -7880,10 +7880,10 @@ Evaluation produces a surprising amount of garbage, so don't leave the GC off fo if (is_not_null(args)) { if (!is_boolean(car(args))) - return(sole_arg_method_or_bust(sc, car(args), sc->gc_symbol, args, sc->type_names[T_BOOLEAN])); + return(sole_arg_method_or_bust(sc, car(args), sc->gc_symbol, args, sc->type_names[T_BOOLEAN])); sc->gc_off = (car(args) == sc->F); if (sc->gc_off) - return(sc->F); + return(sc->F); } call_gc(sc); return(sc->unspecified); @@ -7911,7 +7911,7 @@ static void check_free_heap_size(s7_scheme *sc, s7_int size) gc(sc); #endif while ((sc->free_heap_top - sc->free_heap) < (s7_int)(size * 1.5)) - resize_heap(sc); + resize_heap(sc); } } @@ -7982,12 +7982,12 @@ static void free_cell(s7_scheme *sc, s7_pointer p) if ((t_any_closure_p[typ]) && (gp->loc > 0)) for (s7_int i = 0; i < gp->loc; i++) if (gp->list[i] == p) - fprintf(stderr, "opt1_funcs free_cell of %s?\n", type_name_from_type(typ, NO_ARTICLE)); + fprintf(stderr, "opt1_funcs free_cell of %s?\n", type_name_from_type(typ, NO_ARTICLE)); gp = sc->weak_refs; if (gp->loc > 0) for (s7_int i = 0; i < gp->loc; i++) if (gp->list[i] == p) - fprintf(stderr, "weak refs free_cell of %s?\n", type_name_from_type(typ, NO_ARTICLE)); + fprintf(stderr, "weak refs free_cell of %s?\n", type_name_from_type(typ, NO_ARTICLE)); p->debugger_bits = 0; p->explicit_free_line = line; @@ -8025,14 +8025,14 @@ static void remove_gensym_from_heap(s7_scheme *sc, s7_pointer x) /* x known to b gc_list_t *gp = sc->gensyms; for (s7_int i = 0; i < gp->loc; i++) /* sc->gensyms reaches size 512 during s7test, but this search is called 3 times and costs nothing */ if (gp->list[i] == x) - { - for (s7_int j = i + 1; i < gp->loc - 1; i++, j++) - gp->list[i] = gp->list[j]; - gp->list[i] = NULL; - gp->loc--; - if (gp->loc == 0) mark_function[T_SYMBOL] = mark_noop; - break; - }} + { + for (s7_int j = i + 1; i < gp->loc - 1; i++, j++) + gp->list[i] = gp->list[j]; + gp->list[i] = NULL; + gp->loc--; + if (gp->loc == 0) mark_function[T_SYMBOL] = mark_noop; + break; + }} } static inline void remove_from_heap(s7_scheme *sc, s7_pointer x) @@ -8043,9 +8043,9 @@ static inline void remove_from_heap(s7_scheme *sc, s7_pointer x) { s7_pointer p = x; do { - petrify(sc, p); - remove_from_heap(sc, car(p)); - p = cdr(p); + petrify(sc, p); + remove_from_heap(sc, car(p)); + p = cdr(p); } while (is_pair(p) && (in_heap(p))); if (in_heap(p)) petrify(sc, p); return; @@ -8063,7 +8063,7 @@ static inline void remove_from_heap(s7_scheme *sc, s7_pointer x) return; case T_SYMBOL: if (is_gensym(x)) - remove_gensym_from_heap(sc, x); + remove_gensym_from_heap(sc, x); return; case T_CLOSURE: case T_CLOSURE_STAR: case T_MACRO: case T_MACRO_STAR: @@ -8206,16 +8206,16 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer if (sc->stack_end >= sc->stack_start + sc->stack_size) { fprintf(stderr, "%s%s[%d]: stack overflow, %u > %u, trigger: %u %s\n", - bold_text, func, line, - (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start)), sc->stack_size, - (uint32_t)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)), - unbold_text); + bold_text, func, line, + (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start)), sc->stack_size, + (uint32_t)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)), + unbold_text); s7_show_stack(sc); if (sc->stop_at_error) abort(); } if (sc->stack_end >= sc->stack_resize_trigger) fprintf(stderr, "%s%s[%d] from %s: stack resize skipped, stack at %u of %u%s\n", - bold_text, func, line, op_names[op], (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start) / 4), sc->stack_size / 4, unbold_text); + bold_text, func, line, op_names[op], (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start) / 4), sc->stack_size / 4, unbold_text); if (sc->stack_end != end) fprintf(stderr, "%s[%d]: stack changed in push_stack\n", func, line); if (op >= NUM_OPS) @@ -8230,7 +8230,7 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer sc->stack_end += 4; } -#define push_stack(Sc, Op, Args, Code) \ +#define push_stack(Sc, Op, Args, Code) \ do {s7_pointer *_end_; _end_ = Sc->stack_end; push_stack_1(Sc, Op, Args, Code, _end_, __func__, __LINE__);} while (0) #define push_stack_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused) @@ -8293,7 +8293,7 @@ static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer #define push_stack_no_args_direct(Sc, Op) \ do { \ - memcpy((void *)(Sc->stack_end), (void *)Sc, 2 * sizeof(s7_pointer)); \ + memcpy((void *)(Sc->stack_end), (void *)Sc, 2 * sizeof(s7_pointer)); \ stack_end_op(sc) = (s7_pointer)(opcode_t)(Op); \ Sc->stack_end += 4; \ } while (0) @@ -8393,9 +8393,9 @@ static void resize_stack_1(s7_scheme *sc, const char *func, int line) if ((sc->stack_size * 2) > sc->max_stack_size) { fprintf(stderr, "%s%s[%d]: stack will be too big after resize, %u > %u, trigger: %" ld64 "%s\n", - bold_text, func, line, sc->stack_size * 2, sc->max_stack_size, - (s7_int)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)), - unbold_text); + bold_text, func, line, sc->stack_size * 2, sc->max_stack_size, + (s7_int)((intptr_t)(sc->stack_resize_trigger - sc->stack_start)), + unbold_text); s7_show_stack(sc); if (sc->stop_at_error) abort(); } @@ -8409,7 +8409,7 @@ static void resize_stack(s7_scheme *sc) s7_warn(sc, 128, "stack grows to %u\n", new_size); if (new_size > sc->max_stack_size) error_nr(sc, make_symbol(sc, "stack-too-big", 13), - set_elist_1(sc, wrap_string(sc, "stack has grown past (*s7* 'max-stack-size)", 43))); + set_elist_1(sc, wrap_string(sc, "stack has grown past (*s7* 'max-stack-size)", 43))); /* error needs to follow realloc, else error -> catchers in error_nr -> let_temp* -> eval_done -> stack_resize -> infinite loop */ } #endif @@ -8543,8 +8543,8 @@ static /* inline */ s7_pointer new_symbol(s7_scheme *sc, const char *name, s7_in set_has_keyword(ksym); /* the keyword symbol needs to be semipermanent (not a gensym) else we have to laboriously gc-protect it */ if ((is_gensym(ksym)) && - (in_heap(ksym))) - remove_gensym_from_heap(sc, ksym); + (in_heap(ksym))) + remove_gensym_from_heap(sc, ksym); slot = make_semipermanent_slot(sc, x, x); set_global_slot(x, slot); set_local_slot(x, slot); @@ -8568,16 +8568,16 @@ static Inline s7_pointer inline_make_symbol(s7_scheme *sc, const char *name, s7_ if (len <= 8) { for (s7_pointer x = vector_element(sc->symbol_table, location); is_pair(x); x = cdr(x)) - if ((hash == pair_raw_hash(x)) && - ((uint64_t)len == pair_raw_len(x))) - return(car(x)); + if ((hash == pair_raw_hash(x)) && + ((uint64_t)len == pair_raw_len(x))) + return(car(x)); } else /* checking name[len=='\0' and using strcmp if so was not a big win */ for (s7_pointer x = vector_element(sc->symbol_table, location); is_pair(x); x = cdr(x)) if ((hash == pair_raw_hash(x)) && - ((uint64_t)len == pair_raw_len(x)) && - (strings_are_equal_with_length(name, pair_raw_name(x), len))) /* length here because name might not be null-terminated */ - return(car(x)); + ((uint64_t)len == pair_raw_len(x)) && + (strings_are_equal_with_length(name, pair_raw_name(x), len))) /* length here because name might not be null-terminated */ + return(car(x)); return(new_symbol(sc, name, len, hash, location)); } @@ -8589,7 +8589,7 @@ static s7_pointer symbol_table_find_by_name(s7_scheme *sc, const char *name, uin { for (s7_pointer x = vector_element(sc->symbol_table, location); is_not_null(x); x = cdr(x)) if ((hash == pair_raw_hash(x)) && - (strings_are_equal_with_length(name, pair_raw_name(x), len))) + (strings_are_equal_with_length(name, pair_raw_name(x), len))) return(car(x)); return(sc->nil); } @@ -8627,8 +8627,8 @@ static s7_pointer g_symbol_table(s7_scheme *sc, s7_pointer unused_args) syms++; if (syms > sc->max_vector_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "symbol-table size, ~D, is greater than (*s7* 'max-vector-length), ~D", 68), - wrap_integer(sc, syms), wrap_integer(sc, sc->max_vector_length))); + set_elist_3(sc, wrap_string(sc, "symbol-table size, ~D, is greater than (*s7* 'max-vector-length), ~D", 68), + wrap_integer(sc, syms), wrap_integer(sc, sc->max_vector_length))); sc->w = make_simple_vector(sc, syms); set_is_symbol_table(sc->w); els = vector_elements(sc->w); @@ -8646,11 +8646,11 @@ bool s7_for_each_symbol_name(s7_scheme *sc, bool (*symbol_func)(const char *symb for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) for (s7_pointer x = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x)) if (symbol_func(symbol_name(car(x)), data)) - return(true); + return(true); return((symbol_func("#t", data)) || (symbol_func("#f", data)) || - (symbol_func("#<unspecified>", data)) || (symbol_func("#<undefined>", data)) || - (symbol_func("#<eof>", data)) || - (symbol_func("#true", data)) || (symbol_func("#false", data))); + (symbol_func("#<unspecified>", data)) || (symbol_func("#<undefined>", data)) || + (symbol_func("#<eof>", data)) || + (symbol_func("#true", data)) || (symbol_func("#false", data))); } bool s7_for_each_symbol(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data) @@ -8658,7 +8658,7 @@ bool s7_for_each_symbol(s7_scheme *sc, bool (*symbol_func)(const char *symbol_na for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) for (s7_pointer x = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x)) if (symbol_func(symbol_name(car(x)), data)) - return(true); + return(true); return(false); } @@ -8675,10 +8675,10 @@ static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym) else for (s7_pointer y = x, z = cdr(x); is_pair(z); y = z, z = cdr(z)) if (car(z) == sym) - { - unchecked_set_cdr(y, cdr(z)); - return; - } + { + unchecked_set_cdr(y, cdr(z)); + return; + } } s7_pointer s7_gensym(s7_scheme *sc, const char *prefix) @@ -8725,7 +8725,7 @@ static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args) { s7_pointer gname = car(args); if (!is_string(gname)) - return(sole_arg_method_or_bust(sc, gname, sc->gensym_symbol, args, sc->type_names[T_STRING])); + return(sole_arg_method_or_bust(sc, gname, sc->gensym_symbol, args, sc->type_names[T_STRING])); prefix = string_value(gname); plen = string_length(gname); /* was safe_strlen(prefix): were we stopping at #\null deliberately? */ } @@ -8758,7 +8758,7 @@ static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args) location = hash % SYMBOL_TABLE_SIZE; if (is_null(symbol_table_find_by_name(sc, name, hash, location, nlen))) break; if (sc->safety > NO_SAFETY) - s7_warn(sc, nlen + 25, "%s collides with gensym?\n", name); + s7_warn(sc, nlen + 25, "%s collides with gensym?\n", name); } /* make-string for symbol name */ @@ -8853,8 +8853,8 @@ static s7_pointer g_symbol_to_string(s7_scheme *sc, s7_pointer args) /* s7_make_string uses strlen which stops at an embedded null */ if (symbol_name_length(sym) > sc->max_string_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "symbol->string symbol name is too large: (> ~D ~D) (*s7* 'max-string-length)", 76), - wrap_integer(sc, symbol_name_length(sym)), wrap_integer(sc, sc->max_string_length))); + set_elist_3(sc, wrap_string(sc, "symbol->string symbol name is too large: (> ~D ~D) (*s7* 'max-string-length)", 76), + wrap_integer(sc, symbol_name_length(sym)), wrap_integer(sc, sc->max_string_length))); return(inline_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); /* return a copy */ } @@ -8938,7 +8938,7 @@ static s7_pointer g_symbol(s7_scheme *sc, s7_pointer args) if (is_pair(p)) { if (is_null(cdr(args))) - return(mark_as_symbol_from_symbol(g_string_to_symbol_1(sc, car(args), sc->symbol_symbol))); + return(mark_as_symbol_from_symbol(g_string_to_symbol_1(sc, car(args), sc->symbol_symbol))); return(mark_as_symbol_from_symbol(g_string_to_symbol_1(sc, g_string_append_1(sc, args, sc->symbol_symbol), sc->symbol_symbol))); } if (len == 0) @@ -8951,10 +8951,10 @@ static s7_pointer g_symbol(s7_scheme *sc, s7_pointer args) { s7_pointer str = car(p); if (string_length(str) > 0) - { - memcpy((void *)(name + cur_len), (void *)string_value(str), string_length(str)); - cur_len += string_length(str); - }} + { + memcpy((void *)(name + cur_len), (void *)string_value(str), string_length(str)); + cur_len += string_length(str); + }} name[len] = '\0'; sym = mark_as_symbol_from_symbol(inline_make_symbol(sc, name, len)); liberate(sc, b); @@ -9029,7 +9029,7 @@ static s7_pointer make_let_with_slot(s7_scheme *sc, s7_pointer old_let, s7_point } static Inline s7_pointer inline_make_let_with_two_slots(s7_scheme *sc, s7_pointer old_let, - s7_pointer symbol1, s7_pointer value1, s7_pointer symbol2, s7_pointer value2) + s7_pointer symbol1, s7_pointer value1, s7_pointer symbol2, s7_pointer value2) { /* we leave value1/value2 computation order to the C compiler here -- in the old macro, it was explicitly value1 then value2 * this means any let in old scheme code that actually depends on the order may break -- it should be let*. @@ -9274,7 +9274,7 @@ static inline s7_pointer checked_slot_set_value(s7_scheme *sc, s7_pointer y, s7_ else { if (is_immutable_slot(y)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_set_symbol, slot_symbol(y))); + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_set_symbol, slot_symbol(y))); slot_set_value(y, value); } return(slot_value(y)); @@ -9316,10 +9316,10 @@ static s7_int let_length(s7_scheme *sc, s7_pointer e) { s7_pointer length_func = find_method(sc, e, sc->length_symbol); if (length_func != sc->undefined) - { - p = s7_apply_function(sc, length_func, set_plist_1(sc, e)); - return((s7_is_integer(p)) ? s7_integer(p) : -1); /* ?? */ - }} + { + p = s7_apply_function(sc, length_func, set_plist_1(sc, e)); + return((s7_is_integer(p)) ? s7_integer(p) : -1); /* ?? */ + }} for (i = 0, p = let_slots(e); tis_slot(p); i++, p = next_slot(p)); return(i); } @@ -9350,8 +9350,8 @@ static void remove_let_from_heap(s7_scheme *sc, s7_pointer lt) { s7_pointer val = slot_value(p); if ((has_closure_let(val)) && - (in_heap(closure_args(val)))) - remove_function_from_heap(sc, val); + (in_heap(closure_args(val)))) + remove_function_from_heap(sc, val); } let_set_removed(lt); } @@ -9374,12 +9374,12 @@ static void remove_function_from_heap(s7_scheme *sc, s7_pointer value) { lt = let_outlet(lt); if ((is_let(lt)) && (!let_removed(lt)) && (lt != sc->shadow_rootlet)) - { - remove_let_from_heap(sc, lt); - lt = let_outlet(lt); - if ((is_let(lt)) && (!let_removed(lt)) && (lt != sc->shadow_rootlet)) - remove_let_from_heap(sc, lt); - }} + { + remove_let_from_heap(sc, lt); + lt = let_outlet(lt); + if ((is_let(lt)) && (!let_removed(lt)) && (lt != sc->shadow_rootlet)) + remove_let_from_heap(sc, lt); + }} } s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) @@ -9389,56 +9389,56 @@ s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_poi { s7_pointer slot; if (is_immutable(sc->rootlet)) - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't define '~S; rootlet is immutable", 38), symbol)); + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't define '~S; rootlet is immutable", 38), symbol)); if ((sc->safety <= NO_SAFETY) && - (has_closure_let(value))) - remove_function_from_heap(sc, value); /* optimization of access pointers happens later so presumably this is safe */ + (has_closure_let(value))) + remove_function_from_heap(sc, value); /* optimization of access pointers happens later so presumably this is safe */ /* first look for existing slot -- this is not always checked before calling s7_make_slot */ if (is_slot(global_slot(symbol))) - { - slot = global_slot(symbol); - if (is_immutable_slot(slot)) /* 2-Oct-23: (immutable! 'abs) (set! abs 3) */ - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, symbol)); - symbol_increment_ctr(symbol); - slot_set_value_with_hook(slot, value); - return(slot); - } + { + slot = global_slot(symbol); + if (is_immutable_slot(slot)) /* 2-Oct-23: (immutable! 'abs) (set! abs 3) */ + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, symbol)); + symbol_increment_ctr(symbol); + slot_set_value_with_hook(slot, value); + return(slot); + } slot = make_semipermanent_slot(sc, symbol, value); add_slot_to_rootlet(sc, slot); set_global_slot(symbol, slot); if (symbol_id(symbol) == 0) /* never defined locally? */ - { - if ((!is_gensym(symbol)) && - (initial_slot(symbol) == sc->undefined) && - (!in_heap(value)) && /* else initial_slot value can be GC'd if symbol set! (initial != global, initial unprotected) */ - ((!sc->string_signature) || /* from init_signatures -- maybe need a boolean for this */ - (is_c_function(value)))) /* || (is_syntax(value)) -- we need 'else as a special case? */ - /* the string_signature business means only the initial rootlet c_functions take part in unlet. It would be neat if any - * cload library's c_functions could be there as well, but then (unlet) needs to know which envs are in the chain. - * The current shadow_rootlet could be saved in each initial_slot, these could be marked in some way, then the chain - * searched in (unlet) to get the currently active envs -- maybe too complex? We could also provide a way to overrule - * the string_signature check, but then symbol collisions would probably be resolved as the last loaded (which might not - * be in the active chain). - * Also, the c_function check is overly paranoid -- all we need is that the value is semipermanent (T_UNHEAP?). - */ - { - set_initial_slot(symbol, make_semipermanent_slot(sc, symbol, value)); - if ((!sc->string_signature) && ((is_c_function(value)) || (is_syntax(value)))) /* syntax probably can't happen here (handled explicitly in syntax procedure) */ - { - /* non-c_functions that are not set! (and therefore initial_slot GC) protected by default: make-hook hook-functions - * if these initial_slot values are added to unlet, they need explicit GC protection. - */ - slot_set_next(initial_slot(symbol), sc->unlet_slots); - sc->unlet_slots = initial_slot(symbol); - }} - set_local_slot(symbol, slot); - set_global(symbol); - } + { + if ((!is_gensym(symbol)) && + (initial_slot(symbol) == sc->undefined) && + (!in_heap(value)) && /* else initial_slot value can be GC'd if symbol set! (initial != global, initial unprotected) */ + ((!sc->string_signature) || /* from init_signatures -- maybe need a boolean for this */ + (is_c_function(value)))) /* || (is_syntax(value)) -- we need 'else as a special case? */ + /* the string_signature business means only the initial rootlet c_functions take part in unlet. It would be neat if any + * cload library's c_functions could be there as well, but then (unlet) needs to know which envs are in the chain. + * The current shadow_rootlet could be saved in each initial_slot, these could be marked in some way, then the chain + * searched in (unlet) to get the currently active envs -- maybe too complex? We could also provide a way to overrule + * the string_signature check, but then symbol collisions would probably be resolved as the last loaded (which might not + * be in the active chain). + * Also, the c_function check is overly paranoid -- all we need is that the value is semipermanent (T_UNHEAP?). + */ + { + set_initial_slot(symbol, make_semipermanent_slot(sc, symbol, value)); + if ((!sc->string_signature) && ((is_c_function(value)) || (is_syntax(value)))) /* syntax probably can't happen here (handled explicitly in syntax procedure) */ + { + /* non-c_functions that are not set! (and therefore initial_slot GC) protected by default: make-hook hook-functions + * if these initial_slot values are added to unlet, they need explicit GC protection. + */ + slot_set_next(initial_slot(symbol), sc->unlet_slots); + sc->unlet_slots = initial_slot(symbol); + }} + set_local_slot(symbol, slot); + set_global(symbol); + } symbol_increment_ctr(symbol); if (is_gensym(symbol)) - remove_gensym_from_heap(sc, symbol); + remove_gensym_from_heap(sc, symbol); return(slot); } return(add_slot_checked_with_id(sc, let, symbol, value)); @@ -9498,9 +9498,9 @@ static s7_pointer g_unlet(s7_scheme *sc, s7_pointer unused_args) s7_pointer sym = slot_symbol(p); s7_pointer x = slot_value(p); if ((x != global_value(sym)) || /* it has been changed globally */ - ((!is_global(sym)) && /* it might be shadowed locally */ - (s7_symbol_local_value(sc, sym, sc->curlet) != global_value(sym)))) - add_slot_checked_with_id(sc, sc->w, sym, x); + ((!is_global(sym)) && /* it might be shadowed locally */ + (s7_symbol_local_value(sc, sym, sc->curlet) != global_value(sym)))) + add_slot_checked_with_id(sc, sc->w, sym, x); } res = sc->w; sc->w = sc->unused; @@ -9590,29 +9590,29 @@ static void append_let(s7_scheme *sc, s7_pointer new_e, s7_pointer old_e) if (new_e == sc->rootlet) for (s7_pointer x = let_slots(old_e); tis_slot(x); x = next_slot(x)) { - s7_pointer sym = slot_symbol(x), val = slot_value(x); - if (is_slot(global_slot(sym))) - slot_set_value(global_slot(sym), val); - else s7_make_slot(sc, sc->rootlet, sym, val); + s7_pointer sym = slot_symbol(x), val = slot_value(x); + if (is_slot(global_slot(sym))) + slot_set_value(global_slot(sym), val); + else s7_make_slot(sc, sc->rootlet, sym, val); } else if (old_e == sc->s7_starlet) { - s7_pointer iter = s7_make_iterator(sc, sc->s7_starlet); - s7_int gc_loc = gc_protect_1(sc, iter); - iterator_current(iter) = cons_unchecked(sc, sc->F, sc->F); - set_mark_seq(iter); /* so carrier is GC protected by mark_iterator */ - while (true) - { - s7_pointer y = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - add_slot_checked_with_id(sc, new_e, car(y), cdr(y)); - } - s7_gc_unprotect_at(sc, gc_loc); + s7_pointer iter = s7_make_iterator(sc, sc->s7_starlet); + s7_int gc_loc = gc_protect_1(sc, iter); + iterator_current(iter) = cons_unchecked(sc, sc->F, sc->F); + set_mark_seq(iter); /* so carrier is GC protected by mark_iterator */ + while (true) + { + s7_pointer y = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + add_slot_checked_with_id(sc, new_e, car(y), cdr(y)); + } + s7_gc_unprotect_at(sc, gc_loc); } else for (s7_pointer x = let_slots(old_e); tis_slot(x); x = next_slot(x)) - add_slot_checked_with_id(sc, new_e, slot_symbol(x), slot_value(x)); /* not add_slot here because we might run off the free heap end */ + add_slot_checked_with_id(sc, new_e, slot_symbol(x), slot_value(x)); /* not add_slot here because we might run off the free heap end */ } static s7_pointer check_c_object_let(s7_scheme *sc, s7_pointer old_e, s7_pointer caller) @@ -9638,7 +9638,7 @@ s7_pointer s7_varlet(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointe if (let == sc->rootlet) { if (is_slot(global_slot(symbol))) - slot_set_value(global_slot(symbol), value); + slot_set_value(global_slot(symbol), value); else s7_make_slot(sc, sc->rootlet, symbol, value); } else @@ -9672,61 +9672,61 @@ to the let target-let, and returns target-let. (varlet (curlet) 'a 1) adds 'a t { check_method(sc, e, sc->varlet_symbol, args); if (!is_let(e)) - wrong_type_error_nr(sc, sc->varlet_symbol, 1, e, a_let_string); + wrong_type_error_nr(sc, sc->varlet_symbol, 1, e, a_let_string); if ((is_immutable_let(e)) || (e == sc->s7_starlet)) - immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't (varlet ~{~S~^ ~}), ~S is immutable", 41), args, e)); + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't (varlet ~{~S~^ ~}), ~S is immutable", 41), args, e)); } for (s7_pointer x = cdr(args); is_pair(x); x = cdr(x)) { s7_pointer sym, val, p = car(x); switch (type(p)) - { - case T_SYMBOL: - sym = (is_keyword(p)) ? keyword_symbol(p) : p; - if (!is_pair(cdr(x))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "varlet: symbol ~S, but no value: ~S", 35), p, args)); - if (is_constant_symbol(sc, sym)) - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), sym, a_non_constant_symbol_string); - x = cdr(x); - val = car(x); - break; - - case T_PAIR: - sym = car(p); - if (!is_symbol(sym)) - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), p, a_symbol_string); - if (is_constant_symbol(sc, sym)) - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), sym, a_non_constant_symbol_string); - val = cdr(p); - break; - - case T_LET: /* (varlet (inlet 'a 1) (rootlet)) is trouble */ - if ((p == sc->rootlet) || (e == sc->s7_starlet)) continue; - append_let(sc, e, check_c_object_let(sc, p, sc->varlet_symbol)); - if (has_let_set_fallback(p)) set_has_let_set_fallback(e); - if (has_let_ref_fallback(p)) set_has_let_ref_fallback(e); - continue; - - default: - wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), p, a_symbol_string); - } + { + case T_SYMBOL: + sym = (is_keyword(p)) ? keyword_symbol(p) : p; + if (!is_pair(cdr(x))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "varlet: symbol ~S, but no value: ~S", 35), p, args)); + if (is_constant_symbol(sc, sym)) + wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), sym, a_non_constant_symbol_string); + x = cdr(x); + val = car(x); + break; + + case T_PAIR: + sym = car(p); + if (!is_symbol(sym)) + wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), p, a_symbol_string); + if (is_constant_symbol(sc, sym)) + wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), sym, a_non_constant_symbol_string); + val = cdr(p); + break; + + case T_LET: /* (varlet (inlet 'a 1) (rootlet)) is trouble */ + if ((p == sc->rootlet) || (e == sc->s7_starlet)) continue; + append_let(sc, e, check_c_object_let(sc, p, sc->varlet_symbol)); + if (has_let_set_fallback(p)) set_has_let_set_fallback(e); + if (has_let_ref_fallback(p)) set_has_let_ref_fallback(e); + continue; + + default: + wrong_type_error_nr(sc, sc->varlet_symbol, position_of(x, args), p, a_symbol_string); + } if (e == sc->rootlet) - { - s7_pointer gslot = global_slot(sym); - if (is_slot(gslot)) - { - if (is_immutable(gslot)) /* (immutable! 'abs) (varlet (rootlet) 'abs 1) */ - immutable_object_error_nr(sc, set_elist_5(sc, wrap_string(sc, "~S is immutable in (varlet ~S '~S ~S)", 37), sym, car(args), p, val)); - slot_set_value_with_hook(global_slot(sym), val); - } - else s7_make_slot(sc, sc->rootlet, sym, val); - } + { + s7_pointer gslot = global_slot(sym); + if (is_slot(gslot)) + { + if (is_immutable(gslot)) /* (immutable! 'abs) (varlet (rootlet) 'abs 1) */ + immutable_object_error_nr(sc, set_elist_5(sc, wrap_string(sc, "~S is immutable in (varlet ~S '~S ~S)", 37), sym, car(args), p, val)); + slot_set_value_with_hook(global_slot(sym), val); + } + else s7_make_slot(sc, sc->rootlet, sym, val); + } else - { - check_let_fallback(sc, sym, e); - add_slot_checked_with_id(sc, e, sym, val); - }} + { + check_let_fallback(sc, sym, e); + add_slot_checked_with_id(sc, e, sym, val); + }} /* this used to check for sym already defined, and set its value, but that greatly slows down * the most common use (adding a slot), and makes it hard to shadow explicitly. Don't use * varlet as a substitute for set!/let-set!. @@ -9749,9 +9749,9 @@ static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args) { check_method(sc, e, sc->cutlet_symbol, args); if (!is_let(e)) - wrong_type_error_nr(sc, sc->cutlet_symbol, 1, e, a_let_string); + wrong_type_error_nr(sc, sc->cutlet_symbol, 1, e, a_let_string); if ((is_immutable_let(e)) || (e == sc->s7_starlet)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, e)); + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, e)); } /* besides removing the slot we have to make sure the symbol_id does not match else * let-ref and others will use the old slot! What's the un-id? Perhaps the next one? @@ -9764,49 +9764,49 @@ static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args) s7_pointer sym = car(syms); if (!is_symbol(sym)) - wrong_type_error_nr(sc, sc->cutlet_symbol, position_of(syms, args), sym, a_symbol_string); + wrong_type_error_nr(sc, sc->cutlet_symbol, position_of(syms, args), sym, a_symbol_string); if (is_keyword(sym)) - sym = keyword_symbol(sym); + sym = keyword_symbol(sym); if (e == sc->rootlet) - { - if (!is_slot(global_slot(sym))) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "cutlet can't remove ~S", 22), sym)); - if (is_immutable(global_slot(sym))) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); - symbol_set_id(sym, the_un_id); - slot_set_value(global_slot(sym), sc->undefined); - /* here we need to at least clear bits: syntactic binder clean-symbol(?) etc, maybe also locally */ - } + { + if (!is_slot(global_slot(sym))) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "cutlet can't remove ~S", 22), sym)); + if (is_immutable(global_slot(sym))) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); + symbol_set_id(sym, the_un_id); + slot_set_value(global_slot(sym), sc->undefined); + /* here we need to at least clear bits: syntactic binder clean-symbol(?) etc, maybe also locally */ + } else - { - s7_pointer slot; - if ((has_let_fallback(e)) && - ((sym == sc->let_ref_fallback_symbol) || (sym == sc->let_set_fallback_symbol))) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "cutlet can't remove ~S", 22), sym)); - - slot = let_slots(e); - if (tis_slot(slot)) - { - if (slot_symbol(slot) == sym) - { - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); - let_set_slots(e, next_slot(let_slots(e))); - symbol_set_id(sym, the_un_id); - } - else - { - s7_pointer last_slot = slot; - for (slot = next_slot(let_slots(e)); tis_slot(slot); last_slot = slot, slot = next_slot(slot)) - if (slot_symbol(slot) == sym) - { - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); - symbol_set_id(sym, the_un_id); - slot_set_next(last_slot, next_slot(slot)); - break; - }}}}} + { + s7_pointer slot; + if ((has_let_fallback(e)) && + ((sym == sc->let_ref_fallback_symbol) || (sym == sc->let_set_fallback_symbol))) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "cutlet can't remove ~S", 22), sym)); + + slot = let_slots(e); + if (tis_slot(slot)) + { + if (slot_symbol(slot) == sym) + { + if (is_immutable_slot(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); + let_set_slots(e, next_slot(let_slots(e))); + symbol_set_id(sym, the_un_id); + } + else + { + s7_pointer last_slot = slot; + for (slot = next_slot(let_slots(e)); tis_slot(slot); last_slot = slot, slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + { + if (is_immutable_slot(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->cutlet_symbol, sym)); + symbol_set_id(sym, the_un_id); + slot_set_next(last_slot, next_slot(slot)); + break; + }}}}} return(e); } @@ -9824,59 +9824,59 @@ static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_ s7_pointer sp = NULL; sc->temp3 = new_e; for (s7_pointer x = bindings; is_pair(x); x = cdr(x)) - { - s7_pointer p = car(x), sym, val; - - switch (type(p)) - { - case T_SYMBOL: - sym = (is_keyword(p)) ? keyword_symbol(p) : p; - if (!is_pair(cdr(x))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: entry ~S, but no value: ~S", 30), caller, p, bindings)); - x = cdr(x); - val = car(x); - break; - - case T_PAIR: - sym = car(p); - if (!is_symbol(sym)) - wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), p, a_symbol_string); - if (is_keyword(sym)) - sym = keyword_symbol(sym); - val = cdr(p); - break; - - case T_LET: - if ((p == sc->rootlet) || (new_e == sc->s7_starlet)) continue; - append_let(sc, new_e, check_c_object_let(sc, p, caller)); - if (tis_slot(let_slots(new_e))) /* make sure the end slot (sp) is correct */ - for (sp = let_slots(new_e); tis_slot(next_slot(sp)); sp = next_slot(sp)); - continue; - - default: - wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), p, a_symbol_string); - } - - if (is_constant_symbol(sc, sym)) - wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), sym, a_non_constant_symbol_string); + { + s7_pointer p = car(x), sym, val; + + switch (type(p)) + { + case T_SYMBOL: + sym = (is_keyword(p)) ? keyword_symbol(p) : p; + if (!is_pair(cdr(x))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A: entry ~S, but no value: ~S", 30), caller, p, bindings)); + x = cdr(x); + val = car(x); + break; + + case T_PAIR: + sym = car(p); + if (!is_symbol(sym)) + wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), p, a_symbol_string); + if (is_keyword(sym)) + sym = keyword_symbol(sym); + val = cdr(p); + break; + + case T_LET: + if ((p == sc->rootlet) || (new_e == sc->s7_starlet)) continue; + append_let(sc, new_e, check_c_object_let(sc, p, caller)); + if (tis_slot(let_slots(new_e))) /* make sure the end slot (sp) is correct */ + for (sp = let_slots(new_e); tis_slot(next_slot(sp)); sp = next_slot(sp)); + continue; + + default: + wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), p, a_symbol_string); + } + + if (is_constant_symbol(sc, sym)) + wrong_type_error_nr(sc, caller, 1 + position_of(x, bindings), sym, a_non_constant_symbol_string); #if 0 - if ((is_slot(global_slot(sym))) && - (is_syntax_or_qq(global_value(sym)))) - wrong_type_error_nr(sc, caller, 2, sym, wrap_string(sc, "a non-syntactic symbol", 22)); - /* this is a local redefinition which we accept elsewhere: (let ((if 3)) if) -> 3 */ -#endif - /* here we know new_e is a let and is not rootlet */ - if (!sp) - sp = add_slot_checked_with_id(sc, new_e, sym, val); - else - { - if (sc->free_heap_top <= sc->free_heap_trigger) try_to_call_gc(sc); /* or maybe add add_slot_at_end_checked? */ - sp = inline_add_slot_at_end(sc, let_id(new_e), sp, sym, val); - set_local(sym); /* ? */ - } - check_let_fallback(sc, sym, new_e); - } + if ((is_slot(global_slot(sym))) && + (is_syntax_or_qq(global_value(sym)))) + wrong_type_error_nr(sc, caller, 2, sym, wrap_string(sc, "a non-syntactic symbol", 22)); + /* this is a local redefinition which we accept elsewhere: (let ((if 3)) if) -> 3 */ +#endif + /* here we know new_e is a let and is not rootlet */ + if (!sp) + sp = add_slot_checked_with_id(sc, new_e, sym, val); + else + { + if (sc->free_heap_top <= sc->free_heap_trigger) try_to_call_gc(sc); /* or maybe add add_slot_at_end_checked? */ + sp = inline_add_slot_at_end(sc, let_id(new_e), sp, sym, val); + set_local(sym); /* ? */ + } + check_let_fallback(sc, sym, new_e); + } sc->temp3 = sc->unused; } return(new_e); @@ -9895,9 +9895,9 @@ static s7_pointer g_sublet(s7_scheme *sc, s7_pointer args) else if (e != sc->rootlet) { - check_method(sc, e, sc->sublet_symbol, args); - if (!is_let(e)) - wrong_type_error_nr(sc, sc->sublet_symbol, 1, e, a_let_string); + check_method(sc, e, sc->sublet_symbol, args); + if (!is_let(e)) + wrong_type_error_nr(sc, sc->sublet_symbol, 1, e, a_let_string); } return(sublet_1(sc, e, cdr(args), sc->sublet_symbol)); } @@ -9918,8 +9918,8 @@ static s7_pointer sublet_chooser(s7_scheme *sc, s7_pointer f, int32_t num_args, { s7_pointer args = cdr(expr); if ((is_pair(car(args))) && (caar(args) == sc->curlet_symbol) && (is_null(cdar(args))) && - (is_quoted_symbol(cadr(args)))) - return(sc->sublet_curlet); + (is_quoted_symbol(cadr(args)))) + return(sc->sublet_curlet); } return(f); } @@ -9948,14 +9948,14 @@ static s7_pointer g_simple_inlet(s7_scheme *sc, s7_pointer args) { s7_pointer symbol = car(x); if (is_keyword(symbol)) /* (inlet ':allow-other-keys 3) */ - symbol = keyword_symbol(symbol); + symbol = keyword_symbol(symbol); if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */ - wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); + wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); if (!sp) - { - add_slot_unchecked(sc, new_e, symbol, cadr(x), id); - sp = let_slots(new_e); - } + { + add_slot_unchecked(sc, new_e, symbol, cadr(x), id); + sp = let_slots(new_e); + } else sp = inline_add_slot_at_end(sc, id, sp, symbol, cadr(x)); } sc->temp3 = sc->unused; @@ -10000,10 +10000,10 @@ static s7_pointer internal_inlet(s7_scheme *sc, s7_int num_args, ...) s7_pointer symbol = va_arg(ap, s7_pointer); s7_pointer value = va_arg(ap, s7_pointer); if (!sp) - { - add_slot_unchecked(sc, new_e, symbol, value, id); - sp = let_slots(new_e); - } + { + add_slot_unchecked(sc, new_e, symbol, value, id); + sp = let_slots(new_e); + } else sp = inline_add_slot_at_end(sc, id, sp, symbol, value); } va_end(ap); @@ -10014,8 +10014,8 @@ static s7_pointer internal_inlet(s7_scheme *sc, s7_int num_args, ...) static bool is_proper_quote(s7_scheme *sc, s7_pointer p) { return((is_safe_quoted_pair(p)) && - (is_pair(cdr(p))) && - (is_null(cddr(p)))); + (is_pair(cdr(p))) && + (is_null(cddr(p)))); } static s7_pointer inlet_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) @@ -10024,25 +10024,25 @@ static s7_pointer inlet_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_po ((args % 2) == 0)) { for (s7_pointer p = cdr(expr); is_pair(p); p = cddr(p)) - { - s7_pointer sym; - if (is_symbol_and_keyword(car(p))) /* (inlet :if ...) */ - sym = keyword_symbol(car(p)); - else - { - if (!is_proper_quote(sc, car(p))) return(f); /* (inlet abs ...) */ - sym = cadar(p); /* looking for (inlet 'a ...) */ - if (!is_symbol(sym)) return(f); /* (inlet '(a . 3) ...) */ - if (is_keyword(sym)) sym = keyword_symbol(sym); /* (inlet ':abs ...) */ - } - if ((is_possibly_constant(sym)) || /* (inlet 'define-constant ...) or (inlet 'pi ...) */ - (is_syntactic_symbol(sym)) || /* (inlet 'if 3) */ - ((is_slot(global_slot(sym))) && - (is_syntax_or_qq(global_value(sym)))) || /* (inlet 'quasiquote 1) */ - (sym == sc->let_ref_fallback_symbol) || - (sym == sc->let_set_fallback_symbol)) - return(f); - } + { + s7_pointer sym; + if (is_symbol_and_keyword(car(p))) /* (inlet :if ...) */ + sym = keyword_symbol(car(p)); + else + { + if (!is_proper_quote(sc, car(p))) return(f); /* (inlet abs ...) */ + sym = cadar(p); /* looking for (inlet 'a ...) */ + if (!is_symbol(sym)) return(f); /* (inlet '(a . 3) ...) */ + if (is_keyword(sym)) sym = keyword_symbol(sym); /* (inlet ':abs ...) */ + } + if ((is_possibly_constant(sym)) || /* (inlet 'define-constant ...) or (inlet 'pi ...) */ + (is_syntactic_symbol(sym)) || /* (inlet 'if 3) */ + ((is_slot(global_slot(sym))) && + (is_syntax_or_qq(global_value(sym)))) || /* (inlet 'quasiquote 1) */ + (sym == sc->let_ref_fallback_symbol) || + (sym == sc->let_set_fallback_symbol)) + return(f); + } return(sc->simple_inlet); } return(f); @@ -10068,11 +10068,11 @@ s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let) if (let == sc->rootlet) { for (s7_pointer lib = global_value(sc->libraries_symbol); is_pair(lib); lib = cdr(lib)) - sc->w = cons(sc, caar(lib), sc->w); + sc->w = cons(sc, caar(lib), sc->w); sc->w = cons(sc, cons(sc, sc->libraries_symbol, sc->w), sc->nil); for (s7_pointer y = sc->rootlet_slots; tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) != sc->libraries_symbol) - sc->w = cons_unchecked(sc, cons(sc, slot_symbol(y), abbreviate_let(sc, slot_value(y))), sc->w); + if (slot_symbol(y) != sc->libraries_symbol) + sc->w = cons_unchecked(sc, cons(sc, slot_symbol(y), abbreviate_let(sc, slot_value(y))), sc->w); sc->w = proper_list_reverse_in_place(sc, sc->w); } else @@ -10082,30 +10082,30 @@ s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let) /* need to check make-iterator method before dropping into let->list */ if ((has_active_methods(sc, let)) && - ((func = find_method(sc, let, sc->make_iterator_symbol)) != sc->undefined)) - iter = s7_apply_function(sc, func, set_plist_1(sc, let)); + ((func = find_method(sc, let, sc->make_iterator_symbol)) != sc->undefined)) + iter = s7_apply_function(sc, func, set_plist_1(sc, let)); else - if (let == sc->s7_starlet) /* (let->list *s7*) via s7_starlet_make_iterator */ - { - iter = s7_make_iterator(sc, let); - gc_loc = gc_protect_1(sc, iter); - } - else iter = sc->nil; + if (let == sc->s7_starlet) /* (let->list *s7*) via s7_starlet_make_iterator */ + { + iter = s7_make_iterator(sc, let); + gc_loc = gc_protect_1(sc, iter); + } + else iter = sc->nil; if (is_null(iter)) - for (x = let_slots(let); tis_slot(x); x = next_slot(x)) - sc->w = cons_unchecked(sc, cons(sc, slot_symbol(x), slot_value(x)), sc->w); + for (x = let_slots(let); tis_slot(x); x = next_slot(x)) + sc->w = cons_unchecked(sc, cons(sc, slot_symbol(x), slot_value(x)), sc->w); else - /* (begin (load "mockery.scm") (let ((lt ((*mock-pair* 'mock-pair) 1 2 3))) (format *stderr* "~{~A ~}" lt))) */ - while (true) - { - x = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - sc->w = cons(sc, x, sc->w); - } + /* (begin (load "mockery.scm") (let ((lt ((*mock-pair* 'mock-pair) 1 2 3))) (format *stderr* "~{~A ~}" lt))) */ + while (true) + { + x = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + sc->w = cons(sc, x, sc->w); + } sc->w = proper_list_reverse_in_place(sc, sc->w); if (gc_loc != -1) - s7_gc_unprotect_at(sc, gc_loc); + s7_gc_unprotect_at(sc, gc_loc); } x = sc->w; sc->w = sc->temp3; @@ -10124,12 +10124,12 @@ static s7_pointer g_let_to_list(s7_scheme *sc, s7_pointer args) if (!is_let(let)) { if (is_c_object(let)) - let = c_object_let(let); + let = c_object_let(let); else - if (is_c_pointer(let)) - let = c_pointer_info(let); + if (is_c_pointer(let)) + let = c_pointer_info(let); if (let == sc->rootlet) /* don't laboriously expand this! */ - return(cons(sc, let, sc->nil)); + return(cons(sc, let, sc->nil)); if (!is_let(let)) sole_arg_wrong_type_error_nr(sc, sc->let_to_list_symbol, let, a_let_string); } @@ -10169,12 +10169,12 @@ static /* inline */ s7_pointer let_ref(s7_scheme *sc, s7_pointer let, s7_pointer { let = find_let(sc, let); if (!is_let(let)) - wrong_type_error_nr(sc, sc->let_ref_symbol, 1, let, a_let_string); + wrong_type_error_nr(sc, sc->let_ref_symbol, 1, let, a_let_string); } if (!is_symbol(symbol)) { if ((let != sc->rootlet) && (has_let_ref_fallback(let))) /* let-ref|set-fallback refer to (explicit) let-ref in various forms, not the method lookup process */ - return(call_let_ref_fallback(sc, let, symbol)); + return(call_let_ref_fallback(sc, let, symbol)); wrong_type_error_nr(sc, sc->let_ref_symbol, 2, symbol, a_symbol_string); } /* a let-ref method is almost impossible to write without creating an infinite loop: @@ -10195,7 +10195,7 @@ static /* inline */ s7_pointer let_ref(s7_scheme *sc, s7_pointer let, s7_pointer for (s7_pointer x = let; x; x = let_outlet(x)) for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) - return(slot_value(y)); + return(slot_value(y)); if (is_openlet(let)) { @@ -10203,7 +10203,7 @@ static /* inline */ s7_pointer let_ref(s7_scheme *sc, s7_pointer let, s7_pointer * versus keys), and we can't just try again here because that makes it too easy to get into infinite recursion. So, 'let-ref-fallback... */ if (has_let_ref_fallback(let)) - return(call_let_ref_fallback(sc, let, symbol)); + return(call_let_ref_fallback(sc, let, symbol)); } return((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined); /* (let () ((curlet) 'pi)) */ } @@ -10216,7 +10216,7 @@ static s7_pointer g_let_ref(s7_scheme *sc, s7_pointer args) #define Q_let_ref s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol) if (!is_pair(cdr(args))) error_nr(sc, sc->syntax_error_symbol, - set_elist_2(sc, wrap_string(sc, "let-ref: symbol missing: ~S", 27), set_ulist_1(sc, sc->let_ref_symbol, args))); + set_elist_2(sc, wrap_string(sc, "let-ref: symbol missing: ~S", 27), set_ulist_1(sc, sc->let_ref_symbol, args))); return(let_ref(sc, car(args), cadr(args))); } @@ -10237,7 +10237,7 @@ static s7_pointer let_ref_p_pp(s7_scheme *sc, s7_pointer lt, s7_pointer sym) for (s7_pointer x = lt; x; x = let_outlet(x)) for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == sym) - return(slot_value(y)); + return(slot_value(y)); if ((lt != sc->nil) && (has_let_ref_fallback(lt))) return(call_let_ref_fallback(sc, lt, sym)); return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); @@ -10264,12 +10264,12 @@ static s7_pointer let_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_ar { s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); if ((car(arg1) == sc->cdr_symbol) && - (is_quoted_symbol(arg2)) && - (!is_possibly_constant(cadr(arg2)))) - { - set_opt3_sym(cdr(expr), cadr(arg2)); - return(sc->simple_let_ref); - }} + (is_quoted_symbol(arg2)) && + (!is_possibly_constant(cadr(arg2)))) + { + set_opt3_sym(cdr(expr), cadr(arg2)); + return(sc->simple_let_ref); + }} return(f); } @@ -10311,20 +10311,20 @@ static s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7 { s7_pointer slot; if (is_constant_symbol(sc, symbol)) /* (let-set! (rootlet) 'pi #f) */ - wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, a_non_constant_symbol_string); + wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, a_non_constant_symbol_string); /* it would be nice if safety>0 to add an error check for bad arity if a built-in method is set (set! (lt 'write) hash-table-set!), * built_in being is_slot(initial_slot(sym)), but this function is called a ton, and this error can't easily be * checked by the optimizer (we see the names, but not the values, so bad arity check requires assumptions about those values). */ slot = global_slot(symbol); if (!is_slot(slot)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), symbol, let)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), symbol, let)); if (is_syntax(slot_value(slot))) - wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, wrap_string(sc, "a non-syntactic symbol", 22)); + wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, wrap_string(sc, "a non-syntactic symbol", 22)); if (is_immutable(slot)) - immutable_object_error_nr(sc, set_elist_4(sc, wrap_string(sc, "~S is immutable in (let-set! (rootlet) '~S ~S)", 46), - symbol, symbol, value)); /* also (set! (with-let...)...) */ + immutable_object_error_nr(sc, set_elist_4(sc, wrap_string(sc, "~S is immutable in (let-set! (rootlet) '~S ~S)", 46), + symbol, symbol, value)); /* also (set! (with-let...)...) */ symbol_increment_ctr(symbol); slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, value) : value); return(slot_value(slot)); @@ -10336,20 +10336,20 @@ static s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7 s7_pointer slot = local_slot(symbol); if (is_slot(slot)) { - symbol_increment_ctr(symbol); - return(checked_slot_set_value(sc, slot, value)); + symbol_increment_ctr(symbol); + return(checked_slot_set_value(sc, slot, value)); }} for (s7_pointer x = let; x; x = let_outlet(x)) for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) - { - symbol_increment_ctr(symbol); - return(checked_slot_set_value(sc, y, value)); - } + { + symbol_increment_ctr(symbol); + return(checked_slot_set_value(sc, y, value)); + } if (!has_let_set_fallback(let)) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), symbol, let)); + set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), symbol, let)); /* not sure about this -- what's the most useful choice? */ return(call_let_set_fallback(sc, let, symbol, value)); } @@ -10361,7 +10361,7 @@ static s7_pointer let_set_2(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7 if (!is_symbol(symbol)) { if ((let != sc->rootlet) && (has_let_set_fallback(let))) - return(call_let_set_fallback(sc, let, symbol, value)); + return(call_let_set_fallback(sc, let, symbol, value)); wrong_type_error_nr(sc, sc->let_set_symbol, 2, symbol, a_symbol_string); } /* currently let-set! is immutable, so we don't have to check for a let-set! method (so let_set! is always global) */ @@ -10378,7 +10378,7 @@ static s7_pointer g_let_set(s7_scheme *sc, s7_pointer args) if (!is_pair(cdr(args))) /* (let ((a 123.0)) (define (f) (set! (let-ref) a)) (catch #t f (lambda args #f)) (f)) */ error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S: not enough arguments: ~S", 28), sc->let_set_symbol, sc->code)); + set_elist_3(sc, wrap_string(sc, "~S: not enough arguments: ~S", 28), sc->let_set_symbol, sc->code)); return(let_set_2(sc, car(args), cadr(args), caddr(args))); } @@ -10399,14 +10399,14 @@ static s7_pointer g_simple_let_set(s7_scheme *sc, s7_pointer args) if (lt != sc->rootlet) { for (s7_pointer x = lt; x; x = let_outlet(x)) - for (y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == sym) - { - slot_set_value(y, (slot_has_setter(y)) ? call_setter(sc, y, val) : val); - return(slot_value(y)); - } + for (y = let_slots(x); tis_slot(y); y = next_slot(y)) + if (slot_symbol(y) == sym) + { + slot_set_value(y, (slot_has_setter(y)) ? call_setter(sc, y, val) : val); + return(slot_value(y)); + } if ((lt != sc->rootlet) && (has_let_set_fallback(lt))) - return(call_let_set_fallback(sc, lt, sym, val)); + return(call_let_set_fallback(sc, lt, sym, val)); } y = global_slot(sym); if (!is_slot(y)) @@ -10421,10 +10421,10 @@ static s7_pointer let_set_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_ar { s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); if ((car(arg1) == sc->cdr_symbol) && - (is_quoted_pair(arg2)) && - (!is_possibly_constant(cadr(arg2))) && - (!is_possibly_constant(arg3))) - return(sc->simple_let_set); + (is_quoted_pair(arg2)) && + (!is_possibly_constant(cadr(arg2))) && + (!is_possibly_constant(arg3))) + return(sc->simple_let_set); } return(f); } @@ -10460,23 +10460,23 @@ static s7_pointer let_copy(s7_scheme *sc, s7_pointer let) s7_int id = let_id(new_e); s7_pointer y = NULL; for (s7_pointer x = let_slots(let); tis_slot(x); x = next_slot(x)) - { - s7_pointer z; - new_cell(sc, z, T_SLOT); - slot_set_symbol_and_value(z, slot_symbol(x), slot_value(x)); - if (symbol_id(slot_symbol(z)) != id) /* keep shadowing intact */ - symbol_set_local_slot(slot_symbol(x), id, z); - if (slot_has_setter(x)) - { - slot_set_setter(z, slot_setter(x)); - slot_set_has_setter(z); - } - if (y) - slot_set_next(y, z); - else let_set_slots(new_e, z); - slot_set_next(z, slot_end); /* in case GC runs during this loop */ - y = z; - }} + { + s7_pointer z; + new_cell(sc, z, T_SLOT); + slot_set_symbol_and_value(z, slot_symbol(x), slot_value(x)); + if (symbol_id(slot_symbol(z)) != id) /* keep shadowing intact */ + symbol_set_local_slot(slot_symbol(x), id, z); + if (slot_has_setter(x)) + { + slot_set_setter(z, slot_setter(x)); + slot_set_has_setter(z); + } + if (y) + slot_set_next(y, z); + else let_set_slots(new_e, z); + slot_set_next(z, slot_end); /* in case GC runs during this loop */ + y = z; + }} /* We can't do a (normal) loop here then reverse the slots later because the symbol's local_slot has to * match the unshadowed slot, not the last in the list: * (let ((e1 (inlet 'a 1 'a 2))) (let ((e2 (copy e1))) (list (equal? e1 e2) (equal? (e1 'a) (e2 'a))))) @@ -10534,7 +10534,7 @@ static void update_symbol_ids(s7_scheme *sc, s7_pointer e) { s7_pointer sym = slot_symbol(p); if (symbol_id(sym) != sc->let_number) - symbol_set_local_slot_unincremented(sym, sc->let_number, p); + symbol_set_local_slot_unincremented(sym, sc->let_number, p); } } @@ -10590,9 +10590,9 @@ static s7_pointer g_set_outlet(s7_scheme *sc, s7_pointer args) { /* here it's possible to get cyclic let chains; maybe do this check only if safety>0 */ for (s7_pointer lt = new_outer; lt; lt = let_outlet(lt)) - if (let == lt) - error_nr(sc, make_symbol(sc, "cyclic-let", 10), - set_elist_2(sc, wrap_string(sc, "set! (outlet ~A) creates a cyclic let chain", 43), let)); + if (let == lt) + error_nr(sc, make_symbol(sc, "cyclic-let", 10), + set_elist_2(sc, wrap_string(sc, "set! (outlet ~A) creates a cyclic let chain", 43), let)); let_set_outlet(let, new_outer); } return(new_outer); @@ -10607,12 +10607,12 @@ static Inline s7_pointer inline_lookup_from(s7_scheme *sc, const s7_pointer symb { do {e = let_outlet(e);} while (let_id(e) > symbol_id(symbol)); if (let_id(e) == symbol_id(symbol)) - return(local_value(symbol)); + return(local_value(symbol)); } for (; e; e = let_outlet(e)) for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) - return(slot_value(y)); + return(slot_value(y)); if (is_slot(global_slot(symbol))) return(global_value(symbol)); @@ -10640,12 +10640,12 @@ static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e) { do {e = let_outlet(e);} while (let_id(e) > symbol_id(symbol)); if (let_id(e) == symbol_id(symbol)) - return(local_slot(symbol)); + return(local_slot(symbol)); } for (; e; e = let_outlet(e)) for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) - return(y); + return(y); return(global_slot(symbol)); } @@ -10665,7 +10665,7 @@ static s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_poin if (symbol_id(symbol) != 0) for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) - return(y); + return(y); return(sc->undefined); } @@ -10683,12 +10683,12 @@ s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer let) { do {let = let_outlet(let);} while (let_id(let) > symbol_id(sym)); if (let_id(let) == symbol_id(sym)) - return(local_value(sym)); + return(local_value(sym)); } for (; let; let = let_outlet(let)) for (s7_pointer y = let_slots(let); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == sym) - return(slot_value(y)); + return(slot_value(y)); /* maybe let is local but sym is global but previously shadowed */ if (is_slot(global_slot(sym))) @@ -10719,23 +10719,23 @@ symbol sym in the given let: (let ((x 32)) (symbol->value 'x)) -> 32" if (is_keyword(sym)) { if ((is_pair(cdr(args))) && (!is_let(cadr(args))) && (!is_let(find_let(sc, cadr(args))))) - wrong_type_error_nr(sc, sc->symbol_to_value_symbol, 2, cadr(args), sc->type_names[T_LET]); + wrong_type_error_nr(sc, sc->symbol_to_value_symbol, 2, cadr(args), sc->type_names[T_LET]); return(sym); } if (is_not_null(cdr(args))) { s7_pointer local_let = cadr(args); if (local_let == sc->unlet_symbol) - return((is_slot(initial_slot(sym))) ? initial_value(sym) : sc->undefined); + return((is_slot(initial_slot(sym))) ? initial_value(sym) : sc->undefined); if (!is_let(local_let)) - { - local_let = find_let(sc, local_let); - if (!is_let(local_let)) - return(method_or_bust(sc, cadr(args), sc->symbol_to_value_symbol, args, a_let_string, 2)); /* not local_let */ - } + { + local_let = find_let(sc, local_let); + if (!is_let(local_let)) + return(method_or_bust(sc, cadr(args), sc->symbol_to_value_symbol, args, a_let_string, 2)); /* not local_let */ + } if (local_let == sc->s7_starlet) - return(s7_starlet(sc, s7_starlet_symbol(sym))); + return(s7_starlet(sc, s7_starlet_symbol(sym))); return(s7_symbol_local_value(sc, sym, local_let)); } @@ -10765,10 +10765,10 @@ static s7_pointer find_dynamic_value(s7_scheme *sc, s7_pointer x, s7_pointer sym for (; (x) && (let_id(x) > (*id)); x = let_outlet(x)) for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == sym) - { - (*id) = let_id(x); - return(slot_value(y)); - } + { + (*id) = let_id(x); + return(slot_value(y)); + } return(sc->unused); } @@ -10796,11 +10796,11 @@ static s7_pointer g_symbol_to_dynamic_value(s7_scheme *sc, s7_pointer args) for (int64_t i = stack_top(sc) - 1; i > 0; i -= 4) if (is_let_unchecked(stack_let(sc->stack, i))) /* OP_GC_PROTECT let slot can be anything (even free) */ { - s7_pointer cur_val = find_dynamic_value(sc, stack_let(sc->stack, i), sym, &top_id); - if (cur_val != sc->unused) - val = cur_val; - if (top_id == symbol_id(sym)) - return(val); + s7_pointer cur_val = find_dynamic_value(sc, stack_let(sc->stack, i), sym, &top_id); + if (cur_val != sc->unused) + val = cur_val; + if (top_id == symbol_id(sym)) + return(val); } return((val == sc->unused) ? s7_symbol_value(sc, sym) : val); } @@ -10809,7 +10809,7 @@ static bool direct_memq(const s7_pointer symbol, s7_pointer symbols) { for (s7_pointer x = symbols; is_pair(x); x = cdr(x)) if (car(x) == symbol) - return(true); + return(true); return(false); } @@ -10824,8 +10824,8 @@ static bool direct_assq(const s7_pointer symbol, s7_pointer symbols) static bool do_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) { return((is_slot(global_slot(sym))) || - (direct_assq(sym, e)) || - (is_slot(s7_slot(sc, sym)))); + (direct_assq(sym, e)) || + (is_slot(s7_slot(sc, sym)))); } static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) @@ -10840,20 +10840,20 @@ static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) static bool let_symbol_is_safe_or_listed(s7_scheme *sc, s7_pointer sym, s7_pointer e) { return((symbol_is_in_list(sc, sym)) || - (let_symbol_is_safe(sc, sym, e))); + (let_symbol_is_safe(sc, sym, e))); } static bool let_star_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) { return((symbol_is_in_list(sc, sym)) || - (is_slot(global_slot(sym))) || - ((is_let(e)) && (!is_with_let_let(e)) && (is_slot(s7_slot(sc, sym))))); + (is_slot(global_slot(sym))) || + ((is_let(e)) && (!is_with_let_let(e)) && (is_slot(s7_slot(sc, sym))))); } static bool pair_symbol_is_safe(s7_scheme *unused_sc, s7_pointer sym, s7_pointer e) { return((is_slot(global_slot(sym))) || - (direct_memq(sym, e))); + (direct_memq(sym, e))); } static s7_pointer collect_variables(s7_scheme *sc, s7_pointer lst, s7_pointer e) @@ -10880,12 +10880,12 @@ static s7_pointer collect_parameters(s7_scheme *sc, s7_pointer lst, s7_pointer e { s7_pointer car_p = car(p); if (is_pair(car_p)) - car_p = car(car_p); + car_p = car(car_p); if (is_normal_symbol(car_p)) - { - symbol_set_id(car_p, the_un_id); - sc->w = cons(sc, add_symbol_to_list(sc, car_p), sc->w); - }} + { + symbol_set_id(car_p, the_un_id); + sc->w = cons(sc, add_symbol_to_list(sc, car_p), sc->w); + }} if (is_symbol(p)) /* rest arg */ { symbol_set_id(p, the_un_id); @@ -10905,12 +10905,12 @@ static void clear_all_optimizations(s7_scheme *sc, s7_pointer p) if (is_pair(p)) { if ((is_optimized(p)) && - (((optimize_op(p) >= FIRST_UNHOPPABLE_OP) || /* avoid clearing hop ops, fx_function and op_unknown* need to be cleared */ - (!op_has_hop(p))))) - { - clear_optimized(p); /* includes T_SYNTACTIC */ - clear_optimize_op(p); - } + (((optimize_op(p) >= FIRST_UNHOPPABLE_OP) || /* avoid clearing hop ops, fx_function and op_unknown* need to be cleared */ + (!op_has_hop(p))))) + { + clear_optimized(p); /* includes T_SYNTACTIC */ + clear_optimize_op(p); + } clear_all_optimizations(sc, cdr(p)); clear_all_optimizations(sc, car(p)); } @@ -10994,24 +10994,24 @@ static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named) s7_pointer mac_slot; mac_name = caar(sc->code); if (((op == OP_DEFINE_EXPANSION) || (op == OP_DEFINE_EXPANSION_STAR)) && - (sc->curlet == sc->rootlet)) - set_full_type(mac_name, T_EXPANSION | T_SYMBOL | (full_type(mac_name) & T_UNHEAP)); + (sc->curlet == sc->rootlet)) + set_full_type(mac_name, T_EXPANSION | T_SYMBOL | (full_type(mac_name) & T_UNHEAP)); /* symbol? macro name has already been checked, find name in let, and define it */ mac_slot = symbol_to_local_slot(sc, mac_name, sc->curlet); /* returns global_slot(symbol) if sc->curlet == nil */ if (is_slot(mac_slot)) - { - if (is_immutable_slot(mac_slot)) - immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't ~S ~S; it is immutable", 28), cur_op_to_caller(sc, op), mac_name)); - - if ((sc->curlet == sc->nil) && (!in_rootlet(mac_slot))) - add_slot_to_rootlet(sc, mac_slot); - slot_set_value_with_hook(mac_slot, mac); - } + { + if (is_immutable_slot(mac_slot)) + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't ~S ~S; it is immutable", 28), cur_op_to_caller(sc, op), mac_name)); + + if ((sc->curlet == sc->nil) && (!in_rootlet(mac_slot))) + add_slot_to_rootlet(sc, mac_slot); + slot_set_value_with_hook(mac_slot, mac); + } else s7_make_slot(sc, sc->curlet, mac_name, mac); /* was current but we've checked immutable already */ if (tree_has_definers(sc, body)) - set_is_definer(mac_name); /* (list-values 'define ...) aux-13 */ + set_is_definer(mac_name); /* (list-values 'define ...) aux-13 */ } if ((!is_either_bacro(mac)) && @@ -11027,10 +11027,10 @@ static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named) set_pair_macro(closure_body(mac), mac_name); set_has_pair_macro(mac); if (has_location(car(sc->code))) - { - pair_set_location(closure_body(mac), pair_location(car(sc->code))); - set_has_location(closure_body(mac)); - }} + { + pair_set_location(closure_body(mac), pair_location(car(sc->code))); + set_has_location(closure_body(mac)); + }} /* passed to maclet in apply_macro et al, copied in copy_closure */ return(mac); } @@ -11124,8 +11124,8 @@ static s7_pointer copy_tree_with_type(s7_scheme *sc, s7_pointer tree) #define COPY_TREE_WITH_TYPE(P) copy_tree_with_type(sc, P) #endif return(cons_unchecked_with_type(sc, tree, - (is_unquoted_pair(car(tree))) ? COPY_TREE_WITH_TYPE(car(tree)) : car(tree), - (is_unquoted_pair(cdr(tree))) ? COPY_TREE_WITH_TYPE(cdr(tree)) : cdr(tree))); + (is_unquoted_pair(car(tree))) ? COPY_TREE_WITH_TYPE(car(tree)) : car(tree), + (is_unquoted_pair(cdr(tree))) ? COPY_TREE_WITH_TYPE(cdr(tree)) : cdr(tree))); } static inline s7_pointer copy_tree(s7_scheme *sc, s7_pointer tree) @@ -11138,8 +11138,8 @@ static inline s7_pointer copy_tree(s7_scheme *sc, s7_pointer tree) #define COPY_TREE(P) copy_tree(sc, P) #endif return(cons_unchecked(sc, - (is_unquoted_pair(car(tree))) ? COPY_TREE(car(tree)) : car(tree), - (is_pair(cdr(tree))) ? COPY_TREE(cdr(tree)) : cdr(tree))); + (is_unquoted_pair(car(tree))) ? COPY_TREE(car(tree)) : car(tree), + (is_pair(cdr(tree))) ? COPY_TREE(cdr(tree)) : cdr(tree))); } @@ -11156,22 +11156,22 @@ static int32_t tree_is_cyclic_or_has_pairs(s7_scheme *sc, s7_pointer tree) { if (tree_is_collected(fast)) return(TREE_CYCLIC); if ((!has_pairs) && (is_unquoted_pair(car(fast)))) - has_pairs = true; + has_pairs = true; fast = cdr(fast); if (!is_pair(fast)) - { - if (!has_pairs) return(TREE_NOT_CYCLIC); - break; - } + { + if (!has_pairs) return(TREE_NOT_CYCLIC); + break; + } if (tree_is_collected(fast)) return(TREE_CYCLIC); if ((!has_pairs) && (is_unquoted_pair(car(fast)))) - has_pairs = true; + has_pairs = true; fast = cdr(fast); if (!is_pair(fast)) - { - if (!has_pairs) return(TREE_NOT_CYCLIC); - break; - } + { + if (!has_pairs) return(TREE_NOT_CYCLIC); + break; + } slow = cdr(slow); if (fast == slow) return(TREE_CYCLIC); } @@ -11186,29 +11186,29 @@ static bool tree_is_cyclic_1(s7_scheme *sc, s7_pointer tree) { tree_set_collected(p); if (sc->tree_pointers_top == sc->tree_pointers_size) - { - if (sc->tree_pointers_size == 0) - { - sc->tree_pointers_size = 8; - sc->tree_pointers = (s7_pointer *)Malloc(sc->tree_pointers_size * sizeof(s7_pointer)); - } - else - { - sc->tree_pointers_size *= 2; - sc->tree_pointers = (s7_pointer *)Realloc(sc->tree_pointers, sc->tree_pointers_size * sizeof(s7_pointer)); - }} + { + if (sc->tree_pointers_size == 0) + { + sc->tree_pointers_size = 8; + sc->tree_pointers = (s7_pointer *)Malloc(sc->tree_pointers_size * sizeof(s7_pointer)); + } + else + { + sc->tree_pointers_size *= 2; + sc->tree_pointers = (s7_pointer *)Realloc(sc->tree_pointers, sc->tree_pointers_size * sizeof(s7_pointer)); + }} sc->tree_pointers[sc->tree_pointers_top++] = p; if (is_unquoted_pair(car(p))) - { - int32_t old_top = sc->tree_pointers_top, result; - result = tree_is_cyclic_or_has_pairs(sc, car(p)); - if ((result == TREE_CYCLIC) || - (tree_is_cyclic_1(sc, car(p)))) - return(true); - for (int32_t i = old_top; i < sc->tree_pointers_top; i++) - tree_clear_collected(sc->tree_pointers[i]); - sc->tree_pointers_top = old_top; - }} + { + int32_t old_top = sc->tree_pointers_top, result; + result = tree_is_cyclic_or_has_pairs(sc, car(p)); + if ((result == TREE_CYCLIC) || + (tree_is_cyclic_1(sc, car(p)))) + return(true); + for (int32_t i = old_top; i < sc->tree_pointers_top; i++) + tree_clear_collected(sc->tree_pointers[i]); + sc->tree_pointers_top = old_top; + }} return(false); } @@ -11280,34 +11280,34 @@ Only the let is searched if ignore-globals is not #f." { s7_pointer e = cadr(args), b, x; if (!is_let(e)) - { - e = find_let(sc, e); /* returns () if none */ - if (!is_let(e)) - wrong_type_error_nr(sc, sc->is_defined_symbol, 2, cadr(args), a_let_string); /* not e */ - } + { + e = find_let(sc, e); /* returns () if none */ + if (!is_let(e)) + wrong_type_error_nr(sc, sc->is_defined_symbol, 2, cadr(args), a_let_string); /* not e */ + } if (is_keyword(sym)) /* if no "e", is global -> #t */ - { /* we're treating :x as 'x outside rootlet, but consider all keywords defined (as themselves) in rootlet? */ - if (e == sc->rootlet) return(sc->T); /* (defined? x (rootlet)) where x value is a keyword */ - sym = keyword_symbol(sym); /* (defined? :print-length *s7*) */ - } + { /* we're treating :x as 'x outside rootlet, but consider all keywords defined (as themselves) in rootlet? */ + if (e == sc->rootlet) return(sc->T); /* (defined? x (rootlet)) where x value is a keyword */ + sym = keyword_symbol(sym); /* (defined? :print-length *s7*) */ + } if (e == sc->s7_starlet) - return(make_boolean(sc, s7_starlet_symbol(sym) != SL_NO_FIELD)); + return(make_boolean(sc, s7_starlet_symbol(sym) != SL_NO_FIELD)); if (is_pair(cddr(args))) - { - b = caddr(args); - if (!is_boolean(b)) - return(method_or_bust(sc, b, sc->is_defined_symbol, args, a_boolean_string, 3)); - } + { + b = caddr(args); + if (!is_boolean(b)) + return(method_or_bust(sc, b, sc->is_defined_symbol, args, a_boolean_string, 3)); + } else b = sc->F; if (e == sc->rootlet) /* we checked (let? e) above */ - { - if (b == sc->F) - return(make_boolean(sc, is_slot(global_slot(sym)))); /* new_symbol and gensym initialize global_slot to #<undefined> */ - return(sc->F); - } + { + if (b == sc->F) + return(make_boolean(sc, is_slot(global_slot(sym)))); /* new_symbol and gensym initialize global_slot to #<undefined> */ + return(sc->F); + } x = symbol_to_local_slot(sc, sym, e); if (is_slot(x)) - return(sc->T); + return(sc->T); return((b == sc->T) ? sc->F : make_boolean(sc, is_slot(global_slot(sym)))); } return((is_global(sym)) ? sc->T : make_boolean(sc, is_slot(s7_slot(sc, sym)))); @@ -11331,10 +11331,10 @@ static s7_pointer is_defined_chooser(s7_scheme *sc, s7_pointer f, int32_t args, { s7_pointer e = caddr(expr); if ((is_pair(e)) && (is_null(cdr(e))) && (car(e) == sc->rootlet_symbol)) - { - set_safe_optimize_op(expr, HOP_SAFE_C_NC); - return(sc->is_defined_in_rootlet); - }} + { + set_safe_optimize_op(expr, HOP_SAFE_C_NC); + return(sc->is_defined_in_rootlet); + }} return(f); } @@ -11366,11 +11366,11 @@ void s7_define(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer valu s7_make_slot(sc, let, symbol, value); /* I think this means C code can override "constant" defs */ /* if let is rootlet, s7_make_slot makes a semipermanent_slot */ if ((let == sc->shadow_rootlet) && - (!is_slot(global_slot(symbol)))) - { - set_global(symbol); /* is_global => global_slot is usable -- is this a good idea? */ - set_global_slot(symbol, local_slot(symbol)); - }} + (!is_slot(global_slot(symbol)))) + { + set_global(symbol); /* is_global => global_slot is usable -- is this a good idea? */ + set_global_slot(symbol, local_slot(symbol)); + }} } s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value) @@ -11518,12 +11518,12 @@ void *s7_c_pointer_with_type(s7_scheme *sc, s7_pointer p, s7_pointer expected_ty if ((c_pointer(p) != NULL) && (c_pointer_type(p) != expected_type)) error_nr(sc, sc->wrong_type_arg_symbol, - (argnum == 0) ? - set_elist_4(sc, wrap_string(sc, "~S argument is a pointer of type ~S, but expected ~S", 52), - wrap_string(sc, caller, safe_strlen(caller)), c_pointer_type(p), expected_type) : - set_elist_5(sc, wrap_string(sc, "~S ~:D argument got a pointer of type ~S, but expected ~S", 57), - wrap_string(sc, caller, safe_strlen(caller)), - wrap_integer(sc, argnum), c_pointer_type(p), expected_type)); + (argnum == 0) ? + set_elist_4(sc, wrap_string(sc, "~S argument is a pointer of type ~S, but expected ~S", 52), + wrap_string(sc, caller, safe_strlen(caller)), c_pointer_type(p), expected_type) : + set_elist_5(sc, wrap_string(sc, "~S ~:D argument got a pointer of type ~S, but expected ~S", 57), + wrap_string(sc, caller, safe_strlen(caller)), + wrap_integer(sc, argnum), c_pointer_type(p), expected_type)); return(c_pointer(p)); } @@ -11575,16 +11575,16 @@ static s7_pointer g_c_pointer(s7_scheme *sc, s7_pointer args) type = car(args); args = cdr(args); if (is_pair(args)) - { - info = car(args); - args = cdr(args); - if (is_pair(args)) - { - weak1 = car(args); - args = cdr(args); - if (is_pair(args)) - weak2 = car(args); - }}} + { + info = car(args); + args = cdr(args); + if (is_pair(args)) + { + weak1 = car(args); + args = cdr(args); + if (is_pair(args)) + weak2 = car(args); + }}} cp = s7_make_c_pointer_with_type(sc, (void *)p, type, info); c_pointer_set_weak1(cp, weak1); c_pointer_set_weak2(cp, weak2); @@ -11718,50 +11718,50 @@ static s7_pointer copy_any_list(s7_scheme *sc, s7_pointer a) while (true) { if (!is_pair(fast)) - { - if (is_null(fast)) - wrap_return(sc->w); - set_cdr(p, fast); - wrap_return(sc->w); - } + { + if (is_null(fast)) + wrap_return(sc->w); + set_cdr(p, fast); + wrap_return(sc->w); + } set_cdr(p, list_1(sc, car(fast))); p = cdr(p); fast = cdr(fast); if (!is_pair(fast)) - { - if (is_null(fast)) - wrap_return(sc->w); - set_cdr(p, fast); - wrap_return(sc->w); - } + { + if (is_null(fast)) + wrap_return(sc->w); + set_cdr(p, fast); + wrap_return(sc->w); + } /* if unrolled further, it's a lot slower? */ set_cdr(p, list_1_unchecked(sc, car(fast))); p = cdr(p); fast = cdr(fast); slow = cdr(slow); if (fast == slow) - { - /* try to preserve the original cyclic structure */ - s7_pointer p1, f1, p2, f2; - set_match_pair(a); - for (p1 = sc->w, f1 = a; !(is_matched_pair(cdr(f1))); f1 = cdr(f1), p1 = cdr(p1)) - set_match_pair(f1); - for (p2 = sc->w, f2 = a; cdr(f1) != f2; f2 = cdr(f2), p2 = cdr(p2)) - clear_match_pair(f2); - for (f1 = f2; is_pair(f1); f1 = cdr(f1), f2 = cdr(f2)) - { - clear_match_pair(f1); - f1 = cdr(f1); - clear_match_pair(f1); - if (f1 == f2) break; - } - clear_match_pair(a); - if (is_null(p1)) - set_cdr(p2, p2); - else set_cdr(p1, p2); - wrap_return(sc->w); - }} + { + /* try to preserve the original cyclic structure */ + s7_pointer p1, f1, p2, f2; + set_match_pair(a); + for (p1 = sc->w, f1 = a; !(is_matched_pair(cdr(f1))); f1 = cdr(f1), p1 = cdr(p1)) + set_match_pair(f1); + for (p2 = sc->w, f2 = a; cdr(f1) != f2; f2 = cdr(f2), p2 = cdr(p2)) + clear_match_pair(f2); + for (f1 = f2; is_pair(f1); f1 = cdr(f1), f2 = cdr(f2)) + { + clear_match_pair(f1); + f1 = cdr(f1); + clear_match_pair(f1); + if (f1 == f2) break; + } + clear_match_pair(a); + if (is_null(p1)) + set_cdr(p2, p2); + else set_cdr(p1, p2); + wrap_return(sc->w); + }} wrap_return(sc->w); } @@ -11783,13 +11783,13 @@ static void copy_stack_list_set_immutable(s7_pointer pold, s7_pointer pnew) { if (is_immutable(p1)) set_immutable(p2); if (is_pair(cdr(p1))) - { - p1 = cdr(p1); - p2 = cdr(p2); - if (is_immutable(p1)) set_immutable(p2); - if (p1 == slow) break; - slow = cdr(slow); - }} + { + p1 = cdr(p1); + p2 = cdr(p2); + if (is_immutable(p1)) set_immutable(p2); + if (p1 == slow) break; + slow = cdr(slow); + }} } static s7_pointer copy_stack(s7_scheme *sc, s7_pointer new_v, s7_pointer old_v, int64_t top) @@ -11804,45 +11804,45 @@ static s7_pointer copy_stack(s7_scheme *sc, s7_pointer new_v, s7_pointer old_v, if (stack_has_counters(old_v)) { for (int64_t i = 2; i < top; i += 4) - { - s7_pointer p = ov[i]; /* args */ - /* if op_gc_protect, any ov[i] (except op) can be a list, but it isn't the arglist, so it seems to be safe */ - if (is_pair(p)) /* args need not be a list (it can be a port or #f, etc) */ - { - has_pairs = true; - if (is_null(cdr(p))) - nv[i] = cons_unchecked(sc, car(p), sc->nil); /* GC is off -- could uncheck list_2 et al also */ - else - if ((is_pair(cdr(p))) && (is_null(cddr(p)))) - nv[i] = list_2_unchecked(sc, car(p), cadr(p)); - else nv[i] = copy_any_list(sc, p); /* args (copy is needed -- see s7test.scm) */ - /* if op=eval_args4 for example, this has to be a proper list, and in many cases it doesn't need to be copied */ - copy_stack_list_set_immutable(p, nv[i]); - } - /* lst can be dotted or circular here. The circular list only happens in a case like: - * (dynamic-wind (lambda () (eq? (let ((lst (cons 1 2))) (set-cdr! lst lst) lst) (call/cc (lambda (k) k)))) (lambda () #f) (lambda () #f)) - * proper_list_reverse_in_place(sc->args) is one reason we need to copy, another reuse_as_let - */ - else - if (is_counter(p)) /* these can only occur in this context (not in a list etc) */ - { - stack_set_has_counters(new_v); - nv[i] = copy_counter(sc, p); - }}} + { + s7_pointer p = ov[i]; /* args */ + /* if op_gc_protect, any ov[i] (except op) can be a list, but it isn't the arglist, so it seems to be safe */ + if (is_pair(p)) /* args need not be a list (it can be a port or #f, etc) */ + { + has_pairs = true; + if (is_null(cdr(p))) + nv[i] = cons_unchecked(sc, car(p), sc->nil); /* GC is off -- could uncheck list_2 et al also */ + else + if ((is_pair(cdr(p))) && (is_null(cddr(p)))) + nv[i] = list_2_unchecked(sc, car(p), cadr(p)); + else nv[i] = copy_any_list(sc, p); /* args (copy is needed -- see s7test.scm) */ + /* if op=eval_args4 for example, this has to be a proper list, and in many cases it doesn't need to be copied */ + copy_stack_list_set_immutable(p, nv[i]); + } + /* lst can be dotted or circular here. The circular list only happens in a case like: + * (dynamic-wind (lambda () (eq? (let ((lst (cons 1 2))) (set-cdr! lst lst) lst) (call/cc (lambda (k) k)))) (lambda () #f) (lambda () #f)) + * proper_list_reverse_in_place(sc->args) is one reason we need to copy, another reuse_as_let + */ + else + if (is_counter(p)) /* these can only occur in this context (not in a list etc) */ + { + stack_set_has_counters(new_v); + nv[i] = copy_counter(sc, p); + }}} else for (int64_t i = 2; i < top; i += 4) if (is_pair(ov[i])) - { - s7_pointer p = ov[i]; - has_pairs = true; - if (is_null(cdr(p))) - nv[i] = cons_unchecked(sc, car(p), sc->nil); - else - if ((is_pair(cdr(p))) && (is_null(cddr(p)))) - nv[i] = list_2_unchecked(sc, car(p), cadr(p)); - else nv[i] = copy_any_list(sc, p); /* args (copy is needed -- see s7test.scm) */ - copy_stack_list_set_immutable(p, nv[i]); - } + { + s7_pointer p = ov[i]; + has_pairs = true; + if (is_null(cdr(p))) + nv[i] = cons_unchecked(sc, car(p), sc->nil); + else + if ((is_pair(cdr(p))) && (is_null(cddr(p)))) + nv[i] = list_2_unchecked(sc, car(p), cadr(p)); + else nv[i] = copy_any_list(sc, p); /* args (copy is needed -- see s7test.scm) */ + copy_stack_list_set_immutable(p, nv[i]); + } if (has_pairs) stack_set_has_pairs(new_v); s7_gc_on(sc, true); return(new_v); @@ -11873,8 +11873,8 @@ static bool find_baffle(s7_scheme *sc, s7_int key) if (sc->baffle_ctr > 0) for (s7_pointer x = sc->curlet; x; x = let_outlet(x)) if ((is_baffle_let(x)) && - (let_baffle_key(x) == key)) - return(true); + (let_baffle_key(x) == key)) + return(true); return(false); } @@ -11886,7 +11886,7 @@ static s7_int find_any_baffle(s7_scheme *sc) if (sc->baffle_ctr > 0) for (s7_pointer x = sc->curlet; x; x = let_outlet(x)) if (is_baffle_let(x)) - return(let_baffle_key(x)); + return(let_baffle_key(x)); return(NOT_BAFFLED); } @@ -11919,7 +11919,7 @@ static void make_room_for_cc_stack(s7_scheme *sc) { call_gc(sc); if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 8)) - resize_heap(sc); + resize_heap(sc); } } @@ -11981,91 +11981,91 @@ static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c) { opcode_t op = stack_op(sc->stack, i); switch (op) - { - case OP_DYNAMIC_WIND: - case OP_LET_TEMP_DONE: - { - s7_pointer x = stack_code(sc->stack, i); - int64_t s_base = 0; - for (int64_t j = 3; j < top2; j += 4) - if (((stack_op(continuation_stack(c), j) == OP_DYNAMIC_WIND) || - (stack_op(continuation_stack(c), j) == OP_LET_TEMP_DONE)) && - (x == stack_code(continuation_stack(c), j))) - { - s_base = i; - break; - } - if (s_base == 0) - { - if (op == OP_DYNAMIC_WIND) - { - if (dynamic_wind_state(x) == DWIND_BODY) - { - dynamic_wind_state(x) = DWIND_FINISH; - if (dynamic_wind_out(x) != sc->F) - sc->value = s7_call(sc, dynamic_wind_out(x), sc->nil); - /* free_cell is unsafe here and below */ - }} - else let_temp_done(sc, stack_args(sc->stack, i), T_Let(stack_let(sc->stack, i))); - }} - break; - - case OP_DYNAMIC_UNWIND: - case OP_DYNAMIC_UNWIND_PROFILE: - set_stack_op(sc->stack, i, OP_GC_PROTECT); - break; - - case OP_LET_TEMP_UNWIND: - let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); - break; - - case OP_LET_TEMP_S7_UNWIND: - s7_starlet_set_1(sc, T_Sym(stack_code(sc->stack, i)), stack_args(sc->stack, i)); - break; - - case OP_LET_TEMP_S7_DIRECT_UNWIND: - sc->has_openlets = (stack_args(sc->stack, i) != sc->F); - break; - - case OP_BARRIER: - if (i > top2) /* otherwise it's some unproblematic outer eval-string? */ - return(false); /* but what if we've already evaluated a dynamic-wind closer? */ - break; - - case OP_DEACTIVATE_GOTO: /* here we're jumping out of an unrelated call-with-exit block */ - if (i > top2) - call_exit_active(stack_args(sc->stack, i)) = false; - break; - - case OP_UNWIND_INPUT: - if (stack_args(sc->stack, i) != sc->unused) - set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ - break; - - case OP_UNWIND_OUTPUT: - if (stack_args(sc->stack, i) != sc->unused) - set_current_output_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ - break; - - default: - if ((S7_DEBUGGING) && (op == OP_MAP_UNWIND)) fprintf(stderr, "%s[%d]: unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); - break; - }} + { + case OP_DYNAMIC_WIND: + case OP_LET_TEMP_DONE: + { + s7_pointer x = stack_code(sc->stack, i); + int64_t s_base = 0; + for (int64_t j = 3; j < top2; j += 4) + if (((stack_op(continuation_stack(c), j) == OP_DYNAMIC_WIND) || + (stack_op(continuation_stack(c), j) == OP_LET_TEMP_DONE)) && + (x == stack_code(continuation_stack(c), j))) + { + s_base = i; + break; + } + if (s_base == 0) + { + if (op == OP_DYNAMIC_WIND) + { + if (dynamic_wind_state(x) == DWIND_BODY) + { + dynamic_wind_state(x) = DWIND_FINISH; + if (dynamic_wind_out(x) != sc->F) + sc->value = s7_call(sc, dynamic_wind_out(x), sc->nil); + /* free_cell is unsafe here and below */ + }} + else let_temp_done(sc, stack_args(sc->stack, i), T_Let(stack_let(sc->stack, i))); + }} + break; + + case OP_DYNAMIC_UNWIND: + case OP_DYNAMIC_UNWIND_PROFILE: + set_stack_op(sc->stack, i, OP_GC_PROTECT); + break; + + case OP_LET_TEMP_UNWIND: + let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); + break; + + case OP_LET_TEMP_S7_UNWIND: + s7_starlet_set_1(sc, T_Sym(stack_code(sc->stack, i)), stack_args(sc->stack, i)); + break; + + case OP_LET_TEMP_S7_DIRECT_UNWIND: + sc->has_openlets = (stack_args(sc->stack, i) != sc->F); + break; + + case OP_BARRIER: + if (i > top2) /* otherwise it's some unproblematic outer eval-string? */ + return(false); /* but what if we've already evaluated a dynamic-wind closer? */ + break; + + case OP_DEACTIVATE_GOTO: /* here we're jumping out of an unrelated call-with-exit block */ + if (i > top2) + call_exit_active(stack_args(sc->stack, i)) = false; + break; + + case OP_UNWIND_INPUT: + if (stack_args(sc->stack, i) != sc->unused) + set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ + break; + + case OP_UNWIND_OUTPUT: + if (stack_args(sc->stack, i) != sc->unused) + set_current_output_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ + break; + + default: + if ((S7_DEBUGGING) && (op == OP_MAP_UNWIND)) fprintf(stderr, "%s[%d]: unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); + break; + }} /* check continuation-stack for dynamic-winds we're jumping into */ for (int64_t i = stack_top(sc) - 1; i < top2; i += 4) { opcode_t op = stack_op(continuation_stack(c), i); if (op == OP_DYNAMIC_WIND) - { - s7_pointer x = T_Dyn(stack_code(continuation_stack(c), i)); - if (dynamic_wind_in(x) != sc->F) - sc->value = s7_call(sc, dynamic_wind_in(x), sc->nil); - dynamic_wind_state(x) = DWIND_BODY; - } + { + s7_pointer x = T_Dyn(stack_code(continuation_stack(c), i)); + if (dynamic_wind_in(x) != sc->F) + sc->value = s7_call(sc, dynamic_wind_in(x), sc->nil); + dynamic_wind_state(x) = DWIND_BODY; + } else - if (op == OP_DEACTIVATE_GOTO) - call_exit_active(stack_args(continuation_stack(c), i)) = true; + if (op == OP_DEACTIVATE_GOTO) + call_exit_active(stack_args(continuation_stack(c), i)) = true; /* not let_temp_done here! */ /* if op == OP_LET_TEMP_DONE, we're jumping back into a let-temporarily. MIT and Chez scheme say they remember the * let-temp vars (fluid-let or parameters in their terminology) at the point of the call/cc, and restore them @@ -12091,38 +12091,38 @@ static void call_with_current_continuation(s7_scheme *sc) if ((continuation_key(c) != NOT_BAFFLED) && (!(find_baffle(sc, continuation_key(c))))) error_nr(sc, sc->baffled_symbol, - (is_symbol(continuation_name(sc->code))) ? - set_elist_2(sc, wrap_string(sc, "continuation ~S can't jump into with-baffle", 43), continuation_name(sc->code)) : - set_elist_1(sc, wrap_string(sc, "continuation can't jump into with-baffle", 40))); + (is_symbol(continuation_name(sc->code))) ? + set_elist_2(sc, wrap_string(sc, "continuation ~S can't jump into with-baffle", 43), continuation_name(sc->code)) : + set_elist_1(sc, wrap_string(sc, "continuation can't jump into with-baffle", 40))); if (check_for_dynamic_winds(sc, c)) { /* make_room_for_cc_stack(sc); */ /* 28-May-21 */ /* we push_stack sc->code before calling an embedded eval above, so sc->code should still be c here, etc */ if ((stack_has_pairs(continuation_stack(c))) || - (stack_has_counters(continuation_stack(c)))) - { - make_room_for_cc_stack(sc); - copy_stack(sc, sc->stack, continuation_stack(c), continuation_stack_top(c)); - } + (stack_has_counters(continuation_stack(c)))) + { + make_room_for_cc_stack(sc); + copy_stack(sc, sc->stack, continuation_stack(c), continuation_stack_top(c)); + } else - { - s7_pointer *nv = stack_elements(sc->stack); - s7_pointer *ov = stack_elements(continuation_stack(c)); - memcpy((void *)nv, (void *)ov, continuation_stack_top(c) * sizeof(s7_pointer)); - } + { + s7_pointer *nv = stack_elements(sc->stack); + s7_pointer *ov = stack_elements(continuation_stack(c)); + memcpy((void *)nv, (void *)ov, continuation_stack_top(c) * sizeof(s7_pointer)); + } /* copy_stack(sc, sc->stack, continuation_stack(c), continuation_stack_top(c)); */ sc->stack_end = (s7_pointer *)(sc->stack_start + continuation_stack_top(c)); { - int32_t top = continuation_op_loc(c); - s7_pointer *src, *dst; - sc->op_stack_now = (s7_pointer *)(sc->op_stack + top); - sc->op_stack_size = continuation_op_size(c); - sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size); - src = (s7_pointer *)vector_elements(continuation_op_stack(c)); - dst = sc->op_stack; - for (int32_t i = 0; i < top; i++) dst[i] = src[i]; + int32_t top = continuation_op_loc(c); + s7_pointer *src, *dst; + sc->op_stack_now = (s7_pointer *)(sc->op_stack + top); + sc->op_stack_size = continuation_op_size(c); + sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size); + src = (s7_pointer *)vector_elements(continuation_op_stack(c)); + dst = sc->op_stack; + for (int32_t i = 0; i < top; i++) dst[i] = src[i]; } sc->value = (is_null(sc->args)) ? sc->nil : ((is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc, sc->args)); } @@ -12144,7 +12144,7 @@ static s7_pointer g_call_cc(s7_scheme *sc, s7_pointer args) (closure_arity(p) != 1)) && (!s7_is_aritable(sc, p, 1))) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "call/cc procedure, ~A, should take one argument", 47), p)); + set_elist_2(sc, wrap_string(sc, "call/cc procedure, ~A, should take one argument", 47), p)); sc->w = s7_make_continuation(sc); if ((is_any_closure(p)) && (is_pair(closure_args(p))) && (is_symbol(car(closure_args(p))))) @@ -12190,7 +12190,7 @@ static void call_with_exit(s7_scheme *sc) if (!call_exit_active(sc->code)) error_nr(sc, sc->invalid_escape_function_symbol, - set_elist_1(sc, wrap_string(sc, "call-with-exit escape procedure called outside its block", 56))); + set_elist_1(sc, wrap_string(sc, "call-with-exit escape procedure called outside its block", 56))); call_exit_active(sc->code) = false; new_stack_top = call_exit_goto_loc(sc->code); @@ -12202,83 +12202,83 @@ static void call_with_exit(s7_scheme *sc) switch (stack_op(sc->stack, i)) /* avoidable if we group these ops at the end and use op< */ { case OP_DYNAMIC_WIND: - { - s7_pointer lx = T_Dyn(stack_code(sc->stack, i)); - if (dynamic_wind_state(lx) == DWIND_BODY) - { - dynamic_wind_state(lx) = DWIND_FINISH; - if (dynamic_wind_out(lx) != sc->F) - { - s7_pointer arg = (sc->args == sc->plist_1) ? car(sc->plist_1) : sc->unused; /* might also need GC protection here */ - /* protect the sc->args value across this call if it is sc->plist_1 -- I can't find a broken case */ - sc->value = s7_call(sc, dynamic_wind_out(lx), sc->nil); - if (arg != sc->unused) set_plist_1(sc, arg); - }}} - break; + { + s7_pointer lx = T_Dyn(stack_code(sc->stack, i)); + if (dynamic_wind_state(lx) == DWIND_BODY) + { + dynamic_wind_state(lx) = DWIND_FINISH; + if (dynamic_wind_out(lx) != sc->F) + { + s7_pointer arg = (sc->args == sc->plist_1) ? car(sc->plist_1) : sc->unused; /* might also need GC protection here */ + /* protect the sc->args value across this call if it is sc->plist_1 -- I can't find a broken case */ + sc->value = s7_call(sc, dynamic_wind_out(lx), sc->nil); + if (arg != sc->unused) set_plist_1(sc, arg); + }}} + break; case OP_DYNAMIC_UNWIND: case OP_DYNAMIC_UNWIND_PROFILE: - set_stack_op(sc->stack, i, OP_GC_PROTECT); - dynamic_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); - break; + set_stack_op(sc->stack, i, OP_GC_PROTECT); + dynamic_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); + break; case OP_EVAL_STRING: - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - break; + s7_close_input_port(sc, current_input_port(sc)); + pop_input_port(sc); + break; case OP_BARRIER: /* oops -- we almost certainly went too far */ - goto SET_VALUE; + goto SET_VALUE; case OP_DEACTIVATE_GOTO: /* here we're jumping into an unrelated call-with-exit block */ - call_exit_active(stack_args(sc->stack, i)) = false; - break; + call_exit_active(stack_args(sc->stack, i)) = false; + break; case OP_LET_TEMP_DONE: - { - s7_pointer old_args = sc->args; - let_temp_done(sc, stack_args(sc->stack, i), T_Let(stack_let(sc->stack, i))); - sc->args = old_args; - } - break; + { + s7_pointer old_args = sc->args; + let_temp_done(sc, stack_args(sc->stack, i), T_Let(stack_let(sc->stack, i))); + sc->args = old_args; + } + break; case OP_LET_TEMP_UNWIND: - let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); - break; + let_temp_unwind(sc, stack_code(sc->stack, i), stack_args(sc->stack, i)); + break; case OP_LET_TEMP_S7_UNWIND: - s7_starlet_set_1(sc, T_Sym(stack_code(sc->stack, i)), stack_args(sc->stack, i)); - break; + s7_starlet_set_1(sc, T_Sym(stack_code(sc->stack, i)), stack_args(sc->stack, i)); + break; case OP_LET_TEMP_S7_DIRECT_UNWIND: - sc->has_openlets = (stack_args(sc->stack, i) != sc->F); - break; + sc->has_openlets = (stack_args(sc->stack, i) != sc->F); + break; - /* call/cc does not close files, but I think call-with-exit should */ + /* call/cc does not close files, but I think call-with-exit should */ case OP_GET_OUTPUT_STRING: case OP_UNWIND_OUTPUT: - { - s7_pointer x = T_Pro(stack_code(sc->stack, i)); /* "code" = port that we opened */ - s7_close_output_port(sc, x); - x = stack_args(sc->stack, i); /* "args" = port that we shadowed, if not #<unused> */ - if (x != sc->unused) - set_current_output_port(sc, x); - } - break; + { + s7_pointer x = T_Pro(stack_code(sc->stack, i)); /* "code" = port that we opened */ + s7_close_output_port(sc, x); + x = stack_args(sc->stack, i); /* "args" = port that we shadowed, if not #<unused> */ + if (x != sc->unused) + set_current_output_port(sc, x); + } + break; case OP_UNWIND_INPUT: - s7_close_input_port(sc, T_Pri(stack_code(sc->stack, i))); /* "code" = port that we opened */ - if (stack_args(sc->stack, i) != sc->unused) - set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ - break; + s7_close_input_port(sc, T_Pri(stack_code(sc->stack, i))); /* "code" = port that we opened */ + if (stack_args(sc->stack, i) != sc->unused) + set_current_input_port(sc, stack_args(sc->stack, i)); /* "args" = port that we shadowed */ + break; case OP_EVAL_DONE: /* goto called in a method -- put off the inner eval return(s) until we clean up the stack */ - quit++; - break; + quit++; + break; default: - if ((S7_DEBUGGING) && (stack_op(sc->stack, i) == OP_MAP_UNWIND)) fprintf(stderr, "%s[%d]: unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); - break; + if ((S7_DEBUGGING) && (stack_op(sc->stack, i) == OP_MAP_UNWIND)) fprintf(stderr, "%s[%d]: unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); + break; } i -= 4; } while (i > new_stack_top); @@ -12291,12 +12291,12 @@ static void call_with_exit(s7_scheme *sc) if (quit > 0) { if (sc->longjmp_ok) - { - pop_stack(sc); - LongJmp(*(sc->goto_start), CALL_WITH_EXIT_JUMP); - } + { + pop_stack(sc); + LongJmp(*(sc->goto_start), CALL_WITH_EXIT_JUMP); + } for (i = 0; i < quit; i++) - push_stack_op_let(sc, OP_EVAL_DONE); + push_stack_op_let(sc, OP_EVAL_DONE); } } @@ -12336,10 +12336,10 @@ static s7_pointer g_call_with_exit(s7_scheme *sc, s7_pointer args) /* (call-wi return(method_or_bust_p(sc, p, sc->call_with_exit_symbol, a_procedure_string)); if (!s7_is_aritable(sc, p, 1)) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "call-with-exit argument should be a function of one argument: ~S", 64), p)); + set_elist_2(sc, wrap_string(sc, "call-with-exit argument should be a function of one argument: ~S", 64), p)); if (is_continuation(p)) /* (call/cc call-with-exit) ! */ error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "call-with-exit argument should be a normal function (not a continuation: ~S)", 76), p)); + set_elist_2(sc, wrap_string(sc, "call-with-exit argument should be a normal function (not a continuation: ~S)", 76), p)); x = make_goto(sc, sc->F); call_exit_active(x) = false; return((is_c_function(p)) ? c_function_call(p)(sc, set_plist_1(sc, x)) : s7_apply_function_star(sc, p, set_plist_1(sc, x))); @@ -12799,7 +12799,7 @@ static bool is_integer_via_method(s7_scheme *sc, s7_pointer p) { s7_pointer f = find_method_with_let(sc, p, sc->is_integer_symbol); if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); + return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); } return(false); } @@ -12995,8 +12995,8 @@ static block_t *mpc_to_string(s7_scheme *sc, mpc_t val, int32_t radix, use_write len = safe_strlen((char *)block_data(rl)) + safe_strlen((char *)block_data(im)) + 128; tmp = mallocate(sc, len); snprintf((char *)block_data(tmp), len, "%s%s%si", - (char *)block_data(rl), - ((((char *)block_data(im))[0] == '-') || (((char *)block_data(im))[0] == '+')) ? "" : "+", (char *)block_data(im)); + (char *)block_data(rl), + ((((char *)block_data(im))[0] == '-') || (((char *)block_data(im))[0] == '+')) ? "" : "+", (char *)block_data(im)); liberate(sc, rl); liberate(sc, im); @@ -13029,16 +13029,16 @@ static block_t *big_number_to_string_with_radix(s7_scheme *sc, s7_pointer p, int { s7_int len = safe_strlen((char *)block_data(str)); if (width > len) - { - int32_t spaces = width - len; - block_t *tmp = (block_t *)mallocate(sc, width + 1); - ((char *)block_data(tmp))[width] = '\0'; - memmove((void *)((char *)block_data(tmp) + spaces), (void *)block_data(str), len); - local_memset((void *)block_data(tmp), (int)' ', spaces); - (*nlen) = width; - liberate(sc, str); - return(tmp); - } + { + int32_t spaces = width - len; + block_t *tmp = (block_t *)mallocate(sc, width + 1); + ((char *)block_data(tmp))[width] = '\0'; + memmove((void *)((char *)block_data(tmp) + spaces), (void *)block_data(str), len); + local_memset((void *)block_data(tmp), (int)' ', spaces); + (*nlen) = width; + liberate(sc, str); + return(tmp); + } (*nlen) = len; } else (*nlen) = safe_strlen((char *)block_data(str)); @@ -13099,7 +13099,7 @@ static s7_pointer string_to_either_ratio(s7_scheme *sc, const char *nstr, const if (d == 0) return(real_NaN); n = string_to_integer(nstr, radix, &overflow); if (!overflow) - return(make_ratio(sc, n, d)); + return(make_ratio(sc, n, d)); } if (nstr[0] == '+') return(string_to_big_ratio(sc, (const char *)(nstr + 1), radix)); @@ -13134,26 +13134,26 @@ static s7_pointer string_to_either_complex_1(s7_scheme *sc, char *q, char *slash else { if (slash1) - { - s7_int d, n = string_to_integer(q, radix, &overflow); /* q can include the slash and denominator */ - if (overflow) return(string_to_big_ratio(sc, q, radix)); - d = string_to_integer(slash1, radix, &overflow); - if (overflow) return(string_to_big_ratio(sc, q, radix)); - (*d_rl) = (s7_double)n / (s7_double)d; - } + { + s7_int d, n = string_to_integer(q, radix, &overflow); /* q can include the slash and denominator */ + if (overflow) return(string_to_big_ratio(sc, q, radix)); + d = string_to_integer(slash1, radix, &overflow); + if (overflow) return(string_to_big_ratio(sc, q, radix)); + (*d_rl) = (s7_double)n / (s7_double)d; + } else - { - s7_int val = string_to_integer(q, radix, &overflow); - if (overflow) return(string_to_big_integer(sc, q, radix)); - (*d_rl) = (s7_double)val; - }} + { + s7_int val = string_to_integer(q, radix, &overflow); + if (overflow) return(string_to_big_integer(sc, q, radix)); + (*d_rl) = (s7_double)val; + }} if ((*d_rl) == -0.0) (*d_rl) = 0.0; return(NULL); } static s7_pointer string_to_either_complex(s7_scheme *sc, char *q, char *slash1, char *ex1, bool has_dec_point1, - char *plus, char *slash2, char *ex2, bool has_dec_point2, - int32_t radix, int32_t has_plus_or_minus) + char *plus, char *slash2, char *ex2, bool has_dec_point2, + int32_t radix, int32_t has_plus_or_minus) { /* this can be just about anything involving 2 real/ratio/int portions, +/- in between and 'i' at the end */ double d_rl = 0.0, d_im = 0.0; @@ -13210,24 +13210,24 @@ static bool big_numbers_are_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b) if ((is_NaN(real_part(a))) || (is_NaN(imag_part(a)))) return(false); if (!is_t_big_complex(b)) return(false); if ((mpfr_nan_p(mpc_realref(big_complex(b)))) || (mpfr_nan_p(mpc_imagref(big_complex(b))))) - return(false); + return(false); mpc_set_d_d(sc->mpc_1, real_part(a), imag_part(a), MPC_RNDNN); return(mpc_cmp(sc->mpc_1, big_complex(b)) == 0); case T_BIG_COMPLEX: if ((mpfr_nan_p(mpc_realref(big_complex(a)))) || (mpfr_nan_p(mpc_imagref(big_complex(a))))) - return(false); + return(false); if (is_t_big_complex(b)) - { - if ((mpfr_nan_p(mpc_realref(big_complex(b)))) || (mpfr_nan_p(mpc_imagref(big_complex(b))))) - return(false); - return(mpc_cmp(big_complex(a), big_complex(b)) == 0); - } + { + if ((mpfr_nan_p(mpc_realref(big_complex(b)))) || (mpfr_nan_p(mpc_imagref(big_complex(b))))) + return(false); + return(mpc_cmp(big_complex(a), big_complex(b)) == 0); + } if (is_t_complex(b)) - { - if ((is_NaN(real_part(b))) || (is_NaN(imag_part(b)))) return(false); - mpc_set_d_d(sc->mpc_2, real_part(b), imag_part(b), MPC_RNDNN); - return(mpc_cmp(big_complex(a), sc->mpc_1) == 0); - }} + { + if ((is_NaN(real_part(b))) || (is_NaN(imag_part(b)))) return(false); + mpc_set_d_d(sc->mpc_2, real_part(b), imag_part(b), MPC_RNDNN); + return(mpc_cmp(big_complex(a), sc->mpc_1) == 0); + }} return(false); } @@ -13430,11 +13430,11 @@ static s7_int c_gcd(s7_int u, s7_int v) s7_int divisor = 1; if (u == v) return(u); while (((u & 1) == 0) && ((v & 1) == 0)) - { - u /= 2; - v /= 2; - divisor *= 2; - } + { + u /= 2; + v /= 2; + divisor *= 2; + } return(divisor); } a = s7_int_abs(u); @@ -13485,7 +13485,7 @@ static bool c_rationalize(s7_double ux, s7_double error, s7_int *numer, s7_int * if (error >= 1.0) /* aw good grief! */ { if (x0 < 0.0) - (*numer) = (x1 < 0.0) ? (s7_int)floor(x1) : 0; + (*numer) = (x1 < 0.0) ? (s7_int)floor(x1) : 0; else (*numer) = i; (*denom) = 1; return(true); @@ -13510,20 +13510,20 @@ static bool c_rationalize(s7_double ux, s7_double error, s7_int *numer, s7_int * double val = (double)p0 / (double)q0; if (((x0 <= val) && (val <= x1)) || (e1 == 0.0) || (e1p == 0.0) || (tries > 100)) - { - if ((q0 == s7_int_min) && (p0 == 1)) /* (rationalize 1.000000004297917e-12) when error is 1e-12 */ - { - (*numer) = 0; - (*denom) = 1; - } - else - { - (*numer) = p0; - (*denom) = q0; - if ((S7_DEBUGGING) && (q0 == 0)) fprintf(stderr, "%f %" ld64 "/0\n", ux, p0); - } - return(true); - } + { + if ((q0 == s7_int_min) && (p0 == 1)) /* (rationalize 1.000000004297917e-12) when error is 1e-12 */ + { + (*numer) = 0; + (*denom) = 1; + } + else + { + (*numer) = p0; + (*denom) = q0; + if ((S7_DEBUGGING) && (q0 == 0)) fprintf(stderr, "%f %" ld64 "/0\n", ux, p0); + } + return(true); + } tries++; r = (s7_int)floor(e0 / e1); r1 = (s7_int)ceil(e0p / e1p); @@ -13621,13 +13621,13 @@ static inline s7_pointer c_complex_to_s7(s7_scheme *sc, s7_complex z) {return(ma static noreturn void division_by_zero_error_1_nr(s7_scheme *sc, s7_pointer caller, s7_pointer x) { error_nr(sc, sc->division_by_zero_symbol, - set_elist_4(sc, wrap_string(sc, "~A: division by zero, (~A ~S)", 29), caller, caller, x)); + set_elist_4(sc, wrap_string(sc, "~A: division by zero, (~A ~S)", 29), caller, caller, x)); } static noreturn void division_by_zero_error_2_nr(s7_scheme *sc, s7_pointer caller, s7_pointer x, s7_pointer y) { error_nr(sc, sc->division_by_zero_symbol, - set_elist_5(sc, wrap_string(sc, "~A: division by zero, (~A ~S ~S)", 32), caller, caller, x, y)); + set_elist_5(sc, wrap_string(sc, "~A: division by zero, (~A ~S ~S)", 32), caller, caller, x, y)); } static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b) @@ -13639,7 +13639,7 @@ static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b) * ratio on a switch with-bignums or whatever, so its mere occurrence is just an annoyance. */ if (a & 1) - return(make_real(sc, (long_double)a / (long_double)b)); + return(make_real(sc, (long_double)a / (long_double)b)); a /= 2; b /= 2; } @@ -13651,23 +13651,23 @@ static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b) if (a == s7_int_min) { while (((a & 1) == 0) && ((b & 1) == 0)) - { - a /= 2; - b /= 2; - }} + { + a /= 2; + b /= 2; + }} else { s7_int b1 = b, divisor = s7_int_abs(a); do { - s7_int temp = divisor % b1; - divisor = b1; - b1 = temp; + s7_int temp = divisor % b1; + divisor = b1; + b1 = temp; } while (b1 != 0); if (divisor != 1) - { - a /= divisor; - b /= divisor; - }} + { + a /= divisor; + b /= divisor; + }} if (b == 1) return(make_integer(sc, a)); @@ -13727,7 +13727,7 @@ s7_double s7_number_to_real_with_caller(s7_scheme *sc, s7_pointer x, const char #if WITH_GMP case T_BIG_INTEGER: return((s7_double)big_integer_to_s7_int(sc, big_integer(x))); case T_BIG_RATIO: return((s7_double)((long_double)big_integer_to_s7_int(sc, mpq_numref(big_ratio(x))) / - (long_double)big_integer_to_s7_int(sc, mpq_denref(big_ratio(x))))); + (long_double)big_integer_to_s7_int(sc, mpq_denref(big_ratio(x))))); case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN)); #endif default: @@ -13746,7 +13746,7 @@ s7_double s7_number_to_real_with_location(s7_scheme *sc, s7_pointer x, s7_pointe #if WITH_GMP case T_BIG_INTEGER: return((s7_double)big_integer_to_s7_int(sc, big_integer(x))); case T_BIG_RATIO: return((s7_double)((long_double)big_integer_to_s7_int(sc, mpq_numref(big_ratio(x))) / - (long_double)big_integer_to_s7_int(sc, mpq_denref(big_ratio(x))))); + (long_double)big_integer_to_s7_int(sc, mpq_denref(big_ratio(x))))); case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN)); #endif default: @@ -13813,13 +13813,13 @@ s7_double s7_real(s7_pointer x) case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN)); case T_BIG_RATIO: { - s7_double result; - mpfr_t bx; - mpfr_init2(bx, DEFAULT_BIGNUM_PRECISION); - mpfr_set_q(bx, big_ratio(x), MPFR_RNDN); - result = mpfr_get_d(bx, MPFR_RNDN); - mpfr_clear(bx); - return(result); + s7_double result; + mpfr_t bx; + mpfr_init2(bx, DEFAULT_BIGNUM_PRECISION); + mpfr_set_q(bx, big_ratio(x), MPFR_RNDN); + result = mpfr_get_d(bx, MPFR_RNDN); + mpfr_clear(bx); + return(result); } #endif } @@ -13829,7 +13829,7 @@ s7_double s7_real(s7_pointer x) static bool is_one(s7_pointer x) { return(((is_t_integer(x)) && (integer(x) == 1)) || - ((is_t_real(x)) && (real(x) == 1.0))); + ((is_t_real(x)) && (real(x) == 1.0))); } @@ -13932,14 +13932,14 @@ static dtoa_np dtoa_find_cachedpow10(int exp, int* k) { int32_t current = exp + dtoa_powers_ten[idx].exp + 64; if (current < dtoa_expmin) - { - idx++; - continue; + { + idx++; + continue; } if (current > dtoa_expmax) - { - idx--; - continue; + { + idx--; + continue; } *k = (dtoa_firstpower + idx * dtoa_steppowers); return(dtoa_powers_ten[idx]); @@ -14035,7 +14035,7 @@ static dtoa_np dtoa_multiply(dtoa_np* a, dtoa_np* b) static void dtoa_round_digit(char* digits, int32_t ndigits, uint64_t delta, uint64_t rem, uint64_t kappa, uint64_t frac) { while ((rem < frac) && (delta - rem >= kappa) && - ((rem + kappa < frac) || (frac - rem > rem + kappa - frac))) + ((rem + kappa < frac) || (frac - rem > rem + kappa - frac))) { digits[ndigits - 1]--; rem += kappa; @@ -14060,15 +14060,15 @@ static int32_t dtoa_generate_digits(dtoa_np* fp, dtoa_np* upper, dtoa_np* lower, uint64_t tmp, div = *divp; unsigned digit = part1 / div; if (digit || idx) - digits[idx++] = digit + '0'; + digits[idx++] = digit + '0'; part1 -= digit * div; kappa--; tmp = (part1 << -one.exp) + part2; if (tmp <= delta) - { - *K += kappa; - dtoa_round_digit(digits, idx, delta, tmp, div << -one.exp, wfrac); - return(idx); + { + *K += kappa; + dtoa_round_digit(digits, idx, delta, tmp, div << -one.exp, wfrac); + return(idx); }} /* 10 */ @@ -14081,14 +14081,14 @@ static int32_t dtoa_generate_digits(dtoa_np* fp, dtoa_np* upper, dtoa_np* lower, kappa--; digit = part2 >> -one.exp; if (digit || idx) - digits[idx++] = digit + '0'; + digits[idx++] = digit + '0'; part2 &= one.frac - 1; if (part2 < delta) - { - *K += kappa; - dtoa_round_digit(digits, idx, delta, part2, one.frac, wfrac * *unit); - return(idx); - } + { + *K += kappa; + dtoa_round_digit(digits, idx, delta, part2, one.frac, wfrac * *unit); + return(idx); + } unit--; } } @@ -14132,22 +14132,22 @@ static int32_t dtoa_emit_digits(char* digits, int32_t ndigits, char* dest, int32 int32_t offset = ndigits - dtoa_absv(K); /* fp < 1.0 -> write leading zero */ if (offset <= 0) - { - offset = -offset; - dest[0] = '0'; - dest[1] = '.'; - local_memset(dest + 2, '0', offset); - memcpy(dest + offset + 2, digits, ndigits); - return(ndigits + 2 + offset); - /* fp > 1.0 */ - } + { + offset = -offset; + dest[0] = '0'; + dest[1] = '.'; + local_memset(dest + 2, '0', offset); + memcpy(dest + offset + 2, digits, ndigits); + return(ndigits + 2 + offset); + /* fp > 1.0 */ + } else - { - memcpy(dest, digits, offset); - dest[offset] = '.'; - memcpy(dest + offset + 1, digits + offset, ndigits - offset); - return(ndigits + 1); - }} + { + memcpy(dest, digits, offset); + dest[offset] = '.'; + memcpy(dest + offset + 1, digits + offset, ndigits - offset); + return(ndigits + 1); + }} /* write decimal w/ scientific notation */ ndigits = dtoa_minv(ndigits, 18 - neg); @@ -14249,10 +14249,10 @@ static size_t integer_to_string_any_base(char *p, s7_int n, int32_t radix) /* c if (n == S7_INT64_MIN) /* can't negate this, so do it by hand */ { static const char *mnfs[17] = {"","", - "-1000000000000000000000000000000000000000000000000000000000000000", "-2021110011022210012102010021220101220222", - "-20000000000000000000000000000000", "-1104332401304422434310311213", "-1540241003031030222122212", - "-22341010611245052052301", "-1000000000000000000000", "-67404283172107811828", "-9223372036854775808", - "-1728002635214590698", "-41a792678515120368", "-10b269549075433c38", "-4340724c6c71dc7a8", "-160e2ad3246366808", "-8000000000000000"}; + "-1000000000000000000000000000000000000000000000000000000000000000", "-2021110011022210012102010021220101220222", + "-20000000000000000000000000000000", "-1104332401304422434310311213", "-1540241003031030222122212", + "-22341010611245052052301", "-1000000000000000000000", "-67404283172107811828", "-9223372036854775808", + "-1728002635214590698", "-41a792678515120368", "-10b269549075433c38", "-4340724c6c71dc7a8", "-160e2ad3246366808", "-8000000000000000"}; len = safe_strlen(mnfs[radix]); memcpy((void *)p, (const void *)mnfs[radix], len); @@ -14270,7 +14270,7 @@ static size_t integer_to_string_any_base(char *p, s7_int n, int32_t radix) /* c for (i = 1; i < 100; i++) { if (pown < radix) - break; + break; pown /= (s7_int)radix; } len = i - 1; @@ -14344,17 +14344,17 @@ static char *floatify(char *str, s7_int *nlen) s7_int len = *nlen; /* snprintf returns "nan" and "inf" but we (stupidly) want "+nan.0" and "+inf.0"; "-nan" and "-inf" will be handled by the normal case */ if (len == 3) - { - if (str[0] == 'n') - { - str[0] = '+'; str[1] = 'n'; str[2] = 'a'; str[3] = 'n'; - len = 4; - } - if (str[0] == 'i') - { - str[0] = '+'; str[1] = 'i'; str[2] = 'n'; str[3] = 'f'; - len = 4; - }} + { + if (str[0] == 'n') + { + str[0] = '+'; str[1] = 'n'; str[2] = 'a'; str[3] = 'n'; + len = 4; + } + if (str[0] == 'i') + { + str[0] = '+'; str[1] = 'i'; str[2] = 'n'; str[3] = 'f'; + len = 4; + }} str[len]='.'; str[len + 1]='0'; str[len + 2]='\0'; @@ -14377,7 +14377,7 @@ static void insert_spaces(s7_scheme *sc, const char *src, s7_int width, s7_int l } static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int width, s7_int precision, - char float_choice, s7_int *nlen, use_write_t choice) /* don't free result */ + char float_choice, s7_int *nlen, use_write_t choice) /* don't free result */ { /* called by number_to_string_with_radix g_number_to_string, number_to_string_p_p number_to_port format_number */ /* the rest of s7 assumes nlen is set to the correct length @@ -14397,21 +14397,21 @@ static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int widt { const char *p; if (width == 0) - { - if (has_number_name(obj)) - { - (*nlen) = number_name_length(obj); - return((char *)number_name(obj)); - } - return((char *)integer_to_string(sc, integer(obj), nlen)); - } + { + if (has_number_name(obj)) + { + (*nlen) = number_name_length(obj); + return((char *)number_name(obj)); + } + return((char *)integer_to_string(sc, integer(obj), nlen)); + } p = integer_to_string(sc, integer(obj), &len); if (width > len) - { - insert_spaces(sc, p, width, len); /* writes sc->num_to_str */ - (*nlen) = width; - return(sc->num_to_str); - } + { + insert_spaces(sc, p, width, len); /* writes sc->num_to_str */ + (*nlen) = width; + return(sc->num_to_str); + } (*nlen) = len; return((char *)p); } @@ -14419,27 +14419,27 @@ static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int widt if (is_t_real(obj)) { if (width == 0) - { + { #if WITH_DTOA - if ((float_choice == 'g') && - (precision == WRITE_REAL_PRECISION)) - { - /* (number->string 0.0000001) is sensitive to (*s7* 'float-format-precision) and inconsistent: either 1e-7 or 0.0000001 - * because fpconv_dtoa has some complicated decision about 'g' vs 'f' -- not sure if this is a bug. - */ - len = fpconv_dtoa(real(obj), sc->num_to_str); - sc->num_to_str[len] = '\0'; - (*nlen) = len; - return(sc->num_to_str); - } -#endif - len = snprintf(sc->num_to_str, sc->num_to_str_size - 4, - (float_choice == 'g') ? "%.*g" : ((float_choice == 'f') ? "%.*f" : "%.*e"), - (int32_t)precision, real(obj)); /* -4 for floatify */ - } + if ((float_choice == 'g') && + (precision == WRITE_REAL_PRECISION)) + { + /* (number->string 0.0000001) is sensitive to (*s7* 'float-format-precision) and inconsistent: either 1e-7 or 0.0000001 + * because fpconv_dtoa has some complicated decision about 'g' vs 'f' -- not sure if this is a bug. + */ + len = fpconv_dtoa(real(obj), sc->num_to_str); + sc->num_to_str[len] = '\0'; + (*nlen) = len; + return(sc->num_to_str); + } +#endif + len = snprintf(sc->num_to_str, sc->num_to_str_size - 4, + (float_choice == 'g') ? "%.*g" : ((float_choice == 'f') ? "%.*f" : "%.*e"), + (int32_t)precision, real(obj)); /* -4 for floatify */ + } else len = snprintf(sc->num_to_str, sc->num_to_str_size - 4, - (float_choice == 'g') ? "%*.*g" : ((float_choice == 'f') ? "%*.*f" : "%*.*e"), - (int32_t)width, (int32_t)precision, real(obj)); /* -4 for floatify */ + (float_choice == 'g') ? "%*.*g" : ((float_choice == 'f') ? "%*.*f" : "%*.*e"), + (int32_t)width, (int32_t)precision, real(obj)); /* -4 for floatify */ (*nlen) = len; floatify(sc->num_to_str, nlen); return(sc->num_to_str); @@ -14459,10 +14459,10 @@ static char *number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int widt free(imag); if (width > len) /* (format #f "~20g" 1+i) */ - { - insert_spaces(sc, sc->num_to_str, width, len); /* this checks sc->num_to_str_size */ - (*nlen) = width; - } + { + insert_spaces(sc, sc->num_to_str, width, len); /* this checks sc->num_to_str_size */ + (*nlen) = width; + } else (*nlen) = len; return(sc->num_to_str); } @@ -14506,31 +14506,31 @@ static block_t *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32 { case T_INTEGER: { - size_t len1; - b = inline_mallocate(sc, (128 + width)); - p = (char *)block_data(b); - len1 = integer_to_string_any_base(p, integer(obj), radix); - if ((size_t)width > len1) - { - size_t start = width - len1; - memmove((void *)(p + start), (void *)p, len1); - local_memset((void *)p, (int)' ', start); - p[width] = '\0'; - *nlen = width; - } - else *nlen = len1; - return(b); + size_t len1; + b = inline_mallocate(sc, (128 + width)); + p = (char *)block_data(b); + len1 = integer_to_string_any_base(p, integer(obj), radix); + if ((size_t)width > len1) + { + size_t start = width - len1; + memmove((void *)(p + start), (void *)p, len1); + local_memset((void *)p, (int)' ', start); + p[width] = '\0'; + *nlen = width; + } + else *nlen = len1; + return(b); } case T_RATIO: { - size_t len1, len2; - str_len = 256 + width; - b = inline_mallocate(sc, str_len); - p = (char *)block_data(b); - len1 = integer_to_string_any_base(p, numerator(obj), radix); - p[len1] = '/'; - len2 = integer_to_string_any_base((char *)(p + len1 + 1), denominator(obj), radix); + size_t len1, len2; + str_len = 256 + width; + b = inline_mallocate(sc, str_len); + p = (char *)block_data(b); + len1 = integer_to_string_any_base(p, numerator(obj), radix); + p[len1] = '/'; + len2 = integer_to_string_any_base((char *)(p + len1 + 1), denominator(obj), radix); len = len1 + 1 + len2; p[len] = '\0'; } @@ -14538,97 +14538,97 @@ static block_t *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32 case T_REAL: { - int32_t i; - s7_int int_part, nsize; - s7_double x = real(obj), frac_part, min_frac, base; - bool sign = false; - char n[128], d[256]; - - if (is_NaN(x)) - return(string_to_block(sc, "+nan.0", *nlen = 6)); - if (is_inf(x)) - { - if (x < 0.0) - return(string_to_block(sc, "-inf.0", *nlen = 6)); - return(string_to_block(sc, "+inf.0", *nlen = 6)); - } - if (x < 0.0) - { - sign = true; - x = -x; - } - if (x > 1.0e18) /* i.e. close to or greater than most-positive-fixnum (9.22e18), so the code below is unlikely to work, (format #f "~X" 1e19) */ - { - int32_t ep = (int32_t)floor(log(x) / log((double)radix)); - block_t *b1; - len = 0; - b = number_to_string_with_radix(sc, wrap_real(sc, x / pow((double)radix, (double)ep)), /* divide it down to one digit, then the fractional part */ - radix, width, precision, float_choice, &len); - b1 = inline_mallocate(sc, len + 8); - p = (char *)block_data(b1); - p[0] = '\0'; - (*nlen) = catstrs(p, len + 8, (sign) ? "-" : "", (char *)block_data(b), (radix == 16) ? "@" : "e", integer_to_string_no_length(sc, ep), (char *)NULL); - liberate(sc, b); - return(b1); - } - - int_part = (s7_int)floor(x); - frac_part = x - int_part; - nsize = integer_to_string_any_base(n, int_part, radix); - min_frac = dpow(radix, -precision); - - /* doesn't this assume precision < 128/256 and that we can fit in 256 digits (1e308)? */ - for (i = 0, base = radix; (i < precision) && (frac_part > min_frac); i++, base *= radix) - { - s7_int ipart = (s7_int)(frac_part * base); - if (ipart >= radix) /* rounding confusion */ - ipart = radix - 1; - frac_part -= (ipart / base); - /* d[i] = ((const char *)"0123456789abcdef")[ipart]; */ - d[i] = dignum[ipart]; - } - if (i == 0) - d[i++] = '0'; - d[i] = '\0'; - b = inline_mallocate(sc, 256); + int32_t i; + s7_int int_part, nsize; + s7_double x = real(obj), frac_part, min_frac, base; + bool sign = false; + char n[128], d[256]; + + if (is_NaN(x)) + return(string_to_block(sc, "+nan.0", *nlen = 6)); + if (is_inf(x)) + { + if (x < 0.0) + return(string_to_block(sc, "-inf.0", *nlen = 6)); + return(string_to_block(sc, "+inf.0", *nlen = 6)); + } + if (x < 0.0) + { + sign = true; + x = -x; + } + if (x > 1.0e18) /* i.e. close to or greater than most-positive-fixnum (9.22e18), so the code below is unlikely to work, (format #f "~X" 1e19) */ + { + int32_t ep = (int32_t)floor(log(x) / log((double)radix)); + block_t *b1; + len = 0; + b = number_to_string_with_radix(sc, wrap_real(sc, x / pow((double)radix, (double)ep)), /* divide it down to one digit, then the fractional part */ + radix, width, precision, float_choice, &len); + b1 = inline_mallocate(sc, len + 8); + p = (char *)block_data(b1); + p[0] = '\0'; + (*nlen) = catstrs(p, len + 8, (sign) ? "-" : "", (char *)block_data(b), (radix == 16) ? "@" : "e", integer_to_string_no_length(sc, ep), (char *)NULL); + liberate(sc, b); + return(b1); + } + + int_part = (s7_int)floor(x); + frac_part = x - int_part; + nsize = integer_to_string_any_base(n, int_part, radix); + min_frac = dpow(radix, -precision); + + /* doesn't this assume precision < 128/256 and that we can fit in 256 digits (1e308)? */ + for (i = 0, base = radix; (i < precision) && (frac_part > min_frac); i++, base *= radix) + { + s7_int ipart = (s7_int)(frac_part * base); + if (ipart >= radix) /* rounding confusion */ + ipart = radix - 1; + frac_part -= (ipart / base); + /* d[i] = ((const char *)"0123456789abcdef")[ipart]; */ + d[i] = dignum[ipart]; + } + if (i == 0) + d[i++] = '0'; + d[i] = '\0'; + b = inline_mallocate(sc, 256); p = (char *)block_data(b); - /* much faster than catstrs because we know the string lengths */ - { - char *pt = p; - if (sign) {pt[0] = '-'; pt++;} - memcpy(pt, n, nsize); - pt += nsize; - pt[0] = '.'; - pt++; - memcpy(pt, d, i); - pt[i] = '\0'; - /* len = ((sign) ? 1 : 0) + 1 + nsize + i; */ - len = pt + i - p; - } - str_len = 256; + /* much faster than catstrs because we know the string lengths */ + { + char *pt = p; + if (sign) {pt[0] = '-'; pt++;} + memcpy(pt, n, nsize); + pt += nsize; + pt[0] = '.'; + pt++; + memcpy(pt, d, i); + pt[i] = '\0'; + /* len = ((sign) ? 1 : 0) + 1 + nsize + i; */ + len = pt + i - p; + } + str_len = 256; } break; default: { - char *pt; - s7_int real_len = 0, imag_len = 0; - block_t *n = number_to_string_with_radix(sc, wrap_real(sc, real_part(obj)), radix, 0, precision, float_choice, &real_len); /* include floatify */ - block_t *d = number_to_string_with_radix(sc, wrap_real(sc, imag_part(obj)), radix, 0, precision, float_choice, &imag_len); - char *dp = (char *)block_data(d); - b = inline_mallocate(sc, 512); - p = (char *)block_data(b); - pt = p; - memcpy(pt, (void *)block_data(n), real_len); - pt += real_len; - if ((dp[0] != '+') && (dp[0] != '-')) {pt[0] = '+'; pt++;} - memcpy(pt, dp, imag_len); - pt[imag_len] = 'i'; - pt[imag_len + 1] = '\0'; - len = pt + imag_len + 1 - p; - str_len = 512; - liberate(sc, n); - liberate(sc, d); + char *pt; + s7_int real_len = 0, imag_len = 0; + block_t *n = number_to_string_with_radix(sc, wrap_real(sc, real_part(obj)), radix, 0, precision, float_choice, &real_len); /* include floatify */ + block_t *d = number_to_string_with_radix(sc, wrap_real(sc, imag_part(obj)), radix, 0, precision, float_choice, &imag_len); + char *dp = (char *)block_data(d); + b = inline_mallocate(sc, 512); + p = (char *)block_data(b); + pt = p; + memcpy(pt, (void *)block_data(n), real_len); + pt += real_len; + if ((dp[0] != '+') && (dp[0] != '-')) {pt[0] = '+'; pt++;} + memcpy(pt, dp, imag_len); + pt[imag_len] = 'i'; + pt[imag_len + 1] = '\0'; + len = pt + imag_len + 1 - p; + str_len = 512; + liberate(sc, n); + liberate(sc, d); } break; } @@ -14637,11 +14637,11 @@ static block_t *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32 { s7_int spaces; if (width >= str_len) - { - str_len = width + 1; - b = reallocate(sc, b, str_len); - p = (char *)block_data(b); - } + { + str_len = width + 1; + b = reallocate(sc, b, str_len); + p = (char *)block_data(b); + } spaces = width - len; p[width] = '\0'; memmove((void *)(p + spaces), (void *)p, len); @@ -14677,17 +14677,17 @@ static s7_pointer g_number_to_string(s7_scheme *sc, s7_pointer args) { s7_pointer y = cadr(args); if (s7_is_integer(y)) - radix = s7_integer_clamped_if_gmp(sc, y); + radix = s7_integer_clamped_if_gmp(sc, y); else return(method_or_bust(sc, y, sc->number_to_string_symbol, args, sc->type_names[T_INTEGER], 2)); if ((radix < 2) || (radix > 16)) - out_of_range_error_nr(sc, sc->number_to_string_symbol, int_two, y, a_valid_radix_string); + out_of_range_error_nr(sc, sc->number_to_string_symbol, int_two, y, a_valid_radix_string); #if (WITH_GMP) if (!s7_is_bignum(x)) #endif - { - block_t *b = number_to_string_with_radix(sc, x, radix, 0, sc->float_format_precision, 'g', &nlen); - return(block_to_string(sc, b, nlen)); - }} + { + block_t *b = number_to_string_with_radix(sc, x, radix, 0, sc->float_format_precision, 'g', &nlen); + return(block_to_string(sc, b, nlen)); + }} #if WITH_GMP else radix = 10; if (s7_is_bignum(x)) @@ -14700,10 +14700,10 @@ static s7_pointer g_number_to_string(s7_scheme *sc, s7_pointer args) if (is_t_integer(x)) { if (has_number_name(x)) - { - nlen = number_name_length(x); - res = (const char *)number_name(x); - } + { + nlen = number_name_length(x); + res = (const char *)number_name(x); + } else res = integer_to_string(sc, integer(x), &nlen); } else res = number_to_string_base_10(sc, x, 0, sc->float_format_precision, 'g', &nlen, P_WRITE); @@ -14859,12 +14859,12 @@ static s7_pointer check_sharp_readers(s7_scheme *sc, const char *name) for (s7_pointer reader = slot_value(sc->sharp_readers); is_not_null(reader); reader = cdr(reader)) if (name[0] == s7_character(caar(reader))) { - if (args == sc->F) - args = set_plist_1(sc, wrap_string(sc, name, safe_strlen(name))); - /* args is GC protected by s7_apply_function?? (placed on the stack) */ - value = s7_apply_function(sc, cdar(reader), args); /* this is much less error-safe than s7_call */ - if (value != sc->F) - break; + if (args == sc->F) + args = set_plist_1(sc, wrap_string(sc, name, safe_strlen(name))); + /* args is GC protected by s7_apply_function?? (placed on the stack) */ + value = s7_apply_function(sc, cdar(reader), args); /* this is much less error-safe than s7_call */ + if (value != sc->F) + break; } if (need_loader_port) set_loader_port(current_input_port(sc)); @@ -14880,10 +14880,10 @@ static s7_pointer g_sharp_readers_set(s7_scheme *sc, s7_pointer args) error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *#readers* to ~S", 26), cadr(args))); for (x = cadr(args); is_pair(x); x = cdr(x)) if ((!is_pair(car(x))) || - (!is_character(caar(x))) || - (!is_procedure(cdar(x)))) + (!is_character(caar(x))) || + (!is_procedure(cdar(x)))) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "can't set *#readers* to ~S", 26), cadr(args))); + set_elist_2(sc, wrap_string(sc, "can't set *#readers* to ~S", 26), cadr(args))); if (!is_null(x)) error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *#readers* to ~S", 26), cadr(args))); return(cadr(args)); @@ -14913,7 +14913,7 @@ static int32_t inchar(s7_pointer pt) else { if (port_data_size(pt) <= port_position(pt)) - return(EOF); + return(EOF); c = (uint8_t)port_data(pt)[port_position(pt)++]; } if (c == '\n') @@ -14953,47 +14953,47 @@ static s7_pointer unknown_sharp_constant(s7_scheme *sc, const char *name, s7_poi s7_pointer result = s7_call(sc, sc->read_error_hook, set_plist_2(sc, sc->T, wrap_string(sc, name, safe_strlen(name)))); s7_set_history_enabled(sc, old_history_enabled); if (result != sc->unspecified) - return(result); + return(result); } if (pt) /* #<"..."> which gets here as name="#<" */ { s7_int len = safe_strlen(name); if ((name[len - 1] != '>') && - (is_input_port(pt)) && - (pt != sc->standard_input)) - { - if (s7_peek_char(sc, pt) != chars[(uint8_t)'"']) /* if not #<"...">, just return it */ - return(make_undefined(sc, name)); - /* PERHAPS: strchr port-data '>'?? it might be #<x y> etc -- what would this break? maybe extend section below */ - - if (is_string_port(pt)) /* probably unnecessary (see below) */ - { - s7_int c = inchar(pt); - const char *pstart = (const char *)(port_data(pt) + port_position(pt)); - const char *p = strchr(pstart, (int)'"'); - s7_int added_len; - char *buf; - s7_pointer res; - - if (!p) - { - backchar(c, pt); - return(make_undefined(sc, name)); - } - p++; - while (char_ok_in_a_name[(uint8_t)(*p)]) {p++;} - added_len = (s7_int)(p - pstart); /* p is one past '>' presumably */ - /* we can't use strbuf here -- it might be the source of the "name" argument! */ - buf = (char *)Malloc(len + added_len + 2); - memcpy((void *)buf, (const void *)name, len); - buf[len] = '"'; /* from inchar */ - memcpy((void *)(buf + len + 1), (const void *)pstart, added_len); - buf[len + added_len + 1] = 0; - port_position(pt) += added_len; - res = make_undefined(sc, (const char *)buf); - free(buf); - return(res); - }}} + (is_input_port(pt)) && + (pt != sc->standard_input)) + { + if (s7_peek_char(sc, pt) != chars[(uint8_t)'"']) /* if not #<"...">, just return it */ + return(make_undefined(sc, name)); + /* PERHAPS: strchr port-data '>'?? it might be #<x y> etc -- what would this break? maybe extend section below */ + + if (is_string_port(pt)) /* probably unnecessary (see below) */ + { + s7_int c = inchar(pt); + const char *pstart = (const char *)(port_data(pt) + port_position(pt)); + const char *p = strchr(pstart, (int)'"'); + s7_int added_len; + char *buf; + s7_pointer res; + + if (!p) + { + backchar(c, pt); + return(make_undefined(sc, name)); + } + p++; + while (char_ok_in_a_name[(uint8_t)(*p)]) {p++;} + added_len = (s7_int)(p - pstart); /* p is one past '>' presumably */ + /* we can't use strbuf here -- it might be the source of the "name" argument! */ + buf = (char *)Malloc(len + added_len + 2); + memcpy((void *)buf, (const void *)name, len); + buf[len] = '"'; /* from inchar */ + memcpy((void *)(buf + len + 1), (const void *)pstart, added_len); + buf[len + added_len + 1] = 0; + port_position(pt) += added_len; + res = make_undefined(sc, (const char *)buf); + free(buf); + return(res); + }}} return(make_undefined(sc, name)); } @@ -15024,7 +15024,7 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, const char *name, bool with */ s7_pointer sym = make_symbol_with_strlen(sc, (const char *)(name + 1)); if ((!is_gensym(sym)) && (is_slot(initial_slot(sym)))) - return(initial_value(sym)); + return(initial_value(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. */ @@ -15035,7 +15035,7 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, const char *name, bool with { s7_pointer x = check_sharp_readers(sc, name); if (x != sc->F) - return(x); + return(x); } if ((name[0] == '\0') || name[1] == '\0') @@ -15055,62 +15055,62 @@ static s7_pointer make_sharp_constant(s7_scheme *sc, const char *name, bool with case 'x': /* #x (hex) */ case 'b': /* #b (binary) */ { - s7_pointer res = make_atom(sc, (char *)(name + 1), (name[0] == 'o') ? 8 : ((name[0] == 'x') ? 16 : 2), NO_SYMBOLS, with_error); - if ((error_if_bad_number) && (res == sc->F)) /* #b32 etc but not if called from string->number */ - error_nr(sc, sc->read_error_symbol, set_elist_2(sc, wrap_string(sc, "#~A is not a number", 19), wrap_string(sc, name, safe_strlen(name)))); - return(res); + s7_pointer res = make_atom(sc, (char *)(name + 1), (name[0] == 'o') ? 8 : ((name[0] == 'x') ? 16 : 2), NO_SYMBOLS, with_error); + if ((error_if_bad_number) && (res == sc->F)) /* #b32 etc but not if called from string->number */ + error_nr(sc, sc->read_error_symbol, set_elist_2(sc, wrap_string(sc, "#~A is not a number", 19), wrap_string(sc, name, safe_strlen(name)))); + return(res); } /* -------- #\... -------- */ case '\\': if (name[2] == 0) /* the most common case: #\a */ - return(chars[(uint8_t)(name[1])]); + return(chars[(uint8_t)(name[1])]); /* not uint32_t here! (uint32_t)255 (as a char) returns -1!! */ switch (name[1]) - { - case 'n': - if ((c_strings_are_equal(name + 1, "null")) || - (c_strings_are_equal(name + 1, "nul"))) - return(chars[0]); - - if (c_strings_are_equal(name + 1, "newline")) - return(chars[(uint8_t)'\n']); - break; - - case 's': if (c_strings_are_equal(name + 1, "space")) return(chars[(uint8_t)' ']); break; - case 'r': if (c_strings_are_equal(name + 1, "return")) return(chars[(uint8_t)'\r']); break; - case 'l': if (c_strings_are_equal(name + 1, "linefeed")) return(chars[(uint8_t)'\n']); break; - case 't': if (c_strings_are_equal(name + 1, "tab")) return(chars[(uint8_t)'\t']); break; - case 'a': if (c_strings_are_equal(name + 1, "alarm")) return(chars[7]); break; - case 'b': if (c_strings_are_equal(name + 1, "backspace")) return(chars[8]); break; - case 'e': if (c_strings_are_equal(name + 1, "escape")) return(chars[0x1b]); break; - case 'd': if (c_strings_are_equal(name + 1, "delete")) return(chars[0x7f]); break; - - case 'x': - /* #\x is just x, but apparently #\x<num> is int->char? #\x65 -> #\e, and #\xcebb is lambda? */ - { - /* sscanf here misses errors like #\x1.4, but make_atom misses #\x6/3, - * #\x#b0, #\x#e0.0, #\x-0, #\x#e0e100 etc, so we have to do it at an even lower level. - * another problem: #\xbdca2cbec overflows so lval is -593310740 -> segfault unless caught - */ - bool happy = true; - const char *tmp = (const char *)(name + 2); - int32_t lval = 0; - - while ((*tmp) && (happy) && (lval >= 0) && (lval < 256)) - { - int32_t dig = digits[(int32_t)(*tmp++)]; - if (dig < 16) - lval = dig + (lval * 16); - else happy = false; - } - if ((happy) && - (lval < 256) && - (lval >= 0)) - return(chars[lval]); - } - break; - }} + { + case 'n': + if ((c_strings_are_equal(name + 1, "null")) || + (c_strings_are_equal(name + 1, "nul"))) + return(chars[0]); + + if (c_strings_are_equal(name + 1, "newline")) + return(chars[(uint8_t)'\n']); + break; + + case 's': if (c_strings_are_equal(name + 1, "space")) return(chars[(uint8_t)' ']); break; + case 'r': if (c_strings_are_equal(name + 1, "return")) return(chars[(uint8_t)'\r']); break; + case 'l': if (c_strings_are_equal(name + 1, "linefeed")) return(chars[(uint8_t)'\n']); break; + case 't': if (c_strings_are_equal(name + 1, "tab")) return(chars[(uint8_t)'\t']); break; + case 'a': if (c_strings_are_equal(name + 1, "alarm")) return(chars[7]); break; + case 'b': if (c_strings_are_equal(name + 1, "backspace")) return(chars[8]); break; + case 'e': if (c_strings_are_equal(name + 1, "escape")) return(chars[0x1b]); break; + case 'd': if (c_strings_are_equal(name + 1, "delete")) return(chars[0x7f]); break; + + case 'x': + /* #\x is just x, but apparently #\x<num> is int->char? #\x65 -> #\e, and #\xcebb is lambda? */ + { + /* sscanf here misses errors like #\x1.4, but make_atom misses #\x6/3, + * #\x#b0, #\x#e0.0, #\x-0, #\x#e0e100 etc, so we have to do it at an even lower level. + * another problem: #\xbdca2cbec overflows so lval is -593310740 -> segfault unless caught + */ + bool happy = true; + const char *tmp = (const char *)(name + 2); + int32_t lval = 0; + + while ((*tmp) && (happy) && (lval >= 0) && (lval < 256)) + { + int32_t dig = digits[(int32_t)(*tmp++)]; + if (dig < 16) + lval = dig + (lval * 16); + else happy = false; + } + if ((happy) && + (lval < 256) && + (lval >= 0)) + return(chars[lval]); + } + break; + }} return(unknown_sharp_constant(sc, name, NULL)); } @@ -15128,8 +15128,8 @@ static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow) else if (str[0] == '-') { - negative = true; - tmp++; + negative = true; + tmp++; } while (*tmp == '0') {tmp++;}; #if WITH_GMP @@ -15138,72 +15138,72 @@ static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow) if (radix == 10) { while (true) - { - dig = digits[(uint8_t)(*tmp++)]; - if (dig > 9) break; + { + dig = digits[(uint8_t)(*tmp++)]; + if (dig > 9) break; #if HAVE_OVERFLOW_CHECKS - if ((multiply_overflow(lval, (s7_int)10, &lval)) || - (add_overflow(lval, (s7_int)dig, &lval))) - { - if ((radix == 10) && - (strncmp(str, "-9223372036854775808", 20) == 0) && - (digits[(uint8_t)(*tmp++)] > 9)) /* i.e. next thing is not a digit -- "/" for example */ - return(S7_INT64_MIN); - *overflow = true; - return((negative) ? S7_INT64_MIN : S7_INT64_MAX); - } + if ((multiply_overflow(lval, (s7_int)10, &lval)) || + (add_overflow(lval, (s7_int)dig, &lval))) + { + if ((radix == 10) && + (strncmp(str, "-9223372036854775808", 20) == 0) && + (digits[(uint8_t)(*tmp++)] > 9)) /* i.e. next thing is not a digit -- "/" for example */ + return(S7_INT64_MIN); + *overflow = true; + return((negative) ? S7_INT64_MIN : S7_INT64_MAX); + } #else - lval = dig + (lval * 10); - dig = digits[(uint8_t)(*tmp++)]; - if (dig > 9) break; - lval = dig + (lval * 10); + lval = dig + (lval * 10); + dig = digits[(uint8_t)(*tmp++)]; + if (dig > 9) break; + lval = dig + (lval * 10); #endif - }} + }} else while (true) { - dig = digits[(uint8_t)(*tmp++)]; - if (dig >= radix) break; + dig = digits[(uint8_t)(*tmp++)]; + if (dig >= radix) break; #if HAVE_OVERFLOW_CHECKS && (!WITH_GMP) - { - s7_int oval = 0; - if (multiply_overflow(lval, (s7_int)radix, &oval)) - { - /* maybe a bad idea! #xffffffffffffffff -> -1??? this is needed for 64-bit number hacks (see s7test.scm bit-reverse) */ - if ((radix == 16) && - (digits[(uint8_t)(*tmp)] >= radix)) - { - lval -= 576460752303423488LL; /* turn off sign bit */ - lval *= radix; - lval += dig; - lval -= 9223372036854775807LL; - return(lval - 1); - } - lval = oval; /* old case */ - if ((lval == S7_INT64_MIN) && (digits[(uint8_t)(*tmp++)] > 9)) - return(lval); - *overflow = true; - break; - } - else lval = oval; - if (add_overflow(lval, (s7_int)dig, &lval)) - { - if (lval == S7_INT64_MIN) return(lval); - *overflow = true; - break; - }} + { + s7_int oval = 0; + if (multiply_overflow(lval, (s7_int)radix, &oval)) + { + /* maybe a bad idea! #xffffffffffffffff -> -1??? this is needed for 64-bit number hacks (see s7test.scm bit-reverse) */ + if ((radix == 16) && + (digits[(uint8_t)(*tmp)] >= radix)) + { + lval -= 576460752303423488LL; /* turn off sign bit */ + lval *= radix; + lval += dig; + lval -= 9223372036854775807LL; + return(lval - 1); + } + lval = oval; /* old case */ + if ((lval == S7_INT64_MIN) && (digits[(uint8_t)(*tmp++)] > 9)) + return(lval); + *overflow = true; + break; + } + else lval = oval; + if (add_overflow(lval, (s7_int)dig, &lval)) + { + if (lval == S7_INT64_MIN) return(lval); + *overflow = true; + break; + }} #else - lval = dig + (lval * radix); - dig = digits[(uint8_t)(*tmp++)]; - if (dig >= radix) break; - lval = dig + (lval * radix); + lval = dig + (lval * radix); + dig = digits[(uint8_t)(*tmp++)]; + if (dig >= radix) break; + lval = dig + (lval * radix); #endif } #if WITH_GMP if (!(*overflow)) (*overflow) = ((lval > S7_INT32_MAX) || - ((tmp - tmp1) > s7_int_digits_by_radix[radix])); + ((tmp - tmp1) > s7_int_digits_by_radix[radix])); /* this tells the string->number readers to create a bignum. We need to be very conservative here to catch contexts such as (/ 1/524288 19073486328125) */ #endif return((negative) ? -lval : lval); @@ -15266,32 +15266,32 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix bool exp_negative = false; str++; if (*str == '+') - str++; + str++; else - if (*str == '-') - { - str++; - exp_negative = true; - } + if (*str == '-') + { + str++; + exp_negative = true; + } while ((dig = digits[(int32_t)(*str++)]) < 10) /* exponent itself is always base 10 */ - { + { #if HAVE_OVERFLOW_CHECKS - if ((int32_multiply_overflow(exponent, 10, &exponent)) || - (int32_add_overflow(exponent, dig, &exponent))) - { - exponent = 1000000; /* see below */ - break; - } + if ((int32_multiply_overflow(exponent, 10, &exponent)) || + (int32_add_overflow(exponent, dig, &exponent))) + { + exponent = 1000000; /* see below */ + break; + } #else - exponent = dig + (exponent * 10); + exponent = dig + (exponent * 10); #endif - } + } #if (!defined(__GNUC__)) || ((__GNUC__ < 5) && (!defined(__clang__))) if (exponent < 0) /* we overflowed, so make sure we notice it below (need to check for 0.0e... first) (Brian Damgaard) */ - exponent = 1000000; /* see below for examples -- this number needs to be very big but not too big for add */ + exponent = 1000000; /* see below for examples -- this number needs to be very big but not too big for add */ #endif if (exp_negative) - exponent = -exponent; + exponent = -exponent; /* 2e12341234123123123123213123123123 -> 0.0 * but exp len is not the decider: 2e00000000000000000000000000000000000000001 -> 20.0 @@ -15333,69 +15333,69 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix */ for (i = 0; i < max_len; i++) - { - dig = digits[(int32_t)(*str++)]; - if (dig < radix) - int_part = dig + (int_part * radix); - else break; - } + { + dig = digits[(int32_t)(*str++)]; + if (dig < radix) + int_part = dig + (int_part * radix); + else break; + } /* if the exponent is huge, check for 0 int_part and frac_part before complaining (0e1000 or 0.0e1000) */ if ((int_part == 0) && - (exponent > max_len)) - { - /* if frac_part is also 0, return 0.0 */ - if (frac_len == 0) return(0.0); - str = fpart; - while ((dig = digits[(int32_t)(*str++)]) < radix) - frac_part = dig + (frac_part * radix); - if (frac_part == 0) return(0.0); + (exponent > max_len)) + { + /* if frac_part is also 0, return 0.0 */ + if (frac_len == 0) return(0.0); + str = fpart; + while ((dig = digits[(int32_t)(*str++)]) < radix) + frac_part = dig + (frac_part * radix); + if (frac_part == 0) return(0.0); #if WITH_GMP - (*overflow) = true; + (*overflow) = true; #endif - } + } #if WITH_GMP (*overflow) = ((int_part > 0) || (exponent > 20)); /* .1e310 is a tricky case */ #endif if (int_part != 0) /* 0.<310 zeros here>1e310 for example -- pow (via dpow) thinks it has to be too big, returns Nan, - * then Nan * 0 -> Nan and the NaN propagates - */ - { - if (int_len <= max_len) - dval = int_part * dpow(radix, exponent); - else dval = int_part * dpow(radix, exponent + int_len - max_len); - } + * then Nan * 0 -> Nan and the NaN propagates + */ + { + if (int_len <= max_len) + dval = int_part * dpow(radix, exponent); + else dval = int_part * dpow(radix, exponent + int_len - max_len); + } else dval = 0.0; /* shift by exponent, but if int_len > max_len then we assumed (see below) int_len - max_len 0's on the left */ /* using int_to_int or table lookups here instead of pow did not make any difference in speed */ if (int_len < max_len) - { - str = fpart; - for (int32_t k = 0; (frac_len > 0) && (k < exponent); k += max_len) - { - int32_t flen = (frac_len > max_len) ? max_len : frac_len; /* ? */ - frac_len -= max_len; - frac_part = 0; - for (i = 0; i < flen; i++) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - if (frac_part != 0) /* same pow->NaN problem as above can occur here */ - dval += frac_part * dpow(radix, exponent - flen - k); - }} + { + str = fpart; + for (int32_t k = 0; (frac_len > 0) && (k < exponent); k += max_len) + { + int32_t flen = (frac_len > max_len) ? max_len : frac_len; /* ? */ + frac_len -= max_len; + frac_part = 0; + for (i = 0; i < flen; i++) + frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); + if (frac_part != 0) /* same pow->NaN problem as above can occur here */ + dval += frac_part * dpow(radix, exponent - flen - k); + }} else - /* some of the fraction is in the integer part before the negative exponent shifts it over */ - if (int_len > max_len) - { - int32_t ilen = int_len - max_len; /* we read these above */ - /* str should be at the last digit we read */ - if (ilen > max_len) - ilen = max_len; - for (i = 0; i < ilen; i++) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - dval += frac_part * dpow(radix, exponent - ilen); - } + /* some of the fraction is in the integer part before the negative exponent shifts it over */ + if (int_len > max_len) + { + int32_t ilen = int_len - max_len; /* we read these above */ + /* str should be at the last digit we read */ + if (ilen > max_len) + ilen = max_len; + for (i = 0; i < ilen; i++) + frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); + dval += frac_part * dpow(radix, exponent - ilen); + } return(sign * dval); } @@ -15412,12 +15412,12 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix * this always combines the same integer and the same exponent no matter how the number is expressed. */ if (int_len > 0) - { - const char *iend = (const char *)(str + int_len - 1); - while ((*iend == '0') && (iend != str)) {iend--; int_exponent++;} - while (str <= iend) - int_part = digits[(int32_t)(*str++)] + (int_part * radix); - } + { + const char *iend = (const char *)(str + int_len - 1); + while ((*iend == '0') && (iend != str)) {iend--; int_exponent++;} + while (str <= iend) + int_part = digits[(int32_t)(*str++)] + (int_part * radix); + } dval = (int_exponent == 0) ? (s7_double)int_part : int_part * dpow(radix, int_exponent); } else @@ -15431,14 +15431,14 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix * 98765432101234567890987654321.0e-28 9.8765432101235 */ for (i = 0; i < len; i++) - int_part = digits[(int32_t)(*str++)] + (int_part * radix); + int_part = digits[(int32_t)(*str++)] + (int_part * radix); flen = -exponent; if (flen > max_len) - flen = max_len; + flen = max_len; for (i = 0; i < flen; i++) - frpart = digits[(int32_t)(*str++)] + (frpart * radix); + frpart = digits[(int32_t)(*str++)] + (frpart * radix); if (len <= 0) - dval = int_part + frpart * dpow(radix, len - flen); + dval = int_part + frpart * dpow(radix, len - flen); else dval = int_part + frpart * dpow(radix, -flen); } @@ -15446,63 +15446,63 @@ static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix { str = fpart; if (frac_len <= max_len) - { - /* splitting out base 10 case saves very little here */ - /* this ignores trailing zeros, so that 0.3 equals 0.300 */ - const char *fend = (const char *)(str + frac_len - 1); - - while ((*fend == '0') && (fend != str)) {fend--; frac_len--;} /* (= .6 0.6000) */ - if ((frac_len & 1) == 0) - { - while (str <= fend) - { - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - }} - else - while (str <= fend) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - - dval += frac_part * dpow(radix, exponent - frac_len); - - /* 0.6: frac: 6, exp: 0.10000000000000000555, val: 0.60000000000000008882 - * 0.60: frac: 60, exp: 0.01000000000000000021, val: 0.59999999999999997780 - * 0.6000: frac: 6000, exp: 0.00010000000000000000, val: 0.59999999999999997780 - * (= 0.6 0.60): #f - * (= #i3/5 0.6): #f - * so (string->number (number->string num)) == num only if both num's are the same text (or you get lucky) - * (= 0.6 6e-1): #t ; but not 60e-2 - * to fix the 0.60 case, we need to ignore trailing post-dot zeros. - */ - } + { + /* splitting out base 10 case saves very little here */ + /* this ignores trailing zeros, so that 0.3 equals 0.300 */ + const char *fend = (const char *)(str + frac_len - 1); + + while ((*fend == '0') && (fend != str)) {fend--; frac_len--;} /* (= .6 0.6000) */ + if ((frac_len & 1) == 0) + { + while (str <= fend) + { + frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); + frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); + }} + else + while (str <= fend) + frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); + + dval += frac_part * dpow(radix, exponent - frac_len); + + /* 0.6: frac: 6, exp: 0.10000000000000000555, val: 0.60000000000000008882 + * 0.60: frac: 60, exp: 0.01000000000000000021, val: 0.59999999999999997780 + * 0.6000: frac: 6000, exp: 0.00010000000000000000, val: 0.59999999999999997780 + * (= 0.6 0.60): #f + * (= #i3/5 0.6): #f + * so (string->number (number->string num)) == num only if both num's are the same text (or you get lucky) + * (= 0.6 6e-1): #t ; but not 60e-2 + * to fix the 0.60 case, we need to ignore trailing post-dot zeros. + */ + } else - { - if (exponent <= 0) - { - for (i = 0; i < max_len; i++) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - - dval += frac_part * dpow(radix, exponent - max_len); - } - else - { - /* 1.0123456789876543210e1 10.12345678987654373771 - * 1.0123456789876543210e10 10123456789.87654304504394531250 - * 0.000000010000000000000000e10 100.0 - * 0.000000010000000000000000000000000000000000000e10 100.0 - * 0.000000012222222222222222222222222222222222222e10 122.22222222222222 - * 0.000000012222222222222222222222222222222222222e17 1222222222.222222 - */ - int_part = 0; - for (i = 0; i < exponent; i++) - int_part = digits[(int32_t)(*str++)] + (int_part * radix); - frac_len -= exponent; - if (frac_len > max_len) - frac_len = max_len; - for (i = 0; i < frac_len; i++) - frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); - dval += int_part + frac_part * dpow(radix, -frac_len); - }}} + { + if (exponent <= 0) + { + for (i = 0; i < max_len; i++) + frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); + + dval += frac_part * dpow(radix, exponent - max_len); + } + else + { + /* 1.0123456789876543210e1 10.12345678987654373771 + * 1.0123456789876543210e10 10123456789.87654304504394531250 + * 0.000000010000000000000000e10 100.0 + * 0.000000010000000000000000000000000000000000000e10 100.0 + * 0.000000012222222222222222222222222222222222222e10 122.22222222222222 + * 0.000000012222222222222222222222222222222222222e17 1222222222.222222 + */ + int_part = 0; + for (i = 0; i < exponent; i++) + int_part = digits[(int32_t)(*str++)] + (int_part * radix); + frac_len -= exponent; + if (frac_len > max_len) + frac_len = max_len; + for (i = 0; i < frac_len; i++) + frac_part = digits[(int32_t)(*str++)] + (frac_part * radix); + dval += int_part + frac_part * dpow(radix, -frac_len); + }}} #if WITH_GMP if ((int_part == 0) && (frac_part == 0)) @@ -15532,15 +15532,15 @@ static s7_pointer nan1_or_bust(s7_scheme *sc, s7_double x, const char *p, const if (p[len - 1] == 'i') /* +nan.0[+/-]...i */ { if (len == (offset + 2)) /* +nan.0+i */ - return(make_complex_not_0i(sc, x, (p[offset] == '+') ? 1.0 : -1.0)); + return(make_complex_not_0i(sc, x, (p[offset] == '+') ? 1.0 : -1.0)); if ((len > (offset + 1)) && (len < 1024)) /* make compiler happy */ - { - char *ip = copy_string_with_length((const char *)(p + offset), len - offset - 1); - s7_pointer imag = make_atom(sc, ip, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR); - free(ip); - if (is_real(imag)) - return(make_complex(sc, x, real_to_double(sc, imag, __func__))); /* +nan.0+2/3i etc */ - }} + { + char *ip = copy_string_with_length((const char *)(p + offset), len - offset - 1); + s7_pointer imag = make_atom(sc, ip, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR); + free(ip); + if (is_real(imag)) + return(make_complex(sc, x, real_to_double(sc, imag, __func__))); /* +nan.0+2/3i etc */ + }} return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); } @@ -15553,7 +15553,7 @@ static s7_pointer nan2_or_bust(s7_scheme *sc, s7_double x, const char *q, int32_ s7_pointer rl = make_atom(sc, ip, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR); free(ip); if (is_real(rl)) - return(make_complex(sc, real_to_double(sc, rl, __func__), x)); + return(make_complex(sc, real_to_double(sc, rl, __func__), x)); } return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); } @@ -15580,19 +15580,19 @@ static s7_pointer make_symbol_or_number(s7_scheme *sc, const char *name, int32_t for (i = 0, j = 0; i < len; i++) if (name[i] != sep) { - if ((digits[(uint8_t)(name[i])] < radix) || (!t_number_separator_p[(uint8_t)name[i]])) - new_name[j++] = name[i]; - else - { - liberate(sc, b); - return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); - }} + if ((digits[(uint8_t)(name[i])] < radix) || (!t_number_separator_p[(uint8_t)name[i]])) + new_name[j++] = name[i]; + else + { + liberate(sc, b); + return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); + }} else /* sep has to be between two digits */ if ((digits[(uint8_t)(name[i - 1])] >= radix) || (digits[(uint8_t)(name[i + 1])] >= radix)) - { - liberate(sc, b); - return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); - } + { + liberate(sc, b); + return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F); + } new_name[j] = '\0'; res = string_to_number(sc, new_name, radix); @@ -15623,55 +15623,55 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_sym case '-': c = *p++; if (c == '.') - { - has_dec_point1 = true; - c = *p++; - } + { + has_dec_point1 = true; + c = *p++; + } if (!c) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); if (!is_digit(c, radix)) - { - if (has_dec_point1) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - if (c == 'n') - { - if (local_strcmp(p, "an.0")) /* +nan.0, even if we read -nan.0 -- what's the point of a negative NaN? */ - return(real_NaN); - if ((local_strncmp(p, "an.0", 4)) && /* +nan.0[+/-]...i */ - ((p[4] == '+') || (p[4] == '-'))) - return(nan1_or_bust(sc, NAN, p, q, radix, want_symbol, 4)); - /* read +/-nan.<int> or +/-nan.<int>+/-...i */ - if (local_strncmp(p, "an.", 3)) /* +nan.<int> */ - { - bool overflow = false; - int32_t i; - for (i = 3; is_digit(p[i], 10); i++); - if ((p[i] == '+') || (p[i] == '-')) /* complex case */ - { - int64_t payload = string_to_integer((char *)(p + 3), 10, &overflow); - return(nan1_or_bust(sc, nan_with_payload(payload), p, q, radix, want_symbol, i)); - } - if ((p[i] != '\0') && (!white_space[(uint8_t)(p[i])])) /* check for +nan.0i etc, '\0' is not white_space apparently */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - return(make_nan_with_payload(sc, string_to_integer((char *)(p + 3), 10, &overflow))); - }} - if (c == 'i') - { - if (local_strcmp(p, "nf.0")) /* +inf.0 */ - return((q[0] == '+') ? real_infinity : real_minus_infinity); - if ((local_strncmp(p, "nf.0", 4)) && - ((p[4] == '+') || (p[4] == '-'))) - return(nan1_or_bust(sc, (q[0] == '-') ? -INFINITY : INFINITY, p, q, radix, want_symbol, 4)); - } - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - } + { + if (has_dec_point1) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + if (c == 'n') + { + if (local_strcmp(p, "an.0")) /* +nan.0, even if we read -nan.0 -- what's the point of a negative NaN? */ + return(real_NaN); + if ((local_strncmp(p, "an.0", 4)) && /* +nan.0[+/-]...i */ + ((p[4] == '+') || (p[4] == '-'))) + return(nan1_or_bust(sc, NAN, p, q, radix, want_symbol, 4)); + /* read +/-nan.<int> or +/-nan.<int>+/-...i */ + if (local_strncmp(p, "an.", 3)) /* +nan.<int> */ + { + bool overflow = false; + int32_t i; + for (i = 3; is_digit(p[i], 10); i++); + if ((p[i] == '+') || (p[i] == '-')) /* complex case */ + { + int64_t payload = string_to_integer((char *)(p + 3), 10, &overflow); + return(nan1_or_bust(sc, nan_with_payload(payload), p, q, radix, want_symbol, i)); + } + if ((p[i] != '\0') && (!white_space[(uint8_t)(p[i])])) /* check for +nan.0i etc, '\0' is not white_space apparently */ + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + return(make_nan_with_payload(sc, string_to_integer((char *)(p + 3), 10, &overflow))); + }} + if (c == 'i') + { + if (local_strcmp(p, "nf.0")) /* +inf.0 */ + return((q[0] == '+') ? real_infinity : real_minus_infinity); + if ((local_strncmp(p, "nf.0", 4)) && + ((p[4] == '+') || (p[4] == '-'))) + return(nan1_or_bust(sc, (q[0] == '-') ? -INFINITY : INFINITY, p, q, radix, want_symbol, 4)); + } + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + } break; case '.': has_dec_point1 = true; c = *p++; if ((!c) || (!is_digit(c, radix))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); break; case 'n': @@ -15686,7 +15686,7 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_sym default: if (!is_digit(c, radix)) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); break; } @@ -15702,145 +15702,145 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_sym for ( ; (c = *p) != 0; ++p) { - /* what about embedded null? (string->number (string #\1 (integer->char 0) #\0)) - * currently we stop and return 1, but Guile returns #f. - * this also means we can't use substring_uncopied if (string->number (substring...)) - */ - if (!is_digit(c, current_radix)) /* moving this inside the switch statement was much slower */ - { - current_radix = radix; - - switch (c) - { - /* -------- decimal point -------- */ - case '.': - if ((!is_digit(p[1], current_radix)) && - (!is_digit(p[-1], current_radix))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if (has_plus_or_minus == 0) - { - if ((has_dec_point1) || (slash1)) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - has_dec_point1 = true; - } - else - { - if ((has_dec_point2) || (slash2)) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - has_dec_point2 = true; - } - continue; - - /* -------- exponent marker -------- */ + /* what about embedded null? (string->number (string #\1 (integer->char 0) #\0)) + * currently we stop and return 1, but Guile returns #f. + * this also means we can't use substring_uncopied if (string->number (substring...)) + */ + if (!is_digit(c, current_radix)) /* moving this inside the switch statement was much slower */ + { + current_radix = radix; + + switch (c) + { + /* -------- decimal point -------- */ + case '.': + if ((!is_digit(p[1], current_radix)) && + (!is_digit(p[-1], current_radix))) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + + if (has_plus_or_minus == 0) + { + if ((has_dec_point1) || (slash1)) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + has_dec_point1 = true; + } + else + { + if ((has_dec_point2) || (slash2)) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + has_dec_point2 = true; + } + continue; + + /* -------- exponent marker -------- */ #if WITH_EXTRA_EXPONENT_MARKERS - /* 1st 3d-perspective 0.0f 128.0f 3d 1s -- in 2 million lines of public scheme code, not one actual use! */ - case 's': case 'S': - case 'd': case 'D': - case 'f': case 'F': - case 'l': case 'L': -#endif - case 'e': case 'E': - if (current_radix > 10) /* see above */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - /* fall through -- if '@' used, radices>10 are ok */ - - case '@': - current_radix = 10; - - if (((ex1) || - (slash1)) && - (has_plus_or_minus == 0)) /* ee */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if (((ex2) || - (slash2)) && - (has_plus_or_minus != 0)) /* 1+1.0ee */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if ((!is_digit(p[-1], radix)) && /* was current_radix but that's always 10! */ - (p[-1] != '.')) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if (has_plus_or_minus == 0) - { - ex1 = p; - has_dec_point1 = true; /* decimal point illegal from now on */ - } - else - { - ex2 = p; - has_dec_point2 = true; - } - p++; - if ((*p == '-') || (*p == '+')) p++; - if (is_digit(*p, current_radix)) - continue; - break; - - /* -------- internal + or - -------- */ - case '+': - case '-': - if (has_plus_or_minus != 0) /* already have the separator */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - has_plus_or_minus = (c == '+') ? 1 : -1; - plus = (char *)(p + 1); - /* now check for nan/inf as imaginary part */ - - if ((plus[0] == 'n') && - (local_strncmp(plus, "nan.", 4))) - { - bool overflow1 = false; - int64_t payload = string_to_integer((char *)(p + 5), 10, &overflow1); - return(nan2_or_bust(sc, nan_with_payload(payload), q, radix, want_symbol, (intptr_t)(p - q))); - } - if ((plus[0] == 'i') && - (local_strcmp(plus, "inf.0i"))) - return(nan2_or_bust(sc, (c == '+') ? INFINITY : -INFINITY, q, radix, want_symbol, (intptr_t)(p - q))); - continue; - - /* ratio marker */ - case '/': - if ((has_plus_or_minus == 0) && - ((ex1) || - (slash1) || - (has_dec_point1))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if ((has_plus_or_minus != 0) && - ((ex2) || - (slash2) || - (has_dec_point2))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - if (has_plus_or_minus == 0) - slash1 = (char *)(p + 1); - else slash2 = (char *)(p + 1); - - if ((!is_digit(p[1], current_radix)) || - (!is_digit(p[-1], current_radix))) - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - - continue; - - /* -------- i for the imaginary part -------- */ - case 'i': - if ((has_plus_or_minus != 0) && - (!has_i)) - { - has_i = true; - continue; - } - break; - - default: break; - } - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - }} + /* 1st 3d-perspective 0.0f 128.0f 3d 1s -- in 2 million lines of public scheme code, not one actual use! */ + case 's': case 'S': + case 'd': case 'D': + case 'f': case 'F': + case 'l': case 'L': +#endif + case 'e': case 'E': + if (current_radix > 10) /* see above */ + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + /* fall through -- if '@' used, radices>10 are ok */ + + case '@': + current_radix = 10; + + if (((ex1) || + (slash1)) && + (has_plus_or_minus == 0)) /* ee */ + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + + if (((ex2) || + (slash2)) && + (has_plus_or_minus != 0)) /* 1+1.0ee */ + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + + if ((!is_digit(p[-1], radix)) && /* was current_radix but that's always 10! */ + (p[-1] != '.')) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + + if (has_plus_or_minus == 0) + { + ex1 = p; + has_dec_point1 = true; /* decimal point illegal from now on */ + } + else + { + ex2 = p; + has_dec_point2 = true; + } + p++; + if ((*p == '-') || (*p == '+')) p++; + if (is_digit(*p, current_radix)) + continue; + break; + + /* -------- internal + or - -------- */ + case '+': + case '-': + if (has_plus_or_minus != 0) /* already have the separator */ + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + + has_plus_or_minus = (c == '+') ? 1 : -1; + plus = (char *)(p + 1); + /* now check for nan/inf as imaginary part */ + + if ((plus[0] == 'n') && + (local_strncmp(plus, "nan.", 4))) + { + bool overflow1 = false; + int64_t payload = string_to_integer((char *)(p + 5), 10, &overflow1); + return(nan2_or_bust(sc, nan_with_payload(payload), q, radix, want_symbol, (intptr_t)(p - q))); + } + if ((plus[0] == 'i') && + (local_strcmp(plus, "inf.0i"))) + return(nan2_or_bust(sc, (c == '+') ? INFINITY : -INFINITY, q, radix, want_symbol, (intptr_t)(p - q))); + continue; + + /* ratio marker */ + case '/': + if ((has_plus_or_minus == 0) && + ((ex1) || + (slash1) || + (has_dec_point1))) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + + if ((has_plus_or_minus != 0) && + ((ex2) || + (slash2) || + (has_dec_point2))) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + + if (has_plus_or_minus == 0) + slash1 = (char *)(p + 1); + else slash2 = (char *)(p + 1); + + if ((!is_digit(p[1], current_radix)) || + (!is_digit(p[-1], current_radix))) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + + continue; + + /* -------- i for the imaginary part -------- */ + case 'i': + if ((has_plus_or_minus != 0) && + (!has_i)) + { + has_i = true; + continue; + } + break; + + default: break; + } + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + }} if ((has_plus_or_minus != 0) && /* that is, we have an internal + or - */ - (!has_i)) /* but no i for the imaginary part */ + (!has_i)) /* but no i for the imaginary part */ return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); #if WITH_NUMBER_SEPARATOR @@ -15851,152 +15851,152 @@ static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_sym if (has_i) { #if (!WITH_GMP) - s7_double rl = 0.0, im = 0.0; + s7_double rl = 0.0, im = 0.0; #else - char e1 = 0, e2 = 0; + char e1 = 0, e2 = 0; #endif - s7_pointer result; - s7_int len = safe_strlen(q); - char ql1, pl1; + s7_pointer result; + s7_int len = safe_strlen(q); + char ql1, pl1; - if (q[len - 1] != 'i') - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + if (q[len - 1] != 'i') + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); - /* save original string */ - ql1 = q[len - 1]; - pl1 = (*(plus - 1)); + /* save original string */ + ql1 = q[len - 1]; + pl1 = (*(plus - 1)); #if WITH_GMP - if (ex1) {e1 = *ex1; (*ex1) = '@';} /* for mpfr */ - if (ex2) {e2 = *ex2; (*ex2) = '@';} + if (ex1) {e1 = *ex1; (*ex1) = '@';} /* for mpfr */ + if (ex2) {e2 = *ex2; (*ex2) = '@';} #endif - /* look for cases like 1+i */ - q[len - 1] = ((q[len - 2] == '+') || (q[len - 2] == '-')) ? '1' : '\0'; /* remove 'i' */ + /* look for cases like 1+i */ + q[len - 1] = ((q[len - 2] == '+') || (q[len - 2] == '-')) ? '1' : '\0'; /* remove 'i' */ - (*((char *)(plus - 1))) = '\0'; + (*((char *)(plus - 1))) = '\0'; #if (!WITH_GMP) - if ((has_dec_point1) || - (ex1)) /* (string->number "1100.1+0.11i" 2) -- need to split into 2 honest reals before passing to non-base-10 str->dbl */ - rl = string_to_double_with_radix(q, radix, ignored); - else /* no decimal point, no exponent, a ratio (1/2+i for example, but 1+2/3i is handled below) */ - { - if (slash1) - { - /* here the overflow could be innocuous if it's in the denominator and the numerator is 0: 0/100000000000000000000000000000000000000 */ - s7_int den, num = string_to_integer(q, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - den = string_to_integer(slash1, radix, &overflow); - if (den == 0) - rl = NAN; /* real_part if complex */ - else - { - if (num == 0) - { - rl = 0.0; - overflow = false; - } - else - { - if (overflow) return(make_undefined_bignum(sc, q)); /* denominator overflow */ - rl = (long_double)num / (long_double)den; /* no gmp, so we do what we can */ - }}} - else - { - rl = (s7_double)string_to_integer(q, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - }} - if (rl == -0.0) rl = 0.0; - - if ((has_dec_point2) || - (ex2)) - im = string_to_double_with_radix(plus, radix, ignored); - else - { - if (slash2) /* complex part I think */ - { - /* same as above: 0-0/100000000000000000000000000000000000000i */ - s7_int den, num = string_to_integer(plus, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - den = string_to_integer(slash2, radix, &overflow); - if (den == 0) - im = NAN; - else - { - if (num == 0) - { - im = 0.0; - overflow = false; - } - else - { - if (overflow) return(make_undefined_bignum(sc, q)); /* denominator overflow */ - im = (long_double)num / (long_double)den; - }}} - else - { - im = (s7_double)string_to_integer(plus, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - }} - if ((has_plus_or_minus == -1) && - (im != 0.0)) - im = -im; - result = make_complex(sc, rl, im); + if ((has_dec_point1) || + (ex1)) /* (string->number "1100.1+0.11i" 2) -- need to split into 2 honest reals before passing to non-base-10 str->dbl */ + rl = string_to_double_with_radix(q, radix, ignored); + else /* no decimal point, no exponent, a ratio (1/2+i for example, but 1+2/3i is handled below) */ + { + if (slash1) + { + /* here the overflow could be innocuous if it's in the denominator and the numerator is 0: 0/100000000000000000000000000000000000000 */ + s7_int den, num = string_to_integer(q, radix, &overflow); + if (overflow) return(make_undefined_bignum(sc, q)); + den = string_to_integer(slash1, radix, &overflow); + if (den == 0) + rl = NAN; /* real_part if complex */ + else + { + if (num == 0) + { + rl = 0.0; + overflow = false; + } + else + { + if (overflow) return(make_undefined_bignum(sc, q)); /* denominator overflow */ + rl = (long_double)num / (long_double)den; /* no gmp, so we do what we can */ + }}} + else + { + rl = (s7_double)string_to_integer(q, radix, &overflow); + if (overflow) return(make_undefined_bignum(sc, q)); + }} + if (rl == -0.0) rl = 0.0; + + if ((has_dec_point2) || + (ex2)) + im = string_to_double_with_radix(plus, radix, ignored); + else + { + if (slash2) /* complex part I think */ + { + /* same as above: 0-0/100000000000000000000000000000000000000i */ + s7_int den, num = string_to_integer(plus, radix, &overflow); + if (overflow) return(make_undefined_bignum(sc, q)); + den = string_to_integer(slash2, radix, &overflow); + if (den == 0) + im = NAN; + else + { + if (num == 0) + { + im = 0.0; + overflow = false; + } + else + { + if (overflow) return(make_undefined_bignum(sc, q)); /* denominator overflow */ + im = (long_double)num / (long_double)den; + }}} + else + { + im = (s7_double)string_to_integer(plus, radix, &overflow); + if (overflow) return(make_undefined_bignum(sc, q)); + }} + if ((has_plus_or_minus == -1) && + (im != 0.0)) + im = -im; + result = make_complex(sc, rl, im); #else - result = string_to_either_complex(sc, q, slash1, ex1, has_dec_point1, plus, slash2, ex2, has_dec_point2, radix, has_plus_or_minus); + result = string_to_either_complex(sc, q, slash1, ex1, has_dec_point1, plus, slash2, ex2, has_dec_point2, radix, has_plus_or_minus); #endif - /* restore original string */ - q[len - 1] = ql1; - (*((char *)(plus - 1))) = pl1; + /* restore original string */ + q[len - 1] = ql1; + (*((char *)(plus - 1))) = pl1; #if WITH_GMP - if (ex1) (*ex1) = e1; - if (ex2) (*ex2) = e2; + if (ex1) (*ex1) = e1; + if (ex2) (*ex2) = e2; #endif - return(result); + return(result); } /* not complex */ if ((has_dec_point1) || - (ex1)) + (ex1)) { - s7_pointer result; - if (slash1) /* not complex, so slash and "." is not a number */ - return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + s7_pointer result; + if (slash1) /* not complex, so slash and "." is not a number */ + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); #if (!WITH_GMP) - result = make_real(sc, string_to_double_with_radix(q, radix, ignored)); + result = make_real(sc, string_to_double_with_radix(q, radix, ignored)); #else - { - char old_e = 0; - if (ex1) - { - old_e = (*ex1); - (*ex1) = '@'; - } - result = string_to_either_real(sc, q, radix); - if (ex1) - (*ex1) = old_e; - } -#endif - return(result); + { + char old_e = 0; + if (ex1) + { + old_e = (*ex1); + (*ex1) = '@'; + } + result = string_to_either_real(sc, q, radix); + if (ex1) + (*ex1) = old_e; + } +#endif + return(result); } /* rational */ if (slash1) #if (!WITH_GMP) { - s7_int d, n = string_to_integer(q, radix, &overflow); - if (overflow) return(make_undefined_bignum(sc, q)); - d = string_to_integer(slash1, radix, &overflow); - - if ((n == 0) && (d != 0)) /* 0/100000000000000000000000000000000000000 */ - return(int_zero); - if (d == 0) return(real_NaN); - if (overflow) return(make_undefined_bignum(sc, q)); - /* it would be neat to return 1 from 10000000000000000000000000000/10000000000000000000000000000 - * but q is the entire number ('/' included) and slash1 is the stuff after the '/', and every - * big number comes through here, so there's no clean and safe way to check that q == slash1. - */ - return(make_ratio(sc, n, d)); + s7_int d, n = string_to_integer(q, radix, &overflow); + if (overflow) return(make_undefined_bignum(sc, q)); + d = string_to_integer(slash1, radix, &overflow); + + if ((n == 0) && (d != 0)) /* 0/100000000000000000000000000000000000000 */ + return(int_zero); + if (d == 0) return(real_NaN); + if (overflow) return(make_undefined_bignum(sc, q)); + /* it would be neat to return 1 from 10000000000000000000000000000/10000000000000000000000000000 + * but q is the entire number ('/' included) and slash1 is the stuff after the '/', and every + * big number comes through here, so there's no clean and safe way to check that q == slash1. + */ + return(make_ratio(sc, n, d)); } #else return(string_to_either_ratio(sc, q, slash1, radix)); @@ -16061,10 +16061,10 @@ static s7_pointer g_string_to_number_1(s7_scheme *sc, s7_pointer args, s7_pointe { s7_pointer rad = cadr(args); if (!s7_is_integer(rad)) - return(method_or_bust(sc, rad, caller, args, sc->type_names[T_INTEGER], 2)); + return(method_or_bust(sc, rad, caller, args, sc->type_names[T_INTEGER], 2)); radix = s7_integer_clamped_if_gmp(sc, rad); if ((radix < 2) || (radix > 16)) - out_of_range_error_nr(sc, caller, int_two, rad, a_valid_radix_string); + out_of_range_error_nr(sc, caller, int_two, rad, a_valid_radix_string); } else radix = 10; str = (char *)string_value(car(args)); @@ -16097,7 +16097,7 @@ static inline s7_pointer abs_p_p(s7_scheme *sc, s7_pointer x) if (is_t_real(x)) { if (is_NaN(real(x))) - return((nan_payload(real(x)) > 0) ? x : real_NaN); /* (abs -nan.0) -> +nan.0?? */ + return((nan_payload(real(x)) > 0) ? x : real_NaN); /* (abs -nan.0) -> +nan.0?? */ return((signbit(real(x))) ? make_real(sc, -real(x)) : x); } #endif @@ -16107,14 +16107,14 @@ static inline s7_pointer abs_p_p(s7_scheme *sc, s7_pointer x) if (integer(x) >= 0) return(x); #if WITH_GMP if (integer(x) == S7_INT64_MIN) - { - x = s7_int_to_big_integer(sc, integer(x)); - mpz_neg(big_integer(x), big_integer(x)); - return(x); - } + { + x = s7_int_to_big_integer(sc, integer(x)); + mpz_neg(big_integer(x), big_integer(x)); + return(x); + } #else if (integer(x) == S7_INT64_MIN) - sole_arg_out_of_range_error_nr(sc, sc->abs_symbol, set_elist_1(sc, x), result_is_too_large_string); + sole_arg_out_of_range_error_nr(sc, sc->abs_symbol, set_elist_1(sc, x), result_is_too_large_string); #endif return(make_integer(sc, -integer(x))); @@ -16122,27 +16122,27 @@ static inline s7_pointer abs_p_p(s7_scheme *sc, s7_pointer x) if (numerator(x) >= 0) return(x); #if WITH_GMP && (!POINTER_32) if (numerator(x) == S7_INT64_MIN) - { - s7_pointer p; - mpz_set_si(sc->mpz_1, S7_INT64_MIN); - mpz_neg(sc->mpz_1, sc->mpz_1); - mpz_set_si(sc->mpz_2, denominator(x)); - new_cell(sc, p, T_BIG_RATIO); - big_ratio_bgr(p) = alloc_bigrat(sc); - add_big_ratio(sc, p); - mpq_set_num(big_ratio(p), sc->mpz_1); - mpq_set_den(big_ratio(p), sc->mpz_2); - return(p); - } + { + s7_pointer p; + mpz_set_si(sc->mpz_1, S7_INT64_MIN); + mpz_neg(sc->mpz_1, sc->mpz_1); + mpz_set_si(sc->mpz_2, denominator(x)); + new_cell(sc, p, T_BIG_RATIO); + big_ratio_bgr(p) = alloc_bigrat(sc); + add_big_ratio(sc, p); + mpq_set_num(big_ratio(p), sc->mpz_1); + mpq_set_den(big_ratio(p), sc->mpz_2); + return(p); + } #else if (numerator(x) == S7_INT64_MIN) - return(make_ratio(sc, S7_INT64_MAX, denominator(x))); + return(make_ratio(sc, S7_INT64_MAX, denominator(x))); #endif return(make_simple_ratio(sc, -numerator(x), denominator(x))); case T_REAL: if (is_NaN(real(x))) /* (abs -nan.0) -> +nan.0, not -nan.0 */ - return((nan_payload(real(x)) > 0) ? x : real_NaN); + return((nan_payload(real(x)) > 0) ? x : real_NaN); return((signbit(real(x))) ? make_real(sc, -real(x)) : x); /* (abs -0.0) returns -0.0 -- Shiro Kawai */ #if WITH_GMP case T_BIG_INTEGER: @@ -16200,7 +16200,7 @@ static s7_pointer magnitude_p_p(s7_scheme *sc, s7_pointer x) return((numerator(x) < 0) ? make_simple_ratio(sc, -numerator(x), denominator(x)) : x); case T_REAL: if (is_NaN(real(x))) /* (magnitude -nan.0) -> +nan.0, not -nan.0 */ - return((nan_payload(real(x)) > 0) ? x : real_NaN); + return((nan_payload(real(x)) > 0) ? x : real_NaN); return((signbit(real(x))) ? make_real(sc, -real(x)) : x); #if WITH_GMP case T_BIG_INTEGER: @@ -16278,9 +16278,9 @@ static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args) break; case T_REAL: if (is_NaN(real(pp0))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_nan_string); + out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_nan_string); if (is_inf(real(pp0))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_infinite_string); + out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_infinite_string); mpfr_set_d(r->ux, real(pp0), MPFR_RNDN); break; case T_BIG_INTEGER: @@ -16291,9 +16291,9 @@ static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args) break; case T_BIG_REAL: if (mpfr_nan_p(big_real(pp0))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_nan_string); + out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_nan_string); if (mpfr_inf_p(big_real(pp0))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_infinite_string); + out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, pp0, it_is_infinite_string); mpfr_set(r->ux, big_real(pp0), MPFR_RNDN); break; case T_COMPLEX: @@ -16309,40 +16309,40 @@ static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args) { s7_pointer pp1 = cadr(args); switch (type(pp1)) - { - case T_INTEGER: - mpfr_set_si(r->error, integer(pp1), MPFR_RNDN); - break; - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(pp1), denominator(pp1)); - mpfr_set_q(r->error, sc->mpq_1, MPFR_RNDN); - break; - case T_REAL: - if (is_NaN(real(pp1))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, pp1, it_is_nan_string); - if (is_inf(real(pp1))) - return(int_zero); - mpfr_set_d(r->error, real(pp1), MPFR_RNDN); - break; - case T_BIG_INTEGER: - mpfr_set_z(r->error, big_integer(pp1), MPFR_RNDN); - break; - case T_BIG_RATIO: - mpfr_set_q(r->error, big_ratio(pp1), MPFR_RNDN); - break; - case T_BIG_REAL: - if (mpfr_nan_p(big_real(pp1))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, pp1, it_is_nan_string); - if (mpfr_inf_p(big_real(pp1))) - return(int_zero); - mpfr_set(r->error, big_real(pp1), MPFR_RNDN); - break; - case T_COMPLEX: - case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->rationalize_symbol, 2, pp1, sc->type_names[T_REAL]); - default: - return(method_or_bust(sc, pp1, sc->rationalize_symbol, args, sc->type_names[T_REAL], 2)); - } + { + case T_INTEGER: + mpfr_set_si(r->error, integer(pp1), MPFR_RNDN); + break; + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(pp1), denominator(pp1)); + mpfr_set_q(r->error, sc->mpq_1, MPFR_RNDN); + break; + case T_REAL: + if (is_NaN(real(pp1))) + out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, pp1, it_is_nan_string); + if (is_inf(real(pp1))) + return(int_zero); + mpfr_set_d(r->error, real(pp1), MPFR_RNDN); + break; + case T_BIG_INTEGER: + mpfr_set_z(r->error, big_integer(pp1), MPFR_RNDN); + break; + case T_BIG_RATIO: + mpfr_set_q(r->error, big_ratio(pp1), MPFR_RNDN); + break; + case T_BIG_REAL: + if (mpfr_nan_p(big_real(pp1))) + out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, pp1, it_is_nan_string); + if (mpfr_inf_p(big_real(pp1))) + return(int_zero); + mpfr_set(r->error, big_real(pp1), MPFR_RNDN); + break; + case T_COMPLEX: + case T_BIG_COMPLEX: + wrong_type_error_nr(sc, sc->rationalize_symbol, 2, pp1, sc->type_names[T_REAL]); + default: + return(method_or_bust(sc, pp1, sc->rationalize_symbol, args, sc->type_names[T_REAL], 2)); + } mpfr_abs(r->error, r->error, MPFR_RNDN); } @@ -16355,11 +16355,11 @@ static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args) if (mpfr_cmp_ui(r->error, 1) >= 0) /* if (error >= 1.0) */ { if (mpfr_cmp_ui(r->x0, 0) < 0) /* if (x0 < 0) */ - { - if (mpfr_cmp_ui(r->x1, 0) < 0) /* if (x1 < 0) */ - mpfr_get_z(r->n, r->x1, MPFR_RNDD); /* num = floor(x1) */ - else mpz_set_ui(r->n, 0); /* else num = 0 */ - } + { + if (mpfr_cmp_ui(r->x1, 0) < 0) /* if (x1 < 0) */ + mpfr_get_z(r->n, r->x1, MPFR_RNDD); /* num = floor(x1) */ + else mpz_set_ui(r->n, 0); /* else num = 0 */ + } else mpz_set(r->n, r->i); /* else num = i */ return(mpz_to_integer(sc, r->n)); } @@ -16367,7 +16367,7 @@ static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args) if (mpfr_cmp_z(r->x1, r->i) >= 0) /* if (x1 >= i) */ { if (mpz_cmp_ui(r->i, 0) >= 0) /* if (i >= 0) */ - mpz_set(r->n, r->i); /* num = i */ + mpz_set(r->n, r->i); /* num = i */ else mpfr_get_z(r->n, r->x1, MPFR_RNDD); /* else num = floor(x1) */ return(mpz_to_integer(sc, r->n)); } @@ -16392,22 +16392,22 @@ static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args) mpfr_div_z(r->val, r->val, r->q0, MPFR_RNDN); /* val = p0/q0 */ if (((mpfr_lessequal_p(r->x0, r->val)) && /* if ((x0 <= val) && (val <= x1)) */ - (mpfr_lessequal_p(r->val, r->x1))) || - (mpfr_cmp_ui(r->e1, 0) == 0) || - (mpfr_cmp_ui(r->e1p, 0) == 0)) - /* these last 2 are probably not needed -- they protect against running out of bits in the non-gmp case above */ - { - mpq_set_num(r->q, r->p0); /* return(p0/q0) */ - mpq_set_den(r->q, r->q0); - return(mpq_to_rational(sc, r->q)); - } + (mpfr_lessequal_p(r->val, r->x1))) || + (mpfr_cmp_ui(r->e1, 0) == 0) || + (mpfr_cmp_ui(r->e1p, 0) == 0)) + /* these last 2 are probably not needed -- they protect against running out of bits in the non-gmp case above */ + { + mpq_set_num(r->q, r->p0); /* return(p0/q0) */ + mpq_set_den(r->q, r->q0); + return(mpq_to_rational(sc, r->q)); + } mpfr_div(r->val, r->e0, r->e1, MPFR_RNDN); mpfr_get_z(r->r, r->val, MPFR_RNDD); /* r = floor(e0/e1) */ mpfr_div(r->val, r->e0p, r->e1p, MPFR_RNDN); mpfr_get_z(r->r1, r->val, MPFR_RNDU); /* r1 = ceil(e0p/e1p) */ if (mpz_cmp(r->r1, r->r) < 0) /* if (r1 < r) */ - mpz_set(r->r, r->r1); /* r = r1 */ + mpz_set(r->r, r->r1); /* r = r1 */ mpz_set(r->old_p1, r->p1); /* old_p1 = p1 */ mpz_set(r->p1, r->p0); /* p1 = p0 */ @@ -16458,13 +16458,13 @@ static s7_pointer g_rationalize(s7_scheme *sc, s7_pointer args) s7_pointer ex = cadr(args); #if WITH_GMP if (is_big_number(ex)) - return(big_rationalize(sc, args)); + return(big_rationalize(sc, args)); #endif if (!is_real(ex)) - return(method_or_bust(sc, ex, sc->rationalize_symbol, args, sc->type_names[T_REAL], 2)); + return(method_or_bust(sc, ex, sc->rationalize_symbol, args, sc->type_names[T_REAL], 2)); err = real_to_double(sc, ex, "rationalize"); if (is_NaN(err)) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, ex, it_is_nan_string); + out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, ex, it_is_nan_string); if (err < 0.0) err = -err; } @@ -16472,48 +16472,48 @@ static s7_pointer g_rationalize(s7_scheme *sc, s7_pointer args) { case T_INTEGER: { - s7_int a, b, pa; - if (err < 1.0) return(x); - a = integer(x); - pa = (a < 0) ? -a : a; - if (err >= pa) return(int_zero); - b = (s7_int)err; - pa -= b; - return(make_integer(sc, (a < 0) ? -pa : pa)); + s7_int a, b, pa; + if (err < 1.0) return(x); + a = integer(x); + pa = (a < 0) ? -a : a; + if (err >= pa) return(int_zero); + b = (s7_int)err; + pa -= b; + return(make_integer(sc, (a < 0) ? -pa : pa)); } case T_RATIO: if (err == 0.0) - return(x); + return(x); case T_REAL: { - s7_double rat = s7_real(x); /* possible fall through from above */ - s7_int numer = 0, denom = 1; + s7_double rat = s7_real(x); /* possible fall through from above */ + s7_int numer = 0, denom = 1; - if ((is_NaN(rat)) || (is_inf(rat))) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, x, a_normal_real_string); + if ((is_NaN(rat)) || (is_inf(rat))) + out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, x, a_normal_real_string); - if (err >= fabs(rat)) - return(int_zero); + if (err >= fabs(rat)) + return(int_zero); #if WITH_GMP - if (fabs(rat) > RATIONALIZE_LIMIT) - return(big_rationalize(sc, set_plist_2(sc, x, wrap_real(sc, err)))); + if (fabs(rat) > RATIONALIZE_LIMIT) + return(big_rationalize(sc, set_plist_2(sc, x, wrap_real(sc, err)))); #else - if (fabs(rat) > RATIONALIZE_LIMIT) - out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, x, it_is_too_large_string); + if (fabs(rat) > RATIONALIZE_LIMIT) + out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, x, it_is_too_large_string); #endif - if ((fabs(rat) + fabs(err)) < 1.0e-18) - err = 1.0e-18; - /* (/ 1.0 most-positive-fixnum) is 1.0842021e-19, so if we let err be less than that, - * (rationalize 1e-19 1e-20) hangs, but this only affects the initial ceiling, I believe. - */ + if ((fabs(rat) + fabs(err)) < 1.0e-18) + err = 1.0e-18; + /* (/ 1.0 most-positive-fixnum) is 1.0842021e-19, so if we let err be less than that, + * (rationalize 1e-19 1e-20) hangs, but this only affects the initial ceiling, I believe. + */ - if (fabs(rat) < fabs(err)) - return(int_zero); + if (fabs(rat) < fabs(err)) + return(int_zero); - return((c_rationalize(rat, err, &numer, &denom)) ? make_ratio(sc, numer, denom) : sc->F); + return((c_rationalize(rat, err, &numer, &denom)) ? make_ratio(sc, numer, denom) : sc->F); }} return(sc->F); /* make compiler happy */ } @@ -16558,12 +16558,12 @@ static s7_pointer g_angle(s7_scheme *sc, s7_pointer args) return((mpfr_cmp_d(big_real(x), 0.0) >= 0) ? real_zero : big_pi(sc)); case T_BIG_COMPLEX: { - s7_pointer z; - new_cell(sc, z, T_BIG_REAL); - big_real_bgf(z) = alloc_bigflt(sc); - add_big_real(sc, z); - mpc_arg(big_real(z), big_complex(x), MPFR_RNDN); - return(z); + s7_pointer z; + new_cell(sc, z, T_BIG_REAL); + big_real_bgf(z) = alloc_bigflt(sc); + add_big_real(sc, z); + mpc_arg(big_real(z), big_complex(x), MPFR_RNDN); + return(z); } #endif default: @@ -16582,55 +16582,55 @@ static s7_pointer complex_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) s7_pointer p0 = x, p1 = y, p = NULL; if (!is_real(p0)) - return(method_or_bust(sc, p0, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); + return(method_or_bust(sc, p0, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); if (!is_real(p1)) - return(method_or_bust(sc, p1, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 2)); + return(method_or_bust(sc, p1, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 2)); switch (type(p1)) - { - case T_INTEGER: case T_RATIO: case T_REAL: - { - s7_double iz = s7_real(p1); - if (iz == 0.0) /* imag-part is 0.0 */ - return(p0); - new_cell(sc, p, T_BIG_COMPLEX); - big_complex_bgc(p) = alloc_bigcmp(sc); - mpfr_set_d(mpc_imagref(big_complex(p)), iz, MPFR_RNDN); - } - break; - case T_BIG_REAL: - if (mpfr_zero_p(big_real(p1))) return(p0); - new_cell(sc, p, T_BIG_COMPLEX); - big_complex_bgc(p) = alloc_bigcmp(sc); - mpfr_set(mpc_imagref(big_complex(p)), big_real(p1), MPFR_RNDN); - break; - case T_BIG_RATIO: - new_cell(sc, p, T_BIG_COMPLEX); - big_complex_bgc(p) = alloc_bigcmp(sc); - mpfr_set_q(mpc_imagref(big_complex(p)), big_ratio(p1), MPFR_RNDN); - break; - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(p1), 0) == 0) return(p0); - new_cell(sc, p, T_BIG_COMPLEX); - big_complex_bgc(p) = alloc_bigcmp(sc); - mpfr_set_z(mpc_imagref(big_complex(p)), big_integer(p1), MPFR_RNDN); - break; - } + { + case T_INTEGER: case T_RATIO: case T_REAL: + { + s7_double iz = s7_real(p1); + if (iz == 0.0) /* imag-part is 0.0 */ + return(p0); + new_cell(sc, p, T_BIG_COMPLEX); + big_complex_bgc(p) = alloc_bigcmp(sc); + mpfr_set_d(mpc_imagref(big_complex(p)), iz, MPFR_RNDN); + } + break; + case T_BIG_REAL: + if (mpfr_zero_p(big_real(p1))) return(p0); + new_cell(sc, p, T_BIG_COMPLEX); + big_complex_bgc(p) = alloc_bigcmp(sc); + mpfr_set(mpc_imagref(big_complex(p)), big_real(p1), MPFR_RNDN); + break; + case T_BIG_RATIO: + new_cell(sc, p, T_BIG_COMPLEX); + big_complex_bgc(p) = alloc_bigcmp(sc); + mpfr_set_q(mpc_imagref(big_complex(p)), big_ratio(p1), MPFR_RNDN); + break; + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(p1), 0) == 0) return(p0); + new_cell(sc, p, T_BIG_COMPLEX); + big_complex_bgc(p) = alloc_bigcmp(sc); + mpfr_set_z(mpc_imagref(big_complex(p)), big_integer(p1), MPFR_RNDN); + break; + } switch (type(p0)) - { - case T_INTEGER: case T_RATIO: case T_REAL: - mpfr_set_d(mpc_realref(big_complex(p)), s7_real(p0), MPFR_RNDN); - break; - case T_BIG_REAL: - mpfr_set(mpc_realref(big_complex(p)), big_real(p0), MPFR_RNDN); - break; - case T_BIG_RATIO: - mpfr_set_q(mpc_realref(big_complex(p)), big_ratio(p0), MPFR_RNDN); - break; - case T_BIG_INTEGER: - mpfr_set_z(mpc_realref(big_complex(p)), big_integer(p0), MPFR_RNDN); - break; - } + { + case T_INTEGER: case T_RATIO: case T_REAL: + mpfr_set_d(mpc_realref(big_complex(p)), s7_real(p0), MPFR_RNDN); + break; + case T_BIG_REAL: + mpfr_set(mpc_realref(big_complex(p)), big_real(p0), MPFR_RNDN); + break; + case T_BIG_RATIO: + mpfr_set_q(mpc_realref(big_complex(p)), big_ratio(p0), MPFR_RNDN); + break; + case T_BIG_INTEGER: + mpfr_set_z(mpc_realref(big_complex(p)), big_integer(p0), MPFR_RNDN); + break; + } add_big_complex(sc, p); return(p); } @@ -16640,32 +16640,32 @@ static s7_pointer complex_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { case T_INTEGER: switch (type(x)) - { - case T_INTEGER: return((integer(y) == 0) ? x : make_complex_not_0i(sc, (s7_double)integer(x), (s7_double)integer(y))); - /* these int->dbl's are problematic: - * (complex 9223372036854775807 9007199254740995): 9223372036854776000.0+9007199254740996.0i - * should we raise an error? - */ - case T_RATIO: return((integer(y) == 0) ? x : make_complex_not_0i(sc, (s7_double)fraction(x), (s7_double)integer(y))); - case T_REAL: return((integer(y) == 0) ? x : make_complex_not_0i(sc, real(x), (s7_double)integer(y))); - default: return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); - } + { + case T_INTEGER: return((integer(y) == 0) ? x : make_complex_not_0i(sc, (s7_double)integer(x), (s7_double)integer(y))); + /* these int->dbl's are problematic: + * (complex 9223372036854775807 9007199254740995): 9223372036854776000.0+9007199254740996.0i + * should we raise an error? + */ + case T_RATIO: return((integer(y) == 0) ? x : make_complex_not_0i(sc, (s7_double)fraction(x), (s7_double)integer(y))); + case T_REAL: return((integer(y) == 0) ? x : make_complex_not_0i(sc, real(x), (s7_double)integer(y))); + default: return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); + } case T_RATIO: switch (type(x)) - { - case T_INTEGER: return(make_complex(sc, (s7_double)integer(x), (s7_double)fraction(y))); /* can fraction be 0.0? */ - case T_RATIO: return(make_complex(sc, (s7_double)fraction(x), (s7_double)fraction(y))); - case T_REAL: return(make_complex(sc, real(x), (s7_double)fraction(y))); - default: return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); - } + { + case T_INTEGER: return(make_complex(sc, (s7_double)integer(x), (s7_double)fraction(y))); /* can fraction be 0.0? */ + case T_RATIO: return(make_complex(sc, (s7_double)fraction(x), (s7_double)fraction(y))); + case T_REAL: return(make_complex(sc, real(x), (s7_double)fraction(y))); + default: return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); + } case T_REAL: switch (type(x)) - { - case T_INTEGER: return((real(y) == 0.0) ? x : make_complex_not_0i(sc, (s7_double)integer(x), real(y))); - case T_RATIO: return((real(y) == 0.0) ? x : make_complex_not_0i(sc, (s7_double)fraction(x), real(y))); - case T_REAL: return((real(y) == 0.0) ? x : make_complex_not_0i(sc, real(x), real(y))); - default: return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); - } + { + case T_INTEGER: return((real(y) == 0.0) ? x : make_complex_not_0i(sc, (s7_double)integer(x), real(y))); + case T_RATIO: return((real(y) == 0.0) ? x : make_complex_not_0i(sc, (s7_double)fraction(x), real(y))); + case T_REAL: return((real(y) == 0.0) ? x : make_complex_not_0i(sc, real(x), real(y))); + default: return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); + } default: return(method_or_bust(sc, (is_let(x)) ? x : y, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 2)); } @@ -16707,17 +16707,17 @@ bignum returns that number as a bignum" if (is_number(p)) { if (!is_null(cdr(args))) - error_nr(sc, make_symbol(sc, "bignum-error", 12), - set_elist_2(sc, wrap_string(sc, "bignum of a number takes only one argument: ~S", 46), args)); + error_nr(sc, make_symbol(sc, "bignum-error", 12), + set_elist_2(sc, wrap_string(sc, "bignum of a number takes only one argument: ~S", 46), args)); #if WITH_GMP switch (type(p)) - { - case T_INTEGER: return(s7_int_to_big_integer(sc, integer(p))); - case T_RATIO: return(s7_int_to_big_ratio(sc, numerator(p), denominator(p))); - case T_REAL: return(s7_double_to_big_real(sc, real(p))); - case T_COMPLEX: return(s7_double_to_big_complex(sc, real_part(p), imag_part(p))); - default: return(p); - } + { + case T_INTEGER: return(s7_int_to_big_integer(sc, integer(p))); + case T_RATIO: return(s7_int_to_big_ratio(sc, numerator(p), denominator(p))); + case T_REAL: return(s7_double_to_big_real(sc, real(p))); + case T_COMPLEX: return(s7_double_to_big_complex(sc, real_part(p), imag_part(p))); + default: return(p); + } #else return(p); #endif @@ -16725,7 +16725,7 @@ bignum returns that number as a bignum" p = g_string_to_number_1(sc, args, sc->bignum_symbol); if (is_false(sc, p)) /* (bignum "1/3.0") */ error_nr(sc, make_symbol(sc, "bignum-error", 12), - set_elist_2(sc, wrap_string(sc, "bignum string argument does not represent a number: ~S", 54), car(args))); + set_elist_2(sc, wrap_string(sc, "bignum string argument does not represent a number: ~S", 54), car(args))); #if WITH_GMP switch (type(p)) { @@ -16778,7 +16778,7 @@ static s7_pointer exp_p_p(s7_scheme *sc, s7_pointer x) z = (s7_double)integer(x); #if WITH_GMP if (fabs(z) > EXP_LIMIT) - return(exp_1(sc, z)); + return(exp_1(sc, z)); #endif return(make_real(sc, exp(z))); @@ -16786,14 +16786,14 @@ static s7_pointer exp_p_p(s7_scheme *sc, s7_pointer x) z = (s7_double)fraction(x); #if WITH_GMP if (fabs(z) > EXP_LIMIT) - return(exp_1(sc, z)); + return(exp_1(sc, z)); #endif return(make_real(sc, exp(z))); case T_REAL: #if WITH_GMP if (fabs(real(x)) > EXP_LIMIT) - return(exp_1(sc, real(x))); + return(exp_1(sc, real(x))); #endif return(make_real(sc, exp(real(x)))); @@ -16801,8 +16801,8 @@ static s7_pointer exp_p_p(s7_scheme *sc, s7_pointer x) #if HAVE_COMPLEX_NUMBERS #if WITH_GMP if ((fabs(real_part(x)) > EXP_LIMIT) || - (fabs(imag_part(x)) > EXP_LIMIT)) - return(exp_2(sc, real_part(x), imag_part(x))); + (fabs(imag_part(x)) > EXP_LIMIT)) + return(exp_2(sc, real_part(x), imag_part(x))); #endif return(c_complex_to_s7(sc, cexp(to_c_complex(x)))); /* this is inaccurate for large arguments: @@ -16827,7 +16827,7 @@ static s7_pointer exp_p_p(s7_scheme *sc, s7_pointer x) case T_BIG_COMPLEX: mpc_exp(sc->mpc_1, big_complex(x), MPC_RNDNN); if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); return(mpc_to_number(sc, sc->mpc_1)); #endif default: @@ -16865,7 +16865,7 @@ static s7_pointer big_log(s7_scheme *sc, s7_pointer args) { p1 = cadr(args); if (!is_number(p1)) - return(method_or_bust(sc, p1, sc->log_symbol, args, a_number_string, 2)); + return(method_or_bust(sc, p1, sc->log_symbol, args, a_number_string, 2)); } if (is_real(p0)) @@ -16873,38 +16873,38 @@ static s7_pointer big_log(s7_scheme *sc, s7_pointer args) res = any_real_to_mpfr(sc, p0, sc->mpfr_1); if (res == real_NaN) return(res); if ((is_positive(sc, p0)) && - ((!p1) || - ((is_real(p1)) && (is_positive(sc, p1))))) - { - if (res) return(res); - mpfr_log(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - if (p1) - { - res = any_real_to_mpfr(sc, p1, sc->mpfr_2); - if (res) - return((res == real_infinity) ? real_zero : res); - if (mpfr_zero_p(sc->mpfr_2)) - out_of_range_error_nr(sc, sc->log_symbol, int_two, p1, wrap_string(sc, "can't be zero", 13)); - mpfr_log(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - } - if ((mpfr_integer_p(sc->mpfr_1)) && ((is_rational(p0)) && ((!p1) || (is_rational(p1))))) - return(mpfr_to_integer(sc, sc->mpfr_1)); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - }} + ((!p1) || + ((is_real(p1)) && (is_positive(sc, p1))))) + { + if (res) return(res); + mpfr_log(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + if (p1) + { + res = any_real_to_mpfr(sc, p1, sc->mpfr_2); + if (res) + return((res == real_infinity) ? real_zero : res); + if (mpfr_zero_p(sc->mpfr_2)) + out_of_range_error_nr(sc, sc->log_symbol, int_two, p1, wrap_string(sc, "can't be zero", 13)); + mpfr_log(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); + mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + } + if ((mpfr_integer_p(sc->mpfr_1)) && ((is_rational(p0)) && ((!p1) || (is_rational(p1))))) + return(mpfr_to_integer(sc, sc->mpfr_1)); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + }} if (p1) { res = any_number_to_mpc(sc, p1, sc->mpc_2); if (res) - return((res == real_infinity) ? real_zero : complex_NaN); + return((res == real_infinity) ? real_zero : complex_NaN); if (mpc_zero_p(sc->mpc_2)) - out_of_range_error_nr(sc, sc->log_symbol, int_two, p1, wrap_string(sc, "can't be zero", 13)); + out_of_range_error_nr(sc, sc->log_symbol, int_two, p1, wrap_string(sc, "can't be zero", 13)); } res = any_number_to_mpc(sc, p0, sc->mpc_1); if (res) { if ((res == real_infinity) && (p1) && ((is_negative(sc, p0)))) - return(make_complex_not_0i(sc, INFINITY, -NAN)); + return(make_complex_not_0i(sc, INFINITY, -NAN)); return((res == real_NaN) ? complex_NaN : res); } mpc_log(sc->mpc_1, sc->mpc_1, MPC_RNDNN); @@ -16944,85 +16944,85 @@ static s7_pointer g_log(s7_scheme *sc, s7_pointer args) { s7_pointer y = cadr(args); if (!(is_number(y))) - return(method_or_bust(sc, y, sc->log_symbol, args, a_number_string, 2)); + return(method_or_bust(sc, y, sc->log_symbol, args, a_number_string, 2)); #if WITH_GMP if (is_big_number(y)) return(big_log(sc, args)); #endif if ((is_t_integer(y)) && (integer(y) == 2)) - { - /* (define (2^n? x) (and (not (zero? x)) (zero? (logand x (- x 1))))) */ - if (is_t_integer(x)) - { - s7_int ix = integer(x); - if (ix > 0) - { - s7_double fx; + { + /* (define (2^n? x) (and (not (zero? x)) (zero? (logand x (- x 1))))) */ + if (is_t_integer(x)) + { + s7_int ix = integer(x); + if (ix > 0) + { + s7_double fx; #if (__ANDROID__) || (MS_WINDOWS) || (((__GNUC__) && ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ <= 4)))) && (!defined(__clang__))) - /* just a guess -- log2 gets a warning in gcc 4.3.2, but not in 4.4.4 */ - fx = log((double)ix) * LOG_2; + /* just a guess -- log2 gets a warning in gcc 4.3.2, but not in 4.4.4 */ + fx = log((double)ix) * LOG_2; #else - fx = log2((double)ix); + fx = log2((double)ix); #endif - /* (s7_int)fx rounds (log 8 2) to 2 in FreeBSD! */ + /* (s7_int)fx rounds (log 8 2) to 2 in FreeBSD! */ #if (((__GNUC__) && ((__GNUC__ < 4) || ((__GNUC__ == 4) && (__GNUC_MINOR__ < 4)))) && (!defined(__clang__))) - return(make_real(sc, fx)); + return(make_real(sc, fx)); #else - return(((ix & (ix - 1)) == 0) ? make_integer(sc, (s7_int)s7_round(fx)) : make_real(sc, fx)); + return(((ix & (ix - 1)) == 0) ? make_integer(sc, (s7_int)s7_round(fx)) : make_real(sc, fx)); #endif - }} - if ((is_real(x)) && - (is_positive(sc, x))) - return(make_real(sc, log(s7_real(x)) * LOG_2)); - return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)) * LOG_2)); - } + }} + if ((is_real(x)) && + (is_positive(sc, x))) + return(make_real(sc, log(s7_real(x)) * LOG_2)); + return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)) * LOG_2)); + } if ((is_t_integer(x)) && (integer(x) == 1) && (is_t_integer(y)) && (integer(y) == 1)) /* (log 1 1) -> 0 (this is NaN in the bignum case) */ - return(int_zero); + return(int_zero); /* (log 1 0) must be 0 since everyone says (expt 0 0) is 1 */ if (is_zero(y)) - { - if ((is_t_integer(y)) && (is_t_integer(x)) && (integer(x) == 1)) - return(y); - out_of_range_error_nr(sc, sc->log_symbol, int_two, y, wrap_string(sc, "can't be zero", 13)); - } + { + if ((is_t_integer(y)) && (is_t_integer(x)) && (integer(x) == 1)) + return(y); + out_of_range_error_nr(sc, sc->log_symbol, int_two, y, wrap_string(sc, "can't be zero", 13)); + } if ((is_t_real(x)) && (is_NaN(real(x)))) - return(x); + return(x); if (is_one(y)) /* this used to raise an error, but the bignum case is simpler if we return inf */ - return((is_one(x)) ? real_zero : real_infinity); /* but (log 1.0 1.0) -> 0.0, currently (log 1/0 1) is inf? */ + return((is_one(x)) ? real_zero : real_infinity); /* but (log 1.0 1.0) -> 0.0, currently (log 1/0 1) is inf? */ if ((is_real(x)) && - (is_real(y)) && - (is_positive(sc, x)) && - (is_positive(sc, y))) - { - if ((is_rational(x)) && - (is_rational(y))) - { - s7_double res = log(rational_to_double(sc, x)) / log(rational_to_double(sc, y)); - s7_int ires = (s7_int)res; - if (res - ires == 0.0) - return(make_integer(sc, ires)); /* (log 8 2) -> 3 or (log 1/8 2) -> -3 */ - /* since x and y are rational here, it seems reasonable to try to rationalize the result, but not go overboard? - * what about (expt 16 3/2) -> 64? also 2 as base is handled above and always returns a float. - */ - if (fabs(res) < RATIONALIZE_LIMIT) - { - s7_int num, den; - if ((c_rationalize(res, sc->default_rationalize_error, &num, &den)) && - (s7_int_abs(num) < 100) && (s7_int_abs(den) < 100)) - return(make_simple_ratio(sc, num, den)); - } - return(make_real(sc, res)); - } - return(make_real(sc, log(s7_real(x)) / log(s7_real(y)))); - } + (is_real(y)) && + (is_positive(sc, x)) && + (is_positive(sc, y))) + { + if ((is_rational(x)) && + (is_rational(y))) + { + s7_double res = log(rational_to_double(sc, x)) / log(rational_to_double(sc, y)); + s7_int ires = (s7_int)res; + if (res - ires == 0.0) + return(make_integer(sc, ires)); /* (log 8 2) -> 3 or (log 1/8 2) -> -3 */ + /* since x and y are rational here, it seems reasonable to try to rationalize the result, but not go overboard? + * what about (expt 16 3/2) -> 64? also 2 as base is handled above and always returns a float. + */ + if (fabs(res) < RATIONALIZE_LIMIT) + { + s7_int num, den; + if ((c_rationalize(res, sc->default_rationalize_error, &num, &den)) && + (s7_int_abs(num) < 100) && (s7_int_abs(den) < 100)) + return(make_simple_ratio(sc, num, den)); + } + return(make_real(sc, res)); + } + return(make_real(sc, log(s7_real(x)) / log(s7_real(y)))); + } if ((is_t_real(x)) && (is_NaN(real(x)))) - return(x); + return(x); if ((is_t_complex(y)) && ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))))) - return(y); + return(y); return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)) / clog(s7_to_c_complex(y)))); } @@ -17040,7 +17040,7 @@ static s7_pointer log_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_poin { s7_pointer x = cadr(expr), y = caddr(expr); if ((is_t_integer(y)) && (integer(y) == 2) && (is_t_integer(x)) && (integer(x) > 0)) - return(sc->int_log2); + return(sc->int_log2); } #endif return(f); @@ -17064,12 +17064,12 @@ static s7_pointer sin_p_p(s7_scheme *sc, s7_pointer x) if (integer(x) == 0) return(int_zero); /* (sin 0) -> 0 */ #if WITH_GMP if (integer(x) > SIN_LIMIT) - { - mpz_set_si(sc->mpz_1, integer(x)); - mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); - mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } + { + mpz_set_si(sc->mpz_1, integer(x)); + mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); + mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } #endif return(make_real(sc, sin((s7_double)(integer(x))))); /* bogus for very large integers, but so is the equivalent real (see SIN_LIMIT) */ @@ -17078,26 +17078,26 @@ static s7_pointer sin_p_p(s7_scheme *sc, s7_pointer x) case T_REAL: { - s7_double y = real(x); + s7_double y = real(x); #if WITH_GMP - if (fabs(y) > SIN_LIMIT) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, sin(y))); + if (fabs(y) > SIN_LIMIT) + { + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, sin(y))); } case T_COMPLEX: #if WITH_GMP if ((fabs(real_part(x)) > SIN_LIMIT) || (fabs(imag_part(x)) > SINH_LIMIT)) - { - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_sin(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } + { + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_sin(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + } #endif #if HAVE_COMPLEX_NUMBERS return(c_complex_to_s7(sc, csin(to_c_complex(x)))); @@ -17120,7 +17120,7 @@ static s7_pointer sin_p_p(s7_scheme *sc, s7_pointer x) case T_BIG_COMPLEX: mpc_sin(sc->mpc_1, big_complex(x), MPC_RNDNN); if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); return(mpc_to_number(sc, sc->mpc_1)); #endif default: @@ -17171,12 +17171,12 @@ static s7_pointer cos_p_p(s7_scheme *sc, s7_pointer x) if (integer(x) == 0) return(int_one); /* (cos 0) -> 1 */ #if WITH_GMP if (integer(x) > SIN_LIMIT) - { - mpz_set_si(sc->mpz_1, integer(x)); - mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); - mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } + { + mpz_set_si(sc->mpz_1, integer(x)); + mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); + mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } #endif return(make_real(sc, cos((s7_double)(integer(x))))); @@ -17185,26 +17185,26 @@ static s7_pointer cos_p_p(s7_scheme *sc, s7_pointer x) case T_REAL: /* if with_gmp */ { - s7_double y = real(x); + s7_double y = real(x); #if WITH_GMP - if (fabs(y) > SIN_LIMIT) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, cos(y))); + if (fabs(y) > SIN_LIMIT) + { + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, cos(y))); } case T_COMPLEX: #if WITH_GMP if ((fabs(real_part(x)) > SIN_LIMIT) || (fabs(imag_part(x)) > SINH_LIMIT)) - { - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_cos(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } + { + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_cos(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + } #endif #if HAVE_COMPLEX_NUMBERS return(c_complex_to_s7(sc, ccos(to_c_complex(x)))); @@ -17227,7 +17227,7 @@ static s7_pointer cos_p_p(s7_scheme *sc, s7_pointer x) case T_BIG_COMPLEX: mpc_cos(sc->mpc_1, big_complex(x), MPC_RNDNN); if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); return(mpc_to_number(sc, sc->mpc_1)); #endif default: @@ -17272,12 +17272,12 @@ static s7_pointer tan_p_p(s7_scheme *sc, s7_pointer x) if (integer(x) == 0) return(int_zero); /* (tan 0) -> 0 */ #if WITH_GMP if (integer(x) > TAN_LIMIT) - { - mpz_set_si(sc->mpz_1, integer(x)); - mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); - mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } + { + mpz_set_si(sc->mpz_1, integer(x)); + mpfr_set_z(sc->mpfr_1, sc->mpz_1, MPFR_RNDN); + mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } #endif return(make_real(sc, tan((s7_double)(integer(x))))); @@ -17287,18 +17287,18 @@ static s7_pointer tan_p_p(s7_scheme *sc, s7_pointer x) #if WITH_GMP case T_REAL: if (fabs(real(x)) > TAN_LIMIT) - { - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } + { + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } #endif return(make_real(sc, tan(real(x)))); case T_COMPLEX: #if HAVE_COMPLEX_NUMBERS if (imag_part(x) > 350.0) - return(make_complex_not_0i(sc, 0.0, 1.0)); + return(make_complex_not_0i(sc, 0.0, 1.0)); return((imag_part(x) < -350.0) ? make_complex_not_0i(sc, 0.0, -1.0) : c_complex_to_s7(sc, ctan(to_c_complex(x)))); #else out_of_range_error_nr(sc, sc->tan_symbol, int_one, x, no_complex_numbers_string); @@ -17318,12 +17318,12 @@ static s7_pointer tan_p_p(s7_scheme *sc, s7_pointer x) return(mpfr_to_big_real(sc, sc->mpfr_1)); case T_BIG_COMPLEX: if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, 350))) > 0) - return(make_complex_not_0i(sc, 0.0, 1.0)); + return(make_complex_not_0i(sc, 0.0, 1.0)); if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, -350))) < 0) - return(make_complex_not_0i(sc, 0.0, -1.0)); + return(make_complex_not_0i(sc, 0.0, -1.0)); mpc_tan(sc->mpc_1, big_complex(x), MPC_RNDNN); if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); return(mpc_to_number(sc, sc->mpc_1)); #endif default: @@ -17373,13 +17373,13 @@ static s7_pointer asin_p_p(s7_scheme *sc, s7_pointer p) /* if either real or imag part is very large, use explicit formula, not casin */ /* this code taken from sbcl's src/code/irrat.lisp; break is around x+70000000i */ if ((fabs(real_part(p)) > 1.0e7) || - (fabs(imag_part(p)) > 1.0e7)) - { - s7_complex sq1mz, sq1pz, z = to_c_complex(p); - sq1mz = csqrt(1.0 - z); - sq1pz = csqrt(1.0 + z); - return(make_complex(sc, atan(real_part(p) / creal(sq1mz * sq1pz)), asinh(cimag(sq1pz * conj(sq1mz))))); - } + (fabs(imag_part(p)) > 1.0e7)) + { + s7_complex sq1mz, sq1pz, z = to_c_complex(p); + sq1mz = csqrt(1.0 - z); + sq1pz = csqrt(1.0 + z); + return(make_complex(sc, atan(real_part(p) / creal(sq1mz * sq1pz)), asinh(cimag(sq1pz * conj(sq1mz))))); + } return(c_complex_to_s7(sc, casin(to_c_complex(p)))); #else out_of_range_error_nr(sc, sc->asin_symbol, int_one, p, no_complex_numbers_string); @@ -17394,19 +17394,19 @@ static s7_pointer asin_p_p(s7_scheme *sc, s7_pointer p) goto ASIN_BIG_REAL; case T_BIG_REAL: if (mpfr_inf_p(big_real(p))) - { - if (mpfr_cmp_ui(big_real(p), 0) < 0) - return(make_complex_not_0i(sc, NAN, INFINITY)); /* match non-bignum choice */ - return(make_complex_not_0i(sc, NAN, -INFINITY)); - } + { + if (mpfr_cmp_ui(big_real(p), 0) < 0) + return(make_complex_not_0i(sc, NAN, INFINITY)); /* match non-bignum choice */ + return(make_complex_not_0i(sc, NAN, -INFINITY)); + } mpfr_set(sc->mpfr_1, big_real(p), MPFR_RNDN); ASIN_BIG_REAL: mpfr_set_ui(sc->mpfr_2, 1, MPFR_RNDN); if (mpfr_cmpabs(sc->mpfr_1, sc->mpfr_2) <= 0) - { - mpfr_asin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } + { + mpfr_asin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } mpc_set_fr(sc->mpc_1, sc->mpfr_1, MPC_RNDNN); mpc_asin(sc->mpc_1, sc->mpc_1, MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); @@ -17461,15 +17461,15 @@ static s7_pointer acos_p_p(s7_scheme *sc, s7_pointer p) /* this code taken from sbcl's src/code/irrat.lisp */ if ((fabs(real_part(p)) > 1.0e7) || - (fabs(imag_part(p)) > 1.0e7)) - { - s7_complex sq1mz, sq1pz, z = to_c_complex(p); - sq1mz = csqrt(1.0 - z); - sq1pz = csqrt(1.0 + z); /* creal(sq1pz) can be 0.0 */ - if (creal(sq1pz) == 0.0) /* so the atan arg will be inf, so the real part will be pi/2(?) */ - return(make_complex(sc, M_PI / 2.0, asinh(cimag(sq1mz * conj(sq1pz))))); - return(make_complex(sc, 2.0 * atan(creal(sq1mz) / creal(sq1pz)), asinh(cimag(sq1mz * conj(sq1pz))))); - } + (fabs(imag_part(p)) > 1.0e7)) + { + s7_complex sq1mz, sq1pz, z = to_c_complex(p); + sq1mz = csqrt(1.0 - z); + sq1pz = csqrt(1.0 + z); /* creal(sq1pz) can be 0.0 */ + if (creal(sq1pz) == 0.0) /* so the atan arg will be inf, so the real part will be pi/2(?) */ + return(make_complex(sc, M_PI / 2.0, asinh(cimag(sq1mz * conj(sq1pz))))); + return(make_complex(sc, 2.0 * atan(creal(sq1mz) / creal(sq1pz)), asinh(cimag(sq1mz * conj(sq1pz))))); + } return(c_complex_to_s7(sc, cacos(s7_to_c_complex(p)))); #else out_of_range_error_nr(sc, sc->acos_symbol, int_one, p, no_complex_numbers_string); @@ -17484,19 +17484,19 @@ static s7_pointer acos_p_p(s7_scheme *sc, s7_pointer p) goto ACOS_BIG_REAL; case T_BIG_REAL: if (mpfr_inf_p(big_real(p))) - { - if (mpfr_cmp_ui(big_real(p), 0) < 0) - return(make_complex_not_0i(sc, -NAN, -INFINITY)); /* match non-bignum choice */ - return(make_complex_not_0i(sc, -NAN, INFINITY)); - } + { + if (mpfr_cmp_ui(big_real(p), 0) < 0) + return(make_complex_not_0i(sc, -NAN, -INFINITY)); /* match non-bignum choice */ + return(make_complex_not_0i(sc, -NAN, INFINITY)); + } mpfr_set(sc->mpfr_1, big_real(p), MPFR_RNDN); ACOS_BIG_REAL: mpfr_set_ui(sc->mpfr_2, 1, MPFR_RNDN); if (mpfr_cmpabs(sc->mpfr_1, sc->mpfr_2) <= 0) - { - mpfr_acos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } + { + mpfr_acos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } mpc_set_fr(sc->mpc_1, sc->mpfr_1, MPC_RNDNN); mpc_acos(sc->mpc_1, sc->mpc_1, MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); @@ -17530,47 +17530,47 @@ static s7_pointer g_atan(s7_scheme *sc, s7_pointer args) if (!is_pair(cdr(args))) { switch (type(x)) - { - case T_INTEGER: return((integer(x) == 0) ? int_zero : make_real(sc, atan((double)integer(x)))); - case T_RATIO: return(make_real(sc, atan(fraction(x)))); - case T_REAL: return(make_real(sc, atan(real(x)))); + { + case T_INTEGER: return((integer(x) == 0) ? int_zero : make_real(sc, atan((double)integer(x)))); + case T_RATIO: return(make_real(sc, atan(fraction(x)))); + case T_REAL: return(make_real(sc, atan(real(x)))); - case T_COMPLEX: + case T_COMPLEX: #if HAVE_COMPLEX_NUMBERS - return(c_complex_to_s7(sc, catan(to_c_complex(x)))); + return(c_complex_to_s7(sc, catan(to_c_complex(x)))); #else - out_of_range_error_nr(sc, sc->atan_symbol, int_one, x, no_complex_numbers_string); + out_of_range_error_nr(sc, sc->atan_symbol, int_one, x, no_complex_numbers_string); #endif #if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_atan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_atan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_atan(sc->mpfr_1, big_real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_atan(sc->mpc_1, big_complex(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_p(sc, x, sc->atan_symbol, a_number_string)); - }} + case T_BIG_INTEGER: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_atan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_atan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_atan(sc->mpfr_1, big_real(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_atan(sc->mpc_1, big_complex(x), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_p(sc, x, sc->atan_symbol, a_number_string)); + }} y = cadr(args); switch (type(x)) { case T_INTEGER: case T_RATIO: case T_REAL: if (is_small_real(y)) - return(make_real(sc, atan2(s7_real(x), s7_real(y)))); + return(make_real(sc, atan2(s7_real(x), s7_real(y)))); #if WITH_GMP if (!is_real(y)) - return(method_or_bust(sc, y, sc->atan_symbol, args, sc->type_names[T_REAL], 2)); + return(method_or_bust(sc, y, sc->atan_symbol, args, sc->type_names[T_REAL], 2)); mpfr_set_d(sc->mpfr_1, s7_real(x), MPFR_RNDN); goto ATAN2_BIG_REAL; case T_BIG_INTEGER: @@ -17595,11 +17595,11 @@ static s7_pointer g_atan(s7_scheme *sc, s7_pointer args) mpfr_set(sc->mpfr_2, big_real(y), MPFR_RNDN); else if (is_t_big_integer(y)) - mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); + mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); else - if (is_t_big_ratio(y)) - mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); - else return(method_or_bust(sc, y, sc->atan_symbol, args, sc->type_names[T_REAL], 2)); + if (is_t_big_ratio(y)) + mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); + else return(method_or_bust(sc, y, sc->atan_symbol, args, sc->type_names[T_REAL], 2)); mpfr_atan2(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); return(mpfr_to_big_real(sc, sc->mpfr_1)); #endif @@ -17619,26 +17619,26 @@ static s7_pointer sinh_p_p(s7_scheme *sc, s7_pointer x) case T_REAL: case T_RATIO: { - s7_double y = s7_real(x); + s7_double y = s7_real(x); #if WITH_GMP - if (fabs(y) > SINH_LIMIT) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, sinh(y))); + if (fabs(y) > SINH_LIMIT) + { + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + mpfr_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, sinh(y))); } case T_COMPLEX: #if WITH_GMP if ((fabs(real_part(x)) > SINH_LIMIT) || (fabs(imag_part(x)) > SINH_LIMIT)) - { - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_sinh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } + { + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_sinh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + } #endif #if HAVE_COMPLEX_NUMBERS return(c_complex_to_s7(sc, csinh(to_c_complex(x)))); @@ -17661,7 +17661,7 @@ static s7_pointer sinh_p_p(s7_scheme *sc, s7_pointer x) case T_BIG_COMPLEX: mpc_sinh(sc->mpc_1, big_complex(x), MPC_RNDNN); if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); return(mpc_to_number(sc, sc->mpc_1)); #endif default: @@ -17692,26 +17692,26 @@ static s7_pointer cosh_p_p(s7_scheme *sc, s7_pointer x) case T_REAL: case T_RATIO: { - s7_double y = s7_real(x); + s7_double y = s7_real(x); #if WITH_GMP - if (fabs(y) > SINH_LIMIT) - { - mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); - mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, cosh(y))); + if (fabs(y) > SINH_LIMIT) + { + mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN); + mpfr_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, cosh(y))); } case T_COMPLEX: #if WITH_GMP if ((fabs(real_part(x)) > SINH_LIMIT) || (fabs(imag_part(x)) > SINH_LIMIT)) - { - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_cosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } + { + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_cosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + } #endif #if HAVE_COMPLEX_NUMBERS return(c_complex_to_s7(sc, ccosh(to_c_complex(x)))); @@ -17734,7 +17734,7 @@ static s7_pointer cosh_p_p(s7_scheme *sc, s7_pointer x) case T_BIG_COMPLEX: mpc_cosh(sc->mpc_1, big_complex(x), MPC_RNDNN); if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); return(mpc_to_number(sc, sc->mpc_1)); #endif default: @@ -17766,9 +17766,9 @@ static s7_pointer tanh_p_p(s7_scheme *sc, s7_pointer x) case T_COMPLEX: #if HAVE_COMPLEX_NUMBERS if (real_part(x) > TANH_LIMIT) - return(real_one); /* closer than 0.0 which is what ctanh is about to return! */ + return(real_one); /* closer than 0.0 which is what ctanh is about to return! */ if (real_part(x) < -TANH_LIMIT) - return(make_real(sc, -1.0)); /* closer than ctanh's -0.0 */ + return(make_real(sc, -1.0)); /* closer than ctanh's -0.0 */ return(c_complex_to_s7(sc, ctanh(to_c_complex(x)))); #else out_of_range_error_nr(sc, sc->tanh_symbol, int_one, x, no_complex_numbers_string); @@ -17791,19 +17791,19 @@ static s7_pointer tanh_p_p(s7_scheme *sc, s7_pointer x) return(mpfr_to_big_real(sc, sc->mpfr_1)); case T_BIG_COMPLEX: if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), TANH_LIMIT, 1))) > 0) - return(real_one); + return(real_one); if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), -TANH_LIMIT, 1))) < 0) - return(make_real(sc, -1.0)); + return(make_real(sc, -1.0)); if ((mpfr_nan_p(mpc_imagref(big_complex(x)))) || - (mpfr_inf_p(mpc_imagref(big_complex(x))))) - { - if (mpfr_cmp_ui(mpc_realref(big_complex(x)), 0) == 0) - return(make_complex_not_0i(sc, 0.0, NAN)); /* match non-bignum choice */ - return(complex_NaN); - } + (mpfr_inf_p(mpc_imagref(big_complex(x))))) + { + if (mpfr_cmp_ui(mpc_realref(big_complex(x)), 0) == 0) + return(make_complex_not_0i(sc, 0.0, NAN)); /* match non-bignum choice */ + return(complex_NaN); + } mpc_tanh(sc->mpc_1, big_complex(x), MPC_RNDNN); if (mpfr_zero_p(mpc_imagref(sc->mpc_1))) - return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); + return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1))); return(mpc_to_number(sc, sc->mpc_1)); #endif default: @@ -17879,9 +17879,9 @@ static s7_pointer acosh_p_p(s7_scheme *sc, s7_pointer x) case T_REAL: case T_RATIO: { - s7_double x1 = s7_real(x); - if (x1 >= 1.0) - return(make_real(sc, acosh(x1))); + s7_double x1 = s7_real(x); + if (x1 >= 1.0) + return(make_real(sc, acosh(x1))); } case T_COMPLEX: #if HAVE_COMPLEX_NUMBERS @@ -17935,9 +17935,9 @@ static s7_pointer atanh_p_p(s7_scheme *sc, s7_pointer x) case T_REAL: case T_RATIO: { - s7_double x1 = s7_real(x); - if (fabs(x1) < 1.0) - return(make_real(sc, atanh(x1))); + s7_double x1 = s7_real(x); + if (fabs(x1) < 1.0) + return(make_real(sc, atanh(x1))); } /* if we can't distinguish x from 1.0 even with long_doubles, we'll get inf.0: * (atanh 9223372036854775/9223372036854776) -> 18.714973875119 @@ -17968,10 +17968,10 @@ static s7_pointer atanh_p_p(s7_scheme *sc, s7_pointer x) ATANH_BIG_REAL: mpfr_set_ui(sc->mpfr_1, 1, MPFR_RNDN); if (mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) < 0) - { - mpfr_atanh(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_2)); - } + { + mpfr_atanh(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_2)); + } mpc_set_fr(sc->mpc_1, sc->mpfr_2, MPC_RNDNN); mpc_atanh(sc->mpc_1, sc->mpc_1, MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); @@ -17999,54 +17999,54 @@ static s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer p) { case T_INTEGER: { - s7_double sqx; - if (integer(p) >= 0) - { - s7_int ix; + s7_double sqx; + if (integer(p) >= 0) + { + s7_int ix; #if WITH_GMP - mpz_set_si(sc->mpz_1, integer(p)); - mpz_sqrtrem(sc->mpz_1, sc->mpz_2, sc->mpz_1); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - return(make_integer(sc, mpz_get_si(sc->mpz_1))); - mpfr_set_si(sc->mpfr_1, integer(p), MPFR_RNDN); - mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); -#endif - sqx = sqrt((s7_double)integer(p)); - ix = (s7_int)sqx; - return(((ix * ix) == integer(p)) ? make_integer(sc, ix) : make_real(sc, sqx)); - /* Mark Weaver notes that (zero? (- (sqrt 9007199136250226) 94906265.0)) -> #t - * but (* 94906265 94906265) -> 9007199136250225 -- oops - * if we use bigfloats, we're ok: - * (* (sqrt 9007199136250226.0) (sqrt 9007199136250226.0)) -> 9.007199136250226000000000000000000000026E15 - * at least we return a real here, not an incorrect integer and (sqrt 9007199136250225) -> 94906265 - */ - } + mpz_set_si(sc->mpz_1, integer(p)); + mpz_sqrtrem(sc->mpz_1, sc->mpz_2, sc->mpz_1); + if (mpz_cmp_ui(sc->mpz_2, 0) == 0) + return(make_integer(sc, mpz_get_si(sc->mpz_1))); + mpfr_set_si(sc->mpfr_1, integer(p), MPFR_RNDN); + mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); +#endif + sqx = sqrt((s7_double)integer(p)); + ix = (s7_int)sqx; + return(((ix * ix) == integer(p)) ? make_integer(sc, ix) : make_real(sc, sqx)); + /* Mark Weaver notes that (zero? (- (sqrt 9007199136250226) 94906265.0)) -> #t + * but (* 94906265 94906265) -> 9007199136250225 -- oops + * if we use bigfloats, we're ok: + * (* (sqrt 9007199136250226.0) (sqrt 9007199136250226.0)) -> 9.007199136250226000000000000000000000026E15 + * at least we return a real here, not an incorrect integer and (sqrt 9007199136250225) -> 94906265 + */ + } #if HAVE_COMPLEX_NUMBERS #if WITH_GMP - mpc_set_si(sc->mpc_1, integer(p), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); + mpc_set_si(sc->mpc_1, integer(p), MPC_RNDNN); + mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); #endif - sqx = (s7_double)integer(p); /* we're trying to protect against (sqrt -9223372036854775808) where we can't negate the integer argument */ - return(make_complex_not_0i(sc, 0.0, sqrt((s7_double)(-sqx)))); + sqx = (s7_double)integer(p); /* we're trying to protect against (sqrt -9223372036854775808) where we can't negate the integer argument */ + return(make_complex_not_0i(sc, 0.0, sqrt((s7_double)(-sqx)))); #else - out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, p, no_complex_numbers_string); + out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, p, no_complex_numbers_string); #endif } case T_RATIO: if (numerator(p) > 0) /* else it's complex, so it can't be a ratio */ - { - s7_int nm = (s7_int)sqrt(numerator(p)); - if (nm * nm == numerator(p)) - { - s7_int dn = (s7_int)sqrt(denominator(p)); - if (dn * dn == denominator(p)) - return(make_ratio(sc, nm, dn)); - } - return(make_real(sc, sqrt((s7_double)fraction(p)))); - } + { + s7_int nm = (s7_int)sqrt(numerator(p)); + if (nm * nm == numerator(p)) + { + s7_int dn = (s7_int)sqrt(denominator(p)); + if (dn * dn == denominator(p)) + return(make_ratio(sc, nm, dn)); + } + return(make_real(sc, sqrt((s7_double)fraction(p)))); + } #if HAVE_COMPLEX_NUMBERS return(make_complex(sc, 0.0, sqrt((s7_double)(-fraction(p))))); #else @@ -18056,7 +18056,7 @@ static s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer p) case T_REAL: if (is_NaN(real(p))) return(p); if (real(p) >= 0.0) - return(make_real(sc, sqrt(real(p)))); + return(make_real(sc, sqrt(real(p)))); return(make_complex_not_0i(sc, 0.0, sqrt(-real(p)))); case T_COMPLEX: /* (* inf.0 (sqrt -1)) -> -nan+infi, but (sqrt -inf.0) -> 0+infi */ @@ -18069,46 +18069,46 @@ static s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer p) #if WITH_GMP case T_BIG_INTEGER: if (mpz_cmp_ui(big_integer(p), 0) >= 0) - { - mpz_sqrtrem(sc->mpz_1, sc->mpz_2, big_integer(p)); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - return(mpz_to_integer(sc, sc->mpz_1)); - mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN); - mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } + { + mpz_sqrtrem(sc->mpz_1, sc->mpz_2, big_integer(p)); + if (mpz_cmp_ui(sc->mpz_2, 0) == 0) + return(mpz_to_integer(sc, sc->mpz_1)); + mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN); + mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } mpc_set_z(sc->mpc_1, big_integer(p), MPC_RNDNN); mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); case T_BIG_RATIO: /* if big ratio, check both num and den for squares */ if (mpq_cmp_ui(big_ratio(p), 0, 1) < 0) - { - mpc_set_q(sc->mpc_1, big_ratio(p), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } + { + mpc_set_q(sc->mpc_1, big_ratio(p), MPC_RNDNN); + mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + } mpz_sqrtrem(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(p))); if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - { - mpz_sqrtrem(sc->mpz_3, sc->mpz_2, mpq_denref(big_ratio(p))); - if (mpz_cmp_ui(sc->mpz_2, 0) == 0) - { - mpq_set_num(sc->mpq_1, sc->mpz_1); - mpq_set_den(sc->mpq_1, sc->mpz_3); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - }} + { + mpz_sqrtrem(sc->mpz_3, sc->mpz_2, mpq_denref(big_ratio(p))); + if (mpz_cmp_ui(sc->mpz_2, 0) == 0) + { + mpq_set_num(sc->mpq_1, sc->mpz_1); + mpq_set_den(sc->mpq_1, sc->mpz_3); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + }} mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN); mpfr_sqrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); return(mpfr_to_big_real(sc, sc->mpfr_1)); case T_BIG_REAL: if (mpfr_cmp_ui(big_real(p), 0) < 0) - { - mpc_set_fr(sc->mpc_1, big_real(p), MPC_RNDNN); - mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - } + { + mpc_set_fr(sc->mpc_1, big_real(p), MPC_RNDNN); + mpc_sqrt(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + } mpfr_sqrt(sc->mpfr_1, big_real(p), MPFR_RNDN); return(mpfr_to_big_real(sc, sc->mpfr_1)); @@ -18172,19 +18172,19 @@ static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) if (is_zero(x)) { if ((s7_is_integer(x)) && (s7_is_integer(y)) && (is_zero(y))) - return(int_one); + return(int_one); if (is_real(y)) - { - if (is_negative(sc, y)) - division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y); - } + { + if (is_negative(sc, y)) + division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y); + } else - if (s7_real_part(y) < 0.0) - division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y); + if (s7_real_part(y) < 0.0) + division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y); if ((is_rational(x)) && (is_rational(y))) - return(int_zero); + return(int_zero); return(real_zero); } @@ -18192,92 +18192,92 @@ static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) { s7_int yval = s7_integer_clamped_if_gmp(sc, y); if (yval == 0) - return((is_rational(x)) ? int_one : real_one); + return((is_rational(x)) ? int_one : real_one); if (yval == 1) - return(x); + return(x); if ((!is_big_number(x)) && - ((is_one(x)) || (is_zero(x)))) - return(x); + ((is_one(x)) || (is_zero(x)))) + return(x); if ((yval < S7_INT32_MAX) && - (yval > S7_INT32_MIN)) - { - /* (protect against gmp exception if for example (expt 1/9223372036854775807 -9223372036854775807) */ - if (s7_is_integer(x)) - { - if (is_t_big_integer(x)) - mpz_set(sc->mpz_2, big_integer(x)); - else mpz_set_si(sc->mpz_2, integer(x)); - if (yval >= 0) - { - mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval); - return(mpz_to_integer(sc, sc->mpz_2)); - } - mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)(-yval)); - mpq_set_z(sc->mpq_1, sc->mpz_2); - mpq_inv(sc->mpq_1, sc->mpq_1); - if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) - return(mpz_to_integer(sc, mpq_numref(sc->mpq_1))); - return(mpq_to_big_ratio(sc, sc->mpq_1)); - } - - if (s7_is_ratio(x)) /* here y is an integer */ - { - if (is_t_big_ratio(x)) - { - mpz_set(sc->mpz_1, mpq_numref(big_ratio(x))); - mpz_set(sc->mpz_2, mpq_denref(big_ratio(x))); - } - else - { - mpz_set_si(sc->mpz_1, numerator(x)); - mpz_set_si(sc->mpz_2, denominator(x)); - } - if (yval >= 0) - { - mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t)yval); - mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval); - mpq_set_num(sc->mpq_1, sc->mpz_1); - mpq_set_den(sc->mpq_1, sc->mpz_2); - } - else - { - yval = -yval; - mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t)yval); - mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval); - mpq_set_num(sc->mpq_1, sc->mpz_2); - mpq_set_den(sc->mpq_1, sc->mpz_1); - mpq_canonicalize(sc->mpq_1); - } - if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) - return(mpz_to_integer(sc, mpq_numref(sc->mpq_1))); - return(mpq_to_big_ratio(sc, sc->mpq_1)); - } - - if (is_real(x)) - { - if (is_t_big_real(x)) - mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); - else mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_pow_si(sc->mpfr_1, sc->mpfr_1, yval, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - }}} + (yval > S7_INT32_MIN)) + { + /* (protect against gmp exception if for example (expt 1/9223372036854775807 -9223372036854775807) */ + if (s7_is_integer(x)) + { + if (is_t_big_integer(x)) + mpz_set(sc->mpz_2, big_integer(x)); + else mpz_set_si(sc->mpz_2, integer(x)); + if (yval >= 0) + { + mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval); + return(mpz_to_integer(sc, sc->mpz_2)); + } + mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)(-yval)); + mpq_set_z(sc->mpq_1, sc->mpz_2); + mpq_inv(sc->mpq_1, sc->mpq_1); + if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) + return(mpz_to_integer(sc, mpq_numref(sc->mpq_1))); + return(mpq_to_big_ratio(sc, sc->mpq_1)); + } + + if (s7_is_ratio(x)) /* here y is an integer */ + { + if (is_t_big_ratio(x)) + { + mpz_set(sc->mpz_1, mpq_numref(big_ratio(x))); + mpz_set(sc->mpz_2, mpq_denref(big_ratio(x))); + } + else + { + mpz_set_si(sc->mpz_1, numerator(x)); + mpz_set_si(sc->mpz_2, denominator(x)); + } + if (yval >= 0) + { + mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t)yval); + mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval); + mpq_set_num(sc->mpq_1, sc->mpz_1); + mpq_set_den(sc->mpq_1, sc->mpz_2); + } + else + { + yval = -yval; + mpz_pow_ui(sc->mpz_1, sc->mpz_1, (uint32_t)yval); + mpz_pow_ui(sc->mpz_2, sc->mpz_2, (uint32_t)yval); + mpq_set_num(sc->mpq_1, sc->mpz_2); + mpq_set_den(sc->mpq_1, sc->mpz_1); + mpq_canonicalize(sc->mpq_1); + } + if (mpz_cmp_ui(mpq_denref(sc->mpq_1), 1) == 0) + return(mpz_to_integer(sc, mpq_numref(sc->mpq_1))); + return(mpq_to_big_ratio(sc, sc->mpq_1)); + } + + if (is_real(x)) + { + if (is_t_big_real(x)) + mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); + else mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_pow_si(sc->mpfr_1, sc->mpfr_1, yval, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + }}} if ((is_t_ratio(y)) && /* not s7_is_ratio which accepts bignums */ (numerator(y) == 1)) { if (denominator(y) == 2) - return(sqrt_p_p(sc, x)); + return(sqrt_p_p(sc, x)); if ((is_real(x)) && - (denominator(y) == 3)) - { - any_real_to_mpfr(sc, x, sc->mpfr_1); - mpfr_cbrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - }} + (denominator(y) == 3)) + { + any_real_to_mpfr(sc, x, sc->mpfr_1); + mpfr_cbrt(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + }} res = any_number_to_mpc(sc, y, sc->mpc_2); if (res == real_infinity) @@ -18285,18 +18285,18 @@ static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) if (is_one(x)) return(int_one); if (!is_real(x)) return((is_negative(sc, y)) ? real_zero : complex_NaN); if (is_zero(x)) - { - if (is_negative(sc, y)) division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y); - return(real_zero); - } + { + if (is_negative(sc, y)) division_by_zero_error_2_nr(sc, sc->expt_symbol, x, y); + return(real_zero); + } if (lt_b_pi(sc, x, 0)) - { - if (lt_b_pi(sc, x, -1)) - return((is_positive(sc, y)) ? real_infinity : real_zero); - return((is_positive(sc, y)) ? real_zero : real_infinity); - } + { + if (lt_b_pi(sc, x, -1)) + return((is_positive(sc, y)) ? real_infinity : real_zero); + return((is_positive(sc, y)) ? real_zero : real_infinity); + } if (lt_b_pi(sc, x, 1)) - return((is_positive(sc, y)) ? real_zero : real_infinity); + return((is_positive(sc, y)) ? real_zero : real_infinity); return((is_positive(sc, y)) ? real_infinity : real_zero); } if (res) return(complex_NaN); @@ -18307,14 +18307,14 @@ static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) { res = any_real_to_mpfr(sc, x, sc->mpfr_1); if (res) - { - if (res == real_infinity) - { - if (is_negative(sc, y)) return(real_zero); - return((is_zero(y)) ? real_one : real_infinity); - } - return(complex_NaN); - } + { + if (res == real_infinity) + { + if (is_negative(sc, y)) return(real_zero); + return((is_zero(y)) ? real_one : real_infinity); + } + return(complex_NaN); + } mpfr_pow(sc->mpfr_1, sc->mpfr_1, mpc_realref(sc->mpc_2), MPFR_RNDN); return(mpfr_to_big_real(sc, sc->mpfr_1)); } @@ -18323,10 +18323,10 @@ static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) if (res) { if ((res == real_infinity) && (is_real(y))) - { - if (is_negative(sc, y)) return(real_zero); - return((is_zero(y)) ? real_one : real_infinity); - } + { + if (is_negative(sc, y)) return(real_zero); + return((is_zero(y)) ? real_one : real_infinity); + } return(complex_NaN); } if (mpc_cmp_si_si(sc->mpc_1, 0, 0) == 0) @@ -18339,17 +18339,17 @@ static s7_pointer big_expt(s7_scheme *sc, s7_pointer args) if ((!mpfr_nan_p(mpc_imagref(sc->mpc_1))) && (mpfr_cmp_ui(mpc_imagref(sc->mpc_1), 0) == 0)) /* (expt -inf.0 1/3) -> +inf.0+nan.0i in mpc */ { if ((is_rational(car(args))) && - (is_rational(cadr(args))) && - (mpfr_integer_p(mpc_realref(sc->mpc_1)) != 0)) - { - /* mpfr_integer_p can be confused: (expt 2718/1000 (bignum 617/5)) returns an int32_t if precision=128, float if 512 */ - /* so first make sure we're within (say) 31 bits */ - mpfr_set_ui(sc->mpfr_1, S7_INT32_MAX, MPFR_RNDN); - if (mpfr_cmpabs(mpc_realref(sc->mpc_1), sc->mpfr_1) < 0) - { - mpfr_get_z(sc->mpz_1, mpc_realref(sc->mpc_1), MPFR_RNDN); - return(mpz_to_integer(sc, sc->mpz_1)); - }} + (is_rational(cadr(args))) && + (mpfr_integer_p(mpc_realref(sc->mpc_1)) != 0)) + { + /* mpfr_integer_p can be confused: (expt 2718/1000 (bignum 617/5)) returns an int32_t if precision=128, float if 512 */ + /* so first make sure we're within (say) 31 bits */ + mpfr_set_ui(sc->mpfr_1, S7_INT32_MAX, MPFR_RNDN); + if (mpfr_cmpabs(mpc_realref(sc->mpc_1), sc->mpfr_1) < 0) + { + mpfr_get_z(sc->mpz_1, mpc_realref(sc->mpc_1), MPFR_RNDN); + return(mpz_to_integer(sc, sc->mpz_1)); + }} mpfr_set(sc->mpfr_1, mpc_realref(sc->mpc_1), MPFR_RNDN); return(mpfr_to_big_real(sc, sc->mpfr_1)); } @@ -18367,136 +18367,136 @@ static s7_pointer expt_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer pw) if (is_zero(n)) { if (is_zero(pw)) - { - if ((s7_is_integer(n)) && (s7_is_integer(pw))) /* (expt 0 0) -> 1 */ - return(int_one); - return(real_zero); /* (expt 0.0 0) -> 0.0 */ - } + { + if ((s7_is_integer(n)) && (s7_is_integer(pw))) /* (expt 0 0) -> 1 */ + return(int_one); + return(real_zero); /* (expt 0.0 0) -> 0.0 */ + } if (is_real(pw)) - { - if (is_negative(sc, pw)) /* (expt 0 -1) */ - division_by_zero_error_2_nr(sc, sc->expt_symbol, n, pw); - /* (Clisp gives divide-by-zero error here, Guile returns inf.0) */ - - if (is_NaN(s7_real(pw))) /* (expt 0 +nan.0) */ - return(pw); - } + { + if (is_negative(sc, pw)) /* (expt 0 -1) */ + division_by_zero_error_2_nr(sc, sc->expt_symbol, n, pw); + /* (Clisp gives divide-by-zero error here, Guile returns inf.0) */ + + if (is_NaN(s7_real(pw))) /* (expt 0 +nan.0) */ + return(pw); + } else - { /* (expt 0 a+bi) */ - if (real_part(pw) < 0.0) /* (expt 0 -1+i) */ - division_by_zero_error_2_nr(sc, sc->expt_symbol, n, pw); - if ((is_NaN(real_part(pw))) || /* (expt 0 0+1/0i) */ - (is_NaN(imag_part(pw)))) - return(pw); - } + { /* (expt 0 a+bi) */ + if (real_part(pw) < 0.0) /* (expt 0 -1+i) */ + division_by_zero_error_2_nr(sc, sc->expt_symbol, n, pw); + if ((is_NaN(real_part(pw))) || /* (expt 0 0+1/0i) */ + (is_NaN(imag_part(pw)))) + return(pw); + } if ((s7_is_integer(n)) && (s7_is_integer(pw))) /* pw != 0, (expt 0 2312) */ - return(int_zero); + return(int_zero); return(real_zero); /* (expt 0.0 123123) */ } if (is_one(pw)) { if (s7_is_integer(pw)) /* (expt x 1) */ - return(n); + return(n); if (is_rational(n)) /* (expt ratio 1.0) */ - return(make_real(sc, rational_to_double(sc, n))); + return(make_real(sc, rational_to_double(sc, n))); return(n); } if (is_t_integer(pw)) { s7_int y = integer(pw); if (y == 0) - { - if (is_rational(n)) /* (expt 3 0) */ - return(int_one); - if ((is_NaN(s7_real_part(n))) || /* (expt 1/0 0) -> NaN */ - (is_NaN(s7_imag_part(n)))) /* (expt (complex 0 1/0) 0) -> NaN */ - return(n); - return(real_one); /* (expt 3.0 0) */ - } + { + if (is_rational(n)) /* (expt 3 0) */ + return(int_one); + if ((is_NaN(s7_real_part(n))) || /* (expt 1/0 0) -> NaN */ + (is_NaN(s7_imag_part(n)))) /* (expt (complex 0 1/0) 0) -> NaN */ + return(n); + return(real_one); /* (expt 3.0 0) */ + } switch (type(n)) - { - case T_INTEGER: - { - s7_int x = integer(n); - if (x == 1) /* (expt 1 y) */ - return(n); - - if (x == -1) - { - if (y == S7_INT64_MIN) /* (expt -1 most-negative-fixnum) */ - return(int_one); - if (s7_int_abs(y) & 1) /* (expt -1 odd-int) */ - return(n); - return(int_one); /* (expt -1 even-int) */ - } - - if (y == S7_INT64_MIN) /* (expt x most-negative-fixnum) */ - return(int_zero); - if (x == S7_INT64_MIN) /* (expt most-negative-fixnum y) */ - return(make_real(sc, pow((double)x, (double)y))); - - if (int_pow_ok(x, s7_int_abs(y))) - { - if (y > 0) - return(make_integer(sc, int_to_int(x, y))); - return(make_ratio(sc, 1, int_to_int(x, -y))); - }} - break; - - case T_RATIO: - { - s7_int nm = numerator(n), dn = denominator(n); - if (y == S7_INT64_MIN) - { - if (s7_int_abs(nm) > dn) - return(int_zero); /* (expt 4/3 most-negative-fixnum) -> 0? */ - return(real_infinity); /* (expt 3/4 most-negative-fixnum) -> inf? */ - } - if ((int_pow_ok(nm, s7_int_abs(y))) && - (int_pow_ok(dn, s7_int_abs(y)))) - { - if (y > 0) - return(make_ratio(sc, int_to_int(nm, y), int_to_int(dn, y))); - return(make_ratio_with_div_check(sc, sc->expt_symbol, int_to_int(dn, -y), int_to_int(nm, -y))); - }} - break; - /* occasionally int^rat can be int32_t but it happens so infrequently it's probably not worth checking - * one possibly easy case: (expt 1 1/2) -> 1 (-1?) etc - */ - - case T_REAL: - /* (expt -1.0 most-positive-fixnum) should be -1.0 - * (expt -1.0 (+ (expt 2 53) 1)) -> -1.0 - * (expt -1.0 (- 1 (expt 2 54))) -> -1.0 - */ - if (real(n) == -1.0) - { - if (y == S7_INT64_MIN) - return(real_one); - return((s7_int_abs(y) & 1) ? n : real_one); - } - break; - - case T_COMPLEX: + { + case T_INTEGER: + { + s7_int x = integer(n); + if (x == 1) /* (expt 1 y) */ + return(n); + + if (x == -1) + { + if (y == S7_INT64_MIN) /* (expt -1 most-negative-fixnum) */ + return(int_one); + if (s7_int_abs(y) & 1) /* (expt -1 odd-int) */ + return(n); + return(int_one); /* (expt -1 even-int) */ + } + + if (y == S7_INT64_MIN) /* (expt x most-negative-fixnum) */ + return(int_zero); + if (x == S7_INT64_MIN) /* (expt most-negative-fixnum y) */ + return(make_real(sc, pow((double)x, (double)y))); + + if (int_pow_ok(x, s7_int_abs(y))) + { + if (y > 0) + return(make_integer(sc, int_to_int(x, y))); + return(make_ratio(sc, 1, int_to_int(x, -y))); + }} + break; + + case T_RATIO: + { + s7_int nm = numerator(n), dn = denominator(n); + if (y == S7_INT64_MIN) + { + if (s7_int_abs(nm) > dn) + return(int_zero); /* (expt 4/3 most-negative-fixnum) -> 0? */ + return(real_infinity); /* (expt 3/4 most-negative-fixnum) -> inf? */ + } + if ((int_pow_ok(nm, s7_int_abs(y))) && + (int_pow_ok(dn, s7_int_abs(y)))) + { + if (y > 0) + return(make_ratio(sc, int_to_int(nm, y), int_to_int(dn, y))); + return(make_ratio_with_div_check(sc, sc->expt_symbol, int_to_int(dn, -y), int_to_int(nm, -y))); + }} + break; + /* occasionally int^rat can be int32_t but it happens so infrequently it's probably not worth checking + * one possibly easy case: (expt 1 1/2) -> 1 (-1?) etc + */ + + case T_REAL: + /* (expt -1.0 most-positive-fixnum) should be -1.0 + * (expt -1.0 (+ (expt 2 53) 1)) -> -1.0 + * (expt -1.0 (- 1 (expt 2 54))) -> -1.0 + */ + if (real(n) == -1.0) + { + if (y == S7_INT64_MIN) + return(real_one); + return((s7_int_abs(y) & 1) ? n : real_one); + } + break; + + case T_COMPLEX: #if HAVE_COMPLEX_NUMBERS - if ((s7_real_part(n) == 0.0) && - ((s7_imag_part(n) == 1.0) || - (s7_imag_part(n) == -1.0))) - { - bool yp = (y > 0), np = (s7_imag_part(n) > 0.0); - switch (s7_int_abs(y) % 4) - { - case 0: return(real_one); - case 1: return(make_complex_not_0i(sc, 0.0, (yp == np) ? 1.0 : -1.0)); - case 2: return(make_real(sc, -1.0)); - case 3: return(make_complex_not_0i(sc, 0.0, (yp == np) ? -1.0 : 1.0)); - }} + if ((s7_real_part(n) == 0.0) && + ((s7_imag_part(n) == 1.0) || + (s7_imag_part(n) == -1.0))) + { + bool yp = (y > 0), np = (s7_imag_part(n) > 0.0); + switch (s7_int_abs(y) % 4) + { + case 0: return(real_one); + case 1: return(make_complex_not_0i(sc, 0.0, (yp == np) ? 1.0 : -1.0)); + case 2: return(make_real(sc, -1.0)); + case 3: return(make_complex_not_0i(sc, 0.0, (yp == np) ? -1.0 : 1.0)); + }} #else - out_of_range_error_nr(sc, sc->expt_symbol, int_two, n, no_complex_numbers_string); + out_of_range_error_nr(sc, sc->expt_symbol, int_two, n, no_complex_numbers_string); #endif - break; - }} + break; + }} if ((is_real(n)) && (is_real(pw))) @@ -18504,14 +18504,14 @@ static s7_pointer expt_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer pw) s7_double x, y; if ((is_t_ratio(pw)) && - (numerator(pw) == 1)) - { - if (denominator(pw) == 2) - return(sqrt_p_p(sc, n)); - if (denominator(pw) == 3) - return(make_real(sc, cbrt(s7_real(n)))); /* (expt 27 1/3) should be 3, not 3.0... */ - /* but: (expt 512/729 1/3) -> 0.88888888888889, and 4 -> sqrt(sqrt...) etc? */ - } + (numerator(pw) == 1)) + { + if (denominator(pw) == 2) + return(sqrt_p_p(sc, n)); + if (denominator(pw) == 3) + return(make_real(sc, cbrt(s7_real(n)))); /* (expt 27 1/3) should be 3, not 3.0... */ + /* but: (expt 512/729 1/3) -> 0.88888888888889, and 4 -> sqrt(sqrt...) etc? */ + } x = s7_real(n); y = s7_real(pw); @@ -18520,7 +18520,7 @@ static s7_pointer expt_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer pw) if (y == 0.0) return(real_one); /* I think pow(rl, inf) is ok */ if (x > 0.0) - return(make_real(sc, pow(x, y))); /* tricky cases abound here: (expt -1 1/9223372036854775807) */ + return(make_real(sc, pow(x, y))); /* tricky cases abound here: (expt -1 1/9223372036854775807) */ } /* (expt 0+i 1e+16) = 0.98156860153485-0.19111012657867i ? @@ -18552,33 +18552,33 @@ static s7_pointer big_lcm(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args { s7_pointer rat = car(x); switch (type(rat)) - { - case T_INTEGER: - mpz_set_si(sc->mpz_1, integer(rat)); - mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1); - mpz_set_si(sc->mpz_4, 1); - break; - case T_RATIO: - mpz_set_si(sc->mpz_1, numerator(rat)); - mpz_set_si(sc->mpz_2, denominator(rat)); - mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1); - mpz_gcd(sc->mpz_4, sc->mpz_4, sc->mpz_2); - break; - case T_BIG_INTEGER: - mpz_lcm(sc->mpz_3, sc->mpz_3, big_integer(rat)); - mpz_set_si(sc->mpz_4, 1); - break; - case T_BIG_RATIO: - mpz_lcm(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat))); - mpz_gcd(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat))); - break; - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->lcm_symbol, position_of(x, args), rat, a_rational_string); - default: - return(method_or_bust(sc, rat, sc->lcm_symbol, - set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x), - a_rational_string, position_of(x, args))); - }} + { + case T_INTEGER: + mpz_set_si(sc->mpz_1, integer(rat)); + mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1); + mpz_set_si(sc->mpz_4, 1); + break; + case T_RATIO: + mpz_set_si(sc->mpz_1, numerator(rat)); + mpz_set_si(sc->mpz_2, denominator(rat)); + mpz_lcm(sc->mpz_3, sc->mpz_3, sc->mpz_1); + mpz_gcd(sc->mpz_4, sc->mpz_4, sc->mpz_2); + break; + case T_BIG_INTEGER: + mpz_lcm(sc->mpz_3, sc->mpz_3, big_integer(rat)); + mpz_set_si(sc->mpz_4, 1); + break; + case T_BIG_RATIO: + mpz_lcm(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat))); + mpz_gcd(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat))); + break; + case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: + wrong_type_error_nr(sc, sc->lcm_symbol, position_of(x, args), rat, a_rational_string); + default: + return(method_or_bust(sc, rat, sc->lcm_symbol, + set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x), + a_rational_string, position_of(x, args))); + }} return(mpz_to_rational(sc, sc->mpz_3, sc->mpz_4)); } #endif @@ -18597,7 +18597,7 @@ static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args) if (!is_pair(cdr(args))) { if (!is_rational(car(args))) - return(method_or_bust(sc, car(args), sc->lcm_symbol, args, a_rational_string, 1)); + return(method_or_bust(sc, car(args), sc->lcm_symbol, args, a_rational_string, 1)); return(g_abs(sc, args)); } @@ -18609,97 +18609,97 @@ static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args) s7_int n1; #endif switch (type(x)) - { - case T_INTEGER: - d = 1; - if (integer(x) == 0) /* return 0 unless there's a wrong-type-arg (geez what a mess) */ - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - { - s7_pointer x1 = car(p); - if (is_number(x1)) - { - if (!is_rational(x1)) - wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string); - } - else - if (has_active_methods(sc, x1)) - { - s7_pointer f = find_method_with_let(sc, x1, sc->is_rational_symbol); - if ((f == sc->undefined) || - (is_false(sc, s7_apply_function(sc, f, set_plist_1(sc, x1))))) - wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string); - } - else wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string); - } - return(int_zero); - } - b = integer(x); - if (b < 0) - { - if (b == S7_INT64_MIN) + { + case T_INTEGER: + d = 1; + if (integer(x) == 0) /* return 0 unless there's a wrong-type-arg (geez what a mess) */ + { + for (p = cdr(p); is_pair(p); p = cdr(p)) + { + s7_pointer x1 = car(p); + if (is_number(x1)) + { + if (!is_rational(x1)) + wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string); + } + else + if (has_active_methods(sc, x1)) + { + s7_pointer f = find_method_with_let(sc, x1, sc->is_rational_symbol); + if ((f == sc->undefined) || + (is_false(sc, s7_apply_function(sc, f, set_plist_1(sc, x1))))) + wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string); + } + else wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x1, a_rational_string); + } + return(int_zero); + } + b = integer(x); + if (b < 0) + { + if (b == S7_INT64_MIN) #if WITH_GMP - return(big_lcm(sc, n, d, p)); + return(big_lcm(sc, n, d, p)); #else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, it_is_too_large_string); + sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, it_is_too_large_string); #endif - b = -b; - } + b = -b; + } #if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(n / c_gcd(n, b), b, &n1)) + if (multiply_overflow(n / c_gcd(n, b), b, &n1)) #if WITH_GMP - return(big_lcm(sc, n, d, p)); + return(big_lcm(sc, n, d, p)); #else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, result_is_too_large_string); + sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, result_is_too_large_string); #endif - n = n1; + n = n1; #else - n = (n / c_gcd(n, b)) * b; + n = (n / c_gcd(n, b)) * b; #endif - break; + break; - case T_RATIO: - b = numerator(x); - if (b < 0) - { - if (b == S7_INT64_MIN) + case T_RATIO: + b = numerator(x); + if (b < 0) + { + if (b == S7_INT64_MIN) #if WITH_GMP - return(big_lcm(sc, n, d, p)); + return(big_lcm(sc, n, d, p)); #else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, it_is_too_large_string); + sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, it_is_too_large_string); #endif - b = -b; - } + b = -b; + } #if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(n / c_gcd(n, b), b, &n1)) /* (lcm 92233720368547758/3 3005/2) */ + if (multiply_overflow(n / c_gcd(n, b), b, &n1)) /* (lcm 92233720368547758/3 3005/2) */ #if WITH_GMP - return(big_lcm(sc, n, d, p)); + return(big_lcm(sc, n, d, p)); #else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, intermediate_too_large_string); + sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, intermediate_too_large_string); #endif n = n1; #else - n = (n / c_gcd(n, b)) * b; + n = (n / c_gcd(n, b)) * b; #endif - if (d == 0) - d = (p == args) ? denominator(x) : 1; - else d = c_gcd(d, denominator(x)); - break; + if (d == 0) + d = (p == args) ? denominator(x) : 1; + else d = c_gcd(d, denominator(x)); + break; #if WITH_GMP - case T_BIG_INTEGER: - d = 1; - case T_BIG_RATIO: - return(big_lcm(sc, n, d, p)); -#endif - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x, a_rational_string); - - default: - return(method_or_bust(sc, x, sc->lcm_symbol, - set_ulist_1(sc, (d <= 1) ? make_integer(sc, n) : make_ratio_with_div_check(sc, sc->lcm_symbol, n, d), p), - a_rational_string, position_of(p, args))); - }} + case T_BIG_INTEGER: + d = 1; + case T_BIG_RATIO: + return(big_lcm(sc, n, d, p)); +#endif + case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: + wrong_type_error_nr(sc, sc->lcm_symbol, position_of(p, args), x, a_rational_string); + + default: + return(method_or_bust(sc, x, sc->lcm_symbol, + set_ulist_1(sc, (d <= 1) ? make_integer(sc, n) : make_ratio_with_div_check(sc, sc->lcm_symbol, n, d), p), + a_rational_string, position_of(p, args))); + }} return((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d)); } @@ -18715,31 +18715,31 @@ static s7_pointer big_gcd(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args { s7_pointer rat = car(x); switch (type(rat)) - { - case T_INTEGER: - mpz_set_si(sc->mpz_1, integer(rat)); - mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1); - break; - case T_RATIO: - mpz_set_si(sc->mpz_1, numerator(rat)); - mpz_set_si(sc->mpz_2, denominator(rat)); - mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1); - mpz_lcm(sc->mpz_4, sc->mpz_4, sc->mpz_2); - break; - case T_BIG_INTEGER: - mpz_gcd(sc->mpz_3, sc->mpz_3, big_integer(rat)); - break; - case T_BIG_RATIO: - mpz_gcd(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat))); - mpz_lcm(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat))); - break; - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->gcd_symbol, position_of(x, args), rat, a_rational_string); - default: - return(method_or_bust(sc, rat, sc->gcd_symbol, - set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x), - a_rational_string, position_of(x, args))); - }} + { + case T_INTEGER: + mpz_set_si(sc->mpz_1, integer(rat)); + mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1); + break; + case T_RATIO: + mpz_set_si(sc->mpz_1, numerator(rat)); + mpz_set_si(sc->mpz_2, denominator(rat)); + mpz_gcd(sc->mpz_3, sc->mpz_3, sc->mpz_1); + mpz_lcm(sc->mpz_4, sc->mpz_4, sc->mpz_2); + break; + case T_BIG_INTEGER: + mpz_gcd(sc->mpz_3, sc->mpz_3, big_integer(rat)); + break; + case T_BIG_RATIO: + mpz_gcd(sc->mpz_3, sc->mpz_3, mpq_numref(big_ratio(rat))); + mpz_lcm(sc->mpz_4, sc->mpz_4, mpq_denref(big_ratio(rat))); + break; + case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: + wrong_type_error_nr(sc, sc->gcd_symbol, position_of(x, args), rat, a_rational_string); + default: + return(method_or_bust(sc, rat, sc->gcd_symbol, + set_ulist_1(sc, mpz_to_rational(sc, sc->mpz_3, sc->mpz_4), x), + a_rational_string, position_of(x, args))); + }} return(mpz_to_rational(sc, sc->mpz_3, sc->mpz_4)); } #endif @@ -18757,7 +18757,7 @@ static s7_pointer g_gcd(s7_scheme *sc, s7_pointer args) if (!is_pair(cdr(args))) /* (gcd 3/4) */ { if (!is_rational(car(args))) - return(method_or_bust(sc, car(args), sc->gcd_symbol, args, a_rational_string, 1)); + return(method_or_bust(sc, car(args), sc->gcd_symbol, args, a_rational_string, 1)); return(abs_p_p(sc, car(args))); } @@ -18765,56 +18765,56 @@ static s7_pointer g_gcd(s7_scheme *sc, s7_pointer args) { s7_pointer x = car(p); switch (type(x)) - { - case T_INTEGER: - if (integer(x) == S7_INT64_MIN) + { + case T_INTEGER: + if (integer(x) == S7_INT64_MIN) #if WITH_GMP - return(big_gcd(sc, n, d, p)); + return(big_gcd(sc, n, d, p)); #else - sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, it_is_too_large_string); + sole_arg_out_of_range_error_nr(sc, sc->lcm_symbol, args, it_is_too_large_string); #endif - n = c_gcd(n, integer(x)); - break; + n = c_gcd(n, integer(x)); + break; - case T_RATIO: - { + case T_RATIO: + { #if HAVE_OVERFLOW_CHECKS - s7_int dn; -#endif - n = c_gcd(n, numerator(x)); - if (d == 1) - d = denominator(x); - else - { - s7_int b = denominator(x); + s7_int dn; +#endif + n = c_gcd(n, numerator(x)); + if (d == 1) + d = denominator(x); + else + { + s7_int b = denominator(x); #if HAVE_OVERFLOW_CHECKS - if (multiply_overflow(d / c_gcd(d, b), b, &dn)) /* (gcd 1/92233720368547758 1/3005) */ + if (multiply_overflow(d / c_gcd(d, b), b, &dn)) /* (gcd 1/92233720368547758 1/3005) */ #if WITH_GMP - return(big_gcd(sc, n, d, x)); + return(big_gcd(sc, n, d, x)); #else - sole_arg_out_of_range_error_nr(sc, sc->gcd_symbol, args, intermediate_too_large_string); + sole_arg_out_of_range_error_nr(sc, sc->gcd_symbol, args, intermediate_too_large_string); #endif - d = dn; + d = dn; #else - d = (d / c_gcd(d, b)) * b; + d = (d / c_gcd(d, b)) * b; #endif - }} - break; + }} + break; #if WITH_GMP - case T_BIG_INTEGER: - case T_BIG_RATIO: - return(big_gcd(sc, n, d, p)); + case T_BIG_INTEGER: + case T_BIG_RATIO: + return(big_gcd(sc, n, d, p)); #endif - case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: - wrong_type_error_nr(sc, sc->gcd_symbol, position_of(p, args), x, a_rational_string); + case T_REAL: case T_BIG_REAL: case T_COMPLEX: case T_BIG_COMPLEX: + wrong_type_error_nr(sc, sc->gcd_symbol, position_of(p, args), x, a_rational_string); - default: - return(method_or_bust(sc, x, sc->gcd_symbol, - set_ulist_1(sc, (d <= 1) ? make_integer(sc, n) : make_ratio_with_div_check(sc, sc->gcd_symbol, n, d), p), - a_rational_string, position_of(p, args))); - }} + default: + return(method_or_bust(sc, x, sc->gcd_symbol, + set_ulist_1(sc, (d <= 1) ? make_integer(sc, n) : make_ratio_with_div_check(sc, sc->gcd_symbol, n, d), p), + a_rational_string, position_of(p, args))); + }} return((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d)); } @@ -18828,35 +18828,35 @@ static s7_pointer floor_p_p(s7_scheme *sc, s7_pointer x) return(x); case T_RATIO: { - s7_int val = numerator(x) / denominator(x); - /* C "/" truncates? -- C spec says "truncation toward 0" */ - /* we're avoiding "floor" here because the int->double conversion introduces inaccuracies for big numbers - * but it's used by opt_i_d_c (via s7_number_to_real) so floor_i_7d below can return different results: - * (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (floor 3441313796169221281/1720656898084610641)) (newline))) (func)): 1 - * (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (/ (floor 3441313796169221281/1720656898084610641))) (newline))) (func)): 1/2 - */ - return(make_integer(sc, (numerator(x) < 0) ? (val - 1) : val)); /* not "val" because it might be truncated to 0 */ + s7_int val = numerator(x) / denominator(x); + /* C "/" truncates? -- C spec says "truncation toward 0" */ + /* we're avoiding "floor" here because the int->double conversion introduces inaccuracies for big numbers + * but it's used by opt_i_d_c (via s7_number_to_real) so floor_i_7d below can return different results: + * (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (floor 3441313796169221281/1720656898084610641)) (newline))) (func)): 1 + * (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (display (/ (floor 3441313796169221281/1720656898084610641))) (newline))) (func)): 1/2 + */ + return(make_integer(sc, (numerator(x) < 0) ? (val - 1) : val)); /* not "val" because it might be truncated to 0 */ } case T_REAL: { - s7_double z = real(x); - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_nan_string); - if (is_inf(z)) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_infinite_string); + s7_double z = real(x); + if (is_NaN(z)) + sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_nan_string); + if (is_inf(z)) + sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_infinite_string); #if WITH_GMP - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - { - mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD); - return(mpz_to_integer(sc, sc->mpz_1)); - } + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) + { + mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); + mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD); + return(mpz_to_integer(sc, sc->mpz_1)); + } #else - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_too_large_string); + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_too_large_string); #endif - return(make_integer(sc, (s7_int)floor(z))); - /* floor here rounds down, whereas a straight int<=real coercion apparently rounds towards 0 */ + return(make_integer(sc, (s7_int)floor(z))); + /* floor here rounds down, whereas a straight int<=real coercion apparently rounds towards 0 */ } #if WITH_GMP case T_BIG_INTEGER: @@ -18866,9 +18866,9 @@ static s7_pointer floor_p_p(s7_scheme *sc, s7_pointer x) return(mpz_to_integer(sc, sc->mpz_1)); case T_BIG_REAL: if (mpfr_nan_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_nan_string); + sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_nan_string); if (mpfr_inf_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_infinite_string); + sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, x, it_is_infinite_string); mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDD); return(mpz_to_integer(sc, sc->mpz_1)); case T_BIG_COMPLEX: @@ -18924,28 +18924,28 @@ static s7_pointer ceiling_p_p(s7_scheme *sc, s7_pointer x) return(x); case T_RATIO: { - s7_int val = numerator(x) / denominator(x); - return(make_integer(sc, (numerator(x) < 0) ? val : (val + 1))); + s7_int val = numerator(x) / denominator(x); + return(make_integer(sc, (numerator(x) < 0) ? val : (val + 1))); } case T_REAL: { - s7_double z = real(x); - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_nan_string); - if (is_inf(z)) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_infinite_string); + s7_double z = real(x); + if (is_NaN(z)) + sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_nan_string); + if (is_inf(z)) + sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_infinite_string); #if WITH_GMP - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - { - mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDU); - return(mpz_to_integer(sc, sc->mpz_1)); - } + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) + { + mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); + mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDU); + return(mpz_to_integer(sc, sc->mpz_1)); + } #else - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_too_large_string); + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_too_large_string); #endif - return(make_integer(sc, (s7_int)ceil(real(x)))); + return(make_integer(sc, (s7_int)ceil(real(x)))); } #if WITH_GMP case T_BIG_INTEGER: @@ -18955,9 +18955,9 @@ static s7_pointer ceiling_p_p(s7_scheme *sc, s7_pointer x) return(mpz_to_integer(sc, sc->mpz_1)); case T_BIG_REAL: if (mpfr_nan_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_nan_string); + sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_nan_string); if (mpfr_inf_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_infinite_string); + sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, x, it_is_infinite_string); mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDU); return(mpz_to_integer(sc, sc->mpz_1)); case T_BIG_COMPLEX: @@ -19012,23 +19012,23 @@ static s7_pointer truncate_p_p(s7_scheme *sc, s7_pointer x) return(make_integer(sc, (s7_int)(numerator(x) / denominator(x)))); /* C "/" already truncates (but this divide is not accurate over e13) */ case T_REAL: { - s7_double z = real(x); - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_nan_string); - if (is_inf(z)) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_infinite_string); + s7_double z = real(x); + if (is_NaN(z)) + sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_nan_string); + if (is_inf(z)) + sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_infinite_string); #if WITH_GMP - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - { - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDZ); - return(mpz_to_integer(sc, sc->mpz_1)); - } + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) + { + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDZ); + return(mpz_to_integer(sc, sc->mpz_1)); + } #else - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_too_large_string); + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_too_large_string); #endif - return(make_integer(sc, (z > 0.0) ? (s7_int)floor(z) : (s7_int)ceil(z))); + return(make_integer(sc, (z > 0.0) ? (s7_int)floor(z) : (s7_int)ceil(z))); } #if WITH_GMP case T_BIG_INTEGER: @@ -19038,9 +19038,9 @@ static s7_pointer truncate_p_p(s7_scheme *sc, s7_pointer x) return(mpz_to_integer(sc, sc->mpz_1)); case T_BIG_REAL: if (mpfr_nan_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_nan_string); + sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_nan_string); if (mpfr_inf_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_infinite_string); + sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, x, it_is_infinite_string); mpfr_get_z(sc->mpz_1, big_real(x), MPFR_RNDZ); return(mpz_to_integer(sc, sc->mpz_1)); case T_BIG_COMPLEX: @@ -19096,58 +19096,58 @@ static s7_pointer round_p_p(s7_scheme *sc, s7_pointer x) return(x); case T_RATIO: { - s7_int truncated = numerator(x) / denominator(x), remains = numerator(x) % denominator(x); - long_double frac = s7_fabsl((long_double)remains / (long_double)denominator(x)); - if ((frac > 0.5) || - ((frac == 0.5) && - (truncated % 2 != 0))) - return(make_integer(sc, (numerator(x) < 0) ? (truncated - 1) : (truncated + 1))); - return(make_integer(sc, truncated)); + s7_int truncated = numerator(x) / denominator(x), remains = numerator(x) % denominator(x); + long_double frac = s7_fabsl((long_double)remains / (long_double)denominator(x)); + if ((frac > 0.5) || + ((frac == 0.5) && + (truncated % 2 != 0))) + return(make_integer(sc, (numerator(x) < 0) ? (truncated - 1) : (truncated + 1))); + return(make_integer(sc, truncated)); } case T_REAL: { - s7_double z = real(x); - if (is_NaN(z)) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_nan_string); - if (is_inf(z)) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_infinite_string); + s7_double z = real(x); + if (is_NaN(z)) + sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_nan_string); + if (is_inf(z)) + sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_infinite_string); #if WITH_GMP - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - { - mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); - mpfr_rint(sc->mpfr_2, sc->mpfr_1, MPFR_RNDN); /* mpfr_roundeven in mpfr 4.0.0 */ - mpfr_get_z(sc->mpz_3, sc->mpfr_2, MPFR_RNDN); - return(mpz_to_integer(sc, sc->mpz_3)); - } + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) + { + mpfr_set_d(sc->mpfr_1, z, MPFR_RNDN); + mpfr_rint(sc->mpfr_2, sc->mpfr_1, MPFR_RNDN); /* mpfr_roundeven in mpfr 4.0.0 */ + mpfr_get_z(sc->mpz_3, sc->mpfr_2, MPFR_RNDN); + return(mpz_to_integer(sc, sc->mpz_3)); + } #else - if (fabs(z) > DOUBLE_TO_INT64_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_too_large_string); + if (fabs(z) > DOUBLE_TO_INT64_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_too_large_string); #endif - return(make_integer(sc, (s7_int)r5rs_round(z))); + return(make_integer(sc, (s7_int)r5rs_round(z))); } #if WITH_GMP case T_BIG_INTEGER: - return(x); + return(x); case T_BIG_RATIO: { - int32_t rnd; - mpz_fdiv_qr(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); - mpz_mul_ui(sc->mpz_2, sc->mpz_2, 2); - rnd = mpz_cmpabs(sc->mpz_2, mpq_denref(big_ratio(x))); - mpz_fdiv_q(sc->mpz_2, sc->mpz_2, mpq_denref(big_ratio(x))); - if (rnd > 0) - mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); - else - if ((rnd == 0) && - (mpz_odd_p(sc->mpz_1))) - mpz_add_ui(sc->mpz_1, sc->mpz_1, 1); - return(mpz_to_integer(sc, sc->mpz_1)); + int32_t rnd; + mpz_fdiv_qr(sc->mpz_1, sc->mpz_2, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(x))); + mpz_mul_ui(sc->mpz_2, sc->mpz_2, 2); + rnd = mpz_cmpabs(sc->mpz_2, mpq_denref(big_ratio(x))); + mpz_fdiv_q(sc->mpz_2, sc->mpz_2, mpq_denref(big_ratio(x))); + if (rnd > 0) + mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); + else + if ((rnd == 0) && + (mpz_odd_p(sc->mpz_1))) + mpz_add_ui(sc->mpz_1, sc->mpz_1, 1); + return(mpz_to_integer(sc, sc->mpz_1)); } case T_BIG_REAL: if (mpfr_nan_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_nan_string); + sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_nan_string); if (mpfr_inf_p(big_real(x))) - sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_infinite_string); + sole_arg_out_of_range_error_nr(sc, sc->round_symbol, x, it_is_infinite_string); mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN); mpfr_rint(sc->mpfr_2, sc->mpfr_1, MPFR_RNDN); mpfr_get_z(sc->mpz_3, sc->mpfr_2, MPFR_RNDN); @@ -19247,376 +19247,376 @@ static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if (is_t_integer(x)) { if (is_t_integer(y)) - return(add_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); + return(add_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); } else if (is_t_real(x)) { - if (is_t_real(y)) - return(make_real(sc, real(x) + real(y))); + if (is_t_real(y)) + return(make_real(sc, real(x) + real(y))); } else if ((is_t_complex(x)) && (is_t_complex(y))) - return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); + return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); switch (type(x)) { case T_INTEGER: switch (type(y)) - { - case T_INTEGER: - return(add_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); - case T_RATIO: - return(integer_ratio_add_if_overflow_to_real_or_rational(sc, x, y)); - case T_REAL: + { + case T_INTEGER: + return(add_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); + case T_RATIO: + return(integer_ratio_add_if_overflow_to_real_or_rational(sc, x, y)); + case T_REAL: #if WITH_GMP - if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) /* (+ 9223372036854775807 .1), >= needed for (+ 9007199254740992 1.0) */ - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, (long_double)integer(x) + real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, (long_double)integer(x) + (long_double)real_part(y), imag_part(y))); + if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) /* (+ 9223372036854775807 .1), >= needed for (+ 9007199254740992 1.0) */ + { + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, (long_double)integer(x) + real(y))); + case T_COMPLEX: + return(make_complex_not_0i(sc, (long_double)integer(x) + (long_double)real_part(y), imag_part(y))); #if WITH_GMP - case T_BIG_INTEGER: - mpz_set_si(sc->mpz_1, integer(x)); - mpz_add(sc->mpz_1, sc->mpz_1, big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_add_si(sc->mpfr_1, big_real(y), integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + mpz_set_si(sc->mpz_1, integer(x)); + mpz_add(sc->mpz_1, sc->mpz_1, big_integer(y)); + return(mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, integer(x), 1); + mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_add_si(sc->mpfr_1, big_real(y), integer(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } case T_RATIO: switch (type(y)) - { - case T_INTEGER: - return(integer_ratio_add_if_overflow_to_real_or_rational(sc, y, x)); - case T_RATIO: - { - s7_int d1, d2, n1, n2; - parcel_out_fractions(x, y); - if (d1 == d2) - { + { + case T_INTEGER: + return(integer_ratio_add_if_overflow_to_real_or_rational(sc, y, x)); + case T_RATIO: + { + s7_int d1, d2, n1, n2; + parcel_out_fractions(x, y); + if (d1 == d2) + { #if HAVE_OVERFLOW_CHECKS - s7_int q; - if (add_overflow(n1, n2, &q)) + s7_int q; + if (add_overflow(n1, n2, &q)) #if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } + { + mpq_set_si(sc->mpq_1, n1, d1); + mpq_set_si(sc->mpq_2, n2, d2); + mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return(mpq_to_rational(sc, sc->mpq_1)); + } #else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio + ratio overflow: (/ (+ %" ld64 " %" ld64 ") %" ld64 ")\n", n1, n2, d1); - return(make_real(sc, ((long_double)n1 + (long_double)n2) / (long_double)d1)); - } + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio + ratio overflow: (/ (+ %" ld64 " %" ld64 ") %" ld64 ")\n", n1, n2, d1); + return(make_real(sc, ((long_double)n1 + (long_double)n2) / (long_double)d1)); + } #endif - return(make_ratio_with_div_check(sc, sc->add_symbol, q, d1)); + return(make_ratio_with_div_check(sc, sc->add_symbol, q, d1)); #else - return(make_ratio_with_div_check(sc, sc->add_symbol, n1 + n2, d1)); + return(make_ratio_with_div_check(sc, sc->add_symbol, n1 + n2, d1)); #endif - } + } #if HAVE_OVERFLOW_CHECKS - { - s7_int n1d2, n2d1, d1d2, q; - if ((multiply_overflow(d1, d2, &d1d2)) || - (multiply_overflow(n1, d2, &n1d2)) || - (multiply_overflow(n2, d1, &n2d1)) || - (add_overflow(n1d2, n2d1, &q))) + { + s7_int n1d2, n2d1, d1d2, q; + if ((multiply_overflow(d1, d2, &d1d2)) || + (multiply_overflow(n1, d2, &n1d2)) || + (multiply_overflow(n2, d1, &n2d1)) || + (add_overflow(n1d2, n2d1, &q))) #if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } + { + mpq_set_si(sc->mpq_1, n1, d1); + mpq_set_si(sc->mpq_2, n2, d2); + mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return(mpq_to_rational(sc, sc->mpq_1)); + } #else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio + ratio overflow: (+ %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); - return(make_real(sc, ((long_double)n1 / (long_double)d1) + ((long_double)n2 / (long_double)d2))); - } + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio + ratio overflow: (+ %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); + return(make_real(sc, ((long_double)n1 / (long_double)d1) + ((long_double)n2 / (long_double)d2))); + } #endif - return(make_ratio_with_div_check(sc, sc->add_symbol, q, d1d2)); - } + return(make_ratio_with_div_check(sc, sc->add_symbol, q, d1d2)); + } #else - return(make_ratio_with_div_check(sc, sc->add_symbol, n1 * d2 + n2 * d1, d1 * d2)); + return(make_ratio_with_div_check(sc, sc->add_symbol, n1 * d2 + n2 * d1, d1 * d2)); #endif - } - case T_REAL: - return(make_real(sc, fraction(x) + real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, fraction(x) + real_part(y), imag_part(y))); + } + case T_REAL: + return(make_real(sc, fraction(x) + real(y))); + case T_COMPLEX: + return(make_complex_not_0i(sc, fraction(x) + real_part(y), imag_part(y))); #if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_set_z(sc->mpq_2, big_integer(y)); - mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_add_q(sc->mpfr_1, big_real(y), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_set_z(sc->mpq_2, big_integer(y)); + mpq_add(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpfr_add_q(sc->mpfr_1, big_real(y), sc->mpq_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } case T_REAL: switch (type(y)) - { - case T_INTEGER: + { + case T_INTEGER: #if WITH_GMP - if (s7_int_abs(integer(y)) >= INT64_TO_DOUBLE_LIMIT) /* (+ .1 9223372036854775807) */ - { - mpfr_set_si(sc->mpfr_1, integer(y), MPFR_RNDN); - mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, real(x) + (long_double)integer(y))); - case T_RATIO: - return(make_real(sc, real(x) + fraction(y))); - case T_REAL: - return(make_real(sc, real(x) + real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, real(x) + real_part(y), imag_part(y))); + if (s7_int_abs(integer(y)) >= INT64_TO_DOUBLE_LIMIT) /* (+ .1 9223372036854775807) */ + { + mpfr_set_si(sc->mpfr_1, integer(y), MPFR_RNDN); + mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, real(x) + (long_double)integer(y))); + case T_RATIO: + return(make_real(sc, real(x) + fraction(y))); + case T_REAL: + return(make_real(sc, real(x) + real(y))); + case T_COMPLEX: + return(make_complex_not_0i(sc, real(x) + real_part(y), imag_part(y))); #if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_add_d(sc->mpfr_1, big_real(y), real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_add_d(sc->mpfr_1, big_real(y), real(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } case T_COMPLEX: switch (type(y)) - { - case T_INTEGER: - return(make_complex_not_0i(sc, real_part(x) + integer(y), imag_part(x))); - case T_RATIO: - return(make_complex_not_0i(sc, real_part(x) + fraction(y), imag_part(x))); - case T_REAL: - return(make_complex_not_0i(sc, real_part(x) + real(y), imag_part(x))); - case T_COMPLEX: - return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); + { + case T_INTEGER: + return(make_complex_not_0i(sc, real_part(x) + integer(y), imag_part(x))); + case T_RATIO: + return(make_complex_not_0i(sc, real_part(x) + fraction(y), imag_part(x))); + case T_REAL: + return(make_complex_not_0i(sc, real_part(x) + real(y), imag_part(x))); + case T_COMPLEX: + return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); #if WITH_GMP - case T_BIG_INTEGER: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } #if WITH_GMP case T_BIG_INTEGER: switch (type(y)) - { - case T_INTEGER: - mpz_set_si(sc->mpz_1, integer(y)); - mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_RATIO: - mpq_set_z(sc->mpq_2, big_integer(x)); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_add(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpz_add(sc->mpz_1, big_integer(x), big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_add_z(sc->mpfr_1, big_real(y), big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + mpz_set_si(sc->mpz_1, integer(y)); + mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1); + return(mpz_to_integer(sc, sc->mpz_1)); + case T_RATIO: + mpq_set_z(sc->mpq_2, big_integer(x)); + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_add(sc->mpq_1, sc->mpq_2, sc->mpq_1); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + mpfr_add_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpz_add(sc->mpz_1, big_integer(x), big_integer(y)); + return(mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + mpq_add(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_add_z(sc->mpfr_1, big_real(y), big_integer(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } case T_BIG_RATIO: switch (type(y)) - { - case T_INTEGER: - mpq_set_si(sc->mpq_1, integer(y), 1); - mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_add(sc->mpq_1, big_ratio(x), big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_add_q(sc->mpfr_1, big_real(y), big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + mpq_set_si(sc->mpq_1, integer(y), 1); + mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + mpfr_add_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpq_set_z(sc->mpq_1, big_integer(y)); + mpq_add(sc->mpq_1, big_ratio(x), sc->mpq_1); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_add(sc->mpq_1, big_ratio(x), big_ratio(y)); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_add_q(sc->mpfr_1, big_real(y), big_ratio(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_add(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } case T_BIG_REAL: switch (type(y)) - { - case T_INTEGER: - mpfr_add_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_add_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_add_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpfr_add_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_add_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_add(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_add_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + mpfr_add_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpfr_add_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_add_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_add_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpfr_add_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_add_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_add(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_add_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } case T_BIG_COMPLEX: switch (type(y)) - { - case T_INTEGER: - mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_REAL: - /* if (is_NaN(real(y))) return(y); */ - mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); - mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_add_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_add(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN); + mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_REAL: + /* if (is_NaN(real(y))) return(y); */ + mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); + mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); + mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); + mpc_add(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_add_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_add(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } #endif default: - return(method_or_bust_pp(sc, x, sc->add_symbol, x, y, a_number_string, 1)); + return(method_or_bust_pp(sc, x, sc->add_symbol, x, y, a_number_string, 1)); } } @@ -19627,8 +19627,8 @@ static s7_pointer add_p_ppp(s7_scheme *sc, s7_pointer p0, s7_pointer p1, s7_poin #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)); + (!add_overflow(val, integer(p2), &val))) + return(make_integer(sc, val)); #if WITH_GMP mpz_set_si(sc->mpz_1, integer(p0)); mpz_set_si(sc->mpz_2, integer(p1)); @@ -19668,7 +19668,7 @@ static s7_pointer g_add(s7_scheme *sc, s7_pointer args) if (is_null(p)) { if (!is_number(x)) - return(method_or_bust_p(sc, x, sc->add_symbol, a_number_string)); + return(method_or_bust_p(sc, x, sc->add_symbol, a_number_string)); return(x); } if (is_null(cdr(p))) @@ -19704,8 +19704,8 @@ static s7_pointer g_add_x1_1(s7_scheme *sc, s7_pointer x, int32_t pos) #endif default: return(method_or_bust(sc, x, sc->add_symbol, - (pos == 1) ? set_plist_2(sc, x, int_one) : set_plist_2(sc, int_one, x), - a_number_string, pos)); + (pos == 1) ? set_plist_2(sc, x, int_one) : set_plist_2(sc, int_one, x), + a_number_string, pos)); } return(x); } @@ -19796,11 +19796,11 @@ static s7_pointer add_2_if(s7_scheme *sc, s7_pointer x, s7_pointer y) if ((is_t_integer(x)) && (is_t_real(y))) { if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } + { + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + mpfr_add_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } return(make_real(sc, integer(x) + real(y))); } return(add_p_pp(sc, x, y)); @@ -19841,18 +19841,18 @@ static s7_pointer argument_type(s7_scheme *sc, s7_pointer arg1) if (is_pair(arg1)) { if (is_quote(car(arg1))) - return((is_pair(cdr(arg1))) ? s7_type_of(sc, cadr(arg1)) : NULL); /* arg1 = (quote) */ + return((is_pair(cdr(arg1))) ? s7_type_of(sc, cadr(arg1)) : NULL); /* arg1 = (quote) */ if ((is_h_optimized(arg1)) && - (is_safe_c_op(optimize_op(arg1))) && - (is_c_function(opt1_cfunc(arg1)))) - { - s7_pointer sig = c_function_signature(opt1_cfunc(arg1)); - if ((sig) && - (is_pair(sig)) && - (is_symbol(car(sig)))) - return(car(sig)); - } + (is_safe_c_op(optimize_op(arg1))) && + (is_c_function(opt1_cfunc(arg1)))) + { + s7_pointer sig = c_function_signature(opt1_cfunc(arg1)); + if ((sig) && + (is_pair(sig)) && + (is_symbol(car(sig)))) + return(car(sig)); + } /* perhaps add closure sig if we can depend on it (immutable func etc) */ } else @@ -19862,29 +19862,29 @@ static s7_pointer argument_type(s7_scheme *sc, s7_pointer arg1) } static s7_pointer chooser_check_arg_types(s7_scheme *sc, s7_pointer arg1, s7_pointer arg2, s7_pointer fallback, - s7_pointer f_2_ff, s7_pointer f_2_ii, s7_pointer f_2_if, s7_pointer f_2_fi, - s7_pointer f_2_xi, s7_pointer f_2_ix, s7_pointer f_2_fx, s7_pointer f_2_xf) + s7_pointer f_2_ff, s7_pointer f_2_ii, s7_pointer f_2_if, s7_pointer f_2_fi, + s7_pointer f_2_xi, s7_pointer f_2_ix, s7_pointer f_2_fx, s7_pointer f_2_xf) { const s7_pointer arg1_type = argument_type(sc, arg1); const s7_pointer arg2_type = argument_type(sc, arg2); if ((arg1_type) || (arg2_type)) { if (arg1_type == sc->is_float_symbol) - { - if (arg2_type == sc->is_float_symbol) - return(f_2_ff); - return((arg2_type == sc->is_integer_symbol) ? f_2_fi : f_2_fx); - } + { + if (arg2_type == sc->is_float_symbol) + return(f_2_ff); + return((arg2_type == sc->is_integer_symbol) ? f_2_fi : f_2_fx); + } if (arg1_type == sc->is_integer_symbol) - { - if (arg2_type == sc->is_float_symbol) - return(f_2_if); - return((arg2_type == sc->is_integer_symbol) ? f_2_ii : f_2_ix); - } + { + if (arg2_type == sc->is_float_symbol) + return(f_2_if); + return((arg2_type == sc->is_integer_symbol) ? f_2_ii : f_2_ix); + } if (arg2_type == sc->is_float_symbol) - return(f_2_xf); + return(f_2_xf); if (arg2_type == sc->is_integer_symbol) - return(f_2_xi); + return(f_2_xi); } return(fallback); } @@ -19898,18 +19898,18 @@ static s7_pointer add_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_poin { s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); if (arg2 == int_one) /* (+ ... 1) */ - return(sc->add_x1); + return(sc->add_x1); if ((is_t_integer(arg1)) && ((is_pair(arg2)) && (is_optimized(arg2)) && (is_h_safe_c_nc(arg2)) && (fn_proc(arg2) == g_random_i))) - { - set_opt3_int(cdr(expr), integer(cadr(arg2))); - set_safe_optimize_op(expr, HOP_SAFE_C_NC); /* op if r op? */ - return(sc->add_i_random); - } + { + set_opt3_int(cdr(expr), integer(cadr(arg2))); + set_safe_optimize_op(expr, HOP_SAFE_C_NC); /* op if r op? */ + return(sc->add_i_random); + } if (arg1 == int_one) - return(sc->add_1x); + return(sc->add_1x); return(chooser_check_arg_types(sc, arg1, arg2, sc->add_2, - sc->add_2_ff, sc->add_2_ii, sc->add_2_if, sc->add_2_fi, - sc->add_2_xi, sc->add_2_ix, sc->add_2_fx, sc->add_2_xf)); + sc->add_2_ff, sc->add_2_ii, sc->add_2_if, sc->add_2_fi, + sc->add_2_xi, sc->add_2_ix, sc->add_2_fx, sc->add_2_xf)); } return(sc->add_2); } @@ -19922,13 +19922,13 @@ static s7_pointer negate_p_p(s7_scheme *sc, s7_pointer p) /* can't use "nega case T_INTEGER: if (integer(p) == S7_INT64_MIN) #if WITH_GMP - { - mpz_set_si(sc->mpz_1, S7_INT64_MIN); - mpz_neg(sc->mpz_1, sc->mpz_1); - return(mpz_to_big_integer(sc, sc->mpz_1)); - } + { + mpz_set_si(sc->mpz_1, S7_INT64_MIN); + mpz_neg(sc->mpz_1, sc->mpz_1); + return(mpz_to_big_integer(sc, sc->mpz_1)); + } #else - sole_arg_out_of_range_error_nr(sc, sc->subtract_symbol, p, wrap_string(sc, "most-negative-fixnum can't be negated", 37)); + sole_arg_out_of_range_error_nr(sc, sc->subtract_symbol, p, wrap_string(sc, "most-negative-fixnum can't be negated", 37)); #endif return(make_integer(sc, -integer(p))); @@ -19985,414 +19985,414 @@ static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { case T_INTEGER: if (integer(x) == 0) - return(negate_p_p(sc, y)); + return(negate_p_p(sc, y)); switch (type(y)) - { - case T_INTEGER: - return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); + { + case T_INTEGER: + return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); - case T_RATIO: - { + case T_RATIO: + { #if HAVE_OVERFLOW_CHECKS - s7_int z; - if ((multiply_overflow(integer(x), denominator(y), &z)) || - (subtract_overflow(z, numerator(y), &z))) + s7_int z; + if ((multiply_overflow(integer(x), denominator(y), &z)) || + (subtract_overflow(z, numerator(y), &z))) #if WITH_GMP - { - mpz_set_si(sc->mpz_1, integer(x)); - mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(y)); - mpz_set_si(sc->mpz_2, numerator(y)); - mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_1, sc->mpz_2); - mpz_set_si(mpq_denref(sc->mpq_1), denominator(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - } + { + mpz_set_si(sc->mpz_1, integer(x)); + mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(y)); + mpz_set_si(sc->mpz_2, numerator(y)); + mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_1, sc->mpz_2); + mpz_set_si(mpq_denref(sc->mpq_1), denominator(y)); + return(mpq_to_rational(sc, sc->mpq_1)); + } #else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer - ratio overflow: (- %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); - return(make_real(sc, (long_double)integer(x) - fraction(y))); - } + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer - ratio overflow: (- %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); + return(make_real(sc, (long_double)integer(x) - fraction(y))); + } #endif - return(make_ratio(sc, z, denominator(y))); + return(make_ratio(sc, z, denominator(y))); #else - return(make_ratio(sc, integer(x) * denominator(y) - numerator(y), denominator(y))); + return(make_ratio(sc, integer(x) * denominator(y) - numerator(y), denominator(y))); #endif - } - case T_REAL: + } + case T_REAL: #if WITH_GMP - if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) /* (- 9223372036854775807 .1) */ - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, (long_double)integer(x) - real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, (long_double)integer(x) - real_part(y), -imag_part(y))); + if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) /* (- 9223372036854775807 .1) */ + { + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, (long_double)integer(x) - real(y))); + case T_COMPLEX: + return(make_complex_not_0i(sc, (long_double)integer(x) - real_part(y), -imag_part(y))); #if WITH_GMP - case T_BIG_INTEGER: - mpz_set_si(sc->mpz_1, integer(x)); - mpz_sub(sc->mpz_1, sc->mpz_1, big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_si_sub(sc->mpfr_1, integer(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + mpz_set_si(sc->mpz_1, integer(x)); + mpz_sub(sc->mpz_1, sc->mpz_1, big_integer(y)); + return(mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, integer(x), 1); + mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_si_sub(sc->mpfr_1, integer(x), big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } case T_RATIO: switch (type(y)) - { - case T_INTEGER: - { + { + case T_INTEGER: + { #if HAVE_OVERFLOW_CHECKS - s7_int z; - if ((multiply_overflow(integer(y), denominator(x), &z)) || - (subtract_overflow(numerator(x), z, &z))) + s7_int z; + if ((multiply_overflow(integer(y), denominator(x), &z)) || + (subtract_overflow(numerator(x), z, &z))) #if WITH_GMP - { - mpz_set_si(sc->mpz_1, integer(y)); - mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(x)); - mpz_set_si(sc->mpz_2, numerator(x)); - mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1); - mpz_set_si(mpq_denref(sc->mpq_1), denominator(x)); - return(mpq_to_rational(sc, sc->mpq_1)); - } + { + mpz_set_si(sc->mpz_1, integer(y)); + mpz_mul_si(sc->mpz_1, sc->mpz_1, denominator(x)); + mpz_set_si(sc->mpz_2, numerator(x)); + mpz_sub(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1); + mpz_set_si(mpq_denref(sc->mpq_1), denominator(x)); + return(mpq_to_rational(sc, sc->mpq_1)); + } #else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - integer overflow: (- %" ld64 "/%" ld64 " %" ld64 ")\n", numerator(x), denominator(x), integer(y)); - return(make_real(sc, fraction(x) - (long_double)integer(y))); - } + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - integer overflow: (- %" ld64 "/%" ld64 " %" ld64 ")\n", numerator(x), denominator(x), integer(y)); + return(make_real(sc, fraction(x) - (long_double)integer(y))); + } #endif - return(make_ratio(sc, z, denominator(x))); + return(make_ratio(sc, z, denominator(x))); #else - return(make_ratio(sc, numerator(x) - (integer(y) * denominator(x)), denominator(x))); -#endif - } - case T_RATIO: - { - s7_int d1, d2, n1, n2; - parcel_out_fractions(x, y); - if (d1 == d2) - { + return(make_ratio(sc, numerator(x) - (integer(y) * denominator(x)), denominator(x))); +#endif + } + case T_RATIO: + { + s7_int d1, d2, n1, n2; + parcel_out_fractions(x, y); + if (d1 == d2) + { #if HAVE_OVERFLOW_CHECKS - s7_int q; - if (subtract_overflow(n1, n2, &q)) + s7_int q; + if (subtract_overflow(n1, n2, &q)) #if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } + { + mpq_set_si(sc->mpq_1, n1, d1); + mpq_set_si(sc->mpq_2, n2, d2); + mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return(mpq_to_rational(sc, sc->mpq_1)); + } #else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - ratio overflow: (- %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); - return(make_real(sc, ((long_double)n1 - (long_double)n2) / (long_double)d1)); - } + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - ratio overflow: (- %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); + return(make_real(sc, ((long_double)n1 - (long_double)n2) / (long_double)d1)); + } #endif - return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1)); + return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1)); #else - return(make_ratio(sc, numerator(x) - numerator(y), denominator(x))); + return(make_ratio(sc, numerator(x) - numerator(y), denominator(x))); #endif - } + } #if HAVE_OVERFLOW_CHECKS - { - s7_int n1d2, n2d1, d1d2, q; - if ((multiply_overflow(d1, d2, &d1d2)) || - (multiply_overflow(n1, d2, &n1d2)) || - (multiply_overflow(n2, d1, &n2d1)) || - (subtract_overflow(n1d2, n2d1, &q))) + { + s7_int n1d2, n2d1, d1d2, q; + if ((multiply_overflow(d1, d2, &d1d2)) || + (multiply_overflow(n1, d2, &n1d2)) || + (multiply_overflow(n2, d1, &n2d1)) || + (subtract_overflow(n1d2, n2d1, &q))) #if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } + { + mpq_set_si(sc->mpq_1, n1, d1); + mpq_set_si(sc->mpq_2, n2, d2); + mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return(mpq_to_rational(sc, sc->mpq_1)); + } #else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - ratio overflow: (- %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); - return(make_real(sc, ((long_double)n1 / (long_double)d1) - ((long_double)n2 / (long_double)d2))); - } + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio - ratio overflow: (- %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); + return(make_real(sc, ((long_double)n1 / (long_double)d1) - ((long_double)n2 / (long_double)d2))); + } #endif - return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1d2)); - } + return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1d2)); + } #else - return(make_ratio_with_div_check(sc, sc->subtract_symbol, n1 * d2 - n2 * d1, d1 * d2)); + return(make_ratio_with_div_check(sc, sc->subtract_symbol, n1 * d2 - n2 * d1, d1 * d2)); #endif - } - case T_REAL: - return(make_real(sc, fraction(x) - real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, fraction(x) - real_part(y), -imag_part(y))); + } + case T_REAL: + return(make_real(sc, fraction(x) - real(y))); + case T_COMPLEX: + return(make_complex_not_0i(sc, fraction(x) - real_part(y), -imag_part(y))); #if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_set_z(sc->mpq_2, big_integer(y)); - mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_set_z(sc->mpq_2, big_integer(y)); + mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); + mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } case T_REAL: switch (type(y)) - { - case T_INTEGER: + { + case T_INTEGER: #if WITH_GMP - if (s7_int_abs(integer(y)) >= INT64_TO_DOUBLE_LIMIT) /* (- .1 92233720368547758071) */ - { - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_sub_si(sc->mpfr_1, sc->mpfr_1, integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, real(x) - (long_double)integer(y))); /* long_double saves (- 9007199254740996.0 9007199254740995): 1.0 */ - case T_RATIO: - return(make_real(sc, real(x) - fraction(y))); - case T_REAL: - return(make_real(sc, real(x) - real(y))); - case T_COMPLEX: - return(make_complex_not_0i(sc, real(x) - real_part(y), -imag_part(y))); + if (s7_int_abs(integer(y)) >= INT64_TO_DOUBLE_LIMIT) /* (- .1 92233720368547758071) */ + { + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_sub_si(sc->mpfr_1, sc->mpfr_1, integer(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, real(x) - (long_double)integer(y))); /* long_double saves (- 9007199254740996.0 9007199254740995): 1.0 */ + case T_RATIO: + return(make_real(sc, real(x) - fraction(y))); + case T_REAL: + return(make_real(sc, real(x) - real(y))); + case T_COMPLEX: + return(make_complex_not_0i(sc, real(x) - real_part(y), -imag_part(y))); #if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_sub_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_sub_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_d_sub(sc->mpfr_1, real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_sub_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_sub_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_d_sub(sc->mpfr_1, real(x), big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } case T_COMPLEX: switch (type(y)) - { - case T_INTEGER: - return(make_complex_not_0i(sc, real_part(x) - integer(y), imag_part(x))); - case T_RATIO: - return(make_complex_not_0i(sc, real_part(x) - fraction(y), imag_part(x))); - case T_REAL: - return(make_complex_not_0i(sc, real_part(x) - real(y), imag_part(x))); - case T_COMPLEX: - return(make_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y))); + { + case T_INTEGER: + return(make_complex_not_0i(sc, real_part(x) - integer(y), imag_part(x))); + case T_RATIO: + return(make_complex_not_0i(sc, real_part(x) - fraction(y), imag_part(x))); + case T_REAL: + return(make_complex_not_0i(sc, real_part(x) - real(y), imag_part(x))); + case T_COMPLEX: + return(make_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y))); #if WITH_GMP - case T_BIG_INTEGER: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_sub_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_sub_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } #if WITH_GMP case T_BIG_INTEGER: switch (type(y)) - { - case T_INTEGER: - mpz_set_si(sc->mpz_1, integer(y)); - mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_RATIO: - mpq_set_z(sc->mpq_2, big_integer(x)); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_sub(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpz_sub(sc->mpz_1, big_integer(x), big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + mpz_set_si(sc->mpz_1, integer(y)); + mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1); + return(mpz_to_integer(sc, sc->mpz_1)); + case T_RATIO: + mpq_set_z(sc->mpq_2, big_integer(x)); + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_sub(sc->mpq_1, sc->mpq_2, sc->mpq_1); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpz_sub(sc->mpz_1, big_integer(x), big_integer(y)); + return(mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + mpq_sub(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } case T_BIG_RATIO: switch (type(y)) - { - case T_INTEGER: - mpq_set_si(sc->mpq_1, integer(y), 1); - mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_sub(sc->mpq_1, big_ratio(x), big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + mpq_set_si(sc->mpq_1, integer(y), 1); + mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_sub_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpq_set_z(sc->mpq_1, big_integer(y)); + mpq_sub(sc->mpq_1, big_ratio(x), sc->mpq_1); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_sub(sc->mpq_1, big_ratio(x), big_ratio(y)); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_sub(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_sub(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } case T_BIG_REAL: switch (type(y)) - { - case T_INTEGER: - mpfr_sub_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_sub_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_sub_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_fr_sub(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpfr_sub_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_sub_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_sub(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_fr_sub(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + mpfr_sub_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpfr_sub_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_sub_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_fr_sub(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpfr_sub_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_sub_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_sub(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_fr_sub(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } case T_BIG_COMPLEX: switch (type(y)) - { - case T_INTEGER: - mpc_set_si(sc->mpc_2, integer(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_REAL: - /* if (is_NaN(real(y))) return(y); */ - mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); - mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_sub_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_sub(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + mpc_set_si(sc->mpc_2, integer(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_REAL: + /* if (is_NaN(real(y))) return(y); */ + mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); + mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); + mpc_sub(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_sub_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_sub(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } #endif default: - return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, y, a_number_string, 1)); + return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, y, a_number_string, 1)); } } @@ -20603,353 +20603,353 @@ static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { case T_INTEGER: switch (type(y)) - { - case T_INTEGER: - return(multiply_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); - case T_RATIO: - return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, integer(x), y)); - case T_REAL: + { + case T_INTEGER: + return(multiply_if_overflow_to_real_or_big_integer(sc, integer(x), integer(y))); + case T_RATIO: + return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, integer(x), y)); + case T_REAL: #if WITH_GMP - if (s7_int_abs(integer(x)) > QUOTIENT_INT_LIMIT) - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); - mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, (long_double)integer(x) * real(y))); - case T_COMPLEX: - return(make_complex(sc, (long_double)integer(x) * real_part(y), (long_double)integer(x) * imag_part(y))); + if (s7_int_abs(integer(x)) > QUOTIENT_INT_LIMIT) + { + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); + mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, (long_double)integer(x) * real(y))); + case T_COMPLEX: + return(make_complex(sc, (long_double)integer(x) * real_part(y), (long_double)integer(x) * imag_part(y))); #if WITH_GMP - case T_BIG_INTEGER: - mpz_mul_si(sc->mpz_1, big_integer(y), integer(x)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_mul_si(sc->mpfr_1, big_real(y), integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_mul_si(sc->mpc_1, big_complex(y), integer(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0 */ -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + mpz_mul_si(sc->mpz_1, big_integer(y), integer(x)); + return(mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, integer(x), 1); + mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_mul_si(sc->mpfr_1, big_real(y), integer(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_mul_si(sc->mpc_1, big_complex(y), integer(x), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0 */ +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } case T_RATIO: switch (type(y)) - { - case T_INTEGER: - return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, integer(y), x)); - case T_RATIO: - { - s7_int d1, d2, n1, n2; - parcel_out_fractions(x, y); + { + case T_INTEGER: + return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, integer(y), x)); + case T_RATIO: + { + s7_int d1, d2, n1, n2; + parcel_out_fractions(x, y); #if HAVE_OVERFLOW_CHECKS - { - s7_int n1n2, d1d2; - if ((multiply_overflow(d1, d2, &d1d2)) || - (multiply_overflow(n1, n2, &n1n2))) + { + s7_int n1n2, d1d2; + if ((multiply_overflow(d1, d2, &d1d2)) || + (multiply_overflow(n1, n2, &n1n2))) #if WITH_GMP - { - mpq_set_si(sc->mpq_1, n1, d1); - mpq_set_si(sc->mpq_2, n2, d2); - mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - } + { + mpq_set_si(sc->mpq_1, n1, d1); + mpq_set_si(sc->mpq_2, n2, d2); + mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + } #else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio * ratio overflow: (* %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); - return(make_real(sc, fraction(x) * fraction(y))); - } + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio * ratio overflow: (* %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", n1, d1, n2, d2); + return(make_real(sc, fraction(x) * fraction(y))); + } #endif - return(make_ratio_with_div_check(sc, sc->multiply_symbol, n1n2, d1d2)); - } + return(make_ratio_with_div_check(sc, sc->multiply_symbol, n1n2, d1d2)); + } #else - return(make_ratio_with_div_check(sc, sc->multiply_symbol, n1 * n2, d1 * d2)); + return(make_ratio_with_div_check(sc, sc->multiply_symbol, n1 * n2, d1 * d2)); #endif - } - case T_REAL: + } + case T_REAL: #if WITH_GMP - if (numerator(x) > QUOTIENT_INT_LIMIT) - { - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, fraction(x) * real(y))); - case T_COMPLEX: - return(make_complex(sc, fraction(x) * real_part(y), fraction(x) * imag_part(y))); + if (numerator(x) > QUOTIENT_INT_LIMIT) + { + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); + mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, fraction(x) * real(y))); + case T_COMPLEX: + return(make_complex(sc, fraction(x) * real_part(y), fraction(x) * imag_part(y))); #if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_set_z(sc->mpq_2, big_integer(y)); - mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_mul_q(sc->mpfr_1, big_real(y), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_set_z(sc->mpq_2, big_integer(y)); + mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpfr_mul_q(sc->mpfr_1, big_real(y), sc->mpq_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } case T_REAL: switch (type(y)) - { - case T_INTEGER: + { + case T_INTEGER: #if WITH_GMP - if (s7_int_abs(integer(y)) > QUOTIENT_INT_LIMIT) - { - mpfr_set_si(sc->mpfr_1, integer(y), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real(x), MPFR_RNDN); - mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, real(x) * (long_double)integer(y))); - case T_RATIO: + if (s7_int_abs(integer(y)) > QUOTIENT_INT_LIMIT) + { + mpfr_set_si(sc->mpfr_1, integer(y), MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, real(x), MPFR_RNDN); + mpfr_mul(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, real(x) * (long_double)integer(y))); + case T_RATIO: #if WITH_GMP - if (numerator(y) > QUOTIENT_INT_LIMIT) - { - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, fraction(y) * real(x))); - case T_REAL: - return(make_real(sc, real(x) * real(y))); - case T_COMPLEX: - return(make_complex(sc, real(x) * real_part(y), real(x) * imag_part(y))); + if (numerator(y) > QUOTIENT_INT_LIMIT) + { + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); + mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, fraction(y) * real(x))); + case T_REAL: + return(make_real(sc, real(x) * real(y))); + case T_COMPLEX: + return(make_complex(sc, real(x) * real_part(y), real(x) * imag_part(y))); #if WITH_GMP - case T_BIG_INTEGER: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_mul_d(sc->mpfr_1, big_real(y), real(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* x might = 0.0 */ -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_mul_d(sc->mpfr_1, big_real(y), real(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); /* x might = 0.0 */ +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } case T_COMPLEX: switch (type(y)) - { - case T_INTEGER: - return(make_complex(sc, real_part(x) * integer(y), imag_part(x) * integer(y))); - case T_RATIO: - return(make_complex(sc, real_part(x) * fraction(y), imag_part(x) * fraction(y))); - case T_REAL: - return(make_complex(sc, real_part(x) * real(y), imag_part(x) * real(y))); - case T_COMPLEX: - { - s7_double r1 = real_part(x), r2 = real_part(y), i1 = imag_part(x), i2 = imag_part(y); - return(make_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1)); - } + { + case T_INTEGER: + return(make_complex(sc, real_part(x) * integer(y), imag_part(x) * integer(y))); + case T_RATIO: + return(make_complex(sc, real_part(x) * fraction(y), imag_part(x) * fraction(y))); + case T_REAL: + return(make_complex(sc, real_part(x) * real(y), imag_part(x) * real(y))); + case T_COMPLEX: + { + s7_double r1 = real_part(x), r2 = real_part(y), i1 = imag_part(x), i2 = imag_part(y); + return(make_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1)); + } #if WITH_GMP - case T_BIG_INTEGER: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } #if WITH_GMP case T_BIG_INTEGER: switch (type(y)) - { - case T_INTEGER: - mpz_mul_si(sc->mpz_1, big_integer(x), integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_RATIO: - mpq_set_z(sc->mpq_2, big_integer(x)); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_mul(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpz_mul(sc->mpz_1, big_integer(x), big_integer(y)); - return(mpz_to_integer(sc, sc->mpz_1)); - case T_BIG_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_mul_z(sc->mpfr_1, big_real(y), big_integer(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + mpz_mul_si(sc->mpz_1, big_integer(x), integer(y)); + return(mpz_to_integer(sc, sc->mpz_1)); + case T_RATIO: + mpq_set_z(sc->mpq_2, big_integer(x)); + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_mul(sc->mpq_1, sc->mpq_2, sc->mpq_1); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + mpfr_mul_z(sc->mpfr_1, sc->mpfr_1, big_integer(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpz_mul(sc->mpz_1, big_integer(x), big_integer(y)); + return(mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + mpq_mul(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_mul_z(sc->mpfr_1, big_real(y), big_integer(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } case T_BIG_RATIO: switch (type(y)) - { - case T_INTEGER: - mpq_set_si(sc->mpq_1, integer(y), 1); - mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_mul(sc->mpq_1, big_ratio(x), big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - mpfr_mul_q(sc->mpfr_1, big_real(y), big_ratio(x), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + mpq_set_si(sc->mpq_1, integer(y), 1); + mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpq_set_z(sc->mpq_1, big_integer(y)); + mpq_mul(sc->mpq_1, big_ratio(x), sc->mpq_1); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_mul(sc->mpq_1, big_ratio(x), big_ratio(y)); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_mul_q(sc->mpfr_1, big_real(y), big_ratio(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_mul(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } case T_BIG_REAL: switch (type(y)) - { - case T_INTEGER: - mpfr_mul_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_mul_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_mul_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpfr_mul_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_mul_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - mpfr_mul(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - mpc_mul_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* 0.0? */ - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + mpfr_mul_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpfr_mul_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_mul_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_mul_fr(sc->mpc_1, sc->mpc_1, big_real(x), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpfr_mul_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_mul_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + mpfr_mul(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_mul_fr(sc->mpc_1, big_complex(y), big_real(x), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); /* 0.0? */ + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } case T_BIG_COMPLEX: switch (type(y)) - { - case T_INTEGER: - mpc_mul_si(sc->mpc_1, big_complex(x), integer(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_REAL: - /* if (is_NaN(real(y))) return(y); */ - mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_COMPLEX: - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); - mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - mpc_mul_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - mpc_mul(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + mpc_mul_si(sc->mpc_1, big_complex(x), integer(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_REAL: + /* if (is_NaN(real(y))) return(y); */ + mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); + mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_COMPLEX: + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); + mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); + mpc_mul(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + mpc_mul_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + mpc_mul(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } #endif default: - return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, y, a_number_string, 1)); + return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, y, a_number_string, 1)); } } @@ -20987,7 +20987,7 @@ static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args) if (is_null(p)) { if (!is_number(x)) - return(multiply_method_or_bust(sc, x, args, a_number_string, 0)); + return(multiply_method_or_bust(sc, x, args, a_number_string, 0)); return(x); } for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++) @@ -21151,8 +21151,8 @@ static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7 { if (args != 2) return(f); return(chooser_check_arg_types(sc, cadr(expr), caddr(expr), sc->multiply_2, - sc->mul_2_ff, sc->mul_2_ii, sc->mul_2_if, sc->mul_2_fi, - sc->mul_2_xi, sc->mul_2_ix, sc->mul_2_fx, sc->mul_2_xf)); + sc->mul_2_ff, sc->mul_2_ii, sc->mul_2_if, sc->mul_2_fi, + sc->mul_2_xi, sc->mul_2_ix, sc->mul_2_fx, sc->mul_2_xf)); } @@ -21175,26 +21175,26 @@ static s7_pointer invert_p_p(s7_scheme *sc, s7_pointer p) case T_INTEGER: #if WITH_GMP && (!POINTER_32) if (integer(p) == S7_INT64_MIN) /* (/ 1 (*s7* 'most-negative-fixnum)) -> -1/9223372036854775808 */ - { - new_cell(sc, x, T_BIG_RATIO); - big_ratio_bgr(x) = alloc_bigrat(sc); - add_big_ratio(sc, x); - mpz_set_si(sc->mpz_1, S7_INT64_MAX); - mpz_set_si(sc->mpz_2, 1); - mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); - mpq_set_si(big_ratio(x), -1, 1); - mpq_set_den(big_ratio(x), sc->mpz_1); /* geez... */ - return(x); - } + { + new_cell(sc, x, T_BIG_RATIO); + big_ratio_bgr(x) = alloc_bigrat(sc); + add_big_ratio(sc, x); + mpz_set_si(sc->mpz_1, S7_INT64_MAX); + mpz_set_si(sc->mpz_2, 1); + mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); + mpq_set_si(big_ratio(x), -1, 1); + mpq_set_den(big_ratio(x), sc->mpz_1); /* geez... */ + return(x); + } #endif if (integer(p) == 0) - division_by_zero_error_1_nr(sc, sc->divide_symbol, p); + division_by_zero_error_1_nr(sc, sc->divide_symbol, p); return(make_simple_ratio(sc, 1, integer(p))); /* this checks for int */ case T_RATIO: return(make_simple_ratio(sc, denominator(p), numerator(p))); case T_REAL: if (real(p) == 0.0) - division_by_zero_error_1_nr(sc, sc->divide_symbol, p); + division_by_zero_error_1_nr(sc, sc->divide_symbol, p); return(make_real(sc, 1.0 / real(p))); case T_COMPLEX: return(complex_invert(sc, p)); @@ -21202,9 +21202,9 @@ static s7_pointer invert_p_p(s7_scheme *sc, s7_pointer p) #if WITH_GMP case T_BIG_INTEGER: if (mpz_cmp_ui(big_integer(p), 0) == 0) - division_by_zero_error_1_nr(sc, sc->divide_symbol, p); + division_by_zero_error_1_nr(sc, sc->divide_symbol, p); if ((mpz_cmp_ui(big_integer(p), 1) == 0) || (mpz_cmp_si(big_integer(p), -1) == 0)) - return(p); + return(p); new_cell(sc, x, T_BIG_RATIO); big_ratio_bgr(x) = alloc_bigrat(sc); add_big_ratio(sc, x); @@ -21215,12 +21215,12 @@ static s7_pointer invert_p_p(s7_scheme *sc, s7_pointer p) case T_BIG_RATIO: if (mpz_cmp_ui(mpq_numref(big_ratio(p)), 1) == 0) - return(mpz_to_integer(sc, mpq_denref(big_ratio(p)))); + return(mpz_to_integer(sc, mpq_denref(big_ratio(p)))); if (mpz_cmp_si(mpq_numref(big_ratio(p)), -1) == 0) - { - mpz_neg(sc->mpz_1, mpq_denref(big_ratio(p))); - return(mpz_to_integer(sc, sc->mpz_1)); - } + { + mpz_neg(sc->mpz_1, mpq_denref(big_ratio(p))); + return(mpz_to_integer(sc, sc->mpz_1)); + } new_cell(sc, x, T_BIG_RATIO); big_ratio_bgr(x) = alloc_bigrat(sc); add_big_ratio(sc, x); @@ -21230,14 +21230,14 @@ static s7_pointer invert_p_p(s7_scheme *sc, s7_pointer p) case T_BIG_REAL: if (mpfr_zero_p(big_real(p))) - division_by_zero_error_1_nr(sc, sc->divide_symbol, p); + division_by_zero_error_1_nr(sc, sc->divide_symbol, p); x = mpfr_to_big_real(sc, big_real(p)); mpfr_ui_div(big_real(x), 1, big_real(x), MPFR_RNDN); return(x); case T_BIG_COMPLEX: if ((!mpfr_number_p(mpc_realref(big_complex(p)))) || (!mpfr_number_p(mpc_imagref(big_complex(p))))) - return(complex_NaN); + return(complex_NaN); mpc_ui_div(sc->mpc_1, 1, big_complex(p), MPC_RNDNN); return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0+0i if real-part is inf? */ #endif @@ -21255,540 +21255,540 @@ static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { case T_INTEGER: switch (type(y)) - { - /* -------- integer x -------- */ - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - if (integer(x) == 1) /* mainly to handle (/ 1 -9223372036854775808) correctly! */ - return(invert_p_p(sc, y)); - return(make_ratio(sc, integer(x), integer(y))); - - case T_RATIO: + { + /* -------- integer x -------- */ + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + if (integer(x) == 1) /* mainly to handle (/ 1 -9223372036854775808) correctly! */ + return(invert_p_p(sc, y)); + return(make_ratio(sc, integer(x), integer(y))); + + case T_RATIO: #if HAVE_OVERFLOW_CHECKS - { - s7_int dn; - if (multiply_overflow(integer(x), denominator(y), &dn)) + { + s7_int dn; + if (multiply_overflow(integer(x), denominator(y), &dn)) #if WITH_GMP - { - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_set_si(sc->mpq_2, numerator(y), denominator(y)); - mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - } + { + mpq_set_si(sc->mpq_1, integer(x), 1); + mpq_set_si(sc->mpq_2, numerator(y), denominator(y)); + mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + } #else { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer / ratio overflow: (/ %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); - return(make_real(sc, integer(x) * inverted_fraction(y))); - } + if (WITH_WARNINGS) s7_warn(sc, 128, "integer / ratio overflow: (/ %" ld64 " %" ld64 "/%" ld64 ")\n", integer(x), numerator(y), denominator(y)); + return(make_real(sc, integer(x) * inverted_fraction(y))); + } #endif - return(make_ratio_with_div_check(sc, sc->divide_symbol, dn, numerator(y))); - } + return(make_ratio_with_div_check(sc, sc->divide_symbol, dn, numerator(y))); + } #else - return(make_ratio_with_div_check(sc, sc->divide_symbol, integer(x) * denominator(y), numerator(y))); + return(make_ratio_with_div_check(sc, sc->divide_symbol, integer(x) * denominator(y), numerator(y))); #endif - case T_REAL: - if (is_NaN(real(y))) return(y); - if (is_inf(real(y))) return(real_zero); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + case T_REAL: + if (is_NaN(real(y))) return(y); + if (is_inf(real(y))) return(real_zero); + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); #if WITH_GMP - if ((s7_int_abs(integer(x))) > QUOTIENT_INT_LIMIT) - { - mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); - mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } -#endif - return(make_real(sc, (s7_double)(integer(x)) / real(y))); - - case T_COMPLEX: - { - s7_double den, r1 = (s7_double)integer(x), r2 = real_part(y), i2 = imag_part(y); - den = 1.0 / (r2 * r2 + i2 * i2); - /* we could avoid the squaring (see Knuth II p613 16), not a big deal: (/ 1.0e308+1.0e308i 2.0e308+2.0e308i) => nan, (gmp case is ok here) */ - return(make_complex(sc, r1 * r2 * den, -(r1 * i2 * den))); - } + if ((s7_int_abs(integer(x))) > QUOTIENT_INT_LIMIT) + { + mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN); + mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); + mpfr_div(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } +#endif + return(make_real(sc, (s7_double)(integer(x)) / real(y))); + + case T_COMPLEX: + { + s7_double den, r1 = (s7_double)integer(x), r2 = real_part(y), i2 = imag_part(y); + den = 1.0 / (r2 * r2 + i2 * i2); + /* we could avoid the squaring (see Knuth II p613 16), not a big deal: (/ 1.0e308+1.0e308i 2.0e308+2.0e308i) => nan, (gmp case is ok here) */ + return(make_complex(sc, r1 * r2 * den, -(r1 * i2 * den))); + } #if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_set_den(sc->mpq_1, big_integer(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, integer(x), 1); - mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_si_div(sc->mpfr_1, integer(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0? */ -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpq_set_si(sc->mpq_1, integer(x), 1); + mpq_set_den(sc->mpq_1, big_integer(y)); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, integer(x), 1); + mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpfr_si_div(sc->mpfr_1, integer(x), big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return(complex_NaN); + mpc_set_si(sc->mpc_1, integer(x), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); /* x might be 0? */ +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } break; /* -------- ratio x -------- */ case T_RATIO: switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + { + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); #if HAVE_OVERFLOW_CHECKS - { - s7_int dn; - if (multiply_overflow(denominator(x), integer(y), &dn)) + { + s7_int dn; + if (multiply_overflow(denominator(x), integer(y), &dn)) #if WITH_GMP - { - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_set_si(sc->mpq_2, integer(y), 1); - mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } + { + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_set_si(sc->mpq_2, integer(y), 1); + mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return(mpq_to_rational(sc, sc->mpq_1)); + } #else { - if (WITH_WARNINGS) - s7_warn(sc, 128, "ratio / integer overflow: (/ %" ld64 "/%" ld64 " %" ld64 ")\n", numerator(x), denominator(x), integer(y)); - return(make_real(sc, (long_double)numerator(x) / ((long_double)denominator(x) * (long_double)integer(y)))); - } + if (WITH_WARNINGS) + s7_warn(sc, 128, "ratio / integer overflow: (/ %" ld64 "/%" ld64 " %" ld64 ")\n", numerator(x), denominator(x), integer(y)); + return(make_real(sc, (long_double)numerator(x) / ((long_double)denominator(x) * (long_double)integer(y)))); + } #endif - return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(x), dn)); - } + return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(x), dn)); + } #else - return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(x), denominator(x) * integer(y))); + return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(x), denominator(x) * integer(y))); #endif - case T_RATIO: - { - s7_int d1, d2, n1, n2; - parcel_out_fractions(x, y); - if (d1 == d2) - return(make_ratio_with_div_check(sc, sc->divide_symbol, n1, n2)); + case T_RATIO: + { + s7_int d1, d2, n1, n2; + parcel_out_fractions(x, y); + if (d1 == d2) + return(make_ratio_with_div_check(sc, sc->divide_symbol, n1, n2)); #if HAVE_OVERFLOW_CHECKS - if ((multiply_overflow(n1, d2, &n1)) || - (multiply_overflow(n2, d1, &d1))) - { + if ((multiply_overflow(n1, d2, &n1)) || + (multiply_overflow(n2, d1, &d1))) + { #if WITH_GMP - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); /* not n1 and d1! they are garbage here */ - mpq_set_si(sc->mpq_2, n2, d2); - mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); /* not n1 and d1! they are garbage here */ + mpq_set_si(sc->mpq_2, n2, d2); + mpq_div(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return(mpq_to_rational(sc, sc->mpq_1)); #else - s7_double r1, r2; - if (WITH_WARNINGS) - s7_warn(sc, 128, "ratio / ratio overflow: (/ %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", numerator(x), denominator(x), numerator(y), denominator(y)); - r1 = fraction(x); - r2 = inverted_fraction(y); - return(make_real(sc, r1 * r2)); -#endif - } - return(make_ratio_with_div_check(sc, sc->divide_symbol, n1, d1)); + s7_double r1, r2; + if (WITH_WARNINGS) + s7_warn(sc, 128, "ratio / ratio overflow: (/ %" ld64 "/%" ld64 " %" ld64 "/%" ld64 ")\n", numerator(x), denominator(x), numerator(y), denominator(y)); + r1 = fraction(x); + r2 = inverted_fraction(y); + return(make_real(sc, r1 * r2)); +#endif + } + return(make_ratio_with_div_check(sc, sc->divide_symbol, n1, d1)); #else - return(make_ratio_with_div_check(sc, sc->divide_symbol, n1 * d2, n2 * d1)); + return(make_ratio_with_div_check(sc, sc->divide_symbol, n1 * d2, n2 * d1)); #endif - } + } - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - return(make_real(sc, fraction(x) / real(y))); + case T_REAL: + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + return(make_real(sc, fraction(x) / real(y))); - case T_COMPLEX: - { - s7_double rx = fraction(x), r2 = real_part(y), i2 = imag_part(y); - s7_double den = 1.0 / (r2 * r2 + i2 * i2); - return(make_complex(sc, rx * r2 * den, -rx * i2 * den)); /* not unchecked: (/ 3/4 -inf.0+i) */ - } + case T_COMPLEX: + { + s7_double rx = fraction(x), r2 = real_part(y), i2 = imag_part(y); + s7_double den = 1.0 / (r2 * r2 + i2 * i2); + return(make_complex(sc, rx * r2 * den, -rx * i2 * den)); /* not unchecked: (/ 3/4 -inf.0+i) */ + } #if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_set_si(sc->mpq_2, numerator(x), denominator(x)); - mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpq_set_z(sc->mpq_1, big_integer(y)); + mpq_set_si(sc->mpq_2, numerator(x), denominator(x)); + mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN); + mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return(complex_NaN); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } /* -------- real x -------- */ case T_REAL: switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - if (is_NaN(real(x))) return(x); /* 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, (long_double)real(x) / (long_double)integer(y))); - - case T_RATIO: - if (is_NaN(real(x))) return(x); - if (is_inf(real(x))) - return((real(x) > 0) ? ((numerator(y) > 0) ? real_infinity : real_minus_infinity) : ((numerator(y) > 0) ? real_minus_infinity : real_infinity)); - return(make_real(sc, real(x) * inverted_fraction(y))); - - case T_REAL: - if (is_NaN(real(y))) return(y); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - if (is_NaN(real(x))) return(x); - if (is_inf(real(y))) - return((is_inf(real(x))) ? real_NaN : real_zero); - return(make_real(sc, real(x) / real(y))); - - case T_COMPLEX: - { - s7_double den, r2, i2; - if (is_NaN(real(x))) return(complex_NaN); - r2 = real_part(y); - i2 = imag_part(y); - if ((is_NaN(r2)) || (is_inf(r2))) return(complex_NaN); - if ((is_NaN(i2)) || (is_inf(i2))) return(complex_NaN); - den = 1.0 / (r2 * r2 + i2 * i2); - return(make_complex(sc, real(x) * r2 * den, -real(x) * i2 * den)); - } + { + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + if (is_NaN(real(x))) return(x); /* 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, (long_double)real(x) / (long_double)integer(y))); + + case T_RATIO: + if (is_NaN(real(x))) return(x); + if (is_inf(real(x))) + return((real(x) > 0) ? ((numerator(y) > 0) ? real_infinity : real_minus_infinity) : ((numerator(y) > 0) ? real_minus_infinity : real_infinity)); + return(make_real(sc, real(x) * inverted_fraction(y))); + + case T_REAL: + if (is_NaN(real(y))) return(y); + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + if (is_NaN(real(x))) return(x); + if (is_inf(real(y))) + return((is_inf(real(x))) ? real_NaN : real_zero); + return(make_real(sc, real(x) / real(y))); + + case T_COMPLEX: + { + s7_double den, r2, i2; + if (is_NaN(real(x))) return(complex_NaN); + r2 = real_part(y); + i2 = imag_part(y); + if ((is_NaN(r2)) || (is_inf(r2))) return(complex_NaN); + if ((is_NaN(i2)) || (is_inf(i2))) return(complex_NaN); + den = 1.0 / (r2 * r2 + i2 * i2); + return(make_complex(sc, real(x) * r2 * den, -real(x) * i2 * den)); + } #if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); - mpfr_d_div(sc->mpfr_1, real(x), sc->mpfr_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - mpfr_div_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_d_div(sc->mpfr_1, real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((is_NaN(real(x))) || (!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); + mpfr_d_div(sc->mpfr_1, real(x), sc->mpfr_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + mpfr_div_q(sc->mpfr_1, sc->mpfr_1, big_ratio(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpfr_d_div(sc->mpfr_1, real(x), big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + if ((is_NaN(real(x))) || (!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return(complex_NaN); + mpc_set_d_d(sc->mpc_1, real(x), 0.0, MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } /* -------- complex x -------- */ case T_COMPLEX: switch (type(y)) - { - case T_INTEGER: - { - s7_double r1; - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - r1 = (long_double)1.0 / (long_double)integer(y); - return(make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); - } - - case T_RATIO: - { - s7_double frac = inverted_fraction(y); - return(make_complex(sc, real_part(x) * frac, imag_part(x) * frac)); - } - - case T_REAL: - { - s7_double r1; - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - r1 = 1.0 / real(y); - return(make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); /* (/ 0.0+1.0i +inf.0) */ - } - - case T_COMPLEX: - { - s7_double r1 = real_part(x), r2, i1, i2, den; - if (is_NaN(r1)) return(x); - i1 = imag_part(x); - if (is_NaN(i1)) return(x); - r2 = real_part(y); - if (is_NaN(r2)) return(y); - if (is_inf(r2)) return(complex_NaN); - i2 = imag_part(y); - if (is_NaN(i2)) return(y); - den = 1.0 / (r2 * r2 + i2 * i2); - return(make_complex(sc, (r1 * r2 + i1 * i2) * den, (r2 * i1 - r1 * i2) * den)); - } + { + case T_INTEGER: + { + s7_double r1; + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + r1 = (long_double)1.0 / (long_double)integer(y); + return(make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); + } + + case T_RATIO: + { + s7_double frac = inverted_fraction(y); + return(make_complex(sc, real_part(x) * frac, imag_part(x) * frac)); + } + + case T_REAL: + { + s7_double r1; + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + r1 = 1.0 / real(y); + return(make_complex(sc, real_part(x) * r1, imag_part(x) * r1)); /* (/ 0.0+1.0i +inf.0) */ + } + + case T_COMPLEX: + { + s7_double r1 = real_part(x), r2, i1, i2, den; + if (is_NaN(r1)) return(x); + i1 = imag_part(x); + if (is_NaN(i1)) return(x); + r2 = real_part(y); + if (is_NaN(r2)) return(y); + if (is_inf(r2)) return(complex_NaN); + i2 = imag_part(y); + if (is_NaN(i2)) return(y); + den = 1.0 / (r2 * r2 + i2 * i2); + return(make_complex(sc, (r1 * r2 + i1 * i2) * den, (r2 * i1 - r1 * i2) * den)); + } #if WITH_GMP - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_div_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); -#endif - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(y), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_set_q(sc->mpc_2, big_ratio(y), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_div_fr(sc->mpc_1, sc->mpc_1, big_real(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return(complex_NaN); + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } #if WITH_GMP case T_BIG_INTEGER: switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpz_set_si(sc->mpz_1, integer(y)); - mpq_set_num(sc->mpq_1, big_integer(x)); - mpq_set_den(sc->mpq_1, sc->mpz_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_z(sc->mpq_2, big_integer(x)); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); /* can't invert here, mpq den=unsigned */ - mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (is_inf(real_part(y))) || (is_inf(imag_part(y)))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_num(sc->mpq_1, big_integer(x)); - mpq_set_den(sc->mpq_1, big_integer(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, 0, 1); - mpq_set_num(sc->mpq_1, big_integer(x)); - mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpz_set_si(sc->mpz_1, integer(y)); + mpq_set_num(sc->mpq_1, big_integer(x)); + mpq_set_den(sc->mpq_1, sc->mpz_1); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_RATIO: + mpq_set_z(sc->mpq_2, big_integer(x)); + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); /* can't invert here, mpq den=unsigned */ + mpq_div(sc->mpq_1, sc->mpq_2, sc->mpq_1); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) return(y); + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || + (is_inf(real_part(y))) || (is_inf(imag_part(y)))) + return(complex_NaN); + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_set_z(sc->mpc_2, big_integer(x), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_2, sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpq_set_num(sc->mpq_1, big_integer(x)); + mpq_set_den(sc->mpq_1, big_integer(y)); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, 0, 1); + mpq_set_num(sc->mpq_1, big_integer(x)); + mpq_div(sc->mpq_1, sc->mpq_1, big_ratio(y)); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return(complex_NaN); + mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } case T_BIG_RATIO: switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_si(sc->mpq_1, integer(y), 1); - mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_rational(sc, sc->mpq_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (is_inf(real_part(y))) || (is_inf(imag_part(y)))) - return(complex_NaN); - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpq_set_z(sc->mpq_1, big_integer(y)); - mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_RATIO: - mpq_div(sc->mpq_1, big_ratio(x), big_ratio(y)); - return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); - mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpq_set_si(sc->mpq_1, integer(y), 1); + mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); + return(mpq_to_rational(sc, sc->mpq_1)); + case T_REAL: + if (is_NaN(real(y))) return(y); + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_div_d(sc->mpfr_1, sc->mpfr_1, real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || + (is_inf(real_part(y))) || (is_inf(imag_part(y)))) + return(complex_NaN); + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpq_set_z(sc->mpq_1, big_integer(y)); + mpq_div(sc->mpq_1, big_ratio(x), sc->mpq_1); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_RATIO: + mpq_div(sc->mpq_1, big_ratio(x), big_ratio(y)); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + mpfr_div(sc->mpfr_1, sc->mpfr_1, big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return(complex_NaN); + mpc_set_q(sc->mpc_1, big_ratio(x), MPC_RNDNN); + mpc_div(sc->mpc_1, sc->mpc_1, big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } case T_BIG_REAL: switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_div_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpfr_div_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_REAL: - if (is_NaN(real(y))) return(y); - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_div_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (is_inf(real_part(y))) || (is_inf(imag_part(y)))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_fr_div(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_div_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_RATIO: - mpfr_div_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpfr_div(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_fr_div(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpfr_div_si(sc->mpfr_1, big_real(x), integer(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpfr_div_q(sc->mpfr_1, big_real(x), sc->mpq_1, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_REAL: + if (is_NaN(real(y))) return(y); + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpfr_div_d(sc->mpfr_1, big_real(x), real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_COMPLEX: + if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || + (is_inf(real_part(y))) || (is_inf(imag_part(y)))) + return(complex_NaN); + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_fr_div(sc->mpc_1, big_real(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpfr_div_z(sc->mpfr_1, big_real(x), big_integer(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_RATIO: + mpfr_div_q(sc->mpfr_1, big_real(x), big_ratio(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpfr_div(sc->mpfr_1, big_real(x), big_real(y), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return(complex_NaN); + mpc_fr_div(sc->mpc_1, big_real(x), big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } case T_BIG_COMPLEX: switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_REAL: - /* if (is_NaN(real(y))) return(y); */ - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (is_inf(real_part(y))) || (is_inf(imag_part(y)))) - return(complex_NaN); - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_INTEGER: - if (mpz_cmp_ui(big_integer(y), 0) == 0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_RATIO: - mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); - mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_REAL: - if (mpfr_zero_p(big_real(y))) - division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); - mpc_div_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - case T_BIG_COMPLEX: - if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) - return(complex_NaN); - mpc_div(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); - return(mpc_to_number(sc, sc->mpc_1)); - default: - return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); - } + { + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpc_set_si(sc->mpc_1, integer(y), MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + mpc_set_q(sc->mpc_1, sc->mpq_1, MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_REAL: + /* if (is_NaN(real(y))) return(y); */ + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpc_set_d_d(sc->mpc_1, real(y), 0.0, MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_COMPLEX: + if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || + (is_inf(real_part(y))) || (is_inf(imag_part(y)))) + return(complex_NaN); + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpc_set_z(sc->mpc_1, big_integer(y), MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_RATIO: + mpc_set_q(sc->mpc_1, big_ratio(y), MPC_RNDNN); + mpc_div(sc->mpc_1, big_complex(x), sc->mpc_1, MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_REAL: + if (mpfr_zero_p(big_real(y))) + division_by_zero_error_2_nr(sc, sc->divide_symbol, x, y); + mpc_div_fr(sc->mpc_1, big_complex(x), big_real(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + case T_BIG_COMPLEX: + if ((!mpfr_number_p(mpc_realref(big_complex(y)))) || (!mpfr_number_p(mpc_imagref(big_complex(y))))) + return(complex_NaN); + mpc_div(sc->mpc_1, big_complex(x), big_complex(y), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } #endif default: /* x is not a built-in number */ @@ -21806,7 +21806,7 @@ static s7_pointer g_divide(s7_scheme *sc, s7_pointer args) if (is_null(p)) /* (/ x) */ { if (!is_number(x)) - return(method_or_bust_p(sc, x, sc->divide_symbol, a_number_string)); + return(method_or_bust_p(sc, x, sc->divide_symbol, a_number_string)); return(invert_p_p(sc, x)); } for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++) @@ -21826,13 +21826,13 @@ static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args) { s7_int i = integer(num); if (i & 1) - { - s7_pointer x; - new_cell(sc, x, T_RATIO); - set_numerator(x, i); - set_denominator(x, 2); - return(x); - } + { + s7_pointer x; + new_cell(sc, x, T_RATIO); + set_numerator(x, i); + set_denominator(x, 2); + return(x); + } return(make_integer(sc, i >> 1)); } switch (type(num)) @@ -21840,26 +21840,26 @@ static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args) case T_RATIO: #if HAVE_OVERFLOW_CHECKS { - s7_int dn; - if (multiply_overflow(denominator(num), 2, &dn)) - { - if ((numerator(num) & 1) == 1) + s7_int dn; + if (multiply_overflow(denominator(num), 2, &dn)) + { + if ((numerator(num) & 1) == 1) #if WITH_GMP - { - mpq_set_si(sc->mpq_1, numerator(num), denominator(num)); - mpq_set_si(sc->mpq_2, 1, 2); - mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); - return(mpq_to_rational(sc, sc->mpq_1)); - } + { + mpq_set_si(sc->mpq_1, numerator(num), denominator(num)); + mpq_set_si(sc->mpq_2, 1, 2); + mpq_mul(sc->mpq_1, sc->mpq_1, sc->mpq_2); + return(mpq_to_rational(sc, sc->mpq_1)); + } #else - { - if (WITH_WARNINGS) s7_warn(sc, 128, "ratio / 2 overflow: (/ %" ld64 "/%" ld64 " 2)\n", numerator(num), denominator(num)); - return(make_real(sc, ((long_double)numerator(num) * 0.5) / (long_double)denominator(num))); - } -#endif - return(make_ratio(sc, numerator(num) / 2, denominator(num))); - } - return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(num), dn)); + { + if (WITH_WARNINGS) s7_warn(sc, 128, "ratio / 2 overflow: (/ %" ld64 "/%" ld64 " 2)\n", numerator(num), denominator(num)); + return(make_real(sc, ((long_double)numerator(num) * 0.5) / (long_double)denominator(num))); + } +#endif + return(make_ratio(sc, numerator(num) / 2, denominator(num))); + } + return(make_ratio_with_div_check(sc, sc->divide_symbol, numerator(num), dn)); } #else return(make_ratio(sc, numerator(num), denominator(num) * 2)); @@ -21898,7 +21898,7 @@ static s7_pointer g_invert_x(s7_scheme *sc, s7_pointer args) { s7_double rl = real(x); if (rl == 0.0) - division_by_zero_error_2_nr(sc, sc->divide_symbol, car(args), x); + division_by_zero_error_2_nr(sc, sc->divide_symbol, car(args), x); return((is_NaN(rl)) ? x : make_real(sc, 1.0 / rl)); } return(g_divide(sc, args)); @@ -21927,7 +21927,7 @@ static s7_pointer divide_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_p { s7_pointer arg1 = cadr(expr); if ((is_t_real(arg1)) && (real(arg1) == 1.0)) - return(sc->invert_x); + return(sc->invert_x); return(((is_t_integer(caddr(expr))) && (integer(caddr(expr)) == 2)) ? sc->divide_by_2 : sc->divide_2); } return(f); @@ -21975,28 +21975,28 @@ static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if ((is_real(x)) && (is_real(y))) { if (is_zero(y)) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); + division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); if ((s7_is_integer(x)) && (s7_is_integer(y))) - { - if (is_t_integer(x)) mpz_set_si(sc->mpz_1, integer(x)); else mpz_set(sc->mpz_1, big_integer(x)); - if (is_t_integer(y)) mpz_set_si(sc->mpz_2, integer(y)); else mpz_set(sc->mpz_2, big_integer(y)); - mpz_tdiv_q(sc->mpz_1, sc->mpz_1, sc->mpz_2); - } + { + if (is_t_integer(x)) mpz_set_si(sc->mpz_1, integer(x)); else mpz_set(sc->mpz_1, big_integer(x)); + if (is_t_integer(y)) mpz_set_si(sc->mpz_2, integer(y)); else mpz_set(sc->mpz_2, big_integer(y)); + mpz_tdiv_q(sc->mpz_1, sc->mpz_1, sc->mpz_2); + } else - if ((!is_rational(x)) || (!is_rational(y))) - { - if (any_real_to_mpfr(sc, x, sc->mpfr_1)) return(real_NaN); - if (any_real_to_mpfr(sc, y, sc->mpfr_2)) return(real_NaN); - mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ); - } - else - { - any_rational_to_mpq(sc, x, sc->mpq_1); - any_rational_to_mpq(sc, y, sc->mpq_2); - mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2); - mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3)); - } + if ((!is_rational(x)) || (!is_rational(y))) + { + if (any_real_to_mpfr(sc, x, sc->mpfr_1)) return(real_NaN); + if (any_real_to_mpfr(sc, y, sc->mpfr_2)) return(real_NaN); + mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ); + } + else + { + any_rational_to_mpq(sc, x, sc->mpq_1); + any_rational_to_mpq(sc, y, sc->mpq_2); + mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2); + mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3)); + } return(mpz_to_integer(sc, sc->mpz_1)); } return(method_or_bust_pp(sc, (is_real(x)) ? y : x, sc->quotient_symbol, x, y, sc->type_names[T_REAL], (is_real(x)) ? 2 : 1)); @@ -22010,94 +22010,94 @@ static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { case T_INTEGER: switch (type(y)) - { - case T_INTEGER: - return(make_integer(sc, quotient_i_7ii(sc, integer(x), integer(y)))); - - case T_RATIO: - n1 = integer(x); - d1 = 1; - n2 = numerator(y); - d2 = denominator(y); - /* (quotient -9223372036854775808 -1/9223372036854775807): arithmetic exception in the no-overflow-checks case */ - goto RATIO_QUO_RATIO; - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - if (is_inf(real(y))) return(real_NaN); - if (is_NaN(real(y))) return(y); - return(s7_truncate(sc, sc->quotient_symbol, (s7_double)integer(x) / real(y))); /* s7_truncate returns an integer */ - - default: - return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); - } + { + case T_INTEGER: + return(make_integer(sc, quotient_i_7ii(sc, integer(x), integer(y)))); + + case T_RATIO: + n1 = integer(x); + d1 = 1; + n2 = numerator(y); + d2 = denominator(y); + /* (quotient -9223372036854775808 -1/9223372036854775807): arithmetic exception in the no-overflow-checks case */ + goto RATIO_QUO_RATIO; + + case T_REAL: + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); + if (is_inf(real(y))) return(real_NaN); + if (is_NaN(real(y))) return(y); + return(s7_truncate(sc, sc->quotient_symbol, (s7_double)integer(x) / real(y))); /* s7_truncate returns an integer */ + + default: + return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); + } case T_RATIO: switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - n1 = numerator(x); - d1 = denominator(x); - n2 = integer(y); - d2 = 1; - goto RATIO_QUO_RATIO; - /* this can lose: - * (quotient 1 2305843009213693952/4611686018427387903) -> 2, not 1 - * (quotient 21053343141/6701487259 3587785776203/1142027682075) -> 1, not 0 - */ - - case T_RATIO: - parcel_out_fractions(x, y); - RATIO_QUO_RATIO: - if (d1 == d2) - return(make_integer(sc, n1 / n2)); /* (quotient 3/9223372036854775807 1/9223372036854775807) */ - if (n1 == n2) - return(make_integer(sc, d2 / d1)); /* (quotient 9223372036854775807/2 9223372036854775807/8) */ + { + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); + n1 = numerator(x); + d1 = denominator(x); + n2 = integer(y); + d2 = 1; + goto RATIO_QUO_RATIO; + /* this can lose: + * (quotient 1 2305843009213693952/4611686018427387903) -> 2, not 1 + * (quotient 21053343141/6701487259 3587785776203/1142027682075) -> 1, not 0 + */ + + case T_RATIO: + parcel_out_fractions(x, y); + RATIO_QUO_RATIO: + if (d1 == d2) + return(make_integer(sc, n1 / n2)); /* (quotient 3/9223372036854775807 1/9223372036854775807) */ + if (n1 == n2) + return(make_integer(sc, d2 / d1)); /* (quotient 9223372036854775807/2 9223372036854775807/8) */ #if HAVE_OVERFLOW_CHECKS - { - s7_int n1d2, n2d1; - if ((multiply_overflow(n1, d2, &n1d2)) || - (multiply_overflow(n2, d1, &n2d1))) - return(s7_truncate(sc, sc->quotient_symbol, ((long_double)n1 / (long_double)n2) * ((long_double)d2 / (long_double)d1))); - return(make_integer(sc, n1d2 / n2d1)); - } + { + s7_int n1d2, n2d1; + if ((multiply_overflow(n1, d2, &n1d2)) || + (multiply_overflow(n2, d1, &n2d1))) + return(s7_truncate(sc, sc->quotient_symbol, ((long_double)n1 / (long_double)n2) * ((long_double)d2 / (long_double)d1))); + return(make_integer(sc, n1d2 / n2d1)); + } #else - return(make_integer(sc, (n1 * d2) / (n2 * d1))); + return(make_integer(sc, (n1 * d2) / (n2 * d1))); #endif - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - if (is_inf(real(y))) return(real_NaN); - if (is_NaN(real(y))) return(y); - return(s7_truncate(sc, sc->quotient_symbol, (s7_double)fraction(x) / real(y))); + case T_REAL: + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); + if (is_inf(real(y))) return(real_NaN); + if (is_NaN(real(y))) return(y); + return(s7_truncate(sc, sc->quotient_symbol, (s7_double)fraction(x) / real(y))); - default: - return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); - } + default: + return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); + } case T_REAL: if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y))) - return(real_NaN); + return(real_NaN); /* if infs allowed we need to return infs/nans, else: * (quotient inf.0 1e-309) -> -9223372036854775808 * (quotient inf.0 inf.0) -> -9223372036854775808 */ switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); - return(s7_truncate(sc, sc->quotient_symbol, (long_double)real(x) / (long_double)integer(y))); - - case T_RATIO: return(s7_truncate(sc, sc->quotient_symbol, real(x) / (s7_double)fraction(y))); - case T_REAL: return(make_integer(sc, c_quo_dbl(sc, real(x), real(y)))); /* c_quo_dbl returns an integer */ - default: return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); - } + { + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->quotient_symbol, x, y); + return(s7_truncate(sc, sc->quotient_symbol, (long_double)real(x) / (long_double)integer(y))); + + case T_RATIO: return(s7_truncate(sc, sc->quotient_symbol, real(x) / (s7_double)fraction(y))); + case T_REAL: return(make_integer(sc, c_quo_dbl(sc, real(x), real(y)))); /* c_quo_dbl returns an integer */ + default: return(method_or_bust_pp(sc, y, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); + } default: return(method_or_bust_pp(sc, x, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2)); @@ -22128,33 +22128,33 @@ static s7_pointer big_mod_or_rem(s7_scheme *sc, s7_pointer x, s7_pointer y, bool if ((is_real(x)) && (is_real(y))) { if ((s7_is_integer(x)) && (s7_is_integer(y))) - { - if (is_t_integer(x)) mpz_set_si(sc->mpz_1, integer(x)); else mpz_set(sc->mpz_1, big_integer(x)); - if (is_t_integer(y)) mpz_set_si(sc->mpz_2, integer(y)); else mpz_set(sc->mpz_2, big_integer(y)); - if (use_floor) - mpz_fdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2); - else mpz_tdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2); - mpz_mul(sc->mpz_3, sc->mpz_3, sc->mpz_2); - mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_3); - return(mpz_to_integer(sc, sc->mpz_1)); - } + { + if (is_t_integer(x)) mpz_set_si(sc->mpz_1, integer(x)); else mpz_set(sc->mpz_1, big_integer(x)); + if (is_t_integer(y)) mpz_set_si(sc->mpz_2, integer(y)); else mpz_set(sc->mpz_2, big_integer(y)); + if (use_floor) + mpz_fdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2); + else mpz_tdiv_q(sc->mpz_3, sc->mpz_1, sc->mpz_2); + mpz_mul(sc->mpz_3, sc->mpz_3, sc->mpz_2); + mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_3); + return(mpz_to_integer(sc, sc->mpz_1)); + } if ((!is_rational(x)) || (!is_rational(y))) - { - any_real_to_mpfr(sc, x, sc->mpfr_1); - any_real_to_mpfr(sc, y, sc->mpfr_2); - mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - if (use_floor) - mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDD); - else mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ); - mpfr_mul_z(sc->mpfr_2, sc->mpfr_2, sc->mpz_1, MPFR_RNDN); - mpfr_sub(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); - return(mpfr_to_big_real(sc, sc->mpfr_1)); - } + { + any_real_to_mpfr(sc, x, sc->mpfr_1); + any_real_to_mpfr(sc, y, sc->mpfr_2); + mpfr_div(sc->mpfr_3, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + if (use_floor) + mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDD); + else mpfr_get_z(sc->mpz_1, sc->mpfr_3, MPFR_RNDZ); + mpfr_mul_z(sc->mpfr_2, sc->mpfr_2, sc->mpz_1, MPFR_RNDN); + mpfr_sub(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + } any_rational_to_mpq(sc, x, sc->mpq_1); any_rational_to_mpq(sc, y, sc->mpq_2); mpq_div(sc->mpq_3, sc->mpq_1, sc->mpq_2); if (use_floor) - mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3)); + mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3)); else mpz_tdiv_q(sc->mpz_1, mpq_numref(sc->mpq_3), mpq_denref(sc->mpq_3)); mpz_mul(mpq_numref(sc->mpq_2), sc->mpz_1, mpq_numref(sc->mpq_2)); mpq_sub(sc->mpq_1, sc->mpq_1, sc->mpq_2); @@ -22214,162 +22214,162 @@ static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { case T_INTEGER: switch (type(y)) - { - case T_INTEGER: - return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y)))); - - case T_RATIO: - n1 = integer(x); - d1 = 1; - n2 = numerator(y); - d2 = denominator(y); - goto RATIO_REM_RATIO; - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - if (is_inf(real(y))) return(real_NaN); - if (is_NaN(real(y))) return(y); - pre_quo = (long_double)integer(x) / (long_double)real(y); - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(make_real(sc, integer(x) - real(y) * quo)); - - default: - return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2)); - } + { + case T_INTEGER: + return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y)))); + + case T_RATIO: + n1 = integer(x); + d1 = 1; + n2 = numerator(y); + d2 = denominator(y); + goto RATIO_REM_RATIO; + + case T_REAL: + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); + if (is_inf(real(y))) return(real_NaN); + if (is_NaN(real(y))) return(y); + pre_quo = (long_double)integer(x) / (long_double)real(y); + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); + quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); + return(make_real(sc, integer(x) - real(y) * quo)); + + default: + return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2)); + } case T_RATIO: switch (type(y)) - { - case T_INTEGER: - n2 = integer(y); - if (n2 == 0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - n1 = numerator(x); - d1 = denominator(x); - d2 = 1; - goto RATIO_REM_RATIO; - - case T_RATIO: - parcel_out_fractions(x, y); - RATIO_REM_RATIO: - if (d1 == d2) - quo = (s7_int)(n1 / n2); - else - { - if (n1 == n2) - quo = (s7_int)(d2 / d1); - else - { + { + case T_INTEGER: + n2 = integer(y); + if (n2 == 0) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); + n1 = numerator(x); + d1 = denominator(x); + d2 = 1; + goto RATIO_REM_RATIO; + + case T_RATIO: + parcel_out_fractions(x, y); + RATIO_REM_RATIO: + if (d1 == d2) + quo = (s7_int)(n1 / n2); + else + { + if (n1 == n2) + quo = (s7_int)(d2 / d1); + else + { #if HAVE_OVERFLOW_CHECKS - s7_int n1d2, n2d1; - if ((multiply_overflow(n1, d2, &n1d2)) || - (multiply_overflow(n2, d1, &n2d1))) - { - pre_quo = ((long_double)n1 / (long_double)n2) * ((long_double)d2 / (long_double)d1); - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - } - else quo = n1d2 / n2d1; + s7_int n1d2, n2d1; + if ((multiply_overflow(n1, d2, &n1d2)) || + (multiply_overflow(n2, d1, &n2d1))) + { + pre_quo = ((long_double)n1 / (long_double)n2) * ((long_double)d2 / (long_double)d1); + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); + quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); + } + else quo = n1d2 / n2d1; #else - quo = (n1 * d2) / (n2 * d1); + quo = (n1 * d2) / (n2 * d1); #endif - }} - if (quo == 0) - return(x); + }} + if (quo == 0) + return(x); #if HAVE_OVERFLOW_CHECKS - { - s7_int dn, nq; - if (!multiply_overflow(n2, quo, &nq)) - { - if ((d1 == d2) && - (!subtract_overflow(n1, nq, &dn))) - return(make_ratio_with_div_check(sc, sc->remainder_symbol, dn, d1)); - - if ((!multiply_overflow(n1, d2, &dn)) && - (!multiply_overflow(nq, d1, &nq)) && - (!subtract_overflow(dn, nq, &nq)) && - (!multiply_overflow(d1, d2, &d1))) - return(make_ratio_with_div_check(sc, sc->remainder_symbol, nq, d1)); - }} + { + s7_int dn, nq; + if (!multiply_overflow(n2, quo, &nq)) + { + if ((d1 == d2) && + (!subtract_overflow(n1, nq, &dn))) + return(make_ratio_with_div_check(sc, sc->remainder_symbol, dn, d1)); + + if ((!multiply_overflow(n1, d2, &dn)) && + (!multiply_overflow(nq, d1, &nq)) && + (!subtract_overflow(dn, nq, &nq)) && + (!multiply_overflow(d1, d2, &d1))) + return(make_ratio_with_div_check(sc, sc->remainder_symbol, nq, d1)); + }} #else - if (d1 == d2) - return(make_ratio_with_div_check(sc, sc->remainder_symbol, n1 - n2 * quo, d1)); - - return(make_ratio_with_div_check(sc, sc->remainder_symbol, n1 * d2 - n2 * d1 * quo, d1 * d2)); -#endif - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), intermediate_too_large_string); - - case T_REAL: - { - s7_double frac; - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - if (is_inf(real(y))) return(real_NaN); - if (is_NaN(real(y))) return(y); - if (s7_int_abs(numerator(x)) > QUOTIENT_INT_LIMIT) - return(subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y)))); - frac = (s7_double)fraction(x); - pre_quo = frac / real(y); - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(make_real(sc, frac - real(y) * quo)); - } - - default: - return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2)); - } + if (d1 == d2) + return(make_ratio_with_div_check(sc, sc->remainder_symbol, n1 - n2 * quo, d1)); + + return(make_ratio_with_div_check(sc, sc->remainder_symbol, n1 * d2 - n2 * d1 * quo, d1 * d2)); +#endif + sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), intermediate_too_large_string); + + case T_REAL: + { + s7_double frac; + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); + if (is_inf(real(y))) return(real_NaN); + if (is_NaN(real(y))) return(y); + if (s7_int_abs(numerator(x)) > QUOTIENT_INT_LIMIT) + return(subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y)))); + frac = (s7_double)fraction(x); + pre_quo = frac / real(y); + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); + quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); + return(make_real(sc, frac - real(y) * quo)); + } + + default: + return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2)); + } case T_REAL: if (((is_inf(real(x))) || (is_NaN(real(x)))) && (is_real(y))) - { - if (is_zero(y)) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - return(real_NaN); - } + { + if (is_zero(y)) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); + return(real_NaN); + } switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - /* actually here (and elsewhere) if y > INT64_TO_DOUBLE_LIMIT, the result is probably wrong */ - pre_quo = (long_double)real(x) / (long_double)integer(y); - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(make_real(sc, real(x) - integer(y) * quo)); - /* but... (remainder 1e+18 9223372036854775807) -> 1e+18 */ - - case T_RATIO: - if (s7_int_abs(numerator(y)) > QUOTIENT_INT_LIMIT) - return(subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y)))); - { - s7_double frac = (s7_double)fraction(y); - pre_quo = real(x) / frac; - if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) - sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); - quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); - return(make_real(sc, real(x) - frac * quo)); - } - - case T_REAL: - if (real(y) == 0.0) - division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); - return(make_real(sc, c_rem_dbl(sc, real(x), real(y)))); - /* see under sin -- this calculation is completely bogus if "a" is large - * (quotient 1e22 (* 2 pi)) -> -9223372036854775808 but it should be 1591549430918953357688, - * (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 -- the "remainder" is greater than the original argument! - * Clisp gives 0.0 here, as does sbcl, currently s7 throws an error (out-of-range). - */ - - default: - return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2)); - } + { + case T_INTEGER: + if (integer(y) == 0) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); + /* actually here (and elsewhere) if y > INT64_TO_DOUBLE_LIMIT, the result is probably wrong */ + pre_quo = (long_double)real(x) / (long_double)integer(y); + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); + quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); + return(make_real(sc, real(x) - integer(y) * quo)); + /* but... (remainder 1e+18 9223372036854775807) -> 1e+18 */ + + case T_RATIO: + if (s7_int_abs(numerator(y)) > QUOTIENT_INT_LIMIT) + return(subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y)))); + { + s7_double frac = (s7_double)fraction(y); + pre_quo = real(x) / frac; + if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, x, y), it_is_too_large_string); + quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo); + return(make_real(sc, real(x) - frac * quo)); + } + + case T_REAL: + if (real(y) == 0.0) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y); + return(make_real(sc, c_rem_dbl(sc, real(x), real(y)))); + /* see under sin -- this calculation is completely bogus if "a" is large + * (quotient 1e22 (* 2 pi)) -> -9223372036854775808 but it should be 1591549430918953357688, + * (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 -- the "remainder" is greater than the original argument! + * Clisp gives 0.0 here, as does sbcl, currently s7 throws an error (out-of-range). + */ + + default: + return(method_or_bust_pp(sc, y, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 2)); + } default: return(method_or_bust_pp(sc, x, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 1)); @@ -22430,8 +22430,8 @@ static s7_double modulo_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2) c = x1 / x2; if ((c > 1e19) || (c < -1e19)) sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, - set_elist_3(sc, sc->divide_symbol, wrap_real(sc, x1), wrap_real(sc, x2)), - intermediate_too_large_string); + set_elist_3(sc, sc->divide_symbol, wrap_real(sc, x1), wrap_real(sc, x2)), + intermediate_too_large_string); return(x1 - x2 * (s7_int)floor(c)); } @@ -22454,161 +22454,161 @@ static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { case T_INTEGER: switch (type(y)) - { - case T_INTEGER: - return(make_integer(sc, modulo_i_ii(integer(x), integer(y)))); - - case T_RATIO: - n1 = integer(x); - d1 = 1; - n2 = numerator(y); - d2 = denominator(y); - if ((n1 == n2) && (d1 > d2)) return(x); /* signs match so this should be ok */ - goto RATIO_MOD_RATIO; - - case T_REAL: - if ((integer(x) == S7_INT64_MIN) || (s7_int_abs(integer(x)) > QUOTIENT_INT_LIMIT)) - out_of_range_error_nr(sc, sc->modulo_symbol, int_one, x, it_is_too_large_string); - b = real(y); - if (b == 0.0) return(x); - if (is_NaN(b)) return(y); - if (is_inf(b)) return(real_NaN); - a = (s7_double)integer(x); - goto REAL_MOD; - - default: - return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); - } + { + case T_INTEGER: + return(make_integer(sc, modulo_i_ii(integer(x), integer(y)))); + + case T_RATIO: + n1 = integer(x); + d1 = 1; + n2 = numerator(y); + d2 = denominator(y); + if ((n1 == n2) && (d1 > d2)) return(x); /* signs match so this should be ok */ + goto RATIO_MOD_RATIO; + + case T_REAL: + if ((integer(x) == S7_INT64_MIN) || (s7_int_abs(integer(x)) > QUOTIENT_INT_LIMIT)) + out_of_range_error_nr(sc, sc->modulo_symbol, int_one, x, it_is_too_large_string); + b = real(y); + if (b == 0.0) return(x); + if (is_NaN(b)) return(y); + if (is_inf(b)) return(real_NaN); + a = (s7_double)integer(x); + goto REAL_MOD; + + default: + return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); + } case T_RATIO: switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) return(x); - n1 = numerator(x); - d1 = denominator(x); - n2 = integer(y); - - if ((n2 > 0) && (n1 > 0) && (n2 > n1)) return(x); - if ((n2 < 0) && (n1 < 0) && (n2 < n1)) return(x); - if (n2 == S7_INT64_MIN) - sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, - set_elist_3(sc, sc->divide_symbol, x, y), - intermediate_too_large_string); - /* the problem here is that (modulo 3/2 most-negative-fixnum) - * will segfault with signal SIGFPE, Arithmetic exception, so try to trap it. - */ - if ((n1 == n2) && (d1 > 1)) return(x); - d2 = 1; - goto RATIO_MOD_RATIO; - - case T_RATIO: - parcel_out_fractions(x, y); - if (d1 == d2) - return(make_ratio_with_div_check(sc, sc->modulo_symbol, modulo_i_ii(n1, n2), d1)); - if ((n1 == n2) && (d1 > d2)) return(x); - - RATIO_MOD_RATIO: + { + case T_INTEGER: + if (integer(y) == 0) return(x); + n1 = numerator(x); + d1 = denominator(x); + n2 = integer(y); + + if ((n2 > 0) && (n1 > 0) && (n2 > n1)) return(x); + if ((n2 < 0) && (n1 < 0) && (n2 < n1)) return(x); + if (n2 == S7_INT64_MIN) + sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, + set_elist_3(sc, sc->divide_symbol, x, y), + intermediate_too_large_string); + /* the problem here is that (modulo 3/2 most-negative-fixnum) + * will segfault with signal SIGFPE, Arithmetic exception, so try to trap it. + */ + if ((n1 == n2) && (d1 > 1)) return(x); + d2 = 1; + goto RATIO_MOD_RATIO; + + case T_RATIO: + parcel_out_fractions(x, y); + if (d1 == d2) + return(make_ratio_with_div_check(sc, sc->modulo_symbol, modulo_i_ii(n1, n2), d1)); + if ((n1 == n2) && (d1 > d2)) return(x); + + RATIO_MOD_RATIO: #if HAVE_OVERFLOW_CHECKS - { - s7_int n2d1, n1d2, d1d2, fl; - if (!multiply_overflow(n2, d1, &n2d1)) - { - if ((n2d1 == 1) || (n2d1 == -1)) /* (modulo 100 -1/2) */ - return(int_zero); - - if (!multiply_overflow(n1, d2, &n1d2)) - { - fl = (s7_int)(n1d2 / n2d1); - if (((n1 < 0) && (n2 > 0)) || - ((n1 > 0) && (n2 < 0))) - fl -= 1; - if (fl == 0) - return(x); - - if ((!multiply_overflow(d1, d2, &d1d2)) && - (!multiply_overflow(fl, n2d1, &fl)) && - (!subtract_overflow(n1d2, fl, &fl))) - return(make_ratio_with_div_check(sc, sc->modulo_symbol, fl, d1d2)); - }}} + { + s7_int n2d1, n1d2, d1d2, fl; + if (!multiply_overflow(n2, d1, &n2d1)) + { + if ((n2d1 == 1) || (n2d1 == -1)) /* (modulo 100 -1/2) */ + return(int_zero); + + if (!multiply_overflow(n1, d2, &n1d2)) + { + fl = (s7_int)(n1d2 / n2d1); + if (((n1 < 0) && (n2 > 0)) || + ((n1 > 0) && (n2 < 0))) + fl -= 1; + if (fl == 0) + return(x); + + if ((!multiply_overflow(d1, d2, &d1d2)) && + (!multiply_overflow(fl, n2d1, &fl)) && + (!subtract_overflow(n1d2, fl, &fl))) + return(make_ratio_with_div_check(sc, sc->modulo_symbol, fl, d1d2)); + }}} #else - { - s7_int fl; - s7_int n1d2 = n1 * d2; - s7_int n2d1 = n2 * d1; - - if (n2d1 == 1) - return(int_zero); - - /* can't use "floor" here (float->int ruins everything) */ - fl = (s7_int)(n1d2 / n2d1); - if (((n1 < 0) && (n2 > 0)) || - ((n1 > 0) && (n2 < 0))) - fl -= 1; - - if (fl == 0) - return(x); - - return(make_ratio_with_div_check(sc, sc->modulo_symbol, n1d2 - (n2d1 * fl), d1 * d2)); - } -#endif - sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, - set_elist_3(sc, sc->divide_symbol, x, y), - intermediate_too_large_string); - case T_REAL: - b = real(y); - if (is_inf(b)) return(real_NaN); - if (fabs(b) > 1e17) - out_of_range_error_nr(sc, sc->modulo_symbol, int_two, y, it_is_too_large_string); - if (b == 0.0) return(x); - if (is_NaN(b)) return(y); - a = fraction(x); - return(make_real(sc, a - b * (s7_int)floor(a / b))); - - default: - return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); - } + { + s7_int fl; + s7_int n1d2 = n1 * d2; + s7_int n2d1 = n2 * d1; + + if (n2d1 == 1) + return(int_zero); + + /* can't use "floor" here (float->int ruins everything) */ + fl = (s7_int)(n1d2 / n2d1); + if (((n1 < 0) && (n2 > 0)) || + ((n1 > 0) && (n2 < 0))) + fl -= 1; + + if (fl == 0) + return(x); + + return(make_ratio_with_div_check(sc, sc->modulo_symbol, n1d2 - (n2d1 * fl), d1 * d2)); + } +#endif + sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, + set_elist_3(sc, sc->divide_symbol, x, y), + intermediate_too_large_string); + case T_REAL: + b = real(y); + if (is_inf(b)) return(real_NaN); + if (fabs(b) > 1e17) + out_of_range_error_nr(sc, sc->modulo_symbol, int_two, y, it_is_too_large_string); + if (b == 0.0) return(x); + if (is_NaN(b)) return(y); + a = fraction(x); + return(make_real(sc, a - b * (s7_int)floor(a / b))); + + default: + return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); + } case T_REAL: { - s7_double c; - a = real(x); - if (!is_real(y)) - return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); - if (is_NaN(a)) return(x); - if (is_inf(a)) return(real_NaN); /* not b */ - if (fabs(a) > 1e17) - out_of_range_error_nr(sc, sc->modulo_symbol, int_one, x, it_is_too_large_string); - - switch (type(y)) - { - case T_INTEGER: - if (integer(y) == 0) return(x); - if ((integer(y) == S7_INT64_MIN) || (s7_int_abs(integer(y)) > QUOTIENT_INT_LIMIT)) - out_of_range_error_nr(sc, sc->modulo_symbol, int_two, y, it_is_too_large_string); - b = (s7_double)integer(y); - goto REAL_MOD; - - case T_RATIO: - b = fraction(y); - goto REAL_MOD; - - case T_REAL: - b = real(y); - if (b == 0.0) return(x); - if (is_NaN(b)) return(y); - if (is_inf(b)) return(real_NaN); - REAL_MOD: - c = a / b; - if (fabs(c) > 1e19) - sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, - set_elist_3(sc, sc->divide_symbol, x, y), - intermediate_too_large_string); - return(make_real(sc, a - b * (s7_int)floor(c))); - - default: - return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); - }} + s7_double c; + a = real(x); + if (!is_real(y)) + return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); + if (is_NaN(a)) return(x); + if (is_inf(a)) return(real_NaN); /* not b */ + if (fabs(a) > 1e17) + out_of_range_error_nr(sc, sc->modulo_symbol, int_one, x, it_is_too_large_string); + + switch (type(y)) + { + case T_INTEGER: + if (integer(y) == 0) return(x); + if ((integer(y) == S7_INT64_MIN) || (s7_int_abs(integer(y)) > QUOTIENT_INT_LIMIT)) + out_of_range_error_nr(sc, sc->modulo_symbol, int_two, y, it_is_too_large_string); + b = (s7_double)integer(y); + goto REAL_MOD; + + case T_RATIO: + b = fraction(y); + goto REAL_MOD; + + case T_REAL: + b = real(y); + if (b == 0.0) return(x); + if (is_NaN(b)) return(y); + if (is_inf(b)) return(real_NaN); + REAL_MOD: + c = a / b; + if (fabs(c) > 1e19) + sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, + set_elist_3(sc, sc->divide_symbol, x, y), + intermediate_too_large_string); + return(make_real(sc, a - b * (s7_int)floor(c))); + + default: + return(method_or_bust_pp(sc, y, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 2)); + }} default: return(method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 1)); @@ -22655,156 +22655,156 @@ static s7_pointer max_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if (type(x) == type(y)) { if (is_t_integer(x)) - return((integer(x) < integer(y)) ? y : x); + return((integer(x) < integer(y)) ? y : x); if (is_t_real(x)) - /* return(((is_NaN(real(x))) || (real(x) >= real(y))) ? x : y); */ - return(((real(x) >= real(y)) || (is_NaN(real(x)))) ? x : y); + /* return(((is_NaN(real(x))) || (real(x) >= real(y))) ? x : y); */ + return(((real(x) >= real(y)) || (is_NaN(real(x)))) ? x : y); if (is_t_ratio(x)) - return((fraction(x) < fraction(y)) ? y : x); + return((fraction(x) < fraction(y)) ? y : x); #if WITH_GMP if (is_t_big_integer(x)) - return((mpz_cmp(big_integer(x), big_integer(y)) < 0) ? y : x); + return((mpz_cmp(big_integer(x), big_integer(y)) < 0) ? y : x); if (is_t_big_ratio(x)) - return((mpq_cmp(big_ratio(x), big_ratio(y)) < 0) ? y : x); + return((mpq_cmp(big_ratio(x), big_ratio(y)) < 0) ? y : x); if (is_t_big_real(x)) - return(((mpfr_nan_p(big_real(x)) != 0) || (mpfr_greaterequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */ + return(((mpfr_nan_p(big_real(x)) != 0) || (mpfr_greaterequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */ #endif } switch (type(x)) { case T_INTEGER: switch (type(y)) - { - case T_RATIO: - return((integer(x) < fraction(y)) ? y : x); - case T_REAL: - return(((integer(x) < real(y)) || (is_NaN(real(y)))) ? y : x); + { + case T_RATIO: + return((integer(x) < fraction(y)) ? y : x); + case T_REAL: + return(((integer(x) < real(y)) || (is_NaN(real(y)))) ? y : x); #if WITH_GMP - case T_BIG_INTEGER: - return((mpz_cmp_si(big_integer(y), integer(x)) < 0) ? x : y); - case T_BIG_RATIO: - return((mpq_cmp_si(big_ratio(y), integer(x), 1) < 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_si(big_real(y), integer(x)) < 0) ? x : y); -#endif - default: - return(max_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + return((mpz_cmp_si(big_integer(y), integer(x)) < 0) ? x : y); + case T_BIG_RATIO: + return((mpq_cmp_si(big_ratio(y), integer(x), 1) < 0) ? x : y); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) return(y); + return((mpfr_cmp_si(big_real(y), integer(x)) < 0) ? x : y); +#endif + default: + return(max_out_y(sc, x, y)); + } break; case T_RATIO: switch (type(y)) - { - case T_INTEGER: - return((fraction(x) < integer(y)) ? y : x); - case T_REAL: - return(((fraction(x) < real(y)) || (is_NaN(real(y)))) ? y : x); + { + case T_INTEGER: + return((fraction(x) < integer(y)) ? y : x); + case T_REAL: + return(((fraction(x) < real(y)) || (is_NaN(real(y)))) ? y : x); #if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return((mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0) ? y : x); - case T_BIG_RATIO: - return((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) < 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return((mpfr_cmp_q(big_real(y), sc->mpq_1) < 0) ? x : y); -#endif - default: - return(max_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return((mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0) ? y : x); + case T_BIG_RATIO: + return((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) < 0) ? x : y); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) return(y); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return((mpfr_cmp_q(big_real(y), sc->mpq_1) < 0) ? x : y); +#endif + default: + return(max_out_y(sc, x, y)); + } case T_REAL: switch (type(y)) - { - case T_INTEGER: - return(((real(x) >= integer(y)) || (is_NaN(real(x)))) ? x : y); - case T_RATIO: - return((real(x) < fraction(y)) ? y : x); + { + case T_INTEGER: + return(((real(x) >= integer(y)) || (is_NaN(real(x)))) ? x : y); + case T_RATIO: + return((real(x) < fraction(y)) ? y : x); #if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(x); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0) ? y : x); - case T_BIG_RATIO: - if (is_NaN(real(x))) return(x); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0) ? y : x); - case T_BIG_REAL: - if (is_NaN(real(x))) return(x); - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_d(big_real(y), real(x)) < 0) ? x : y); -#endif - default: - return(max_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + if (is_NaN(real(x))) return(x); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0) ? y : x); + case T_BIG_RATIO: + if (is_NaN(real(x))) return(x); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0) ? y : x); + case T_BIG_REAL: + if (is_NaN(real(x))) return(x); + if (mpfr_nan_p(big_real(y))) return(y); + return((mpfr_cmp_d(big_real(y), real(x)) < 0) ? x : y); +#endif + default: + return(max_out_y(sc, x, y)); + } break; #if WITH_GMP case T_BIG_INTEGER: switch (type(y)) - { - case T_INTEGER: - return((mpz_cmp_si(big_integer(x), integer(y)) < 0) ? y : x); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return((mpq_cmp_z(sc->mpq_1, big_integer(x)) < 0) ? x : y); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x); - case T_BIG_RATIO: - return((mpq_cmp_z(big_ratio(y), big_integer(x)) < 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_z(big_real(y), big_integer(x)) < 0) ? x : y); - default: - return(max_out_y(sc, x, y)); - } + { + case T_INTEGER: + return((mpz_cmp_si(big_integer(x), integer(y)) < 0) ? y : x); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return((mpq_cmp_z(sc->mpq_1, big_integer(x)) < 0) ? x : y); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + return((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x); + case T_BIG_RATIO: + return((mpq_cmp_z(big_ratio(y), big_integer(x)) < 0) ? x : y); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) return(y); + return((mpfr_cmp_z(big_real(y), big_integer(x)) < 0) ? x : y); + default: + return(max_out_y(sc, x, y)); + } case T_BIG_RATIO: switch (type(y)) - { - case T_INTEGER: - return((mpq_cmp_si(big_ratio(x), integer(y), 1) < 0) ? y : x); - case T_RATIO: - return((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) < 0) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x); - case T_BIG_INTEGER: - return((mpq_cmp_z(big_ratio(x), big_integer(y)) < 0) ? y : x); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_q(big_real(y), big_ratio(x)) < 0) ? x : y); - default: - return(max_out_y(sc, x, y)); - } + { + case T_INTEGER: + return((mpq_cmp_si(big_ratio(x), integer(y), 1) < 0) ? y : x); + case T_RATIO: + return((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) < 0) ? y : x); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return((mpfr_cmp_d(sc->mpfr_1, real(y)) < 0) ? y : x); + case T_BIG_INTEGER: + return((mpq_cmp_z(big_ratio(x), big_integer(y)) < 0) ? y : x); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) return(y); + return((mpfr_cmp_q(big_real(y), big_ratio(x)) < 0) ? x : y); + default: + return(max_out_y(sc, x, y)); + } case T_BIG_REAL: switch (type(y)) - { - case T_INTEGER: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_si(big_real(x), integer(y)) < 0) ? y : x); - case T_RATIO: - if (mpfr_nan_p(big_real(x))) return(x); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return((mpfr_cmp_q(big_real(x), sc->mpq_1) < 0) ? y : x); - case T_REAL: - if (mpfr_nan_p(big_real(x))) return(x); - if (is_NaN(real(y))) return(y); - return((mpfr_cmp_d(big_real(x), real(y)) < 0) ? y : x); - case T_BIG_INTEGER: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_z(big_real(x), big_integer(y)) < 0) ? y : x); - case T_BIG_RATIO: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_q(big_real(x), big_ratio(y)) < 0) ? y : x); - default: - return(max_out_y(sc, x, y)); - } + { + case T_INTEGER: + if (mpfr_nan_p(big_real(x))) return(x); + return((mpfr_cmp_si(big_real(x), integer(y)) < 0) ? y : x); + case T_RATIO: + if (mpfr_nan_p(big_real(x))) return(x); + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return((mpfr_cmp_q(big_real(x), sc->mpq_1) < 0) ? y : x); + case T_REAL: + if (mpfr_nan_p(big_real(x))) return(x); + if (is_NaN(real(y))) return(y); + return((mpfr_cmp_d(big_real(x), real(y)) < 0) ? y : x); + case T_BIG_INTEGER: + if (mpfr_nan_p(big_real(x))) return(x); + return((mpfr_cmp_z(big_real(x), big_integer(y)) < 0) ? y : x); + case T_BIG_RATIO: + if (mpfr_nan_p(big_real(x))) return(x); + return((mpfr_cmp_q(big_real(x), big_ratio(y)) < 0) ? y : x); + default: + return(max_out_y(sc, x, y)); + } #endif default: return(max_out_x(sc, x, y)); @@ -22852,155 +22852,155 @@ static s7_pointer min_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if (type(x) == type(y)) { if (is_t_integer(x)) - return((integer(x) > integer(y)) ? y : x); + return((integer(x) > integer(y)) ? y : x); if (is_t_real(x)) - /* return(((is_NaN(real(x))) || (real(x) <= real(y))) ? x : y); */ - return(((real(x) <= real(y)) || (is_NaN(real(x)))) ? x : y); + /* return(((is_NaN(real(x))) || (real(x) <= real(y))) ? x : y); */ + return(((real(x) <= real(y)) || (is_NaN(real(x)))) ? x : y); if (is_t_ratio(x)) - return((fraction(x) > fraction(y)) ? y : x); + return((fraction(x) > fraction(y)) ? y : x); #if WITH_GMP if (is_t_big_integer(x)) - return((mpz_cmp(big_integer(x), big_integer(y)) > 0) ? y : x); + return((mpz_cmp(big_integer(x), big_integer(y)) > 0) ? y : x); if (is_t_big_ratio(x)) - return((mpq_cmp(big_ratio(x), big_ratio(y)) > 0) ? y : x); + return((mpq_cmp(big_ratio(x), big_ratio(y)) > 0) ? y : x); if (is_t_big_real(x)) - return(((mpfr_nan_p(big_real(x)) != 0) || (mpfr_lessequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */ + return(((mpfr_nan_p(big_real(x)) != 0) || (mpfr_lessequal_p(big_real(x), big_real(y)))) ? x : y); /* ?? */ #endif } switch (type(x)) { case T_INTEGER: switch (type(y)) - { - case T_RATIO: return((integer(x) > fraction(y)) ? y : x); - case T_REAL: - return(((integer(x) > real(y)) || (is_NaN(real(y)))) ? y : x); + { + case T_RATIO: return((integer(x) > fraction(y)) ? y : x); + case T_REAL: + return(((integer(x) > real(y)) || (is_NaN(real(y)))) ? y : x); #if WITH_GMP - case T_BIG_INTEGER: return((mpz_cmp_si(big_integer(y), integer(x)) > 0) ? x : y); - case T_BIG_RATIO: return((mpq_cmp_si(big_ratio(y), integer(x), 1) > 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_si(big_real(y), integer(x)) > 0) ? x : y); -#endif - default: - return(min_out_y(sc, x, y)); - } + case T_BIG_INTEGER: return((mpz_cmp_si(big_integer(y), integer(x)) > 0) ? x : y); + case T_BIG_RATIO: return((mpq_cmp_si(big_ratio(y), integer(x), 1) > 0) ? x : y); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) return(y); + return((mpfr_cmp_si(big_real(y), integer(x)) > 0) ? x : y); +#endif + default: + return(min_out_y(sc, x, y)); + } break; case T_RATIO: switch (type(y)) - { - case T_INTEGER: - return((fraction(x) > integer(y)) ? y : x); - case T_REAL: - return(((fraction(x) > real(y)) || (is_NaN(real(y)))) ? y : x); + { + case T_INTEGER: + return((fraction(x) > integer(y)) ? y : x); + case T_REAL: + return(((fraction(x) > real(y)) || (is_NaN(real(y)))) ? y : x); #if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return((mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0) ? y : x); - case T_BIG_RATIO: - return((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) > 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return((mpfr_cmp_q(big_real(y), sc->mpq_1) > 0) ? x : y); -#endif - default: - return(min_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return((mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0) ? y : x); + case T_BIG_RATIO: + return((mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) > 0) ? x : y); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) return(y); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return((mpfr_cmp_q(big_real(y), sc->mpq_1) > 0) ? x : y); +#endif + default: + return(min_out_y(sc, x, y)); + } case T_REAL: switch (type(y)) - { - case T_INTEGER: - return(((real(x) <= integer(y)) || (is_NaN(real(x)))) ? x : y); - case T_RATIO: - return((real(x) > fraction(y)) ? y : x); + { + case T_INTEGER: + return(((real(x) <= integer(y)) || (is_NaN(real(x)))) ? x : y); + case T_RATIO: + return((real(x) > fraction(y)) ? y : x); #if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(x); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0) ? y : x); - - case T_BIG_RATIO: - if (is_NaN(real(x))) return(x); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0) ? y : x); - - case T_BIG_REAL: - if (is_NaN(real(x))) return(x); - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_d(big_real(y), real(x)) > 0) ? x : y); -#endif - default: - return(min_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + if (is_NaN(real(x))) return(x); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return((mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0) ? y : x); + + case T_BIG_RATIO: + if (is_NaN(real(x))) return(x); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return((mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0) ? y : x); + + case T_BIG_REAL: + if (is_NaN(real(x))) return(x); + if (mpfr_nan_p(big_real(y))) return(y); + return((mpfr_cmp_d(big_real(y), real(x)) > 0) ? x : y); +#endif + default: + return(min_out_y(sc, x, y)); + } break; #if WITH_GMP case T_BIG_INTEGER: switch (type(y)) - { - case T_INTEGER: - return((mpz_cmp_si(big_integer(x), integer(y)) > 0) ? y : x); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return((mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) > 0) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x); - case T_BIG_RATIO: - return((mpq_cmp_z(big_ratio(y), big_integer(x)) > 0) ? x : y); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_z(big_real(y), big_integer(x)) > 0) ? x : y); - default: - return(min_out_y(sc, x, y)); - } + { + case T_INTEGER: + return((mpz_cmp_si(big_integer(x), integer(y)) > 0) ? y : x); + case T_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + return((mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) > 0) ? y : x); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + return((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x); + case T_BIG_RATIO: + return((mpq_cmp_z(big_ratio(y), big_integer(x)) > 0) ? x : y); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) return(y); + return((mpfr_cmp_z(big_real(y), big_integer(x)) > 0) ? x : y); + default: + return(min_out_y(sc, x, y)); + } case T_BIG_RATIO: switch (type(y)) - { - case T_INTEGER: - return((mpq_cmp_si(big_ratio(x), integer(y), 1) > 0) ? y : x); - case T_RATIO: - return((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) > 0) ? y : x); - case T_REAL: - if (is_NaN(real(y))) return(y); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x); - case T_BIG_INTEGER: - return((mpq_cmp_z(big_ratio(x), big_integer(y)) > 0) ? y : x); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(y); - return((mpfr_cmp_q(big_real(y), big_ratio(x)) > 0) ? x : y); - default: - return(min_out_y(sc, x, y)); - } + { + case T_INTEGER: + return((mpq_cmp_si(big_ratio(x), integer(y), 1) > 0) ? y : x); + case T_RATIO: + return((mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) > 0) ? y : x); + case T_REAL: + if (is_NaN(real(y))) return(y); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return((mpfr_cmp_d(sc->mpfr_1, real(y)) > 0) ? y : x); + case T_BIG_INTEGER: + return((mpq_cmp_z(big_ratio(x), big_integer(y)) > 0) ? y : x); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) return(y); + return((mpfr_cmp_q(big_real(y), big_ratio(x)) > 0) ? x : y); + default: + return(min_out_y(sc, x, y)); + } case T_BIG_REAL: switch (type(y)) - { - case T_INTEGER: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_si(big_real(x), integer(y)) > 0) ? y : x); - case T_RATIO: - if (mpfr_nan_p(big_real(x))) return(x); - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return((mpfr_cmp_q(big_real(x), sc->mpq_1) > 0) ? y : x); - case T_REAL: - if (mpfr_nan_p(big_real(x))) return(x); - if (is_NaN(real(y))) return(y); - return((mpfr_cmp_d(big_real(x), real(y)) > 0) ? y : x); - case T_BIG_INTEGER: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_z(big_real(x), big_integer(y)) > 0) ? y : x); - case T_BIG_RATIO: - if (mpfr_nan_p(big_real(x))) return(x); - return((mpfr_cmp_q(big_real(x), big_ratio(y)) > 0) ? y : x); - default: - return(min_out_y(sc, x, y)); - } + { + case T_INTEGER: + if (mpfr_nan_p(big_real(x))) return(x); + return((mpfr_cmp_si(big_real(x), integer(y)) > 0) ? y : x); + case T_RATIO: + if (mpfr_nan_p(big_real(x))) return(x); + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return((mpfr_cmp_q(big_real(x), sc->mpq_1) > 0) ? y : x); + case T_REAL: + if (mpfr_nan_p(big_real(x))) return(x); + if (is_NaN(real(y))) return(y); + return((mpfr_cmp_d(big_real(x), real(y)) > 0) ? y : x); + case T_BIG_INTEGER: + if (mpfr_nan_p(big_real(x))) return(x); + return((mpfr_cmp_z(big_real(x), big_integer(y)) > 0) ? y : x); + case T_BIG_RATIO: + if (mpfr_nan_p(big_real(x))) return(x); + return((mpfr_cmp_q(big_real(x), big_ratio(y)) > 0) ? y : x); + default: + return(min_out_y(sc, x, y)); + } #endif default: return(min_out_x(sc, x, y)); @@ -23061,27 +23061,27 @@ static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if (type(x) == type(y)) { if (is_t_integer(x)) - return(integer(x) == integer(y)); + return(integer(x) == integer(y)); if (is_t_real(x)) - return(real(x) == real(y)); + return(real(x) == real(y)); if (is_t_complex(x)) - return((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y))); + return((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y))); if (is_t_ratio(x)) - return((numerator(x) == numerator(y)) && (denominator(x) == denominator(y))); + return((numerator(x) == numerator(y)) && (denominator(x) == denominator(y))); #if WITH_GMP if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) == 0); + return(mpz_cmp(big_integer(x), big_integer(y)) == 0); if (is_t_big_ratio(x)) - return(mpq_equal(big_ratio(x), big_ratio(y))); + return(mpq_equal(big_ratio(x), big_ratio(y))); if (is_t_big_real(x)) - return(mpfr_equal_p(big_real(x), big_real(y))); + return(mpfr_equal_p(big_real(x), big_real(y))); if (is_t_big_complex(x)) /* mpc_cmp can't handle NaN */ - { - if ((mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x)))) || - (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) - return(false); - return(mpc_cmp(big_complex(x), big_complex(y)) == 0); - } + { + if ((mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x)))) || + (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) + return(false); + return(mpc_cmp(big_complex(x), big_complex(y)) == 0); + } #endif } @@ -23089,166 +23089,166 @@ static bool num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { case T_INTEGER: switch (type(y)) - { - case T_RATIO: - return(false); - case T_REAL: + { + case T_RATIO: + return(false); + case T_REAL: #if WITH_GMP - if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) - { - if (is_NaN(real(y))) return(false); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_cmp_si(sc->mpfr_1, integer(x)) == 0); - } -#endif - return(integer(x) == real(y)); - case T_COMPLEX: - return(false); + if (s7_int_abs(integer(x)) >= INT64_TO_DOUBLE_LIMIT) + { + if (is_NaN(real(y))) return(false); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + return(mpfr_cmp_si(sc->mpfr_1, integer(x)) == 0); + } +#endif + return(integer(x) == real(y)); + case T_COMPLEX: + return(false); #if WITH_GMP - case T_BIG_INTEGER: - return((mpz_fits_slong_p(big_integer(y))) && (integer(x) == mpz_get_si(big_integer(y)))); - case T_BIG_RATIO: - return(false); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) == 0)); - case T_BIG_COMPLEX: - return(false); -#endif - default: return(eq_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + return((mpz_fits_slong_p(big_integer(y))) && (integer(x) == mpz_get_si(big_integer(y)))); + case T_BIG_RATIO: + return(false); + case T_BIG_REAL: + return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) == 0)); + case T_BIG_COMPLEX: + return(false); +#endif + default: return(eq_out_y(sc, x, y)); + } break; case T_RATIO: switch (type(y)) - { - case T_INTEGER: return(false); - case T_REAL: return(fraction(x) == real(y)); - case T_COMPLEX: return(false); + { + case T_INTEGER: return(false); + case T_REAL: return(fraction(x) == real(y)); + case T_COMPLEX: return(false); #if WITH_GMP - case T_BIG_INTEGER: - return(false); - case T_BIG_RATIO: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_equal(sc->mpq_1, big_ratio(y))); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(false); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) == 0); - case T_BIG_COMPLEX: - return(false); -#endif - default: return(eq_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + return(false); + case T_BIG_RATIO: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return(mpq_equal(sc->mpq_1, big_ratio(y))); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) return(false); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return(mpfr_cmp_q(big_real(y), sc->mpq_1) == 0); + case T_BIG_COMPLEX: + return(false); +#endif + default: return(eq_out_y(sc, x, y)); + } break; case T_REAL: switch (type(y)) - { - case T_INTEGER: - return(real(x) == integer(y)); - case T_RATIO: - return(real(x) == fraction(y)); - case T_COMPLEX: - return(false); + { + case T_INTEGER: + return(real(x) == integer(y)); + case T_RATIO: + return(real(x) == fraction(y)); + case T_COMPLEX: + return(false); #if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) == 0); - case T_BIG_RATIO: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) == 0); - case T_BIG_REAL: - if (is_NaN(real(x))) return(false); - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) == 0)); - case T_BIG_COMPLEX: - return(false); -#endif - default: return(eq_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + if (is_NaN(real(x))) return(false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) == 0); + case T_BIG_RATIO: + if (is_NaN(real(x))) return(false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) == 0); + case T_BIG_REAL: + if (is_NaN(real(x))) return(false); + return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) == 0)); + case T_BIG_COMPLEX: + return(false); +#endif + default: return(eq_out_y(sc, x, y)); + } break; case T_COMPLEX: if (is_real(y)) return(false); #if WITH_GMP if (is_t_big_complex(y)) - { - if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) || - (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) - return(false); - mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); - return(mpc_cmp(big_complex(y), sc->mpc_1) == 0); - } + { + if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) || + (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) + return(false); + mpc_set_d_d(sc->mpc_1, real_part(x), imag_part(x), MPC_RNDNN); + return(mpc_cmp(big_complex(y), sc->mpc_1) == 0); + } #endif return(eq_out_y(sc, x, y)); #if WITH_GMP case T_BIG_INTEGER: switch (type(y)) - { - case T_INTEGER: - return((mpz_fits_slong_p(big_integer(x))) && (integer(y) == mpz_get_si(big_integer(x)))); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(x)) == 0); - case T_RATIO: case T_COMPLEX: case T_BIG_RATIO: case T_BIG_COMPLEX: - return(false); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) == 0)); - default: return(eq_out_y(sc, x, y)); - } + { + case T_INTEGER: + return((mpz_fits_slong_p(big_integer(x))) && (integer(y) == mpz_get_si(big_integer(x)))); + case T_REAL: + if (is_NaN(real(y))) return(false); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + return(mpfr_cmp_z(sc->mpfr_1, big_integer(x)) == 0); + case T_RATIO: case T_COMPLEX: case T_BIG_RATIO: case T_BIG_COMPLEX: + return(false); + case T_BIG_REAL: + return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) == 0)); + default: return(eq_out_y(sc, x, y)); + } case T_BIG_RATIO: switch (type(y)) - { - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpq_equal(sc->mpq_1, big_ratio(x))); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) == 0); - case T_INTEGER: case T_BIG_INTEGER: case T_COMPLEX: case T_BIG_COMPLEX: - return(false); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) == 0)); - default: return(eq_out_y(sc, x, y)); - } + { + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return(mpq_equal(sc->mpq_1, big_ratio(x))); + case T_REAL: + if (is_NaN(real(y))) return(false); + mpfr_set_d(sc->mpfr_1, real(y), MPFR_RNDN); + return(mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) == 0); + case T_INTEGER: case T_BIG_INTEGER: case T_COMPLEX: case T_BIG_COMPLEX: + return(false); + case T_BIG_REAL: + return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) == 0)); + default: return(eq_out_y(sc, x, y)); + } case T_BIG_REAL: if ((is_number(y)) && (mpfr_nan_p(big_real(x)))) return(false); switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) == 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) == 0); - case T_REAL: - return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) == 0)); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) == 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) == 0); - case T_COMPLEX: case T_BIG_COMPLEX: - return(false); - default: return(eq_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpfr_cmp_si(big_real(x), integer(y)) == 0); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return(mpfr_cmp_q(big_real(x), sc->mpq_1) == 0); + case T_REAL: + return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) == 0)); + case T_BIG_INTEGER: + return(mpfr_cmp_z(big_real(x), big_integer(y)) == 0); + case T_BIG_RATIO: + return(mpfr_cmp_q(big_real(x), big_ratio(y)) == 0); + case T_COMPLEX: case T_BIG_COMPLEX: + return(false); + default: return(eq_out_y(sc, x, y)); + } case T_BIG_COMPLEX: switch (type(y)) - { - case T_RATIO: case T_REAL: case T_INTEGER: case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(false); - case T_COMPLEX: - if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || - (mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x))))) - return(false); - mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); - return(mpc_cmp(big_complex(x), sc->mpc_1) == 0); /* NaN's not allowed! */ - default: return(eq_out_y(sc, x, y)); - } + { + case T_RATIO: case T_REAL: case T_INTEGER: case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: + return(false); + case T_COMPLEX: + if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y))) || + (mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x))))) + return(false); + mpc_set_d_d(sc->mpc_1, real_part(y), imag_part(y), MPC_RNDNN); + return(mpc_cmp(big_complex(x), sc->mpc_1) == 0); /* NaN's not allowed! */ + default: return(eq_out_y(sc, x, y)); + } #endif default: return(eq_out_x(sc, x, y)); } @@ -23263,7 +23263,7 @@ static bool is_number_via_method(s7_scheme *sc, s7_pointer p) { s7_pointer f = find_method_with_let(sc, p, sc->is_number_symbol); if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); + return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); } return(false); } @@ -23280,10 +23280,10 @@ static s7_pointer g_num_eq(s7_scheme *sc, s7_pointer args) for (; is_pair(p); p = cdr(p)) if (!num_eq_b_7pp(sc, x, car(p))) { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_number_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->num_eq_symbol, position_of(p, args), car(p), a_number_string); - return(sc->F); + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_number_via_method(sc, car(p))) + wrong_type_error_nr(sc, sc->num_eq_symbol, position_of(p, args), car(p), a_number_string); + return(sc->F); } return(sc->T); } @@ -23398,127 +23398,127 @@ static bool lt_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if (type(x) == type(y)) { if (is_t_integer(x)) - return(integer(x) < integer(y)); + return(integer(x) < integer(y)); if (is_t_real(x)) - return(real(x) < real(y)); + return(real(x) < real(y)); if (is_t_ratio(x)) - return(fraction(x) < fraction(y)); + return(fraction(x) < fraction(y)); #if WITH_GMP if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) < 0); + return(mpz_cmp(big_integer(x), big_integer(y)) < 0); if (is_t_big_ratio(x)) - return(mpq_cmp(big_ratio(x), big_ratio(y)) < 0); + return(mpq_cmp(big_ratio(x), big_ratio(y)) < 0); if (is_t_big_real(x)) - return(mpfr_less_p(big_real(x), big_real(y))); + return(mpfr_less_p(big_real(x), big_real(y))); #endif } switch (type(x)) { case T_INTEGER: switch (type(y)) - { - case T_RATIO: return(integer(x) < fraction(y)); /* ?? */ - case T_REAL: return(integer(x) < real(y)); + { + case T_RATIO: return(integer(x) < fraction(y)); /* ?? */ + case T_REAL: return(integer(x) < real(y)); #if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) > 0); - case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) > 0); - case T_BIG_REAL: return(mpfr_cmp_si(big_real(y), integer(x)) > 0); + case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) > 0); + case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) > 0); + case T_BIG_REAL: return(mpfr_cmp_si(big_real(y), integer(x)) > 0); #endif - default: return(lt_out_y(sc, x, y)); - } + default: return(lt_out_y(sc, x, y)); + } break; case T_RATIO: switch (type(y)) - { - case T_INTEGER: return(fraction(x) < integer(y)); - case T_REAL: return(fraction(x) < real(y)); + { + case T_INTEGER: return(fraction(x) < integer(y)); + case T_REAL: return(fraction(x) < real(y)); #if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0); - case T_BIG_RATIO: - return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) > 0); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) > 0); -#endif - default: return(lt_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return(mpq_cmp_z(sc->mpq_1, big_integer(y)) < 0); + case T_BIG_RATIO: + return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) > 0); + case T_BIG_REAL: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return(mpfr_cmp_q(big_real(y), sc->mpq_1) > 0); +#endif + default: return(lt_out_y(sc, x, y)); + } case T_REAL: switch (type(y)) - { - case T_INTEGER: return(real(x) < integer(y)); - case T_RATIO: return(real(x) < fraction(y)); + { + case T_INTEGER: return(real(x) < integer(y)); + case T_RATIO: return(real(x) < fraction(y)); #if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0); - case T_BIG_REAL: - return(mpfr_cmp_d(big_real(y), real(x)) > 0); -#endif - default: return(lt_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + if (is_NaN(real(x))) return(false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) < 0); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) < 0); + case T_BIG_REAL: + return(mpfr_cmp_d(big_real(y), real(x)) > 0); +#endif + default: return(lt_out_y(sc, x, y)); + } break; #if WITH_GMP case T_BIG_INTEGER: switch (type(y)) - { - case T_INTEGER: - return(mpz_cmp_si(big_integer(x), integer(y)) < 0); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) < 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) < 0); - case T_BIG_RATIO: - return(mpq_cmp_z(big_ratio(y), big_integer(x)) > 0); - case T_BIG_REAL: - return(mpfr_cmp_z(big_real(y), big_integer(x)) > 0); - default: return(lt_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpz_cmp_si(big_integer(x), integer(y)) < 0); + case T_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) < 0); + case T_REAL: + if (is_NaN(real(y))) return(false); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + return(mpfr_cmp_d(sc->mpfr_1, real(y)) < 0); + case T_BIG_RATIO: + return(mpq_cmp_z(big_ratio(y), big_integer(x)) > 0); + case T_BIG_REAL: + return(mpfr_cmp_z(big_real(y), big_integer(x)) > 0); + default: return(lt_out_y(sc, x, y)); + } case T_BIG_RATIO: switch (type(y)) - { - case T_INTEGER: - return(mpq_cmp_si(big_ratio(x), integer(y), 1) < 0); - case T_RATIO: - return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) < 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) < 0); - case T_BIG_INTEGER: - return(mpq_cmp_z(big_ratio(x), big_integer(y)) < 0); - case T_BIG_REAL: - return(mpfr_cmp_q(big_real(y), big_ratio(x)) > 0); - default: return(lt_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpq_cmp_si(big_ratio(x), integer(y), 1) < 0); + case T_RATIO: + return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) < 0); + case T_REAL: + if (is_NaN(real(y))) return(false); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return(mpfr_cmp_d(sc->mpfr_1, real(y)) < 0); + case T_BIG_INTEGER: + return(mpq_cmp_z(big_ratio(x), big_integer(y)) < 0); + case T_BIG_REAL: + return(mpfr_cmp_q(big_real(y), big_ratio(x)) > 0); + default: return(lt_out_y(sc, x, y)); + } case T_BIG_REAL: switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) < 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) < 0); - case T_REAL: - return(mpfr_cmp_d(big_real(x), real(y)) < 0); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) < 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) < 0); - default: return(lt_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpfr_cmp_si(big_real(x), integer(y)) < 0); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return(mpfr_cmp_q(big_real(x), sc->mpq_1) < 0); + case T_REAL: + return(mpfr_cmp_d(big_real(x), real(y)) < 0); + case T_BIG_INTEGER: + return(mpfr_cmp_z(big_real(x), big_integer(y)) < 0); + case T_BIG_RATIO: + return(mpfr_cmp_q(big_real(x), big_ratio(y)) < 0); + default: return(lt_out_y(sc, x, y)); + } #endif default: return(lt_out_x(sc, x, y)); } @@ -23537,12 +23537,12 @@ static s7_pointer g_less(s7_scheme *sc, s7_pointer args) for (; is_pair(p); p = cdr(p)) { if (!lt_b_7pp(sc, x, car(p))) - { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->lt_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); - return(sc->F); - } + { + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_real_via_method(sc, car(p))) + wrong_type_error_nr(sc, sc->lt_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); + return(sc->F); + } x = car(p); } return(sc->T); @@ -23660,9 +23660,9 @@ static s7_pointer less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_poi if (is_t_integer(arg2)) { if (integer(arg2) == 0) - return(sc->less_x0); + return(sc->less_x0); if ((integer(arg2) < S7_INT32_MAX) && (integer(arg2) > S7_INT32_MIN)) - return(sc->less_xi); + return(sc->less_xi); } if (is_t_real(arg2)) return(sc->less_xf); @@ -23692,132 +23692,132 @@ static bool leq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if (type(x) == type(y)) { if (is_t_integer(x)) - return(integer(x) <= integer(y)); + return(integer(x) <= integer(y)); if (is_t_real(x)) - return(real(x) <= real(y)); + return(real(x) <= real(y)); if (is_t_ratio(x)) - return(fraction(x) <= fraction(y)); + return(fraction(x) <= fraction(y)); #if WITH_GMP if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) <= 0); + return(mpz_cmp(big_integer(x), big_integer(y)) <= 0); if (is_t_big_ratio(x)) - return(mpq_cmp(big_ratio(x), big_ratio(y)) <= 0); + return(mpq_cmp(big_ratio(x), big_ratio(y)) <= 0); if (is_t_big_real(x)) - return(mpfr_lessequal_p(big_real(x), big_real(y))); + return(mpfr_lessequal_p(big_real(x), big_real(y))); #endif } switch (type(x)) { case T_INTEGER: switch (type(y)) - { - case T_RATIO: return(integer(x) <= fraction(y)); /* ?? */ - case T_REAL: return(integer(x) <= real(y)); + { + case T_RATIO: return(integer(x) <= fraction(y)); /* ?? */ + case T_REAL: return(integer(x) <= real(y)); #if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) >= 0); - case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) >= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) >= 0)); + case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) >= 0); + case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) >= 0); + case T_BIG_REAL: + return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) >= 0)); #endif - default: return(leq_out_y(sc, x, y)); - } + default: return(leq_out_y(sc, x, y)); + } break; case T_RATIO: switch (type(y)) - { - case T_INTEGER: return(fraction(x) <= integer(y)); - case T_REAL: return(fraction(x) <= real(y)); + { + case T_INTEGER: return(fraction(x) <= integer(y)); + case T_REAL: return(fraction(x) <= real(y)); #if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_cmp_z(sc->mpq_1, big_integer(y)) <= 0); - case T_BIG_RATIO: - return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) >= 0); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(false); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) >= 0); -#endif - default: return(leq_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return(mpq_cmp_z(sc->mpq_1, big_integer(y)) <= 0); + case T_BIG_RATIO: + return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) >= 0); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) return(false); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return(mpfr_cmp_q(big_real(y), sc->mpq_1) >= 0); +#endif + default: return(leq_out_y(sc, x, y)); + } case T_REAL: switch (type(y)) - { - case T_INTEGER: return(real(x) <= integer(y)); - case T_RATIO: return(real(x) <= fraction(y)); + { + case T_INTEGER: return(real(x) <= integer(y)); + case T_RATIO: return(real(x) <= fraction(y)); #if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) <= 0); - case T_BIG_RATIO: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) <= 0); - case T_BIG_REAL: - if (is_NaN(real(x))) return(false); - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) >= 0)); -#endif - default: return(leq_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + if (is_NaN(real(x))) return(false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) <= 0); + case T_BIG_RATIO: + if (is_NaN(real(x))) return(false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) <= 0); + case T_BIG_REAL: + if (is_NaN(real(x))) return(false); + return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) >= 0)); +#endif + default: return(leq_out_y(sc, x, y)); + } break; #if WITH_GMP case T_BIG_INTEGER: switch (type(y)) - { - case T_INTEGER: - return(mpz_cmp_si(big_integer(x), integer(y)) <= 0); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) <= 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0); - case T_BIG_RATIO: - return(mpq_cmp_z(big_ratio(y), big_integer(x)) >= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) >= 0)); - default: return(leq_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpz_cmp_si(big_integer(x), integer(y)) <= 0); + case T_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) <= 0); + case T_REAL: + if (is_NaN(real(y))) return(false); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + return(mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0); + case T_BIG_RATIO: + return(mpq_cmp_z(big_ratio(y), big_integer(x)) >= 0); + case T_BIG_REAL: + return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) >= 0)); + default: return(leq_out_y(sc, x, y)); + } case T_BIG_RATIO: switch (type(y)) - { - case T_INTEGER: - return(mpq_cmp_si(big_ratio(x), integer(y), 1) <= 0); - case T_RATIO: - return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) <= 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0); - case T_BIG_INTEGER: - return(mpq_cmp_z(big_ratio(x), big_integer(y)) <= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) >= 0)); - default: return(leq_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpq_cmp_si(big_ratio(x), integer(y), 1) <= 0); + case T_RATIO: + return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) <= 0); + case T_REAL: + if (is_NaN(real(y))) return(false); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return(mpfr_cmp_d(sc->mpfr_1, real(y)) <= 0); + case T_BIG_INTEGER: + return(mpq_cmp_z(big_ratio(x), big_integer(y)) <= 0); + case T_BIG_REAL: + return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) >= 0)); + default: return(leq_out_y(sc, x, y)); + } case T_BIG_REAL: if ((is_real(y)) && (mpfr_nan_p(big_real(x)))) return(false); switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) <= 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) <= 0); - case T_REAL: - return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) <= 0)); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) <= 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) <= 0); - default: return(leq_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpfr_cmp_si(big_real(x), integer(y)) <= 0); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return(mpfr_cmp_q(big_real(x), sc->mpq_1) <= 0); + case T_REAL: + return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) <= 0)); + case T_BIG_INTEGER: + return(mpfr_cmp_z(big_real(x), big_integer(y)) <= 0); + case T_BIG_RATIO: + return(mpfr_cmp_q(big_real(x), big_ratio(y)) <= 0); + default: return(leq_out_y(sc, x, y)); + } #endif default: return(leq_out_x(sc, x, y)); } @@ -23837,10 +23837,10 @@ static s7_pointer g_less_or_equal(s7_scheme *sc, s7_pointer args) for (; is_pair(p); x = car(p), p = cdr(p)) if (!leq_b_7pp(sc, x, car(p))) { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->leq_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); - return(sc->F); + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_real_via_method(sc, car(p))) + wrong_type_error_nr(sc, sc->leq_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); + return(sc->F); } return(sc->T); } @@ -23916,13 +23916,13 @@ static s7_pointer g_leq_ixx(s7_scheme *sc, s7_pointer args) if (is_t_integer(car(p))) { if (integer(car(args)) > integer(car(p))) - { - if (!is_real_via_method(sc, cadr(p))) - wrong_type_error_nr(sc, sc->leq_symbol, 3, cadr(p), sc->type_names[T_REAL]); - return(sc->F); - } + { + if (!is_real_via_method(sc, cadr(p))) + wrong_type_error_nr(sc, sc->leq_symbol, 3, cadr(p), sc->type_names[T_REAL]); + return(sc->F); + } if (is_t_integer(cadr(p))) - return((integer(car(p)) > integer(cadr(p))) ? sc->F : sc->T); + return((integer(car(p)) > integer(cadr(p))) ? sc->F : sc->T); } return(g_less_or_equal(sc, args)); } @@ -23934,7 +23934,7 @@ static s7_pointer leq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_poin { arg2 = caddr(expr); if ((is_t_integer(arg2)) && (integer(arg2) < S7_INT32_MAX) && (integer(arg2) > S7_INT32_MIN)) - return(sc->leq_xi); + return(sc->leq_xi); return(sc->leq_2); } if ((args == 3) && (is_t_integer(cadr(expr)))) @@ -23965,126 +23965,126 @@ static bool gt_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if (type(x) == type(y)) { if (is_t_integer(x)) - return(integer(x) > integer(y)); + return(integer(x) > integer(y)); if (is_t_real(x)) - return(real(x) > real(y)); + return(real(x) > real(y)); if (is_t_ratio(x)) - return(fraction(x) > fraction(y)); + return(fraction(x) > fraction(y)); #if WITH_GMP if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) > 0); + return(mpz_cmp(big_integer(x), big_integer(y)) > 0); if (is_t_big_ratio(x)) - return(mpq_cmp(big_ratio(x), big_ratio(y)) > 0); + return(mpq_cmp(big_ratio(x), big_ratio(y)) > 0); if (is_t_big_real(x)) - return(mpfr_greater_p(big_real(x), big_real(y))); + return(mpfr_greater_p(big_real(x), big_real(y))); #endif } switch (type(x)) { case T_INTEGER: switch (type(y)) - { - case T_RATIO: return(integer(x) > fraction(y)); /* ?? */ - case T_REAL: return(integer(x) > real(y)); + { + case T_RATIO: return(integer(x) > fraction(y)); /* ?? */ + case T_REAL: return(integer(x) > real(y)); #if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) < 0); - case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) < 0); - case T_BIG_REAL: return(mpfr_cmp_si(big_real(y), integer(x)) < 0); + case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) < 0); + case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) < 0); + case T_BIG_REAL: return(mpfr_cmp_si(big_real(y), integer(x)) < 0); #endif - default: return(gt_out_y(sc, x, y)); - } + default: return(gt_out_y(sc, x, y)); + } break; case T_RATIO: switch (type(y)) - { - case T_INTEGER: return(fraction(x) > integer(y)); - case T_REAL: return(fraction(x) > real(y)); + { + case T_INTEGER: return(fraction(x) > integer(y)); + case T_REAL: return(fraction(x) > real(y)); #if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0); - case T_BIG_RATIO: - return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) < 0); - case T_BIG_REAL: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) < 0); -#endif - default: return(gt_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return(mpq_cmp_z(sc->mpq_1, big_integer(y)) > 0); + case T_BIG_RATIO: + return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) < 0); + case T_BIG_REAL: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return(mpfr_cmp_q(big_real(y), sc->mpq_1) < 0); +#endif + default: return(gt_out_y(sc, x, y)); + } case T_REAL: switch (type(y)) - { - case T_INTEGER: return(real(x) > integer(y)); - case T_RATIO: return(real(x) > fraction(y)); + { + case T_INTEGER: return(real(x) > integer(y)); + case T_RATIO: return(real(x) > fraction(y)); #if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0); - case T_BIG_RATIO: - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0); - case T_BIG_REAL: - return(mpfr_cmp_d(big_real(y), real(x)) < 0); -#endif - default: return(gt_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + if (is_NaN(real(x))) return(false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) > 0); + case T_BIG_RATIO: + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) > 0); + case T_BIG_REAL: + return(mpfr_cmp_d(big_real(y), real(x)) < 0); +#endif + default: return(gt_out_y(sc, x, y)); + } break; #if WITH_GMP case T_BIG_INTEGER: switch (type(y)) - { - case T_INTEGER: - return(mpz_cmp_si(big_integer(x), integer(y)) > 0); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) > 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) > 0); - case T_BIG_RATIO: - return(mpq_cmp_z(big_ratio(y), big_integer(x)) < 0); - case T_BIG_REAL: - return(mpfr_cmp_z(big_real(y), big_integer(x)) < 0); - default: return(gt_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpz_cmp_si(big_integer(x), integer(y)) > 0); + case T_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) > 0); + case T_REAL: + if (is_NaN(real(y))) return(false); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + return(mpfr_cmp_d(sc->mpfr_1, real(y)) > 0); + case T_BIG_RATIO: + return(mpq_cmp_z(big_ratio(y), big_integer(x)) < 0); + case T_BIG_REAL: + return(mpfr_cmp_z(big_real(y), big_integer(x)) < 0); + default: return(gt_out_y(sc, x, y)); + } case T_BIG_RATIO: switch (type(y)) - { - case T_INTEGER: - return(mpq_cmp_si(big_ratio(x), integer(y), 1) > 0); - case T_RATIO: - return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) > 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) > 0); - case T_BIG_INTEGER: - return(mpq_cmp_z(big_ratio(x), big_integer(y)) > 0); - case T_BIG_REAL: - return(mpfr_cmp_q(big_real(y), big_ratio(x)) < 0); - default: return(gt_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpq_cmp_si(big_ratio(x), integer(y), 1) > 0); + case T_RATIO: + return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) > 0); + case T_REAL: + if (is_NaN(real(y))) return(false); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return(mpfr_cmp_d(sc->mpfr_1, real(y)) > 0); + case T_BIG_INTEGER: + return(mpq_cmp_z(big_ratio(x), big_integer(y)) > 0); + case T_BIG_REAL: + return(mpfr_cmp_q(big_real(y), big_ratio(x)) < 0); + default: return(gt_out_y(sc, x, y)); + } case T_BIG_REAL: switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) > 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) > 0); - case T_REAL: - return(mpfr_cmp_d(big_real(x), real(y)) > 0); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) > 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) > 0); - default: return(gt_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpfr_cmp_si(big_real(x), integer(y)) > 0); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return(mpfr_cmp_q(big_real(x), sc->mpq_1) > 0); + case T_REAL: + return(mpfr_cmp_d(big_real(x), real(y)) > 0); + case T_BIG_INTEGER: + return(mpfr_cmp_z(big_real(x), big_integer(y)) > 0); + case T_BIG_RATIO: + return(mpfr_cmp_q(big_real(x), big_ratio(y)) > 0); + default: return(gt_out_y(sc, x, y)); + } #endif default: return(gt_out_x(sc, x, y)); } @@ -24104,10 +24104,10 @@ static s7_pointer g_greater(s7_scheme *sc, s7_pointer args) for (; is_pair(p); x = car(p), p = cdr(p)) if (!gt_b_7pp(sc, x, car(p))) { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->gt_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); - return(sc->F); + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_real_via_method(sc, car(p))) + wrong_type_error_nr(sc, sc->gt_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); + return(sc->F); } return(sc->T); } @@ -24149,7 +24149,7 @@ static s7_pointer g_greater_xf(s7_scheme *sc, s7_pointer args) case T_RATIO: /* (> 9223372036854775807/9223372036854775806 1.0) */ if (denominator(x) < S7_INT32_MAX) /* y range check was handled in greater_chooser */ - return(make_boolean(sc, (numerator(x) > (y * denominator(x))))); + return(make_boolean(sc, (numerator(x) > (y * denominator(x))))); return(make_boolean(sc, fraction(x) > y)); #if WITH_GMP @@ -24206,30 +24206,30 @@ static s7_pointer g_greater_2(s7_scheme *sc, s7_pointer args) { case T_INTEGER: switch (type(y)) - { - case T_RATIO: return(gt_p_pp(sc, x, y)); - case T_REAL: return(make_boolean(sc, integer(x) > real(y))); + { + case T_RATIO: return(gt_p_pp(sc, x, y)); + case T_REAL: return(make_boolean(sc, integer(x) > real(y))); #if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(gt_p_pp(sc, x, y)); + case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: + return(gt_p_pp(sc, x, y)); #endif - default: return(make_boolean(sc, gt_out_y(sc, x, y))); - } + default: return(make_boolean(sc, gt_out_y(sc, x, y))); + } break; case T_RATIO: return(gt_p_pp(sc, x, y)); case T_REAL: switch (type(y)) - { - case T_INTEGER: return(make_boolean(sc, real(x) > integer(y))); - case T_RATIO: return(make_boolean(sc, real(x) > fraction(y))); + { + case T_INTEGER: return(make_boolean(sc, real(x) > integer(y))); + case T_RATIO: return(make_boolean(sc, real(x) > fraction(y))); #if WITH_GMP - case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: - return(gt_p_pp(sc, x, y)); + case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: + return(gt_p_pp(sc, x, y)); #endif - default: return(make_boolean(sc, gt_out_y(sc, x, y))); - } + default: return(make_boolean(sc, gt_out_y(sc, x, y))); + } break; #if WITH_GMP case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: @@ -24274,132 +24274,132 @@ static bool geq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) if (type(x) == type(y)) { if (is_t_integer(x)) - return(integer(x) >= integer(y)); + return(integer(x) >= integer(y)); if (is_t_real(x)) - return(real(x) >= real(y)); + return(real(x) >= real(y)); if (is_t_ratio(x)) - return(fraction(x) >= fraction(y)); + return(fraction(x) >= fraction(y)); #if WITH_GMP if (is_t_big_integer(x)) - return(mpz_cmp(big_integer(x), big_integer(y)) >= 0); + return(mpz_cmp(big_integer(x), big_integer(y)) >= 0); if (is_t_big_ratio(x)) - return(mpq_cmp(big_ratio(x), big_ratio(y)) >= 0); + return(mpq_cmp(big_ratio(x), big_ratio(y)) >= 0); if (is_t_big_real(x)) - return(mpfr_greaterequal_p(big_real(x), big_real(y))); + return(mpfr_greaterequal_p(big_real(x), big_real(y))); #endif } switch (type(x)) { case T_INTEGER: switch (type(y)) - { - case T_RATIO: return(integer(x) >= fraction(y)); /* ?? */ - case T_REAL: return(integer(x) >= real(y)); + { + case T_RATIO: return(integer(x) >= fraction(y)); /* ?? */ + case T_REAL: return(integer(x) >= real(y)); #if WITH_GMP - case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) <= 0); - case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) <= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) <= 0)); + case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) <= 0); + case T_BIG_RATIO: return(mpq_cmp_si(big_ratio(y), integer(x), 1) <= 0); + case T_BIG_REAL: + return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_si(big_real(y), integer(x)) <= 0)); #endif - default: return(geq_out_y(sc, x, y)); - } + default: return(geq_out_y(sc, x, y)); + } break; case T_RATIO: switch (type(y)) - { - case T_INTEGER: return(fraction(x) >= integer(y)); - case T_REAL: return(fraction(x) >= real(y)); + { + case T_INTEGER: return(fraction(x) >= integer(y)); + case T_REAL: return(fraction(x) >= real(y)); #if WITH_GMP - case T_BIG_INTEGER: - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpq_cmp_z(sc->mpq_1, big_integer(y)) >= 0); - case T_BIG_RATIO: - return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) <= 0); - case T_BIG_REAL: - if (mpfr_nan_p(big_real(y))) return(false); - mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); - return(mpfr_cmp_q(big_real(y), sc->mpq_1) <= 0); -#endif - default: return(geq_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return(mpq_cmp_z(sc->mpq_1, big_integer(y)) >= 0); + case T_BIG_RATIO: + return(mpq_cmp_si(big_ratio(y), numerator(x), denominator(x)) <= 0); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(y))) return(false); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return(mpfr_cmp_q(big_real(y), sc->mpq_1) <= 0); +#endif + default: return(geq_out_y(sc, x, y)); + } case T_REAL: switch (type(y)) - { - case T_INTEGER: return(real(x) >= integer(y)); - case T_RATIO: return(real(x) >= fraction(y)); + { + case T_INTEGER: return(real(x) >= integer(y)); + case T_RATIO: return(real(x) >= fraction(y)); #if WITH_GMP - case T_BIG_INTEGER: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) >= 0); - case T_BIG_RATIO: - if (is_NaN(real(x))) return(false); - mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); - return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) >= 0); - case T_BIG_REAL: - if (is_NaN(real(x))) return(false); - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) <= 0)); -#endif - default: return(geq_out_y(sc, x, y)); - } + case T_BIG_INTEGER: + if (is_NaN(real(x))) return(false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return(mpfr_cmp_z(sc->mpfr_1, big_integer(y)) >= 0); + case T_BIG_RATIO: + if (is_NaN(real(x))) return(false); + mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN); + return(mpfr_cmp_q(sc->mpfr_1, big_ratio(y)) >= 0); + case T_BIG_REAL: + if (is_NaN(real(x))) return(false); + return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) <= 0)); +#endif + default: return(geq_out_y(sc, x, y)); + } break; #if WITH_GMP case T_BIG_INTEGER: switch (type(y)) - { - case T_INTEGER: - return(mpz_cmp_si(big_integer(x), integer(y)) >= 0); - case T_RATIO: - mpq_set_z(sc->mpq_1, big_integer(x)); - return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) >= 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0); - case T_BIG_RATIO: - return(mpq_cmp_z(big_ratio(y), big_integer(x)) <= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) <= 0)); - default: return(geq_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpz_cmp_si(big_integer(x), integer(y)) >= 0); + case T_RATIO: + mpq_set_z(sc->mpq_1, big_integer(x)); + return(mpq_cmp_si(sc->mpq_1, numerator(y), denominator(y)) >= 0); + case T_REAL: + if (is_NaN(real(y))) return(false); + mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN); + return(mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0); + case T_BIG_RATIO: + return(mpq_cmp_z(big_ratio(y), big_integer(x)) <= 0); + case T_BIG_REAL: + return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_z(big_real(y), big_integer(x)) <= 0)); + default: return(geq_out_y(sc, x, y)); + } case T_BIG_RATIO: switch (type(y)) - { - case T_INTEGER: - return(mpq_cmp_si(big_ratio(x), integer(y), 1) >= 0); - case T_RATIO: - return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) >= 0); - case T_REAL: - if (is_NaN(real(y))) return(false); - mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); - return(mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0); - case T_BIG_INTEGER: - return(mpq_cmp_z(big_ratio(x), big_integer(y)) >= 0); - case T_BIG_REAL: - return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) <= 0)); - default: return(geq_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpq_cmp_si(big_ratio(x), integer(y), 1) >= 0); + case T_RATIO: + return(mpq_cmp_si(big_ratio(x), numerator(y), denominator(y)) >= 0); + case T_REAL: + if (is_NaN(real(y))) return(false); + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + return(mpfr_cmp_d(sc->mpfr_1, real(y)) >= 0); + case T_BIG_INTEGER: + return(mpq_cmp_z(big_ratio(x), big_integer(y)) >= 0); + case T_BIG_REAL: + return((!mpfr_nan_p(big_real(y))) && (mpfr_cmp_q(big_real(y), big_ratio(x)) <= 0)); + default: return(geq_out_y(sc, x, y)); + } case T_BIG_REAL: if ((is_real(y)) && (mpfr_nan_p(big_real(x)))) return(false); switch (type(y)) - { - case T_INTEGER: - return(mpfr_cmp_si(big_real(x), integer(y)) >= 0); - case T_RATIO: - mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); - return(mpfr_cmp_q(big_real(x), sc->mpq_1) >= 0); - case T_REAL: - return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) >= 0)); - case T_BIG_INTEGER: - return(mpfr_cmp_z(big_real(x), big_integer(y)) >= 0); - case T_BIG_RATIO: - return(mpfr_cmp_q(big_real(x), big_ratio(y)) >= 0); - default: return(geq_out_y(sc, x, y)); - } + { + case T_INTEGER: + return(mpfr_cmp_si(big_real(x), integer(y)) >= 0); + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(y), denominator(y)); + return(mpfr_cmp_q(big_real(x), sc->mpq_1) >= 0); + case T_REAL: + return((!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) >= 0)); + case T_BIG_INTEGER: + return(mpfr_cmp_z(big_real(x), big_integer(y)) >= 0); + case T_BIG_RATIO: + return(mpfr_cmp_q(big_real(x), big_ratio(y)) >= 0); + default: return(geq_out_y(sc, x, y)); + } #endif default: return(geq_out_x(sc, x, y)); } @@ -24418,10 +24418,10 @@ static s7_pointer g_greater_or_equal(s7_scheme *sc, s7_pointer args) for (; is_pair(p); x = car(p), p = cdr(p)) if (!geq_b_7pp(sc, x, car(p))) { - for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!is_real_via_method(sc, car(p))) - wrong_type_error_nr(sc, sc->geq_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); - return(sc->F); + for (p = cdr(p); is_pair(p); p = cdr(p)) + if (!is_real_via_method(sc, car(p))) + wrong_type_error_nr(sc, sc->geq_symbol, position_of(p, args), car(p), sc->type_names[T_REAL]); + return(sc->F); } return(sc->T); } @@ -24511,7 +24511,7 @@ s7_double s7_real_part(s7_pointer x) #if WITH_GMP case T_BIG_INTEGER: return((s7_double)mpz_get_si(big_integer(x))); case T_BIG_RATIO: return((s7_double)((long_double)mpz_get_si(mpq_numref(big_ratio(x))) / - (long_double)mpz_get_si(mpq_denref(big_ratio(x))))); + (long_double)mpz_get_si(mpq_denref(big_ratio(x))))); case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN)); case T_BIG_COMPLEX: return((s7_double)mpfr_get_d(mpc_realref(big_complex(x)), MPFR_RNDN)); #endif @@ -24540,12 +24540,12 @@ static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer p) return(p); case T_BIG_COMPLEX: { - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpc_real(big_real(x), big_complex(p), MPFR_RNDN); - return(x); + s7_pointer x; + new_cell(sc, x, T_BIG_REAL); + big_real_bgf(x) = alloc_bigflt(sc); + add_big_real(sc, x); + mpc_real(big_real(x), big_complex(p), MPFR_RNDN); + return(x); } #endif default: @@ -24598,12 +24598,12 @@ static s7_pointer imag_part_p_p(s7_scheme *sc, s7_pointer p) return(real_zero); case T_BIG_COMPLEX: { - s7_pointer x; - new_cell(sc, x, T_BIG_REAL); - big_real_bgf(x) = alloc_bigflt(sc); - add_big_real(sc, x); - mpc_imag(big_real(x), big_complex(p), MPFR_RNDN); - return(x); + s7_pointer x; + new_cell(sc, x, T_BIG_REAL); + big_real_bgf(x) = alloc_bigflt(sc); + add_big_real(sc, x); + mpc_imag(big_real(x), big_complex(p), MPFR_RNDN); + return(x); } #endif default: @@ -24772,7 +24772,7 @@ static bool is_nan_b_7p(s7_scheme *sc, s7_pointer x) #endif default: if (is_number(x)) - return(method_or_bust_p(sc, x, sc->is_nan_symbol, a_number_string) != sc->F); + return(method_or_bust_p(sc, x, sc->is_nan_symbol, a_number_string) != sc->F); } return(false); } @@ -24800,11 +24800,11 @@ static bool is_infinite_b_7p(s7_scheme *sc, s7_pointer x) case T_BIG_REAL: return(mpfr_inf_p(big_real(x)) != 0); case T_BIG_COMPLEX: return((mpfr_inf_p(mpc_realref(big_complex(x))) != 0) || - (mpfr_inf_p(mpc_imagref(big_complex(x))) != 0)); + (mpfr_inf_p(mpc_imagref(big_complex(x))) != 0)); #endif default: if (is_number(x)) - return(method_or_bust_p(sc, x, sc->is_infinite_symbol, a_number_string) != sc->F); + return(method_or_bust_p(sc, x, sc->is_infinite_symbol, a_number_string) != sc->F); } return(false); } @@ -25009,15 +25009,15 @@ static s7_pointer exact_to_inexact_p_p(s7_scheme *sc, s7_pointer x) case T_INTEGER: #if WITH_GMP if ((integer(x) > INT64_TO_DOUBLE_LIMIT) || (integer(x) < -INT64_TO_DOUBLE_LIMIT)) - return(s7_number_to_big_real(sc, x)); + return(s7_number_to_big_real(sc, x)); #endif return(make_real(sc, (s7_double)(integer(x)))); case T_RATIO: #if WITH_GMP if ((numerator(x) > INT64_TO_DOUBLE_LIMIT) || (numerator(x) < -INT64_TO_DOUBLE_LIMIT) || - (denominator(x) > INT64_TO_DOUBLE_LIMIT)) /* just a guess */ - return(s7_number_to_big_real(sc, x)); + (denominator(x) > INT64_TO_DOUBLE_LIMIT)) /* just a guess */ + return(s7_number_to_big_real(sc, x)); #endif return(make_real(sc, (s7_double)(fraction(x)))); @@ -25058,22 +25058,22 @@ static s7_pointer inexact_to_exact_p_p(s7_scheme *sc, s7_pointer x) case T_REAL: { - s7_int numer = 0, denom = 1; - s7_double val = real(x); - if ((is_inf(val)) || (is_NaN(val))) - sole_arg_wrong_type_error_nr(sc, sc->inexact_to_exact_symbol, x, a_normal_real_string); + s7_int numer = 0, denom = 1; + s7_double val = real(x); + if ((is_inf(val)) || (is_NaN(val))) + sole_arg_wrong_type_error_nr(sc, sc->inexact_to_exact_symbol, x, a_normal_real_string); - if ((val > DOUBLE_TO_INT64_LIMIT) || (val < -(DOUBLE_TO_INT64_LIMIT))) - { + if ((val > DOUBLE_TO_INT64_LIMIT) || (val < -(DOUBLE_TO_INT64_LIMIT))) + { #if WITH_GMP - return(big_rationalize(sc, set_plist_1(sc, x))); /* this can handle t_real as well as t_big_real */ + return(big_rationalize(sc, set_plist_1(sc, x))); /* this can handle t_real as well as t_big_real */ #else - sole_arg_out_of_range_error_nr(sc, sc->inexact_to_exact_symbol, x, it_is_too_large_string); + sole_arg_out_of_range_error_nr(sc, sc->inexact_to_exact_symbol, x, it_is_too_large_string); #endif - } - /* c_rationalize limit is RATIONALIZE_LIMIT=1e12 currently so this is a tighter limit than DOUBLE_TO_INT64_LIMIT */ - if (c_rationalize(val, sc->default_rationalize_error, &numer, &denom)) - return(make_ratio(sc, numer, denom)); + } + /* c_rationalize limit is RATIONALIZE_LIMIT=1e12 currently so this is a tighter limit than DOUBLE_TO_INT64_LIMIT */ + if (c_rationalize(val, sc->default_rationalize_error, &numer, &denom)) + return(make_ratio(sc, numer, denom)); } default: @@ -25196,12 +25196,12 @@ sign of 'x' (1 = positive, -1 = negative). (integer-decode-float 0.0): (0 0 1)" if (is_t_real(x)) { if (real(x) == 0.0) - return(list_3(sc, int_zero, int_zero, int_one)); + return(list_3(sc, int_zero, int_zero, int_one)); num.fx = (double)real(x); return(list_3(sc, - make_integer_unchecked(sc, (s7_int)((num.ix & 0xfffffffffffffLL) | 0x10000000000000LL)), - make_integer(sc, (s7_int)(((num.ix & 0x7fffffffffffffffLL) >> 52) - 1023 - 52)), - ((num.ix & 0x8000000000000000LL) != 0) ? minus_one : int_one)); + make_integer_unchecked(sc, (s7_int)((num.ix & 0xfffffffffffffLL) | 0x10000000000000LL)), + make_integer(sc, (s7_int)(((num.ix & 0x7fffffffffffffffLL) >> 52) - 1023 - 52)), + ((num.ix & 0x8000000000000000LL) != 0) ? minus_one : int_one)); } #if WITH_GMP if (is_t_big_real(x)) @@ -25228,21 +25228,21 @@ static s7_pointer big_logior(s7_scheme *sc, s7_int start, s7_pointer args) { s7_pointer i = car(x); switch (type(i)) - { - case T_BIG_INTEGER: - mpz_ior(sc->mpz_1, sc->mpz_1, big_integer(i)); - break; - case T_INTEGER: - mpz_set_si(sc->mpz_2, integer(i)); - mpz_ior(sc->mpz_1, sc->mpz_1, sc->mpz_2); - break; - default: - if (!is_integer_via_method(sc, i)) - wrong_type_error_nr(sc, sc->logior_symbol, position_of(x, args), i, sc->type_names[T_INTEGER]); - return(method_or_bust(sc, i, sc->logior_symbol, - set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), - sc->type_names[T_INTEGER], position_of(x, args))); - }} + { + case T_BIG_INTEGER: + mpz_ior(sc->mpz_1, sc->mpz_1, big_integer(i)); + break; + case T_INTEGER: + mpz_set_si(sc->mpz_2, integer(i)); + mpz_ior(sc->mpz_1, sc->mpz_1, sc->mpz_2); + break; + default: + if (!is_integer_via_method(sc, i)) + wrong_type_error_nr(sc, sc->logior_symbol, position_of(x, args), i, sc->type_names[T_INTEGER]); + return(method_or_bust(sc, i, sc->logior_symbol, + set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), + sc->type_names[T_INTEGER], position_of(x, args))); + }} return(mpz_to_integer(sc, sc->mpz_1)); } #endif @@ -25257,12 +25257,12 @@ static s7_pointer g_logior(s7_scheme *sc, s7_pointer args) { #if WITH_GMP if (is_t_big_integer(car(x))) - return(big_logior(sc, result, x)); + return(big_logior(sc, result, x)); #endif if (!is_t_integer(car(x))) - return(method_or_bust(sc, car(x), sc->logior_symbol, - (result == 0) ? x : set_ulist_1(sc, make_integer(sc, result), x), - sc->type_names[T_INTEGER], position_of(x, args))); + return(method_or_bust(sc, car(x), sc->logior_symbol, + (result == 0) ? x : set_ulist_1(sc, make_integer(sc, result), x), + sc->type_names[T_INTEGER], position_of(x, args))); result |= integer(car(x)); } return(make_integer(sc, result)); @@ -25281,21 +25281,21 @@ static s7_pointer big_logxor(s7_scheme *sc, s7_int start, s7_pointer args) { s7_pointer i = car(x); switch (type(i)) - { - case T_BIG_INTEGER: - mpz_xor(sc->mpz_1, sc->mpz_1, big_integer(i)); - break; - case T_INTEGER: - mpz_set_si(sc->mpz_2, integer(i)); - mpz_xor(sc->mpz_1, sc->mpz_1, sc->mpz_2); - break; - default: - if (!is_integer_via_method(sc, i)) - wrong_type_error_nr(sc, sc->logxor_symbol, position_of(x, args), i, sc->type_names[T_INTEGER]); - return(method_or_bust(sc, i, sc->logxor_symbol, - set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), - sc->type_names[T_INTEGER], position_of(x, args))); - }} + { + case T_BIG_INTEGER: + mpz_xor(sc->mpz_1, sc->mpz_1, big_integer(i)); + break; + case T_INTEGER: + mpz_set_si(sc->mpz_2, integer(i)); + mpz_xor(sc->mpz_1, sc->mpz_1, sc->mpz_2); + break; + default: + if (!is_integer_via_method(sc, i)) + wrong_type_error_nr(sc, sc->logxor_symbol, position_of(x, args), i, sc->type_names[T_INTEGER]); + return(method_or_bust(sc, i, sc->logxor_symbol, + set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), + sc->type_names[T_INTEGER], position_of(x, args))); + }} return(mpz_to_integer(sc, sc->mpz_1)); } #endif @@ -25310,12 +25310,12 @@ static s7_pointer g_logxor(s7_scheme *sc, s7_pointer args) { #if WITH_GMP if (is_t_big_integer(car(x))) - return(big_logxor(sc, result, x)); + return(big_logxor(sc, result, x)); #endif if (!is_t_integer(car(x))) - return(method_or_bust(sc, car(x), sc->logxor_symbol, - (result == 0) ? x : set_ulist_1(sc, make_integer(sc, result), x), - sc->type_names[T_INTEGER], position_of(x, args))); + return(method_or_bust(sc, car(x), sc->logxor_symbol, + (result == 0) ? x : set_ulist_1(sc, make_integer(sc, result), x), + sc->type_names[T_INTEGER], position_of(x, args))); result ^= integer(car(x)); } return(make_integer(sc, result)); @@ -25334,21 +25334,21 @@ static s7_pointer big_logand(s7_scheme *sc, s7_int start, s7_pointer args) { s7_pointer i = car(x); switch (type(i)) - { - case T_BIG_INTEGER: - mpz_and(sc->mpz_1, sc->mpz_1, big_integer(i)); - break; - case T_INTEGER: - mpz_set_si(sc->mpz_2, integer(i)); - mpz_and(sc->mpz_1, sc->mpz_1, sc->mpz_2); - break; - default: - if (!is_integer_via_method(sc, i)) - wrong_type_error_nr(sc, sc->logand_symbol, position_of(x, args), i, sc->type_names[T_INTEGER]); - return(method_or_bust(sc, i, sc->logand_symbol, - set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), - sc->type_names[T_INTEGER], position_of(x, args))); - }} + { + case T_BIG_INTEGER: + mpz_and(sc->mpz_1, sc->mpz_1, big_integer(i)); + break; + case T_INTEGER: + mpz_set_si(sc->mpz_2, integer(i)); + mpz_and(sc->mpz_1, sc->mpz_1, sc->mpz_2); + break; + default: + if (!is_integer_via_method(sc, i)) + wrong_type_error_nr(sc, sc->logand_symbol, position_of(x, args), i, sc->type_names[T_INTEGER]); + return(method_or_bust(sc, i, sc->logand_symbol, + set_ulist_1(sc, mpz_to_integer(sc, sc->mpz_1), x), + sc->type_names[T_INTEGER], position_of(x, args))); + }} return(mpz_to_integer(sc, sc->mpz_1)); } #endif @@ -25363,12 +25363,12 @@ static s7_pointer g_logand(s7_scheme *sc, s7_pointer args) { #if WITH_GMP if (is_t_big_integer(car(x))) - return(big_logand(sc, result, x)); + return(big_logand(sc, result, x)); #endif if (!is_t_integer(car(x))) - return(method_or_bust(sc, car(x), sc->logand_symbol, - (result == -1) ? x : set_ulist_1(sc, make_integer(sc, result), x), - sc->type_names[T_INTEGER], position_of(x, args))); + return(method_or_bust(sc, car(x), sc->logand_symbol, + (result == -1) ? x : set_ulist_1(sc, make_integer(sc, result), x), + sc->type_names[T_INTEGER], position_of(x, args))); result &= integer(car(x)); } return(make_integer(sc, result)); @@ -25455,7 +25455,7 @@ static bool logbit_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) if (is_t_integer(p1)) { if (is_t_integer(p2)) - return(logbit_b_7ii(sc, integer(p1), integer(p2))); + return(logbit_b_7ii(sc, integer(p1), integer(p2))); return(method_or_bust(sc, p2, sc->logbit_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_INTEGER], 2) != sc->F); } #if WITH_GMP @@ -25473,7 +25473,7 @@ static s7_int c_ash(s7_scheme *sc, s7_int arg1, s7_int arg2) if (arg2 >= S7_INT_BITS) { if ((arg1 == -1) && (arg2 == 63)) /* (ash -1 63): most-negative-fixnum */ - return(S7_INT64_MIN); + return(S7_INT64_MIN); out_of_range_error_nr(sc, sc->ash_symbol, int_two, wrap_integer(sc, arg2), it_is_too_large_string); } if (arg2 < -S7_INT_BITS) @@ -25508,45 +25508,45 @@ static s7_pointer g_ash(s7_scheme *sc, s7_pointer args) int32_t p0_compared_to_zero = 0; if (p0_is_big) - p0_compared_to_zero = mpz_cmp_ui(big_integer(p0), 0); + p0_compared_to_zero = mpz_cmp_ui(big_integer(p0), 0); else - if (integer(p0) > 0) - p0_compared_to_zero = 1; - else p0_compared_to_zero = (integer(p0) < 0) ? -1 : 0; + if (integer(p0) > 0) + p0_compared_to_zero = 1; + else p0_compared_to_zero = (integer(p0) < 0) ? -1 : 0; if (p0_compared_to_zero == 0) - return(int_zero); + return(int_zero); if (is_big_number(p1)) - { - if (!mpz_fits_sint_p(big_integer(p1))) - { - if (mpz_cmp_ui(big_integer(p1), 0) > 0) - out_of_range_error_nr(sc, sc->ash_symbol, int_two, p1, it_is_too_large_string); - - /* here if p0 is negative, we need to return -1 */ - return((p0_compared_to_zero == 1) ? int_zero : minus_one); - } - shift = mpz_get_si(big_integer(p1)); - } + { + if (!mpz_fits_sint_p(big_integer(p1))) + { + if (mpz_cmp_ui(big_integer(p1), 0) > 0) + out_of_range_error_nr(sc, sc->ash_symbol, int_two, p1, it_is_too_large_string); + + /* here if p0 is negative, we need to return -1 */ + return((p0_compared_to_zero == 1) ? int_zero : minus_one); + } + shift = mpz_get_si(big_integer(p1)); + } else - { - shift = integer(p1); - if (shift < S7_INT32_MIN) - return((p0_compared_to_zero == 1) ? int_zero : minus_one); - } + { + shift = integer(p1); + if (shift < S7_INT32_MIN) + return((p0_compared_to_zero == 1) ? int_zero : minus_one); + } if (shift > S7_INT32_MAX) - out_of_range_error_nr(sc, sc->ash_symbol, int_two, p1, it_is_too_large_string); /* gmp calls abort if overflow here */ + out_of_range_error_nr(sc, sc->ash_symbol, int_two, p1, it_is_too_large_string); /* gmp calls abort if overflow here */ if (is_t_big_integer(p0)) - mpz_set(sc->mpz_1, big_integer(p0)); + mpz_set(sc->mpz_1, big_integer(p0)); else mpz_set_si(sc->mpz_1, integer(p0)); if (shift > 0) /* left */ - mpz_mul_2exp(sc->mpz_1, sc->mpz_1, shift); + mpz_mul_2exp(sc->mpz_1, sc->mpz_1, shift); else - if (shift < 0) /* right */ - mpz_fdiv_q_2exp(sc->mpz_1, sc->mpz_1, (uint32_t)(-shift)); + if (shift < 0) /* right */ + mpz_fdiv_q_2exp(sc->mpz_1, sc->mpz_1, (uint32_t)(-shift)); return(mpz_to_integer(sc, sc->mpz_1)); } @@ -25772,7 +25772,7 @@ static s7_pointer g_random(s7_scheme *sc, s7_pointer args) { r = cadr(args); if (!is_random_state(r)) - return(method_or_bust(sc, r, sc->random_symbol, args, a_random_state_object_string, 2)); + return(method_or_bust(sc, r, sc->random_symbol, args, a_random_state_object_string, 2)); } num = car(args); switch (type(num)) @@ -25782,43 +25782,43 @@ static s7_pointer g_random(s7_scheme *sc, s7_pointer args) return(make_integer(sc, (s7_int)(integer(num) * next_random(r)))); case T_RATIO: { - s7_double x = fraction(num), error; - s7_int numer = 0, denom = 1; - /* the error here needs to take the size of the fraction into account. Otherwise, if - * error is (say) 1e-6 and the fraction is (say) 9000000/9223372036854775807, - * c_rationalize will always return 0. But even that isn't foolproof: - * (random 1/562949953421312) -> 1/376367230475000 - */ - if ((x < 1.0e-10) && (x > -1.0e-10)) - { - /* 1e-12 is not tight enough: - * (random 1/2251799813685248) -> 1/2250240579436280 - * (random -1/4503599627370496) -> -1/4492889778435526 - * (random 1/140737488355328) -> 1/140730223985746 - * (random -1/35184372088832) -> -1/35183145492420 - * (random -1/70368744177664) -> -1/70366866392738 - * (random 1/4398046511104) -> 1/4398033095756 - * (random 1/137438953472) -> 1/137438941127 - */ - if (numerator(num) < -10) - numer = -(s7_int)(floor(-numerator(num) * next_random(r))); - else - if (numerator(num) > 10) - numer = (s7_int)floor(numerator(num) * next_random(r)); - else - { - int64_t diff = S7_INT64_MAX - denominator(num); - numer = numerator(num); - if (diff < 100) - return(make_ratio(sc, numer, denominator(num))); - denom = denominator(num) + (s7_int)floor(diff * next_random(r)); - return(make_ratio_with_div_check(sc, sc->random_symbol, numer, denom)); - } - return(make_ratio(sc, numer, denominator(num))); - } - error = ((x < 1e-6) && (x > -1e-6)) ? 1e-18 : 1e-12; - c_rationalize(x * next_random(r), error, &numer, &denom); - return(make_ratio(sc, numer, denom)); + s7_double x = fraction(num), error; + s7_int numer = 0, denom = 1; + /* the error here needs to take the size of the fraction into account. Otherwise, if + * error is (say) 1e-6 and the fraction is (say) 9000000/9223372036854775807, + * c_rationalize will always return 0. But even that isn't foolproof: + * (random 1/562949953421312) -> 1/376367230475000 + */ + if ((x < 1.0e-10) && (x > -1.0e-10)) + { + /* 1e-12 is not tight enough: + * (random 1/2251799813685248) -> 1/2250240579436280 + * (random -1/4503599627370496) -> -1/4492889778435526 + * (random 1/140737488355328) -> 1/140730223985746 + * (random -1/35184372088832) -> -1/35183145492420 + * (random -1/70368744177664) -> -1/70366866392738 + * (random 1/4398046511104) -> 1/4398033095756 + * (random 1/137438953472) -> 1/137438941127 + */ + if (numerator(num) < -10) + numer = -(s7_int)(floor(-numerator(num) * next_random(r))); + else + if (numerator(num) > 10) + numer = (s7_int)floor(numerator(num) * next_random(r)); + else + { + int64_t diff = S7_INT64_MAX - denominator(num); + numer = numerator(num); + if (diff < 100) + return(make_ratio(sc, numer, denominator(num))); + denom = denominator(num) + (s7_int)floor(diff * next_random(r)); + return(make_ratio_with_div_check(sc, sc->random_symbol, numer, denom)); + } + return(make_ratio(sc, numer, denominator(num))); + } + error = ((x < 1e-6) && (x > -1e-6)) ? 1e-18 : 1e-12; + c_rationalize(x * next_random(r), error, &numer, &denom); + return(make_ratio(sc, numer, denom)); } case T_REAL: return(make_real(sc, real(num) * next_random(r))); @@ -25836,7 +25836,7 @@ static s7_pointer g_random(s7_scheme *sc, s7_pointer args) mpz_urandomm(sc->mpz_1, random_gmp_state(r), big_integer(num)); /* this does not work if num is a negative number -- you get positive results. so check num for sign, and negate result if necessary */ if (mpz_cmp_ui(big_integer(num), 0) < 0) - mpz_neg(sc->mpz_1, sc->mpz_1); + mpz_neg(sc->mpz_1, sc->mpz_1); return(mpz_to_integer(sc, sc->mpz_1)); case T_RATIO: mpfr_urandomb(sc->mpfr_1, random_gmp_state(r)); @@ -25950,7 +25950,7 @@ static s7_pointer random_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_p { s7_pointer arg1 = cadr(expr); if (is_t_integer(arg1)) - return(sc->random_i); + return(sc->random_i); return((is_t_real(arg1)) ? sc->random_f : sc->random_1); } return(f); @@ -26014,7 +26014,7 @@ static s7_pointer integer_to_char_p_i(s7_scheme *sc, s7_int ind) { if ((ind < 0) || (ind >= NUM_CHARS)) sole_arg_out_of_range_error_nr(sc, sc->integer_to_char_symbol, wrap_integer(sc, ind), - wrap_string(sc, "it doen't fit in an unsigned byte", 33)); /* int2 s7_out... uses 1 */ + wrap_string(sc, "it doen't fit in an unsigned byte", 33)); /* int2 s7_out... uses 1 */ return(chars[(uint8_t)ind]); } @@ -26060,21 +26060,21 @@ static void init_chars(void) #define make_character_name(S) memcpy((void *)(&(character_name(cp))), (const void *)(S), character_name_length(cp) = (int32_t)strlen(S)) switch (c) - { - case ' ': make_character_name("#\\space"); break; - case '\n': make_character_name("#\\newline"); break; - case '\r': make_character_name("#\\return"); break; - case '\t': make_character_name("#\\tab"); break; - case '\0': make_character_name("#\\null"); break; - case (char)0x1b: make_character_name("#\\escape"); break; - case (char)0x7f: make_character_name("#\\delete"); break; - case (char)7: make_character_name("#\\alarm"); break; - case (char)8: make_character_name("#\\backspace"); break; - default: + { + case ' ': make_character_name("#\\space"); break; + case '\n': make_character_name("#\\newline"); break; + case '\r': make_character_name("#\\return"); break; + case '\t': make_character_name("#\\tab"); break; + case '\0': make_character_name("#\\null"); break; + case (char)0x1b: make_character_name("#\\escape"); break; + case (char)0x7f: make_character_name("#\\delete"); break; + case (char)7: make_character_name("#\\alarm"); break; + case (char)8: make_character_name("#\\backspace"); break; + default: #define P_SIZE 12 - character_name_length(cp) = snprintf((char *)(&(character_name(cp))), P_SIZE, ((c < 32) || (c >= 127)) ? "#\\x%x" : "#\\%c", c); - break; - }} + character_name_length(cp) = snprintf((char *)(&(character_name(cp))), P_SIZE, ((c < 32) || (c >= 127)) ? "#\\x%x" : "#\\%c", c); + break; + }} } @@ -26259,7 +26259,7 @@ static bool is_character_via_method(s7_scheme *sc, s7_pointer p) { s7_pointer f = find_method_with_let(sc, p, sc->is_char_symbol); if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); + return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); } return(false); } @@ -26280,9 +26280,9 @@ static s7_pointer g_char_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_poi for (s7_pointer x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) { if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); if (charcmp(character(y), character(car(x))) != val) - return(char_with_error_check(sc, x, args, sym)); + return(char_with_error_check(sc, x, args, sym)); } return(sc->T); } @@ -26295,9 +26295,9 @@ static s7_pointer g_char_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7 for (s7_pointer x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) { if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); if (charcmp(character(y), character(car(x))) == val) - return(char_with_error_check(sc, x, args, sym)); + return(char_with_error_check(sc, x, args, sym)); } return(sc->T); } @@ -26313,9 +26313,9 @@ static s7_pointer g_chars_are_equal(s7_scheme *sc, s7_pointer args) for (s7_pointer x = cdr(args); is_pair(x); x = cdr(x)) { if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sc->char_eq_symbol, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); + return(method_or_bust(sc, car(x), sc->char_eq_symbol, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); if (car(x) != y) - return(char_with_error_check(sc, x, args, sc->char_eq_symbol)); + return(char_with_error_check(sc, x, args, sc->char_eq_symbol)); } return(sc->T); } @@ -26434,7 +26434,7 @@ static s7_pointer char_equal_chooser(s7_scheme *sc, s7_pointer f, int32_t args, { s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); if ((returns_char(sc, arg1)) && (returns_char(sc, arg2))) - return(sc->simple_char_eq); + return(sc->simple_char_eq); } return(sc->char_equal_2); } @@ -26461,9 +26461,9 @@ static s7_pointer g_char_cmp_ci(s7_scheme *sc, s7_pointer args, int32_t val, s7_ for (s7_pointer x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) { if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); if (charcmp(upper_character(y), upper_character(car(x))) != val) - return(char_with_error_check(sc, x, args, sym)); + return(char_with_error_check(sc, x, args, sym)); } return(sc->T); } @@ -26476,9 +26476,9 @@ static s7_pointer g_char_cmp_ci_not(s7_scheme *sc, s7_pointer args, int32_t val, for (s7_pointer x = cdr(args); is_pair(x); y = car(x), x = cdr(x)) { if (!is_character(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_CHARACTER], position_of(x, args))); if (charcmp(upper_character(y), upper_character(car(x))) == val) - return(char_with_error_check(sc, x, args, sym)); + return(char_with_error_check(sc, x, args, sym)); } return(sc->T); } @@ -26581,10 +26581,10 @@ static s7_pointer g_char_position(s7_scheme *sc, s7_pointer args) { s7_pointer arg3 = caddr(args); if (!s7_is_integer(arg3)) - return(method_or_bust(sc, arg3, sc->char_position_symbol, args, sc->type_names[T_INTEGER], 3)); + return(method_or_bust(sc, arg3, sc->char_position_symbol, args, sc->type_names[T_INTEGER], 3)); start = s7_integer_clamped_if_gmp(sc, arg3); if (start < 0) - wrong_type_error_nr(sc, sc->char_position_symbol, 3, arg3, a_non_negative_integer_string); + wrong_type_error_nr(sc, sc->char_position_symbol, 3, arg3, a_non_negative_integer_string); } else start = 0; @@ -26651,10 +26651,10 @@ static s7_pointer g_char_position_csi(s7_scheme *sc, s7_pointer args) { s7_pointer arg3 = caddr(args); if (!s7_is_integer(arg3)) - return(g_char_position(sc, args)); + return(g_char_position(sc, args)); start = s7_integer_clamped_if_gmp(sc, arg3); if (start < 0) - wrong_type_error_nr(sc, sc->char_position_symbol, 3, arg3, a_non_negative_integer_string); + wrong_type_error_nr(sc, sc->char_position_symbol, 3, arg3, a_non_negative_integer_string); if (start >= len) return(sc->F); } else start = 0; @@ -26692,10 +26692,10 @@ static s7_pointer g_string_position(s7_scheme *sc, s7_pointer args) { s7_pointer arg3 = caddr(args); if (!s7_is_integer(arg3)) - return(method_or_bust(sc, arg3, sc->string_position_symbol, args, sc->type_names[T_INTEGER], 3)); + return(method_or_bust(sc, arg3, sc->string_position_symbol, args, sc->type_names[T_INTEGER], 3)); start = s7_integer_clamped_if_gmp(sc, arg3); if (start < 0) - wrong_type_error_nr(sc, sc->string_position_symbol, 3, caddr(args), a_non_negative_integer_string); + wrong_type_error_nr(sc, sc->string_position_symbol, 3, caddr(args), a_non_negative_integer_string); } if (string_length(s1p) == 0) @@ -26917,8 +26917,8 @@ static s7_pointer g_make_string(s7_scheme *sc, s7_pointer args) out_of_range_error_nr(sc, sc->make_string_symbol, int_one, n, it_is_negative_string); if (len > sc->max_string_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "make-string length argument ~D is greater than (*s7* 'max-string-length), ~D", 76), - wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); + set_elist_3(sc, wrap_string(sc, "make-string length argument ~D is greater than (*s7* 'max-string-length), ~D", 76), + wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); if (is_null(cdr(args))) return(make_empty_string(sc, len, '\0')); /* #\null here means "don't fill/clear" */ @@ -26936,8 +26936,8 @@ static s7_pointer make_string_p_i(s7_scheme *sc, s7_int len) out_of_range_error_nr(sc, sc->make_string_symbol, int_one, wrap_integer(sc, len), it_is_negative_string); if (len > sc->max_string_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "make-string length argument ~D is greater than (*s7* 'max-string-length), ~D", 76), - wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); + set_elist_3(sc, wrap_string(sc, "make-string length argument ~D is greater than (*s7* 'max-string-length), ~D", 76), + wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); return(make_empty_string(sc, len, '\0')); } @@ -26985,7 +26985,7 @@ static s7_pointer g_string_downcase(s7_scheme *sc, s7_pointer args) { i = len - 1; while (i >= 8) - LOOP_8(nstr[i] = lowers[(uint8_t)ostr[i]]; i--); + LOOP_8(nstr[i] = lowers[(uint8_t)ostr[i]]; i--); while (i >= 0) {nstr[i] = lowers[(uint8_t)ostr[i]]; i--;} } else @@ -27014,7 +27014,7 @@ static s7_pointer g_string_upcase(s7_scheme *sc, s7_pointer args) { i = len - 1; while (i >= 8) - LOOP_8(nstr[i] = uppers[(uint8_t)ostr[i]]; i--); + LOOP_8(nstr[i] = uppers[(uint8_t)ostr[i]]; i--); while (i >= 0) {nstr[i] = uppers[(uint8_t)ostr[i]]; i--;} } else @@ -27180,8 +27180,8 @@ static s7_int sequence_length(s7_scheme *sc, s7_pointer lst) { case T_PAIR: { - s7_int len = s7_list_length(sc, lst); - return((len == 0) ? -1 : len); + s7_int len = s7_list_length(sc, lst); + return((len == 0) ? -1 : len); } case T_NIL: return(0); case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: @@ -27191,9 +27191,9 @@ static s7_int sequence_length(s7_scheme *sc, s7_pointer lst) case T_LET: return(let_length(sc, lst)); case T_C_OBJECT: { - s7_pointer x = c_object_length(sc, lst); - if (s7_is_integer(x)) - return(s7_integer_clamped_if_gmp(sc, x)); + s7_pointer x = c_object_length(sc, lst); + if (s7_is_integer(x)) + return(s7_integer_clamped_if_gmp(sc, x)); }} return(-1); } @@ -27208,22 +27208,22 @@ static void string_append_2(s7_scheme *sc, s7_pointer newstr, s7_pointer args, c for (pos = string_value(newstr), x = args; x != stop_arg; x = cdr(x)) if (is_string(car(x))) { - len = string_length(car(x)); - if (len > 0) - { - memcpy(pos, string_value(car(x)), len); - pos += len; - }} + len = string_length(car(x)); + if (len > 0) + { + memcpy(pos, string_value(car(x)), len); + pos += len; + }} else if (!sequence_is_empty(sc, car(x))) - { - char *old_str = string_value(newstr); - string_value(newstr) = pos; - len = sequence_length(sc, car(x)); - s7_copy_1(sc, caller, set_plist_2(sc, car(x), newstr)); - string_value(newstr) = old_str; - pos += len; - } + { + char *old_str = string_value(newstr); + string_value(newstr) = pos; + len = sequence_length(sc, car(x)); + s7_copy_1(sc, caller, set_plist_2(sc, car(x), newstr)); + string_value(newstr) = old_str; + pos += len; + } } static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) @@ -27244,44 +27244,44 @@ static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer c { s7_pointer p = car(x); if (is_string(p)) - len += string_length(p); + len += string_length(p); else - { - s7_int newlen; - if (!is_sequence(p)) - { - unstack_gc_protect(sc); - wrong_type_error_nr(sc, caller, position_of(x, args), p, sc->type_names[T_STRING]); - } - if (has_active_methods(sc, p)) /* look for string-append and if found, cobble up a plausible intermediate call */ - { - s7_pointer func = find_method_with_let(sc, p, caller); - if (func != sc->undefined) - { - if (len == 0) - { - unstack_gc_protect(sc); - return(s7_apply_function(sc, func, x)); /* not args (string-append "" "" ...) */ - } - newstr = make_empty_string(sc, len, 0); - string_append_2(sc, newstr, args, x, caller); - unstack_gc_protect(sc); - return(s7_apply_function(sc, func, set_ulist_1(sc, newstr, x))); - }} - if ((caller == sc->string_append_symbol) || (caller == sc->symbol_symbol)) - { - unstack_gc_protect(sc); - wrong_type_error_nr(sc, caller, position_of(x, args), p, sc->type_names[T_STRING]); - } - newlen = sequence_length(sc, p); - if (newlen < 0) - { - unstack_gc_protect(sc); - wrong_type_error_nr(sc, caller, position_of(x, args), p, sc->type_names[T_STRING]); - } - just_strings = false; - len += newlen; - }} + { + s7_int newlen; + if (!is_sequence(p)) + { + unstack_gc_protect(sc); + wrong_type_error_nr(sc, caller, position_of(x, args), p, sc->type_names[T_STRING]); + } + if (has_active_methods(sc, p)) /* look for string-append and if found, cobble up a plausible intermediate call */ + { + s7_pointer func = find_method_with_let(sc, p, caller); + if (func != sc->undefined) + { + if (len == 0) + { + unstack_gc_protect(sc); + return(s7_apply_function(sc, func, x)); /* not args (string-append "" "" ...) */ + } + newstr = make_empty_string(sc, len, 0); + string_append_2(sc, newstr, args, x, caller); + unstack_gc_protect(sc); + return(s7_apply_function(sc, func, set_ulist_1(sc, newstr, x))); + }} + if ((caller == sc->string_append_symbol) || (caller == sc->symbol_symbol)) + { + unstack_gc_protect(sc); + wrong_type_error_nr(sc, caller, position_of(x, args), p, sc->type_names[T_STRING]); + } + newlen = sequence_length(sc, p); + if (newlen < 0) + { + unstack_gc_protect(sc); + wrong_type_error_nr(sc, caller, position_of(x, args), p, sc->type_names[T_STRING]); + } + just_strings = false; + len += newlen; + }} if (len == 0) { unstack_gc_protect(sc); @@ -27291,21 +27291,21 @@ static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer c { unstack_gc_protect(sc); error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", 70), - caller, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); + set_elist_4(sc, wrap_string(sc, "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", 70), + caller, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); } newstr = inline_make_empty_string(sc, len, 0); if (just_strings) { x = args; for (char *pos = string_value(newstr); is_not_null(x); x = cdr(x)) - { - len = string_length(car(x)); - if (len > 0) - { - memcpy(pos, string_value(car(x)), len); - pos += len; - }}} + { + len = string_length(car(x)); + if (len > 0) + { + memcpy(pos, string_value(car(x)), len); + pos += len; + }}} else string_append_2(sc, newstr, args, sc->nil, caller); unstack_gc_protect(sc); return(newstr); @@ -27323,9 +27323,9 @@ static inline s7_pointer string_append_1(s7_scheme *sc, s7_pointer s1, s7_pointe len = pos + string_length(s2); if (len == pos) return(make_string_with_length(sc, string_value(s1), string_length(s1))); if (len > sc->max_string_length) - error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", 70), - sc->string_append_symbol, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); + error_nr(sc, sc->out_of_range_symbol, + set_elist_4(sc, wrap_string(sc, "~S new string length, ~D, is larger than (*s7* 'max-string-length): ~D", 70), + sc->string_append_symbol, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); newstr = make_empty_string(sc, len, 0); /* len+1 0-terminated */ memcpy(string_value(newstr), string_value(s1), pos); memcpy((char *)(string_value(newstr) + pos), string_value(s2), string_length(s2)); @@ -27366,11 +27366,11 @@ static s7_pointer start_and_end(s7_scheme *sc, s7_pointer caller, s7_pointer arg { s7_pointer pend = cadr(index_args); if (!s7_is_integer(pend)) - return(method_or_bust(sc, pend, caller, args, sc->type_names[T_INTEGER], position + 1)); + return(method_or_bust(sc, pend, caller, args, sc->type_names[T_INTEGER], position + 1)); index = s7_integer_clamped_if_gmp(sc, pend); if ((index < *start) || - (index > *end)) - out_of_range_error_nr(sc, caller, small_int(position + 1), pend, (index < *start) ? it_is_too_small_string : it_is_too_large_string); + (index > *end)) + out_of_range_error_nr(sc, caller, small_int(position + 1), pend, (index < *start) ? it_is_too_small_string : it_is_too_large_string); *end = index; } return(sc->unused); @@ -27438,23 +27438,23 @@ static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr) { s7_pointer arg = car(p); if ((is_pair(arg)) && - (is_symbol(car(arg))) && - (is_safely_optimized(arg)) && - (has_fn(arg))) - { - if (fn_proc(arg) == g_substring) - { - if (substrs < NUM_STRING_WRAPPERS) - set_c_function(arg, sc->substring_uncopied); - substrs++; - } - else - if (fn_proc(arg) == g_symbol_to_string) - set_c_function(arg, sc->symbol_to_string_uncopied); - else - if ((fn_proc(arg) == g_get_output_string) && (is_null(cddr(arg)))) - set_c_function(arg, sc->get_output_string_uncopied); - }} + (is_symbol(car(arg))) && + (is_safely_optimized(arg)) && + (has_fn(arg))) + { + if (fn_proc(arg) == g_substring) + { + if (substrs < NUM_STRING_WRAPPERS) + set_c_function(arg, sc->substring_uncopied); + substrs++; + } + else + if (fn_proc(arg) == g_symbol_to_string) + set_c_function(arg, sc->symbol_to_string_uncopied); + else + if ((fn_proc(arg) == g_get_output_string) && (is_null(cddr(arg)))) + set_c_function(arg, sc->get_output_string_uncopied); + }} } static s7_pointer string_substring_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr) @@ -27493,19 +27493,19 @@ static s7_pointer g_string_copy(s7_scheme *sc, s7_pointer args) else { if (!s7_is_integer(car(p))) - wrong_type_error_nr(sc, sc->string_copy_symbol, 3, car(p), sc->type_names[T_INTEGER]); + wrong_type_error_nr(sc, sc->string_copy_symbol, 3, car(p), sc->type_names[T_INTEGER]); start = s7_integer_clamped_if_gmp(sc, car(p)); if (start < 0) start = 0; p = cdr(p); if (is_null(p)) - end = start + string_length(source); + end = start + string_length(source); else - { - if (!s7_is_integer(car(p))) - wrong_type_error_nr(sc, sc->string_copy_symbol, 4, car(p), sc->type_names[T_INTEGER]); - end = s7_integer_clamped_if_gmp(sc, car(p)); - if (end < 0) end = start; - }} + { + if (!s7_is_integer(car(p))) + wrong_type_error_nr(sc, sc->string_copy_symbol, 4, car(p), sc->type_names[T_INTEGER]); + end = s7_integer_clamped_if_gmp(sc, car(p)); + if (end < 0) end = start; + }} if (end > string_length(dest)) end = string_length(dest); if (end <= start) return(dest); if ((end - start) > string_length(source)) end = start + string_length(source); @@ -27536,25 +27536,25 @@ static int32_t scheme_strcmp(s7_pointer s1, s7_pointer s2) if (len < sizeof(size_t)) for (size_t i = 0; i < len; i++) { - if ((uint8_t)(str1[i]) < (uint8_t )(str2[i])) - return(-1); - if ((uint8_t)(str1[i]) > (uint8_t)(str2[i])) - return(1); + if ((uint8_t)(str1[i]) < (uint8_t )(str2[i])) + return(-1); + if ((uint8_t)(str1[i]) > (uint8_t)(str2[i])) + return(1); } else { /* this algorithm from stackoverflow(?), with various changes (original did not work for large strings, etc) */ size_t i = 0, last = len / sizeof(size_t); for (const size_t *ptr1 = (size_t *)str1, *ptr2 = (size_t *)str2; i < last; i++) - if (ptr1[i] != ptr2[i]) - break; + if (ptr1[i] != ptr2[i]) + break; for (size_t pos = i * sizeof(size_t); pos < len; pos++) - { - if ((uint8_t)str1[pos] < (uint8_t)str2[pos]) - return(-1); - if ((uint8_t)str1[pos] > (uint8_t)str2[pos]) - return(1); - }} + { + if ((uint8_t)str1[pos] < (uint8_t)str2[pos]) + return(-1); + if ((uint8_t)str1[pos] > (uint8_t)str2[pos]) + return(1); + }} if (len1 < len2) return(-1); return((len1 > len2) ? 1 : 0); @@ -27568,7 +27568,7 @@ static bool is_string_via_method(s7_scheme *sc, s7_pointer p) { s7_pointer f = find_method_with_let(sc, p, sc->is_string_symbol); if (f != sc->undefined) - return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); + return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p)))); } return(false); } @@ -27581,14 +27581,14 @@ static s7_pointer g_string_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_p for (s7_pointer x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) { if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); if (scheme_strcmp(y, car(x)) != val) - { - for (y = cdr(x); is_pair(y); y = cdr(y)) - if (!is_string_via_method(sc, car(y))) - wrong_type_error_nr(sc, sym, position_of(y, args), car(y), sc->type_names[T_STRING]); - return(sc->F); - }} + { + for (y = cdr(x); is_pair(y); y = cdr(y)) + if (!is_string_via_method(sc, car(y))) + wrong_type_error_nr(sc, sym, position_of(y, args), car(y), sc->type_names[T_STRING]); + return(sc->F); + }} return(sc->T); } @@ -27600,21 +27600,21 @@ static s7_pointer g_string_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, for (s7_pointer x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) { if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); if (scheme_strcmp(y, car(x)) == val) - { - for (y = cdr(x); is_pair(y); y = cdr(y)) - if (!is_string_via_method(sc, car(y))) - wrong_type_error_nr(sc, sym, position_of(y, args), car(y), sc->type_names[T_STRING]); - return(sc->F); - }} + { + for (y = cdr(x); is_pair(y); y = cdr(y)) + if (!is_string_via_method(sc, car(y))) + wrong_type_error_nr(sc, sym, position_of(y, args), car(y), sc->type_names[T_STRING]); + return(sc->F); + }} return(sc->T); } static bool scheme_strings_are_equal(s7_pointer x, s7_pointer y) { return((string_length(x) == string_length(y)) && - (strings_are_equal_with_length(string_value(x), string_value(y), string_length(x)))); + (strings_are_equal_with_length(string_value(x), string_value(y), string_length(x)))); } static s7_pointer g_strings_are_equal(s7_scheme *sc, s7_pointer args) @@ -27634,12 +27634,12 @@ static s7_pointer g_strings_are_equal(s7_scheme *sc, s7_pointer args) { s7_pointer p = car(x); if (y != p) - { - if (!is_string(p)) - return(method_or_bust(sc, p, sc->string_eq_symbol, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); - if (happy) - happy = scheme_strings_are_equal(p, y); - }} + { + if (!is_string(p)) + return(method_or_bust(sc, p, sc->string_eq_symbol, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); + if (happy) + happy = scheme_strings_are_equal(p, y); + }} return((happy) ? sc->T : sc->F); } @@ -27806,9 +27806,9 @@ static int32_t scheme_strcasecmp(s7_pointer s1, s7_pointer s2) for (s7_int i = 0; i < len; i++) { if (uppers[(int32_t)str1[i]] < uppers[(int32_t)str2[i]]) - return(-1); + return(-1); if (uppers[(int32_t)str1[i]] > uppers[(int32_t)str2[i]]) - return(1); + return(1); } if (len1 < len2) return(-1); @@ -27849,15 +27849,15 @@ static s7_pointer g_string_ci_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s for (s7_pointer x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) { if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); if (val == 0) - { - if (!scheme_strequal_ci(y, car(x))) - return(check_rest_are_strings(sc, sym, cdr(x), args)); - } + { + if (!scheme_strequal_ci(y, car(x))) + return(check_rest_are_strings(sc, sym, cdr(x), args)); + } else - if (scheme_strcasecmp(y, car(x)) != val) - return(check_rest_are_strings(sc, sym, cdr(x), args)); + if (scheme_strcasecmp(y, car(x)) != val) + return(check_rest_are_strings(sc, sym, cdr(x), args)); } return(sc->T); } @@ -27871,9 +27871,9 @@ static s7_pointer g_string_ci_cmp_not(s7_scheme *sc, s7_pointer args, int32_t va for (s7_pointer x = cdr(args); is_not_null(x); y = car(x), x = cdr(x)) { if (!is_string(car(x))) - return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); + return(method_or_bust(sc, car(x), sym, set_ulist_1(sc, y, x), sc->type_names[T_STRING], position_of(x, args))); if (scheme_strcasecmp(y, car(x)) == val) - return(check_rest_are_strings(sc, sym, cdr(x), args)); + return(check_rest_are_strings(sc, sym, cdr(x), args)); } return(sc->T); } @@ -27968,7 +27968,7 @@ static s7_pointer g_string_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer a { s7_pointer p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end); if (p != sc->unused) - return(p); + return(p); if (start == end) return(chr); } if (end == 0) return(chr); @@ -28004,27 +28004,27 @@ static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym) { s7_pointer p = car(x); if (!is_character(p)) - { - if (has_active_methods(sc, p)) - { - s7_pointer func = find_method_with_let(sc, p, sym); - if (func != sc->undefined) - { - s7_pointer y; - if (len == 0) - return(s7_apply_function(sc, func, args)); - newstr = make_empty_string(sc, len, 0); - str = string_value(newstr); - for (i = 0, y = args; y != x; i++, y = cdr(y)) - str[i] = character(car(y)); - return(g_string_append_1(sc, set_plist_2(sc, newstr, s7_apply_function(sc, func, x)), sym)); - }} - wrong_type_error_nr(sc, sym, len + 1, car(x), sc->type_names[T_CHARACTER]); - }} + { + if (has_active_methods(sc, p)) + { + s7_pointer func = find_method_with_let(sc, p, sym); + if (func != sc->undefined) + { + s7_pointer y; + if (len == 0) + return(s7_apply_function(sc, func, args)); + newstr = make_empty_string(sc, len, 0); + str = string_value(newstr); + for (i = 0, y = args; y != x; i++, y = cdr(y)) + str[i] = character(car(y)); + return(g_string_append_1(sc, set_plist_2(sc, newstr, s7_apply_function(sc, func, x)), sym)); + }} + wrong_type_error_nr(sc, sym, len + 1, car(x), sc->type_names[T_CHARACTER]); + }} if (len > sc->max_string_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "~S result string is too large (> ~D ~D) (*s7* 'max-string-length)", 65), - sym, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); + set_elist_4(sc, wrap_string(sc, "~S result string is too large (> ~D ~D) (*s7* 'max-string-length)", 65), + sym, wrap_integer(sc, len), wrap_integer(sc, sc->max_string_length))); newstr = inline_make_empty_string(sc, len, 0); str = string_value(newstr); for (i = 0, x = args; is_not_null(x); i++, x = cdr(x)) @@ -28076,7 +28076,7 @@ static s7_pointer g_list_to_string(s7_scheme *sc, s7_pointer args) return(nil_string); if (!s7_is_proper_list(sc, car(args))) return(method_or_bust_p(sc, car(args), sc->list_to_string_symbol, - wrap_string(sc, "a (proper, non-circular) list of characters", 43))); + wrap_string(sc, "a (proper, non-circular) list of characters", 43))); return(g_string_1(sc, car(args), sc->list_to_string_symbol)); } #endif @@ -28119,9 +28119,9 @@ static s7_pointer g_string_to_list(s7_scheme *sc, s7_pointer args) if (end == 0) return(sc->nil); if ((end - start) > sc->max_list_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_5(sc, wrap_string(sc, "string->list length ~D, (- ~D ~D), is greater than (*s7* 'max-list-length), ~D", 78), - wrap_integer(sc, end - start), wrap_integer(sc, end), wrap_integer(sc, start), - wrap_integer(sc, sc->max_list_length))); + set_elist_5(sc, wrap_string(sc, "string->list length ~D, (- ~D ~D), is greater than (*s7* 'max-list-length), ~D", 78), + wrap_integer(sc, end - start), wrap_integer(sc, end), wrap_integer(sc, start), + wrap_integer(sc, sc->max_list_length))); sc->w = sc->nil; check_free_heap_size(sc, end - start); for (s7_int i = end - 1; i >= start; i--) @@ -28265,8 +28265,8 @@ static s7_pointer g_set_port_position(s7_scheme *sc, s7_pointer args) else if (is_file_port(port)) { - rewind(port_file(port)); - fseek(port_file(port), (long)position, SEEK_SET); + rewind(port_file(port)); + fseek(port_file(port), (long)position, SEEK_SET); } #endif return(pos); @@ -28326,7 +28326,7 @@ static s7_pointer g_set_port_line_number(s7_scheme *sc, s7_pointer args) { p = car(args); if (!(is_input_port(p))) - wrong_type_error_nr(sc, wrap_string(sc, "set! port-line-number", 21), 1, p, an_input_port_string); + wrong_type_error_nr(sc, wrap_string(sc, "set! port-line-number", 21), 1, p, an_input_port_string); } line = (is_null(cdr(args)) ? car(args) : cadr(args)); if (!is_t_integer(line)) @@ -28352,13 +28352,13 @@ static s7_pointer port_filename_p_p(s7_scheme *sc, s7_pointer x) (!port_is_closed(x))) { if (port_filename(x)) - { - if (port_filename_length(x) > sc->max_string_length) - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "port-filename is too long (> ~D ~D) (*s7* 'max-string-length)", 61), - wrap_integer(sc, port_filename_length(x)), wrap_integer(sc, sc->max_string_length))); - return(make_string_with_length(sc, port_filename(x), port_filename_length(x))); /* not wrapper here! */ - } + { + if (port_filename_length(x) > sc->max_string_length) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "port-filename is too long (> ~D ~D) (*s7* 'max-string-length)", 61), + wrap_integer(sc, port_filename_length(x)), wrap_integer(sc, sc->max_string_length))); + return(make_string_with_length(sc, port_filename(x), port_filename_length(x))); /* not wrapper here! */ + } return(nil_string); /* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */ } @@ -28649,10 +28649,10 @@ static s7_pointer g_close_input_port(s7_scheme *sc, s7_pointer args) static noreturn void file_error_nr(s7_scheme *sc, const char *caller, const char *descr, const char *name) { error_nr(sc, sc->io_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: ~A ~S", 9), - s7_make_string_wrapper(sc, caller), - s7_make_string_wrapper(sc, descr), - s7_make_string_wrapper(sc, name))); + set_elist_4(sc, wrap_string(sc, "~A: ~A ~S", 9), + s7_make_string_wrapper(sc, caller), + s7_make_string_wrapper(sc, descr), + s7_make_string_wrapper(sc, name))); } bool s7_flush_output_port(s7_scheme *sc, s7_pointer p) @@ -28664,12 +28664,12 @@ bool s7_flush_output_port(s7_scheme *sc, s7_pointer p) (port_file(p))) { if (port_position(p) > 0) - { - result = (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) == (size_t)port_position(p)); - port_position(p) = 0; - } + { + result = (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) == (size_t)port_position(p)); + port_position(p) = 0; + } if (fflush(port_file(p)) == -1) - file_error_nr(sc, "flush-output-port", strerror(errno), port_filename(p)); + file_error_nr(sc, "flush-output-port", strerror(errno), port_filename(p)); } return(result); } @@ -28705,14 +28705,14 @@ static void close_output_file(s7_scheme *sc, s7_pointer p) { #if (WITH_WARNINGS) if ((port_position(p) > 0) && - (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) != (size_t)port_position(p))) - s7_warn(sc, 64, "fwrite trouble in close-output-port\n"); + (fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)) != (size_t)port_position(p))) + s7_warn(sc, 64, "fwrite trouble in close-output-port\n"); #else if (port_position(p) > 0) - fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)); + fwrite((void *)(port_data(p)), 1, port_position(p), port_file(p)); #endif if (fflush(port_file(p)) == -1) - s7_warn(sc, 64, "fflush in close-output-port: %s\n", strerror(errno)); + s7_warn(sc, 64, "fflush in close-output-port: %s\n", strerror(errno)); fclose(port_file(p)); port_file(p) = NULL; } @@ -28769,10 +28769,10 @@ static int32_t function_read_char(s7_scheme *sc, s7_pointer port) if (!is_character(res)) /* port_input_function might return some non-character */ { if (is_multiple_value(res)) - { - clear_multiple_value(res); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-char returned: ~S", 42), res)); - } + { + clear_multiple_value(res); + error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-char returned: ~S", 42), res)); + } error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-char returned: ~S", 42), res)); } return((int32_t)character(res)); /* kinda nutty -- we return chars[this] in g_read_char! */ @@ -28856,15 +28856,15 @@ static s7_pointer file_read_line(s7_scheme *sc, s7_pointer port, bool with_eol) char *buf; const char *snew = strchr(sc->read_line_buf, (int)'\n'); /* or maybe just strlen + end-of-string=newline */ if (snew) - { - s7_int pos = (s7_int)(snew - sc->read_line_buf); - port_line_number(port)++; - return(inline_make_string_with_length(sc, sc->read_line_buf, (with_eol) ? (pos + 1) : pos)); - } + { + s7_int pos = (s7_int)(snew - sc->read_line_buf); + port_line_number(port)++; + return(inline_make_string_with_length(sc, sc->read_line_buf, (with_eol) ? (pos + 1) : pos)); + } reads++; cur_size = strlen(sc->read_line_buf); if ((cur_size + reads) < read_size) /* end of data, no newline */ - return(make_string_with_length(sc, sc->read_line_buf, cur_size)); + return(make_string_with_length(sc, sc->read_line_buf, cur_size)); /* need more data */ sc->read_line_buf_size *= 2; @@ -28909,7 +28909,7 @@ static void resize_port_data(s7_scheme *sc, s7_pointer pt, s7_int new_size) if (new_size < loc) return; if (new_size > sc->max_port_data_size) error_nr(sc, make_symbol(sc, "port-too-big", 12), - set_elist_1(sc, wrap_string(sc, "port data size has grown past (*s7* 'max-port-data-size)", 56))); + set_elist_1(sc, wrap_string(sc, "port data size has grown past (*s7* 'max-port-data-size)", 56))); nb = reallocate(sc, port_data_block(pt), new_size); port_data_block(pt) = nb; @@ -29037,15 +29037,15 @@ static void file_write_string(s7_scheme *sc, const char *str, s7_int len, s7_poi if (new_len >= sc->output_file_port_data_size) { if (port_position(pt) > 0) - { + { #if (WITH_WARNINGS) - if (fwrite((void *)(port_data(pt)), 1, port_position(pt), port_file(pt)) != (size_t)port_position(pt)) - s7_warn(sc, 64, "fwrite trouble in write-string\n"); + if (fwrite((void *)(port_data(pt)), 1, port_position(pt), port_file(pt)) != (size_t)port_position(pt)) + s7_warn(sc, 64, "fwrite trouble in write-string\n"); #else - fwrite((void *)(port_data(pt)), 1, port_position(pt), port_file(pt)); + fwrite((void *)(port_data(pt)), 1, port_position(pt), port_file(pt)); #endif - port_position(pt) = 0; - } + port_position(pt) = 0; + } fwrite((const void *)str, 1, len, port_file(pt)); } else @@ -29065,18 +29065,18 @@ static void file_display(s7_scheme *sc, const char *s, s7_pointer port) if (s) { if (port_position(port) > 0) - { + { #if (WITH_WARNINGS) - if (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) != (size_t)port_position(port)) - s7_warn(sc, 64, "fwrite trouble in display\n"); + if (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) != (size_t)port_position(port)) + s7_warn(sc, 64, "fwrite trouble in display\n"); #else - fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)); + fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)); #endif - port_position(port) = 0; - } + port_position(port) = 0; + } #if (WITH_WARNINGS) if (fputs(s, port_file(port)) == EOF) - s7_warn(sc, 64, "write to %s: %s\n", port_filename(port), strerror(errno)); + s7_warn(sc, 64, "write to %s: %s\n", port_filename(port), strerror(errno)); #else fputs(s, port_file(port)); #endif @@ -29137,21 +29137,21 @@ static s7_pointer g_write_string(s7_scheme *sc, s7_pointer args) s7_pointer inds = cddr(args); port = cadr(args); if (!is_null(inds)) - { - s7_pointer p = start_and_end(sc, sc->write_string_symbol, args, 3, inds, &start, &end); - if (p != sc->unused) return(p); - }} + { + s7_pointer p = start_and_end(sc, sc->write_string_symbol, args, 3, inds, &start, &end); + if (p != sc->unused) return(p); + }} else port = current_output_port(sc); if (!is_output_port(port)) { if (port == sc->F) - { - s7_int len; - if ((start == 0) && (end == string_length(str))) - return(str); - len = (s7_int)(end - start); - return(make_string_with_length(sc, (char *)(string_value(str) + start), len)); - } + { + s7_int len; + if ((start == 0) && (end == string_length(str))) + return(str); + len = (s7_int)(end - start); + return(make_string_with_length(sc, (char *)(string_value(str) + start), len)); + } check_method(sc, port, sc->write_string_symbol, args); wrong_type_error_nr(sc, sc->write_string_symbol, 2, port, an_output_port_or_f_string); } @@ -29249,11 +29249,11 @@ static s7_pointer file_read_name_or_sharp(s7_scheme *sc, s7_pointer pt, bool ato else { if (c != EOF) - { - if (c == '\n') - port_line_number(pt)--; - ungetc(c, port_file(pt)); - } + { + if (c == '\n') + port_line_number(pt)--; + ungetc(c, port_file(pt)); + } sc->strbuf[i - 1] = '\0'; } if (atom_case) @@ -29278,7 +29278,7 @@ static s7_pointer string_read_name_no_free(s7_scheme *sc, s7_pointer pt) while (char_ok_in_a_name[*str]) str++; k = str - orig_str; if (*str != 0) - port_position(pt) += (k - 1); + port_position(pt) += (k - 1); else port_position(pt) = port_data_size(pt); /* this is equivalent to: * str = strpbrk(str, "(); \"\t\r\n"); @@ -29286,11 +29286,11 @@ static s7_pointer string_read_name_no_free(s7_scheme *sc, s7_pointer pt) * but slightly faster. */ if (!number_table[*orig_str]) - return(inline_make_symbol(sc, (const char *)orig_str, k)); + return(inline_make_symbol(sc, (const char *)orig_str, k)); /* eval_c_string string is a constant so we can't set and unset the token's end char */ if ((k + 1) >= sc->strbuf_size) - resize_strbuf(sc, k + 1); + resize_strbuf(sc, k + 1); memcpy((void *)(sc->strbuf), (void *)orig_str, k); sc->strbuf[k] = '\0'; @@ -29321,7 +29321,7 @@ static s7_pointer string_read_sharp(s7_scheme *sc, s7_pointer pt) k = str - orig_str; port_position(pt) += (k - 1); if ((k + 1) >= sc->strbuf_size) - resize_strbuf(sc, k + 1); + resize_strbuf(sc, k + 1); memcpy((void *)(sc->strbuf), (void *)orig_str, k); sc->strbuf[k] = '\0'; return(make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true)); @@ -29356,7 +29356,7 @@ static s7_pointer string_read_name(s7_scheme *sc, s7_pointer pt) k = str - orig_str; port_position(pt) += (k - 1); if (!number_table[*orig_str]) - return(inline_make_symbol(sc, (const char *)orig_str, k)); + return(inline_make_symbol(sc, (const char *)orig_str, k)); endc = *str; *str = 0; result = make_atom(sc, (char *)orig_str, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR); @@ -29441,15 +29441,15 @@ static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int ma uint8_t *content = (uint8_t *)(block_data(block)); size_t bytes = fread(content, sizeof(uint8_t), size, fp); if (bytes != (size_t)size) - { - if (current_output_port(sc) != sc->F) - { - char tmp[256]; - int32_t len = snprintf(tmp, 256, "(%s \"%s\") read %ld bytes of an expected %" ld64 "?", caller, name, (long)bytes, size); - port_write_string(current_output_port(sc))(sc, tmp, clamp_length(len, 256), current_output_port(sc)); - } - size = bytes; - } + { + if (current_output_port(sc) != sc->F) + { + char tmp[256]; + int32_t len = snprintf(tmp, 256, "(%s \"%s\") read %ld bytes of an expected %" ld64 "?", caller, name, (long)bytes, size); + port_write_string(current_output_port(sc))(sc, tmp, clamp_length(len, 256), current_output_port(sc)); + } + size = bytes; + } content[size] = '\0'; content[size + 1] = '\0'; fclose(fp); @@ -29506,18 +29506,18 @@ static int32_t remember_file_name(s7_scheme *sc, const char *file) int32_t old_size = 0; /* what if file_names_size is greater than file_bits in pair|profile_file? */ if (sc->file_names_size == 0) - { - sc->file_names_size = INITIAL_FILE_NAMES_SIZE; - sc->file_names = (s7_pointer *)Malloc(sc->file_names_size * sizeof(s7_pointer)); - } + { + sc->file_names_size = INITIAL_FILE_NAMES_SIZE; + sc->file_names = (s7_pointer *)Malloc(sc->file_names_size * sizeof(s7_pointer)); + } else - { - old_size = sc->file_names_size; - sc->file_names_size *= 2; - sc->file_names = (s7_pointer *)Realloc(sc->file_names, sc->file_names_size * sizeof(s7_pointer)); - } + { + old_size = sc->file_names_size; + sc->file_names_size *= 2; + sc->file_names = (s7_pointer *)Realloc(sc->file_names, sc->file_names_size * sizeof(s7_pointer)); + } for (int32_t i = old_size; i < sc->file_names_size; i++) - sc->file_names[i] = sc->F; + sc->file_names[i] = sc->F; } sc->file_names[sc->file_names_top] = s7_make_semipermanent_string(sc, file); return(sc->file_names_top); @@ -29544,7 +29544,7 @@ static bool is_directory(const char *filename) #ifdef S_ISDIR struct stat statbuf; return((stat(filename, &statbuf) >= 0) && - (S_ISDIR(statbuf.st_mode))); + (S_ISDIR(statbuf.st_mode))); #endif #endif return(false); @@ -29557,14 +29557,14 @@ static block_t *expand_filename(s7_scheme *sc, const char *name) { char *home = getenv("HOME"); if (home) - { - s7_int len = safe_strlen(name) + safe_strlen(home) + 1; - block_t *b = mallocate(sc, len); - char *filename = (char *)block_data(b); - filename[0] = '\0'; - catstrs(filename, len, home, (const char *)(name + 1), (char *)NULL); - return(b); - }} + { + s7_int len = safe_strlen(name) + safe_strlen(home) + 1; + block_t *b = mallocate(sc, len); + char *filename = (char *)block_data(b); + filename[0] = '\0'; + catstrs(filename, len, home, (const char *)(name + 1), (char *)NULL); + return(b); + }} #endif return(NULL); } @@ -29596,7 +29596,7 @@ static s7_pointer open_input_file_1(s7_scheme *sc, const char *name, const char fp = fopen(new_name, mode); liberate(sc, b); if (fp) - return(make_input_file(sc, name, fp)); + return(make_input_file(sc, name, fp)); } #endif #endif @@ -29727,7 +29727,7 @@ s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode { #if (!MS_WINDOWS) if (errno == EINVAL) - file_error_nr(sc, "open-output-file", "invalid mode", mode); + file_error_nr(sc, "open-output-file", "invalid mode", mode); #endif file_error_nr(sc, "open-output-file", strerror(errno), name); } @@ -29777,7 +29777,7 @@ static s7_pointer g_open_output_file(s7_scheme *sc, s7_pointer args) static const port_functions_t input_string_functions = {string_read_char, input_write_char, input_write_string, string_read_semicolon, terminated_string_read_white_space, - string_read_name_no_free, string_read_sharp, string_read_line, input_display, close_simple_input_string}; + string_read_name_no_free, string_read_sharp, string_read_line, input_display, close_simple_input_string}; static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_int len) { @@ -29809,7 +29809,7 @@ static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_ if ((len > 0) && (input_string[len] != '\0')) { fprintf(stderr, "%s%s[%d]: input_string is not terminated: len: %" ld64 ", at end: %c%c, str: %s%s\n", - bold_text, __func__, __LINE__, len, input_string[len - 1], input_string[len], input_string, unbold_text); + bold_text, __func__, __LINE__, len, input_string[len - 1], input_string[len], input_string, unbold_text); if (sc->stop_at_error) abort(); } #endif @@ -29903,8 +29903,8 @@ static inline void check_get_output_string_port(s7_scheme *sc, s7_pointer p) wrong_type_error_nr(sc, sc->get_output_string_symbol, 1, p, wrap_string(sc, "an active (open) string port", 28)); if (port_position(p) > sc->max_string_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "get-output-string port-position ~D is greater than (*s7* 'max-string-length), ~D", 80), - wrap_integer(sc, port_position(p)), wrap_integer(sc, sc->max_string_length))); + set_elist_3(sc, wrap_string(sc, "get-output-string port-position ~D is greater than (*s7* 'max-string-length), ~D", 80), + wrap_integer(sc, port_position(p)), wrap_integer(sc, sc->max_string_length))); } /* if pos>max and clear, where should the clear be? Not here because we might want to see output in error handler. * similarly below if pos>size how can we call make_string (out-of-bounds) and ignore error? @@ -29924,7 +29924,7 @@ If the optional 'clear-port' is #t, the current string is flushed." { p = cadr(args); if (!is_boolean(p)) - wrong_type_error_nr(sc, sc->get_output_string_symbol, 2, p, sc->type_names[T_BOOLEAN]); + wrong_type_error_nr(sc, sc->get_output_string_symbol, 2, p, sc->type_names[T_BOOLEAN]); clear_port = (p == sc->T); } p = car(args); @@ -29988,7 +29988,7 @@ static s7_pointer g_get_output_string_uncopied(s7_scheme *sc, s7_pointer args) static s7_pointer g_closed_input_function_port(s7_scheme *sc, s7_pointer unused_args) { error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_1(sc, wrap_string(sc, "attempt to read from a closed input-function port", 49))); + set_elist_1(sc, wrap_string(sc, "attempt to read from a closed input-function port", 49))); return(NULL); } @@ -30059,7 +30059,7 @@ static s7_pointer g_open_input_function(s7_scheme *sc, s7_pointer args) sole_arg_wrong_type_error_nr(sc, sc->open_input_function_symbol, func, a_procedure_string); if (!s7_is_aritable(sc, func, 1)) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "input-function-port function, ~A, should take one argument", 58), func)); + set_elist_2(sc, wrap_string(sc, "input-function-port function, ~A, should take one argument", 58), func)); port = s7_open_input_function(sc, input_scheme_function_wrapper); port_set_string_or_function(port, func); @@ -30115,7 +30115,7 @@ static s7_pointer g_open_output_function(s7_scheme *sc, s7_pointer args) sole_arg_wrong_type_error_nr(sc, sc->open_output_function_symbol, func, a_procedure_string); if (!s7_is_aritable(sc, func, 1)) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "output-function-port function, ~A, should take one argument", 59), func)); + set_elist_2(sc, wrap_string(sc, "output-function-port function, ~A, should take one argument", 59), func)); port = s7_open_output_function(sc, output_scheme_function_wrapper); port_set_string_or_function(port, func); @@ -30280,11 +30280,11 @@ static s7_pointer g_peek_char(s7_scheme *sc, s7_pointer args) { clear_multiple_value(res); error_nr(sc, sc->bad_result_symbol, - set_elist_2(sc, wrap_string(sc, "input-function-port peek-char returned multiple values: ~S", 58), res)); + set_elist_2(sc, wrap_string(sc, "input-function-port peek-char returned multiple values: ~S", 58), res)); } if (!is_character(res)) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "input-function-port peek-char returned: ~S", 42), res)); + set_elist_2(sc, wrap_string(sc, "input-function-port peek-char returned: ~S", 42), res)); return(res); } @@ -30358,10 +30358,10 @@ If 'with-eol' is not #f, read-line includes the trailing end-of-line character." { port = car(args); if (!is_input_port(port)) - return(method_or_bust(sc, port, sc->read_line_symbol, args, an_input_port_string, 1)); + return(method_or_bust(sc, port, sc->read_line_symbol, args, an_input_port_string, 1)); if (is_not_null(cdr(args))) - with_eol = (cadr(args) != sc->F); /* perhaps this should insist on #t: (read-line port (c-pointer 0)) */ + with_eol = (cadr(args) != sc->F); /* perhaps this should insist on #t: (read-line port (c-pointer 0)) */ } else { @@ -30408,8 +30408,8 @@ static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args) out_of_range_error_nr(sc, sc->read_string_symbol, int_one, k, it_is_negative_string); if (nchars > sc->max_string_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "read-string first argument ~D is greater than (*s7* 'max-string-length), ~D", 75), - wrap_integer(sc, nchars), wrap_integer(sc, sc->max_string_length))); + set_elist_3(sc, wrap_string(sc, "read-string first argument ~D is greater than (*s7* 'max-string-length), ~D", 75), + wrap_integer(sc, nchars), wrap_integer(sc, sc->max_string_length))); if (!is_null(cdr(args))) port = cadr(args); @@ -30450,12 +30450,12 @@ static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args) { int32_t c = port_read_character(port)(sc, port); if (c == EOF) - { - if (i == 0) - return(eof_object); - string_length(s) = i; - return(s); - } + { + if (i == 0) + return(eof_object); + string_length(s) = i; + return(s); + } str[i] = (uint8_t)c; } return(s); @@ -30465,29 +30465,29 @@ static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args) /* -------------------------------- read -------------------------------- */ #define declare_jump_info() bool old_longjmp; setjmp_loc_t old_jump_loc; jump_loc_t jump_loc; Jmp_Buf *old_goto_start; Jmp_Buf new_goto_start -#define store_jump_info(Sc) \ - do { \ - old_longjmp = Sc->longjmp_ok; \ - old_jump_loc = Sc->setjmp_loc; \ - old_goto_start = Sc->goto_start; \ +#define store_jump_info(Sc) \ + do { \ + old_longjmp = Sc->longjmp_ok; \ + old_jump_loc = Sc->setjmp_loc; \ + old_goto_start = Sc->goto_start; \ } while (0) -#define restore_jump_info(Sc) \ - do { \ - Sc->longjmp_ok = old_longjmp; \ - Sc->setjmp_loc = old_jump_loc; \ - Sc->goto_start = old_goto_start; \ - if ((jump_loc == ERROR_JUMP) && \ - (Sc->longjmp_ok)) \ - LongJmp(*(Sc->goto_start), ERROR_JUMP); \ +#define restore_jump_info(Sc) \ + do { \ + Sc->longjmp_ok = old_longjmp; \ + Sc->setjmp_loc = old_jump_loc; \ + Sc->goto_start = old_goto_start; \ + if ((jump_loc == ERROR_JUMP) && \ + (Sc->longjmp_ok)) \ + LongJmp(*(Sc->goto_start), ERROR_JUMP); \ } while (0) -#define set_jump_info(Sc, Tag) \ - do { \ - Sc->longjmp_ok = true; \ - Sc->setjmp_loc = Tag; \ - jump_loc = (jump_loc_t)SetJmp(new_goto_start, 1); \ - Sc->goto_start = &new_goto_start; \ +#define set_jump_info(Sc, Tag) \ + do { \ + Sc->longjmp_ok = true; \ + Sc->setjmp_loc = Tag; \ + jump_loc = (jump_loc_t)SetJmp(new_goto_start, 1); \ + Sc->goto_start = &new_goto_start; \ } while (0) static s7_pointer eval(s7_scheme *sc, opcode_t first_op); @@ -30503,21 +30503,21 @@ s7_pointer s7_read(s7_scheme *sc, s7_pointer port) store_jump_info(sc); set_jump_info(sc, READ_SET_JUMP); if (jump_loc != NO_JUMP) - { - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - } + { + if (jump_loc != ERROR_JUMP) + eval(sc, sc->cur_op); + } else - { - push_stack_no_let_no_code(sc, OP_BARRIER, port); - push_stack_direct(sc, OP_EVAL_DONE); - eval(sc, OP_READ_INTERNAL); - if (sc->tok == TOKEN_EOF) - sc->value = eof_object; - if ((sc->cur_op == OP_EVAL_DONE) && /* pushed above */ - (stack_top_op(sc) == OP_BARRIER)) - pop_stack(sc); - } + { + push_stack_no_let_no_code(sc, OP_BARRIER, port); + push_stack_direct(sc, OP_EVAL_DONE); + eval(sc, OP_READ_INTERNAL); + if (sc->tok == TOKEN_EOF) + sc->value = eof_object; + if ((sc->cur_op == OP_EVAL_DONE) && /* pushed above */ + (stack_top_op(sc) == OP_BARRIER)) + pop_stack(sc); + } pop_input_port(sc); set_curlet(sc, old_let); restore_jump_info(sc); @@ -30547,10 +30547,10 @@ static s7_pointer g_read(s7_scheme *sc, s7_pointer args) { s7_pointer res = (*(port_input_function(port)))(sc, S7_READ, port); if (is_multiple_value(res)) - { - clear_multiple_value(res); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read returned: ~S", 37), res)); - } + { + clear_multiple_value(res); + error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read returned: ~S", 37), res)); + } return(res); } if ((is_string_port(port)) && @@ -30617,25 +30617,25 @@ static block_t *search_load_path(s7_scheme *sc, const char *name) char *filename = (char *)block_data(b); s7_int name_len = safe_strlen(name); for (s7_pointer dir_names = lst; is_pair(dir_names); dir_names = cdr(dir_names)) - { - const char *new_dir = string_value(car(dir_names)); - if (new_dir) - { - if ((WITH_WARNINGS) && (string_length(car(dir_names)) + name_len >= S7_FILENAME_MAX)) - s7_warn(sc, 256, "load: file + directory name too long: %" ld64 " + %" ld64 " > %d\n", - name_len, string_length(car(dir_names)), S7_FILENAME_MAX); - filename[0] = '\0'; - if (new_dir[strlen(new_dir) - 1] == '/') - catstrs(filename, S7_FILENAME_MAX, new_dir, name, (char *)NULL); - else catstrs(filename, S7_FILENAME_MAX, new_dir, "/", name, (char *)NULL); + { + const char *new_dir = string_value(car(dir_names)); + if (new_dir) + { + if ((WITH_WARNINGS) && (string_length(car(dir_names)) + name_len >= S7_FILENAME_MAX)) + s7_warn(sc, 256, "load: file + directory name too long: %" ld64 " + %" ld64 " > %d\n", + name_len, string_length(car(dir_names)), S7_FILENAME_MAX); + filename[0] = '\0'; + if (new_dir[strlen(new_dir) - 1] == '/') + catstrs(filename, S7_FILENAME_MAX, new_dir, name, (char *)NULL); + else catstrs(filename, S7_FILENAME_MAX, new_dir, "/", name, (char *)NULL); #ifdef _MSC_VER - if (_access(filename, 0) != -1) - return(b); + if (_access(filename, 0) != -1) + return(b); #else - if (access(filename, F_OK) == 0) - return(b); + if (access(filename, F_OK) == 0) + return(b); #endif - }} + }} liberate(sc, b); } return(NULL); @@ -30666,18 +30666,18 @@ static block_t *full_filename(s7_scheme *sc, const char *filename) block = mallocate(sc, len); rtn = (char *)block_data(block); if (pwd) - { - memcpy((void *)rtn, (void *)pwd, pwd_len); - rtn[pwd_len] = '/'; - memcpy((void *)(rtn + pwd_len + 1), (const void *)filename, filename_len); - rtn[pwd_len + filename_len + 1] = '\0'; + { + memcpy((void *)rtn, (void *)pwd, pwd_len); + rtn[pwd_len] = '/'; + memcpy((void *)(rtn + pwd_len + 1), (const void *)filename, filename_len); + rtn[pwd_len + filename_len + 1] = '\0'; free(pwd); - } + } else /* isn't this an error? -- perhaps warn about getcwd, strerror(errno) */ - { + { memcpy((void *)rtn, (const void *)filename, filename_len); rtn[filename_len] = '\0'; - }} + }} return(block); } @@ -30695,86 +30695,86 @@ static s7_pointer load_shared_object(s7_scheme *sc, const char *fname, s7_pointe block_t *pname = NULL; if ((access(fname, F_OK) == 0) || (fname[0] == '/')) - { - pname = full_filename(sc, fname); - pwd_name = (char *)block_data(pname); - } + { + pname = full_filename(sc, fname); + pwd_name = (char *)block_data(pname); + } else - { - block_t *searched = search_load_path(sc, fname); /* returns NULL if *load-path* is nil, or if nothing matches */ - if (searched) - { - if (((const char *)block_data(searched))[0] == '/') - pname = searched; - else - { /* this is necessary, at least in Linux -- we can't blithely dlopen whatever is passed to us */ - pname = full_filename(sc, (const char *)block_data(searched)); - liberate(sc, searched); - } - pwd_name = (char *)block_data(pname); - } - else /* perhaps no *load-path* entries */ - { - pname = full_filename(sc, fname); - pwd_name = (char *)block_data(pname); - }} + { + block_t *searched = search_load_path(sc, fname); /* returns NULL if *load-path* is nil, or if nothing matches */ + if (searched) + { + if (((const char *)block_data(searched))[0] == '/') + pname = searched; + else + { /* this is necessary, at least in Linux -- we can't blithely dlopen whatever is passed to us */ + pname = full_filename(sc, (const char *)block_data(searched)); + liberate(sc, searched); + } + pwd_name = (char *)block_data(pname); + } + else /* perhaps no *load-path* entries */ + { + pname = full_filename(sc, fname); + pwd_name = (char *)block_data(pname); + }} if ((S7_DEBUGGING) && (!pname)) fprintf(stderr, "pname is null\n"); library = dlopen((pname) ? pwd_name : fname, RTLD_NOW); if (!library) - s7_warn(sc, 512, "load %s failed: %s\n", (pname) ? pwd_name : fname, dlerror()); + s7_warn(sc, 512, "load %s failed: %s\n", (pname) ? pwd_name : fname, dlerror()); else - if (let) /* look for 'init_func in let -- let has been checked by caller that it actually is a let */ - { - s7_pointer init = let_ref_p_pp(sc, let, make_symbol(sc, "init_func", 9)); - /* init is a symbol (surely not a gensym?), so it should not need to be protected */ - if (!is_symbol(init)) - s7_warn(sc, 512, "can't load %s: no init function\n", fname); - else - { - const char *init_name; - void *init_func; - - if (hook_has_functions(sc->load_hook)) - s7_apply_function(sc, sc->load_hook, set_plist_1(sc, s7_make_string(sc, (pname) ? (const char *)pwd_name : fname))); - - init_name = symbol_name(init); - init_func = dlsym(library, init_name); - if (init_func) - { - typedef void (*dl_func)(s7_scheme *sc); - typedef s7_pointer (*dl_func_with_args)(s7_scheme *sc, s7_pointer args); - s7_pointer init_args = let_ref_p_pp(sc, let, make_symbol(sc, "init_args", 9)); - s7_pointer p; - gc_protect_via_stack(sc, init_args); - if (is_pair(init_args)) - { - p = ((dl_func_with_args)init_func)(sc, init_args); - set_stack_protected2(sc, p); - } - /* if caller includes init_args, but init_func is actually a dl_func, it seems to be ok, - * but the returned value is whatever was last computed in the init_func. - */ - else - { - /* if the init_func is expecting args, but caller forgets init_args, this gives a segfault when - * init_func accesses the forgotten args. s7_is_valid can't catch this currently -- - * we need a better way to tell that a random value can't be a cell pointer (scan permallocs and use heap_location?) - */ - ((dl_func)init_func)(sc); - p = sc->F; - } - unstack_gc_protect(sc); - if (pname) liberate(sc, pname); - return(p); - } - s7_warn(sc, 512, "loaded %s, but can't find init_func %s, dlerror: %s, let: %s\n", - fname, init_name, dlerror(), display(let)); - dlclose(library); - } - if (S7_DEBUGGING) fprintf(stderr, "init_func trouble in %s, %s\n", fname, display(init)); - if (pname) liberate(sc, pname); - return(sc->undefined); - } + if (let) /* look for 'init_func in let -- let has been checked by caller that it actually is a let */ + { + s7_pointer init = let_ref_p_pp(sc, let, make_symbol(sc, "init_func", 9)); + /* init is a symbol (surely not a gensym?), so it should not need to be protected */ + if (!is_symbol(init)) + s7_warn(sc, 512, "can't load %s: no init function\n", fname); + else + { + const char *init_name; + void *init_func; + + if (hook_has_functions(sc->load_hook)) + s7_apply_function(sc, sc->load_hook, set_plist_1(sc, s7_make_string(sc, (pname) ? (const char *)pwd_name : fname))); + + init_name = symbol_name(init); + init_func = dlsym(library, init_name); + if (init_func) + { + typedef void (*dl_func)(s7_scheme *sc); + typedef s7_pointer (*dl_func_with_args)(s7_scheme *sc, s7_pointer args); + s7_pointer init_args = let_ref_p_pp(sc, let, make_symbol(sc, "init_args", 9)); + s7_pointer p; + gc_protect_via_stack(sc, init_args); + if (is_pair(init_args)) + { + p = ((dl_func_with_args)init_func)(sc, init_args); + set_stack_protected2(sc, p); + } + /* if caller includes init_args, but init_func is actually a dl_func, it seems to be ok, + * but the returned value is whatever was last computed in the init_func. + */ + else + { + /* if the init_func is expecting args, but caller forgets init_args, this gives a segfault when + * init_func accesses the forgotten args. s7_is_valid can't catch this currently -- + * we need a better way to tell that a random value can't be a cell pointer (scan permallocs and use heap_location?) + */ + ((dl_func)init_func)(sc); + p = sc->F; + } + unstack_gc_protect(sc); + if (pname) liberate(sc, pname); + return(p); + } + s7_warn(sc, 512, "loaded %s, but can't find init_func %s, dlerror: %s, let: %s\n", + fname, init_name, dlerror(), display(let)); + dlclose(library); + } + if (S7_DEBUGGING) fprintf(stderr, "init_func trouble in %s, %s\n", fname, display(init)); + if (pname) liberate(sc, pname); + return(sc->undefined); + } if (pname) liberate(sc, pname); } return(NULL); @@ -30790,11 +30790,11 @@ static s7_pointer load_file_1(s7_scheme *sc, const char *filename) { block_t *b = expand_filename(sc, filename); if (b) - { - fp = fopen((char *)block_data(b), "r"); - if (fp) local_file_name = copy_string((char *)block_data(b)); - liberate(sc, b); - }} + { + fp = fopen((char *)block_data(b), "r"); + if (fp) local_file_name = copy_string((char *)block_data(b)); + liberate(sc, b); + }} #endif if (!fp) { @@ -30810,7 +30810,7 @@ static s7_pointer load_file_1(s7_scheme *sc, const char *filename) { s7_pointer port; if (hook_has_functions(sc->load_hook)) - s7_apply_function(sc, sc->load_hook, set_plist_1(sc, s7_make_string(sc, (local_file_name) ? local_file_name : filename))); + s7_apply_function(sc, sc->load_hook, set_plist_1(sc, s7_make_string(sc, (local_file_name) ? local_file_name : filename))); port = read_file(sc, fp, (local_file_name) ? local_file_name : filename, -1, "load"); /* -1 = read entire file into string, this is currently not tweakable */ port_file_number(port) = remember_file_name(sc, (local_file_name) ? local_file_name : filename); if (local_file_name) free(local_file_name); @@ -30917,10 +30917,10 @@ defaults to the rootlet. To load into the current environment instead, pass (cu { s7_pointer e = cadr(args); if (!is_let(e)) - wrong_type_error_nr(sc, sc->load_symbol, 2, e, a_let_string); + wrong_type_error_nr(sc, sc->load_symbol, 2, e, a_let_string); if (e == sc->s7_starlet) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "can't load ~S into *s7*", 23), name)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "can't load ~S into *s7*", 23), name)); set_curlet(sc, e); } else set_curlet(sc, sc->rootlet); @@ -30928,11 +30928,11 @@ defaults to the rootlet. To load into the current environment instead, pass (cu fname = string_value(name); if ((!fname) || (!(*fname))) /* fopen("", "r") returns a file pointer?? */ error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "load's first argument, ~S, should be a filename", 47), name)); + set_elist_2(sc, wrap_string(sc, "load's first argument, ~S, should be a filename", 47), name)); if (is_directory(fname)) error_nr(sc, sc->io_error_symbol, - set_elist_2(sc, wrap_string(sc, "load: ~S is a directory", 23), wrap_string(sc, fname, safe_strlen(fname)))); + set_elist_2(sc, wrap_string(sc, "load: ~S is a directory", 23), wrap_string(sc, fname, safe_strlen(fname)))); #if WITH_C_LOADER { s7_pointer p = load_shared_object(sc, fname, sc->curlet); @@ -31004,10 +31004,10 @@ void s7_autoload_set_names(s7_scheme *sc, const char **names, s7_int size) if (sc->safety > IMMUTABLE_VECTOR_SAFETY) for (int32_t i = 0, k = 2; k < (size * 2); i += 2, k += 2) if ((names[i]) && (names[k]) && (strcmp(names[i], names[k]) > 0)) - { - s7_warn(sc, 256, "%s: names[%d]: %s is out of order\n", __func__, k, names[k]); - break; - } + { + s7_warn(sc, 256, "%s: names[%d]: %s is out of order\n", __func__, k, names[k]); + break; + } if (!sc->autoload_names) { sc->autoload_names = (const char ***)Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(const char **)); @@ -31019,16 +31019,16 @@ void s7_autoload_set_names(s7_scheme *sc, const char **names, s7_int size) else if (sc->autoload_names_loc >= sc->autoload_names_top) { - sc->autoload_names_top *= 2; - sc->autoload_names = (const char ***)Realloc(sc->autoload_names, sc->autoload_names_top * sizeof(const char **)); - sc->autoload_names_sizes = (s7_int *)Realloc(sc->autoload_names_sizes, sc->autoload_names_top * sizeof(s7_int)); - sc->autoloaded_already = (bool **)Realloc(sc->autoloaded_already, sc->autoload_names_top * sizeof(bool *)); - for (s7_int i = sc->autoload_names_loc; i < sc->autoload_names_top; i++) - { - sc->autoload_names[i] = NULL; - sc->autoload_names_sizes[i] = 0; - sc->autoloaded_already[i] = NULL; - }} + sc->autoload_names_top *= 2; + sc->autoload_names = (const char ***)Realloc(sc->autoload_names, sc->autoload_names_top * sizeof(const char **)); + sc->autoload_names_sizes = (s7_int *)Realloc(sc->autoload_names_sizes, sc->autoload_names_top * sizeof(s7_int)); + sc->autoloaded_already = (bool **)Realloc(sc->autoloaded_already, sc->autoload_names_top * sizeof(bool *)); + for (s7_int i = sc->autoload_names_loc; i < sc->autoload_names_top; i++) + { + sc->autoload_names[i] = NULL; + sc->autoload_names_sizes[i] = 0; + sc->autoloaded_already[i] = NULL; + }} sc->autoload_names[sc->autoload_names_loc] = names; sc->autoload_names_sizes[sc->autoload_names_loc] = size; sc->autoloaded_already[sc->autoload_names_loc] = (bool *)Calloc(size, sizeof(bool)); @@ -31044,23 +31044,23 @@ static const char *find_autoload_name(s7_scheme *sc, s7_pointer symbol, bool *al s7_int u = sc->autoload_names_sizes[lib] - 1; const char **names = sc->autoload_names[lib]; while (true) - { - s7_int comp, pos; - const char *this_name; - if (u < l) break; - pos = (l + u) / 2; - this_name = names[pos * 2]; - comp = strcmp(this_name, name); - if (comp == 0) - { - *already_loaded = sc->autoloaded_already[lib][pos]; - if (loading) sc->autoloaded_already[lib][pos] = true; - return(names[pos * 2 + 1]); /* file name given func name */ - } - if (comp < 0) - l = pos + 1; - else u = pos - 1; - }} + { + s7_int comp, pos; + const char *this_name; + if (u < l) break; + pos = (l + u) / 2; + this_name = names[pos * 2]; + comp = strcmp(this_name, name); + if (comp == 0) + { + *already_loaded = sc->autoloaded_already[lib][pos]; + if (loading) sc->autoloaded_already[lib][pos] = true; + return(names[pos * 2 + 1]); /* file name given func name */ + } + if (comp < 0) + l = pos + 1; + else u = pos - 1; + }} return(NULL); } @@ -31073,7 +31073,7 @@ s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_func { const s7_pointer p = s7_hash_table_ref(sc, sc->autoload_table, symbol); if ((p != sc->F) && (p != file_or_function)) - s7_warn(sc, 256, "'%s autoload value changed\n", symbol_name(symbol)); + s7_warn(sc, 256, "'%s autoload value changed\n", symbol_name(symbol)); } s7_hash_table_set(sc, sc->autoload_table, symbol, file_or_function); return(file_or_function); @@ -31091,7 +31091,7 @@ in the file, or by the function." if (is_string(sym)) { if (string_length(sym) == 0) /* (autoload "" ...) */ - wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a symbol-name or a symbol", 25)); + wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a symbol-name or a symbol", 25)); sym = make_symbol(sc, string_value(sym), string_length(sym)); } if (!is_symbol(sym)) @@ -31132,7 +31132,7 @@ static s7_pointer g_autoloader(s7_scheme *sc, s7_pointer args) /* the *autoload* bool loaded = false; const char *file = find_autoload_name(sc, sym, &loaded, false); if (file) - return(s7_make_string(sc, file)); + return(s7_make_string(sc, file)); } if (is_hash_table(sc->autoload_table)) return(s7_hash_table_ref(sc, sc->autoload_table, sym)); @@ -31169,35 +31169,35 @@ The symbols refer to the argument to \"provide\". (require lint.scm)" { s7_pointer sym; if (is_symbol(car(p))) - sym = car(p); + sym = car(p); else - if ((is_proper_quote(sc, car(p))) && - (is_symbol(cadar(p)))) - sym = cadar(p); - else - { - unstack_gc_protect(sc); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "require: ~S is not a symbol", 27), car(p))); - } + if ((is_proper_quote(sc, car(p))) && + (is_symbol(cadar(p)))) + sym = cadar(p); + else + { + unstack_gc_protect(sc); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "require: ~S is not a symbol", 27), car(p))); + } if ((!is_a_feature(sym, s7_symbol_value(sc, sc->features_symbol))) && - (sc->is_autoloading)) - { - s7_pointer f = g_autoloader(sc, set_plist_1(sc, sym)); - if (is_false(sc, f)) - { - unstack_gc_protect(sc); - error_nr(sc, sc->autoload_error_symbol, - set_elist_2(sc, wrap_string(sc, "require: no autoload info for ~S", 32), sym)); - } - if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, f)); - if (is_string(f)) - s7_load_with_environment(sc, string_value(f), sc->curlet); - else - if (is_closure(f)) /* f should be a function of one argument, the current (calling) environment */ - s7_call(sc, f, set_ulist_1(sc, sc->curlet, sc->nil)); - }} + (sc->is_autoloading)) + { + s7_pointer f = g_autoloader(sc, set_plist_1(sc, sym)); + if (is_false(sc, f)) + { + unstack_gc_protect(sc); + error_nr(sc, sc->autoload_error_symbol, + set_elist_2(sc, wrap_string(sc, "require: no autoload info for ~S", 32), sym)); + } + if (hook_has_functions(sc->autoload_hook)) + s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, f)); + if (is_string(f)) + s7_load_with_environment(sc, string_value(f), sc->curlet); + else + if (is_closure(f)) /* f should be a function of one argument, the current (calling) environment */ + s7_call(sc, f, set_ulist_1(sc, sc->curlet, sc->nil)); + }} if (stack_top_op(sc) == OP_GC_PROTECT) unstack_gc_protect(sc); /* op_error_quit if load failed in scheme in Snd */ return(sc->T); } @@ -31228,9 +31228,9 @@ static s7_pointer g_is_provided(s7_scheme *sc, s7_pointer args) for (; x; x = let_outlet(x)) for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) if ((slot_symbol(y) == sc->features_symbol) && - (slot_value(y) != topf) && - (is_a_feature(sym, slot_value(y)))) - return(sc->T); + (slot_value(y) != topf) && + (is_a_feature(sym, slot_value(y)))) + return(sc->T); return(sc->F); } @@ -31265,15 +31265,15 @@ static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym) { s7_pointer lst = slot_value(s7_slot(sc, sc->features_symbol)); /* in either case, we want the current *features* list */ if (p == sc->undefined) - { - /* (setter symbol) follows local lets, so we need to make sure this one is set */ - s7_pointer slot = add_slot_checked_with_id(sc, sc->curlet, sc->features_symbol, cons(sc, sym, lst)); - slot_set_setter(slot, sc->features_setter); - slot_set_has_setter(slot); - } + { + /* (setter symbol) follows local lets, so we need to make sure this one is set */ + s7_pointer slot = add_slot_checked_with_id(sc, sc->curlet, sc->features_symbol, cons(sc, sym, lst)); + slot_set_setter(slot, sc->features_setter); + slot_set_has_setter(slot); + } else - if ((!is_a_feature(sym, lst)) && (!is_a_feature(sym, slot_value(p)))) - slot_set_value(p, cons(sc, sym, slot_value(p))); + if ((!is_a_feature(sym, lst)) && (!is_a_feature(sym, slot_value(p)))) + slot_set_value(p, cons(sc, sym, slot_value(p))); } return(sym); } @@ -31316,8 +31316,8 @@ static s7_pointer g_libraries_set(s7_scheme *sc, s7_pointer args) /* *libraries* error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *libraries* to ~S", 27), nf)); for (s7_pointer p = nf; is_pair(p); p = cdr(p)) if ((!is_pair(car(p))) || - (!is_string(caar(p))) || - (!is_let(cdar(p)))) + (!is_string(caar(p))) || + (!is_let(cdar(p)))) sole_arg_wrong_type_error_nr(sc, sc->libraries_symbol, car(p), wrap_string(sc, "a list of conses of the form (string . let)", 43)); return(nf); } @@ -31353,7 +31353,7 @@ static s7_pointer g_eval_string(s7_scheme *sc, s7_pointer args) { s7_pointer e = cadr(args); if (!is_let(e)) - wrong_type_error_nr(sc, sc->eval_string_symbol, 2, e, a_let_string); + wrong_type_error_nr(sc, sc->eval_string_symbol, 2, e, a_let_string); set_curlet(sc, e); } sc->temp3 = sc->args; /* see t101-aux-17.scm */ @@ -31370,15 +31370,15 @@ static s7_pointer op_eval_string(s7_scheme *sc) { int32_t tk = token(sc); /* (eval-string "(+ 1 2) ; a comment (not a mistake)") */ if (tk != TOKEN_EOF) - { - s7_pointer trail_data; - s7_int trail_len = port_data_size(current_input_port(sc)) - port_position(current_input_port(sc)) + 1; - if (trail_len > 32) trail_len = 32; - trail_data = wrap_string(sc, (const char *)(port_data(current_input_port(sc)) + port_position(current_input_port(sc)) - 1), trail_len); - s7_close_input_port(sc, current_input_port(sc)); - pop_input_port(sc); - error_nr(sc, sc->read_error_symbol, set_elist_2(sc, wrap_string(sc, "eval-string trailing junk: ~S", 29), trail_data)); - }} + { + s7_pointer trail_data; + s7_int trail_len = port_data_size(current_input_port(sc)) - port_position(current_input_port(sc)) + 1; + if (trail_len > 32) trail_len = 32; + trail_data = wrap_string(sc, (const char *)(port_data(current_input_port(sc)) + port_position(current_input_port(sc)) - 1), trail_len); + s7_close_input_port(sc, current_input_port(sc)); + pop_input_port(sc); + error_nr(sc, sc->read_error_symbol, set_elist_2(sc, wrap_string(sc, "eval-string trailing junk: ~S", 29), trail_data)); + }} s7_close_input_port(sc, current_input_port(sc)); pop_input_port(sc); sc->code = sc->value; @@ -31412,7 +31412,7 @@ static s7_pointer g_call_with_input_string(s7_scheme *sc, s7_pointer args) if (!s7_is_aritable(sc, proc, 1)) wrong_type_error_nr(sc, sc->call_with_input_string_symbol, 2, proc, - wrap_string(sc, "a procedure of one argument (the port)", 38)); + wrap_string(sc, "a procedure of one argument (the port)", 38)); if ((is_continuation(proc)) || (is_goto(proc))) wrong_type_error_nr(sc, sc->call_with_input_string_symbol, 2, proc, a_normal_procedure_string); return(call_with_input(sc, open_and_protect_input_string(sc, str), args)); @@ -31431,7 +31431,7 @@ static s7_pointer g_call_with_input_file(s7_scheme *sc, s7_pointer args) if (!s7_is_aritable(sc, proc, 1)) wrong_type_error_nr(sc, sc->call_with_input_file_symbol, 2, proc, - wrap_string(sc, "a procedure of one argument (the port)", 38)); + wrap_string(sc, "a procedure of one argument (the port)", 38)); if ((is_continuation(proc)) || (is_goto(proc))) wrong_type_error_nr(sc, sc->call_with_input_file_symbol, 2, proc, a_normal_procedure_string); return(call_with_input(sc, open_input_file_1(sc, string_value(str), "r", "call-with-input-file"), args)); @@ -31457,7 +31457,7 @@ static s7_int procedure_required_args(s7_scheme *sc, s7_pointer x) case T_C_MACRO: return(c_macro_min_args(x)); case T_CLOSURE: case T_MACRO: case T_BACRO: if (closure_arity_unknown(x)) - closure_set_arity(x, s7_list_length(sc, closure_args(x))); + closure_set_arity(x, s7_list_length(sc, closure_args(x))); return(s7_int_abs(closure_arity(x))); } return(0); @@ -31474,7 +31474,7 @@ static s7_pointer g_with_input_from_string(s7_scheme *sc, s7_pointer args) if (proc == global_value(sc->read_symbol)) { if (string_length(str) == 0) - return(eof_object); + return(eof_object); push_input_port(sc, current_input_port(sc)); set_current_input_port(sc, open_and_protect_input_string(sc, str)); port_set_string_or_function(current_input_port(sc), str); @@ -31486,12 +31486,12 @@ static s7_pointer g_with_input_from_string(s7_scheme *sc, s7_pointer args) if (!is_thunk(sc, proc)) { if (is_any_procedure(proc)) /* i.e. c_function, lambda, macro, etc */ - { - s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but with-input-from-string's second argument should be a thunk", 89), - proc, req_args, req_args)); - } + { + s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but with-input-from-string's second argument should be a thunk", 89), + proc, req_args, req_args)); + } else return(method_or_bust(sc, proc, sc->with_input_from_string_symbol, args, a_thunk_string, 2)); } /* since the arguments are evaluated before we get here, we can get some confusing situations: @@ -31517,12 +31517,12 @@ static s7_pointer g_with_input_from_file(s7_scheme *sc, s7_pointer args) if (!is_thunk(sc, proc)) { if (is_any_procedure(proc)) /* i.e. c_function, lambda, macro, etc */ - { - s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but with-input-from-file's second argument should be a thunk", 87), - proc, req_args, req_args)); - } + { + s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but with-input-from-file's second argument should be a thunk", 87), + proc, req_args, req_args)); + } else return(method_or_bust(sc, proc, sc->with_input_from_file_symbol, args, a_thunk_string, 2)); } return(with_input(sc, open_input_file_1(sc, string_value(str), "r", "with-input-from-file"), args)); @@ -31598,7 +31598,7 @@ static void op_with_io_1_method(s7_scheme *sc) { s7_pointer method = car(sc->code); if (is_c_function(method)) /* #_call-with-input-string et al */ - method = c_function_name_to_symbol(sc, method); + method = c_function_name_to_symbol(sc, method); push_stack(sc, OP_GC_PROTECT, lt, sc->code); sc->code = caddr(sc->code); sc->value = op_lambda(sc, sc->code); /* don't unstack */ @@ -31650,7 +31650,7 @@ static s7_pointer titr_let(s7_scheme *sc, s7_pointer p, const char *func, int32_ if (!is_let(iterator_sequence(p))) { fprintf(stderr, "%s%s[%d]: let iterator sequence is %s%s\n", - bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(p))), unbold_text); + bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(p))), unbold_text); if (sc->stop_at_error) abort(); } return(p); @@ -31661,7 +31661,7 @@ static s7_pointer titr_pair(s7_scheme *sc, s7_pointer p, const char *func, int32 if (!is_pair(iterator_sequence(p))) { fprintf(stderr, "%s%s[%d]: pair iterator sequence is %s%s\n", - bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(p))), unbold_text); + bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(p))), unbold_text); if (sc->stop_at_error) abort(); } return(p); @@ -31672,7 +31672,7 @@ static s7_pointer titr_hash(s7_scheme *sc, s7_pointer p, const char *func, int32 if (!is_hash_table(iterator_sequence(p))) { fprintf(stderr, "%s%s[%d]: hash iterator sequence is %s%s\n", - bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(p))), unbold_text); + bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(p))), unbold_text); if (sc->stop_at_error) abort(); } return(p); @@ -31683,7 +31683,7 @@ static s7_pointer titr_len(s7_scheme *sc, s7_pointer p, const char *func, int32_ if ((is_hash_table(iterator_sequence(p))) || (is_pair(iterator_sequence(p)))) { fprintf(stderr, "%s%s[%d]: iterator length sequence is %s%s\n", - bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(p))), unbold_text); + bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(p))), unbold_text); if (sc->stop_at_error) abort(); } return(p); @@ -31695,7 +31695,7 @@ static s7_pointer titr_pos(s7_scheme *sc, s7_pointer p, const char *func, int32_ (is_pair(iterator_sequence(p)))) { fprintf(stderr, "%s%s[%d]: iterator-position sequence is %s%s\n", - bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(p))), unbold_text); + bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(p))), unbold_text); if (sc->stop_at_error) abort(); } return(p); @@ -31782,11 +31782,11 @@ static s7_pointer hash_table_iterate(s7_scheme *sc, s7_pointer iterator) { hash_entry_t *x = elements[loc]; if (x) - { - iterator_position(iterator) = loc; - iterator_hash_current(iterator) = hash_entry_next(x); - return(hash_entry_to_cons(sc, x, iterator_current(iterator))); - }} + { + iterator_position(iterator) = loc; + iterator_hash_current(iterator) = hash_entry_next(x); + return(hash_entry_to_cons(sc, x, iterator_current(iterator))); + }} if (is_weak_hash_table(table)) { clear_weak_hash_iterator(iterator); @@ -31918,8 +31918,8 @@ static s7_pointer find_make_iterator_method(s7_scheme *sc, s7_pointer e, s7_poin it = s7_apply_function(sc, func, set_plist_1(sc, e)); unstack_gc_protect(sc); if (!is_iterator(it)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "make-iterator method must return an iterator: ~S", 48), it)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "make-iterator method must return an iterator: ~S", 48), it)); return(it); } return(NULL); @@ -31933,9 +31933,9 @@ static s7_pointer funclet_entry(s7_scheme *sc, s7_pointer x, s7_pointer sym) { s7_pointer val = symbol_to_local_slot(sc, sym, closure_let(x)); if ((!is_slot(val)) && (let_outlet(closure_let(x)) != sc->rootlet)) - val = symbol_to_local_slot(sc, sym, let_outlet(closure_let(x))); + val = symbol_to_local_slot(sc, sym, let_outlet(closure_let(x))); if (is_slot(val)) - return(slot_value(val)); + return(slot_value(val)); } return(NULL); } @@ -31972,14 +31972,14 @@ s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e) { case T_LET: if (e == sc->rootlet) - { - iterator_set_current_slot(iter, sc->rootlet_slots); - iterator_next(iter) = let_iterate; - iterator_let_cons(iter) = NULL; - return(iter); - } + { + iterator_set_current_slot(iter, sc->rootlet_slots); + iterator_next(iter) = let_iterate; + iterator_let_cons(iter) = NULL; + return(iter); + } if (e == sc->s7_starlet) - return(s7_starlet_make_iterator(sc, iter)); + return(s7_starlet_make_iterator(sc, iter)); p = find_make_iterator_method(sc, e, iter); if (p) {free_cell(sc, iter); return(p);} iterator_set_current_slot(iter, let_slots(e)); @@ -31993,11 +31993,11 @@ s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e) iterator_position(iter) = -1; iterator_next(iter) = hash_table_iterate; if (is_weak_hash_table(e)) - { - set_weak_hash_iterator(iter); - weak_hash_iters(e)++; - add_weak_hash_iterator(sc, iter); - } + { + set_weak_hash_iterator(iter); + weak_hash_iters(e)++; + add_weak_hash_iterator(sc, iter); + } break; case T_STRING: @@ -32035,19 +32035,19 @@ s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e) case T_BACRO: case T_BACRO_STAR: case T_CLOSURE: case T_CLOSURE_STAR: if (is_iterable_closure(sc, e)) - { - p = list_1_unchecked(sc, int_zero); - iterator_current(iter) = p; - set_mark_seq(iter); - iterator_next(iter) = closure_iterate; - iterator_length(iter) = (has_active_methods(sc, e)) ? closure_length(sc, e) : S7_INT64_MAX; - } + { + p = list_1_unchecked(sc, int_zero); + iterator_current(iter) = p; + set_mark_seq(iter); + iterator_next(iter) = closure_iterate; + iterator_length(iter) = (has_active_methods(sc, e)) ? closure_length(sc, e) : S7_INT64_MAX; + } else - { - free_cell(sc, iter); - sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, e, - wrap_string(sc, "a function or macro with a '+iterator+ local that is not #f", 59)); - } + { + free_cell(sc, iter); + sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, e, + wrap_string(sc, "a function or macro with a '+iterator+ local that is not #f", 59)); + } break; case T_C_OBJECT: @@ -32080,22 +32080,22 @@ in the sequence each time it is called. When it reaches the end, it returns " I if (carrier) { if (!is_pair(carrier)) - sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, carrier, sc->type_names[T_PAIR]); + sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, carrier, sc->type_names[T_PAIR]); if (is_immutable_pair(carrier)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->make_iterator_symbol, carrier)); + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->make_iterator_symbol, carrier)); if (is_hash_table(iterator_sequence(iter))) - { - iterator_current(iter) = carrier; - set_mark_seq(iter); - } + { + iterator_current(iter) = carrier; + set_mark_seq(iter); + } else - if ((is_let(iterator_sequence(iter))) && - (iterator_sequence(iter) != sc->rootlet)) - { - iterator_let_cons(iter) = carrier; - set_mark_seq(iter); - }} + if ((is_let(iterator_sequence(iter))) && + (iterator_sequence(iter) != sc->rootlet)) + { + iterator_let_cons(iter) = carrier; + set_mark_seq(iter); + }} return(iter); } @@ -32178,10 +32178,10 @@ static int32_t shared_ref(shared_info_t *ci, const s7_pointer p) for (int32_t i = 0; i < ci->top; i++) if (objs[i] == p) { - int32_t val = ci->refs[i]; - if (val > 0) - ci->refs[i] = -ci->refs[i]; - return(val); + int32_t val = ci->refs[i]; + if (val > 0) + ci->refs[i] = -ci->refs[i]; + return(val); } return(0); } @@ -32192,8 +32192,8 @@ static void flip_ref(shared_info_t *ci, const s7_pointer p) for (int32_t i = 0; i < ci->top; i++) if (objs[i] == p) { - ci->refs[i] = -ci->refs[i]; - break; + ci->refs[i] = -ci->refs[i]; + break; } } @@ -32234,13 +32234,13 @@ static bool check_collected(s7_pointer top, shared_info_t *ci) for (s7_pointer *p = ci->objs; p < objs_end; p++) if ((*p) == top) { - int32_t i = (int32_t)(p - ci->objs); - if (ci->refs[i] == 0) - { - ci->has_hits = true; - ci->refs[i] = ++ci->ref; /* if found, set the ref number */ - } - break; + int32_t i = (int32_t)(p - ci->objs); + if (ci->refs[i] == 0) + { + ci->has_hits = true; + ci->refs[i] = ++ci->ref; /* if found, set the ref number */ + } + break; } set_cyclic(top); return(true); @@ -32258,7 +32258,7 @@ static bool collect_vector_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top { plen = sc->print_length; if (plen > vector_length(top)) - plen = vector_length(top); + plen = vector_length(top); } else plen = vector_length(top); @@ -32266,15 +32266,15 @@ static bool collect_vector_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top { s7_pointer vel = unchecked_vector_element(top, i); /* "unchecked" because top might be rootlet, I think */ if ((has_structure(vel)) && - (collect_shared_info(sc, ci, vel, stop_at_print_length))) - { - set_cyclic(vel); - cyclic = true; - if ((is_c_pointer(vel)) || - (is_iterator(vel)) || - (is_c_object(vel))) - check_collected(top, ci); - }} + (collect_shared_info(sc, ci, vel, stop_at_print_length))) + { + set_cyclic(vel); + cyclic = true; + if ((is_c_pointer(vel)) || + (is_iterator(vel)) || + (is_c_object(vel))) + check_collected(top, ci); + }} if (cyclic) set_cyclic(top); return(cyclic); } @@ -32304,37 +32304,37 @@ static bool collect_shared_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top { s7_pointer p; if ((has_structure(car(top))) && - (collect_shared_info(sc, ci, car(top), stop_at_print_length))) - top_cyclic = true; + (collect_shared_info(sc, ci, car(top), stop_at_print_length))) + top_cyclic = true; for (p = cdr(top); is_pair(p); p = cdr(p)) - { - if (is_collected_or_shared(p)) - { - set_cyclic(top); - set_cyclic(p); - if (!is_shared(p)) - return(check_collected(p, ci)); - if (!top_cyclic) - for (s7_pointer cp = top; cp != p; cp = cdr(cp)) set_shared(cp); - return(top_cyclic); - } - set_collected(p); - if (ci->top == ci->size) - enlarge_shared_info(ci); - ci->objs[ci->top++] = p; - if ((has_structure(car(p))) && - (collect_shared_info(sc, ci, car(p), stop_at_print_length))) - top_cyclic = true; - } + { + if (is_collected_or_shared(p)) + { + set_cyclic(top); + set_cyclic(p); + if (!is_shared(p)) + return(check_collected(p, ci)); + if (!top_cyclic) + for (s7_pointer cp = top; cp != p; cp = cdr(cp)) set_shared(cp); + return(top_cyclic); + } + set_collected(p); + if (ci->top == ci->size) + enlarge_shared_info(ci); + ci->objs[ci->top++] = p; + if ((has_structure(car(p))) && + (collect_shared_info(sc, ci, car(p), stop_at_print_length))) + top_cyclic = true; + } if ((has_structure(p)) && - (collect_shared_info(sc, ci, p, stop_at_print_length))) - { - set_cyclic(top); - return(true); - } + (collect_shared_info(sc, ci, p, stop_at_print_length))) + { + set_cyclic(top); + return(true); + } if (!top_cyclic) - for (s7_pointer cp = top; is_pair(cp); cp = cdr(cp)) set_shared(cp); + for (s7_pointer cp = top; is_pair(cp); cp = cdr(cp)) set_shared(cp); else set_cyclic(top); return(top_cyclic); } @@ -32343,105 +32343,105 @@ static bool collect_shared_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top { case T_VECTOR: if (collect_vector_info(sc, ci, top, stop_at_print_length)) - top_cyclic = true; + top_cyclic = true; break; case T_ITERATOR: if ((is_sequence(iterator_sequence(top))) && /* might be a function with +iterator+ local */ - (collect_shared_info(sc, ci, iterator_sequence(top), stop_at_print_length))) - { - if (peek_shared_ref(ci, iterator_sequence(top)) == 0) - check_collected(iterator_sequence(top), ci); - top_cyclic = true; - } + (collect_shared_info(sc, ci, iterator_sequence(top), stop_at_print_length))) + { + if (peek_shared_ref(ci, iterator_sequence(top)) == 0) + check_collected(iterator_sequence(top), ci); + top_cyclic = true; + } break; case T_HASH_TABLE: if (hash_table_entries(top) > 0) - { - s7_int len = hash_table_size(top); - hash_entry_t **entries = hash_table_elements(top); - bool keys_safe = hash_keys_not_cyclic(sc, top); - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *p = entries[i]; p; p = hash_entry_next(p)) - { - if ((!keys_safe) && - (has_structure(hash_entry_key(p))) && - (collect_shared_info(sc, ci, hash_entry_key(p), stop_at_print_length))) - top_cyclic = true; - if ((has_structure(hash_entry_value(p))) && - (collect_shared_info(sc, ci, hash_entry_value(p), stop_at_print_length))) - { - if ((is_c_pointer(hash_entry_value(p))) || - (is_iterator(hash_entry_value(p))) || - (is_c_object(hash_entry_value(p)))) - check_collected(top, ci); - top_cyclic = true; - }}} + { + s7_int len = hash_table_size(top); + hash_entry_t **entries = hash_table_elements(top); + bool keys_safe = hash_keys_not_cyclic(sc, top); + for (s7_int i = 0; i < len; i++) + for (hash_entry_t *p = entries[i]; p; p = hash_entry_next(p)) + { + if ((!keys_safe) && + (has_structure(hash_entry_key(p))) && + (collect_shared_info(sc, ci, hash_entry_key(p), stop_at_print_length))) + top_cyclic = true; + if ((has_structure(hash_entry_value(p))) && + (collect_shared_info(sc, ci, hash_entry_value(p), stop_at_print_length))) + { + if ((is_c_pointer(hash_entry_value(p))) || + (is_iterator(hash_entry_value(p))) || + (is_c_object(hash_entry_value(p)))) + check_collected(top, ci); + top_cyclic = true; + }}} break; case T_SLOT: /* this can be hit if we somehow collect_shared_info on sc->rootlet via collect_vector_info (see the let case below) */ if ((has_structure(slot_value(top))) && - (collect_shared_info(sc, ci, slot_value(top), stop_at_print_length))) - top_cyclic = true; + (collect_shared_info(sc, ci, slot_value(top), stop_at_print_length))) + top_cyclic = true; break; case T_LET: if (top == sc->rootlet) - { - if (collect_vector_info(sc, ci, top, stop_at_print_length)) - top_cyclic = true; - } + { + if (collect_vector_info(sc, ci, top, stop_at_print_length)) + top_cyclic = true; + } else - for (s7_pointer q = top; q; q = let_outlet(q)) - for (s7_pointer p = let_slots(q); tis_slot(p); p = next_slot(p)) - if ((has_structure(slot_value(p))) && - (collect_shared_info(sc, ci, slot_value(p), stop_at_print_length))) - { - top_cyclic = true; - if ((is_c_pointer(slot_value(p))) || - (is_iterator(slot_value(p))) || - (is_c_object(slot_value(p)))) - check_collected(top, ci); - } + for (s7_pointer q = top; q; q = let_outlet(q)) + for (s7_pointer p = let_slots(q); tis_slot(p); p = next_slot(p)) + if ((has_structure(slot_value(p))) && + (collect_shared_info(sc, ci, slot_value(p), stop_at_print_length))) + { + top_cyclic = true; + if ((is_c_pointer(slot_value(p))) || + (is_iterator(slot_value(p))) || + (is_c_object(slot_value(p)))) + check_collected(top, ci); + } break; case T_CLOSURE: case T_CLOSURE_STAR: if (collect_shared_info(sc, ci, closure_body(top), stop_at_print_length)) - { - if (peek_shared_ref(ci, top) == 0) - check_collected(top, ci); - top_cyclic = true; - } + { + if (peek_shared_ref(ci, top) == 0) + check_collected(top, ci); + top_cyclic = true; + } break; case T_C_POINTER: if ((has_structure(c_pointer_type(top))) && - (collect_shared_info(sc, ci, c_pointer_type(top), stop_at_print_length))) - { - if (peek_shared_ref(ci, c_pointer_type(top)) == 0) - check_collected(c_pointer_type(top), ci); - top_cyclic = true; - } + (collect_shared_info(sc, ci, c_pointer_type(top), stop_at_print_length))) + { + if (peek_shared_ref(ci, c_pointer_type(top)) == 0) + check_collected(c_pointer_type(top), ci); + top_cyclic = true; + } if ((has_structure(c_pointer_info(top))) && - (collect_shared_info(sc, ci, c_pointer_info(top), stop_at_print_length))) - { - if (peek_shared_ref(ci, c_pointer_info(top)) == 0) - check_collected(c_pointer_info(top), ci); - top_cyclic = true; - } + (collect_shared_info(sc, ci, c_pointer_info(top), stop_at_print_length))) + { + if (peek_shared_ref(ci, c_pointer_info(top)) == 0) + check_collected(c_pointer_info(top), ci); + top_cyclic = true; + } break; case T_C_OBJECT: if ((c_object_to_list(sc, top)) && - (c_object_set(sc, top)) && - (collect_shared_info(sc, ci, (*(c_object_to_list(sc, top)))(sc, set_plist_1(sc, top)), stop_at_print_length))) - { - if (peek_shared_ref(ci, top) == 0) - check_collected(top, ci); - top_cyclic = true; - } + (c_object_set(sc, top)) && + (collect_shared_info(sc, ci, (*(c_object_to_list(sc, top)))(sc, set_plist_1(sc, top)), stop_at_print_length))) + { + if (peek_shared_ref(ci, top) == 0) + check_collected(top, ci); + top_cyclic = true; + } break; } if (!top_cyclic) @@ -32481,7 +32481,7 @@ static inline shared_info_t *clear_shared_info(shared_info_t *ci) memclr((void *)(ci->refs), ci->top * sizeof(int32_t)); memclr((void *)(ci->defined), ci->top * sizeof(bool)); for (int32_t i = 0; i < ci->top; i++) - clear_cyclic_bits(ci->objs[i]); /* LOOP_4 is not faster */ + clear_cyclic_bits(ci->objs[i]); /* LOOP_4 is not faster */ ci->top = 0; } ci->ref = 0; @@ -32501,65 +32501,65 @@ static shared_info_t *load_shared_info(s7_scheme *sc, s7_pointer top, bool stop_ { s7_pointer x = top; if (stop_at_print_length) - { - s7_pointer slow = top; - stop_len = sc->print_length; - for (k = 0; k < stop_len; k += 2) - { - if (!is_pair(x)) break; - if (has_structure(car(x))) {no_problem = false; break;} - x = cdr(x); - if (!is_pair(x)) break; - if (has_structure(car(x))) {no_problem = false; break;} - x = cdr(x); - slow = cdr(slow); - if (x == slow) {no_problem = false; break;} - }} + { + s7_pointer slow = top; + stop_len = sc->print_length; + for (k = 0; k < stop_len; k += 2) + { + if (!is_pair(x)) break; + if (has_structure(car(x))) {no_problem = false; break;} + x = cdr(x); + if (!is_pair(x)) break; + if (has_structure(car(x))) {no_problem = false; break;} + x = cdr(x); + slow = cdr(slow); + if (x == slow) {no_problem = false; break;} + }} else - if (s7_list_length(sc, top) == 0) /* it is circular at the top level (following cdr) */ - no_problem = false; - else - for (; is_pair(x); x = cdr(x)) - if (has_structure(car(x))) {no_problem = false; break;} /* perhaps (and (length > 0)) or vector typer etc */ + if (s7_list_length(sc, top) == 0) /* it is circular at the top level (following cdr) */ + no_problem = false; + else + for (; is_pair(x); x = cdr(x)) + if (has_structure(car(x))) {no_problem = false; break;} /* perhaps (and (length > 0)) or vector typer etc */ if ((no_problem) && - (!is_null(x)) && (has_structure(x))) - no_problem = false; + (!is_null(x)) && (has_structure(x))) + no_problem = false; if (no_problem) return(NULL); } else if (is_t_vector(top)) /* any other vector can't happen */ { - stop_len = vector_length(top); - if ((stop_at_print_length) && - (stop_len > sc->print_length)) - stop_len = sc->print_length; - for (k = 0; k < stop_len; k++) - if (has_structure(vector_element(top, k))) {no_problem = false; break;} - if (no_problem) return(NULL); + stop_len = vector_length(top); + if ((stop_at_print_length) && + (stop_len > sc->print_length)) + stop_len = sc->print_length; + for (k = 0; k < stop_len; k++) + if (has_structure(vector_element(top, k))) {no_problem = false; break;} + if (no_problem) return(NULL); } else /* added these 19-Oct-22 -- helps in tgc, but not much elsewhere */ if ((is_let(top)) && (top != sc->rootlet)) { - for (s7_pointer lp = top; (no_problem) && (lp); lp = let_outlet(lp)) - for (s7_pointer p = let_slots(lp); tis_slot(p); p = next_slot(p)) - if (has_structure(slot_value(p))) /* slot_symbol need not be checked? */ - {no_problem = false; break;} - if (no_problem) return(NULL); + for (s7_pointer lp = top; (no_problem) && (lp); lp = let_outlet(lp)) + for (s7_pointer p = let_slots(lp); tis_slot(p); p = next_slot(p)) + if (has_structure(slot_value(p))) /* slot_symbol need not be checked? */ + {no_problem = false; break;} + if (no_problem) return(NULL); } else if (is_hash_table(top)) - { - s7_int len = hash_table_size(top); - hash_entry_t **entries = hash_table_elements(top); - bool keys_safe = hash_keys_not_cyclic(sc, top); - if (hash_table_entries(top) == 0) return(NULL); - for (s7_int i = 0; i < len; i++) - for (hash_entry_t *p = entries[i]; p; p = hash_entry_next(p)) - if (((!keys_safe) && (has_structure(hash_entry_key(p)))) || (has_structure(hash_entry_value(p)))) - {no_problem = false; break;} - if (no_problem) return(NULL); - } + { + s7_int len = hash_table_size(top); + hash_entry_t **entries = hash_table_elements(top); + bool keys_safe = hash_keys_not_cyclic(sc, top); + if (hash_table_entries(top) == 0) return(NULL); + for (s7_int i = 0; i < len; i++) + for (hash_entry_t *p = entries[i]; p; p = hash_entry_next(p)) + if (((!keys_safe) && (has_structure(hash_entry_key(p)))) || (has_structure(hash_entry_value(p)))) + {no_problem = false; break;} + if (no_problem) return(NULL); + } if ((S7_DEBUGGING) && (is_any_vector(top)) && (!is_t_vector(top))) fprintf(stderr, "%s[%d]: got abnormal vector\n", __func__, __LINE__); clear_shared_info(ci); @@ -32583,17 +32583,17 @@ static shared_info_t *load_shared_info(s7_scheme *sc, s7_pointer top, bool stop_ */ for (int32_t i = 0; i < ci->top; i++) if (ci_refs[i] > 0) - { - set_collected(ci_objs[i]); - if (i == refs) - refs++; - else - { - ci_objs[refs] = ci_objs[i]; - ci_refs[refs++] = ci_refs[i]; - ci_refs[i] = 0; - ci_objs[i] = NULL; - }} + { + set_collected(ci_objs[i]); + if (i == refs) + refs++; + else + { + ci_objs[refs] = ci_objs[i]; + ci_refs[refs++] = ci_refs[i]; + ci_refs[i] = 0; + ci_objs[i] = NULL; + }} ci->top = refs; return(ci); } @@ -32607,16 +32607,16 @@ static s7_pointer cyclic_sequences_p_p(s7_scheme *sc, s7_pointer obj) { shared_info_t *ci = (sc->object_out_locked) ? sc->circle_info : load_shared_info(sc, obj, false, sc->circle_info); /* false=don't stop at print length (vectors etc) */ if (ci) - { - s7_pointer lst; - sc->w = sc->nil; - check_free_heap_size(sc, ci->top); - for (int32_t i = 0; i < ci->top; i++) - sc->w = cons_unchecked(sc, ci->objs[i], sc->w); - lst = sc->w; - sc->w = sc->unused; - return(lst); - }} + { + s7_pointer lst; + sc->w = sc->nil; + check_free_heap_size(sc, ci->top); + for (int32_t i = 0; i < ci->top; i++) + sc->w = cons_unchecked(sc, ci->objs[i], sc->w); + lst = sc->w; + sc->w = sc->unused; + return(lst); + }} return(sc->nil); } @@ -32636,18 +32636,18 @@ static int32_t circular_list_entries(s7_pointer lst) { int32_t j = 0; for (s7_pointer y = lst; j < i; y = cdr(y), j++) - if (x == y) - return(i); + if (x == y) + return(i); } } static void object_to_port_with_circle_check_1(s7_scheme *sc, s7_pointer vr, s7_pointer port, use_write_t use_write, shared_info_t *ci); #define object_to_port_with_circle_check(Sc, Vr, Port, Use_Write, Ci) \ - do { \ - s7_pointer _V_ = Vr; \ - if ((Ci) && (has_structure(_V_))) \ + do { \ + s7_pointer _V_ = Vr; \ + if ((Ci) && (has_structure(_V_))) \ object_to_port_with_circle_check_1(Sc, _V_, Port, Use_Write, Ci); \ - else object_to_port(Sc, _V_, Port, Use_Write, Ci); \ + else object_to_port(Sc, _V_, Port, Use_Write, Ci); \ } while (0) static void (*display_functions[256])(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci); @@ -32672,7 +32672,7 @@ static void slashify_string_to_port(s7_scheme *sc, s7_pointer port, const char * if (len == 0) { if (quoted) - port_write_string(port)(sc, "\"\"", 2, port); + port_write_string(port)(sc, "\"\"", 2, port); return; } pend = (const uint8_t *)(p + len); @@ -32695,44 +32695,44 @@ static void slashify_string_to_port(s7_scheme *sc, s7_pointer port, const char * for (pcur = (const uint8_t *)p; pcur < pend; pcur++) if (slashify_table[*pcur]) { - if (pstart) pstart++; else pstart = (const uint8_t *)p; - if (pstart != pcur) - { - port_write_string(port)(sc, (const char *)pstart, pcur - pstart, port); - pstart = pcur; - } - port_write_character(port)(sc, '\\', port); - switch (*pcur) - { - case '"': port_write_character(port)(sc, '"', port); break; - case '\\': port_write_character(port)(sc, '\\', port); break; - case '\'': port_write_character(port)(sc, '\'', port); break; - case '\t': port_write_character(port)(sc, 't', port); break; - case '\r': port_write_character(port)(sc, 'r', port); break; - case '\b': port_write_character(port)(sc, 'b', port); break; - case '\f': port_write_character(port)(sc, 'f', port); break; - case '\?': port_write_character(port)(sc, '?', port); break; - case 'x': port_write_character(port)(sc, 'x', port); break; - default: - { - char buf[5]; - s7_int n = (s7_int)(*pcur); - buf[0] = 'x'; - buf[1] = (n < 16) ? '0' : dignum[(n / 16) % 16]; - buf[2] = dignum[n % 16]; - buf[3] = ';'; - buf[4] = '\0'; - port_write_string(port)(sc, buf, 4, port); - } - break; - }} + if (pstart) pstart++; else pstart = (const uint8_t *)p; + if (pstart != pcur) + { + port_write_string(port)(sc, (const char *)pstart, pcur - pstart, port); + pstart = pcur; + } + port_write_character(port)(sc, '\\', port); + switch (*pcur) + { + case '"': port_write_character(port)(sc, '"', port); break; + case '\\': port_write_character(port)(sc, '\\', port); break; + case '\'': port_write_character(port)(sc, '\'', port); break; + case '\t': port_write_character(port)(sc, 't', port); break; + case '\r': port_write_character(port)(sc, 'r', port); break; + case '\b': port_write_character(port)(sc, 'b', port); break; + case '\f': port_write_character(port)(sc, 'f', port); break; + case '\?': port_write_character(port)(sc, '?', port); break; + case 'x': port_write_character(port)(sc, 'x', port); break; + default: + { + char buf[5]; + s7_int n = (s7_int)(*pcur); + buf[0] = 'x'; + buf[1] = (n < 16) ? '0' : dignum[(n / 16) % 16]; + buf[2] = dignum[n % 16]; + buf[3] = ';'; + buf[4] = '\0'; + port_write_string(port)(sc, buf, 4, port); + } + break; + }} if (!pstart) port_write_string(port)(sc, (const char *)p, len, port); else { pstart++; if (pstart != pcur) - port_write_string(port)(sc, (const char *)pstart, pcur - pstart, port); + port_write_string(port)(sc, (const char *)pstart, pcur - pstart, port); } if (quoted) port_write_character(port)(sc, '"', port); } @@ -32745,42 +32745,42 @@ static void output_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, else if (use_write == P_READABLE) { - if (port_is_closed(obj)) - port_write_string(port)(sc, "(let ((p (open-output-string))) (close-output-port p) p)", 56, port); - else - if (is_string_port(obj)) - { - port_write_string(port)(sc, "(let ((p (open-output-string)))", 31, port); - if (port_position(obj) > 0) - { - port_write_string(port)(sc, " (display ", 10, port); - slashify_string_to_port(sc, port, (const char *)port_data(obj), port_position(obj), IN_QUOTES); - port_write_string(port)(sc, " p)", 3, port); - } - port_write_string(port)(sc, " p)", 3, port); - } - else - if (is_file_port(obj)) - { - char str[256]; - int32_t nlen; - str[0] = '\0'; - nlen = (int32_t)catstrs(str, 256, "(open-output-file \"", port_filename(obj), "\" \"a\")", (char *)NULL); - port_write_string(port)(sc, str, nlen, port); - } - else port_write_string(port)(sc, "#<output-function-port>", 23, port); + if (port_is_closed(obj)) + port_write_string(port)(sc, "(let ((p (open-output-string))) (close-output-port p) p)", 56, port); + else + if (is_string_port(obj)) + { + port_write_string(port)(sc, "(let ((p (open-output-string)))", 31, port); + if (port_position(obj) > 0) + { + port_write_string(port)(sc, " (display ", 10, port); + slashify_string_to_port(sc, port, (const char *)port_data(obj), port_position(obj), IN_QUOTES); + port_write_string(port)(sc, " p)", 3, port); + } + port_write_string(port)(sc, " p)", 3, port); + } + else + if (is_file_port(obj)) + { + char str[256]; + int32_t nlen; + str[0] = '\0'; + nlen = (int32_t)catstrs(str, 256, "(open-output-file \"", port_filename(obj), "\" \"a\")", (char *)NULL); + port_write_string(port)(sc, str, nlen, port); + } + else port_write_string(port)(sc, "#<output-function-port>", 23, port); } else { - if (is_string_port(obj)) - port_write_string(port)(sc, "#<output-string-port", 20, port); - else - if (is_file_port(obj)) - port_write_string(port)(sc, "#<output-file-port", 18, port); - else port_write_string(port)(sc, "#<output-function-port", 22, port); - if (port_is_closed(obj)) - port_write_string(port)(sc, ":closed>", 8, port); - else port_write_character(port)(sc, '>', port); + if (is_string_port(obj)) + port_write_string(port)(sc, "#<output-string-port", 20, port); + else + if (is_file_port(obj)) + port_write_string(port)(sc, "#<output-file-port", 18, port); + else port_write_string(port)(sc, "#<output-function-port", 22, port); + if (port_is_closed(obj)) + port_write_string(port)(sc, ":closed>", 8, port); + else port_write_character(port)(sc, '>', port); } } @@ -32791,66 +32791,66 @@ static void input_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, u else if (use_write == P_READABLE) { - if (port_is_closed(obj)) - port_write_string(port)(sc, "(call-with-input-string \"\" (lambda (p) p))", 42, port); - else - if (is_function_port(obj)) - port_write_string(port)(sc, "#<input-function-port>", 22, port); - else - if (is_file_port(obj)) - { - char str[256]; - int32_t nlen; - str[0] = '\0'; - nlen = (int32_t)catstrs(str, 256, "(open-input-file \"", port_filename(obj), "\")", (char *)NULL); - port_write_string(port)(sc, str, nlen, port); - } - else - { - s7_int data_len = port_data_size(obj) - port_position(obj); - if (data_len > 100) - { - const char *filename = (const char *)s7_port_filename(sc, obj); - if (filename) - { + if (port_is_closed(obj)) + port_write_string(port)(sc, "(call-with-input-string \"\" (lambda (p) p))", 42, port); + else + if (is_function_port(obj)) + port_write_string(port)(sc, "#<input-function-port>", 22, port); + else + if (is_file_port(obj)) + { + char str[256]; + int32_t nlen; + str[0] = '\0'; + nlen = (int32_t)catstrs(str, 256, "(open-input-file \"", port_filename(obj), "\")", (char *)NULL); + port_write_string(port)(sc, str, nlen, port); + } + else + { + s7_int data_len = port_data_size(obj) - port_position(obj); + if (data_len > 100) + { + const char *filename = (const char *)s7_port_filename(sc, obj); + if (filename) + { #define DO_STR_LEN 1024 - char do_str[DO_STR_LEN]; - int32_t len; - do_str[0] = '\0'; - if (port_position(obj) > 0) - { - len = (int32_t)catstrs(do_str, DO_STR_LEN, "(let ((port (open-input-file \"", filename, "\")))", (char *)NULL); - port_write_string(port)(sc, do_str, len, port); - do_str[0] = '\0'; - len = (int32_t)catstrs(do_str, DO_STR_LEN, " (do ((i 0 (+ i 1)) (c (read-char port) (read-char port))) ((= i ", - pos_int_to_str_direct(sc, port_position(obj) - 1), - ") port)))", (char *)NULL); - } - else len = (int32_t)catstrs(do_str, DO_STR_LEN, "(open-input-file \"", filename, "\")", (char *)NULL); - port_write_string(port)(sc, do_str, len, port); - return; - }} - port_write_string(port)(sc, "(open-input-string ", 19, port); - /* not port_write_string here because there might be embedded double-quotes */ - slashify_string_to_port(sc, port, (const char *)(port_data(obj) + port_position(obj)), port_data_size(obj) - port_position(obj), IN_QUOTES); - port_write_character(port)(sc, ')', port); - }} + char do_str[DO_STR_LEN]; + int32_t len; + do_str[0] = '\0'; + if (port_position(obj) > 0) + { + len = (int32_t)catstrs(do_str, DO_STR_LEN, "(let ((port (open-input-file \"", filename, "\")))", (char *)NULL); + port_write_string(port)(sc, do_str, len, port); + do_str[0] = '\0'; + len = (int32_t)catstrs(do_str, DO_STR_LEN, " (do ((i 0 (+ i 1)) (c (read-char port) (read-char port))) ((= i ", + pos_int_to_str_direct(sc, port_position(obj) - 1), + ") port)))", (char *)NULL); + } + else len = (int32_t)catstrs(do_str, DO_STR_LEN, "(open-input-file \"", filename, "\")", (char *)NULL); + port_write_string(port)(sc, do_str, len, port); + return; + }} + port_write_string(port)(sc, "(open-input-string ", 19, port); + /* not port_write_string here because there might be embedded double-quotes */ + slashify_string_to_port(sc, port, (const char *)(port_data(obj) + port_position(obj)), port_data_size(obj) - port_position(obj), IN_QUOTES); + port_write_character(port)(sc, ')', port); + }} else { - if (is_string_port(obj)) - port_write_string(port)(sc, "#<input-string-port", 19, port); - else - if (is_file_port(obj)) - port_write_string(port)(sc, "#<input-file-port", 17, port); - else port_write_string(port)(sc, "#<input-function-port", 21, port); - if (port_filename(obj)) - { - port_write_character(port)(sc, ' ', port); - port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port); - } - if (port_is_closed(obj)) - port_write_string(port)(sc, " :closed>", 9, port); - else port_write_character(port)(sc, '>', port); + if (is_string_port(obj)) + port_write_string(port)(sc, "#<input-string-port", 19, port); + else + if (is_file_port(obj)) + port_write_string(port)(sc, "#<input-file-port", 17, port); + else port_write_string(port)(sc, "#<input-function-port", 21, port); + if (port_filename(obj)) + { + port_write_character(port)(sc, ' ', port); + port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port); + } + if (port_is_closed(obj)) + port_write_string(port)(sc, " :closed>", 9, port); + else port_write_character(port)(sc, '>', port); } } @@ -32888,24 +32888,24 @@ static /* inline */ void symbol_to_port(s7_scheme *sc, s7_pointer obj, s7_pointe { char c = '\0'; if ((use_write == P_READABLE) || (use_write == P_CODE)) - { - if (!is_keyword(obj)) c = '\''; - } + { + if (!is_keyword(obj)) c = '\''; + } else if ((use_write == P_KEY) && (!is_keyword(obj))) c = ':'; if (is_string_port(port)) - { - s7_int new_len = port_position(port) + symbol_name_length(obj) + ((c) ? 1 : 0); - if (new_len >= port_data_size(port)) - resize_port_data(sc, port, new_len * 2); - if (c) port_data(port)[port_position(port)++] = c; - memcpy((void *)(port_data(port) + port_position(port)), (void *)symbol_name(obj), symbol_name_length(obj)); - port_position(port) = new_len; - } + { + s7_int new_len = port_position(port) + symbol_name_length(obj) + ((c) ? 1 : 0); + if (new_len >= port_data_size(port)) + resize_port_data(sc, port, new_len * 2); + if (c) port_data(port)[port_position(port)++] = c; + memcpy((void *)(port_data(port) + port_position(port)), (void *)symbol_name(obj), symbol_name_length(obj)); + port_position(port) = new_len; + } else - { - if (c) port_write_character(port)(sc, c, port); - port_write_string(port)(sc, symbol_name(obj), symbol_name_length(obj), port); - }} + { + if (c) port_write_character(port)(sc, c, port); + port_write_string(port)(sc, symbol_name(obj), symbol_name_length(obj), port); + }} } static char *multivector_indices_to_string(s7_scheme *sc, s7_int index, s7_pointer vect, char *str, int32_t str_len, int32_t cur_dim) @@ -32921,44 +32921,44 @@ static char *multivector_indices_to_string(s7_scheme *sc, s7_int index, s7_point #define not_p_display(Choice) ((Choice == P_DISPLAY) ? P_WRITE : Choice) static int32_t multivector_to_port_1(s7_scheme *sc, s7_pointer vec, s7_pointer port, - int32_t out_len, int32_t flat_ref, int32_t dimension, int32_t dimensions, bool *last, - use_write_t use_write, shared_info_t *ci) + int32_t out_len, int32_t flat_ref, int32_t dimension, int32_t dimensions, bool *last, + use_write_t use_write, shared_info_t *ci) { if (use_write != P_READABLE) { if (*last) - port_write_string(port)(sc, " (", 2, port); + port_write_string(port)(sc, " (", 2, port); else port_write_character(port)(sc, '(', port); (*last) = false; } for (int32_t i = 0; i < vector_dimension(vec, dimension); i++) if (dimension == (dimensions - 1)) { - if (flat_ref < out_len) - { - object_to_port_with_circle_check(sc, vector_getter(vec)(sc, vec, flat_ref), port, not_p_display(use_write), ci); - - if (use_write == P_READABLE) - port_write_string(port)(sc, ") ", 2, port); - flat_ref++; - } - else - { - port_write_string(port)(sc, "...)", 4, port); - return(flat_ref); - } - if ((use_write != P_READABLE) && - (i < (vector_dimension(vec, dimension) - 1))) - port_write_character(port)(sc, ' ', port); + if (flat_ref < out_len) + { + object_to_port_with_circle_check(sc, vector_getter(vec)(sc, vec, flat_ref), port, not_p_display(use_write), ci); + + if (use_write == P_READABLE) + port_write_string(port)(sc, ") ", 2, port); + flat_ref++; + } + else + { + port_write_string(port)(sc, "...)", 4, port); + return(flat_ref); + } + if ((use_write != P_READABLE) && + (i < (vector_dimension(vec, dimension) - 1))) + port_write_character(port)(sc, ' ', port); } else if (flat_ref < out_len) - flat_ref = multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension + 1, dimensions, last, not_p_display(use_write), ci); + flat_ref = multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension + 1, dimensions, last, not_p_display(use_write), ci); else - { - port_write_string(port)(sc, "...)", 4, port); - return(flat_ref); - } + { + port_write_string(port)(sc, "...)", 4, port); + return(flat_ref); + } if (use_write != P_READABLE) port_write_character(port)(sc, ')', port); (*last) = true; @@ -32966,8 +32966,8 @@ static int32_t multivector_to_port_1(s7_scheme *sc, s7_pointer vec, s7_pointer p } static int32_t multivector_to_port(s7_scheme *sc, s7_pointer vec, s7_pointer port, - int32_t out_len, int32_t flat_ref, int32_t dimension, int32_t dimensions, - use_write_t use_write, shared_info_t *ci) + int32_t out_len, int32_t flat_ref, int32_t dimension, int32_t dimensions, + use_write_t use_write, shared_info_t *ci) { bool last = false; return(multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension, dimensions, &last, use_write, ci)); @@ -32987,7 +32987,7 @@ static void make_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port) vtyp = "int-"; else if (is_byte_vector(vect)) - vtyp = "byte-"; + vtyp = "byte-"; vlen = vector_length(vect); if (vector_rank(vect) == 1) @@ -33001,10 +33001,10 @@ static void make_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port) plen = (int32_t)catstrs_direct(buf, "(make-", vtyp, "vector '(", (const char *)NULL); port_write_string(port)(sc, buf, plen, port); for (dim = 0; dim < vector_ndims(vect) - 1; dim++) - { - plen = (int32_t)catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), " ", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } + { + plen = (int32_t)catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), " ", (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + } plen = (int32_t)catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), ") ", (const char *)NULL); port_write_string(port)(sc, buf, plen, port); } @@ -33035,30 +33035,30 @@ static void vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_ if (len == 0) { if (vector_rank(vect) > 1) - { - plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d()", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } + { + plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d()", (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + } else port_write_string(port)(sc, "#()", 3, port); return; } if (use_write != P_READABLE) { if (sc->print_length == 0) - { - if (vector_rank(vect) > 1) - { - plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d(...)", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else port_write_string(port)(sc, "#(...)", 6, port); - return; - } + { + if (vector_rank(vect) > 1) + { + plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d(...)", (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + } + else port_write_string(port)(sc, "#(...)", 6, port); + return; + } if (len > sc->print_length) - { - too_long = true; - len = sc->print_length; - }} + { + too_long = true; + len = sc->print_length; + }} if ((!ci) && (len > 1000)) { @@ -33066,20 +33066,20 @@ static void vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_ s7_pointer *els = vector_elements(vect); s7_pointer p0 = els[0]; for (i = 1; i < vlen; i++) - if (els[i] != p0) - break; + if (els[i] != p0) + break; if (i == vlen) - { - make_vector_to_port(sc, vect, port); - object_to_port(sc, p0, port, use_write, NULL); - if (is_typed_vector(vect)) - { - port_write_character(port)(sc, ' ', port); - port_write_vector_typer(sc, vect, port); - } - port_write_character(port)(sc, ')', port); - return; - }} + { + make_vector_to_port(sc, vect, port); + object_to_port(sc, p0, port, use_write, NULL); + if (is_typed_vector(vect)) + { + port_write_character(port)(sc, ' ', port); + port_write_vector_typer(sc, vect, port); + } + port_write_character(port)(sc, ')', port); + return; + }} check_stack_size(sc); gc_protect_via_stack(sc, vect); @@ -33087,153 +33087,153 @@ static void vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_ { int32_t vref; if ((ci) && - (is_cyclic(vect)) && - ((vref = peek_shared_ref(ci, vect)) != 0)) - { - s7_pointer *els = vector_elements(vect); - if (vref < 0) vref = -vref; - if ((ci->defined[vref]) || (port == ci->cycle_port)) - { - plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, vref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - unstack_gc_protect(sc); - return; - } - - if (is_typed_vector(vect)) - port_write_string(port)(sc, "(let ((<v> ", 11, port); - - if (vector_rank(vect) > 1) - port_write_string(port)(sc, "(subvector ", 11, port); - - port_write_string(port)(sc, "(vector", 7, port); /* top level let */ - for (i = 0; i < len; i++) - if (has_structure(els[i])) - { - int32_t eref = peek_shared_ref(ci, els[i]); - port_write_string(port)(sc, " #f", 3, port); - if (eref != 0) - { - if (eref < 0) eref = -eref; - if (vector_rank(vect) > 1) - { - s7_int dimension = vector_rank(vect) - 1; - int32_t str_len = (dimension < 8) ? 128 : ((dimension + 1) * 16); - block_t *b = callocate(sc, str_len); - char *indices = (char *)block_data(b); - multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* calls pos_int_to_str_direct, writes to indices */ - plen = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, vref), ">", - indices, ") <", pos_int_to_str_direct_1(sc, eref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - liberate(sc, b); - } - else - { - size_t len1 = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, vref), "> ", integer_to_string(sc, i, &plen), ") <", - pos_int_to_str_direct_1(sc, eref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len1, ci->cycle_port); - }} - else - { - if (vector_rank(vect) > 1) - { - s7_int dimension = vector_rank(vect) - 1; - int32_t str_len = (dimension < 8) ? 128 : ((dimension + 1) * 16); - block_t *b = callocate(sc, str_len); - char *indices = (char *)block_data(b); - buf[0] = '\0'; - multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* writes to indices */ - plen = catstrs(buf, 2048, " (set! (<", pos_int_to_str_direct(sc, vref), ">", indices, ") ", (char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - liberate(sc, b); - } - else - { - size_t len1 = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, vref), "> ", integer_to_string_no_length(sc, i), ") ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len1, ci->cycle_port); - } - object_to_port_with_circle_check(sc, els[i], ci->cycle_port, P_READABLE, ci); - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - }} - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, els[i], port, P_READABLE, ci); - } - port_write_character(port)(sc, ')', port); - if (vector_rank(vect) > 1) - { - plen = catstrs_direct(buf, " 0 ", pos_int_to_str_direct(sc, len), (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - write_vector_dimensions(sc, vect, port); - } - if (is_typed_vector(vect)) - { - port_write_string(port)(sc, ")) (set! (vector-typer <v>) ", 28, port); - port_write_vector_typer(sc, vect, port); - port_write_string(port)(sc, ") <v>)", 6, port); - }} + (is_cyclic(vect)) && + ((vref = peek_shared_ref(ci, vect)) != 0)) + { + s7_pointer *els = vector_elements(vect); + if (vref < 0) vref = -vref; + if ((ci->defined[vref]) || (port == ci->cycle_port)) + { + plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, vref), ">", (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + unstack_gc_protect(sc); + return; + } + + if (is_typed_vector(vect)) + port_write_string(port)(sc, "(let ((<v> ", 11, port); + + if (vector_rank(vect) > 1) + port_write_string(port)(sc, "(subvector ", 11, port); + + port_write_string(port)(sc, "(vector", 7, port); /* top level let */ + for (i = 0; i < len; i++) + if (has_structure(els[i])) + { + int32_t eref = peek_shared_ref(ci, els[i]); + port_write_string(port)(sc, " #f", 3, port); + if (eref != 0) + { + if (eref < 0) eref = -eref; + if (vector_rank(vect) > 1) + { + s7_int dimension = vector_rank(vect) - 1; + int32_t str_len = (dimension < 8) ? 128 : ((dimension + 1) * 16); + block_t *b = callocate(sc, str_len); + char *indices = (char *)block_data(b); + multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* calls pos_int_to_str_direct, writes to indices */ + plen = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, vref), ">", + indices, ") <", pos_int_to_str_direct_1(sc, eref), ">) ", (const char *)NULL); + port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); + liberate(sc, b); + } + else + { + size_t len1 = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, vref), "> ", integer_to_string(sc, i, &plen), ") <", + pos_int_to_str_direct_1(sc, eref), ">) ", (const char *)NULL); + port_write_string(ci->cycle_port)(sc, buf, len1, ci->cycle_port); + }} + else + { + if (vector_rank(vect) > 1) + { + s7_int dimension = vector_rank(vect) - 1; + int32_t str_len = (dimension < 8) ? 128 : ((dimension + 1) * 16); + block_t *b = callocate(sc, str_len); + char *indices = (char *)block_data(b); + buf[0] = '\0'; + multivector_indices_to_string(sc, i, vect, indices, str_len, dimension); /* writes to indices */ + plen = catstrs(buf, 2048, " (set! (<", pos_int_to_str_direct(sc, vref), ">", indices, ") ", (char *)NULL); + port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); + liberate(sc, b); + } + else + { + size_t len1 = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, vref), "> ", integer_to_string_no_length(sc, i), ") ", (const char *)NULL); + port_write_string(ci->cycle_port)(sc, buf, len1, ci->cycle_port); + } + object_to_port_with_circle_check(sc, els[i], ci->cycle_port, P_READABLE, ci); + port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); + }} + else + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, els[i], port, P_READABLE, ci); + } + port_write_character(port)(sc, ')', port); + if (vector_rank(vect) > 1) + { + plen = catstrs_direct(buf, " 0 ", pos_int_to_str_direct(sc, len), (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + write_vector_dimensions(sc, vect, port); + } + if (is_typed_vector(vect)) + { + port_write_string(port)(sc, ")) (set! (vector-typer <v>) ", 28, port); + port_write_vector_typer(sc, vect, port); + port_write_string(port)(sc, ") <v>)", 6, port); + }} else - { - if (is_typed_vector(vect)) - port_write_string(port)(sc, "(let ((<v> ", 11, port); - /* (let ((v (make-vector 3 'a symbol?))) (object->string v :readable)): "(let ((<v> (vector 'a 'a 'a))) (set! (vector-typer <v>) symbol?) <v>)" */ - - if (vector_rank(vect) > 1) - port_write_string(port)(sc, "(subvector ", 11, port); - - if (is_immutable_vector(vect)) - port_write_string(port)(sc, "(immutable! ", 12, port); - - port_write_string(port)(sc, "(vector", 7, port); - for (i = 0; i < len; i++) - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, vector_element(vect, i), port, P_READABLE, ci); - } - - if (is_immutable_vector(vect)) - port_write_string(port)(sc, "))", 2, port); - else port_write_character(port)(sc, ')', port); - - if (vector_rank(vect) > 1) /* subvector above */ - { - plen = catstrs_direct(buf, " 0 ", pos_int_to_str_direct(sc, len), (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - write_vector_dimensions(sc, vect, port); - } - if (is_typed_vector(vect)) - { - port_write_string(port)(sc, ")) (set! (vector-typer <v>) ", 28, port); - port_write_vector_typer(sc, vect, port); - port_write_string(port)(sc, ") <v>)", 6, port); - }}} + { + if (is_typed_vector(vect)) + port_write_string(port)(sc, "(let ((<v> ", 11, port); + /* (let ((v (make-vector 3 'a symbol?))) (object->string v :readable)): "(let ((<v> (vector 'a 'a 'a))) (set! (vector-typer <v>) symbol?) <v>)" */ + + if (vector_rank(vect) > 1) + port_write_string(port)(sc, "(subvector ", 11, port); + + if (is_immutable_vector(vect)) + port_write_string(port)(sc, "(immutable! ", 12, port); + + port_write_string(port)(sc, "(vector", 7, port); + for (i = 0; i < len; i++) + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, vector_element(vect, i), port, P_READABLE, ci); + } + + if (is_immutable_vector(vect)) + port_write_string(port)(sc, "))", 2, port); + else port_write_character(port)(sc, ')', port); + + if (vector_rank(vect) > 1) /* subvector above */ + { + plen = catstrs_direct(buf, " 0 ", pos_int_to_str_direct(sc, len), (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + write_vector_dimensions(sc, vect, port); + } + if (is_typed_vector(vect)) + { + port_write_string(port)(sc, ")) (set! (vector-typer <v>) ", 28, port); + port_write_vector_typer(sc, vect, port); + port_write_string(port)(sc, ") <v>)", 6, port); + }}} else /* not readable write */ { if (vector_rank(vect) > 1) - { - if (vector_ndims(vect) > 1) - { - plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else port_write_character(port)(sc, '#', port); - multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), use_write, ci); - } + { + if (vector_ndims(vect) > 1) + { + plen = catstrs_direct(buf, "#", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + } + else port_write_character(port)(sc, '#', port); + multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), use_write, ci); + } else - { - port_write_string(port)(sc, "#(", 2, port); - for (i = 0; i < len - 1; i++) - { - object_to_port_with_circle_check(sc, vector_element(vect, i), port, not_p_display(use_write), ci); - port_write_character(port)(sc, ' ', port); - } - object_to_port_with_circle_check(sc, vector_element(vect, i), port, not_p_display(use_write), ci); - - if (too_long) - port_write_string(port)(sc, " ...)", 5, port); - else port_write_character(port)(sc, ')', port); - }} + { + port_write_string(port)(sc, "#(", 2, port); + for (i = 0; i < len - 1; i++) + { + object_to_port_with_circle_check(sc, vector_element(vect, i), port, not_p_display(use_write), ci); + port_write_character(port)(sc, ' ', port); + } + object_to_port_with_circle_check(sc, vector_element(vect, i), port, not_p_display(use_write), ci); + + if (too_long) + port_write_string(port)(sc, " ...)", 5, port); + else port_write_character(port)(sc, ')', port); + }} unstack_gc_protect(sc); } @@ -33248,7 +33248,7 @@ static int32_t print_vector_length(s7_scheme *sc, s7_pointer vect, s7_pointer po if (len == 0) { if (vector_rank(vect) > 1) - plen = (int32_t)catstrs_direct(buf, "#", vtype, pos_int_to_str_direct(sc, vector_ndims(vect)), "d()", (const char *)(const char *)NULL); + plen = (int32_t)catstrs_direct(buf, "#", vtype, pos_int_to_str_direct(sc, vector_ndims(vect)), "d()", (const char *)(const char *)NULL); else plen = (int32_t)catstrs_direct(buf, "#", vtype, "()", (const char *)NULL); port_write_string(port)(sc, buf, plen, port); return(-1); @@ -33268,7 +33268,7 @@ static int32_t print_vector_length(s7_scheme *sc, s7_pointer vect, s7_pointer po port_write_string(port)(sc, "#i(...)", 7, port); else if (is_float_vector(vect)) - port_write_string(port)(sc, "#r(...)", 7, port); + port_write_string(port)(sc, "#r(...)", 7, port); else port_write_string(port)(sc, "#u(...)", 7, port); return(-1); } @@ -33293,60 +33293,60 @@ static void int_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, const s7_int *els = int_vector_ints(vect); s7_int first = els[0]; for (i = 1; i < vlen; i++) - if (els[i] != first) - break; + if (els[i] != first) + break; if (i == vlen) - { - make_vector_to_port(sc, vect, port); - p = integer_to_string(sc, int_vector(vect, 0), &plen); - port_write_string(port)(sc, p, plen, port); - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_string(port)(sc, "))", 2, port); - else port_write_character(port)(sc, ')', port); - return; - }} + { + make_vector_to_port(sc, vect, port); + p = integer_to_string(sc, int_vector(vect, 0), &plen); + port_write_string(port)(sc, p, plen, port); + if ((use_write == P_READABLE) && + (is_immutable_vector(vect))) + port_write_string(port)(sc, "))", 2, port); + else port_write_character(port)(sc, ')', port); + return; + }} if (vector_rank(vect) == 1) { port_write_string(port)(sc, "#i(", 3, port); if (!is_string_port(port)) - { - p = integer_to_string(sc, int_vector(vect, 0), &plen); - port_write_string(port)(sc, p, plen, port); - for (s7_int i = 1; i < len; i++) - { - plen = catstrs_direct(buf, " ", integer_to_string_no_length(sc, int_vector(vect, i)), (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - }} + { + p = integer_to_string(sc, int_vector(vect, 0), &plen); + port_write_string(port)(sc, p, plen, port); + for (s7_int i = 1; i < len; i++) + { + plen = catstrs_direct(buf, " ", integer_to_string_no_length(sc, int_vector(vect, i)), (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + }} else - { - s7_int new_len = port_position(port); - s7_int next_len = port_data_size(port) - 128; - uint8_t *dbuf = port_data(port); - if (new_len >= next_len) - { - resize_port_data(sc, port, port_data_size(port) * 2); - next_len = port_data_size(port) - 128; - dbuf = port_data(port); - } - p = integer_to_string(sc, int_vector(vect, 0), &plen); - memcpy((void *)(dbuf + new_len), (const void *)p, plen); - new_len += plen; - for (s7_int i = 1; i < len; i++) - { - if (new_len >= next_len) - { - resize_port_data(sc, port, port_data_size(port) * 2); - next_len = port_data_size(port) - 128; - dbuf = port_data(port); - } - plen = catstrs_direct((char *)(dbuf + new_len), " ", integer_to_string_no_length(sc, int_vector(vect, i)), (const char *)NULL); - new_len += plen; - } - port_position(port) = new_len; - } + { + s7_int new_len = port_position(port); + s7_int next_len = port_data_size(port) - 128; + uint8_t *dbuf = port_data(port); + if (new_len >= next_len) + { + resize_port_data(sc, port, port_data_size(port) * 2); + next_len = port_data_size(port) - 128; + dbuf = port_data(port); + } + p = integer_to_string(sc, int_vector(vect, 0), &plen); + memcpy((void *)(dbuf + new_len), (const void *)p, plen); + new_len += plen; + for (s7_int i = 1; i < len; i++) + { + if (new_len >= next_len) + { + resize_port_data(sc, port, port_data_size(port) * 2); + next_len = port_data_size(port) - 128; + dbuf = port_data(port); + } + plen = catstrs_direct((char *)(dbuf + new_len), " ", integer_to_string_no_length(sc, int_vector(vect, i)), (const char *)NULL); + new_len += plen; + } + port_position(port) = new_len; + } if (too_long) - port_write_string(port)(sc, " ...)", 5, port); + port_write_string(port)(sc, " ...)", 5, port); else port_write_character(port)(sc, ')', port); } else @@ -33382,18 +33382,18 @@ static void float_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port s7_int vlen = vector_length(vect); s7_double first = els[0]; for (i = 1; i < vlen; i++) - if (els[i] != first) - break; + if (els[i] != first) + break; if (i == vlen) - { - make_vector_to_port(sc, vect, port); - plen = snprintf(buf, FV_BUFSIZE, "%.*g)", sc->float_format_precision, first); - port_write_string(port)(sc, buf, clamp_length(plen, FV_BUFSIZE), port); - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_character(port)(sc, ')', port); - return; - }} + { + make_vector_to_port(sc, vect, port); + plen = snprintf(buf, FV_BUFSIZE, "%.*g)", sc->float_format_precision, first); + port_write_string(port)(sc, buf, clamp_length(plen, FV_BUFSIZE), port); + if ((use_write == P_READABLE) && + (is_immutable_vector(vect))) + port_write_character(port)(sc, ')', port); + return; + }} if (vector_rank(vect) == 1) { @@ -33402,14 +33402,14 @@ static void float_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port floatify(buf, &plen); port_write_string(port)(sc, buf, clamp_length(plen, FV_BUFSIZE), port); for (i = 1; i < len; i++) - { - plen = snprintf(buf, FV_BUFSIZE - 4, " %.*g", sc->float_format_precision, els[i]); - plen--; /* fixup for the initial #\space */ - floatify((char *)(buf + 1), &plen); - port_write_string(port)(sc, buf, clamp_length(plen + 1, FV_BUFSIZE), port); - } + { + plen = snprintf(buf, FV_BUFSIZE - 4, " %.*g", sc->float_format_precision, els[i]); + plen--; /* fixup for the initial #\space */ + floatify((char *)(buf + 1), &plen); + port_write_string(port)(sc, buf, clamp_length(plen + 1, FV_BUFSIZE), port); + } if (too_long) - port_write_string(port)(sc, " ...)", 5, port); + port_write_string(port)(sc, " ...)", 5, port); else port_write_character(port)(sc, ')', port); } else @@ -33445,19 +33445,19 @@ static void byte_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, const uint8_t *els = byte_vector_bytes(vect); uint8_t first = els[0]; for (i = 1; i < vlen; i++) - if (els[i] != first) - break; + if (els[i] != first) + break; if (i == vlen) - { - make_vector_to_port(sc, vect, port); - p = integer_to_string(sc, byte_vector(vect, 0), &plen); /* only 0..10 start out with names: init_small_ints */ - port_write_string(port)(sc, p, plen, port); - if ((use_write == P_READABLE) && - (is_immutable_vector(vect))) - port_write_string(port)(sc, "))", 2, port); - else port_write_character(port)(sc, ')', port); - return; - }} + { + make_vector_to_port(sc, vect, port); + p = integer_to_string(sc, byte_vector(vect, 0), &plen); /* only 0..10 start out with names: init_small_ints */ + port_write_string(port)(sc, p, plen, port); + if ((use_write == P_READABLE) && + (is_immutable_vector(vect))) + port_write_string(port)(sc, "))", 2, port); + else port_write_character(port)(sc, ')', port); + return; + }} if (vector_rank(vect) == 1) { @@ -33465,12 +33465,12 @@ static void byte_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, p = integer_to_string(sc, byte_vector(vect, 0), &plen); port_write_string(port)(sc, p, plen, port); for (i = 1; i < len; i++) - { - plen = catstrs_direct(buf, " ", integer_to_string_no_length(sc, byte_vector(vect, i)), (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } + { + plen = catstrs_direct(buf, " ", integer_to_string_no_length(sc, byte_vector(vect, i)), (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + } if (too_long) - port_write_string(port)(sc, " ...)", 5, port); + port_write_string(port)(sc, " ...)", 5, port); else port_write_character(port)(sc, ')', port); } else @@ -33487,8 +33487,8 @@ static void byte_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, static void string_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) { bool immutable = ((use_write == P_READABLE) && - (is_immutable_string(obj)) && - (string_length(obj) > 0)); /* (immutable "") looks dumb */ + (is_immutable_string(obj)) && + (string_length(obj) > 0)); /* (immutable "") looks dumb */ if (immutable) port_write_string(port)(sc, "(immutable! ", 12, port); @@ -33496,33 +33496,33 @@ static void string_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_w { /* since string_length is a scheme length, not C, this write can embed nulls from C's point of view */ if (string_length(obj) > 1000) /* was 10000 28-Feb-18 */ - { - size_t size; - char buf[128]; - buf[0] = string_value(obj)[0]; - buf[1] = '\0'; - size = strspn((const char *)(string_value(obj) + 1), buf); /* if all #\null, this won't work */ - if (size == (size_t)(string_length(obj) - 1)) - { - s7_pointer c = chars[(int32_t)((uint8_t)(buf[0]))]; - int32_t nlen = (int32_t)catstrs_direct(buf, "(make-string ", pos_int_to_str_direct(sc, string_length(obj)), " ", (const char *)NULL); - port_write_string(port)(sc, buf, nlen, port); - port_write_string(port)(sc, character_name(c), character_name_length(c), port); - if (immutable) - port_write_string(port)(sc, "))", 2, port); - else port_write_character(port)(sc, ')', port); - return; - }} + { + size_t size; + char buf[128]; + buf[0] = string_value(obj)[0]; + buf[1] = '\0'; + size = strspn((const char *)(string_value(obj) + 1), buf); /* if all #\null, this won't work */ + if (size == (size_t)(string_length(obj) - 1)) + { + s7_pointer c = chars[(int32_t)((uint8_t)(buf[0]))]; + int32_t nlen = (int32_t)catstrs_direct(buf, "(make-string ", pos_int_to_str_direct(sc, string_length(obj)), " ", (const char *)NULL); + port_write_string(port)(sc, buf, nlen, port); + port_write_string(port)(sc, character_name(c), character_name_length(c), port); + if (immutable) + port_write_string(port)(sc, "))", 2, port); + else port_write_character(port)(sc, ')', port); + return; + }} if (use_write == P_DISPLAY) - port_write_string(port)(sc, string_value(obj), string_length(obj), port); + port_write_string(port)(sc, string_value(obj), string_length(obj), port); else - if (!string_needs_slashification((const uint8_t *)string_value(obj), string_length(obj))) - { - port_write_character(port)(sc, '"', port); - port_write_string(port)(sc, string_value(obj), string_length(obj), port); - port_write_character(port)(sc, '"', port); - } - else slashify_string_to_port(sc, port, string_value(obj), string_length(obj), IN_QUOTES); + if (!string_needs_slashification((const uint8_t *)string_value(obj), string_length(obj))) + { + port_write_character(port)(sc, '"', port); + port_write_string(port)(sc, string_value(obj), string_length(obj), port); + port_write_character(port)(sc, '"', port); + } + else slashify_string_to_port(sc, port, string_value(obj), string_length(obj), IN_QUOTES); } else if (use_write != P_DISPLAY) @@ -33558,44 +33558,44 @@ static void simple_list_readable_display(s7_scheme *sc, s7_pointer lst, s7_int t { port_write_string(port)(sc, "list", 4, port); for (x = lst; is_pair(x); x = cdr(x)) - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, car(x), port, P_READABLE, ci); - } + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, car(x), port, P_READABLE, ci); + } port_write_character(port)(sc, ')', port); } else { s7_int immutable_ctr = 0; if (is_immutable_pair(lst)) - { - port_write_string(port)(sc, "immutable! (cons ", 17, port); - immutable_ctr++; - } + { + port_write_string(port)(sc, "immutable! (cons ", 17, port); + immutable_ctr++; + } else port_write_string(port)(sc, "cons ", 5, port); object_to_port_with_circle_check(sc, car(lst), port, P_READABLE, ci); for (x = cdr(lst); is_pair(x); x = cdr(x)) - { - if (is_immutable_pair(x)) - { - port_write_string(port)(sc, " (immutable! (cons ", 19, port); - immutable_ctr++; - } - else port_write_string(port)(sc, " (cons ", 7, port); - object_to_port_with_circle_check(sc, car(x), port, P_READABLE, ci); - } + { + if (is_immutable_pair(x)) + { + port_write_string(port)(sc, " (immutable! (cons ", 19, port); + immutable_ctr++; + } + else port_write_string(port)(sc, " (cons ", 7, port); + object_to_port_with_circle_check(sc, car(x), port, P_READABLE, ci); + } if (is_null(x)) - port_write_string(port)(sc, " ()", 3, port); + port_write_string(port)(sc, " ()", 3, port); else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, x, port, P_READABLE, ci); - } + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, x, port, P_READABLE, ci); + } for (s7_int i = (true_len <= 0) ? 1 : 0; i < len; i++) - port_write_character(port)(sc, ')', port); + port_write_character(port)(sc, ')', port); for (s7_int i = 0; i < immutable_ctr; i++) - port_write_character(port)(sc, ')', port); + port_write_character(port)(sc, ')', port); } } @@ -33614,15 +33614,15 @@ static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri { int32_t href = peek_shared_ref(ci, lst); if (href != 0) - { - if (href < 0) href = -href; - if ((ci->defined[href]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t plen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - return; - }}} + { + if (href < 0) href = -href; + if ((ci->defined[href]) || (port == ci->cycle_port)) + { + char buf[128]; + int32_t plen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + return; + }}} if ((use_write != P_READABLE) && ((car(lst) == sc->quote_function) || (car(lst) == sc->quote_symbol)) && (true_len == 2)) @@ -33636,24 +33636,24 @@ static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri * :readable is tricky because the list might be something like (list 'quote (lambda () #f)) which needs to be evalable back to its original */ if (car(lst) == sc->quote_symbol) - port_write_string(port)(sc, "(quote ", 7, port); + port_write_string(port)(sc, "(quote ", 7, port); else port_write_character(port)(sc, '\'', port); if (need_new_ci) - { - new_ci = make_shared_info(sc); - /* clear_shared_info(new_ci); */ - temp_ci = load_shared_info(sc, cadr(lst), false, new_ci); /* temp_ci can be NULL! */ - } + { + new_ci = make_shared_info(sc); + /* clear_shared_info(new_ci); */ + temp_ci = load_shared_info(sc, cadr(lst), false, new_ci); /* temp_ci can be NULL! */ + } else temp_ci = ci; if (need_new_ci) sc->object_out_locked = true; object_to_port_with_circle_check(sc, cadr(lst), port, P_WRITE, temp_ci); if (need_new_ci) - { - sc->object_out_locked = old_locked; - free_shared_info(new_ci); - } + { + sc->object_out_locked = old_locked; + free_shared_info(new_ci); + } if (car(lst) == sc->quote_symbol) - port_write_character(port)(sc, ')', port); + port_write_character(port)(sc, ')', port); return; } #if WITH_IMMUTABLE_UNQUOTE @@ -33672,202 +33672,202 @@ static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_wri if (use_write == P_READABLE) { if (!is_cyclic(lst)) - { - /* here (and in the cyclic case) we need to handle immutable pairs -- this requires using cons rather than list etc */ - simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); - return; - } + { + /* here (and in the cyclic case) we need to handle immutable pairs -- this requires using cons rather than list etc */ + simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); + return; + } if (ci) - { - int32_t plen; - s7_pointer local_port; - char buf[128], lst_name[128]; - bool lst_local = false; - int32_t lst_ref = peek_shared_ref(ci, lst); - if (lst_ref == 0) - { - s7_pointer p; - for (p = lst; is_pair(p); p = cdr(p)) - if ((has_structure(car(p))) || - ((is_pair(cdr(p))) && - (peek_shared_ref(ci, cdr(p)) != 0))) - { - lst_name[0] = '<'; lst_name[1] = 'L'; lst_name[2] = '>'; lst_name[3] = '\0'; - lst_local = true; - port_write_string(port)(sc, "let ((<L> (list", 15, port); /* '(' above */ - break; - } - if (!lst_local) - { - if (has_structure(p)) - { - lst_name[0] = '<'; lst_name[1] = 'L'; lst_name[2] = '>'; lst_name[3] = '\0'; - lst_local = true; - port_write_string(port)(sc, "let ((<L> (list", 15, port); /* '(' above */ - } - else - { - simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); - return; - }}} - else - { - if (lst_ref < 0) lst_ref = -lst_ref; - catstrs_direct(lst_name, "<", pos_int_to_str_direct(sc, lst_ref), ">", (const char *)NULL); - port_write_string(port)(sc, "list", 4, port); /* '(' above */ - } - - for (i = 0, x = lst; (i < len) && (is_pair(x)); x = cdr(x), i++) - { - if ((has_structure(car(x))) && - (is_cyclic(car(x)))) - port_write_string(port)(sc, " #f", 3, port); - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, car(x), port, use_write, ci); - } - if ((is_pair(cdr(x))) && - (peek_shared_ref(ci, cdr(x)) != 0)) - break; - } - - if (lst_local) - port_write_string(port)(sc, "))) ", 4, port); - else port_write_character(port)(sc, ')', port); - - /* fill in the cyclic entries */ - local_port = ((lst_local) || (ci->cycle_port == sc->F)) ? port : ci->cycle_port; /* (object->string (list-values `(x . 1) (signature (int-vector))) :readable) */ - for (x = lst, i = 0; (i < len) && (is_pair(x)); x = cdr(x), i++) - { - int32_t lref; - if ((has_structure(car(x))) && - (is_cyclic(car(x)))) - { - if (i == 0) - plen = (int32_t)catstrs_direct(buf, " (set-car! ", lst_name, " ", (const char *)NULL); - else plen = (int32_t)catstrs_direct(buf, " (set! (", lst_name, " ", pos_int_to_str_direct(sc, i), ") ", (const char *)NULL); - port_write_string(local_port)(sc, buf, plen, local_port); - lref = peek_shared_ref(ci, car(x)); - if (lref == 0) - object_to_port_with_circle_check(sc, car(x), local_port, use_write, ci); - else - { - if (lref < 0) lref = -lref; - plen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, lref), ">", (const char *)NULL); - port_write_string(local_port)(sc, buf, plen, local_port); - } - port_write_string(local_port)(sc, ") ", 2, local_port); - } - if ((is_pair(cdr(x))) && - ((lref = peek_shared_ref(ci, cdr(x))) != 0)) - { - if (lref < 0) lref = -lref; - if (i == 0) - plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", - "(set-cdr! ", lst_name, " <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); - else - if (i == 1) - plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", - "(set-cdr! (cdr ", lst_name, ") <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); - else plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", - "(set-cdr! (list-tail ", lst_name, " ", pos_int_to_str_direct_1(sc, i), - ") <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); - port_write_string(local_port)(sc, buf, plen, local_port); - break; - }} - if (true_len < 0) /* dotted list */ - { - s7_pointer end_x; - for (end_x = lst; is_pair(end_x); end_x = cdr(end_x)); /* or maybe faster, start at x? */ - /* we can't depend on the loops above to set x to the last element because they sometimes break out */ - if (true_len == -1) /* cons cell */ - plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", "(set-cdr! ", lst_name, " ", (const char *)NULL); - else - if (true_len == -2) - plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", "(set-cdr! (cdr ", lst_name, ") ", (const char *)NULL); - else plen = (int32_t)catstrs_direct(buf, "(set-cdr! (list-tail ", lst_name, " ", pos_int_to_str_direct(sc, len - 2), ") ", (const char *)NULL); - port_write_string(local_port)(sc, buf, plen, local_port); - object_to_port_with_circle_check(sc, end_x, local_port, use_write, ci); - port_write_string(local_port)(sc, ") ", 2, local_port); - } - if (lst_local) - port_write_string(local_port)(sc, " <L>)", 8, local_port); - } + { + int32_t plen; + s7_pointer local_port; + char buf[128], lst_name[128]; + bool lst_local = false; + int32_t lst_ref = peek_shared_ref(ci, lst); + if (lst_ref == 0) + { + s7_pointer p; + for (p = lst; is_pair(p); p = cdr(p)) + if ((has_structure(car(p))) || + ((is_pair(cdr(p))) && + (peek_shared_ref(ci, cdr(p)) != 0))) + { + lst_name[0] = '<'; lst_name[1] = 'L'; lst_name[2] = '>'; lst_name[3] = '\0'; + lst_local = true; + port_write_string(port)(sc, "let ((<L> (list", 15, port); /* '(' above */ + break; + } + if (!lst_local) + { + if (has_structure(p)) + { + lst_name[0] = '<'; lst_name[1] = 'L'; lst_name[2] = '>'; lst_name[3] = '\0'; + lst_local = true; + port_write_string(port)(sc, "let ((<L> (list", 15, port); /* '(' above */ + } + else + { + simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); + return; + }}} + else + { + if (lst_ref < 0) lst_ref = -lst_ref; + catstrs_direct(lst_name, "<", pos_int_to_str_direct(sc, lst_ref), ">", (const char *)NULL); + port_write_string(port)(sc, "list", 4, port); /* '(' above */ + } + + for (i = 0, x = lst; (i < len) && (is_pair(x)); x = cdr(x), i++) + { + if ((has_structure(car(x))) && + (is_cyclic(car(x)))) + port_write_string(port)(sc, " #f", 3, port); + else + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, car(x), port, use_write, ci); + } + if ((is_pair(cdr(x))) && + (peek_shared_ref(ci, cdr(x)) != 0)) + break; + } + + if (lst_local) + port_write_string(port)(sc, "))) ", 4, port); + else port_write_character(port)(sc, ')', port); + + /* fill in the cyclic entries */ + local_port = ((lst_local) || (ci->cycle_port == sc->F)) ? port : ci->cycle_port; /* (object->string (list-values `(x . 1) (signature (int-vector))) :readable) */ + for (x = lst, i = 0; (i < len) && (is_pair(x)); x = cdr(x), i++) + { + int32_t lref; + if ((has_structure(car(x))) && + (is_cyclic(car(x)))) + { + if (i == 0) + plen = (int32_t)catstrs_direct(buf, " (set-car! ", lst_name, " ", (const char *)NULL); + else plen = (int32_t)catstrs_direct(buf, " (set! (", lst_name, " ", pos_int_to_str_direct(sc, i), ") ", (const char *)NULL); + port_write_string(local_port)(sc, buf, plen, local_port); + lref = peek_shared_ref(ci, car(x)); + if (lref == 0) + object_to_port_with_circle_check(sc, car(x), local_port, use_write, ci); + else + { + if (lref < 0) lref = -lref; + plen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, lref), ">", (const char *)NULL); + port_write_string(local_port)(sc, buf, plen, local_port); + } + port_write_string(local_port)(sc, ") ", 2, local_port); + } + if ((is_pair(cdr(x))) && + ((lref = peek_shared_ref(ci, cdr(x))) != 0)) + { + if (lref < 0) lref = -lref; + if (i == 0) + plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", + "(set-cdr! ", lst_name, " <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); + else + if (i == 1) + plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", + "(set-cdr! (cdr ", lst_name, ") <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); + else plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", + "(set-cdr! (list-tail ", lst_name, " ", pos_int_to_str_direct_1(sc, i), + ") <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); + port_write_string(local_port)(sc, buf, plen, local_port); + break; + }} + if (true_len < 0) /* dotted list */ + { + s7_pointer end_x; + for (end_x = lst; is_pair(end_x); end_x = cdr(end_x)); /* or maybe faster, start at x? */ + /* we can't depend on the loops above to set x to the last element because they sometimes break out */ + if (true_len == -1) /* cons cell */ + plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", "(set-cdr! ", lst_name, " ", (const char *)NULL); + else + if (true_len == -2) + plen = (int32_t)catstrs_direct(buf, (lst_local) ? " " : " ", "(set-cdr! (cdr ", lst_name, ") ", (const char *)NULL); + else plen = (int32_t)catstrs_direct(buf, "(set-cdr! (list-tail ", lst_name, " ", pos_int_to_str_direct(sc, len - 2), ") ", (const char *)NULL); + port_write_string(local_port)(sc, buf, plen, local_port); + object_to_port_with_circle_check(sc, end_x, local_port, use_write, ci); + port_write_string(local_port)(sc, ") ", 2, local_port); + } + if (lst_local) + port_write_string(local_port)(sc, " <L>)", 8, local_port); + } else simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); } else /* not :readable */ { s7_int plen = (len > sc->print_length) ? sc->print_length : len; if (plen <= 0) - { - port_write_string(port)(sc, "(...))", 6, port); /* open paren above about 150 lines, "list" here is wrong if it's a cons */ - return; - } + { + port_write_string(port)(sc, "(...))", 6, port); /* open paren above about 150 lines, "list" here is wrong if it's a cons */ + return; + } if (ci) - { - for (x = lst, i = 0; (is_pair(x)) && (i < plen) && ((i == 0) || (peek_shared_ref(ci, x) == 0)); i++, x = cdr(x)) - { - ci->ctr++; - if (ci->ctr > sc->print_length) - { - port_write_string(port)(sc, " ...)", 5, port); - return; - } - object_to_port_with_circle_check(sc, car(x), port, not_p_display(use_write), ci); - if (i < (len - 1)) - port_write_character(port)(sc, ' ', port); - } - if (is_not_null(x)) - { - if (plen < len) - port_write_string(port)(sc, " ...", 4, port); - else - { - if ((true_len == 0) && - (i == len)) - port_write_string(port)(sc, " . ", 3, port); - else port_write_string(port)(sc, ". ", 2, port); - object_to_port_with_circle_check(sc, x, port, not_p_display(use_write), ci); - }} - port_write_character(port)(sc, ')', port); - } + { + for (x = lst, i = 0; (is_pair(x)) && (i < plen) && ((i == 0) || (peek_shared_ref(ci, x) == 0)); i++, x = cdr(x)) + { + ci->ctr++; + if (ci->ctr > sc->print_length) + { + port_write_string(port)(sc, " ...)", 5, port); + return; + } + object_to_port_with_circle_check(sc, car(x), port, not_p_display(use_write), ci); + if (i < (len - 1)) + port_write_character(port)(sc, ' ', port); + } + if (is_not_null(x)) + { + if (plen < len) + port_write_string(port)(sc, " ...", 4, port); + else + { + if ((true_len == 0) && + (i == len)) + port_write_string(port)(sc, " . ", 3, port); + else port_write_string(port)(sc, ". ", 2, port); + object_to_port_with_circle_check(sc, x, port, not_p_display(use_write), ci); + }} + port_write_character(port)(sc, ')', port); + } else - { - s7_int len1 = plen - 1; - if (is_string_port(port)) - { - for (x = lst, i = 0; (is_pair(x)) && (i < len1); i++, x = cdr(x)) - { - object_to_port(sc, car(x), port, not_p_display(use_write), ci); - if (port_position(port) >= sc->objstr_max_len) - return; - if (port_position(port) >= port_data_size(port)) - resize_port_data(sc, port, port_data_size(port) * 2); - port_data(port)[port_position(port)++] = (uint8_t)' '; - }} - else - for (x = lst, i = 0; (is_pair(x)) && (i < len1); i++, x = cdr(x)) - { - object_to_port(sc, car(x), port, not_p_display(use_write), ci); /* lst free here if unprotected */ - port_write_character(port)(sc, ' ', port); - } - if (is_pair(x)) - { - object_to_port(sc, car(x), port, not_p_display(use_write), ci); - x = cdr(x); - } - if (is_not_null(x)) - { - if (plen < len) - port_write_string(port)(sc, " ...", 4, port); - else - { - port_write_string(port)(sc, ". ", 2, port); - object_to_port(sc, x, port, not_p_display(use_write), ci); - }} - port_write_character(port)(sc, ')', port); - }} + { + s7_int len1 = plen - 1; + if (is_string_port(port)) + { + for (x = lst, i = 0; (is_pair(x)) && (i < len1); i++, x = cdr(x)) + { + object_to_port(sc, car(x), port, not_p_display(use_write), ci); + if (port_position(port) >= sc->objstr_max_len) + return; + if (port_position(port) >= port_data_size(port)) + resize_port_data(sc, port, port_data_size(port) * 2); + port_data(port)[port_position(port)++] = (uint8_t)' '; + }} + else + for (x = lst, i = 0; (is_pair(x)) && (i < len1); i++, x = cdr(x)) + { + object_to_port(sc, car(x), port, not_p_display(use_write), ci); /* lst free here if unprotected */ + port_write_character(port)(sc, ' ', port); + } + if (is_pair(x)) + { + object_to_port(sc, car(x), port, not_p_display(use_write), ci); + x = cdr(x); + } + if (is_not_null(x)) + { + if (plen < len) + port_write_string(port)(sc, " ...", 4, port); + else + { + port_write_string(port)(sc, ". ", 2, port); + object_to_port(sc, x, port, not_p_display(use_write), ci); + }} + port_write_character(port)(sc, ')', port); + }} } static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let); @@ -33909,55 +33909,55 @@ static void hash_table_procedures_to_port(s7_scheme *sc, s7_pointer hash, s7_poi if (typer[0] == '#') /* #f */ { if (is_pair(hash_table_procedures(hash))) - { - s7_int nlen = 0; - const char *str = (const char *)integer_to_string(sc, hash_table_size(hash), &nlen); - const char *checker = hash_table_typer_name(sc, hash_table_procedures_checker(hash)); - const char *mapper = hash_table_typer_name(sc, hash_table_procedures_mapper(hash)); - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(make-weak-hash-table ", 22, port); - else port_write_string(port)(sc, "(make-hash-table ", 17, port); - port_write_string(port)(sc, str, nlen, port); - if ((checker) && (mapper)) - { - if ((is_boolean(hash_table_procedures_checker(hash))) && (is_boolean(hash_table_procedures_mapper(hash)))) - port_write_string(port)(sc, " #f", 3, port); /* no checker/mapper set? */ - else - { - port_write_string(port)(sc, " (cons ", 7, port); - port_write_string(port)(sc, checker, safe_strlen(checker), port); - port_write_character(port)(sc, ' ', port); - port_write_string(port)(sc, mapper, safe_strlen(mapper), port); - port_write_character(port)(sc, ')', port); - }} - else - if ((is_any_closure(hash_table_procedures_checker(hash))) || - (is_any_closure(hash_table_procedures_mapper(hash)))) - { - port_write_string(port)(sc, " (cons ", 7, port); - if (is_any_closure(hash_table_procedures_checker(hash))) - object_to_port_with_circle_check(sc, hash_table_procedures_checker(hash), port, P_READABLE, ci); - else port_write_string(port)(sc, checker, safe_strlen(checker), port); - port_write_character(port)(sc, ' ', port); - if (is_any_closure(hash_table_procedures_mapper(hash))) - object_to_port_with_circle_check(sc, hash_table_procedures_mapper(hash), port, P_READABLE, ci); - else port_write_string(port)(sc, mapper, safe_strlen(mapper), port); - port_write_character(port)(sc, ')', port); - } - else port_write_string(port)(sc, " #f", 3, port); /* no checker/mapper set? */ - hash_typers_to_port(sc, hash, port); - } + { + s7_int nlen = 0; + const char *str = (const char *)integer_to_string(sc, hash_table_size(hash), &nlen); + const char *checker = hash_table_typer_name(sc, hash_table_procedures_checker(hash)); + const char *mapper = hash_table_typer_name(sc, hash_table_procedures_mapper(hash)); + if (is_weak_hash_table(hash)) + port_write_string(port)(sc, "(make-weak-hash-table ", 22, port); + else port_write_string(port)(sc, "(make-hash-table ", 17, port); + port_write_string(port)(sc, str, nlen, port); + if ((checker) && (mapper)) + { + if ((is_boolean(hash_table_procedures_checker(hash))) && (is_boolean(hash_table_procedures_mapper(hash)))) + port_write_string(port)(sc, " #f", 3, port); /* no checker/mapper set? */ + else + { + port_write_string(port)(sc, " (cons ", 7, port); + port_write_string(port)(sc, checker, safe_strlen(checker), port); + port_write_character(port)(sc, ' ', port); + port_write_string(port)(sc, mapper, safe_strlen(mapper), port); + port_write_character(port)(sc, ')', port); + }} + else + if ((is_any_closure(hash_table_procedures_checker(hash))) || + (is_any_closure(hash_table_procedures_mapper(hash)))) + { + port_write_string(port)(sc, " (cons ", 7, port); + if (is_any_closure(hash_table_procedures_checker(hash))) + object_to_port_with_circle_check(sc, hash_table_procedures_checker(hash), port, P_READABLE, ci); + else port_write_string(port)(sc, checker, safe_strlen(checker), port); + port_write_character(port)(sc, ' ', port); + if (is_any_closure(hash_table_procedures_mapper(hash))) + object_to_port_with_circle_check(sc, hash_table_procedures_mapper(hash), port, P_READABLE, ci); + else port_write_string(port)(sc, mapper, safe_strlen(mapper), port); + port_write_character(port)(sc, ')', port); + } + else port_write_string(port)(sc, " #f", 3, port); /* no checker/mapper set? */ + hash_typers_to_port(sc, hash, port); + } else - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(weak-hash-table)", 17, port); - else port_write_string(port)(sc, "(hash-table)", 12, port); + if (is_weak_hash_table(hash)) + port_write_string(port)(sc, "(weak-hash-table)", 17, port); + else port_write_string(port)(sc, "(hash-table)", 12, port); } else { s7_int nlen = 0; const char *str = integer_to_string(sc, hash_table_size(hash), &nlen); if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(make-weak-hash-table ", 22, port); + port_write_string(port)(sc, "(make-weak-hash-table ", 22, port); else port_write_string(port)(sc, "(make-hash-table ", 17, port); port_write_string(port)(sc, str, nlen, port); port_write_character(port)(sc, ' ', port); @@ -33978,13 +33978,13 @@ static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, if (len == 0) { if (use_write == P_READABLE) - hash_table_procedures_to_port(sc, hash, port, true, ci); + hash_table_procedures_to_port(sc, hash, port, true, ci); else - { - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(weak-hash-table)", 17, port); - else port_write_string(port)(sc, "(hash-table)", 12, port); - } + { + if (is_weak_hash_table(hash)) + port_write_string(port)(sc, "(weak-hash-table)", 17, port); + else port_write_string(port)(sc, "(hash-table)", 12, port); + } return; } @@ -33992,30 +33992,30 @@ static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, { s7_int plen = sc->print_length; if (plen <= 0) - { - port_write_string(port)(sc, "(hash-table ...)", 16, port); - return; - } + { + port_write_string(port)(sc, "(hash-table ...)", 16, port); + return; + } if (len > plen) - { - too_long = true; - len = plen; - }} + { + too_long = true; + len = plen; + }} if ((use_write == P_READABLE) && (ci)) { href = peek_shared_ref(ci, hash); if (href != 0) - { - if (href < 0) href = -href; - if ((ci->defined[href]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - return; - }}} + { + if (href < 0) href = -href; + if ((ci->defined[href]) || (port == ci->cycle_port)) + { + char buf[128]; + int32_t plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + return; + }}} iterator = s7_make_iterator(sc, hash); gc_iter = gc_protect_1(sc, iterator); @@ -34027,117 +34027,117 @@ static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, if (use_write == P_READABLE) { if ((is_typed_hash_table(hash)) || (is_pair(hash_table_procedures(hash))) || (hash_chosen(hash))) - { - port_write_string(port)(sc, "(let ((<h> ", 11, port); - letd = true; - } + { + port_write_string(port)(sc, "(let ((<h> ", 11, port); + letd = true; + } else - if ((is_immutable_hash_table(hash)) && (!hash_cyclic)) - { - port_write_string(port)(sc, "(immutable! ", 12, port); - immut = true; - }} + if ((is_immutable_hash_table(hash)) && (!hash_cyclic)) + { + port_write_string(port)(sc, "(immutable! ", 12, port); + immut = true; + }} if ((use_write == P_READABLE) && (hash_cyclic)) { if (href < 0) href = -href; if ((!is_typed_hash_table(hash)) && (!is_pair(hash_table_procedures(hash))) && (!hash_chosen(hash))) - { - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(weak-hash-table", 16, port); - else port_write_string(port)(sc, "(hash-table", 11, port); /* top level let */ - } + { + if (is_weak_hash_table(hash)) + port_write_string(port)(sc, "(weak-hash-table", 16, port); + else port_write_string(port)(sc, "(hash-table", 11, port); /* top level let */ + } else - { - hash_table_procedures_to_port(sc, hash, port, true, ci); - port_write_character(port)(sc, ')', port); - } + { + hash_table_procedures_to_port(sc, hash, port, true, ci); + port_write_character(port)(sc, ')', port); + } /* output here is deferred via ci->cycle_port until later in cyclic_out */ for (s7_int i = 0; i < len; i++) - { - s7_pointer key_val = hash_table_iterate(sc, iterator); - s7_pointer key = car(key_val); - s7_pointer val = cdr(key_val); - char buf[128]; - int32_t eref = peek_shared_ref(ci, val); - int32_t kref = peek_shared_ref(ci, key); - int32_t plen = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, href), "> ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - if (kref != 0) - { - if (kref < 0) kref = -kref; - plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, kref), ">", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - } - else object_to_port(sc, key, ci->cycle_port, P_READABLE, ci); - if (eref != 0) - { - if (eref < 0) eref = -eref; - plen = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, eref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); - } - else - { - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - object_to_port_with_circle_check(sc, val, ci->cycle_port, P_READABLE, ci); - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - }}} + { + s7_pointer key_val = hash_table_iterate(sc, iterator); + s7_pointer key = car(key_val); + s7_pointer val = cdr(key_val); + char buf[128]; + int32_t eref = peek_shared_ref(ci, val); + int32_t kref = peek_shared_ref(ci, key); + int32_t plen = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, href), "> ", (const char *)NULL); + port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); + if (kref != 0) + { + if (kref < 0) kref = -kref; + plen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, kref), ">", (const char *)NULL); + port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); + } + else object_to_port(sc, key, ci->cycle_port, P_READABLE, ci); + if (eref != 0) + { + if (eref < 0) eref = -eref; + plen = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, eref), ">) ", (const char *)NULL); + port_write_string(ci->cycle_port)(sc, buf, plen, ci->cycle_port); + } + else + { + port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); + object_to_port_with_circle_check(sc, val, ci->cycle_port, P_READABLE, ci); + port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); + }}} else { if (((!is_typed_hash_table(hash)) && (!is_pair(hash_table_procedures(hash))) && (!hash_chosen(hash))) || (use_write != P_READABLE)) - { - if (is_weak_hash_table(hash)) - port_write_string(port)(sc, "(weak-hash-table", 16, port); - else port_write_string(port)(sc, "(hash-table", 11, port); - } + { + if (is_weak_hash_table(hash)) + port_write_string(port)(sc, "(weak-hash-table", 16, port); + else port_write_string(port)(sc, "(hash-table", 11, port); + } else - { - hash_table_procedures_to_port(sc, hash, port, true, ci); - port_write_character(port)(sc, ')', port); - port_write_string(port)(sc, ") (copy (hash-table", 19, port); - copied = true; - } + { + hash_table_procedures_to_port(sc, hash, port, true, ci); + port_write_character(port)(sc, ')', port); + port_write_string(port)(sc, ") (copy (hash-table", 19, port); + copied = true; + } for (s7_int i = 0; i < len; i++) - { - s7_pointer key_val = hash_table_iterate(sc, iterator); - port_write_character(port)(sc, ' ', port); - if ((use_write != P_READABLE) && (use_write != P_CODE) && (is_normal_symbol(car(key_val)))) - port_write_character(port)(sc, '\'', port); - object_to_port_with_circle_check(sc, car(key_val), port, not_p_display(use_write), ci); - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, cdr(key_val), port, not_p_display(use_write), ci); - } + { + s7_pointer key_val = hash_table_iterate(sc, iterator); + port_write_character(port)(sc, ' ', port); + if ((use_write != P_READABLE) && (use_write != P_CODE) && (is_normal_symbol(car(key_val)))) + port_write_character(port)(sc, '\'', port); + object_to_port_with_circle_check(sc, car(key_val), port, not_p_display(use_write), ci); + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, cdr(key_val), port, not_p_display(use_write), ci); + } if (use_write != P_READABLE) - { - if (too_long) - port_write_string(port)(sc, " ...)", 5, port); - else port_write_character(port)(sc, ')', port); - }} + { + if (too_long) + port_write_string(port)(sc, " ...)", 5, port); + else port_write_character(port)(sc, ')', port); + }} if (use_write == P_READABLE) { if (copied) - { - if (!letd) - { - char buf[128]; - int32_t plen = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); - port_write_string(port)(sc, buf, plen, port); - } - else port_write_string(port)(sc, ") <h>))", 7, port); - } + { + if (!letd) + { + char buf[128]; + int32_t plen = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); + port_write_string(port)(sc, buf, plen, port); + } + else port_write_string(port)(sc, ") <h>))", 7, port); + } else - if (letd) - port_write_string(port)(sc, ") <h>)", 6, port); - else port_write_character(port)(sc, ')', port); + if (letd) + port_write_string(port)(sc, ") <h>)", 6, port); + else port_write_character(port)(sc, ')', port); if ((is_immutable_hash_table(hash)) && (!hash_cyclic) && (!is_typed_hash_table(hash))) - port_write_character(port)(sc, ')', port); + port_write_character(port)(sc, ')', port); if ((!immut) && (is_immutable_hash_table(hash)) && (!hash_cyclic)) - port_write_string(port)(sc, ") (immutable! <h>))", 19, port); + port_write_string(port)(sc, ") (immutable! <h>))", 19, port); } s7_gc_unprotect_at(sc, gc_iter); iterator_current(iterator) = sc->nil; @@ -34150,14 +34150,14 @@ static void slot_list_to_port(s7_scheme *sc, s7_pointer slot, s7_pointer port, s for (; tis_slot(slot); slot = next_slot(slot)) { if (bindings) - { - if (first_time) - { - port_write_character(port)(sc, '(', port); - first_time = false; - } - else port_write_string(port)(sc, " (", 2, port); - } + { + if (first_time) + { + port_write_character(port)(sc, '(', port); + first_time = false; + } + else port_write_string(port)(sc, " (", 2, port); + } else port_write_character(port)(sc, ' ', port); symbol_to_port(sc, slot_symbol(slot), port, (bindings) ? P_DISPLAY : P_KEY, NULL); /* (object->string (inlet (symbol "(\")") 1) :readable) */ port_write_character(port)(sc, ' ', port); @@ -34173,50 +34173,50 @@ static void slot_list_to_port_with_cycle(s7_scheme *sc, s7_pointer obj, s7_point { s7_pointer sym = slot_symbol(slot), val = slot_value(slot); if (bindings) - { - if (first_time) - { - port_write_character(port)(sc, '(', port); - first_time = false; - } - else port_write_string(port)(sc, " (", 2, port); - } + { + if (first_time) + { + port_write_character(port)(sc, '(', port); + first_time = false; + } + else port_write_string(port)(sc, " (", 2, port); + } else port_write_character(port)(sc, ' ', port); symbol_to_port(sc, sym, port, (bindings) ? P_DISPLAY : P_KEY, NULL); if (has_structure(val)) - { - char buf[128]; - int32_t symref; - int32_t len = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, -peek_shared_ref(ci, obj)), "> ", (const char *)NULL); - port_write_string(port)(sc, " #f", 3, port); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - symbol_to_port(sc, sym, ci->cycle_port, P_KEY, NULL); - - symref = peek_shared_ref(ci, val); - if (symref != 0) - { - if (symref < 0) symref = -symref; - len = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, symref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - } - else - { - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - object_to_port_with_circle_check(sc, val, ci->cycle_port, P_READABLE, ci); - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - }} + { + char buf[128]; + int32_t symref; + int32_t len = catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, -peek_shared_ref(ci, obj)), "> ", (const char *)NULL); + port_write_string(port)(sc, " #f", 3, port); + port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); + symbol_to_port(sc, sym, ci->cycle_port, P_KEY, NULL); + + symref = peek_shared_ref(ci, val); + if (symref != 0) + { + if (symref < 0) symref = -symref; + len = catstrs_direct(buf, ") <", pos_int_to_str_direct(sc, symref), ">) ", (const char *)NULL); + port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); + } + else + { + port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); + object_to_port_with_circle_check(sc, val, ci->cycle_port, P_READABLE, ci); + port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); + }} else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, val, port, P_READABLE, ci); - } + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, val, port, P_READABLE, ci); + } if (bindings) port_write_character(port)(sc, ')', port); if (is_immutable(obj)) - { - char buf[128]; - int32_t len = catstrs_direct(buf, " (immutable! <", pos_int_to_str_direct(sc, -peek_shared_ref(ci, obj)), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - }} + { + char buf[128]; + int32_t len = catstrs_direct(buf, " (immutable! <", pos_int_to_str_direct(sc, -peek_shared_ref(ci, obj)), ">) ", (const char *)NULL); + port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); + }} } static bool let_has_setter(s7_pointer obj) @@ -34233,12 +34233,12 @@ static bool slot_setters_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, for (s7_pointer slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot)) if (slot_has_setter(slot)) { - if (spaced_out) port_write_character(port)(sc, ' ', port); else spaced_out = true; - port_write_string(port)(sc, "(set! (setter '", 15, port); - symbol_to_port(sc, slot_symbol(slot), port, P_DISPLAY, NULL); - port_write_string(port)(sc, ") ", 2, port); - object_to_port_with_circle_check(sc, slot_setter(slot), port, P_READABLE, ci); - port_write_character(port)(sc, ')', port); + if (spaced_out) port_write_character(port)(sc, ' ', port); else spaced_out = true; + port_write_string(port)(sc, "(set! (setter '", 15, port); + symbol_to_port(sc, slot_symbol(slot), port, P_DISPLAY, NULL); + port_write_string(port)(sc, ") ", 2, port); + object_to_port_with_circle_check(sc, slot_setter(slot), port, P_READABLE, ci); + port_write_character(port)(sc, ')', port); } return(spaced_out); } @@ -34248,10 +34248,10 @@ static void immutable_slots_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer po for (s7_pointer slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot)) if (is_immutable_slot(slot)) { - if (spaced_out) port_write_character(port)(sc, ' ', port); else spaced_out = true; - port_write_string(port)(sc, "(immutable! '", 13, port); - symbol_to_port(sc, slot_symbol(slot), port, P_DISPLAY, NULL); - port_write_character(port)(sc, ')', port); + if (spaced_out) port_write_character(port)(sc, ' ', port); else spaced_out = true; + port_write_string(port)(sc, "(immutable! '", 13, port); + symbol_to_port(sc, slot_symbol(slot), port, P_DISPLAY, NULL); + port_write_character(port)(sc, ')', port); } } @@ -34280,21 +34280,21 @@ static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_writ { s7_pointer print_func = find_method(sc, obj, sc->object_to_string_symbol); if (print_func != sc->undefined) - { - s7_pointer p; - /* what needs to be protected here? for one, the function might not return a string! */ - - clear_has_methods(obj); - if ((use_write == P_WRITE) || (use_write == P_CODE)) - p = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); - else p = s7_apply_function(sc, print_func, set_plist_2(sc, obj, (use_write == P_DISPLAY) ? sc->F : sc->readable_keyword)); - set_has_methods(obj); - - if ((is_string(p)) && - (string_length(p) > 0)) - port_write_string(port)(sc, string_value(p), string_length(p), port); - return; - }} + { + s7_pointer p; + /* what needs to be protected here? for one, the function might not return a string! */ + + clear_has_methods(obj); + if ((use_write == P_WRITE) || (use_write == P_CODE)) + p = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); + else p = s7_apply_function(sc, print_func, set_plist_2(sc, obj, (use_write == P_DISPLAY) ? sc->F : sc->readable_keyword)); + set_has_methods(obj); + + if ((is_string(p)) && + (string_length(p) > 0)) + port_write_string(port)(sc, string_value(p), string_length(p), port); + return; + }} if (obj == sc->rootlet) {port_write_string(port)(sc, "(rootlet)", 9, port); return;} if (obj == sc->s7_starlet) {port_write_string(port)(sc, "*s7*", 4, port); return;} if (is_unlet(obj)) {port_write_string(port)(sc, "(unlet)", 7, port); return;} @@ -34308,104 +34308,104 @@ static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_writ { int32_t lref; if ((ci) && - (is_cyclic(obj)) && - ((lref = peek_shared_ref(ci, obj)) != 0)) - { - if (lref < 0) lref = -lref; - if ((ci->defined[lref]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t len = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, lref), ">", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - return; - } - if (let_outlet(obj) != sc->rootlet) - { - char buf[128]; - int32_t len = (int32_t)catstrs_direct(buf, " (set! (outlet <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - let_to_port(sc, let_outlet(obj), ci->cycle_port, use_write, ci); - port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); - } - if (is_openlet(obj)) - port_write_string(port)(sc, "(openlet ", 9, port); - /* not immutable here because we'll need to set the let fields below, then declare it immutable */ - if (let_has_setter(obj)) /* both explicit setters and immutable slots */ - { - port_write_string(port)(sc, "(let (", 6, port); - slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, true); - port_write_string(port)(sc, ") ", 2, port); - immutable_slots_to_port(sc, obj, port, slot_setters_to_port(sc, obj, port, ci)); - port_write_string(port)(sc, " (curlet))", 10, port); - } - else - { - port_write_string(port)(sc, "(inlet", 6, port); - slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, false); - port_write_character(port)(sc, ')', port); - } - if (is_openlet(obj)) - port_write_character(port)(sc, ')', port); - } + (is_cyclic(obj)) && + ((lref = peek_shared_ref(ci, obj)) != 0)) + { + if (lref < 0) lref = -lref; + if ((ci->defined[lref]) || (port == ci->cycle_port)) + { + char buf[128]; + int32_t len = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, lref), ">", (const char *)NULL); + port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); + return; + } + if (let_outlet(obj) != sc->rootlet) + { + char buf[128]; + int32_t len = (int32_t)catstrs_direct(buf, " (set! (outlet <", pos_int_to_str_direct(sc, lref), ">) ", (const char *)NULL); + port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); + let_to_port(sc, let_outlet(obj), ci->cycle_port, use_write, ci); + port_write_string(ci->cycle_port)(sc, ") ", 2, ci->cycle_port); + } + if (is_openlet(obj)) + port_write_string(port)(sc, "(openlet ", 9, port); + /* not immutable here because we'll need to set the let fields below, then declare it immutable */ + if (let_has_setter(obj)) /* both explicit setters and immutable slots */ + { + port_write_string(port)(sc, "(let (", 6, port); + slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, true); + port_write_string(port)(sc, ") ", 2, port); + immutable_slots_to_port(sc, obj, port, slot_setters_to_port(sc, obj, port, ci)); + port_write_string(port)(sc, " (curlet))", 10, port); + } + else + { + port_write_string(port)(sc, "(inlet", 6, port); + slot_list_to_port_with_cycle(sc, obj, let_slots(obj), port, ci, false); + port_write_character(port)(sc, ')', port); + } + if (is_openlet(obj)) + port_write_character(port)(sc, ')', port); + } else - { - if (is_openlet(obj)) - port_write_string(port)(sc, "(openlet ", 9, port); - if (is_immutable_let(obj)) - port_write_string(port)(sc, "(immutable! ", 12, port); - - /* this ignores outlet -- but is that a problem? */ - /* (object->string (let ((i 0)) (set! (setter 'i) integer?) (curlet)) :readable) -> "(let ((i 0)) (set! (setter 'i) #_integer?) (curlet))" */ - if (let_has_setter(obj)) - { - port_write_string(port)(sc, "(let (", 6, port); - slot_list_to_port(sc, let_slots(obj), port, ci, true); - port_write_string(port)(sc, ") ", 2, port); - immutable_slots_to_port(sc, obj, port, slot_setters_to_port(sc, obj, port, ci)); - /* perhaps set outlet here?? */ - port_write_string(port)(sc, " (curlet))", 10, port); - } - else - { - if (let_outlet(obj) != sc->rootlet) - { - int32_t ref; - port_write_string(port)(sc, "(sublet ", 8, port); - if ((ci) && ((ref = peek_shared_ref(ci, let_outlet(obj))) < 0)) - { - char buf[128]; - int32_t len = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, len, port); - } - else - { - s7_pointer name = let_ref_p_pp(sc, obj, sc->class_name_symbol); - if (is_symbol(name)) - symbol_to_port(sc, name, port, P_DISPLAY, NULL); - else let_to_port(sc, let_outlet(obj), port, use_write, ci); - }} - else port_write_string(port)(sc, "(inlet", 6, port); - slot_list_to_port(sc, let_slots(obj), port, ci, false); - port_write_character(port)(sc, ')', port); - } - if (is_immutable_let(obj)) - port_write_character(port)(sc, ')', port); - if (is_openlet(obj)) - port_write_character(port)(sc, ')', port); - }} + { + if (is_openlet(obj)) + port_write_string(port)(sc, "(openlet ", 9, port); + if (is_immutable_let(obj)) + port_write_string(port)(sc, "(immutable! ", 12, port); + + /* this ignores outlet -- but is that a problem? */ + /* (object->string (let ((i 0)) (set! (setter 'i) integer?) (curlet)) :readable) -> "(let ((i 0)) (set! (setter 'i) #_integer?) (curlet))" */ + if (let_has_setter(obj)) + { + port_write_string(port)(sc, "(let (", 6, port); + slot_list_to_port(sc, let_slots(obj), port, ci, true); + port_write_string(port)(sc, ") ", 2, port); + immutable_slots_to_port(sc, obj, port, slot_setters_to_port(sc, obj, port, ci)); + /* perhaps set outlet here?? */ + port_write_string(port)(sc, " (curlet))", 10, port); + } + else + { + if (let_outlet(obj) != sc->rootlet) + { + int32_t ref; + port_write_string(port)(sc, "(sublet ", 8, port); + if ((ci) && ((ref = peek_shared_ref(ci, let_outlet(obj))) < 0)) + { + char buf[128]; + int32_t len = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", (const char *)NULL); + port_write_string(port)(sc, buf, len, port); + } + else + { + s7_pointer name = let_ref_p_pp(sc, obj, sc->class_name_symbol); + if (is_symbol(name)) + symbol_to_port(sc, name, port, P_DISPLAY, NULL); + else let_to_port(sc, let_outlet(obj), port, use_write, ci); + }} + else port_write_string(port)(sc, "(inlet", 6, port); + slot_list_to_port(sc, let_slots(obj), port, ci, false); + port_write_character(port)(sc, ')', port); + } + if (is_immutable_let(obj)) + port_write_character(port)(sc, ')', port); + if (is_openlet(obj)) + port_write_character(port)(sc, ')', port); + }} else /* not readable write */ { s7_pointer slot = let_slots(obj); port_write_string(port)(sc, "(inlet", 6, port); for (int32_t i = 1; tis_slot(slot); i++, slot = next_slot(slot)) - { - port_write_character(port)(sc, ' ', port); - slot_to_port(sc, slot, port, use_write, ci); - if ((tis_slot(next_slot(slot))) && (i == sc->print_length)) - { - port_write_string(port)(sc, " ...", 4, port); - break; - }} + { + port_write_character(port)(sc, ' ', port); + slot_to_port(sc, slot, port, use_write, ci); + if ((tis_slot(next_slot(slot))) && (i == sc->print_length)) + { + port_write_string(port)(sc, " ...", 4, port); + break; + }} port_write_character(port)(sc, ')', port); } } @@ -34428,19 +34428,19 @@ static void write_macro_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port) else if (is_pair(arglist)) { - port_write_string(port)(sc, " (", 2, port); - for (expr = arglist; is_pair(expr); expr = cdr(expr)) - { - object_to_port(sc, car(expr), port, P_WRITE, NULL); - if (is_pair(cdr(expr))) - port_write_character(port)(sc, ' ', port); - } - if (!is_null(expr)) - { - port_write_string(port)(sc, " . ", 3, port); - object_to_port(sc, expr, port, P_WRITE, NULL); - } - port_write_string(port)(sc, ") ", 2, port); + port_write_string(port)(sc, " (", 2, port); + for (expr = arglist; is_pair(expr); expr = cdr(expr)) + { + object_to_port(sc, car(expr), port, P_WRITE, NULL); + if (is_pair(cdr(expr))) + port_write_character(port)(sc, ' ', port); + } + if (!is_null(expr)) + { + port_write_string(port)(sc, " . ", 3, port); + object_to_port(sc, expr, port, P_WRITE, NULL); + } + port_write_string(port)(sc, ") ", 2, port); } else port_write_string(port)(sc, " () ", 4, port); @@ -34455,7 +34455,7 @@ static s7_pointer match_symbol(const s7_pointer symbol, s7_pointer e) for (s7_pointer le = e; le; le = let_outlet(le)) for (s7_pointer y = let_slots(le); tis_slot(y); y = next_slot(y)) if (slot_symbol(y) == symbol) - return(y); + return(y); return(NULL); } @@ -34471,8 +34471,8 @@ static bool arg_memq(const s7_pointer symbol, s7_pointer args) { for (s7_pointer x = args; is_pair(x); x = cdr(x)) if ((car(x) == symbol) || - ((is_pair(car(x))) && - (caar(x) == symbol))) + ((is_pair(car(x))) && + (caar(x) == symbol))) return(true); return(false); } @@ -34484,7 +34484,7 @@ static void collect_symbol(s7_scheme *sc, s7_pointer sym, s7_pointer e, s7_point { s7_pointer slot = match_symbol(sym, e); if (slot) - gc_protected_at(sc, gc_loc) = cons(sc, slot, gc_protected_at(sc, gc_loc)); + gc_protected_at(sc, gc_loc) = cons(sc, slot, gc_protected_at(sc, gc_loc)); } } @@ -34513,15 +34513,15 @@ static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer cur for (s7_pointer e = current_let; e; e = let_outlet(e)) { if ((is_funclet(e)) || (is_maclet(e))) - { - s7_pointer sym = funclet_function(e); - const s7_pointer f = s7_symbol_local_value(sc, sym, e); - if (f == closure) - return(sym); - } + { + s7_pointer sym = funclet_function(e); + const s7_pointer f = s7_symbol_local_value(sc, sym, e); + if (f == closure) + return(sym); + } for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y)) - if (slot_value(y) == closure) - return(slot_symbol(y)); + if (slot_value(y) == closure) + return(slot_symbol(y)); } if ((is_any_macro(closure)) && /* can't be a c_macro here */ (has_pair_macro(closure))) /* maybe macro never called, so no maclet exists */ @@ -34546,13 +34546,13 @@ static void write_closure_name(s7_scheme *sc, s7_pointer closure, s7_pointer por case T_MACRO: if (is_expansion(closure)) - port_write_string(port)(sc, "#<expansion ", 12, port); + port_write_string(port)(sc, "#<expansion ", 12, port); else port_write_string(port)(sc, "#<macro ", 8, port); break; case T_MACRO_STAR: if (is_expansion(closure)) - port_write_string(port)(sc, "#<expansion* ", 13, port); + port_write_string(port)(sc, "#<expansion* ", 13, port); else port_write_string(port)(sc, "#<macro* ", 9, port); break; } @@ -34563,45 +34563,45 @@ static void write_closure_name(s7_scheme *sc, s7_pointer closure, s7_pointer por { s7_pointer args = closure_args(closure); if (is_symbol(args)) - { - port_write_string(port)(sc, symbol_name(args), symbol_name_length(args), port); - port_write_character(port)(sc, '>', port); /* (lambda a a) -> #<lambda a> */ - } + { + port_write_string(port)(sc, symbol_name(args), symbol_name_length(args), port); + port_write_character(port)(sc, '>', port); /* (lambda a a) -> #<lambda a> */ + } else - { - port_write_character(port)(sc, '(', port); - x = car(args); - if (is_pair(x)) x = car(x); - port_write_string(port)(sc, symbol_name(x), symbol_name_length(x), port); - if (!is_null(cdr(args))) - { - s7_pointer y; - port_write_character(port)(sc, ' ', port); - if (is_pair(cdr(args))) - { - y = cadr(args); - if (is_pair(y)) - y = car(y); - else - if (y == sc->rest_keyword) - { - port_write_string(port)(sc, ":rest ", 6, port); - args = cdr(args); - y = cadr(args); - if (is_pair(y)) y = car(y); - }} - else - { - port_write_string(port)(sc, ". ", 2, port); - y = cdr(args); - } - port_write_string(port)(sc, symbol_name(y), symbol_name_length(y), port); - if ((is_pair(cdr(args))) && - (!is_null(cddr(args)))) - port_write_string(port)(sc, " ...", 4, port); - } - port_write_string(port)(sc, ")>", 2, port); - }} + { + port_write_character(port)(sc, '(', port); + x = car(args); + if (is_pair(x)) x = car(x); + port_write_string(port)(sc, symbol_name(x), symbol_name_length(x), port); + if (!is_null(cdr(args))) + { + s7_pointer y; + port_write_character(port)(sc, ' ', port); + if (is_pair(cdr(args))) + { + y = cadr(args); + if (is_pair(y)) + y = car(y); + else + if (y == sc->rest_keyword) + { + port_write_string(port)(sc, ":rest ", 6, port); + args = cdr(args); + y = cadr(args); + if (is_pair(y)) y = car(y); + }} + else + { + port_write_string(port)(sc, ". ", 2, port); + y = cdr(args); + } + port_write_string(port)(sc, symbol_name(y), symbol_name_length(y), port); + if ((is_pair(cdr(args))) && + (!is_null(cddr(args)))) + port_write_string(port)(sc, " ...", 4, port); + } + port_write_string(port)(sc, ")>", 2, port); + }} } static s7_pointer closure_name(s7_scheme *sc, s7_pointer closure) @@ -34627,7 +34627,7 @@ static s7_pointer pair_append(s7_scheme *sc, s7_pointer a, s7_pointer b) tp = list_1(sc, car(a)); set_stack_protected2(sc, tp); for (np = tp; is_pair(p); p = cdr(p), np = cdr(np)) - set_cdr(np, list_1(sc, car(p))); + set_cdr(np, list_1(sc, car(p))); set_cdr(np, b); } unstack_gc_protect(sc); @@ -34646,8 +34646,8 @@ static void write_closure_readably_1(s7_scheme *sc, s7_pointer obj, s7_pointer a (allows_other_keys(arglist))) { sc->temp9 = (is_null(cdr(arglist))) ? set_plist_2(sc, car(arglist), sc->allow_other_keys_keyword) : - ((is_null(cddr(arglist))) ? set_plist_3(sc, car(arglist), cadr(arglist), sc->allow_other_keys_keyword) : - pair_append(sc, arglist, list_1(sc, sc->allow_other_keys_keyword))); + ((is_null(cddr(arglist))) ? set_plist_3(sc, car(arglist), cadr(arglist), sc->allow_other_keys_keyword) : + pair_append(sc, arglist, list_1(sc, sc->allow_other_keys_keyword))); object_to_port(sc, sc->temp9, port, P_WRITE, NULL); sc->temp9 = sc->unused; } @@ -34674,22 +34674,22 @@ static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer por if (sc->safety > NO_SAFETY) { if (tree_is_cyclic(sc, body)) - { - port_write_string(port)(sc, "#<write_closure_readably: body is cyclic>", 41, port); /* not s7_error here! */ - return; - } + { + port_write_string(port)(sc, "#<write_closure_readably: body is cyclic>", 41, port); /* not s7_error here! */ + return; + } if ((!ci) && (is_pair(arglist))) - { /* (format #f "~W" (make-hook (let ((cp (list 1))) (set-cdr! cp cp) (list 'quote cp)))) */ - shared_info_t *new_ci = make_shared_info(sc); - clear_shared_info(new_ci); - if (collect_shared_info(sc, new_ci, arglist, false)) - { - free_shared_info(new_ci); - port_write_string(port)(sc, "#<write_closure_readably: arglist is cyclic>", 44, port); /* not s7_error here! */ - return; - } - free_shared_info(new_ci); - }} + { /* (format #f "~W" (make-hook (let ((cp (list 1))) (set-cdr! cp cp) (list 'quote cp)))) */ + shared_info_t *new_ci = make_shared_info(sc); + clear_shared_info(new_ci); + if (collect_shared_info(sc, new_ci, arglist, false)) + { + free_shared_info(new_ci); + port_write_string(port)(sc, "#<write_closure_readably: arglist is cyclic>", 44, port); /* not s7_error here! */ + return; + } + free_shared_info(new_ci); + }} if (is_symbol(arglist)) arglist = set_dlist_1(sc, arglist); pe = closure_let(obj); @@ -34701,11 +34701,11 @@ static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer por { setter = closure_setter(obj); if (has_closure_let(setter)) /* collect args etc so need the arglist */ - { - arglist = closure_args(setter); - if (is_symbol(arglist)) arglist = set_dlist_1(sc, arglist); - collect_locals(sc, closure_body(setter), pe, arglist, gc_loc); - }} + { + arglist = closure_args(setter); + if (is_symbol(arglist)) arglist = set_dlist_1(sc, arglist); + collect_locals(sc, closure_body(setter), pe, arglist, gc_loc); + }} local_slots = T_Lst(gc_protected_at(sc, gc_loc)); /* possibly a list of slots */ if (!is_null(local_slots)) @@ -34713,26 +34713,26 @@ static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer por /* if (let|letrec ((f (lambda () f))) (object->string f :readable)), local_slots: ('f f) */ /* but we can't handle it below because that leads to an infinite loop */ for (s7_pointer x = local_slots; is_pair(x); x = cdr(x)) - { - s7_pointer slot = car(x); - if ((!is_any_closure(slot_value(slot))) && /* mutually referencing closures? ./snd -l snd-test 24 hits this in the effects dialogs */ - ((!has_structure(slot_value(slot))) || /* see s7test example, vector has closure that refers to vector */ - (slot_symbol(slot) == sc->local_signature_symbol))) - { - if (!sent_let) - { - port_write_string(port)(sc, "(let (", 6, port); - sent_let = true; - } - port_write_character(port)(sc, '(', port); - port_write_string(port)(sc, symbol_name(slot_symbol(slot)), symbol_name_length(slot_symbol(slot)), port); - port_write_character(port)(sc, ' ', port); - /* (object->string (list (let ((local 1)) (lambda (x) (+ x local)))) :readable) */ - object_to_port(sc, slot_value(slot), port, P_READABLE, NULL); - if (is_null(cdr(x))) - port_write_character(port)(sc, ')', port); - else port_write_string(port)(sc, ") ", 2, port); - }} + { + s7_pointer slot = car(x); + if ((!is_any_closure(slot_value(slot))) && /* mutually referencing closures? ./snd -l snd-test 24 hits this in the effects dialogs */ + ((!has_structure(slot_value(slot))) || /* see s7test example, vector has closure that refers to vector */ + (slot_symbol(slot) == sc->local_signature_symbol))) + { + if (!sent_let) + { + port_write_string(port)(sc, "(let (", 6, port); + sent_let = true; + } + port_write_character(port)(sc, '(', port); + port_write_string(port)(sc, symbol_name(slot_symbol(slot)), symbol_name_length(slot_symbol(slot)), port); + port_write_character(port)(sc, ' ', port); + /* (object->string (list (let ((local 1)) (lambda (x) (+ x local)))) :readable) */ + object_to_port(sc, slot_value(slot), port, P_READABLE, NULL); + if (is_null(cdr(x))) + port_write_character(port)(sc, ')', port); + else port_write_string(port)(sc, ") ", 2, port); + }} if (sent_let) port_write_string(port)(sc, ") ", 2, port); } @@ -34742,17 +34742,17 @@ static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer por if (!is_null(local_slots)) for (s7_pointer x = local_slots; is_pair(x); x = cdr(x)) { - s7_pointer slot = car(x); - if ((is_any_closure(slot_value(slot))) && - (slot_value(slot) == obj)) - { - port_write_string(port)(sc, "(letrec ((", 10, port); /* (letrec ((f (lambda () f))) f) */ - sent_letrec = true; - port_write_string(port)(sc, symbol_name(slot_symbol(slot)), symbol_name_length(slot_symbol(slot)), port); - port_write_character(port)(sc, ' ', port); - obj_slot = slot; - break; - }} + s7_pointer slot = car(x); + if ((is_any_closure(slot_value(slot))) && + (slot_value(slot) == obj)) + { + port_write_string(port)(sc, "(letrec ((", 10, port); /* (letrec ((f (lambda () f))) f) */ + sent_letrec = true; + port_write_string(port)(sc, symbol_name(slot_symbol(slot)), symbol_name_length(slot_symbol(slot)), port); + port_write_character(port)(sc, ' ', port); + obj_slot = slot; + break; + }} if (setter) port_write_string(port)(sc, "(dilambda ", 10, port); @@ -34763,7 +34763,7 @@ static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer por { port_write_character(port)(sc, ' ', port); if (has_closure_let(setter)) - write_closure_readably_1(sc, setter, closure_args(setter), closure_body(setter), port); + write_closure_readably_1(sc, setter, closure_args(setter), closure_body(setter), port); else object_to_port_with_circle_check(sc, setter, port, P_READABLE, ci); port_write_character(port)(sc, ')', port); } @@ -34785,118 +34785,118 @@ static void iterator_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use if (use_write == P_READABLE) { if (iterator_is_at_end(obj)) - { - switch (type(iterator_sequence(obj))) - { - case T_NIL: - case T_PAIR: port_write_string(port)(sc, "(make-iterator ())", 18, port); break; - case T_STRING: port_write_string(port)(sc, "(make-iterator \"\")", 18, port); break; - case T_BYTE_VECTOR: port_write_string(port)(sc, "(make-iterator #u())", 20, port); break; - case T_VECTOR: port_write_string(port)(sc, "(make-iterator #())", 19, port); break; - case T_INT_VECTOR: port_write_string(port)(sc, "(make-iterator #i())", 20, port); break; - case T_FLOAT_VECTOR: port_write_string(port)(sc, "(make-iterator #r())", 20, port); break; - case T_LET: port_write_string(port)(sc, "(make-iterator (inlet))", 23, port); break; - - case T_HASH_TABLE: - if (is_weak_hash_table(iterator_sequence(obj))) - port_write_string(port)(sc, "(make-iterator (weak-hash-table))", 33, port); - else port_write_string(port)(sc, "(make-iterator (hash-table))", 28, port); - break; - - default: - port_write_string(port)(sc, "(make-iterator ())", 18, port); break; /* c-object?? function? */ - }} + { + switch (type(iterator_sequence(obj))) + { + case T_NIL: + case T_PAIR: port_write_string(port)(sc, "(make-iterator ())", 18, port); break; + case T_STRING: port_write_string(port)(sc, "(make-iterator \"\")", 18, port); break; + case T_BYTE_VECTOR: port_write_string(port)(sc, "(make-iterator #u())", 20, port); break; + case T_VECTOR: port_write_string(port)(sc, "(make-iterator #())", 19, port); break; + case T_INT_VECTOR: port_write_string(port)(sc, "(make-iterator #i())", 20, port); break; + case T_FLOAT_VECTOR: port_write_string(port)(sc, "(make-iterator #r())", 20, port); break; + case T_LET: port_write_string(port)(sc, "(make-iterator (inlet))", 23, port); break; + + case T_HASH_TABLE: + if (is_weak_hash_table(iterator_sequence(obj))) + port_write_string(port)(sc, "(make-iterator (weak-hash-table))", 33, port); + else port_write_string(port)(sc, "(make-iterator (hash-table))", 28, port); + break; + + default: + port_write_string(port)(sc, "(make-iterator ())", 18, port); break; /* c-object?? function? */ + }} else - { - s7_pointer seq = iterator_sequence(obj); - int32_t iter_ref; - if ((ci) && - (is_cyclic(obj)) && - ((iter_ref = peek_shared_ref(ci, obj)) != 0)) - { - /* basically the same as c_pointer_to_port */ - if (!is_cyclic_set(obj)) - { - int32_t nlen; - char buf[128]; - if (iter_ref < 0) iter_ref = -iter_ref; - - if (ci->init_port == sc->F) - { - ci->init_port = s7_open_output_string(sc); - ci->init_loc = gc_protect_1(sc, ci->init_port); - } - port_write_string(port)(sc, "#f", 2, port); - nlen = (int32_t)catstrs_direct(buf, " (set! <", pos_int_to_str_direct(sc, iter_ref), "> (make-iterator ", (const char *)NULL); - port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port); - - flip_ref(ci, seq); - object_to_port_with_circle_check(sc, seq, ci->init_port, use_write, ci); - flip_ref(ci, seq); - - port_write_string(ci->init_port)(sc, "))\n", 3, ci->init_port); - set_cyclic_set(obj); - return; - }} - - if (is_string(seq)) - { - s7_int len = string_length(seq) - iterator_position(obj); - if (len == 0) - port_write_string(port)(sc, "(make-iterator \"\")", 18, port); - else - { - const char *iter_str = (const char *)(string_value(seq) + iterator_position(obj)); - port_write_string(port)(sc, "(make-iterator \"", 16, port); - if (!string_needs_slashification((const uint8_t *)iter_str, len)) - port_write_string(port)(sc, iter_str, len, port); - else slashify_string_to_port(sc, port, iter_str, len, NOT_IN_QUOTES); - port_write_string(port)(sc, "\")", 2, port); - }} - else - { - if (is_pair(seq)) - { - port_write_string(port)(sc, "(make-iterator ", 15, port); - object_to_port_with_circle_check(sc, iterator_current(obj), port, use_write, ci); - port_write_character(port)(sc, ')', port); - } - else - { - if ((is_let(seq)) && (seq != sc->rootlet) && (seq != sc->s7_starlet)) - { - port_write_string(port)(sc, "(let ((iter (make-iterator ", 27, port); - object_to_port_with_circle_check(sc, seq, port, use_write, ci); - port_write_string(port)(sc, "))) ", 4, port); - for (s7_pointer slot = let_slots(seq); slot != iterator_current_slot(obj); slot = next_slot(slot)) - port_write_string(port)(sc, "(iter) ", 7, port); - port_write_string(port)(sc, "iter)", 5, port); - } - else - { - if (iterator_position(obj) > 0) - port_write_string(port)(sc, "(let ((iter (make-iterator ", 27, port); - else port_write_string(port)(sc, "(make-iterator ", 15, port); - object_to_port_with_circle_check(sc, seq, port, use_write, ci); - if (iterator_position(obj) > 0) - { - if (iterator_position(obj) == 1) - port_write_string(port)(sc, "))) (iter) iter)", 16, port); - else - { - char str[128]; - int32_t nlen = (int32_t)catstrs_direct(str, "))) (do ((i 0 (+ i 1))) ((= i ", - pos_int_to_str_direct(sc, iterator_position(obj)), - ") iter) (iter)))", (const char *)NULL); - port_write_string(port)(sc, str, nlen, port); - }} - else port_write_character(port)(sc, ')', port); - }}}}} + { + s7_pointer seq = iterator_sequence(obj); + int32_t iter_ref; + if ((ci) && + (is_cyclic(obj)) && + ((iter_ref = peek_shared_ref(ci, obj)) != 0)) + { + /* basically the same as c_pointer_to_port */ + if (!is_cyclic_set(obj)) + { + int32_t nlen; + char buf[128]; + if (iter_ref < 0) iter_ref = -iter_ref; + + if (ci->init_port == sc->F) + { + ci->init_port = s7_open_output_string(sc); + ci->init_loc = gc_protect_1(sc, ci->init_port); + } + port_write_string(port)(sc, "#f", 2, port); + nlen = (int32_t)catstrs_direct(buf, " (set! <", pos_int_to_str_direct(sc, iter_ref), "> (make-iterator ", (const char *)NULL); + port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port); + + flip_ref(ci, seq); + object_to_port_with_circle_check(sc, seq, ci->init_port, use_write, ci); + flip_ref(ci, seq); + + port_write_string(ci->init_port)(sc, "))\n", 3, ci->init_port); + set_cyclic_set(obj); + return; + }} + + if (is_string(seq)) + { + s7_int len = string_length(seq) - iterator_position(obj); + if (len == 0) + port_write_string(port)(sc, "(make-iterator \"\")", 18, port); + else + { + const char *iter_str = (const char *)(string_value(seq) + iterator_position(obj)); + port_write_string(port)(sc, "(make-iterator \"", 16, port); + if (!string_needs_slashification((const uint8_t *)iter_str, len)) + port_write_string(port)(sc, iter_str, len, port); + else slashify_string_to_port(sc, port, iter_str, len, NOT_IN_QUOTES); + port_write_string(port)(sc, "\")", 2, port); + }} + else + { + if (is_pair(seq)) + { + port_write_string(port)(sc, "(make-iterator ", 15, port); + object_to_port_with_circle_check(sc, iterator_current(obj), port, use_write, ci); + port_write_character(port)(sc, ')', port); + } + else + { + if ((is_let(seq)) && (seq != sc->rootlet) && (seq != sc->s7_starlet)) + { + port_write_string(port)(sc, "(let ((iter (make-iterator ", 27, port); + object_to_port_with_circle_check(sc, seq, port, use_write, ci); + port_write_string(port)(sc, "))) ", 4, port); + for (s7_pointer slot = let_slots(seq); slot != iterator_current_slot(obj); slot = next_slot(slot)) + port_write_string(port)(sc, "(iter) ", 7, port); + port_write_string(port)(sc, "iter)", 5, port); + } + else + { + if (iterator_position(obj) > 0) + port_write_string(port)(sc, "(let ((iter (make-iterator ", 27, port); + else port_write_string(port)(sc, "(make-iterator ", 15, port); + object_to_port_with_circle_check(sc, seq, port, use_write, ci); + if (iterator_position(obj) > 0) + { + if (iterator_position(obj) == 1) + port_write_string(port)(sc, "))) (iter) iter)", 16, port); + else + { + char str[128]; + int32_t nlen = (int32_t)catstrs_direct(str, "))) (do ((i 0 (+ i 1))) ((= i ", + pos_int_to_str_direct(sc, iterator_position(obj)), + ") iter) (iter)))", (const char *)NULL); + port_write_string(port)(sc, str, nlen, port); + }} + else port_write_character(port)(sc, ')', port); + }}}}} else { const char *str; if ((is_hash_table(iterator_sequence(obj))) && (is_weak_hash_table(iterator_sequence(obj)))) - str = "weak-hash-table"; + str = "weak-hash-table"; else str = type_name(sc, iterator_sequence(obj), NO_ARTICLE); port_write_string(port)(sc, "#<iterator: ", 12, port); port_write_string(port)(sc, str, safe_strlen(str), port); @@ -34915,58 +34915,58 @@ static void c_pointer_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, us { int32_t ref; if ((ci) && - (is_cyclic(obj)) && - ((ref = peek_shared_ref(ci, obj)) != 0)) - { - port_write_string(port)(sc, "#f", 2, port); - if (!is_cyclic_set(obj)) - { - if (ci->init_port == sc->F) - { - ci->init_port = s7_open_output_string(sc); - ci->init_loc = gc_protect_1(sc, ci->init_port); - } - nlen = snprintf(buf, CP_BUFSIZE, " (set! <%d> (c-pointer %" p64, -ref, (intptr_t)c_pointer(obj)); - port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port); - - if ((c_pointer_type(obj) != sc->F) || - (c_pointer_info(obj) != sc->F)) - { - flip_ref(ci, c_pointer_type(obj)); - - port_write_character(ci->init_port)(sc, ' ', ci->init_port); - object_to_port_with_circle_check(sc, c_pointer_type(obj), ci->init_port, use_write, ci); - - flip_ref(ci, c_pointer_type(obj)); - flip_ref(ci, c_pointer_info(obj)); - - port_write_character(ci->init_port)(sc, ' ', ci->init_port); - object_to_port_with_circle_check(sc, c_pointer_info(obj), ci->init_port, use_write, ci); - - flip_ref(ci, c_pointer_info(obj)); - } - port_write_string(ci->init_port)(sc, "))\n", 3, ci->init_port); - set_cyclic_set(obj); - }} + (is_cyclic(obj)) && + ((ref = peek_shared_ref(ci, obj)) != 0)) + { + port_write_string(port)(sc, "#f", 2, port); + if (!is_cyclic_set(obj)) + { + if (ci->init_port == sc->F) + { + ci->init_port = s7_open_output_string(sc); + ci->init_loc = gc_protect_1(sc, ci->init_port); + } + nlen = snprintf(buf, CP_BUFSIZE, " (set! <%d> (c-pointer %" p64, -ref, (intptr_t)c_pointer(obj)); + port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port); + + if ((c_pointer_type(obj) != sc->F) || + (c_pointer_info(obj) != sc->F)) + { + flip_ref(ci, c_pointer_type(obj)); + + port_write_character(ci->init_port)(sc, ' ', ci->init_port); + object_to_port_with_circle_check(sc, c_pointer_type(obj), ci->init_port, use_write, ci); + + flip_ref(ci, c_pointer_type(obj)); + flip_ref(ci, c_pointer_info(obj)); + + port_write_character(ci->init_port)(sc, ' ', ci->init_port); + object_to_port_with_circle_check(sc, c_pointer_info(obj), ci->init_port, use_write, ci); + + flip_ref(ci, c_pointer_info(obj)); + } + port_write_string(ci->init_port)(sc, "))\n", 3, ci->init_port); + set_cyclic_set(obj); + }} else - { - nlen = snprintf(buf, CP_BUFSIZE, "(c-pointer %" p64, (intptr_t)c_pointer(obj)); - port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port); - if ((c_pointer_type(obj) != sc->F) || - (c_pointer_info(obj) != sc->F)) - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, c_pointer_type(obj), port, use_write, ci); - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, c_pointer_info(obj), port, use_write, ci); - } - port_write_character(port)(sc, ')', port); - }} + { + nlen = snprintf(buf, CP_BUFSIZE, "(c-pointer %" p64, (intptr_t)c_pointer(obj)); + port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port); + if ((c_pointer_type(obj) != sc->F) || + (c_pointer_info(obj) != sc->F)) + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, c_pointer_type(obj), port, use_write, ci); + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, c_pointer_info(obj), port, use_write, ci); + } + port_write_character(port)(sc, ')', port); + }} else { if ((is_symbol(c_pointer_type(obj))) && - (symbol_name_length(c_pointer_type(obj)) < (CP_BUFSIZE / 2))) - nlen = snprintf(buf, CP_BUFSIZE, "#<%s %p>", symbol_name(c_pointer_type(obj)), c_pointer(obj)); + (symbol_name_length(c_pointer_type(obj)) < (CP_BUFSIZE / 2))) + nlen = snprintf(buf, CP_BUFSIZE, "#<%s %p>", symbol_name(c_pointer_type(obj)), c_pointer(obj)); else nlen = snprintf(buf, CP_BUFSIZE, "#<c_pointer %p>", c_pointer(obj)); port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port); } @@ -35034,14 +35034,14 @@ static void integer_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_ if (has_number_name(obj)) { if (is_string_port(port)) - { - if (port_position(port) + number_name_length(obj) < port_data_size(port)) - { - memcpy((void *)(port_data(port) + port_position(port)), (void *)number_name(obj), number_name_length(obj)); - port_position(port) += number_name_length(obj); - } - else string_write_string_resized(sc, number_name(obj), number_name_length(obj), port); - } + { + if (port_position(port) + number_name_length(obj) < port_data_size(port)) + { + memcpy((void *)(port_data(port) + port_position(port)), (void *)number_name(obj), number_name_length(obj)); + port_position(port) += number_name_length(obj); + } + else string_write_string_resized(sc, number_name(obj), number_name_length(obj), port); + } else port_write_string(port)(sc, number_name(obj), number_name_length(obj), port); } else @@ -35062,10 +35062,10 @@ static void number_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_w s7_int nlen = 0; char *str = number_to_string_base_10(sc, obj, 0, sc->float_format_precision, 'g', &nlen, use_write); /* was 14 */ if ((nlen < NUMBER_NAME_SIZE) && - (str[0] != 'n') && (str[0] != 'i') && - ((!(is_t_complex(obj))) || - ((!is_NaN(imag_part(obj))) && (!is_inf(imag_part(obj)))))) - set_number_name(obj, str, nlen); + (str[0] != 'n') && (str[0] != 'i') && + ((!(is_t_complex(obj))) || + ((!is_NaN(imag_part(obj))) && (!is_inf(imag_part(obj)))))) + set_number_name(obj, str, nlen); port_write_string(port)(sc, str, nlen, port); } } @@ -35106,12 +35106,12 @@ static void closure_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_ */ s7_pointer print_func = find_method(sc, closure_let(obj), sc->object_to_string_symbol); if (print_func != sc->undefined) - { - s7_pointer p = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); - if (string_length(p) > 0) - port_write_string(port)(sc, string_value(p), string_length(p), port); - return; - }} + { + s7_pointer p = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); + if (string_length(p) > 0) + port_write_string(port)(sc, string_value(p), string_length(p), port); + return; + }} if (use_write == P_READABLE) write_closure_readably(sc, obj, port, ci); else write_closure_name(sc, obj, port); @@ -35123,12 +35123,12 @@ static void macro_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_wr { s7_pointer print_func = find_method(sc, closure_let(obj), sc->object_to_string_symbol); if (print_func != sc->undefined) - { - s7_pointer p = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); - if (string_length(p) > 0) - port_write_string(port)(sc, string_value(p), string_length(p), port); - return; - }} + { + s7_pointer p = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); + if (string_length(p) > 0) + port_write_string(port)(sc, string_value(p), string_length(p), port); + return; + }} if (use_write == P_READABLE) write_macro_readably(sc, obj, port); else write_closure_name(sc, obj, port); @@ -35220,78 +35220,78 @@ static void c_object_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use else { if ((use_write == P_READABLE) && - (c_object_to_list(sc, obj)) && /* to_list and (implicit) set are needed to reconstruct a cyclic c-object, as well as the maker (via type name) */ - (c_object_set(sc, obj))) - { - int32_t href; - s7_pointer old_w = sc->w; - s7_pointer obj_list = ((*(c_object_to_list(sc, obj)))(sc, set_mlist_1(sc, obj))); - s7_pointer p = obj_list; - sc->w = obj_list; - if ((ci) && - (is_cyclic(obj)) && - ((href = peek_shared_ref(ci, obj)) != 0)) - { - if (href < 0) href = -href; - if ((ci->defined[href]) || (port == ci->cycle_port)) - { - char buf[128]; - int32_t nlen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); - port_write_string(port)(sc, buf, nlen, port); - return; - } - port_write_character(port)(sc, '(', port); - c_object_name_to_port(sc, obj, port); - for (int32_t i = 0; is_pair(p); i++, p = cdr(p)) - { - s7_pointer val = car(p); - if (has_structure(val)) - { - char buf[128]; - int32_t symref; - int32_t len = (int32_t)catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, href), "> ", pos_int_to_str_direct_1(sc, i), ") ", (const char *)NULL); - port_write_string(port)(sc, " #f", 3, port); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - - symref = peek_shared_ref(ci, val); - if (symref != 0) - { - if (symref < 0) symref = -symref; - len = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, symref), ">)\n", (const char *)NULL); - port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); - } - else - { - object_to_port_with_circle_check(sc, val, ci->cycle_port, P_READABLE, ci); - port_write_string(ci->cycle_port)(sc, ")\n", 2, ci->cycle_port); - }} - else - { - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, val, port, P_READABLE, ci); - }}} - else - { - port_write_character(port)(sc, '(', port); - c_object_name_to_port(sc, obj, port); - for (p = obj_list; is_pair(p); p = cdr(p)) - { - s7_pointer val = car(p); - port_write_character(port)(sc, ' ', port); - object_to_port_with_circle_check(sc, val, port, P_READABLE, ci); - }} - port_write_character(port)(sc, ')', port); - sc->w = old_w; - } + (c_object_to_list(sc, obj)) && /* to_list and (implicit) set are needed to reconstruct a cyclic c-object, as well as the maker (via type name) */ + (c_object_set(sc, obj))) + { + int32_t href; + s7_pointer old_w = sc->w; + s7_pointer obj_list = ((*(c_object_to_list(sc, obj)))(sc, set_mlist_1(sc, obj))); + s7_pointer p = obj_list; + sc->w = obj_list; + if ((ci) && + (is_cyclic(obj)) && + ((href = peek_shared_ref(ci, obj)) != 0)) + { + if (href < 0) href = -href; + if ((ci->defined[href]) || (port == ci->cycle_port)) + { + char buf[128]; + int32_t nlen = catstrs_direct(buf, "<", pos_int_to_str_direct(sc, href), ">", (const char *)NULL); + port_write_string(port)(sc, buf, nlen, port); + return; + } + port_write_character(port)(sc, '(', port); + c_object_name_to_port(sc, obj, port); + for (int32_t i = 0; is_pair(p); i++, p = cdr(p)) + { + s7_pointer val = car(p); + if (has_structure(val)) + { + char buf[128]; + int32_t symref; + int32_t len = (int32_t)catstrs_direct(buf, " (set! (<", pos_int_to_str_direct(sc, href), "> ", pos_int_to_str_direct_1(sc, i), ") ", (const char *)NULL); + port_write_string(port)(sc, " #f", 3, port); + port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); + + symref = peek_shared_ref(ci, val); + if (symref != 0) + { + if (symref < 0) symref = -symref; + len = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, symref), ">)\n", (const char *)NULL); + port_write_string(ci->cycle_port)(sc, buf, len, ci->cycle_port); + } + else + { + object_to_port_with_circle_check(sc, val, ci->cycle_port, P_READABLE, ci); + port_write_string(ci->cycle_port)(sc, ")\n", 2, ci->cycle_port); + }} + else + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, val, port, P_READABLE, ci); + }}} + else + { + port_write_character(port)(sc, '(', port); + c_object_name_to_port(sc, obj, port); + for (p = obj_list; is_pair(p); p = cdr(p)) + { + s7_pointer val = car(p); + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, val, port, P_READABLE, ci); + }} + port_write_character(port)(sc, ')', port); + sc->w = old_w; + } else - { - char buf[128]; - int32_t nlen; - port_write_string(port)(sc, "#<", 2, port); - c_object_name_to_port(sc, obj, port); - nlen = snprintf(buf, 128, " %p>", obj); - port_write_string(port)(sc, buf, clamp_length(nlen, 128), port); - }} + { + char buf[128]; + int32_t nlen; + port_write_string(port)(sc, "#<", 2, port); + c_object_name_to_port(sc, obj, port); + nlen = snprintf(buf, 128, " %p>", obj); + port_write_string(port)(sc, buf, clamp_length(nlen, 128), port); + }} } static void stack_to_port(s7_scheme *sc, const s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) @@ -35366,39 +35366,39 @@ static void object_to_port_with_circle_check_1(s7_scheme *sc, s7_pointer vr, s7_ char buf[32]; int32_t nlen; if (ref > 0) - { - if (use_write == P_READABLE) - { - if (ci->defined[ref]) - { - flip_ref(ci, vr); - nlen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, ref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, nlen, port); - return; - } - object_to_port(sc, vr, port, P_READABLE, ci); - } - else - { /* "normal" printout involving #n= and #n# */ - s7_int len = 0; - char *p = pos_int_to_str(sc, (s7_int)ref, &len, '='); - *--p = '#'; - port_write_string(port)(sc, p, len, port); - object_to_port(sc, vr, port, not_p_display(use_write), ci); - }} + { + if (use_write == P_READABLE) + { + if (ci->defined[ref]) + { + flip_ref(ci, vr); + nlen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, ref), ">", (const char *)NULL); + port_write_string(port)(sc, buf, nlen, port); + return; + } + object_to_port(sc, vr, port, P_READABLE, ci); + } + else + { /* "normal" printout involving #n= and #n# */ + s7_int len = 0; + char *p = pos_int_to_str(sc, (s7_int)ref, &len, '='); + *--p = '#'; + port_write_string(port)(sc, p, len, port); + object_to_port(sc, vr, port, not_p_display(use_write), ci); + }} else - if (use_write == P_READABLE) - { - nlen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", (const char *)NULL); - port_write_string(port)(sc, buf, nlen, port); - } - else - { - s7_int len = 0; - char *p = pos_int_to_str(sc, (s7_int)(-ref), &len, '#'); - *--p = '#'; - port_write_string(port)(sc, p, len, port); - }} + if (use_write == P_READABLE) + { + nlen = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, -ref), ">", (const char *)NULL); + port_write_string(port)(sc, buf, nlen, port); + } + else + { + s7_int len = 0; + char *p = pos_int_to_str(sc, (s7_int)(-ref), &len, '#'); + *--p = '#'; + port_write_string(port)(sc, p, len, port); + }} } static s7_pointer cyclic_out(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci) @@ -35465,13 +35465,13 @@ static void object_out_1(s7_scheme *sc, s7_pointer obj, s7_pointer strport, use_ { shared_info_t *ci = load_shared_info(sc, T_Pos(obj), choice != P_READABLE, sc->circle_info); if (ci) - { - sc->object_out_locked = true; - if (choice == P_READABLE) - cyclic_out(sc, obj, strport, ci); - else object_to_port_with_circle_check(sc, T_Pos(obj), strport, choice, ci); - sc->object_out_locked = false; - } + { + sc->object_out_locked = true; + if (choice == P_READABLE) + cyclic_out(sc, obj, strport, ci); + else object_to_port_with_circle_check(sc, T_Pos(obj), strport, choice, ci); + sc->object_out_locked = false; + } else object_to_port(sc, obj, strport, choice, NULL); } } @@ -35594,24 +35594,24 @@ static s7_pointer g_object_to_string(s7_scheme *sc, s7_pointer args) s7_pointer arg = cadr(args); if (arg == sc->F) choice = P_DISPLAY; else {if (arg == sc->T) choice = P_WRITE; - else {if (arg == sc->readable_keyword) choice = P_READABLE; - else {if (arg == sc->display_keyword) choice = P_DISPLAY; - else {if (arg == sc->write_keyword) choice = P_WRITE; - else wrong_type_error_nr(sc, sc->object_to_string_symbol, 2, arg, wrap_string(sc, "a boolean or :readable", 22));}}}} + else {if (arg == sc->readable_keyword) choice = P_READABLE; + else {if (arg == sc->display_keyword) choice = P_DISPLAY; + else {if (arg == sc->write_keyword) choice = P_WRITE; + else wrong_type_error_nr(sc, sc->object_to_string_symbol, 2, arg, wrap_string(sc, "a boolean or :readable", 22));}}}} if (is_not_null(cddr(args))) - { - arg = caddr(args); - if (!s7_is_integer(arg)) - { - if (choice == P_READABLE) /* (object->string #r(1 2 3) :readable "hi") */ - wrong_type_error_nr(sc, sc->object_to_string_symbol, 3, arg, sc->type_names[T_INTEGER]); - return(method_or_bust(sc, arg, sc->object_to_string_symbol, args, sc->type_names[T_INTEGER], 3)); - } - if (s7_integer_clamped_if_gmp(sc, arg) < 0) - out_of_range_error_nr(sc, sc->object_to_string_symbol, int_three, arg, a_non_negative_integer_string); - pending_max = s7_integer_clamped_if_gmp(sc, arg); - }} + { + arg = caddr(args); + if (!s7_is_integer(arg)) + { + if (choice == P_READABLE) /* (object->string #r(1 2 3) :readable "hi") */ + wrong_type_error_nr(sc, sc->object_to_string_symbol, 3, arg, sc->type_names[T_INTEGER]); + return(method_or_bust(sc, arg, sc->object_to_string_symbol, args, sc->type_names[T_INTEGER], 3)); + } + if (s7_integer_clamped_if_gmp(sc, arg) < 0) + out_of_range_error_nr(sc, sc->object_to_string_symbol, int_three, arg, a_non_negative_integer_string); + pending_max = s7_integer_clamped_if_gmp(sc, arg); + }} else choice = P_WRITE; /* can't use s7_object_to_string here anymore because it assumes use_write arg is a boolean */ @@ -35629,20 +35629,20 @@ static s7_pointer g_object_to_string(s7_scheme *sc, s7_pointer args) (out_len > pending_max)) { if (choice == P_READABLE) /* (object->string #r(1 2 3) :readable 4) */ - { - close_format_port(sc, strport); - sc->has_openlets = old_openlets; - out_of_range_error_nr(sc, sc->object_to_string_symbol, int_three, wrap_integer(sc, out_len), wrap_string(sc, "the readable string is too long", 31)); - } + { + close_format_port(sc, strport); + sc->has_openlets = old_openlets; + out_of_range_error_nr(sc, sc->object_to_string_symbol, int_three, wrap_integer(sc, out_len), wrap_string(sc, "the readable string is too long", 31)); + } out_len = pending_max; if (out_len < 3) - { - close_format_port(sc, strport); - sc->has_openlets = old_openlets; - return(make_string_with_length(sc, "...", 3)); - } + { + close_format_port(sc, strport); + sc->has_openlets = old_openlets; + return(make_string_with_length(sc, "...", 3)); + } for (s7_int i = out_len - 3; i < out_len; i++) - port_data(strport)[i] = (uint8_t)'.'; + port_data(strport)[i] = (uint8_t)'.'; } if (out_len >= port_data_size(strport)) /* this can happen (but only == I think) */ res = block_to_string(sc, reallocate(sc, port_data_block(strport), out_len + 1), out_len); @@ -35709,7 +35709,7 @@ s7_pointer s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port) if (port != sc->F) { if (port_is_closed(port)) - wrong_type_error_nr(sc, sc->write_symbol, 2, port, an_open_output_port_string); + wrong_type_error_nr(sc, sc->write_symbol, 2, port, an_open_output_port_string); object_out(sc, obj, port, P_WRITE); } return(obj); @@ -35748,7 +35748,7 @@ s7_pointer s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port) if (port != sc->F) { if (port_is_closed(port)) - wrong_type_error_nr(sc, sc->display_symbol, 2, port, an_open_output_port_string); + wrong_type_error_nr(sc, sc->display_symbol, 2, port, an_open_output_port_string); object_out(sc, obj, port, P_DISPLAY); } return(obj); @@ -35848,12 +35848,12 @@ calls thunk, then returns the collected output" if (!is_thunk(sc, proc)) { if (is_any_procedure(proc)) /* i.e. c_function, lambda, macro, etc */ - { - s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but with-output-to-string's first argument should be a thunk", 87), - proc, req_args, req_args)); - } + { + s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but with-output-to-string's first argument should be a thunk", 87), + proc, req_args, req_args)); + } else return(method_or_bust(sc, proc, sc->with_output_to_string_symbol, args, a_thunk_string, 1)); } if ((is_continuation(proc)) || (is_goto(proc))) @@ -35880,12 +35880,12 @@ static s7_pointer g_with_output_to_file(s7_scheme *sc, s7_pointer args) if (!is_thunk(sc, proc)) { if (is_any_procedure(proc)) /* i.e. c_function, lambda, macro, etc */ - { - s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but with-output-to-file's second argument should be a thunk", 86), - proc, req_args, req_args)); - } + { + s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but with-output-to-file's second argument should be a thunk", 86), + proc, req_args, req_args)); + } else return(method_or_bust(sc, proc, sc->with_output_to_file_symbol, args, a_thunk_string, 2)); } if ((is_continuation(proc)) || (is_goto(proc))) @@ -35911,7 +35911,7 @@ static noreturn void format_error_nr(s7_scheme *sc, const char *ur_msg, s7_int m if (fdat->loc == 0) { if (is_pair(args)) - x = set_elist_4(sc, format_string_1, ctrl_str, args, msg); /* "~S ~{~S~^ ~}: ~A" */ + x = set_elist_4(sc, format_string_1, ctrl_str, args, msg); /* "~S ~{~S~^ ~}: ~A" */ else x = set_elist_3(sc, format_string_2, ctrl_str, msg); /* "~S: ~A" */ } else @@ -35950,17 +35950,17 @@ static void format_append_chars(s7_scheme *sc, format_data_t *fdat, char pad, s7 if (is_string_port(port)) { if ((port_position(port) + chrs) < port_data_size(port)) - { - local_memset((char *)port_data(port) + port_position(port), pad, chrs); - port_position(port) += chrs; - } + { + local_memset((char *)port_data(port) + port_position(port), pad, chrs); + port_position(port) += chrs; + } else - { - s7_int new_len = port_position(port) + chrs; - resize_port_data(sc, port, new_len * 2); - local_memset((char *)port_data(port) + port_position(port), pad, chrs); - port_position(port) = new_len; - } + { + s7_int new_len = port_position(port) + chrs; + resize_port_data(sc, port, new_len * 2); + local_memset((char *)port_data(port) + port_position(port), pad, chrs); + port_position(port) = new_len; + } fdat->loc += chrs; sc->format_column += chrs; } @@ -35983,15 +35983,15 @@ static s7_int format_read_integer(s7_int *cur_i, s7_int str_len, const char *str { int32_t dig = digits[(uint8_t)str[i]]; if (dig < 10) - { + { #if HAVE_OVERFLOW_CHECKS - if ((multiply_overflow(lval, 10, &lval)) || - (add_overflow(lval, dig, &lval))) - break; + if ((multiply_overflow(lval, 10, &lval)) || + (add_overflow(lval, dig, &lval))) + break; #else - lval = dig + (lval * 10); + lval = dig + (lval * 10); #endif - } + } else break; } *cur_i = i; @@ -36009,14 +36009,14 @@ static void format_number(s7_scheme *sc, format_data_t *fdat, int32_t radix, s7_ if (precision < 0) { if ((float_choice == 'e') || - (float_choice == 'f') || - (float_choice == 'g')) - precision = 6; + (float_choice == 'f') || + (float_choice == 'g')) + precision = 6; else - { - int32_t typ = type(car(fdat->args)); /* in the "int" cases, precision depends on the arg type */ - precision = ((typ == T_INTEGER) || (typ == T_RATIO)) ? 0 : 6; - }} + { + int32_t typ = type(car(fdat->args)); /* in the "int" cases, precision depends on the arg type */ + precision = ((typ == T_INTEGER) || (typ == T_RATIO)) ? 0 : 6; + }} /* should (format #f "~F" 1/3) return "1/3"?? in CL it's "0.33333334" */ if (pad != ' ') @@ -36024,13 +36024,13 @@ static void format_number(s7_scheme *sc, format_data_t *fdat, int32_t radix, s7_ char *padtmp; #if (!WITH_GMP) if (radix == 10) - tmp = number_to_string_base_10(sc, car(fdat->args), width, precision, float_choice, &nlen, P_WRITE); + tmp = number_to_string_base_10(sc, car(fdat->args), width, precision, float_choice, &nlen, P_WRITE); else #endif - { - b = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen); - tmp = (char *)block_data(b); - } + { + b = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen); + tmp = (char *)block_data(b); + } padtmp = tmp; while (*padtmp == ' ') (*(padtmp++)) = pad; format_append_string(sc, fdat, tmp, nlen, port); @@ -36040,13 +36040,13 @@ static void format_number(s7_scheme *sc, format_data_t *fdat, int32_t radix, s7_ { #if (!WITH_GMP) if (radix == 10) - tmp = number_to_string_base_10(sc, car(fdat->args), width, precision, float_choice, &nlen, P_WRITE); + tmp = number_to_string_base_10(sc, car(fdat->args), width, precision, float_choice, &nlen, P_WRITE); else #endif - { - b = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen); - tmp = (char *)block_data(b); - } + { + b = number_to_string_with_radix(sc, car(fdat->args), radix, width, precision, float_choice, &nlen); + tmp = (char *)block_data(b); + } format_append_string(sc, fdat, tmp, nlen, port); if ((WITH_GMP) || (radix != 10)) liberate(sc, b); } @@ -36069,17 +36069,17 @@ static void format_ordinal_number(s7_scheme *sc, format_data_t *fdat, s7_pointer format_append_string(sc, fdat, tmp, nlen, port); num = num % 100; if ((num >= 11) && (num <= 13)) - format_append_string(sc, fdat, "th", 2, port); + format_append_string(sc, fdat, "th", 2, port); else - { - num = num % 10; - if (num == 1) format_append_string(sc, fdat, "st", 2, port); - else - if (num == 2) format_append_string(sc, fdat, "nd", 2, port); - else - if (num == 3) format_append_string(sc, fdat, "rd", 2, port); - else format_append_string(sc, fdat, "th", 2, port); - }} + { + num = num % 10; + if (num == 1) format_append_string(sc, fdat, "st", 2, port); + else + if (num == 2) format_append_string(sc, fdat, "nd", 2, port); + else + if (num == 3) format_append_string(sc, fdat, "rd", 2, port); + else format_append_string(sc, fdat, "th", 2, port); + }} fdat->args = cdr(fdat->args); fdat->ctr++; } @@ -36090,15 +36090,15 @@ static s7_int format_nesting(const char *str, char opener, char closer, s7_int s for (s7_int k = start + 2; k < end; k++) if (str[k] == '~') { - if (str[k + 1] == closer) - { - nesting--; - if (nesting == 0) - return(k - start - 1); - } - else - if (str[k + 1] == opener) - nesting++; + if (str[k + 1] == closer) + { + nesting--; + if (nesting == 0) + return(k - start - 1); + } + else + if (str[k + 1] == opener) + nesting++; } return(-1); } @@ -36151,13 +36151,13 @@ static s7_int format_numeric_arg(s7_scheme *sc, const char *str, s7_int str_len, if (width < 0) { if (str[old_i - 1] != ',') /* need branches here, not if-expr because format_error creates the permanent string */ - format_error_nr(sc, "width is negative?", 18, str, fdat->args, fdat); + format_error_nr(sc, "width is negative?", 18, str, fdat->args, fdat); format_error_nr(sc, "precision is negative?", 22, str, fdat->args, fdat); } if (width > sc->max_format_length) { if (str[old_i - 1] != ',') - format_error_nr(sc, "width is too big", 16, str, fdat->args, fdat); + format_error_nr(sc, "width is too big", 16, str, fdat->args, fdat); format_error_nr(sc, "precision is too big", 20, str, fdat->args, fdat); } return(width); @@ -36186,9 +36186,9 @@ static format_data_t *open_format_data(s7_scheme *sc) else { if (fdat->port) - close_format_port(sc, fdat->port); + close_format_port(sc, fdat->port); if (fdat->strport) - close_format_port(sc, fdat->strport); + close_format_port(sc, fdat->strport); } fdat->port = NULL; fdat->strport = NULL; @@ -36212,7 +36212,7 @@ static bool is_one_or_big_one(s7_scheme *sc, s7_pointer p) static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj); static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *str, s7_pointer args, - s7_pointer *next_arg, bool with_result, bool columnized, s7_int len, s7_pointer orig_str) + s7_pointer *next_arg, bool with_result, bool columnized, s7_int len, s7_pointer orig_str) { s7_int i, str_len; format_data_t *fdat; @@ -36222,12 +36222,12 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s { str_len = safe_strlen(str); if (str_len == 0) - { - if (is_not_null(args)) - error_nr(sc, sc->format_error_symbol, - set_elist_2(sc, wrap_string(sc, "format control string is null, but there are arguments: ~S", 58), args)); - return(nil_string); - }} + { + if (is_not_null(args)) + error_nr(sc, sc->format_error_symbol, + set_elist_2(sc, wrap_string(sc, "format control string is null, but there are arguments: ~S", 58), args)); + return(nil_string); + }} else str_len = len; fdat = open_format_data(sc); @@ -36245,458 +36245,458 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s for (i = 0; i < str_len - 1; i++) { if ((uint8_t)(str[i]) == (uint8_t)'~') - { - use_write_t use_write; - switch (str[i + 1]) - { - case '%': /* -------- newline -------- */ - /* sbcl apparently accepts numeric args here (including 0) */ - if ((port_data(port)) && - (port_position(port) < port_data_size(port))) - { - port_data(port)[port_position(port)++] = '\n'; - sc->format_column = 0; - } - else format_append_newline(sc, port); - i++; - break; - - case '&': /* -------- conditional newline -------- */ - /* this only works if all output goes through format -- display/write for example do not update format_column */ - if (sc->format_column > 0) - format_append_newline(sc, port); - i++; - break; - - case '~': /* -------- tilde -------- */ - format_append_char(sc, '~', port); - i++; - break; - - case '\n': /* -------- trim white-space -------- so (format #f "hiho~\n") -> "hiho"! */ - for (i = i + 2; i <str_len - 1; i++) - if (!(white_space[(uint8_t)(str[i])])) - { - i--; - break; - } - break; - - case '*': /* -------- ignore arg -------- */ - i++; - if (is_null(fdat->args)) /* (format #f "~*~A") */ - format_error_nr(sc, "can't skip argument!", 20, str, args, fdat); - fdat->args = cdr(fdat->args); - break; - - case '|': /* -------- exit if args nil or ctr > (*s7* 'print-length) -------- */ - if ((is_pair(fdat->args)) && - (fdat->ctr >= sc->print_length)) - { - format_append_string(sc, fdat, " ...", 4, port); - fdat->args = sc->nil; - } - /* fall through */ - - case '^': /* -------- exit -------- */ - if (is_null(fdat->args)) - { - i = str_len; - goto ALL_DONE; - } - i++; - break; - - case '@': /* -------- plural, 'y' or 'ies' -------- */ - i += 2; - if ((str[i] != 'P') && (str[i] != 'p')) - format_error_nr(sc, "unknown '@' directive", 21, str, args, fdat); - if (!is_pair(fdat->args)) - format_error_nr(sc, "'@' directive argument missing", 30, str, args, fdat); - if (!is_real(car(fdat->args))) /* CL accepts non numbers here */ - format_error_nr(sc, "'@P' directive argument is not a real number", 44, str, args, fdat); - - if (!is_one_or_big_one(sc, car(fdat->args))) - format_append_string(sc, fdat, "ies", 3, port); - else format_append_char(sc, 'y', port); - - fdat->args = cdr(fdat->args); - break; - - case 'P': case 'p': /* -------- plural in 's' -------- */ - if (!is_pair(fdat->args)) - format_error_nr(sc, "'P' directive argument missing", 30, str, args, fdat); - if (!is_real(car(fdat->args))) - format_error_nr(sc, "'P' directive argument is not a real number", 43, str, args, fdat); - if (!is_one_or_big_one(sc, car(fdat->args))) - format_append_char(sc, 's', port); - i++; - fdat->args = cdr(fdat->args); - break; - - case '{': /* -------- iteration -------- */ - { - s7_int curly_len; - - if (is_null(fdat->args)) - format_error_nr(sc, "missing argument", 16, str, args, fdat); - - if ((is_pair(car(fdat->args))) && /* any sequence is possible here */ - (s7_list_length(sc, car(fdat->args)) < 0)) /* (format #f "~{~a~e~}" (cons 1 2)) */ - format_error_nr(sc, "~{ argument is a dotted list", 28, str, args, fdat); - - curly_len = format_nesting(str, '{', '}', i, str_len - 1); - - if (curly_len == -1) - format_error_nr(sc, "'{' directive, but no matching '}'", 34, str, args, fdat); - if (curly_len == 1) - format_error_nr(sc, "~{~}' doesn't consume any arguments!", 36, str, args, fdat); - - /* what about cons's here? I can't see any way to specify the car or cdr of a cons within the format string */ - if (is_not_null(car(fdat->args))) /* (format #f "~{~A ~}" ()) -> "" */ - { - s7_pointer curly_arg = object_to_list(sc, car(fdat->args)); /* if a pair (or non-sequence), this simply returns the original */ - /* perhaps use an iterator here -- rootlet->list is expensive! */ - if (is_pair(curly_arg)) /* (format #f "~{~A ~}" #()) -> "" */ - { - char *curly_str = NULL; /* this is the local (nested) format control string */ - s7_pointer cycle_arg; - - fdat->curly_arg = curly_arg; - if (curly_len > fdat->curly_len) - { - if (fdat->curly_str) free(fdat->curly_str); - fdat->curly_len = curly_len; - fdat->curly_str = (char *)Malloc(curly_len); - } - curly_str = fdat->curly_str; - memcpy((void *)curly_str, (const void *)(str + i + 2), curly_len - 1); - curly_str[curly_len - 1] = '\0'; - - if ((sc->format_depth < sc->num_fdats - 1) && - (sc->fdats[sc->format_depth + 1])) - sc->fdats[sc->format_depth + 1]->ctr = 0; - - /* it's not easy to use an iterator here instead of a list (so object->list isn't needed above), - * because the curly brackets may enclose multiple arguments -- we would need to use - * iterators throughout this function. - */ - cycle_arg = curly_arg; - while (is_pair(curly_arg)) - { - s7_pointer new_arg = sc->nil; - format_to_port_1(sc, port, curly_str, curly_arg, &new_arg, false, columnized, curly_len - 1, NULL); - if (curly_arg == new_arg) - { - if (cdr(curly_arg) == curly_arg) break; - fdat->curly_arg = sc->nil; - format_error_nr(sc, "'{...}' doesn't consume any arguments!", 38, str, args, fdat); - } - curly_arg = new_arg; - if ((!is_pair(curly_arg)) || (curly_arg == cycle_arg)) - break; - cycle_arg = cdr(cycle_arg); - format_to_port_1(sc, port, curly_str, curly_arg, &new_arg, false, columnized, curly_len - 1, NULL); - curly_arg = new_arg; - } - fdat->curly_arg = sc->nil; - } - else - if (!is_null(curly_arg)) - format_error_nr(sc, "'{' directive argument should be a list or something we can turn into a list", 76, str, args, fdat); - } - i += (curly_len + 2); /* jump past the ending '}' too */ - fdat->args = cdr(fdat->args); - fdat->ctr++; - } - break; - - case '}': - format_error_nr(sc, "unmatched '}'", 13, str, args, fdat); - - case '$': - use_write = P_CODE; /* affects when symbols but not keywords are quoted (symbol_to_port and hash_table_to_port) */ - goto OBJSTR; - - case 'W': case 'w': - use_write = P_READABLE; - goto OBJSTR; - - case 'S': case 's': - use_write = P_WRITE; - goto OBJSTR; - - case 'A': case 'a': - use_write = P_DISPLAY; - OBJSTR: /* object->string */ - { - s7_pointer obj, strport; - if (is_null(fdat->args)) - format_error_nr(sc, "missing argument", 16, str, args, fdat); - i++; - obj = car(fdat->args); - if ((use_write == P_READABLE) || - (!has_active_methods(sc, obj)) || - (!format_method(sc, (const char *)(str + i), fdat, port))) - { - bool old_openlets = sc->has_openlets; - /* for the column check, we need to know the length of the object->string output */ - if (columnized) - { - strport = open_format_port(sc); - fdat->strport = strport; - } - else strport = port; - if (use_write == P_READABLE) - sc->has_openlets = false; - object_out(sc, obj, strport, use_write); - if (use_write == P_READABLE) - sc->has_openlets = old_openlets; - if (columnized) - { - if (port_position(strport) >= port_data_size(strport)) - resize_port_data(sc, strport, port_data_size(strport) * 2); - port_data(strport)[port_position(strport)] = '\0'; - if (port_position(strport) > 0) - format_append_string(sc, fdat, (const char *)port_data(strport), port_position(strport), port); - close_format_port(sc, strport); - fdat->strport = NULL; - } - fdat->args = cdr(fdat->args); - fdat->ctr++; - }} - break; - - /* -------- numeric args -------- */ - case ':': - i += 2; - if ((str[i] != 'D') && (str[i] != 'd')) - format_error_nr(sc, "unknown ':' directive", 21, str, args, fdat); - if (!is_pair(fdat->args)) - format_error_nr(sc, "':D' directive argument missing", 31, str, args, fdat); - if (!s7_is_integer(car(fdat->args))) - format_error_nr(sc, "':D' directive argument is not an integer", 41, str, args, fdat); - if (s7_integer_clamped_if_gmp(sc, car(fdat->args)) < 0) - format_error_nr(sc, "':D' directive argument can't be negative", 41, str, args, fdat); - format_ordinal_number(sc, fdat, port); - break; - - case '0': case '1': case '2': case '3': case '4': case '5': - case '6': case '7': case '8': case '9': case ',': - case 'N': case 'n': - - case 'B': case 'b': - case 'D': case 'd': - case 'E': case 'e': - case 'F': case 'f': - case 'G': case 'g': - case 'O': case 'o': - case 'X': case 'x': - - case 'T': case 't': - case 'C': case 'c': - { - s7_int width = -1, precision = -1; - char pad = ' '; - i++; /* str[i] == '~' */ - - if (isdigit((int32_t)(str[i]))) - width = format_numeric_arg(sc, str, str_len, fdat, &i); - else - if ((str[i] == 'N') || (str[i] == 'n')) - { - i++; - width = format_n_arg(sc, str, fdat, args); - } - if (str[i] == ',') - { - i++; /* is (format #f "~12,12D" 1) an error? The precision (or is it the width?) has no use here */ - if (isdigit((int32_t)(str[i]))) - precision = format_numeric_arg(sc, str, str_len, fdat, &i); - else - if ((str[i] == 'N') || (str[i] == 'n')) - { - i++; - precision = format_n_arg(sc, str, fdat, args); - } - else - if (str[i] == '\'') /* (format #f "~12,'xD" 1) -> "xxxxxxxxxxx1" */ - { - pad = str[i + 1]; - i += 2; - if (i >= str_len) /* (format #f "~,'") */ - format_error_nr(sc, "incomplete numeric argument", 27, str, args, fdat); - }} /* is (let ((str "~12,'xD")) (set! (str 5) #\null) (format #f str 1)) an error? */ - - switch (str[i]) - { - /* -------- pad to column -------- - * are columns numbered from 1 or 0? there seems to be disagreement about this directive, does "space over to" mean including? - */ - case 'T': case 't': - if (width == -1) width = 0; - if (precision == -1) precision = 0; - if ((width > 0) || (precision > 0)) /* (format #f "a~8Tb") */ - { - /* (length (substring (format #f "~%~10T.") 1)) == (length (format #f "~10T.")) - * (length (substring (format #f "~%-~10T.~%") 1)) == (length (format #f "-~10T.~%")) - */ - if (precision > 0) - { - int32_t mult = (int32_t)(ceil((s7_double)(sc->format_column + 1 - width) / (s7_double)precision)); /* CLtL2 ("least positive int") */ - if (mult < 1) mult = 1; - width += (precision * mult); - } - width -= (sc->format_column + 1); - if (width > 0) - format_append_chars(sc, fdat, pad, width, port); - } - break; - - case 'C': case 'c': - { - s7_pointer obj; - - if (is_null(fdat->args)) - format_error_nr(sc, "~~C: missing argument", 21, str, args, fdat); - /* the "~~" here and below protects against "~C" being treated as a directive */ - obj = car(fdat->args); - if (!is_character(obj)) - { - if (!format_method(sc, (const char *)(str + i), fdat, port)) /* i stepped forward above */ - format_error_nr(sc, "'C' directive requires a character argument", 43, str, args, fdat); - } - else - { - /* here use_write is false, so we just add the char, not its name */ - if (width == -1) - format_append_char(sc, character(obj), port); - else - if (width > 0) - format_append_chars(sc, fdat, character(obj), width, port); - - fdat->args = cdr(fdat->args); - fdat->ctr++; - }} - break; - - /* -------- numbers -------- */ - case 'F': case 'f': - if (is_null(fdat->args)) - format_error_nr(sc, "~~F: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (const char *)(str + i), fdat, port)) - format_error_nr(sc, "~~F: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 10, width, precision, 'f', pad, port); - break; - - case 'G': case 'g': - if (is_null(fdat->args)) - format_error_nr(sc, "~~G: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (const char *)(str + i), fdat, port)) - format_error_nr(sc, "~~G: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 10, width, precision, 'g', pad, port); - break; - - case 'E': case 'e': - if (is_null(fdat->args)) - format_error_nr(sc, "~~E: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (const char *)(str + i), fdat, port)) - format_error_nr(sc, "~~E: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 10, width, precision, 'e', pad, port); - break; - - /* how to handle non-integer arguments in the next 4 cases? clisp just returns - * the argument: (format nil "~X" 1.25) -> "1.25" which is perverse (ClTl2 p 581: - * "if arg is not an integer, it is printed in ~A format and decimal base")!! - * I think I'll use the type of the number to choose the output format. - */ - case 'D': case 'd': - if (is_null(fdat->args)) - format_error_nr(sc, "~~D: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - /* (let () (require mockery.scm) (format #f "~D" ((*mock-number* 'mock-number) 123))) - * port here is a string-port, str has the width/precision data if the caller wants it, - * args is the current arg. But format_number handles fdat->args and so on, so - * I think I'll pass the format method the current control string (str), the - * current object (car(fdat->args)), and the arglist (args), and assume it will - * return a (scheme) string. - */ - if (!format_method(sc, (const char *)(str + i), fdat, port)) - format_error_nr(sc, "~~D: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 10, width, precision, 'd', pad, port); - break; - - case 'O': case 'o': - if (is_null(fdat->args)) - format_error_nr(sc, "~~O: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (const char *)(str + i), fdat, port)) - format_error_nr(sc, "~~O: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 8, width, precision, 'o', pad, port); - break; - - case 'X': case 'x': - if (is_null(fdat->args)) - format_error_nr(sc, "~~X: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (const char *)(str + i), fdat, port)) - format_error_nr(sc, "~~X: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 16, width, precision, 'x', pad, port); - break; - - case 'B': case 'b': - if (is_null(fdat->args)) - format_error_nr(sc, "~~B: missing argument", 21, str, args, fdat); - if (!(is_number(car(fdat->args)))) - { - if (!format_method(sc, (const char *)(str + i), fdat, port)) - format_error_nr(sc, "~~B: numeric argument required", 30, str, args, fdat); - } - else format_number(sc, fdat, 2, width, precision, 'b', pad, port); - break; - - default: - if (width > 0) - format_error_nr(sc, "unused numeric argument", 23, str, args, fdat); - format_error_nr(sc, "unimplemented format directive", 30, str, args, fdat); - }} - break; - - default: - format_error_nr(sc, "unimplemented format directive", 30, str, args, fdat); - }} + { + use_write_t use_write; + switch (str[i + 1]) + { + case '%': /* -------- newline -------- */ + /* sbcl apparently accepts numeric args here (including 0) */ + if ((port_data(port)) && + (port_position(port) < port_data_size(port))) + { + port_data(port)[port_position(port)++] = '\n'; + sc->format_column = 0; + } + else format_append_newline(sc, port); + i++; + break; + + case '&': /* -------- conditional newline -------- */ + /* this only works if all output goes through format -- display/write for example do not update format_column */ + if (sc->format_column > 0) + format_append_newline(sc, port); + i++; + break; + + case '~': /* -------- tilde -------- */ + format_append_char(sc, '~', port); + i++; + break; + + case '\n': /* -------- trim white-space -------- so (format #f "hiho~\n") -> "hiho"! */ + for (i = i + 2; i <str_len - 1; i++) + if (!(white_space[(uint8_t)(str[i])])) + { + i--; + break; + } + break; + + case '*': /* -------- ignore arg -------- */ + i++; + if (is_null(fdat->args)) /* (format #f "~*~A") */ + format_error_nr(sc, "can't skip argument!", 20, str, args, fdat); + fdat->args = cdr(fdat->args); + break; + + case '|': /* -------- exit if args nil or ctr > (*s7* 'print-length) -------- */ + if ((is_pair(fdat->args)) && + (fdat->ctr >= sc->print_length)) + { + format_append_string(sc, fdat, " ...", 4, port); + fdat->args = sc->nil; + } + /* fall through */ + + case '^': /* -------- exit -------- */ + if (is_null(fdat->args)) + { + i = str_len; + goto ALL_DONE; + } + i++; + break; + + case '@': /* -------- plural, 'y' or 'ies' -------- */ + i += 2; + if ((str[i] != 'P') && (str[i] != 'p')) + format_error_nr(sc, "unknown '@' directive", 21, str, args, fdat); + if (!is_pair(fdat->args)) + format_error_nr(sc, "'@' directive argument missing", 30, str, args, fdat); + if (!is_real(car(fdat->args))) /* CL accepts non numbers here */ + format_error_nr(sc, "'@P' directive argument is not a real number", 44, str, args, fdat); + + if (!is_one_or_big_one(sc, car(fdat->args))) + format_append_string(sc, fdat, "ies", 3, port); + else format_append_char(sc, 'y', port); + + fdat->args = cdr(fdat->args); + break; + + case 'P': case 'p': /* -------- plural in 's' -------- */ + if (!is_pair(fdat->args)) + format_error_nr(sc, "'P' directive argument missing", 30, str, args, fdat); + if (!is_real(car(fdat->args))) + format_error_nr(sc, "'P' directive argument is not a real number", 43, str, args, fdat); + if (!is_one_or_big_one(sc, car(fdat->args))) + format_append_char(sc, 's', port); + i++; + fdat->args = cdr(fdat->args); + break; + + case '{': /* -------- iteration -------- */ + { + s7_int curly_len; + + if (is_null(fdat->args)) + format_error_nr(sc, "missing argument", 16, str, args, fdat); + + if ((is_pair(car(fdat->args))) && /* any sequence is possible here */ + (s7_list_length(sc, car(fdat->args)) < 0)) /* (format #f "~{~a~e~}" (cons 1 2)) */ + format_error_nr(sc, "~{ argument is a dotted list", 28, str, args, fdat); + + curly_len = format_nesting(str, '{', '}', i, str_len - 1); + + if (curly_len == -1) + format_error_nr(sc, "'{' directive, but no matching '}'", 34, str, args, fdat); + if (curly_len == 1) + format_error_nr(sc, "~{~}' doesn't consume any arguments!", 36, str, args, fdat); + + /* what about cons's here? I can't see any way to specify the car or cdr of a cons within the format string */ + if (is_not_null(car(fdat->args))) /* (format #f "~{~A ~}" ()) -> "" */ + { + s7_pointer curly_arg = object_to_list(sc, car(fdat->args)); /* if a pair (or non-sequence), this simply returns the original */ + /* perhaps use an iterator here -- rootlet->list is expensive! */ + if (is_pair(curly_arg)) /* (format #f "~{~A ~}" #()) -> "" */ + { + char *curly_str = NULL; /* this is the local (nested) format control string */ + s7_pointer cycle_arg; + + fdat->curly_arg = curly_arg; + if (curly_len > fdat->curly_len) + { + if (fdat->curly_str) free(fdat->curly_str); + fdat->curly_len = curly_len; + fdat->curly_str = (char *)Malloc(curly_len); + } + curly_str = fdat->curly_str; + memcpy((void *)curly_str, (const void *)(str + i + 2), curly_len - 1); + curly_str[curly_len - 1] = '\0'; + + if ((sc->format_depth < sc->num_fdats - 1) && + (sc->fdats[sc->format_depth + 1])) + sc->fdats[sc->format_depth + 1]->ctr = 0; + + /* it's not easy to use an iterator here instead of a list (so object->list isn't needed above), + * because the curly brackets may enclose multiple arguments -- we would need to use + * iterators throughout this function. + */ + cycle_arg = curly_arg; + while (is_pair(curly_arg)) + { + s7_pointer new_arg = sc->nil; + format_to_port_1(sc, port, curly_str, curly_arg, &new_arg, false, columnized, curly_len - 1, NULL); + if (curly_arg == new_arg) + { + if (cdr(curly_arg) == curly_arg) break; + fdat->curly_arg = sc->nil; + format_error_nr(sc, "'{...}' doesn't consume any arguments!", 38, str, args, fdat); + } + curly_arg = new_arg; + if ((!is_pair(curly_arg)) || (curly_arg == cycle_arg)) + break; + cycle_arg = cdr(cycle_arg); + format_to_port_1(sc, port, curly_str, curly_arg, &new_arg, false, columnized, curly_len - 1, NULL); + curly_arg = new_arg; + } + fdat->curly_arg = sc->nil; + } + else + if (!is_null(curly_arg)) + format_error_nr(sc, "'{' directive argument should be a list or something we can turn into a list", 76, str, args, fdat); + } + i += (curly_len + 2); /* jump past the ending '}' too */ + fdat->args = cdr(fdat->args); + fdat->ctr++; + } + break; + + case '}': + format_error_nr(sc, "unmatched '}'", 13, str, args, fdat); + + case '$': + use_write = P_CODE; /* affects when symbols but not keywords are quoted (symbol_to_port and hash_table_to_port) */ + goto OBJSTR; + + case 'W': case 'w': + use_write = P_READABLE; + goto OBJSTR; + + case 'S': case 's': + use_write = P_WRITE; + goto OBJSTR; + + case 'A': case 'a': + use_write = P_DISPLAY; + OBJSTR: /* object->string */ + { + s7_pointer obj, strport; + if (is_null(fdat->args)) + format_error_nr(sc, "missing argument", 16, str, args, fdat); + i++; + obj = car(fdat->args); + if ((use_write == P_READABLE) || + (!has_active_methods(sc, obj)) || + (!format_method(sc, (const char *)(str + i), fdat, port))) + { + bool old_openlets = sc->has_openlets; + /* for the column check, we need to know the length of the object->string output */ + if (columnized) + { + strport = open_format_port(sc); + fdat->strport = strport; + } + else strport = port; + if (use_write == P_READABLE) + sc->has_openlets = false; + object_out(sc, obj, strport, use_write); + if (use_write == P_READABLE) + sc->has_openlets = old_openlets; + if (columnized) + { + if (port_position(strport) >= port_data_size(strport)) + resize_port_data(sc, strport, port_data_size(strport) * 2); + port_data(strport)[port_position(strport)] = '\0'; + if (port_position(strport) > 0) + format_append_string(sc, fdat, (const char *)port_data(strport), port_position(strport), port); + close_format_port(sc, strport); + fdat->strport = NULL; + } + fdat->args = cdr(fdat->args); + fdat->ctr++; + }} + break; + + /* -------- numeric args -------- */ + case ':': + i += 2; + if ((str[i] != 'D') && (str[i] != 'd')) + format_error_nr(sc, "unknown ':' directive", 21, str, args, fdat); + if (!is_pair(fdat->args)) + format_error_nr(sc, "':D' directive argument missing", 31, str, args, fdat); + if (!s7_is_integer(car(fdat->args))) + format_error_nr(sc, "':D' directive argument is not an integer", 41, str, args, fdat); + if (s7_integer_clamped_if_gmp(sc, car(fdat->args)) < 0) + format_error_nr(sc, "':D' directive argument can't be negative", 41, str, args, fdat); + format_ordinal_number(sc, fdat, port); + break; + + case '0': case '1': case '2': case '3': case '4': case '5': + case '6': case '7': case '8': case '9': case ',': + case 'N': case 'n': + + case 'B': case 'b': + case 'D': case 'd': + case 'E': case 'e': + case 'F': case 'f': + case 'G': case 'g': + case 'O': case 'o': + case 'X': case 'x': + + case 'T': case 't': + case 'C': case 'c': + { + s7_int width = -1, precision = -1; + char pad = ' '; + i++; /* str[i] == '~' */ + + if (isdigit((int32_t)(str[i]))) + width = format_numeric_arg(sc, str, str_len, fdat, &i); + else + if ((str[i] == 'N') || (str[i] == 'n')) + { + i++; + width = format_n_arg(sc, str, fdat, args); + } + if (str[i] == ',') + { + i++; /* is (format #f "~12,12D" 1) an error? The precision (or is it the width?) has no use here */ + if (isdigit((int32_t)(str[i]))) + precision = format_numeric_arg(sc, str, str_len, fdat, &i); + else + if ((str[i] == 'N') || (str[i] == 'n')) + { + i++; + precision = format_n_arg(sc, str, fdat, args); + } + else + if (str[i] == '\'') /* (format #f "~12,'xD" 1) -> "xxxxxxxxxxx1" */ + { + pad = str[i + 1]; + i += 2; + if (i >= str_len) /* (format #f "~,'") */ + format_error_nr(sc, "incomplete numeric argument", 27, str, args, fdat); + }} /* is (let ((str "~12,'xD")) (set! (str 5) #\null) (format #f str 1)) an error? */ + + switch (str[i]) + { + /* -------- pad to column -------- + * are columns numbered from 1 or 0? there seems to be disagreement about this directive, does "space over to" mean including? + */ + case 'T': case 't': + if (width == -1) width = 0; + if (precision == -1) precision = 0; + if ((width > 0) || (precision > 0)) /* (format #f "a~8Tb") */ + { + /* (length (substring (format #f "~%~10T.") 1)) == (length (format #f "~10T.")) + * (length (substring (format #f "~%-~10T.~%") 1)) == (length (format #f "-~10T.~%")) + */ + if (precision > 0) + { + int32_t mult = (int32_t)(ceil((s7_double)(sc->format_column + 1 - width) / (s7_double)precision)); /* CLtL2 ("least positive int") */ + if (mult < 1) mult = 1; + width += (precision * mult); + } + width -= (sc->format_column + 1); + if (width > 0) + format_append_chars(sc, fdat, pad, width, port); + } + break; + + case 'C': case 'c': + { + s7_pointer obj; + + if (is_null(fdat->args)) + format_error_nr(sc, "~~C: missing argument", 21, str, args, fdat); + /* the "~~" here and below protects against "~C" being treated as a directive */ + obj = car(fdat->args); + if (!is_character(obj)) + { + if (!format_method(sc, (const char *)(str + i), fdat, port)) /* i stepped forward above */ + format_error_nr(sc, "'C' directive requires a character argument", 43, str, args, fdat); + } + else + { + /* here use_write is false, so we just add the char, not its name */ + if (width == -1) + format_append_char(sc, character(obj), port); + else + if (width > 0) + format_append_chars(sc, fdat, character(obj), width, port); + + fdat->args = cdr(fdat->args); + fdat->ctr++; + }} + break; + + /* -------- numbers -------- */ + case 'F': case 'f': + if (is_null(fdat->args)) + format_error_nr(sc, "~~F: missing argument", 21, str, args, fdat); + if (!(is_number(car(fdat->args)))) + { + if (!format_method(sc, (const char *)(str + i), fdat, port)) + format_error_nr(sc, "~~F: numeric argument required", 30, str, args, fdat); + } + else format_number(sc, fdat, 10, width, precision, 'f', pad, port); + break; + + case 'G': case 'g': + if (is_null(fdat->args)) + format_error_nr(sc, "~~G: missing argument", 21, str, args, fdat); + if (!(is_number(car(fdat->args)))) + { + if (!format_method(sc, (const char *)(str + i), fdat, port)) + format_error_nr(sc, "~~G: numeric argument required", 30, str, args, fdat); + } + else format_number(sc, fdat, 10, width, precision, 'g', pad, port); + break; + + case 'E': case 'e': + if (is_null(fdat->args)) + format_error_nr(sc, "~~E: missing argument", 21, str, args, fdat); + if (!(is_number(car(fdat->args)))) + { + if (!format_method(sc, (const char *)(str + i), fdat, port)) + format_error_nr(sc, "~~E: numeric argument required", 30, str, args, fdat); + } + else format_number(sc, fdat, 10, width, precision, 'e', pad, port); + break; + + /* how to handle non-integer arguments in the next 4 cases? clisp just returns + * the argument: (format nil "~X" 1.25) -> "1.25" which is perverse (ClTl2 p 581: + * "if arg is not an integer, it is printed in ~A format and decimal base")!! + * I think I'll use the type of the number to choose the output format. + */ + case 'D': case 'd': + if (is_null(fdat->args)) + format_error_nr(sc, "~~D: missing argument", 21, str, args, fdat); + if (!(is_number(car(fdat->args)))) + { + /* (let () (require mockery.scm) (format #f "~D" ((*mock-number* 'mock-number) 123))) + * port here is a string-port, str has the width/precision data if the caller wants it, + * args is the current arg. But format_number handles fdat->args and so on, so + * I think I'll pass the format method the current control string (str), the + * current object (car(fdat->args)), and the arglist (args), and assume it will + * return a (scheme) string. + */ + if (!format_method(sc, (const char *)(str + i), fdat, port)) + format_error_nr(sc, "~~D: numeric argument required", 30, str, args, fdat); + } + else format_number(sc, fdat, 10, width, precision, 'd', pad, port); + break; + + case 'O': case 'o': + if (is_null(fdat->args)) + format_error_nr(sc, "~~O: missing argument", 21, str, args, fdat); + if (!(is_number(car(fdat->args)))) + { + if (!format_method(sc, (const char *)(str + i), fdat, port)) + format_error_nr(sc, "~~O: numeric argument required", 30, str, args, fdat); + } + else format_number(sc, fdat, 8, width, precision, 'o', pad, port); + break; + + case 'X': case 'x': + if (is_null(fdat->args)) + format_error_nr(sc, "~~X: missing argument", 21, str, args, fdat); + if (!(is_number(car(fdat->args)))) + { + if (!format_method(sc, (const char *)(str + i), fdat, port)) + format_error_nr(sc, "~~X: numeric argument required", 30, str, args, fdat); + } + else format_number(sc, fdat, 16, width, precision, 'x', pad, port); + break; + + case 'B': case 'b': + if (is_null(fdat->args)) + format_error_nr(sc, "~~B: missing argument", 21, str, args, fdat); + if (!(is_number(car(fdat->args)))) + { + if (!format_method(sc, (const char *)(str + i), fdat, port)) + format_error_nr(sc, "~~B: numeric argument required", 30, str, args, fdat); + } + else format_number(sc, fdat, 2, width, precision, 'b', pad, port); + break; + + default: + if (width > 0) + format_error_nr(sc, "unused numeric argument", 23, str, args, fdat); + format_error_nr(sc, "unimplemented format directive", 30, str, args, fdat); + }} + break; + + default: + format_error_nr(sc, "unimplemented format directive", 30, str, args, fdat); + }} else /* str[i] is not #\~ */ - { - const char *p = (char *)strchr((const char *)(str + i + 1), (int)'~'); - s7_int j = (p) ? p - str : str_len; - s7_int new_len = j - i; - - if ((port_data(port)) && - ((port_position(port) + new_len) < port_data_size(port))) - { - memcpy((void *)(port_data(port) + port_position(port)), (const void *)(str + i), new_len); - port_position(port) += new_len; - } - else port_write_string(port)(sc, (const char *)(str + i), new_len, port); - fdat->loc += new_len; - sc->format_column += new_len; - i = j - 1; - }} + { + const char *p = (char *)strchr((const char *)(str + i + 1), (int)'~'); + s7_int j = (p) ? p - str : str_len; + s7_int new_len = j - i; + + if ((port_data(port)) && + ((port_position(port) + new_len) < port_data_size(port))) + { + memcpy((void *)(port_data(port) + port_position(port)), (const void *)(str + i), new_len); + port_position(port) += new_len; + } + else port_write_string(port)(sc, (const char *)(str + i), new_len, port); + fdat->loc += new_len; + sc->format_column += new_len; + i = j - 1; + }} ALL_DONE: if (next_arg) @@ -36708,7 +36708,7 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s if (i < str_len) { if (str[i] == '~') - format_error_nr(sc, "control string ends in tilde", 28, str, args, fdat); + format_error_nr(sc, "control string ends in tilde", 28, str, args, fdat); format_append_char(sc, str[i], port); } sc->format_depth--; @@ -36716,22 +36716,22 @@ static s7_pointer format_to_port_1(s7_scheme *sc, s7_pointer port, const char *s { s7_pointer result; if ((is_output_port(deferred_port)) && - (port_position(port) > 0)) - { - if (port_position(port) < port_data_size(port)) - port_data(port)[port_position(port)] = '\0'; - port_write_string(deferred_port)(sc, (const char *)port_data(port), port_position(port), deferred_port); - } + (port_position(port) > 0)) + { + if (port_position(port) < port_data_size(port)) + port_data(port)[port_position(port)] = '\0'; + port_write_string(deferred_port)(sc, (const char *)port_data(port), port_position(port), deferred_port); + } if (port_position(port) < port_data_size(port)) - { - block_t *block = inline_mallocate(sc, FORMAT_PORT_LENGTH); - result = inline_block_to_string(sc, port_data_block(port), port_position(port)); - port_data_size(port) = FORMAT_PORT_LENGTH; - port_data_block(port) = block; - port_data(port) = (uint8_t *)(block_data(block)); - port_data(port)[0] = '\0'; - port_position(port) = 0; - } + { + block_t *block = inline_mallocate(sc, FORMAT_PORT_LENGTH); + result = inline_block_to_string(sc, port_data_block(port), port_position(port)); + port_data_size(port) = FORMAT_PORT_LENGTH; + port_data_block(port) = block; + port_data(port) = (uint8_t *)(block_data(block)); + port_data(port)[0] = '\0'; + port_position(port) = 0; + } else result = make_string_with_length(sc, (char *)port_data(port), port_position(port)); close_format_port(sc, port); fdat->port = NULL; @@ -36745,21 +36745,21 @@ static bool is_columnizing(const char *str) /* look for ~t ~,<int>T ~<int>,<int for (const char *p = (const char *)str; (*p);) if (*p++ == '~') /* this is faster than strchr */ { - char c = *p++; - if ((c == 't') || (c == 'T')) return(true); - if (!c) return(false); - if ((c == ',') || ((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) - { - while (((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) c = *p++; - if ((c == 't') || (c == 'T')) return(true); - if (!c) return(false); /* ~,1 for example */ - if (c == ',') - { - c = *p++; - while (((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) c = *p++; - if ((c == 't') || (c == 'T')) return(true); - if (!c) return(false); - }}} + char c = *p++; + if ((c == 't') || (c == 'T')) return(true); + if (!c) return(false); + if ((c == ',') || ((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) + { + while (((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) c = *p++; + if ((c == 't') || (c == 'T')) return(true); + if (!c) return(false); /* ~,1 for example */ + if (c == ',') + { + c = *p++; + while (((c >= '0') && (c <= '9')) || (c == 'n') || (c == 'N')) c = *p++; + if ((c == 't') || (c == 'T')) return(true); + if (!c) return(false); + }}} return(false); } @@ -36792,19 +36792,19 @@ is #t, the string is also sent to the current-output-port." { pt = current_output_port(sc); /* () -> (current-output-port) */ if (pt == sc->F) /* otherwise () -> #f so we get a returned string, which is confusing */ - return(nil_string); /* was #f 18-Mar-24 */ + return(nil_string); /* was #f 18-Mar-24 */ } sc->format_column = 0; if (!((is_boolean(pt)) || /* #f or #t */ - ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ - (!port_is_closed(pt))))) + ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ + (!port_is_closed(pt))))) return(method_or_bust(sc, pt, sc->format_symbol, args, an_output_port_string, 1)); str = cadr(args); if (!is_string(str)) return(method_or_bust(sc, str, sc->format_symbol, args, sc->type_names[T_STRING], 2)); return(format_to_port_1(sc, (pt == sc->T) ? current_output_port(sc) : pt, - string_value(str), cddr(args), NULL, !is_output_port(pt), true, string_length(str), str)); + string_value(str), cddr(args), NULL, !is_output_port(pt), true, string_length(str), str)); } const char *s7_format(s7_scheme *sc, s7_pointer args) @@ -36833,12 +36833,12 @@ static s7_pointer g_format_just_control_string(s7_scheme *sc, s7_pointer args) { pt = current_output_port(sc); if (pt == sc->F) - return(nil_string); + return(nil_string); } if (pt == sc->T) { if ((current_output_port(sc) != sc->F) && (string_length(str) != 0)) - port_write_string(current_output_port(sc))(sc, string_value(str), string_length(str), current_output_port(sc)); + port_write_string(current_output_port(sc))(sc, string_value(str), string_length(str), current_output_port(sc)); return(str); } if ((!is_output_port(pt)) || @@ -36868,20 +36868,20 @@ static s7_pointer g_format_no_column(s7_scheme *sc, s7_pointer args) { pt = current_output_port(sc); if (pt == sc->F) - return(nil_string); + return(nil_string); } if (!((is_boolean(pt)) || - ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ - (!port_is_closed(pt))))) + ((is_output_port(pt)) && /* (current-output-port) or call-with-open-file arg, etc */ + (!port_is_closed(pt))))) return(method_or_bust(sc, pt, sc->format_symbol, args, a_format_port_string, 1)); str = cadr(args); sc->format_column = 0; return(format_to_port_1(sc, (pt == sc->T) ? current_output_port(sc) : pt, - string_value(str), cddr(args), NULL, - !is_output_port(pt), /* i.e. is boolean port so we're returning a string */ - false, /* we checked in advance that it is not columnized */ - string_length(str), str)); + string_value(str), cddr(args), NULL, + !is_output_port(pt), /* i.e. is boolean port so we're returning a string */ + false, /* we checked in advance that it is not columnized */ + string_length(str), str)); } static s7_pointer format_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) @@ -36891,39 +36891,39 @@ static s7_pointer format_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_p const s7_pointer port = cadr(expr); s7_pointer str_arg = caddr(expr); if (is_string(str_arg)) - { - if ((args == 2) || (args == 3)) - { - s7_int len; - char *orig = string_value(str_arg); - const char *p = strchr((const char *)orig, (int)'~'); - if (!p) - return((args == 2) ? sc->format_just_control_string : f); - - len = string_length(str_arg); - if ((args == 2) && - (len > 1) && - (orig[len - 1] == '%') && - ((p - orig) == len - 2)) - { - orig[len - 2] = '\n'; - orig[len - 1] = '\0'; - string_length(str_arg) = len - 1; - return(sc->format_just_control_string); - } - if ((args == 3) && - (len == 2) && - (port == sc->F) && - (orig[0] == '~') && - ((orig[1] == 'A') || (orig[1] == 'a'))) - return(sc->format_as_objstr); - } - /* this used to worry about optimized expr and particular cases -- why? I can't find a broken case */ - if (!is_columnizing(string_value(str_arg))) - return(sc->format_no_column); - } + { + if ((args == 2) || (args == 3)) + { + s7_int len; + char *orig = string_value(str_arg); + const char *p = strchr((const char *)orig, (int)'~'); + if (!p) + return((args == 2) ? sc->format_just_control_string : f); + + len = string_length(str_arg); + if ((args == 2) && + (len > 1) && + (orig[len - 1] == '%') && + ((p - orig) == len - 2)) + { + orig[len - 2] = '\n'; + orig[len - 1] = '\0'; + string_length(str_arg) = len - 1; + return(sc->format_just_control_string); + } + if ((args == 3) && + (len == 2) && + (port == sc->F) && + (orig[0] == '~') && + ((orig[1] == 'A') || (orig[1] == 'a'))) + return(sc->format_as_objstr); + } + /* this used to worry about optimized expr and particular cases -- why? I can't find a broken case */ + if (!is_columnizing(string_value(str_arg))) + return(sc->format_no_column); + } if (port == sc->F) - return(sc->format_f); + return(sc->format_f); } return(f); } @@ -36941,11 +36941,11 @@ static bool is_directory_b_7p(s7_scheme *sc, s7_pointer p) { block_t *b = expand_filename(sc, string_value(p)); if (b) - { - bool result = is_directory((char *)block_data(b)); - liberate(sc, b); - return(result); - }} + { + bool result = is_directory((char *)block_data(b)); + liberate(sc, b); + return(result); + }} return(is_directory(string_value(p))); } @@ -36977,11 +36977,11 @@ static bool file_exists_b_7p(s7_scheme *sc, s7_pointer p) { block_t *b = expand_filename(sc, string_value(p)); if (b) - { - bool result = file_probe((char *)block_data(b)); - liberate(sc, b); - return(result); - }} + { + bool result = file_probe((char *)block_data(b)); + liberate(sc, b); + return(result); + }} return(file_probe(string_value(p))); } @@ -37005,11 +37005,11 @@ static s7_pointer g_delete_file(s7_scheme *sc, s7_pointer args) { block_t *b = expand_filename(sc, string_value(name)); if (b) - { - s7_int result = unlink((char *)block_data(b)); - liberate(sc, b); - return(make_integer(sc, result)); - }} + { + s7_int result = unlink((char *)block_data(b)); + liberate(sc, b); + return(make_integer(sc, result)); + }} return(make_integer(sc, unlink(string_value(name)))); } @@ -37051,24 +37051,24 @@ system captures the output as a string and returns it." int32_t cur_len = 0, full_len = 0; FILE *fd = popen(string_value(name), "r"); while (fgets(buf, BUF_SIZE, fd)) - { - s7_int buf_len = safe_strlen(buf); - if (cur_len + buf_len >= full_len) - { - full_len += BUF_SIZE * 2; - str = (str) ? (char *)Realloc(str, full_len) : (char *)Malloc(full_len); - } - memcpy((void *)(str + cur_len), (void *)buf, buf_len); - cur_len += buf_len; - } + { + s7_int buf_len = safe_strlen(buf); + if (cur_len + buf_len >= full_len) + { + full_len += BUF_SIZE * 2; + str = (str) ? (char *)Realloc(str, full_len) : (char *)Malloc(full_len); + } + memcpy((void *)(str + cur_len), (void *)buf, buf_len); + cur_len += buf_len; + } pclose(fd); if (str) - { - block_t *b = mallocate_block(sc); - block_data(b) = (void *)str; - block_set_index(b, TOP_BLOCK_LIST); - return(block_to_string(sc, b, cur_len)); - } + { + block_t *b = mallocate_block(sc); + block_data(b) = (void *)str; + block_set_index(b, TOP_BLOCK_LIST); + return(block_to_string(sc, b, cur_len)); + } return(nil_string); } return(make_integer(sc, system(string_value(name)))); @@ -37089,7 +37089,7 @@ static s7_pointer directory_to_list_1(s7_scheme *sc, const char *dir_name) { struct dirent *dirp; while ((dirp = readdir(dpos))) - sc->w = cons_unchecked(sc, s7_make_string(sc, dirp->d_name), sc->w); + sc->w = cons_unchecked(sc, s7_make_string(sc, dirp->d_name), sc->w); closedir(dpos); } result = sc->w; @@ -37109,11 +37109,11 @@ static s7_pointer g_directory_to_list(s7_scheme *sc, s7_pointer args) { block_t *b = expand_filename(sc, string_value(name)); if (b) - { - s7_pointer result = directory_to_list_1(sc, (char *)block_data(b)); - liberate(sc, b); - return(result); - }} + { + s7_pointer result = directory_to_list_1(sc, (char *)block_data(b)); + liberate(sc, b); + return(result); + }} return(directory_to_list_1(sc, string_value(name))); } @@ -37133,13 +37133,13 @@ static s7_pointer g_file_mtime(s7_scheme *sc, s7_pointer args) { block_t *b = expand_filename(sc, string_value(name)); if (b) - { - err = stat((char *)block_data(b), &statbuf); - liberate(sc, b); - if (err < 0) - file_error_nr(sc, "file-mtime", strerror(errno), string_value(name)); - return(make_integer(sc, (s7_int)(statbuf.st_mtime))); - }} + { + err = stat((char *)block_data(b), &statbuf); + liberate(sc, b); + if (err < 0) + file_error_nr(sc, "file-mtime", strerror(errno), string_value(name)); + return(make_integer(sc, (s7_int)(statbuf.st_mtime))); + }} err = stat(string_value(name), &statbuf); if (err < 0) file_error_nr(sc, "file-mtime", strerror(errno), string_value(name)); @@ -37200,7 +37200,7 @@ s7_pointer s7_make_signature(s7_scheme *sc, s7_int len, ...) { set_car(p, va_arg(ap, s7_pointer)); if ((!is_normal_symbol(car(p))) && (!is_boolean(car(p))) && (!is_pair(car(p)))) - s7_warn(sc, 512, "s7_make_signature got an invalid entry %s at position %" ld64, display(car(p)), i); + s7_warn(sc, 512, "s7_make_signature got an invalid entry %s at position %" ld64, display(car(p)), i); } va_end(ap); return((s7_pointer)res); @@ -37219,7 +37219,7 @@ s7_pointer s7_make_circular_signature(s7_scheme *sc, s7_int cycle_point, s7_int { set_car(p, va_arg(ap, s7_pointer)); if ((!is_normal_symbol(car(p))) && (!is_boolean(car(p))) && (!is_pair(car(p)))) - s7_warn(sc, 512, "s7_make_circular_signature got an invalid entry %s at position %" ld64, display(car(p)), i); + s7_warn(sc, 512, "s7_make_circular_signature got an invalid entry %s at position %" ld64, display(car(p)), i); if (i == cycle_point) back = p; if (i == (len - 1)) end = p; } @@ -37291,31 +37291,31 @@ static inline s7_int tree_len_1(s7_scheme *sc, s7_pointer p) { s7_pointer cp = car(p); if ((!is_pair(cp)) || - (is_quote(car(cp)))) - sum++; + (is_quote(car(cp)))) + sum++; else - { - do { - s7_pointer ccp = car(cp); - if ((!is_pair(ccp)) || - (is_quote(car(ccp)))) - sum++; - else - { - do { - s7_pointer cccp = car(ccp); - if ((!is_pair(cccp)) || - (is_quote(car(cccp)))) - sum++; - else sum += tree_len_1(sc, cccp); - ccp = cdr(ccp); - } while (is_pair(ccp)); - if (!is_null(ccp)) sum++; - } - cp = cdr(cp); - } while (is_pair(cp)); - if (!is_null(cp)) sum++; - }} + { + do { + s7_pointer ccp = car(cp); + if ((!is_pair(ccp)) || + (is_quote(car(ccp)))) + sum++; + else + { + do { + s7_pointer cccp = car(ccp); + if ((!is_pair(cccp)) || + (is_quote(car(cccp)))) + sum++; + else sum += tree_len_1(sc, cccp); + ccp = cdr(ccp); + } while (is_pair(ccp)); + if (!is_null(ccp)) sum++; + } + cp = cdr(cp); + } while (is_pair(cp)); + if (!is_null(cp)) sum++; + }} return((is_null(p)) ? sum : sum + 1); } @@ -37363,22 +37363,22 @@ static inline bool tree_memq_1(s7_scheme *sc, s7_pointer sym, s7_pointer tree) if (is_pair(car(tree))) { - s7_pointer cp = car(tree); - if (is_quote(car(cp))) - { - if ((!is_symbol(sym)) && (!is_pair(sym)) && (is_pair(cdr(cp))) && (sym == cadr(cp))) - return(true); - } - else - do { - if (sym == car(cp)) - return(true); - if ((is_pair(car(cp))) && (tree_memq_1(sc, sym, car(cp)))) - return(true); - cp = cdr(cp); - if (sym == cp) - return(true); - } while (is_pair(cp)); + s7_pointer cp = car(tree); + if (is_quote(car(cp))) + { + if ((!is_symbol(sym)) && (!is_pair(sym)) && (is_pair(cdr(cp))) && (sym == cadr(cp))) + return(true); + } + else + do { + if (sym == car(cp)) + return(true); + if ((is_pair(car(cp))) && (tree_memq_1(sc, sym, car(cp)))) + return(true); + cp = cdr(cp); + if (sym == cp) + return(true); + } while (is_pair(cp)); } tree = cdr(tree); if (sym == tree) @@ -37415,14 +37415,14 @@ static inline bool pair_set_memq(s7_scheme *sc, s7_pointer tree) { s7_pointer p = car(tree); if (is_symbol(p)) - { - if (symbol_is_in_list(sc, p)) - return(true); - } + { + if (symbol_is_in_list(sc, p)) + return(true); + } else - if ((is_unquoted_pair(p)) && - (pair_set_memq(sc, p))) - return(true); + if ((is_unquoted_pair(p)) && + (pair_set_memq(sc, p))) + return(true); tree = cdr(tree); if (!is_pair(tree)) break; } @@ -37441,9 +37441,9 @@ static bool tree_set_memq_b_7pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree) if (sc->safety > NO_SAFETY) { if (tree_is_cyclic(sc, syms)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: symbol list is cyclic: ~S", 40), syms)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: symbol list is cyclic: ~S", 40), syms)); if (tree_is_cyclic(sc, tree)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: tree is cyclic: ~S", 33), tree)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-set-memq: tree is cyclic: ~S", 33), tree)); } clear_symbol_list(sc); for (s7_pointer p = syms; is_pair(p); p = cdr(p)) @@ -37456,8 +37456,8 @@ static bool tree_set_memq_b_7pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree) if (non_symbols) for (s7_pointer p = syms; is_pair(p); p = cdr(p)) if ((!is_symbol(car(p))) && - (s7_tree_memq(sc, car(p), tree))) - return(true); + (s7_tree_memq(sc, car(p), tree))) + return(true); return(false); } @@ -37499,8 +37499,8 @@ static s7_pointer tree_set_memq_chooser(s7_scheme *sc, s7_pointer f, int32_t unu (is_pair(cadadr(expr)))) /* (tree-set-memq '(...)...) */ { for (s7_pointer p = cadadr(expr); is_pair(p); p = cdr(p)) - if (!is_symbol(car(p))) - return(f); + if (!is_symbol(car(p))) + return(f); return(sc->tree_set_memq_syms); } return(f); @@ -37538,8 +37538,8 @@ static s7_pointer g_tree_count(s7_scheme *sc, s7_pointer args) if (!is_pair(tree)) { if ((is_pair(cddr(args))) && - (!s7_is_integer(caddr(args)))) - wrong_type_error_nr(sc, sc->tree_count_symbol, 3, caddr(args), sc->type_names[T_INTEGER]); + (!s7_is_integer(caddr(args)))) + wrong_type_error_nr(sc, sc->tree_count_symbol, 3, caddr(args), sc->type_names[T_INTEGER]); if (is_null(tree)) return(int_zero); wrong_type_error_nr(sc, sc->tree_count_symbol, 2, tree, a_list_string); } @@ -37603,7 +37603,7 @@ s7_int s7_list_length(s7_scheme *sc, s7_pointer a) /* returns -len if list is do if (!is_pair(fast)) return((is_null(fast)) ? (i + 1) : (-i - 1)); /* if unrolled further, it's a lot slower? */ fast = cdr(fast); slow = cdr(slow); - if (fast == slow) return(0); + if (fast == slow) return(0); } return(0); } @@ -37637,7 +37637,7 @@ bool s7_is_proper_list(s7_scheme *sc, s7_pointer lst) while (true) { if (!is_pair(fast)) - return(is_null(fast)); /* else it's an improper list */ + return(is_null(fast)); /* else it's an improper list */ LOOP_4(fast = cdr(fast); if (!is_pair(fast)) return(is_null(fast))); fast = cdr(fast); slow = cdr(slow); @@ -37686,7 +37686,7 @@ static inline s7_pointer make_list(s7_scheme *sc, s7_int len, s7_pointer init) case 6: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil)))))))); case 7: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, - cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))))))))); + cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))))))))); default: return(make_big_list(sc, len, init)); } @@ -37711,8 +37711,8 @@ static s7_pointer make_list_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer init) out_of_range_error_nr(sc, sc->make_list_symbol, int_one, n, it_is_negative_string); if (len > sc->max_list_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "make-list length argument ~D is greater than (*s7* 'max-list-length), ~D", 72), - wrap_integer(sc, len), wrap_integer(sc, sc->max_list_length))); + set_elist_3(sc, wrap_string(sc, "make-list length argument ~D is greater than (*s7* 'max-list-length), ~D", 72), + wrap_integer(sc, len), wrap_integer(sc, sc->max_list_length))); return(make_list(sc, len, init)); } @@ -37760,8 +37760,8 @@ static s7_pointer ref_index_checked(s7_scheme *sc, s7_pointer caller, s7_pointer { if (!is_applicable(in_obj)) /* let implicit_index shuffle syntax and closures */ error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), - cons(sc, caller, args), cons(sc, in_obj, cddr(args)), in_obj)); + set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), + cons(sc, caller, args), cons(sc, in_obj, cddr(args)), in_obj)); /* perhaps first $s -> "(~S ~{~$~^ ~})..." and we can pass the symbol rather than the global value as "caller" */ return(implicit_index(sc, in_obj, cddr(args))); } @@ -37804,8 +37804,8 @@ static s7_pointer implicit_pair_index_checked(s7_scheme *sc, s7_pointer obj, s7_ { s7_pointer safe_indices = copy_proper_list(sc, indices); error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), - cons(sc, obj, safe_indices), cons(sc, in_obj, cdr(safe_indices)), in_obj)); + set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), + cons(sc, obj, safe_indices), cons(sc, in_obj, cdr(safe_indices)), in_obj)); } return(implicit_index(sc, in_obj, cdr(indices))); } @@ -37827,11 +37827,11 @@ static s7_pointer list_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7 { s7_pointer index = caddr(expr); if (is_t_integer(index)) - { - if (integer(index) == 0) return(sc->list_ref_at_0); - if (integer(index) == 1) return(sc->list_ref_at_1); - if (integer(index) == 2) return(sc->list_ref_at_2); - }} + { + if (integer(index) == 0) return(sc->list_ref_at_0); + if (integer(index) == 1) return(sc->list_ref_at_1); + if (integer(index) == 2) return(sc->list_ref_at_2); + }} return(f); } @@ -37844,7 +37844,7 @@ static inline s7_pointer list_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer p1, s if (!is_pair(p)) { if (is_null(p)) - out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, wrap_integer(sc, i1), it_is_too_large_string); + out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, wrap_integer(sc, i1), it_is_too_large_string); wrong_type_error_nr(sc, sc->list_ref_symbol, 1, p1, a_proper_list_string); } return(car(p)); @@ -37906,7 +37906,7 @@ static s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, i if (!is_pair(p)) { if (is_null(p)) - out_of_range_error_nr(sc, sc->list_set_symbol, wrap_integer(sc, arg_num), ind, it_is_too_large_string); + out_of_range_error_nr(sc, sc->list_set_symbol, wrap_integer(sc, arg_num), ind, it_is_too_large_string); wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, a_proper_list_string); } if (is_null(cddr(args))) @@ -37914,7 +37914,7 @@ static s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, i else { if (!s7_is_pair(car(p))) - wrong_number_of_arguments_error_nr(sc, "too many arguments for list-set!: ~S", 36, args); + wrong_number_of_arguments_error_nr(sc, "too many arguments for list-set!: ~S", 36, args); return(g_list_set_1(sc, car(p), cdr(args), arg_num + 1)); } return(cadr(args)); @@ -37931,7 +37931,7 @@ static inline s7_pointer list_set_p_pip_unchecked(s7_scheme *sc, s7_pointer p1, if (!is_pair(p)) { if (is_null(p)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, i1), it_is_too_large_string); + out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, i1), it_is_too_large_string); wrong_type_error_nr(sc, sc->list_set_symbol, 1, p1, a_proper_list_string); } set_car(p, p2); @@ -37951,7 +37951,7 @@ static s7_pointer list_increment_p_pip_unchecked(opt_info *o) if (!is_pair(p)) { if (is_null(p)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); + out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); wrong_type_error_nr(sc, sc->list_set_symbol, 1, p1, a_proper_list_string); } p2 = g_add_xi(sc, car(p), integer(o->v[3].p), index); @@ -37982,7 +37982,7 @@ static s7_pointer g_list_set_i(s7_scheme *sc, s7_pointer args) if (!is_pair(p)) { if (is_null(p)) - out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); + out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, a_proper_list_string); } val = caddr(args); @@ -38657,8 +38657,8 @@ s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer x) static s7_pointer assq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { return((is_pair(y)) ? s7_assq(sc, x, y) : - ((is_null(y)) ? sc->F : - method_or_bust_pp(sc, y, sc->assq_symbol, x, y, an_association_list_string, 2))); + ((is_null(y)) ? sc->F : + method_or_bust_pp(sc, y, sc->assq_symbol, x, y, an_association_list_string, 2))); } static s7_pointer g_assq(s7_scheme *sc, s7_pointer args) @@ -38736,31 +38736,31 @@ static s7_pointer assoc_1(s7_scheme *sc, s7_pointer obj, s7_pointer x) if (is_string(obj)) { while (true) - { - if (is_pair(car(x))) - { - s7_pointer val = caar(x); - if ((val == obj) || - ((is_string(val)) && - (scheme_strings_are_equal(obj, val)))) - return(car(x)); - } - x = cdr(x); - if (!is_pair(x)) return(sc->F); - - if (is_pair(car(x))) - { - s7_pointer val = caar(x); - if ((val == obj) || - ((is_string(val)) && - (scheme_strings_are_equal(obj, val)))) - return(car(x)); - } - x = cdr(x); - if (!is_pair(x)) return(sc->F); - y = cdr(y); - if (x == y) return(sc->F); - } + { + if (is_pair(car(x))) + { + s7_pointer val = caar(x); + if ((val == obj) || + ((is_string(val)) && + (scheme_strings_are_equal(obj, val)))) + return(car(x)); + } + x = cdr(x); + if (!is_pair(x)) return(sc->F); + + if (is_pair(car(x))) + { + s7_pointer val = caar(x); + if ((val == obj) || + ((is_string(val)) && + (scheme_strings_are_equal(obj, val)))) + return(car(x)); + } + x = cdr(x); + if (!is_pair(x)) return(sc->F); + y = cdr(y); + if (x == y) return(sc->F); + } return(sc->F); } while (true) @@ -38781,9 +38781,9 @@ static s7_pointer assoc_1(s7_scheme *sc, s7_pointer obj, s7_pointer x) static bool closure_has_two_normal_args(s7_scheme *sc, s7_pointer eq_func) /* sc for is_null */ { return((is_closure(eq_func)) && - (is_pair(closure_args(eq_func))) && - (is_pair(cdr(closure_args(eq_func)))) && /* not dotted arg list */ - (is_null(cddr(closure_args(eq_func))))); /* arity == 2 */ + (is_pair(closure_args(eq_func))) && + (is_pair(cdr(closure_args(eq_func)))) && /* not dotted arg list */ + (is_null(cddr(closure_args(eq_func))))); /* arity == 2 */ } static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args); @@ -38802,9 +38802,9 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of if (!is_null(x)) { if (!is_pair(x)) - return(method_or_bust(sc, x, sc->assoc_symbol, args, an_association_list_string, 2)); + return(method_or_bust(sc, x, sc->assoc_symbol, args, an_association_list_string, 2)); if (!is_pair(car(x))) - wrong_type_error_nr(sc, sc->assoc_symbol, 2, x, an_association_list_string); /* we're assuming caar below so it better exist */ + wrong_type_error_nr(sc, sc->assoc_symbol, 2, x, an_association_list_string); /* we're assuming caar below so it better exist */ } if (is_pair(cddr(args))) { @@ -38814,65 +38814,65 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of /* I wonder if the assoc equality function should get the cons, not just caar? */ if (is_safe_c_function(eq_func)) - { - s7_function func = c_function_call(eq_func); - if (func == g_is_eq) return(is_null(x) ? sc->F : s7_assq(sc, car(args), x)); - if (func == g_is_eqv) return(assv_p_pp(sc, car(args), x)); - if (!s7_is_aritable(sc, eq_func, 2)) - wrong_type_error_nr(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string); - set_car(sc->t2_1, car(args)); - for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) - { - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); /* not x */ - set_car(sc->t2_2, caar(x)); - if (is_true(sc, func(sc, sc->t2_1))) return(car(x)); - x = cdr(x); - if ((!is_pair(x)) || (x == slow)) return(sc->F); - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); - set_car(sc->t2_2, caar(x)); - if (is_true(sc, func(sc, sc->t2_1))) return(car(x)); - } - return(sc->F); - } + { + s7_function func = c_function_call(eq_func); + if (func == g_is_eq) return(is_null(x) ? sc->F : s7_assq(sc, car(args), x)); + if (func == g_is_eqv) return(assv_p_pp(sc, car(args), x)); + if (!s7_is_aritable(sc, eq_func, 2)) + wrong_type_error_nr(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string); + set_car(sc->t2_1, car(args)); + for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) + { + if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); /* not x */ + set_car(sc->t2_2, caar(x)); + if (is_true(sc, func(sc, sc->t2_1))) return(car(x)); + x = cdr(x); + if ((!is_pair(x)) || (x == slow)) return(sc->F); + if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); + set_car(sc->t2_2, caar(x)); + if (is_true(sc, func(sc, sc->t2_1))) return(car(x)); + } + return(sc->F); + } if (closure_has_two_normal_args(sc, eq_func)) - { - s7_pointer body = closure_body(eq_func); - if (is_null(x)) return(sc->F); - if (is_null(cdr(body))) - { - s7_pfunc func; - set_curlet(sc, make_let_with_two_slots(sc, sc->curlet, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F)); - func = s7_bool_optimize(sc, body); - if (func) - { - s7_pointer slowx = x; - opt_info *o = sc->opts[0]; - s7_pointer b = next_slot(let_slots(sc->curlet)); - while (true) - { - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); - slot_set_value(b, caar(x)); - if (o->v[0].fb(o)) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); - slot_set_value(b, caar(x)); - if (o->v[0].fb(o)) return(car(x)); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - slowx = cdr(slowx); - if (x == slowx) return(sc->F); - } - return(sc->F); - }}} + { + s7_pointer body = closure_body(eq_func); + if (is_null(x)) return(sc->F); + if (is_null(cdr(body))) + { + s7_pfunc func; + set_curlet(sc, make_let_with_two_slots(sc, sc->curlet, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F)); + func = s7_bool_optimize(sc, body); + if (func) + { + s7_pointer slowx = x; + opt_info *o = sc->opts[0]; + s7_pointer b = next_slot(let_slots(sc->curlet)); + while (true) + { + if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); + slot_set_value(b, caar(x)); + if (o->v[0].fb(o)) return(car(x)); + x = cdr(x); + if (!is_pair(x)) return(sc->F); + if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); + slot_set_value(b, caar(x)); + if (o->v[0].fb(o)) return(car(x)); + x = cdr(x); + if (!is_pair(x)) return(sc->F); + slowx = cdr(slowx); + if (x == slowx) return(sc->F); + } + return(sc->F); + }}} /* member_if is similar. Do not call eval here with op_eval_done to return! An error will longjmp past the * assoc point, leaving the op_eval_done on the stack, causing s7 to quit. */ if (type(eq_func) < T_CONTINUATION) - return(method_or_bust_p(sc, eq_func, sc->assoc_symbol, a_procedure_string)); + return(method_or_bust_p(sc, eq_func, sc->assoc_symbol, a_procedure_string)); if (!s7_is_aritable(sc, eq_func, 2)) - wrong_type_error_nr(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string); + wrong_type_error_nr(sc, sc->assoc_symbol, 3, eq_func, an_eq_func_string); if (is_null(x)) return(sc->F); if ((is_any_macro(eq_func)) && (!is_c_macro(eq_func))) clear_all_optimizations(sc, closure_body(eq_func)); y = list_1(sc, copy_proper_list(sc, args)); @@ -38880,13 +38880,13 @@ If 'func' is a function of 2 arguments, it is used for the comparison instead of set_opt2_slow(y, x); push_stack(sc, OP_ASSOC_IF, list_1_unchecked(sc, y), eq_func); if (needs_copied_args(eq_func)) - push_stack(sc, OP_APPLY, list_2_unchecked(sc, car(args), caar(x)), eq_func); + push_stack(sc, OP_APPLY, list_2_unchecked(sc, car(args), caar(x)), eq_func); else - { - set_car(sc->t2_1, car(args)); - set_car(sc->t2_2, caar(x)); - push_stack(sc, OP_APPLY, sc->t2_1, eq_func); - } + { + set_car(sc->t2_1, car(args)); + set_car(sc->t2_2, caar(x)); + push_stack(sc, OP_APPLY, sc->t2_1, eq_func); + } return(sc->unspecified); } if (is_null(x)) return(sc->F); @@ -38930,10 +38930,10 @@ static bool op_assoc_if(s7_scheme *sc) { /* circular list check */ if (opt1_fast(orig_args) == opt2_slow(orig_args)) - { - sc->value = sc->F; - return(true); - } + { + sc->value = sc->F; + return(true); + } set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list */ push_stack_direct(sc, OP_ASSOC_IF); } @@ -38978,7 +38978,7 @@ s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x) static s7_pointer memq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { return((is_pair(y)) ? s7_memq(sc, x, y) : - ((is_null(y)) ? sc->F : method_or_bust_pp(sc, y, sc->memq_symbol, x, y, a_list_string, 2))); + ((is_null(y)) ? sc->F : method_or_bust_pp(sc, y, sc->memq_symbol, x, y, a_list_string, 2))); } static s7_pointer g_memq(s7_scheme *sc, s7_pointer args) @@ -39068,13 +39068,13 @@ static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, { s7_int len = s7_list_length(sc, cadr(lst)); if (len > 0) - { - if (len == 2) /* this used to set opt3_any to cadr, but that doesn't survive call/cc's copy_stack */ - return(sc->memq_2); - if ((len % 4) == 0) - return(sc->memq_4); - return(((len % 3) == 0) ? sc->memq_3 : sc->memq_any); - }} + { + if (len == 2) /* this used to set opt3_any to cadr, but that doesn't survive call/cc's copy_stack */ + return(sc->memq_2); + if ((len % 4) == 0) + return(sc->memq_4); + return(((len % 3) == 0) ? sc->memq_3 : sc->memq_any); + }} return(f); } @@ -39164,28 +39164,28 @@ static s7_pointer member(s7_scheme *sc, s7_pointer obj, s7_pointer x) if (is_string(obj)) while (true) { - if ((obj == car(x)) || - ((is_string(car(x))) && - (scheme_strings_are_equal(obj, car(x))))) - return(x); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - - if ((obj == car(x)) || - ((is_string(car(x))) && - (scheme_strings_are_equal(obj, car(x))))) - return(x); - x = cdr(x); - if (!is_pair(x)) return(sc->F); - y = cdr(y); - if (x == y) return(sc->F); + if ((obj == car(x)) || + ((is_string(car(x))) && + (scheme_strings_are_equal(obj, car(x))))) + return(x); + x = cdr(x); + if (!is_pair(x)) return(sc->F); + + if ((obj == car(x)) || + ((is_string(car(x))) && + (scheme_strings_are_equal(obj, car(x))))) + return(x); + x = cdr(x); + if (!is_pair(x)) return(sc->F); + y = cdr(y); + if (x == y) return(sc->F); } else while (true) { - LOOP_4(if (s7_is_equal(sc, obj, car(x))) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); - y = cdr(y); - if (x == y) return(sc->F); + LOOP_4(if (s7_is_equal(sc, obj, car(x))) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F)); + y = cdr(y); + if (x == y) return(sc->F); } return(sc->F); } @@ -39217,78 +39217,78 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c s7_pointer y, eq_func = caddr(args); if (is_safe_c_function(eq_func)) - { - s7_function func = c_function_call(eq_func); - if (func == g_is_eq) return(is_null(x) ? sc->F : s7_memq(sc, car(args), x)); - if (func == g_is_eqv) return(g_memv(sc, args)); - if (func == g_less) - func = g_less_2; - else - if (func == g_greater) - func = g_greater_2; - else - if (!s7_is_aritable(sc, eq_func, 2)) - wrong_type_error_nr(sc, sc->member_symbol, 3, eq_func, an_eq_func_string); - set_car(sc->t2_1, car(args)); - for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) - { - set_car(sc->t2_2, car(x)); - if (is_true(sc, func(sc, sc->t2_1))) return(x); - if (!is_pair(cdr(x))) return(sc->F); - x = cdr(x); - if (x == slow) return(sc->F); - set_car(sc->t2_2, car(x)); - if (is_true(sc, func(sc, sc->t2_1))) return(x); - } - return(sc->F); - } + { + s7_function func = c_function_call(eq_func); + if (func == g_is_eq) return(is_null(x) ? sc->F : s7_memq(sc, car(args), x)); + if (func == g_is_eqv) return(g_memv(sc, args)); + if (func == g_less) + func = g_less_2; + else + if (func == g_greater) + func = g_greater_2; + else + if (!s7_is_aritable(sc, eq_func, 2)) + wrong_type_error_nr(sc, sc->member_symbol, 3, eq_func, an_eq_func_string); + set_car(sc->t2_1, car(args)); + for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) + { + set_car(sc->t2_2, car(x)); + if (is_true(sc, func(sc, sc->t2_1))) return(x); + if (!is_pair(cdr(x))) return(sc->F); + x = cdr(x); + if (x == slow) return(sc->F); + set_car(sc->t2_2, car(x)); + if (is_true(sc, func(sc, sc->t2_1))) return(x); + } + return(sc->F); + } if (closure_has_two_normal_args(sc, eq_func)) - { - s7_pointer body = closure_body(eq_func); - if (is_null(x)) return(sc->F); - if ((!no_bool_opt(body)) && - (is_null(cdr(body)))) - { - s7_pfunc func; - set_curlet(sc, make_let_with_two_slots(sc, sc->curlet, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F)); - func = s7_bool_optimize(sc, body); - if (func) - { - opt_info *o = sc->opts[0]; - s7_pointer b = next_slot(let_slots(sc->curlet)); - if (o->v[0].fb == p_to_b) - { - s7_pointer (*fp)(opt_info *o) = o->v[O_WRAP].fp; - for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) - { - slot_set_value(b, car(x)); - 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)); - if (fp(o) != sc->F) return(x); - }} - else - for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) - { - slot_set_value(b, car(x)); - 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)); - if (o->v[0].fb(o)) return(x); - } - return(sc->F); - } - set_no_bool_opt(body); - }} + { + s7_pointer body = closure_body(eq_func); + if (is_null(x)) return(sc->F); + if ((!no_bool_opt(body)) && + (is_null(cdr(body)))) + { + s7_pfunc func; + set_curlet(sc, make_let_with_two_slots(sc, sc->curlet, car(closure_args(eq_func)), car(args), cadr(closure_args(eq_func)), sc->F)); + func = s7_bool_optimize(sc, body); + if (func) + { + opt_info *o = sc->opts[0]; + s7_pointer b = next_slot(let_slots(sc->curlet)); + if (o->v[0].fb == p_to_b) + { + s7_pointer (*fp)(opt_info *o) = o->v[O_WRAP].fp; + for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) + { + slot_set_value(b, car(x)); + 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)); + if (fp(o) != sc->F) return(x); + }} + else + for (s7_pointer slow = x; is_pair(x); x = cdr(x), slow = cdr(slow)) + { + slot_set_value(b, car(x)); + 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)); + if (o->v[0].fb(o)) return(x); + } + return(sc->F); + } + set_no_bool_opt(body); + }} if (type(eq_func) < T_CONTINUATION) - return(method_or_bust(sc, eq_func, sc->member_symbol, args, a_procedure_string, 3)); + return(method_or_bust(sc, eq_func, sc->member_symbol, args, a_procedure_string, 3)); if (!s7_is_aritable(sc, eq_func, 2)) - wrong_type_error_nr(sc, sc->member_symbol, 3, eq_func, an_eq_func_string); + wrong_type_error_nr(sc, sc->member_symbol, 3, eq_func, an_eq_func_string); if (is_null(x)) return(sc->F); if ((is_any_macro(eq_func)) && (!is_c_macro(eq_func))) clear_all_optimizations(sc, closure_body(eq_func)); y = list_1(sc, copy_proper_list(sc, args)); /* this could probably be handled with a counter cell (cdr here is unused) */ @@ -39296,13 +39296,13 @@ member uses equal? If 'func' is a function of 2 arguments, it is used for the c set_opt2_slow(y, x); push_stack(sc, OP_MEMBER_IF, list_1(sc, y), eq_func); if (needs_copied_args(eq_func)) - push_stack(sc, OP_APPLY, list_2_unchecked(sc, car(args), car(x)), eq_func); + push_stack(sc, OP_APPLY, list_2_unchecked(sc, car(args), car(x)), eq_func); else - { - set_car(sc->t2_1, car(args)); - set_car(sc->t2_2, car(x)); - push_stack(sc, OP_APPLY, sc->t2_1, eq_func); - } + { + set_car(sc->t2_1, car(args)); + set_car(sc->t2_2, car(x)); + push_stack(sc, OP_APPLY, sc->t2_1, eq_func); + } return(sc->unspecified); } if (is_null(x)) return(sc->F); @@ -39357,10 +39357,10 @@ static bool op_member_if(s7_scheme *sc) { /* circular list check */ if (opt1_fast(orig_args) == opt2_slow(orig_args)) - { - sc->value = sc->F; - return(true); - } + { + sc->value = sc->F; + return(true); + } set_opt2_slow(orig_args, cdr(opt2_slow(orig_args))); /* cdr down the slow list (check for circular list) */ push_stack_direct(sc, OP_MEMBER_IF); } @@ -39411,9 +39411,9 @@ static void check_list_validity(s7_scheme *sc, const char *caller, s7_pointer ls for (int32_t i = 1; is_pair(p); p = cdr(p), i++) if (!s7_is_valid(sc, car(p))) { - if (i < 11) - s7_warn(sc, 256, "the %s argument to %s: %p, is not an s7 object\n", ordinal[i], caller, car(p)); - else s7_warn(sc, 256, "%s: argument number %d is not an s7 object: %p\n", caller, i, car(p)); + if (i < 11) + s7_warn(sc, 256, "the %s argument to %s: %p, is not an s7 object\n", ordinal[i], caller, car(p)); + else s7_warn(sc, 256, "%s: argument number %d is not an s7 object: %p\n", caller, i, car(p)); } } @@ -39451,10 +39451,10 @@ s7_pointer s7_list_nl(s7_scheme *sc, s7_int num_values, ...) /* arglist should b { p = va_arg(ap, s7_pointer); if (!p) - { - va_end(ap); - wrong_number_of_arguments_error_nr(sc, "not enough arguments for s7_list_nl: ~S", 39, sc->w); /* ideally we'd sublist this and append extra below */ - } + { + va_end(ap); + wrong_number_of_arguments_error_nr(sc, "not enough arguments for s7_list_nl: ~S", 39, sc->w); /* ideally we'd sublist this and append extra below */ + } set_car(q, p); } p = va_arg(ap, s7_pointer); @@ -39503,15 +39503,15 @@ static s7_pointer make_safe_list(s7_scheme *sc, s7_int num_args) { sc->current_safe_list = num_args; if (!is_pair(sc->safe_lists[num_args])) - sc->safe_lists[num_args] = semipermanent_list(sc, num_args); + sc->safe_lists[num_args] = semipermanent_list(sc, num_args); if (!list_is_in_use(sc->safe_lists[num_args])) - { - set_list_in_use(sc->safe_lists[num_args]); + { + set_list_in_use(sc->safe_lists[num_args]); #if S7_DEBUGGING - sc->safe_list_uses[num_args]++; + sc->safe_list_uses[num_args]++; #endif - return(sc->safe_lists[num_args]); - }} + return(sc->safe_lists[num_args]); + }} return(make_big_list(sc, num_args, sc->nil)); } @@ -39541,83 +39541,83 @@ static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args) s7_pointer p = car(y), func; if ((has_active_methods(sc, p)) && - ((func = find_method_with_let(sc, p, sc->append_symbol)) != sc->undefined)) - { - unstack_gc_protect(sc); - return(s7_apply_function(sc, func, (is_null(tp)) ? y : set_ulist_1(sc, tp, y))); - } + ((func = find_method_with_let(sc, p, sc->append_symbol)) != sc->undefined)) + { + unstack_gc_protect(sc); + return(s7_apply_function(sc, func, (is_null(tp)) ? y : set_ulist_1(sc, tp, y))); + } if (is_null(cdr(y))) - { - if (is_null(tp)) - { - /* Guile: (append '() 1): 1, r7rs claims an improper list is the result, yet its own examples contradict that - * (what does "share structure" mean when there are no structures? I assume they mean sequences) - */ - unstack_gc_protect(sc); - return(p); - } - if (is_list(p)) - set_cdr(np, p); - else - { - s7_int len = sequence_length(sc, p); - if (len > 0) - set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused)))); - else - if (len < 0) - set_cdr(np, p); - } - sc->temp8 = sc->unused; - unstack_gc_protect(sc); - return(tp); - } + { + if (is_null(tp)) + { + /* Guile: (append '() 1): 1, r7rs claims an improper list is the result, yet its own examples contradict that + * (what does "share structure" mean when there are no structures? I assume they mean sequences) + */ + unstack_gc_protect(sc); + return(p); + } + if (is_list(p)) + set_cdr(np, p); + else + { + s7_int len = sequence_length(sc, p); + if (len > 0) + set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused)))); + else + if (len < 0) + set_cdr(np, p); + } + sc->temp8 = sc->unused; + unstack_gc_protect(sc); + return(tp); + } if (!is_sequence(p)) - { - unstack_gc_protect(sc); - wrong_type_error_nr(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string); - } + { + unstack_gc_protect(sc); + wrong_type_error_nr(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string); + } if (!sequence_is_empty(sc, p)) - { - if (is_pair(p)) - { - if (!s7_is_proper_list(sc, p)) - { - sc->temp8 = sc->unused; - unstack_gc_protect(sc); - wrong_type_error_nr(sc, sc->append_symbol, position_of(y, args), p, a_proper_list_string); - } - if (is_null(tp)) - { - tp = list_1(sc, car(p)); - np = tp; - sc->temp8 = tp; /* GC protect? */ - pp = cdr(p); - } - else pp = p; - for (; is_pair(pp); pp = cdr(pp), np = cdr(np)) - set_cdr(np, list_1(sc, car(pp))); - } - else - { - s7_int len = sequence_length(sc, p); - if (len > 0) - { - if (is_null(tp)) - { - tp = s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused))); - np = tp; - sc->temp8 = tp; - } - else set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused)))); - for (; is_pair(cdr(np)); np = cdr(np)); - } - else - if (len < 0) - { - unstack_gc_protect(sc); - wrong_type_error_nr(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string); - }}}} + { + if (is_pair(p)) + { + if (!s7_is_proper_list(sc, p)) + { + sc->temp8 = sc->unused; + unstack_gc_protect(sc); + wrong_type_error_nr(sc, sc->append_symbol, position_of(y, args), p, a_proper_list_string); + } + if (is_null(tp)) + { + tp = list_1(sc, car(p)); + np = tp; + sc->temp8 = tp; /* GC protect? */ + pp = cdr(p); + } + else pp = p; + for (; is_pair(pp); pp = cdr(pp), np = cdr(np)) + set_cdr(np, list_1(sc, car(pp))); + } + else + { + s7_int len = sequence_length(sc, p); + if (len > 0) + { + if (is_null(tp)) + { + tp = s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused))); + np = tp; + sc->temp8 = tp; + } + else set_cdr(np, s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, p, make_list(sc, len, sc->unused)))); + for (; is_pair(cdr(np)); np = cdr(np)); + } + else + if (len < 0) + { + unstack_gc_protect(sc); + wrong_type_error_nr(sc, sc->append_symbol, position_of(y, args), p, a_sequence_string); + }}}} unstack_gc_protect(sc); return(tp); } @@ -39672,8 +39672,8 @@ static noreturn void typed_vector_type_error_nr(s7_scheme *sc, s7_pointer vec, s { const char *descr = typed_vector_typer_name(sc, vec); error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "vector-set! third argument ~$, is ~A, but the vector's element type checker, ~A, rejects it", 91), - val, type_name_string(sc, val), wrap_string(sc, descr, safe_strlen(descr)))); + set_elist_4(sc, wrap_string(sc, "vector-set! third argument ~$, is ~A, but the vector's element type checker, ~A, rejects it", 91), + val, type_name_string(sc, val), wrap_string(sc, descr, safe_strlen(descr)))); } static inline s7_pointer typed_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) /* tstr faster without inline, but tbig slower */ @@ -39809,8 +39809,8 @@ static s7_pointer make_vector_1(s7_scheme *sc, s7_int len, bool filled, uint8_t out_of_range_error_nr(sc, sc->make_vector_symbol, int_one, wrap_integer(sc, len), it_is_negative_string); if (len > sc->max_vector_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "make-vector length argument ~D is greater than (*s7* 'max-vector-length), ~D", 76), - wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); + set_elist_3(sc, wrap_string(sc, "make-vector length argument ~D is greater than (*s7* 'max-vector-length), ~D", 76), + wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); /* this has to follow the error checks! (else garbage in free_heap temps portion confuses GC when "vector" is finalized) */ new_cell(sc, x, typ | T_SAFE_PROCEDURE); @@ -39824,56 +39824,56 @@ static s7_pointer make_vector_1(s7_scheme *sc, s7_int len, bool filled, uint8_t else if (typ == T_VECTOR) { - block_t *b = inline_mallocate(sc, len * sizeof(s7_pointer)); - vector_block(x) = b; - vector_elements(x) = (s7_pointer *)block_data(b); - vector_getter(x) = t_vector_getter; - vector_setter(x) = t_vector_setter; - if (filled) t_vector_fill(x, sc->nil); + block_t *b = inline_mallocate(sc, len * sizeof(s7_pointer)); + vector_block(x) = b; + vector_elements(x) = (s7_pointer *)block_data(b); + vector_getter(x) = t_vector_getter; + vector_setter(x) = t_vector_setter; + if (filled) t_vector_fill(x, sc->nil); } else if (typ == T_FLOAT_VECTOR) - { - block_t *b = inline_mallocate(sc, len * sizeof(s7_double)); - vector_block(x) = b; - float_vector_floats(x) = (s7_double *)block_data(b); - if (filled) - { - if (STEP_8(len)) - memclr64((void *)float_vector_floats(x), len * sizeof(s7_double)); - else memclr((void *)float_vector_floats(x), len * sizeof(s7_double)); - } - vector_getter(x) = float_vector_getter; - vector_setter(x) = float_vector_setter; - } + { + block_t *b = inline_mallocate(sc, len * sizeof(s7_double)); + vector_block(x) = b; + float_vector_floats(x) = (s7_double *)block_data(b); + if (filled) + { + if (STEP_8(len)) + memclr64((void *)float_vector_floats(x), len * sizeof(s7_double)); + else memclr((void *)float_vector_floats(x), len * sizeof(s7_double)); + } + vector_getter(x) = float_vector_getter; + vector_setter(x) = float_vector_setter; + } else - if (typ == T_INT_VECTOR) - { - block_t *b = inline_mallocate(sc, len * sizeof(s7_int)); - vector_block(x) = b; - int_vector_ints(x) = (s7_int *)block_data(b); - if (filled) - { - if (STEP_8(len)) - memclr64((void *)int_vector_ints(x), len * sizeof(s7_int)); - else memclr((void *)int_vector_ints(x), len * sizeof(s7_int)); - } - vector_getter(x) = int_vector_getter; - vector_setter(x) = int_vector_setter; - } - else /* byte-vector */ - { - block_t *b = mallocate(sc, len); - vector_block(x) = b; - byte_vector_bytes(x) = (uint8_t *)block_data(b); - vector_getter(x) = byte_vector_getter; - vector_setter(x) = byte_vector_setter; - if (filled) - { - if (STEP_64(len)) - memclr64((void *)(byte_vector_bytes(x)), len); - else memclr((void *)(byte_vector_bytes(x)), len); - }} + if (typ == T_INT_VECTOR) + { + block_t *b = inline_mallocate(sc, len * sizeof(s7_int)); + vector_block(x) = b; + int_vector_ints(x) = (s7_int *)block_data(b); + if (filled) + { + if (STEP_8(len)) + memclr64((void *)int_vector_ints(x), len * sizeof(s7_int)); + else memclr((void *)int_vector_ints(x), len * sizeof(s7_int)); + } + vector_getter(x) = int_vector_getter; + vector_setter(x) = int_vector_setter; + } + else /* byte-vector */ + { + block_t *b = mallocate(sc, len); + vector_block(x) = b; + byte_vector_bytes(x) = (uint8_t *)block_data(b); + vector_getter(x) = byte_vector_getter; + vector_setter(x) = byte_vector_setter; + if (filled) + { + if (STEP_64(len)) + memclr64((void *)(byte_vector_bytes(x)), len); + else memclr((void *)(byte_vector_bytes(x)), len); + }} vector_set_dimension_info(x, NULL); return(x); } @@ -39921,12 +39921,12 @@ static vdims_t *make_vdims(s7_scheme *sc, bool elements_should_be_freed, s7_int vdims_rank(v) = dims; vdims_offsets(v) = (s7_int *)(vdims_dims(v) + dims); for (s7_int i = 0; i < dims; i++) - vdims_dims(v)[i] = dim_info[i]; + vdims_dims(v)[i] = dim_info[i]; for (s7_int i = dims - 1; i >= 0; i--) - { - vdims_offsets(v)[i] = offset; - offset *= vdims_dims(v)[i]; - } + { + vdims_offsets(v)[i] = offset; + offset *= vdims_dims(v)[i]; + } return(v); } v = (vdims_t *)mallocate_block(sc); @@ -39986,7 +39986,7 @@ static Vectorized void float_vector_fill(s7_pointer vec, s7_double x) if (x == 0.0) { if (STEP_8(len)) - memclr64((void *)float_vector_floats(vec), len * sizeof(s7_double)); + memclr64((void *)float_vector_floats(vec), len * sizeof(s7_double)); else memclr((void *)float_vector_floats(vec), len * sizeof(s7_double)); } else @@ -39994,9 +39994,9 @@ static Vectorized void float_vector_fill(s7_pointer vec, s7_double x) s7_int i = 0, left = len - 8; s7_double *orig = float_vector_floats(vec); while (i <= left) - LOOP_8(orig[i++] = x); + LOOP_8(orig[i++] = x); for (; i < len; i++) - orig[i] = x; + orig[i] = x; } } @@ -40007,7 +40007,7 @@ static Vectorized void int_vector_fill(s7_pointer vec, s7_int k) if (k == 0) { if (STEP_8(len)) - memclr64((void *)int_vector_ints(vec), len * sizeof(s7_int)); + memclr64((void *)int_vector_ints(vec), len * sizeof(s7_int)); else memclr((void *)int_vector_ints(vec), len * sizeof(s7_int)); } else @@ -40015,9 +40015,9 @@ static Vectorized void int_vector_fill(s7_pointer vec, s7_int k) s7_int i = 0, left = len - 8; s7_int *orig = int_vector_ints(vec); while (i <= left) - LOOP_8(orig[i++] = k); + LOOP_8(orig[i++] = k); for (; i < len; i++) - orig[i] = k; + orig[i] = k; } } @@ -40039,17 +40039,17 @@ void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj) { case T_FLOAT_VECTOR: if (!is_real(obj)) - wrong_type_error_nr(sc, wrap_string(sc, "float-vector fill!", 18), 2, obj, sc->type_names[T_REAL]); + wrong_type_error_nr(sc, wrap_string(sc, "float-vector fill!", 18), 2, obj, sc->type_names[T_REAL]); float_vector_fill(vec, s7_real(obj)); break; case T_INT_VECTOR: if (!s7_is_integer(obj)) /* possibly a bignum */ - wrong_type_error_nr(sc, wrap_string(sc, "int-vector fill!", 16), 2, obj, sc->type_names[T_INTEGER]); + wrong_type_error_nr(sc, wrap_string(sc, "int-vector fill!", 16), 2, obj, sc->type_names[T_INTEGER]); int_vector_fill(vec, s7_integer_clamped_if_gmp(sc, obj)); break; case T_BYTE_VECTOR: if (!is_byte(obj)) - wrong_type_error_nr(sc, wrap_string(sc, "byte-vector fill!", 17), 2, obj, wrap_string(sc, "a byte", 6)); + wrong_type_error_nr(sc, wrap_string(sc, "byte-vector fill!", 17), 2, obj, wrap_string(sc, "a byte", 6)); byte_vector_fill(vec, (uint8_t)s7_integer_clamped_if_gmp(sc, obj)); break; case T_VECTOR: @@ -40085,17 +40085,17 @@ static s7_pointer g_vector_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer a if (is_float_vector(x)) { if (!is_real(fill)) /* possibly a bignum */ - return(method_or_bust(sc, fill, caller, args, sc->type_names[T_REAL], 2)); + return(method_or_bust(sc, fill, caller, args, sc->type_names[T_REAL], 2)); } else if ((is_int_vector(x)) || (is_byte_vector(x))) { - if (!s7_is_integer(fill)) - return(method_or_bust(sc, fill, caller, args, sc->type_names[T_INTEGER], 2)); - if ((is_byte_vector(x)) && - ((s7_integer_clamped_if_gmp(sc, fill) < 0) || (s7_integer_clamped_if_gmp(sc, fill) > 255))) - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "~S second argument, ~S, should fit in an unsigned byte", 54), caller, fill)); + if (!s7_is_integer(fill)) + return(method_or_bust(sc, fill, caller, args, sc->type_names[T_INTEGER], 2)); + if ((is_byte_vector(x)) && + ((s7_integer_clamped_if_gmp(sc, fill) < 0) || (s7_integer_clamped_if_gmp(sc, fill) > 255))) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "~S second argument, ~S, should fit in an unsigned byte", 54), caller, fill)); } end = vector_length(x); if (!is_null(cddr(args))) @@ -40113,36 +40113,36 @@ static s7_pointer g_vector_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer a for (s7_int i = start; i < end; i++) vector_element(x, i) = fill; else if (is_int_vector(x)) - { - s7_int k = s7_integer_clamped_if_gmp(sc, fill); - if (k == 0) - memclr((void *)(int_vector_ints(x) + start), (end - start) * sizeof(s7_int)); - else for (s7_int i = start; i < end; i++) int_vector(x, i) = k; - } + { + s7_int k = s7_integer_clamped_if_gmp(sc, fill); + if (k == 0) + memclr((void *)(int_vector_ints(x) + start), (end - start) * sizeof(s7_int)); + else for (s7_int i = start; i < end; i++) int_vector(x, i) = k; + } else - if (is_float_vector(x)) - { - s7_double y = s7_real(fill); - if (y == 0.0) - memclr((void *)(float_vector_floats(x) + start), (end - start) * sizeof(s7_double)); - else - { - s7_double *orig = float_vector_floats(x); - s7_int left = end - 8; - s7_int i = start; - while (i <= left) - LOOP_8(orig[i++] = y); - for (; i < end; i++) - orig[i] = y; - }} - else - if (is_byte_vector(x)) - { - uint8_t k = (uint8_t)s7_integer_clamped_if_gmp(sc, fill); - if (k == 0) - memclr((void *)(byte_vector_bytes(x) + start), end - start); - else local_memset((void *)(byte_vector_bytes(x) + start), k, end - start); - } + if (is_float_vector(x)) + { + s7_double y = s7_real(fill); + if (y == 0.0) + memclr((void *)(float_vector_floats(x) + start), (end - start) * sizeof(s7_double)); + else + { + s7_double *orig = float_vector_floats(x); + s7_int left = end - 8; + s7_int i = start; + while (i <= left) + LOOP_8(orig[i++] = y); + for (; i < end; i++) + orig[i] = y; + }} + else + if (is_byte_vector(x)) + { + uint8_t k = (uint8_t)s7_integer_clamped_if_gmp(sc, fill); + if (k == 0) + memclr((void *)(byte_vector_bytes(x) + start), end - start); + else local_memset((void *)(byte_vector_bytes(x) + start), k, end - start); + } return(fill); } @@ -40180,26 +40180,26 @@ static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args) { s7_pointer x = car(p); if (!is_any_vector(x)) - { - if (has_active_methods(sc, x)) - { - s7_pointer func = find_method_with_let(sc, x, sc->vector_append_symbol); - if (func != sc->undefined) - { - int32_t k; - s7_pointer v, y; - if (i == 0) - return(s7_apply_function(sc, func, args)); - sc->temp9 = make_list(sc, i, sc->unused); /* we have to copy the arglist here */ - for (k = 0, y = args, v = sc->temp9; k < i; k++, y = cdr(y), v = cdr(v)) - set_car(v, car(y)); - v = g_vector_append(sc, sc->temp9); - y = s7_apply_function(sc, func, set_ulist_1(sc, v, p)); - sc->temp9 = sc->unused; - return(y); - }} - wrong_type_error_nr(sc, sc->vector_append_symbol, i + 1, x, sc->type_names[T_VECTOR]); - }} + { + if (has_active_methods(sc, x)) + { + s7_pointer func = find_method_with_let(sc, x, sc->vector_append_symbol); + if (func != sc->undefined) + { + int32_t k; + s7_pointer v, y; + if (i == 0) + return(s7_apply_function(sc, func, args)); + sc->temp9 = make_list(sc, i, sc->unused); /* we have to copy the arglist here */ + for (k = 0, y = args, v = sc->temp9; k < i; k++, y = cdr(y), v = cdr(v)) + set_car(v, car(y)); + v = g_vector_append(sc, sc->temp9); + y = s7_apply_function(sc, func, set_ulist_1(sc, v, p)); + sc->temp9 = sc->unused; + return(y); + }} + wrong_type_error_nr(sc, sc->vector_append_symbol, i + 1, x, sc->type_names[T_VECTOR]); + }} return(vector_append(sc, args, type(car(args)), sc->vector_append_symbol)); } @@ -40263,7 +40263,7 @@ s7_int s7_vector_dimensions(s7_pointer vec, s7_int *dims, s7_int dims_size) { s7_int lim = vector_ndims(vec); if (lim > dims_size) lim = dims_size; - for (s7_int i = 0; i < lim; i++) dims[i] = vector_dimension(vec, i); + for (s7_int i = 0; i < lim; i++) dims[i] = vector_dimension(vec, i); return(lim); } dims[0] = vector_length(vec); @@ -40284,7 +40284,7 @@ s7_int s7_vector_offsets(s7_pointer vec, s7_int *offs, s7_int offs_size) { s7_int lim = vector_ndims(vec); if (lim > offs_size) lim = offs_size; - for (s7_int i = 0; i < lim; i++) offs[i] = vector_offset(vec, i); + for (s7_int i = 0; i < lim; i++) offs[i] = vector_offset(vec, i); return(lim); } offs[0] = 1; @@ -40308,16 +40308,16 @@ static s7_int flatten_multivector_indices(s7_scheme *sc, s7_pointer vector, s7_i const s7_int *dimensions = vector_dimensions(vector); const s7_int *offsets = vector_offsets(vector); for (i = 0, index = 0; i < indices; i++) - { - s7_int ind = va_arg(ap, s7_int); - if ((ind < 0) || (ind >= dimensions[i])) - { - va_end(ap); - out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i), wrap_integer(sc, ind), (ind < 0) ? it_is_negative_string : it_is_too_large_string); - return(-1); - } - index += (ind * offsets[i]); - }} + { + s7_int ind = va_arg(ap, s7_int); + if ((ind < 0) || (ind >= dimensions[i])) + { + va_end(ap); + out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i), wrap_integer(sc, ind), (ind < 0) ? it_is_negative_string : it_is_too_large_string); + return(-1); + } + index += (ind * offsets[i]); + }} va_end(ap); return(index); } @@ -40356,22 +40356,22 @@ s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect) case T_VECTOR: check_free_heap_size(sc, len); for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, vector_element(vect, i), sc->y); + sc->y = cons_unchecked(sc, vector_element(vect, i), sc->y); break; case T_BYTE_VECTOR: check_free_heap_size(sc, len); for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, small_int(byte_vector(vect, i)), sc->y); + sc->y = cons_unchecked(sc, small_int(byte_vector(vect, i)), sc->y); break; case T_INT_VECTOR: check_free_heap_size(sc, 2 * len); for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, make_integer_unchecked(sc, int_vector(vect, i)), sc->y); + sc->y = cons_unchecked(sc, make_integer_unchecked(sc, int_vector(vect, i)), sc->y); break; case T_FLOAT_VECTOR: check_free_heap_size(sc, 2 * len); for (s7_int i = len - 1; i >= 0; i--) - sc->y = cons_unchecked(sc, make_real_unchecked(sc, float_vector(vect, i)), sc->y); + sc->y = cons_unchecked(sc, make_real_unchecked(sc, float_vector(vect, i)), sc->y); break; } unstack_gc_protect(sc); @@ -40415,9 +40415,9 @@ static s7_pointer g_vector_to_list(s7_scheme *sc, s7_pointer args) } if ((end - start) > sc->max_list_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_5(sc, wrap_string(sc, "vector->list length ~D, (- ~D ~D), is greater than (*s7* 'max-list-length), ~D", 78), - wrap_integer(sc, end - start), wrap_integer(sc, end), wrap_integer(sc, start), - wrap_integer(sc, sc->max_list_length))); + set_elist_5(sc, wrap_string(sc, "vector->list length ~D, (- ~D ~D), is greater than (*s7* 'max-list-length), ~D", 78), + wrap_integer(sc, end - start), wrap_integer(sc, end), wrap_integer(sc, start), + wrap_integer(sc, sc->max_list_length))); check_free_heap_size(sc, end - start); sc->w = sc->nil; @@ -40450,8 +40450,8 @@ static s7_pointer g_string_to_byte_vector(s7_scheme *sc, s7_pointer args) return(method_or_bust_p(sc, str, sc->string_to_byte_vector_symbol, sc->type_names[T_STRING])); if (string_length(str) > sc->max_vector_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "string->byte-vector string is too long: (> ~D ~D) (*s7* 'max-vector-length)", 75), - wrap_integer(sc, string_length(str)), wrap_integer(sc, sc->max_vector_length))); + set_elist_3(sc, wrap_string(sc, "string->byte-vector string is too long: (> ~D ~D) (*s7* 'max-vector-length)", 75), + wrap_integer(sc, string_length(str)), wrap_integer(sc, sc->max_vector_length))); return(s7_copy_1(sc, sc->string_to_byte_vector_symbol, set_plist_2(sc, str, make_simple_byte_vector(sc, string_length(str))))); } @@ -40466,8 +40466,8 @@ static s7_pointer g_byte_vector_to_string(s7_scheme *sc, s7_pointer args) return(method_or_bust_p(sc, v, sc->byte_vector_to_string_symbol, sc->type_names[T_BYTE_VECTOR])); if (byte_vector_length(v) > sc->max_string_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "byte-vector->string byte-vector is too large: (> ~D ~D) (*s7* 'max-string-length)", 81), - wrap_integer(sc, byte_vector_length(v)), wrap_integer(sc, sc->max_string_length))); + set_elist_3(sc, wrap_string(sc, "byte-vector->string byte-vector is too large: (> ~D ~D) (*s7* 'max-string-length)", 81), + wrap_integer(sc, byte_vector_length(v)), wrap_integer(sc, sc->max_string_length))); return(s7_copy_1(sc, sc->byte_vector_to_string_symbol, set_plist_2(sc, v, make_empty_string(sc, byte_vector_length(v), 0)))); } @@ -40484,14 +40484,14 @@ static s7_pointer g_vector(s7_scheme *sc, s7_pointer args) error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "vector contents list is not a proper list", 41))); if (len > sc->max_vector_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 71), - args, wrap_integer(sc, sc->max_vector_length))); + set_elist_3(sc, wrap_string(sc, "vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 71), + args, wrap_integer(sc, sc->max_vector_length))); vec = make_simple_vector(sc, len); if (len > 0) { s7_pointer x = args; for (s7_int i = 0; is_pair(x); x = cdr(x), i++) - vector_element(vec, i) = car(x); + vector_element(vec, i) = car(x); } return(vec); } @@ -40543,22 +40543,22 @@ static s7_pointer g_float_vector(s7_scheme *sc, s7_pointer args) error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "float-vector contents list is not a proper list", 47))); if (len > sc->max_vector_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "float-vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 77), - args, wrap_integer(sc, sc->max_vector_length))); + set_elist_3(sc, wrap_string(sc, "float-vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 77), + args, wrap_integer(sc, sc->max_vector_length))); vec = make_simple_float_vector(sc, len); if (len > 0) { s7_int i = 0; for (s7_pointer x = args; is_pair(x); x = cdr(x), i++) - { /* this used to gc protect vec via sc->w? was that due to very old bignum code in s7_real? */ - s7_pointer p = car(x); - if (is_t_real(p)) - float_vector(vec, i) = real(p); - else - if (is_real(p)) /* bignum is ok here */ - float_vector(vec, i) = s7_real(p); - else return(method_or_bust(sc, p, sc->float_vector_symbol, args, sc->type_names[T_REAL], i + 1)); - }} + { /* this used to gc protect vec via sc->w? was that due to very old bignum code in s7_real? */ + s7_pointer p = car(x); + if (is_t_real(p)) + float_vector(vec, i) = real(p); + else + if (is_real(p)) /* bignum is ok here */ + float_vector(vec, i) = s7_real(p); + else return(method_or_bust(sc, p, sc->float_vector_symbol, args, sc->type_names[T_REAL], i + 1)); + }} return(vec); } @@ -40600,15 +40600,15 @@ static s7_pointer g_int_vector(s7_scheme *sc, s7_pointer args) error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "int-vector contents list is not a proper list", 45))); if (len > sc->max_vector_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "int-vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 75), - args, wrap_integer(sc, sc->max_vector_length))); + set_elist_3(sc, wrap_string(sc, "int-vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 75), + args, wrap_integer(sc, sc->max_vector_length))); vec = make_simple_int_vector(sc, len); if (len == 0) return(vec); for (s7_pointer x = args; is_pair(x); x = cdr(x), i++) { s7_pointer p = car(x); if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->int_vector_symbol, args, sc->type_names[T_INTEGER], i + 1)); + return(method_or_bust(sc, p, sc->int_vector_symbol, args, sc->type_names[T_INTEGER], i + 1)); int_vector(vec, i) = s7_integer_clamped_if_gmp(sc, p); } return(vec); @@ -40646,8 +40646,8 @@ static s7_pointer g_byte_vector(s7_scheme *sc, s7_pointer args) error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "byte-vector contents list is not a proper list", 46))); if (len > sc->max_vector_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "byte-vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 76), - args, wrap_integer(sc, sc->max_vector_length))); + set_elist_3(sc, wrap_string(sc, "byte-vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 76), + args, wrap_integer(sc, sc->max_vector_length))); vec = make_simple_byte_vector(sc, len); str = byte_vector_bytes(vec); for (s7_pointer x = args; is_pair(x); i++, x = cdr(x)) @@ -40655,16 +40655,16 @@ static s7_pointer g_byte_vector(s7_scheme *sc, s7_pointer args) s7_pointer byte = car(x); s7_int b; if (is_t_integer(byte)) - b = integer(byte); + b = integer(byte); else #if WITH_GMP - if (is_t_big_integer(byte)) - b = big_integer_to_s7_int(sc, big_integer(byte)); - else + if (is_t_big_integer(byte)) + b = big_integer_to_s7_int(sc, big_integer(byte)); + else #endif - return(method_or_bust(sc, byte, sc->byte_vector_symbol, args, sc->type_names[T_INTEGER], i + 1)); + return(method_or_bust(sc, byte, sc->byte_vector_symbol, args, sc->type_names[T_INTEGER], i + 1)); if ((b < 0) || (b > 255)) - wrong_type_error_nr(sc, sc->byte_vector_symbol, i + 1, byte, an_unsigned_byte_string); + wrong_type_error_nr(sc, sc->byte_vector_symbol, i + 1, byte, an_unsigned_byte_string); str[i] = (uint8_t)b; } return(vec); @@ -40740,12 +40740,12 @@ static s7_pointer g_subvector_position(s7_scheme *sc, s7_pointer args) * Since we currently let the user reset s7_int and s7_double, all four cases have to be handled explicitly. */ switch (type(sv)) - { - case T_VECTOR: return(make_integer(sc, (s7_int)(vector_elements(sv) - vector_elements(subvector_vector(sv))))); - case T_INT_VECTOR: return(make_integer(sc, (s7_int)(int_vector_ints(sv) - int_vector_ints(subvector_vector(sv))))); - case T_FLOAT_VECTOR: return(make_integer(sc, (s7_int)(float_vector_floats(sv) - float_vector_floats(subvector_vector(sv))))); - case T_BYTE_VECTOR: return(make_integer(sc, (s7_int)(byte_vector_bytes(sv) - byte_vector_bytes(subvector_vector(sv))))); - }} + { + case T_VECTOR: return(make_integer(sc, (s7_int)(vector_elements(sv) - vector_elements(subvector_vector(sv))))); + case T_INT_VECTOR: return(make_integer(sc, (s7_int)(int_vector_ints(sv) - int_vector_ints(subvector_vector(sv))))); + case T_FLOAT_VECTOR: return(make_integer(sc, (s7_int)(float_vector_floats(sv) - float_vector_floats(subvector_vector(sv))))); + case T_BYTE_VECTOR: return(make_integer(sc, (s7_int)(byte_vector_bytes(sv) - byte_vector_bytes(subvector_vector(sv))))); + }} return(sole_arg_method_or_bust(sc, sv, sc->subvector_position_symbol, args, sc->type_names[T_VECTOR])); } @@ -40796,7 +40796,7 @@ static s7_pointer subvector(s7_scheme *sc, s7_pointer vect, s7_int skip_dims, s7 float_vector_floats(x) = (s7_double *)(float_vector_floats(vect) + index); else if (is_t_vector(vect)) - vector_elements(x) = (s7_pointer *)(vector_elements(vect) + index); + vector_elements(x) = (s7_pointer *)(vector_elements(vect) + index); else byte_vector_bytes(x) = (uint8_t *)(byte_vector_bytes(vect) + index); add_multivector(sc, x); return(x); @@ -40849,58 +40849,58 @@ a vector that points to the same elements as the original-vector but with differ { s7_pointer start = cadr(args); if (!s7_is_integer(start)) - return(method_or_bust(sc, start, sc->subvector_symbol, args, sc->type_names[T_INTEGER], 2)); + return(method_or_bust(sc, start, sc->subvector_symbol, args, sc->type_names[T_INTEGER], 2)); offset = s7_integer_clamped_if_gmp(sc, start); if ((offset < 0) || (offset > orig_len)) /* we need this if, for example, offset == 9223372036854775807 */ - out_of_range_error_nr(sc, sc->subvector_symbol, int_two, start, (offset < 0) ? it_is_negative_string : it_is_too_large_string); + out_of_range_error_nr(sc, sc->subvector_symbol, int_two, start, (offset < 0) ? it_is_negative_string : it_is_too_large_string); new_len -= offset; if (is_pair(cddr(args))) /* get end point in vector */ - { - s7_pointer end = caddr(args); - s7_int new_end; - if (!s7_is_integer(end)) - return(method_or_bust(sc, end, sc->subvector_symbol, args, sc->type_names[T_INTEGER], 3)); - new_end = s7_integer_clamped_if_gmp(sc, end); - if ((new_end < 0) || (new_end > orig_len)) - out_of_range_error_nr(sc, sc->subvector_symbol, int_three, end, (new_end < 0) ? it_is_negative_string : it_is_too_large_string); - if (offset > new_end) - out_of_range_error_nr(sc, sc->subvector_symbol, int_two, start, wrap_string(sc, "start point > end point", 23)); - new_len = new_end - offset; - - if (is_pair(cdddr(args))) /* get new dimensions */ - { - s7_pointer dims = cadddr(args); - if ((is_null(dims)) || - (!s7_is_proper_list(sc, dims))) - return(method_or_bust(sc, dims, sc->subvector_symbol, args, sc->type_names[T_PAIR], 4)); - - for (s7_pointer y = dims; is_pair(y); y = cdr(y)) - if ((!s7_is_integer(car(y))) || /* (subvector v '((1 2) (3 4))) */ - (s7_integer_clamped_if_gmp(sc, car(y)) > orig_len) || - (s7_integer_clamped_if_gmp(sc, car(y)) < 0)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_1(sc, wrap_string(sc, "a subvector must fit in the original vector", 43))); - - v = list_to_dims(sc, dims); - if (vdims_rank(v) > sc->max_vector_dimensions) - { - liberate(sc, v); - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "subvector specifies too many dimensions: '~S, but (*s7* 'max-vector-dimensions) is ~D", 85), - dims, wrap_integer(sc, sc->max_vector_dimensions))); - } - new_len = vdims_dims(v)[0]; - for (s7_int i = 1; i < vdims_rank(v); i++) new_len *= vdims_dims(v)[i]; - if (new_len != new_end - offset) - { - liberate(sc, v); /* 14-Sep-23 */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "subvector dimensional length, ~D, does not match the start and end positions: ~S to ~S~%", 88), - wrap_integer(sc, new_len), start, end)); - } - vdims_original(v) = orig; - }}} + { + s7_pointer end = caddr(args); + s7_int new_end; + if (!s7_is_integer(end)) + return(method_or_bust(sc, end, sc->subvector_symbol, args, sc->type_names[T_INTEGER], 3)); + new_end = s7_integer_clamped_if_gmp(sc, end); + if ((new_end < 0) || (new_end > orig_len)) + out_of_range_error_nr(sc, sc->subvector_symbol, int_three, end, (new_end < 0) ? it_is_negative_string : it_is_too_large_string); + if (offset > new_end) + out_of_range_error_nr(sc, sc->subvector_symbol, int_two, start, wrap_string(sc, "start point > end point", 23)); + new_len = new_end - offset; + + if (is_pair(cdddr(args))) /* get new dimensions */ + { + s7_pointer dims = cadddr(args); + if ((is_null(dims)) || + (!s7_is_proper_list(sc, dims))) + return(method_or_bust(sc, dims, sc->subvector_symbol, args, sc->type_names[T_PAIR], 4)); + + for (s7_pointer y = dims; is_pair(y); y = cdr(y)) + if ((!s7_is_integer(car(y))) || /* (subvector v '((1 2) (3 4))) */ + (s7_integer_clamped_if_gmp(sc, car(y)) > orig_len) || + (s7_integer_clamped_if_gmp(sc, car(y)) < 0)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_1(sc, wrap_string(sc, "a subvector must fit in the original vector", 43))); + + v = list_to_dims(sc, dims); + if (vdims_rank(v) > sc->max_vector_dimensions) + { + liberate(sc, v); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "subvector specifies too many dimensions: '~S, but (*s7* 'max-vector-dimensions) is ~D", 85), + dims, wrap_integer(sc, sc->max_vector_dimensions))); + } + new_len = vdims_dims(v)[0]; + for (s7_int i = 1; i < vdims_rank(v); i++) new_len *= vdims_dims(v)[i]; + if (new_len != new_end - offset) + { + liberate(sc, v); /* 14-Sep-23 */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "subvector dimensional length, ~D, does not match the start and end positions: ~S to ~S~%", 88), + wrap_integer(sc, new_len), start, end)); + } + vdims_original(v) = orig; + }}} if (is_t_vector(orig)) mark_function[T_VECTOR] = mark_vector_possibly_shared; @@ -40922,7 +40922,7 @@ a vector that points to the same elements as the original-vector but with differ float_vector_floats(x) = (s7_double *)(float_vector_floats(orig) + offset); else if (is_t_vector(x)) - vector_elements(x) = (s7_pointer *)(vector_elements(orig) + offset); + vector_elements(x) = (s7_pointer *)(vector_elements(orig) + offset); else byte_vector_bytes(x) = (uint8_t *)(byte_vector_bytes(orig) + offset); add_multivector(sc, x); return(x); @@ -40941,29 +40941,29 @@ static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indice s7_int i; s7_pointer x; for (x = indices, i = 0; (is_not_null(x)) && (i < vector_ndims(vect)); x = cdr(x), i++) - { - s7_int n; - s7_pointer p = car(x); - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], i + 2)); + { + s7_int n; + s7_pointer p = car(x); + if (!s7_is_integer(p)) + return(method_or_bust(sc, p, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], i + 2)); n = s7_integer_clamped_if_gmp(sc, p); - if ((n < 0) || (n >= vector_dimension(vect, i))) - out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i + 2), p, (n < 0) ? it_is_negative_string : it_is_too_large_string); + if ((n < 0) || (n >= vector_dimension(vect, i))) + out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i + 2), p, (n < 0) ? it_is_negative_string : it_is_too_large_string); - index += n * vector_offset(vect, i); - } + index += n * vector_offset(vect, i); + } if (is_not_null(x)) - { - s7_pointer nv; - if (!is_t_vector(vect)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S: too many indices: ~S", 24), sc->vector_ref_symbol, copy_proper_list(sc, indices))); - nv = vector_element(vect, index); - return(implicit_index(sc, nv, x)); - } + { + s7_pointer nv; + if (!is_t_vector(vect)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "~S: too many indices: ~S", 24), sc->vector_ref_symbol, copy_proper_list(sc, indices))); + nv = vector_element(vect, index); + return(implicit_index(sc, nv, x)); + } /* if not enough indices, return a subvector covering whatever is left */ if (i < vector_ndims(vect)) - return(subvector(sc, vect, i, index)); + return(subvector(sc, vect, i, index)); } else { @@ -40971,21 +40971,21 @@ static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indice /* (let ((hi (make-vector 3 0.0)) (sum 0.0)) (do ((i 0 (+ i 1))) ((= i 3)) (set! sum (+ sum (hi i)))) sum) */ if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], 2)); + return(method_or_bust(sc, p, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], 2)); index = s7_integer_clamped_if_gmp(sc, p); if ((index < 0) || (index >= vector_length(vect))) - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, p, (index < 0) ? it_is_negative_string : it_is_too_large_string); + out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, p, (index < 0) ? it_is_negative_string : it_is_too_large_string); if (is_not_null(cdr(indices))) /* (let ((L #(#(1 2 3) #(4 5 6)))) (vector-ref L 1 2)) */ - { - s7_pointer nv; - if (!is_t_vector(vect)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S: too many indices: ~S", 24), sc->vector_ref_symbol, copy_proper_list(sc, indices))); - nv = vector_element(vect, index); - return(implicit_pair_index_checked(sc, vect, nv, indices)); - }} + { + s7_pointer nv; + if (!is_t_vector(vect)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "~S: too many indices: ~S", 24), sc->vector_ref_symbol, copy_proper_list(sc, indices))); + nv = vector_element(vect, index); + return(implicit_pair_index_checked(sc, vect, nv, indices)); + }} return((vector_getter(vect))(sc, vect, index)); } @@ -41117,21 +41117,21 @@ static s7_pointer g_vector_set(s7_scheme *sc, s7_pointer args) s7_pointer x; index = 0; for (x = cdr(args), i = 0; (is_not_null(cdr(x))) && (i < vector_ndims(vec)); x = cdr(x), i++) - { - s7_int n; - s7_pointer p = car(x); - if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], i + 2)); + { + s7_int n; + s7_pointer p = car(x); + if (!s7_is_integer(p)) + return(method_or_bust(sc, p, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], i + 2)); n = s7_integer_clamped_if_gmp(sc, p); - if ((n < 0) || (n >= vector_dimension(vec, i))) - out_of_range_error_nr(sc, sc->vector_set_symbol, wrap_integer(sc, i + 2), p, (n < 0) ? it_is_negative_string : it_is_too_large_string); + if ((n < 0) || (n >= vector_dimension(vec, i))) + out_of_range_error_nr(sc, sc->vector_set_symbol, wrap_integer(sc, i + 2), p, (n < 0) ? it_is_negative_string : it_is_too_large_string); - index += n * vector_offset(vec, i); - } + index += n * vector_offset(vec, i); + } if (is_not_null(cdr(x))) - wrong_number_of_arguments_error_nr(sc, "too many arguments for vector-set!: ~S", 38, args); + wrong_number_of_arguments_error_nr(sc, "too many arguments for vector-set!: ~S", 38, args); if (i != vector_ndims(vec)) - wrong_number_of_arguments_error_nr(sc, "not enough arguments for vector-set!: ~S", 40, args); + wrong_number_of_arguments_error_nr(sc, "not enough arguments for vector-set!: ~S", 40, args); /* since vector-ref can return a subvector (if not passed enough args), it might be interesting to * also set a complete subvector via set!, but would that introduce ambiguity? Only copy the vector @@ -41146,18 +41146,18 @@ static s7_pointer g_vector_set(s7_scheme *sc, s7_pointer args) { s7_pointer p = cadr(args); if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); + return(method_or_bust(sc, p, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); index = s7_integer_clamped_if_gmp(sc, p); if ((index < 0) || (index >= vector_length(vec))) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, p, (index < 0) ? it_is_negative_string : it_is_too_large_string); + out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, p, (index < 0) ? it_is_negative_string : it_is_too_large_string); if (is_not_null(cdddr(args))) - { - s7_pointer v = vector_getter(vec)(sc, vec, index); - if (!is_any_vector(v)) - wrong_number_of_arguments_error_nr(sc, "too many arguments for vector-set!: ~S", 38, args); - return(g_vector_set(sc, set_ulist_1(sc, v, cddr(args)))); - } + { + s7_pointer v = vector_getter(vec)(sc, vec, index); + if (!is_any_vector(v)) + wrong_number_of_arguments_error_nr(sc, "too many arguments for vector-set!: ~S", 38, args); + return(g_vector_set(sc, set_ulist_1(sc, v, cddr(args)))); + } val = caddr(args); } if (is_typed_t_vector(vec)) @@ -41199,7 +41199,7 @@ static s7_pointer vector_set_p_piip(s7_scheme *sc, s7_pointer v, s7_int i1, s7_i if (is_t_vector(v)) { if (is_typed_vector(v)) - return(typed_vector_setter(sc, v, i2 + (i1 * vector_offset(v, 0)), p)); + return(typed_vector_setter(sc, v, i2 + (i1 * vector_offset(v, 0)), p)); vector_element(v, i2 + (i1 * vector_offset(v, 0))) = p; } else vector_setter(v)(sc, v, i2 + (i1 * vector_offset(v, 0)), p); @@ -41329,20 +41329,20 @@ static s7_int multivector_length(s7_scheme *sc, s7_pointer x, s7_pointer caller) wrong_type_error_nr(sc, caller, 1, x, a_proper_list_string); if (dims > sc->max_vector_dimensions) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "~S specifies too many dimensions: '~S, but (*s7* 'max-vector-dimensions) is ~D", 78), - x, wrap_integer(sc, sc->max_vector_dimensions))); + set_elist_3(sc, wrap_string(sc, "~S specifies too many dimensions: '~S, but (*s7* 'max-vector-dimensions) is ~D", 78), + x, wrap_integer(sc, sc->max_vector_dimensions))); for (y = x, len = 1; is_pair(y); y = cdr(y)) { if (!s7_is_integer(car(y))) - wrong_type_error_nr(sc, caller, position_of(y, x), car(y), sc->type_names[T_INTEGER]); + wrong_type_error_nr(sc, caller, position_of(y, x), car(y), sc->type_names[T_INTEGER]); #if HAVE_OVERFLOW_CHECKS if (multiply_overflow(len, s7_integer_clamped_if_gmp(sc, car(y)), &len)) /* or better perhaps len > sc->max_vector_length */ - out_of_range_error_nr(sc, caller, wrap_integer(sc, position_of(y, x)), car(y), it_is_too_large_string); + out_of_range_error_nr(sc, caller, wrap_integer(sc, position_of(y, x)), car(y), it_is_too_large_string); #else len *= s7_integer_clamped_if_gmp(sc, car(y)); #endif if (len < 0) - wrong_type_error_nr(sc, caller, position_of(y, x), car(y), a_non_negative_integer_string); + wrong_type_error_nr(sc, caller, position_of(y, x), car(y), a_non_negative_integer_string); } return(len); } @@ -41381,14 +41381,14 @@ static s7_pointer g_make_vector_1(s7_scheme *sc, s7_pointer args, s7_pointer cal { len = s7_integer_clamped_if_gmp(sc, x); if (len < 0) - wrong_type_error_nr(sc, caller, 1, x, a_non_negative_integer_string); + wrong_type_error_nr(sc, caller, 1, x, a_non_negative_integer_string); } else { if (!(is_pair(x))) - return(method_or_bust(sc, x, caller, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); + return(method_or_bust(sc, x, caller, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); if (!s7_is_integer(car(x))) - wrong_type_error_nr(sc, caller, 1, car(x), sc->type_names[T_INTEGER]); + wrong_type_error_nr(sc, caller, 1, car(x), sc->type_names[T_INTEGER]); len = (is_null(cdr(x))) ? s7_integer_clamped_if_gmp(sc, car(x)) : multivector_length(sc, x, caller); } @@ -41396,48 +41396,48 @@ static s7_pointer g_make_vector_1(s7_scheme *sc, s7_pointer args, s7_pointer cal { fill = cadr(args); if (caller == sc->make_int_vector_symbol) - result_type = T_INT_VECTOR; + result_type = T_INT_VECTOR; else - if (caller == sc->make_float_vector_symbol) - result_type = T_FLOAT_VECTOR; - else - if (caller == sc->make_byte_vector_symbol) - result_type = T_BYTE_VECTOR; + if (caller == sc->make_float_vector_symbol) + result_type = T_FLOAT_VECTOR; + else + if (caller == sc->make_byte_vector_symbol) + result_type = T_BYTE_VECTOR; if (is_pair(cddr(args))) - { - typf = caddr(args); - if ((!is_c_function(typf)) && - (!is_any_closure(typf)) && - (typf != sc->T)) /* default value */ - wrong_type_error_nr(sc, caller, 3, typf, wrap_string(sc, "a built-in procedure, a closure or #t", 37)); - if (is_any_closure(typf)) - { - if (!is_symbol(find_closure(sc, typf, closure_let(typf)))) - wrong_type_error_nr(sc, caller, 3, typf, wrap_string(sc, "a named function", 16)); - /* the name is needed primarily by the error handler: "vector-set! third argument, ..., is a ... but should be a <...>" */ - } - else - if (is_c_function(typf)) - { - if (typf == global_value(sc->is_float_symbol)) - { - if (!is_real(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_REAL]); - result_type = T_FLOAT_VECTOR; - } - else - if (typf == global_value(sc->is_integer_symbol)) - { - if (!s7_is_integer(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_INTEGER]); - result_type = (WITH_GMP) ? T_VECTOR : T_INT_VECTOR; - } - else - if (typf == global_value(sc->is_byte_symbol)) - { - if (!is_byte(fill)) wrong_type_error_nr(sc, caller, 2, fill, an_unsigned_byte_string); - result_type = T_BYTE_VECTOR; - } - else check_vector_typer_c_function(sc, caller, typf); - }}} + { + typf = caddr(args); + if ((!is_c_function(typf)) && + (!is_any_closure(typf)) && + (typf != sc->T)) /* default value */ + wrong_type_error_nr(sc, caller, 3, typf, wrap_string(sc, "a built-in procedure, a closure or #t", 37)); + if (is_any_closure(typf)) + { + if (!is_symbol(find_closure(sc, typf, closure_let(typf)))) + wrong_type_error_nr(sc, caller, 3, typf, wrap_string(sc, "a named function", 16)); + /* the name is needed primarily by the error handler: "vector-set! third argument, ..., is a ... but should be a <...>" */ + } + else + if (is_c_function(typf)) + { + if (typf == global_value(sc->is_float_symbol)) + { + if (!is_real(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_REAL]); + result_type = T_FLOAT_VECTOR; + } + else + if (typf == global_value(sc->is_integer_symbol)) + { + if (!s7_is_integer(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_INTEGER]); + result_type = (WITH_GMP) ? T_VECTOR : T_INT_VECTOR; + } + else + if (typf == global_value(sc->is_byte_symbol)) + { + if (!is_byte(fill)) wrong_type_error_nr(sc, caller, 2, fill, an_unsigned_byte_string); + result_type = T_BYTE_VECTOR; + } + else check_vector_typer_c_function(sc, caller, typf); + }}} /* before making the new vector, if fill is specified and the vector is typed, we have to check for a type error. * otherwise we can end up with a vector whose elements are NULL, causing a segfault in the gc. */ @@ -41457,8 +41457,8 @@ static s7_pointer g_make_vector_1(s7_scheme *sc, s7_pointer args, s7_pointer cal typed_vector_set_typer(vec, typf); if ((is_c_function(typf)) && - (c_function_has_simple_elements(typf))) - set_has_simple_elements(vec); + (c_function_has_simple_elements(typf))) + set_has_simple_elements(vec); } s7_vector_fill(sc, vec, fill); if ((is_pair(x)) && @@ -41476,8 +41476,8 @@ To create a multidimensional vector, put the dimension bounds in a list (this is returns a 2 dimensional vector of 6 total elements, all initialized to 1.0. The 'type argument can set the element type. \ It is a function that checks the new value, returning #f if the value is not acceptable: (make-vector 8 1/2 rational?)." #define Q_make_vector s7_make_signature(sc, 4, sc->is_vector_symbol, \ - s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->T, \ - s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_boolean_symbol)) + s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->T, \ + s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_boolean_symbol)) return(g_make_vector_1(sc, args, sc->make_vector_symbol)); } @@ -41496,30 +41496,30 @@ static s7_pointer g_make_float_vector(s7_scheme *sc, s7_pointer args) { s7_pointer init; if (is_pair(cdr(args))) - { - init = cadr(args); - if (!is_real(init)) - return(method_or_bust(sc, init, sc->make_float_vector_symbol, args, sc->type_names[T_REAL], 2)); + { + init = cadr(args); + if (!is_real(init)) + return(method_or_bust(sc, init, sc->make_float_vector_symbol, args, sc->type_names[T_REAL], 2)); #if WITH_GMP - if (s7_is_bignum(init)) - return(g_make_vector_1(sc, set_plist_2(sc, p, wrap_real(sc, s7_real(init))), sc->make_float_vector_symbol)); + if (s7_is_bignum(init)) + return(g_make_vector_1(sc, set_plist_2(sc, p, wrap_real(sc, s7_real(init))), sc->make_float_vector_symbol)); #endif - if (is_rational(init)) - return(g_make_vector_1(sc, set_plist_2(sc, p, wrap_real(sc, rational_to_double(sc, init))), sc->make_float_vector_symbol)); - } + if (is_rational(init)) + return(g_make_vector_1(sc, set_plist_2(sc, p, wrap_real(sc, rational_to_double(sc, init))), sc->make_float_vector_symbol)); + } else init = real_zero; if (s7_is_integer(p)) - len = s7_integer_clamped_if_gmp(sc, p); + len = s7_integer_clamped_if_gmp(sc, p); else - { - if (!is_pair(p)) - return(method_or_bust(sc, p, sc->make_float_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); - len = multivector_length(sc, p, sc->make_float_vector_symbol); - } + { + if (!is_pair(p)) + return(method_or_bust(sc, p, sc->make_float_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); + len = multivector_length(sc, p, sc->make_float_vector_symbol); + } x = make_vector_1(sc, len, NOT_FILLED, T_FLOAT_VECTOR); float_vector_fill(x, s7_real(init)); if (!s7_is_integer(p)) - return(make_multivector(sc, x, p)); + return(make_multivector(sc, x, p)); add_vector(sc, x); return(x); } @@ -41529,8 +41529,8 @@ static s7_pointer g_make_float_vector(s7_scheme *sc, s7_pointer args) out_of_range_error_nr(sc, sc->make_float_vector_symbol, int_one, p, it_is_negative_string); if (len > sc->max_vector_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "make-float-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 81), - wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); + set_elist_3(sc, wrap_string(sc, "make-float-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 81), + wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); arr = mallocate_vector(sc, len * sizeof(s7_double)); new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); @@ -41540,7 +41540,7 @@ static s7_pointer g_make_float_vector(s7_scheme *sc, s7_pointer args) if (len > 0) { if (STEP_8(len)) - memclr64((void *)float_vector_floats(x), len * sizeof(s7_double)); + memclr64((void *)float_vector_floats(x), len * sizeof(s7_double)); else memclr((void *)float_vector_floats(x), len * sizeof(s7_double)); } vector_set_dimension_info(x, NULL); @@ -41579,24 +41579,24 @@ static s7_pointer g_make_int_vector(s7_scheme *sc, s7_pointer args) { s7_pointer init; if (is_pair(cdr(args))) - { - init = cadr(args); - if (!s7_is_integer(init)) - return(method_or_bust(sc, init, sc->make_int_vector_symbol, args, sc->type_names[T_INTEGER], 2)); - } + { + init = cadr(args); + if (!s7_is_integer(init)) + return(method_or_bust(sc, init, sc->make_int_vector_symbol, args, sc->type_names[T_INTEGER], 2)); + } else init = int_zero; if (s7_is_integer(p)) - len = s7_integer_clamped_if_gmp(sc, p); + len = s7_integer_clamped_if_gmp(sc, p); else - { - if (!is_pair(p)) - return(method_or_bust(sc, p, sc->make_int_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); - len = multivector_length(sc, p, sc->make_int_vector_symbol); - } + { + if (!is_pair(p)) + return(method_or_bust(sc, p, sc->make_int_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); + len = multivector_length(sc, p, sc->make_int_vector_symbol); + } x = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR); int_vector_fill(x, s7_integer_clamped_if_gmp(sc, init)); if (!s7_is_integer(p)) - return(make_multivector(sc, x, p)); + return(make_multivector(sc, x, p)); add_vector(sc, x); return(x); } @@ -41606,8 +41606,8 @@ static s7_pointer g_make_int_vector(s7_scheme *sc, s7_pointer args) out_of_range_error_nr(sc, sc->make_int_vector_symbol, int_one, p, it_is_negative_string); if (len > sc->max_vector_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "make-int-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 79), - wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); + set_elist_3(sc, wrap_string(sc, "make-int-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 79), + wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); arr = mallocate_vector(sc, len * sizeof(s7_int)); new_cell(sc, x, T_INT_VECTOR | T_SAFE_PROCEDURE); @@ -41617,7 +41617,7 @@ static s7_pointer g_make_int_vector(s7_scheme *sc, s7_pointer args) if (len > 0) { if (STEP_8(len)) - memclr64((void *)int_vector_ints(x), len * sizeof(s7_int)); + memclr64((void *)int_vector_ints(x), len * sizeof(s7_int)); else memclr((void *)int_vector_ints(x), len * sizeof(s7_int)); } vector_set_dimension_info(x, NULL); @@ -41649,23 +41649,23 @@ static s7_pointer g_make_byte_vector(s7_scheme *sc, s7_pointer args) if (!is_pair(p)) { if (!s7_is_integer(p)) - return(method_or_bust(sc, p, sc->make_byte_vector_symbol, args, sc->type_names[T_INTEGER], 1)); + return(method_or_bust(sc, p, sc->make_byte_vector_symbol, args, sc->type_names[T_INTEGER], 1)); len = s7_integer_clamped_if_gmp(sc, p); if (len < 0) - out_of_range_error_nr(sc, sc->make_byte_vector_symbol, int_one, p, it_is_negative_string); + out_of_range_error_nr(sc, sc->make_byte_vector_symbol, int_one, p, it_is_negative_string); if (len > sc->max_vector_length) - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "make-byte-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 80), - wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "make-byte-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 80), + wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); } if (is_pair(cdr(args))) { init = cadr(args); if (!s7_is_integer(init)) - return(method_or_bust(sc, init, sc->make_byte_vector_symbol, args, sc->type_names[T_INTEGER], 2)); + return(method_or_bust(sc, init, sc->make_byte_vector_symbol, args, sc->type_names[T_INTEGER], 2)); ib = s7_integer_clamped_if_gmp(sc, init); if ((ib < 0) || (ib > 255)) - wrong_type_error_nr(sc, sc->make_byte_vector_symbol, 2, init, an_unsigned_byte_string); + wrong_type_error_nr(sc, sc->make_byte_vector_symbol, 2, init, an_unsigned_byte_string); } else init = int_zero; @@ -41685,8 +41685,8 @@ static s7_pointer make_byte_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init) out_of_range_error_nr(sc, sc->make_byte_vector_symbol, int_one, wrap_integer(sc, len), it_is_negative_string); if (len > sc->max_vector_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "make-byte-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 80), - wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); + set_elist_3(sc, wrap_string(sc, "make-byte-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 80), + wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); if ((init < 0) || (init > 255)) wrong_type_error_nr(sc, sc->make_byte_vector_symbol, 2, wrap_integer(sc, init), an_unsigned_byte_string); p = make_simple_byte_vector(sc, len); @@ -41734,11 +41734,11 @@ static s7_pointer g_vector_dimension(s7_scheme *sc, s7_pointer args) n = s7_integer_clamped_if_gmp(sc, np); if (n < 0) error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "vector-dimension second argument is negative: ~S", 48), np)); + set_elist_2(sc, wrap_string(sc, "vector-dimension second argument is negative: ~S", 48), np)); if (n >= vector_rank(v)) error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "vector-dimension second argument, ~S, should be less than the vector rank, ~D", 77), - np, wrap_integer(sc, vector_rank(v)))); + set_elist_3(sc, wrap_string(sc, "vector-dimension second argument, ~S, should be less than the vector rank, ~D", 77), + np, wrap_integer(sc, vector_rank(v)))); if (vector_has_dimension_info(v)) return(make_integer(sc, vector_dimension(v, n))); return(make_integer(sc, vector_length(v))); @@ -41795,36 +41795,36 @@ static s7_pointer g_set_vector_typer(s7_scheme *sc, s7_pointer args) if (!is_t_vector(v)) { if (((is_int_vector(v)) && (typer != global_value(sc->is_integer_symbol))) || - ((is_float_vector(v)) && (typer != global_value(sc->is_float_symbol))) || - ((is_byte_vector(v)) && (typer != global_value(sc->is_byte_symbol)))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "vector-typer can't set ~S typer to ~S", 37), v, typer)); + ((is_float_vector(v)) && (typer != global_value(sc->is_float_symbol))) || + ((is_byte_vector(v)) && (typer != global_value(sc->is_byte_symbol)))) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "vector-typer can't set ~S typer to ~S", 37), v, typer)); return(typer); } if (is_boolean(typer)) { if (is_typed_vector(v)) - { - typed_vector_set_typer(v, sc->F); - clear_typed_vector(v); - clear_has_simple_elements(v); /* 15-Oct-23 */ - }} + { + typed_vector_set_typer(v, sc->F); + clear_typed_vector(v); + clear_has_simple_elements(v); /* 15-Oct-23 */ + }} else { if (is_c_function(typer)) - check_vector_typer_c_function(sc, sc->vector_typer_symbol, typer); /* this is just error checking */ + check_vector_typer_c_function(sc, sc->vector_typer_symbol, typer); /* this is just error checking */ else - { - if (!is_any_closure(typer)) - wrong_type_error_nr(sc, sc->vector_typer_symbol, 2, typer, wrap_string(sc, "a built-in procedure, a closure, #f or #t", 41)); - if (!is_symbol(find_closure(sc, typer, closure_let(typer)))) - wrong_type_error_nr(sc, sc->vector_typer_symbol, 2, typer, wrap_string(sc, "a named function", 16)); - /* the name is needed primarily by the error handler: "vector-set! second argument, ..., is a ... but should be a <...>" */ - } + { + if (!is_any_closure(typer)) + wrong_type_error_nr(sc, sc->vector_typer_symbol, 2, typer, wrap_string(sc, "a built-in procedure, a closure, #f or #t", 41)); + if (!is_symbol(find_closure(sc, typer, closure_let(typer)))) + wrong_type_error_nr(sc, sc->vector_typer_symbol, 2, typer, wrap_string(sc, "a named function", 16)); + /* the name is needed primarily by the error handler: "vector-set! second argument, ..., is a ... but should be a <...>" */ + } set_typed_vector(v); typed_vector_set_typer(v, typer); if ((is_c_function(typer)) && - (c_function_has_simple_elements(typer))) - set_has_simple_elements(v); + (c_function_has_simple_elements(typer))) + set_has_simple_elements(v); else clear_has_simple_elements(v); /* 15-Oct-23 */ } return(typer); @@ -41845,14 +41845,14 @@ static int32_t traverse_vector_data(s7_scheme *sc, s7_pointer vec, s7_int flat_r for (s7_int i = 0; i < sizes[dimension]; i++, x = cdr(x)) { if (!is_pair(x)) - return(MULTIVECTOR_NOT_ENOUGH_ELEMENTS); + return(MULTIVECTOR_NOT_ENOUGH_ELEMENTS); if (dimension == (dimensions - 1)) - vector_setter(vec)(sc, vec, flat_ref++, car(x)); + vector_setter(vec)(sc, vec, flat_ref++, car(x)); else - { - flat_ref = traverse_vector_data(sc, vec, flat_ref, dimension + 1, dimensions, sizes, car(x)); - if (flat_ref < 0) return(flat_ref); - }} + { + flat_ref = traverse_vector_data(sc, vec, flat_ref, dimension + 1, dimensions, sizes, car(x)); + if (flat_ref < 0) return(flat_ref); + }} return((is_null(x)) ? flat_ref : MULTIVECTOR_TOO_MANY_ELEMENTS); } @@ -41875,8 +41875,8 @@ static s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list) static noreturn void multivector_error_nr(s7_scheme *sc, const char *message, s7_pointer data) { error_nr(sc, sc->read_error_symbol, - set_elist_3(sc, wrap_string(sc, "reading constant vector, ~A: ~A", 31), - s7_make_string_wrapper(sc, message), data)); + set_elist_3(sc, wrap_string(sc, "reading constant vector, ~A: ~A", 31), + s7_make_string_wrapper(sc, message), data)); } static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) @@ -41897,12 +41897,12 @@ 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] */ error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "#nD(...) dimensions, ~A, should be 1 or more", 44), wrap_integer(sc, dims))); + set_elist_2(sc, wrap_string(sc, "#nD(...) dimensions, ~A, should be 1 or more", 44), wrap_integer(sc, dims))); if (dims > sc->max_vector_dimensions) /* probably can't happen -- caught in read_sharp? */ error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "#nD(...) dimensions, ~D, should be less that (*s7* 'max-vector-dimensions): ~D", 78), - wrap_integer(sc, dims), wrap_integer(sc, sc->max_vector_dimensions))); + set_elist_3(sc, wrap_string(sc, "#nD(...) dimensions, ~D, should be less that (*s7* 'max-vector-dimensions): ~D", 78), + wrap_integer(sc, dims), wrap_integer(sc, sc->max_vector_dimensions))); sc->w = sc->nil; if (is_null(data)) /* dims are already 0 (calloc above) */ return(g_make_vector(sc, set_plist_1(sc, make_list(sc, dims, int_zero)))); @@ -41914,11 +41914,11 @@ static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) sc->w = cons(sc, make_integer(sc, sizes[i]), sc->w); x = car(x); if ((i < (dims - 1)) && - (!is_pair(x))) - { - free(sizes); - multivector_error_nr(sc, "we need a list that fully specifies the vector's elements", data); - }} + (!is_pair(x))) + { + free(sizes); + multivector_error_nr(sc, "we need a list that fully specifies the vector's elements", data); + }} vec = g_make_vector(sc, set_plist_1(sc, sc->w = proper_list_reverse_in_place(sc, sc->w))); vec_loc = gc_protect_1(sc, vec); @@ -41988,17 +41988,17 @@ static Vectorized s7_pointer s7_vector_copy_1(s7_scheme *sc, s7_pointer old_vect { s7_pointer *src = (s7_pointer *)vector_elements(old_vect), *dst; if ((is_typed_vector(old_vect)) && (len > 0)) /* preserve the type info as well */ - { - if (vector_rank(old_vect) > 1) - new_vect = g_make_vector(sc, set_plist_3(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), - vector_element(old_vect, 0), typed_vector_typer(old_vect))); - else new_vect = g_make_vector(sc, set_plist_3(sc, make_integer(sc, len), - vector_element(old_vect, 0), typed_vector_typer(old_vect))); - } + { + if (vector_rank(old_vect) > 1) + new_vect = g_make_vector(sc, set_plist_3(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), + vector_element(old_vect, 0), typed_vector_typer(old_vect))); + else new_vect = g_make_vector(sc, set_plist_3(sc, make_integer(sc, len), + vector_element(old_vect, 0), typed_vector_typer(old_vect))); + } else - if (vector_rank(old_vect) > 1) - new_vect = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)))); - else new_vect = make_simple_vector(sc, len); + if (vector_rank(old_vect) > 1) + new_vect = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)))); + else new_vect = make_simple_vector(sc, len); /* here and in vector-fill! we have a problem with bignums -- should new bignums be allocated? (copy_proper_list also) */ dst = (s7_pointer *)vector_elements(new_vect); for (s7_int i = len; i > 0; i--) *dst++ = *src++; @@ -42010,7 +42010,7 @@ static Vectorized s7_pointer s7_vector_copy_1(s7_scheme *sc, s7_pointer old_vect const s7_double *src = (s7_double *)float_vector_floats(old_vect); s7_double *dst; if (vector_rank(old_vect) > 1) - new_vect = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), real_zero), sc->make_float_vector_symbol); + new_vect = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), real_zero), sc->make_float_vector_symbol); else new_vect = make_simple_float_vector(sc, len); dst = (s7_double *)float_vector_floats(new_vect); for (s7_int i = len; i > 0; i--) *dst++ = *src++; /* same speed as memcpy(dst, src, len * sizeof(s7_double)); */ @@ -42022,7 +42022,7 @@ static Vectorized s7_pointer s7_vector_copy_1(s7_scheme *sc, s7_pointer old_vect const s7_int *src = (s7_int *)int_vector_ints(old_vect); s7_int *dst; if (vector_rank(old_vect) > 1) - new_vect = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), int_zero), sc->make_int_vector_symbol); + new_vect = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), int_zero), sc->make_int_vector_symbol); else new_vect = make_simple_int_vector(sc, len); dst = (s7_int *)int_vector_ints(new_vect); for (s7_int i = len; i > 0; i--) *dst++ = *src++; @@ -42034,7 +42034,7 @@ static Vectorized s7_pointer s7_vector_copy_1(s7_scheme *sc, s7_pointer old_vect const uint8_t *src = (const uint8_t *)byte_vector_bytes(old_vect); uint8_t *dst; if (vector_rank(old_vect) > 1) - new_vect = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), int_zero), sc->make_byte_vector_symbol); + new_vect = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vect)), int_zero), sc->make_byte_vector_symbol); else new_vect = make_simple_byte_vector(sc, len); dst = (uint8_t *)byte_vector_bytes(new_vect); for (s7_int i = len; i > 0; i--) *dst++ = *src++; @@ -42057,12 +42057,12 @@ static s7_pointer univect_ref(s7_scheme *sc, s7_pointer args, s7_pointer caller, { index = cadr(args); if (!s7_is_integer(index)) - return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], 2)); + return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], 2)); ind = s7_integer_clamped_if_gmp(sc, index); if ((ind < 0) || (ind >= vector_length(v))) - sole_arg_out_of_range_error_nr(sc, caller, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + sole_arg_out_of_range_error_nr(sc, caller, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); if (!is_null(cddr(args))) - out_of_range_error_nr(sc, caller, int_two, cdr(args), too_many_indices_string); + out_of_range_error_nr(sc, caller, int_two, cdr(args), too_many_indices_string); } else { @@ -42070,22 +42070,22 @@ static s7_pointer univect_ref(s7_scheme *sc, s7_pointer args, s7_pointer caller, s7_pointer x; ind = 0; for (x = cdr(args), i = 0; (is_not_null(x)) && (i < vector_ndims(v)); x = cdr(x), i++) - { - s7_int n; - index = car(x); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], i + 2)); - n = s7_integer_clamped_if_gmp(sc, index); - if ((n < 0) || (n >= vector_dimension(v, i))) - out_of_range_error_nr(sc, caller, wrap_integer(sc, i + 2), index, (n < 0) ? it_is_negative_string : it_is_too_large_string); - ind += n * vector_offset(v, i); - } + { + s7_int n; + index = car(x); + if (!s7_is_integer(index)) + return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], i + 2)); + n = s7_integer_clamped_if_gmp(sc, index); + if ((n < 0) || (n >= vector_dimension(v, i))) + out_of_range_error_nr(sc, caller, wrap_integer(sc, i + 2), index, (n < 0) ? it_is_negative_string : it_is_too_large_string); + ind += n * vector_offset(v, i); + } if (is_not_null(x)) - out_of_range_error_nr(sc, caller, int_two, cdr(args), too_many_indices_string); + out_of_range_error_nr(sc, caller, int_two, cdr(args), too_many_indices_string); /* if not enough indices, return a subvector covering whatever is left */ if (i < vector_ndims(v)) - return(subvector(sc, v, i, ind)); + return(subvector(sc, v, i, ind)); } if (typ == T_FLOAT_VECTOR) return(make_real(sc, float_vector(v, ind))); @@ -42108,58 +42108,58 @@ static s7_pointer univect_set(s7_scheme *sc, s7_pointer args, s7_pointer caller, s7_pointer x; ind = 0; for (x = cdr(args), i = 0; (is_not_null(cdr(x))) && (i < vector_ndims(vec)); x = cdr(x), i++) - { - s7_int n; - index = car(x); - if (!s7_is_integer(index)) - return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], i + 2)); - n = s7_integer_clamped_if_gmp(sc, index); - if ((n < 0) || (n >= vector_dimension(vec, i))) - out_of_range_error_nr(sc, caller, wrap_integer(sc, i + 2), index, (n < 0) ? it_is_negative_string : it_is_too_large_string); - ind += n * vector_offset(vec, i); - } + { + s7_int n; + index = car(x); + if (!s7_is_integer(index)) + return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], i + 2)); + n = s7_integer_clamped_if_gmp(sc, index); + if ((n < 0) || (n >= vector_dimension(vec, i))) + out_of_range_error_nr(sc, caller, wrap_integer(sc, i + 2), index, (n < 0) ? it_is_negative_string : it_is_too_large_string); + ind += n * vector_offset(vec, i); + } if (is_not_null(cdr(x))) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "too many arguments for ~A: ~S", 29), caller, args)); + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "too many arguments for ~A: ~S", 29), caller, args)); if (i != vector_ndims(vec)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "not enough arguments for ~A: ~S", 31), caller, args)); + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "not enough arguments for ~A: ~S", 31), caller, args)); val = car(x); } else { s7_pointer p = cdr(args); if (is_null(p)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "not enough arguments for ~A: ~S", 31), caller, args)); + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, wrap_string(sc, "not enough arguments for ~A: ~S", 31), caller, args)); /* from (set! (v) val) after optimization into op_set_opsq_a which is completely confused -- set! gets v's setter (float-vector-set!) */ index = car(p); if (!s7_is_integer(index)) - return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], 2)); + return(method_or_bust(sc, index, caller, args, sc->type_names[T_INTEGER], 2)); ind = s7_integer_clamped_if_gmp(sc, index); if ((ind < 0) || (ind >= vector_length(vec))) - out_of_range_error_nr(sc, caller, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + out_of_range_error_nr(sc, caller, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); if (is_not_null(cddr(p))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "too many arguments for ~A: ~S", 29), caller, args)); + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "too many arguments for ~A: ~S", 29), caller, args)); val = cadr(p); } if (typ == T_FLOAT_VECTOR) { if (!is_real(val)) - return(method_or_bust(sc, val, caller, args, sc->type_names[T_REAL], 3)); + return(method_or_bust(sc, val, caller, args, sc->type_names[T_REAL], 3)); float_vector(vec, ind) = s7_real(val); } else if (typ == T_INT_VECTOR) { - if (!s7_is_integer(val)) - return(method_or_bust(sc, val, caller, args, sc->type_names[T_INTEGER], 3)); - int_vector(vec, ind) = s7_integer_clamped_if_gmp(sc, val); + if (!s7_is_integer(val)) + return(method_or_bust(sc, val, caller, args, sc->type_names[T_INTEGER], 3)); + int_vector(vec, ind) = s7_integer_clamped_if_gmp(sc, val); } else { - if (!is_byte(val)) - return(method_or_bust(sc, val, caller, args, sc->type_names[T_INTEGER], 3)); - byte_vector(vec, ind) = (uint8_t)s7_integer_clamped_if_gmp(sc, val); + if (!is_byte(val)) + return(method_or_bust(sc, val, caller, args, sc->type_names[T_INTEGER], 3)); + byte_vector(vec, ind) = (uint8_t)s7_integer_clamped_if_gmp(sc, val); } return(val); } @@ -42309,19 +42309,19 @@ static bool find_matching_ref(s7_scheme *sc, const s7_pointer getter, s7_pointer { s7_pointer val = cadddr(expr); if (is_optimized(val)) /* includes is_pair */ - for (s7_pointer p = val; is_pair(p); p = cdr(p)) - if (is_pair(car(p))) - { - s7_pointer ref = car(p); - if (((car(ref) == getter) && /* (getter v ind) */ - (is_proper_list_2(sc, cdr(ref))) && - (cadr(ref) == v) && - (caddr(ref) == ind)) || - ((car(ref) == v) && /* (v ind) */ - (is_proper_list_1(sc, cdr(ref))) && - (cadr(ref) == ind))) - return(true); - }} + for (s7_pointer p = val; is_pair(p); p = cdr(p)) + if (is_pair(car(p))) + { + s7_pointer ref = car(p); + if (((car(ref) == getter) && /* (getter v ind) */ + (is_proper_list_2(sc, cdr(ref))) && + (cadr(ref) == v) && + (caddr(ref) == ind)) || + ((car(ref) == v) && /* (v ind) */ + (is_proper_list_1(sc, cdr(ref))) && + (cadr(ref) == ind))) + return(true); + }} return(false); } @@ -42501,28 +42501,28 @@ static s7_pointer int_vector_set_p_ppp(s7_scheme *sc, s7_pointer v, s7_pointer i { s7_int i = integer(index); if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (i < 0) ? it_is_negative_string : it_is_too_large_string); + out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (i < 0) ? it_is_negative_string : it_is_too_large_string); int_vector(v, i) = integer(val); } else { if (!is_int_vector(v)) - return(method_or_bust_ppp(sc, v, sc->int_vector_set_symbol, v, index, val, sc->type_names[T_INT_VECTOR], 1)); + return(method_or_bust_ppp(sc, v, sc->int_vector_set_symbol, v, index, val, sc->type_names[T_INT_VECTOR], 1)); if (vector_rank(v) != 1) - return(univect_set(sc, set_plist_3(sc, v, index, val), sc->int_vector_set_symbol, T_INT_VECTOR)); + return(univect_set(sc, set_plist_3(sc, v, index, val), sc->int_vector_set_symbol, T_INT_VECTOR)); if (is_immutable_vector(v)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->int_vector_set_symbol, v)); + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->int_vector_set_symbol, v)); /* (int-vector-set! #i() `(x 1) (abs x)) in a do loop in a function... */ if (!s7_is_integer(index)) - return(method_or_bust_ppp(sc, index, sc->int_vector_set_symbol, v, index, val, sc->type_names[T_INTEGER], 2)); + return(method_or_bust_ppp(sc, index, sc->int_vector_set_symbol, v, index, val, sc->type_names[T_INTEGER], 2)); if (!s7_is_integer(val)) - return(method_or_bust_ppp(sc, val, sc->int_vector_set_symbol, v, index, val, sc->type_names[T_INTEGER], 3)); + return(method_or_bust_ppp(sc, val, sc->int_vector_set_symbol, v, index, val, sc->type_names[T_INTEGER], 3)); #if WITH_GMP { - s7_int i = s7_integer_clamped_if_gmp(sc, index); - if ((i < 0) || (i >= vector_length(v))) - out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (i < 0) ? it_is_negative_string : it_is_too_large_string); - int_vector(v, i) = s7_integer_clamped_if_gmp(sc, val); + s7_int i = s7_integer_clamped_if_gmp(sc, index); + if ((i < 0) || (i >= vector_length(v))) + out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (i < 0) ? it_is_negative_string : it_is_too_large_string); + int_vector(v, i) = s7_integer_clamped_if_gmp(sc, val); } #else if (S7_DEBUGGING) fprintf(stderr, "fell through %s[%d]\n", __func__, __LINE__); @@ -42840,34 +42840,34 @@ static void local_qsort_r(void *base, size_t nmemb, size_t size, int32_t (*compa nmemb /= 4; h = nmemb + 1; for (t = 1; nmemb != 0; nmemb /= 4) - t *= 2; + t *= 2; do { - size_t bytes = h * size; - uint8_t *i = (uint8_t *)(array + bytes); - uint8_t *k; - do { - uint8_t *j = (uint8_t *)(i - bytes); - if (compar(j, i, arg) > 0) - { - k = i; - do { - uint8_t *p1 = j, *p2 = k; - uint8_t *end = (uint8_t *)(p2 + size); - do { - uint8_t swap = *p1; - *p1++ = *p2; - *p2++ = swap; - } while (p2 != end); - if (bytes + array > j) - break; - k = j; - j -= bytes; - } while (compar(j, k, arg) > 0); - } - i += size; - } while (i != after); - t /= 2; - h = t * t - t * 3 / 2 + 1; + size_t bytes = h * size; + uint8_t *i = (uint8_t *)(array + bytes); + uint8_t *k; + do { + uint8_t *j = (uint8_t *)(i - bytes); + if (compar(j, i, arg) > 0) + { + k = i; + do { + uint8_t *p1 = j, *p2 = k; + uint8_t *end = (uint8_t *)(p2 + size); + do { + uint8_t swap = *p1; + *p1++ = *p2; + *p2++ = swap; + } while (p2 != end); + if (bytes + array > j) + break; + k = j; + j -= bytes; + } while (compar(j, k, arg) > 0); + } + i += size; + } while (i != after); + t /= 2; + h = t * t - t * 3 / 2 + 1; } while (t != 0); } #endif @@ -43015,9 +43015,9 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) /* (apply sort! () #f) should be an error I think */ lessp = cadr(args); if (type(lessp) < T_CONTINUATION) - return(method_or_bust(sc, lessp, sc->sort_symbol, args, a_procedure_string, 2)); + return(method_or_bust(sc, lessp, sc->sort_symbol, args, a_procedure_string, 2)); if (!s7_is_aritable(sc, lessp, 2)) - wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, an_eq_func_string); + wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, an_eq_func_string); return(sc->nil); } @@ -43040,159 +43040,159 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) { s7_pointer sig = c_function_signature(lessp); if ((sig) && - (is_pair(sig)) && - (car(sig) != sc->is_boolean_symbol)) - wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, - wrap_string(sc, "sort! function should return a boolean", 38)); + (is_pair(sig)) && + (car(sig) != sc->is_boolean_symbol)) + wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, + wrap_string(sc, "sort! function should return a boolean", 38)); sc->sort_f = s7_b_7pp_function(lessp); if (sc->sort_f) sort_func = (sc->sort_f == lt_b_7pp) ? vector_sort_lt : vector_sort; } else { if (is_closure(lessp)) - { - s7_pointer expr = car(closure_body(lessp)); - s7_pointer largs = closure_args(lessp); - - if ((is_pair(largs)) && /* closure args not a symbol, etc */ - (!arglist_has_rest(sc, largs))) - { - if ((is_null(cdr(closure_body(lessp)))) && - (is_optimized(expr)) && - (is_safe_c_op(optimize_op(expr))) && - /* since (sort seq (lambda (a b) ...)) can't return a "safe closure" (the hop bit is off in - * optimize in this case, for some arcane reason), the optimized expression won't be hop_safe, - * but that is irrelevant at this point -- if c_function_is_ok, we're good to go. - */ - ((op_has_hop(expr)) || - ((is_global(car(expr))) && /* (sort! x (lambda (car y) (car x)...))! */ - (c_function_is_ok(sc, expr))))) - { - int32_t orig_data = optimize_op(expr); - set_optimize_op(expr, optimize_op(expr) | 1); - if ((optimize_op(expr) == HOP_SAFE_C_SS) && - (car(largs) == cadr(expr)) && - (cadr(largs) == caddr(expr))) - { - s7_pointer lp = lookup(sc, car(expr)); - sc->sort_f = s7_b_7pp_function(lp); - if (sc->sort_f) - { - sort_func = (sc->sort_f == lt_b_7pp) ? vector_sort_lt : vector_sort; - lessp = lp; - }} - else - if ((optimize_op(expr) == HOP_SAFE_C_opSq_opSq) && - ((caadr(expr) == sc->car_symbol) || (caadr(expr) == sc->cdr_symbol)) && - (caadr(expr) == caaddr(expr)) && - (car(largs) == cadadr(expr)) && - (cadr(largs) == cadaddr(expr))) - { - s7_pointer lp = lookup(sc, car(expr)); - sc->sort_f = s7_b_7pp_function(lp); - if (sc->sort_f) - { - sort_func = ((caadr(expr) == sc->car_symbol) ? vector_car_sort : vector_cdr_sort); - lessp = lp; - }} - set_optimize_op(expr, orig_data); - } - - if (!sort_func) - { - s7_pointer init_val, old_e = sc->curlet; - if (is_float_vector(data)) - init_val = real_zero; - else init_val = ((is_int_vector(data)) || (is_byte_vector(data))) ? int_zero : sc->F; - set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(lessp), car(largs), init_val, cadr(largs), init_val)); - sc->sort_body = expr; - sc->sort_v1 = let_slots(sc->curlet); - sc->sort_v2 = next_slot(let_slots(sc->curlet)); - if (is_null(cdr(closure_body(lessp)))) - { - if (!no_bool_opt(closure_body(lessp))) - { - s7_pfunc sf1 = s7_bool_optimize(sc, closure_body(lessp)); - if (sf1) - { - 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 - { - sc->sort_body_len = s7_list_length(sc, closure_body(lessp)); - if (sc->sort_body_len < (NUM_VUNIONS - SORT_O1)) - { - s7_pointer p; - int32_t ctr; - opt_info *top; - sc->pc = 0; - top = alloc_opt_info(sc); - for (ctr = SORT_O1, p = closure_body(lessp); is_pair(cdr(p)); ctr++, p = cdr(p)) - { - top->v[ctr].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - } - if (is_null(cdr(p))) - { - int32_t 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 - { - sc->pc = start; - if (cell_optimize(sc, p)) - sort_func = opt_begin_bool_sort_p; - }}}} - if (!sort_func) - set_curlet(sc, old_e); - } - if ((!sort_func) && - (is_safe_closure(lessp))) /* no embedded sort! or call/cc, etc */ - { - set_curlet(sc, make_let_with_two_slots(sc, closure_let(lessp), car(largs), sc->F, cadr(largs), sc->F)); - sc->sort_body = car(closure_body(lessp)); - sc->sort_begin = cdr(closure_body(lessp)); - sort_func = (is_null(sc->sort_begin)) ? closure_sort : closure_sort_begin; - sc->sort_op = (is_syntactic_pair(sc->sort_body)) ? (opcode_t)optimize_op(sc->sort_body) : (opcode_t)OP_EVAL; - sc->sort_v1 = let_slots(sc->curlet); - sc->sort_v2 = next_slot(let_slots(sc->curlet)); - }}}} + { + s7_pointer expr = car(closure_body(lessp)); + s7_pointer largs = closure_args(lessp); + + if ((is_pair(largs)) && /* closure args not a symbol, etc */ + (!arglist_has_rest(sc, largs))) + { + if ((is_null(cdr(closure_body(lessp)))) && + (is_optimized(expr)) && + (is_safe_c_op(optimize_op(expr))) && + /* since (sort seq (lambda (a b) ...)) can't return a "safe closure" (the hop bit is off in + * optimize in this case, for some arcane reason), the optimized expression won't be hop_safe, + * but that is irrelevant at this point -- if c_function_is_ok, we're good to go. + */ + ((op_has_hop(expr)) || + ((is_global(car(expr))) && /* (sort! x (lambda (car y) (car x)...))! */ + (c_function_is_ok(sc, expr))))) + { + int32_t orig_data = optimize_op(expr); + set_optimize_op(expr, optimize_op(expr) | 1); + if ((optimize_op(expr) == HOP_SAFE_C_SS) && + (car(largs) == cadr(expr)) && + (cadr(largs) == caddr(expr))) + { + s7_pointer lp = lookup(sc, car(expr)); + sc->sort_f = s7_b_7pp_function(lp); + if (sc->sort_f) + { + sort_func = (sc->sort_f == lt_b_7pp) ? vector_sort_lt : vector_sort; + lessp = lp; + }} + else + if ((optimize_op(expr) == HOP_SAFE_C_opSq_opSq) && + ((caadr(expr) == sc->car_symbol) || (caadr(expr) == sc->cdr_symbol)) && + (caadr(expr) == caaddr(expr)) && + (car(largs) == cadadr(expr)) && + (cadr(largs) == cadaddr(expr))) + { + s7_pointer lp = lookup(sc, car(expr)); + sc->sort_f = s7_b_7pp_function(lp); + if (sc->sort_f) + { + sort_func = ((caadr(expr) == sc->car_symbol) ? vector_car_sort : vector_cdr_sort); + lessp = lp; + }} + set_optimize_op(expr, orig_data); + } + + if (!sort_func) + { + s7_pointer init_val, old_e = sc->curlet; + if (is_float_vector(data)) + init_val = real_zero; + else init_val = ((is_int_vector(data)) || (is_byte_vector(data))) ? int_zero : sc->F; + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(lessp), car(largs), init_val, cadr(largs), init_val)); + sc->sort_body = expr; + sc->sort_v1 = let_slots(sc->curlet); + sc->sort_v2 = next_slot(let_slots(sc->curlet)); + if (is_null(cdr(closure_body(lessp)))) + { + if (!no_bool_opt(closure_body(lessp))) + { + s7_pfunc sf1 = s7_bool_optimize(sc, closure_body(lessp)); + if (sf1) + { + 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 + { + sc->sort_body_len = s7_list_length(sc, closure_body(lessp)); + if (sc->sort_body_len < (NUM_VUNIONS - SORT_O1)) + { + s7_pointer p; + int32_t ctr; + opt_info *top; + sc->pc = 0; + top = alloc_opt_info(sc); + for (ctr = SORT_O1, p = closure_body(lessp); is_pair(cdr(p)); ctr++, p = cdr(p)) + { + top->v[ctr].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } + if (is_null(cdr(p))) + { + int32_t 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 + { + sc->pc = start; + if (cell_optimize(sc, p)) + sort_func = opt_begin_bool_sort_p; + }}}} + if (!sort_func) + set_curlet(sc, old_e); + } + if ((!sort_func) && + (is_safe_closure(lessp))) /* no embedded sort! or call/cc, etc */ + { + set_curlet(sc, make_let_with_two_slots(sc, closure_let(lessp), car(largs), sc->F, cadr(largs), sc->F)); + sc->sort_body = car(closure_body(lessp)); + sc->sort_begin = cdr(closure_body(lessp)); + sort_func = (is_null(sc->sort_begin)) ? closure_sort : closure_sort_begin; + sc->sort_op = (is_syntactic_pair(sc->sort_body)) ? (opcode_t)optimize_op(sc->sort_body) : (opcode_t)OP_EVAL; + sc->sort_v1 = let_slots(sc->curlet); + sc->sort_v2 = next_slot(let_slots(sc->curlet)); + }}}} switch (type(data)) { case T_PAIR: len = s7_list_length(sc, data); /* 0 here == infinite */ if (len <= 0) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "sort! first argument should be a proper list: ~S", 48), data)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "sort! first argument should be a proper list: ~S", 48), data)); if (len < 2) - return(data); + return(data); if (sort_func) - { - s7_int i = 0; - s7_pointer vec = g_vector(sc, data); - gc_protect_2_via_stack(sc, vec, data); - elements = s7_vector_elements(vec); - local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); - for (s7_pointer p = data; i < len; i++, p = cdr(p)) - { - if (is_immutable_pair(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, data)); - set_car(p, elements[i]); - } - unstack_gc_protect(sc); /* not pop_stack! */ - return(data); - } + { + s7_int i = 0; + s7_pointer vec = g_vector(sc, data); + gc_protect_2_via_stack(sc, vec, data); + elements = s7_vector_elements(vec); + local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); + for (s7_pointer p = data; i < len; i++, p = cdr(p)) + { + if (is_immutable_pair(p)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, data)); + set_car(p, elements[i]); + } + unstack_gc_protect(sc); /* not pop_stack! */ + return(data); + } push_stack(sc, OP_SORT_PAIR_END, cons(sc, data, lessp), sc->code); /* save and gc protect the original list and func */ set_car(args, g_vector(sc, data)); break; @@ -43200,154 +43200,154 @@ static s7_pointer g_sort(s7_scheme *sc, s7_pointer args) case T_BYTE_VECTOR: case T_STRING: { - s7_int i; - s7_pointer vec; - uint8_t *chrs; - if (is_string(data)) - { - len = string_length(data); - chrs = (uint8_t *)string_value(data); - } - else - { - len = byte_vector_length(data); - chrs = byte_vector_bytes(data); - } - if (len < 2) return(data); - if (is_c_function(lessp)) - { - if (((is_string(data)) && (sc->sort_f == char_lt_b_7pp)) || - ((is_byte_vector(data)) && (sc->sort_f == lt_b_7pp))) - { - qsort((void *)chrs, len, sizeof(uint8_t), byte_less); - return(data); - } - if (((is_string(data)) && (sc->sort_f == char_gt_b_7pp)) || - ((is_byte_vector(data)) && (sc->sort_f == gt_b_7pp))) - { - qsort((void *)chrs, len, sizeof(uint8_t), byte_greater); - return(data); - }} - vec = make_simple_vector(sc, len); - gc_protect_2_via_stack(sc, vec, data); - elements = s7_vector_elements(vec); - if (is_byte_vector(data)) - for (i = 0; i < len; i++) elements[i] = small_int(chrs[i]); - else for (i = 0; i < len; i++) elements[i] = chars[chrs[i]]; - if (sort_func) - { - local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); - if (is_byte_vector(data)) - for (i = 0; i < len; i++) chrs[i] = (char)integer(elements[i]); - else for (i = 0; i < len; i++) chrs[i] = character(elements[i]); - unstack_gc_protect(sc); /* not pop_stack! */ - return(data); - } - unstack_gc_protect(sc); /* not pop_stack! */ - push_stack(sc, OP_SORT_STRING_END, cons_unchecked(sc, data, lessp), sc->code); - set_car(args, vec); + s7_int i; + s7_pointer vec; + uint8_t *chrs; + if (is_string(data)) + { + len = string_length(data); + chrs = (uint8_t *)string_value(data); + } + else + { + len = byte_vector_length(data); + chrs = byte_vector_bytes(data); + } + if (len < 2) return(data); + if (is_c_function(lessp)) + { + if (((is_string(data)) && (sc->sort_f == char_lt_b_7pp)) || + ((is_byte_vector(data)) && (sc->sort_f == lt_b_7pp))) + { + qsort((void *)chrs, len, sizeof(uint8_t), byte_less); + return(data); + } + if (((is_string(data)) && (sc->sort_f == char_gt_b_7pp)) || + ((is_byte_vector(data)) && (sc->sort_f == gt_b_7pp))) + { + qsort((void *)chrs, len, sizeof(uint8_t), byte_greater); + return(data); + }} + vec = make_simple_vector(sc, len); + gc_protect_2_via_stack(sc, vec, data); + elements = s7_vector_elements(vec); + if (is_byte_vector(data)) + for (i = 0; i < len; i++) elements[i] = small_int(chrs[i]); + else for (i = 0; i < len; i++) elements[i] = chars[chrs[i]]; + if (sort_func) + { + local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); + if (is_byte_vector(data)) + for (i = 0; i < len; i++) chrs[i] = (char)integer(elements[i]); + else for (i = 0; i < len; i++) chrs[i] = character(elements[i]); + unstack_gc_protect(sc); /* not pop_stack! */ + return(data); + } + unstack_gc_protect(sc); /* not pop_stack! */ + push_stack(sc, OP_SORT_STRING_END, cons_unchecked(sc, data, lessp), sc->code); + set_car(args, vec); } break; case T_INT_VECTOR: case T_FLOAT_VECTOR: { - s7_int i; - s7_pointer vec; - len = vector_length(data); - if (len < 2) - return(data); - if (is_c_function(lessp)) - { - if (sc->sort_f == lt_b_7pp) - { - if (is_float_vector(data)) - qsort((void *)float_vector_floats(data), len, sizeof(s7_double), dbl_less); - else qsort((void *)int_vector_ints(data), len, sizeof(s7_int), int_less); - return(data); - } - if (sc->sort_f == gt_b_7pp) - { - if (is_float_vector(data)) - qsort((void *)float_vector_floats(data), len, sizeof(s7_double), dbl_greater); - else qsort((void *)int_vector_ints(data), len, sizeof(s7_int), int_greater); - return(data); - }} - /* currently we have to make the ordinary vector here even if not sf1 - * because the sorter uses vector_element to access sort args (see SORT_DATA in eval). - * This is probably better than passing down getter/setter (fewer allocations). - * get/set macro in eval is SORT_DATA(k) then s7_vector_to_list if pair at start (sort_*_end) - */ - vec = make_vector_1(sc, len, FILLED, T_VECTOR); - gc_protect_2_via_stack(sc, vec, data); - /* we need this vector prefilled because make_real|integer below can cause a GC at any time during that loop, - * and the GC mark process expects the vector to have an s7_pointer at every element. - */ - add_vector(sc, vec); - elements = s7_vector_elements(vec); - check_free_heap_size(sc, len); - if (is_float_vector(data)) - for (i = 0; i < len; i++) elements[i] = make_real_unchecked(sc, float_vector(data, i)); - else for (i = 0; i < len; i++) elements[i] = make_integer_unchecked(sc, int_vector(data, i)); - if (sort_func) - { - local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); - if (is_float_vector(data)) - for (i = 0; i < len; i++) float_vector(data, i) = real(elements[i]); - else for (i = 0; i < len; i++) int_vector(data, i) = integer(elements[i]); - unstack_gc_protect(sc); - return(data); - } - set_car(args, vec); - init_temp(sc->y, cons(sc, data, lessp)); - unstack_gc_protect(sc); - push_stack(sc, OP_SORT_VECTOR_END, sc->y, sc->code); /* save and gc protect the original homogeneous vector and func */ - sc->y = sc->unused; + s7_int i; + s7_pointer vec; + len = vector_length(data); + if (len < 2) + return(data); + if (is_c_function(lessp)) + { + if (sc->sort_f == lt_b_7pp) + { + if (is_float_vector(data)) + qsort((void *)float_vector_floats(data), len, sizeof(s7_double), dbl_less); + else qsort((void *)int_vector_ints(data), len, sizeof(s7_int), int_less); + return(data); + } + if (sc->sort_f == gt_b_7pp) + { + if (is_float_vector(data)) + qsort((void *)float_vector_floats(data), len, sizeof(s7_double), dbl_greater); + else qsort((void *)int_vector_ints(data), len, sizeof(s7_int), int_greater); + return(data); + }} + /* currently we have to make the ordinary vector here even if not sf1 + * because the sorter uses vector_element to access sort args (see SORT_DATA in eval). + * This is probably better than passing down getter/setter (fewer allocations). + * get/set macro in eval is SORT_DATA(k) then s7_vector_to_list if pair at start (sort_*_end) + */ + vec = make_vector_1(sc, len, FILLED, T_VECTOR); + gc_protect_2_via_stack(sc, vec, data); + /* we need this vector prefilled because make_real|integer below can cause a GC at any time during that loop, + * and the GC mark process expects the vector to have an s7_pointer at every element. + */ + add_vector(sc, vec); + elements = s7_vector_elements(vec); + check_free_heap_size(sc, len); + if (is_float_vector(data)) + for (i = 0; i < len; i++) elements[i] = make_real_unchecked(sc, float_vector(data, i)); + else for (i = 0; i < len; i++) elements[i] = make_integer_unchecked(sc, int_vector(data, i)); + if (sort_func) + { + local_qsort_r((void *)elements, len, sizeof(s7_pointer), sort_func, (void *)sc); + if (is_float_vector(data)) + for (i = 0; i < len; i++) float_vector(data, i) = real(elements[i]); + else for (i = 0; i < len; i++) int_vector(data, i) = integer(elements[i]); + unstack_gc_protect(sc); + return(data); + } + set_car(args, vec); + init_temp(sc->y, cons(sc, data, lessp)); + unstack_gc_protect(sc); + push_stack(sc, OP_SORT_VECTOR_END, sc->y, sc->code); /* save and gc protect the original homogeneous vector and func */ + sc->y = sc->unused; } break; case T_VECTOR: len = vector_length(data); if (len < 2) - return(data); + return(data); if (sort_func) - { - s7_pointer *els = s7_vector_elements(data); - int32_t typ = type(els[0]); - if ((typ == T_INTEGER) || (typ == T_REAL) || (typ == T_STRING) || (typ == T_CHARACTER)) - for (s7_int i = 1; i < len; i++) - if (type(els[i]) != typ) - { - typ = T_FREE; - break; - } - if ((sc->sort_f == lt_b_7pp) || (sc->sort_f == gt_b_7pp)) - { - if (typ == T_INTEGER) - { - qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == lt_b_7pp) ? int_less_2 : int_greater_2)); - return(data); - } - if (typ == T_REAL) - { - qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == lt_b_7pp) ? dbl_less_2 : dbl_greater_2)); - return(data); - }} - if ((typ == T_STRING) && - ((sc->sort_f == string_lt_b_7pp) || (sc->sort_f == string_gt_b_7pp))) - { - qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == string_lt_b_7pp) ? str_less_2 : str_greater_2)); - return(data); - } - if ((typ == T_CHARACTER) && - ((sc->sort_f == char_lt_b_7pp) || (sc->sort_f == char_gt_b_7pp))) - { - qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == char_lt_b_7pp) ? chr_less_2 : chr_greater_2)); - return(data); - } - local_qsort_r((void *)s7_vector_elements(data), len, sizeof(s7_pointer), sort_func, (void *)sc); - return(data); - } + { + s7_pointer *els = s7_vector_elements(data); + int32_t typ = type(els[0]); + if ((typ == T_INTEGER) || (typ == T_REAL) || (typ == T_STRING) || (typ == T_CHARACTER)) + for (s7_int i = 1; i < len; i++) + if (type(els[i]) != typ) + { + typ = T_FREE; + break; + } + if ((sc->sort_f == lt_b_7pp) || (sc->sort_f == gt_b_7pp)) + { + if (typ == T_INTEGER) + { + qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == lt_b_7pp) ? int_less_2 : int_greater_2)); + return(data); + } + if (typ == T_REAL) + { + qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == lt_b_7pp) ? dbl_less_2 : dbl_greater_2)); + return(data); + }} + if ((typ == T_STRING) && + ((sc->sort_f == string_lt_b_7pp) || (sc->sort_f == string_gt_b_7pp))) + { + qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == string_lt_b_7pp) ? str_less_2 : str_greater_2)); + return(data); + } + if ((typ == T_CHARACTER) && + ((sc->sort_f == char_lt_b_7pp) || (sc->sort_f == char_gt_b_7pp))) + { + qsort((void *)els, len, sizeof(s7_pointer), ((sc->sort_f == char_lt_b_7pp) ? chr_less_2 : chr_greater_2)); + return(data); + } + local_qsort_r((void *)s7_vector_elements(data), len, sizeof(s7_pointer), sort_func, (void *)sc); + return(data); + } break; default: @@ -43384,7 +43384,7 @@ static s7_pointer vector_into_list(s7_scheme *sc, s7_pointer vect, s7_pointer ls for (s7_pointer p = lst; i < len; i++, p = cdr(p)) { if (is_immutable_pair(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, lst)); + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, lst)); set_car(p, elements[i]); } return(lst); @@ -43397,12 +43397,12 @@ static s7_pointer vector_into_fi_vector(s7_pointer source, s7_pointer dest) if (is_float_vector(dest)) { s7_double *flts = float_vector_floats(dest); - for (s7_int i = 0; i < len; i++) flts[i] = real(elements[i]); + for (s7_int i = 0; i < len; i++) flts[i] = real(elements[i]); } else { s7_int *ints = int_vector_ints(dest); - for (s7_int i = 0; i < len; i++) ints[i] = integer(elements[i]); + for (s7_int i = 0; i < len; i++) ints[i] = integer(elements[i]); } return(dest); } @@ -43414,12 +43414,12 @@ static s7_pointer vector_into_string(s7_pointer vect, s7_pointer dest) if (is_byte_vector(dest)) { uint8_t *str = (uint8_t *)byte_vector_bytes(dest); - for (s7_int i = 0; i < len; i++) str[i] = (uint8_t)integer(elements[i]); + for (s7_int i = 0; i < len; i++) str[i] = (uint8_t)integer(elements[i]); } else { uint8_t *str = (uint8_t *)string_value(dest); - for (s7_int i = 0; i < len; i++) str[i] = character(elements[i]); + for (s7_int i = 0; i < len; i++) str[i] = character(elements[i]); } return(dest); } @@ -43443,7 +43443,7 @@ static s7_pointer op_heapsort(s7_scheme *sc) { SORT_CALLS++; if (SORT_CALLS > SORT_STOP) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "sort! is caught in an infinite loop, comparison: ~S", 51), SORT_LESSP)); + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "sort! is caught in an infinite loop, comparison: ~S", 51), SORT_LESSP)); } j = 2 * k; SORT_J = j; @@ -43452,7 +43452,7 @@ static s7_pointer op_heapsort(s7_scheme *sc) s7_pointer lx = SORT_LESSP; /* cadr of sc->args */ push_stack_direct(sc, OP_SORT1); if (needs_copied_args(lx)) - sc->args = list_2(sc, SORT_DATA(j), SORT_DATA(j + 1)); + sc->args = list_2(sc, SORT_DATA(j), SORT_DATA(j + 1)); else sc->args = with_list_t2(SORT_DATA(j), SORT_DATA(j + 1)); sc->code = lx; sc->value = sc->T; /* for eval */ @@ -43536,18 +43536,18 @@ static void free_hash_table(s7_scheme *sc, s7_pointer table) hash_entry_t **entries = hash_table_elements(table); s7_int len = hash_table_size(table); for (s7_int i = 0; i < len; i++) - { - hash_entry_t *n; - for (hash_entry_t *p = entries[i++]; p; p = n) - { - n = hash_entry_next(p); - liberate_block(sc, p); - } - for (hash_entry_t *p = entries[i]; p; p = n) - { - n = hash_entry_next(p); - liberate_block(sc, p); - }}} + { + hash_entry_t *n; + for (hash_entry_t *p = entries[i++]; p; p = n) + { + n = hash_entry_next(p); + liberate_block(sc, p); + } + for (hash_entry_t *p = entries[i]; p; p = n) + { + n = hash_entry_next(p); + liberate_block(sc, p); + }}} liberate(sc, hash_table_block(table)); } @@ -43640,36 +43640,36 @@ static void check_hash_table_typer(s7_scheme *sc, s7_pointer caller, s7_pointer { s7_pointer sig = c_function_signature(typer); if ((sig != sc->pl_bt) && - (is_pair(sig)) && - ((car(sig) != sc->is_boolean_symbol) || (cadr(sig) != sc->T) || (!is_null(cddr(sig))))) - wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a boolean procedure", 19)); + (is_pair(sig)) && + ((car(sig) != sc->is_boolean_symbol) || (cadr(sig) != sc->T) || (!is_null(cddr(sig))))) + wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a boolean procedure", 19)); if (!c_function_name(typer)) - wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a named function", 16)); + wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a named function", 16)); } else { if (!is_any_closure(typer)) - wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a built-in procedure, a closure or #t", 37)); + wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a built-in procedure, a closure or #t", 37)); if (!is_symbol(find_closure(sc, typer, closure_let(typer)))) - wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a named function", 16)); + wrong_type_error_nr(sc, caller, 2, typer, wrap_string(sc, "a named function", 16)); } if (!s7_is_aritable(sc, typer, 1)) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: the second argument, ~S, (the type checker) should accept one argument", 74), caller, typer)); + set_elist_3(sc, wrap_string(sc, "~A: the second argument, ~S, (the type checker) should accept one argument", 74), caller, typer)); if (is_c_function(typer)) { if (!c_function_symbol(typer)) - c_function_symbol(typer) = make_symbol(sc, c_function_name(typer), c_function_name_length(typer)); + c_function_symbol(typer) = make_symbol(sc, c_function_name(typer), c_function_name_length(typer)); if (c_function_has_simple_elements(typer)) - { - if (caller == sc->hash_table_value_typer_symbol) - set_has_simple_values(h); - else - { - set_has_simple_keys(h); - if (symbol_type(c_function_symbol(typer)) != T_FREE) - set_has_hash_key_type(h); - }}} + { + if (caller == sc->hash_table_value_typer_symbol) + set_has_simple_values(h); + else + { + set_has_simple_keys(h); + if (symbol_type(c_function_symbol(typer)) != T_FREE) + set_has_hash_key_type(h); + }}} if (is_null(hash_table_procedures(h))) hash_table_set_procedures(h, make_hash_table_procedures(sc)); set_is_typed_hash_table(h); @@ -43687,11 +43687,11 @@ static s7_pointer g_set_hash_table_key_typer(s7_scheme *sc, s7_pointer args) if (is_boolean(typer)) /* remove current typer, if any */ { if (is_typed_hash_table(h)) - { - hash_table_set_key_typer(h, sc->T); - clear_has_simple_keys(h); - if (hash_table_value_typer(h) == sc->T) clear_is_typed_hash_table(h); - }} + { + hash_table_set_key_typer(h, sc->T); + clear_has_simple_keys(h); + if (hash_table_value_typer(h) == sc->T) clear_is_typed_hash_table(h); + }} else { check_hash_table_typer(sc, sc->hash_table_key_typer_symbol, h, typer); @@ -43712,11 +43712,11 @@ static s7_pointer g_set_hash_table_value_typer(s7_scheme *sc, s7_pointer args) if (is_boolean(typer)) /* remove current typer, if any */ { if (is_typed_hash_table(h)) - { - hash_table_set_value_typer(h, sc->T); - clear_has_simple_values(h); - if (hash_table_key_typer(h) == sc->T) clear_is_typed_hash_table(h); - }} + { + hash_table_set_value_typer(h, sc->T); + clear_has_simple_values(h); + if (hash_table_key_typer(h) == sc->T) clear_is_typed_hash_table(h); + }} else { check_hash_table_typer(sc, sc->hash_table_value_typer_symbol, h, typer); @@ -43767,7 +43767,7 @@ static s7_pointer g_hash_code(s7_scheme *sc, s7_pointer args) if ((is_pair(cdr(args))) && (!is_procedure(cadr(args)))) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "hash-code second argument (currently ignored) should be a function: ~S", 70), cadr(args))); + set_elist_2(sc, wrap_string(sc, "hash-code second argument (currently ignored) should be a function: ~S", 70), cadr(args))); return(make_integer(sc, default_hash_map[type(obj)](sc, sc->dummy_equal_hash_table, obj))); } @@ -43790,7 +43790,7 @@ static hash_entry_t *hash_equal_syntax(s7_scheme *sc, s7_pointer table, s7_point s7_int loc = hash_loc(sc, table, key) & hash_table_mask(table); for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) if ((is_syntax(hash_entry_key(x))) && - (syntax_symbol(hash_entry_key(x)) == syntax_symbol(key))) /* the opcodes might differ, but the symbols should not */ + (syntax_symbol(hash_entry_key(x)) == syntax_symbol(key))) /* the opcodes might differ, but the symbols should not */ return(x); return(sc->unentry); } @@ -43888,8 +43888,8 @@ static hash_entry_t *find_number_in_bin(s7_scheme *sc, hash_entry_t *bin, s7_poi for (; bin; bin = hash_entry_next(bin)) if (equiv(sc, key, hash_entry_key(bin), NULL)) { - sc->equivalent_float_epsilon = old_eps; - return(bin); + sc->equivalent_float_epsilon = old_eps; + return(bin); } sc->equivalent_float_epsilon = old_eps; return(NULL); @@ -43977,18 +43977,18 @@ static hash_entry_t *hash_int(s7_scheme *sc, s7_pointer table, s7_pointer key) s7_int loc = s7_int_abs(kv) & hash_mask; for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) #if WITH_GMP - if (is_t_integer(hash_entry_key(x))) - { - if (integer(hash_entry_key(x)) == kv) - return(x); - } - else - if ((is_t_big_integer(hash_entry_key(x))) && - (mpz_get_si(big_integer(hash_entry_key(x))) == kv)) - return(x); + if (is_t_integer(hash_entry_key(x))) + { + if (integer(hash_entry_key(x)) == kv) + return(x); + } + else + if ((is_t_big_integer(hash_entry_key(x))) && + (mpz_get_si(big_integer(hash_entry_key(x))) == kv)) + return(x); #else if (integer(hash_entry_key(x)) == kv) - return(x); + return(x); #endif } return(sc->unentry); @@ -44007,15 +44007,15 @@ static hash_entry_t *hash_float(s7_scheme *sc, s7_pointer table, s7_pointer key) s7_int loc, hash_mask; #if WITH_GMP if (is_t_real(key)) - { - keyval = real(key); - if (is_NaN(keyval)) return(sc->unentry); - } + { + keyval = real(key); + if (is_NaN(keyval)) return(sc->unentry); + } else - { - if (mpfr_nan_p(big_real(key))) return(sc->unentry); - keyval = mpfr_get_d(big_real(key), MPFR_RNDN); - } + { + if (mpfr_nan_p(big_real(key))) return(sc->unentry); + keyval = mpfr_get_d(big_real(key), MPFR_RNDN); + } #else keyval = real(key); if (is_NaN(keyval)) return(sc->unentry); @@ -44024,17 +44024,17 @@ static hash_entry_t *hash_float(s7_scheme *sc, s7_pointer table, s7_pointer key) loc = hash_float_location(keyval) & hash_mask; for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - { - if ((is_t_real(hash_entry_key(x))) && - (keyval == real(hash_entry_key(x)))) - return(x); + { + if ((is_t_real(hash_entry_key(x))) && + (keyval == real(hash_entry_key(x)))) + return(x); #if WITH_GMP - if ((is_t_big_real(hash_entry_key(x))) && - (mpfr_cmp_d(big_real(hash_entry_key(x)), keyval) == 0) && - (!mpfr_nan_p(big_real(hash_entry_key(x))))) - return(x); + if ((is_t_big_real(hash_entry_key(x))) && + (mpfr_cmp_d(big_real(hash_entry_key(x)), keyval) == 0) && + (!mpfr_nan_p(big_real(hash_entry_key(x))))) + return(x); #endif - }} + }} return(sc->unentry); } @@ -44078,16 +44078,16 @@ static hash_entry_t *hash_number_num_eq(s7_scheme *sc, s7_pointer table, s7_poin s7_int hash_mask = hash_table_mask(table); hash_map_t map = hash_table_mapper(table)[type(key)]; if (hash_table_checker(table) == hash_int) /* surely by far the most common case? only ints */ - { - s7_int keyi = integer(key); - s7_int loc = map(sc, table, key) & hash_mask; - for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (keyi == integer(hash_entry_key(x))) /* not in gmp, hash_int as eq_func, what else can key be but t_integer? */ - return(x); - } + { + s7_int keyi = integer(key); + s7_int loc = map(sc, table, key) & hash_mask; + for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) + if (keyi == integer(hash_entry_key(x))) /* not in gmp, hash_int as eq_func, what else can key be but t_integer? */ + return(x); + } else #endif - return((is_real(key)) ? hash_real_num_eq(sc, table, key) : hash_complex_num_eq(sc, table, key)); + return((is_real(key)) ? hash_real_num_eq(sc, table, key) : hash_complex_num_eq(sc, table, key)); } return(sc->unentry); } @@ -44105,8 +44105,8 @@ static hash_entry_t *hash_char(s7_scheme *sc, s7_pointer table, s7_pointer key) */ s7_int loc = character(key) & hash_table_mask(table); for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (key == hash_entry_key(x)) - return(x); + if (key == hash_entry_key(x)) + return(x); } return(sc->unentry); } @@ -44121,8 +44121,8 @@ static hash_entry_t *hash_ci_char(s7_scheme *sc, s7_pointer table, s7_pointer ke s7_int hash_mask = hash_table_mask(table); s7_int loc = hash_loc(sc, table, key) & hash_mask; for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (upper_character(key) == upper_character(hash_entry_key(x))) - return(x); + if (upper_character(key) == upper_character(hash_entry_key(x))) + return(x); } return(sc->unentry); } @@ -44148,22 +44148,22 @@ static hash_entry_t *hash_string(s7_scheme *sc, s7_pointer table, s7_pointer key const char *key_str = string_value(key); if (string_hash(key) == 0) - string_hash(key) = raw_string_hash((const uint8_t *)string_value(key), string_length(key)); + string_hash(key) = raw_string_hash((const uint8_t *)string_value(key), string_length(key)); hash = string_hash(key); /* keep uint64_t (not s7_int from hash_map_string) */ if (key_len <= 8) - { - for (x = hash_table_element(table, hash & hash_mask); x; x = hash_entry_next(x)) - if ((hash == string_hash(hash_entry_key(x))) && - (key_len == string_length(hash_entry_key(x)))) - return(x); - } + { + for (x = hash_table_element(table, hash & hash_mask); x; x = hash_entry_next(x)) + if ((hash == string_hash(hash_entry_key(x))) && + (key_len == string_length(hash_entry_key(x)))) + return(x); + } else - for (x = hash_table_element(table, hash & hash_mask); x; x = hash_entry_next(x)) - if ((hash == string_hash(hash_entry_key(x))) && - (key_len == string_length(hash_entry_key(x))) && /* these are scheme strings, so we can't assume 0=end of string */ - (strings_are_equal_with_length(key_str, string_value(hash_entry_key(x)), key_len))) - return(x); + for (x = hash_table_element(table, hash & hash_mask); x; x = hash_entry_next(x)) + if ((hash == string_hash(hash_entry_key(x))) && + (key_len == string_length(hash_entry_key(x))) && /* these are scheme strings, so we can't assume 0=end of string */ + (strings_are_equal_with_length(key_str, string_value(hash_entry_key(x)), key_len))) + return(x); } return(sc->unentry); } @@ -44182,8 +44182,8 @@ static hash_entry_t *hash_ci_string(s7_scheme *sc, s7_pointer table, s7_pointer s7_int hash_mask = hash_table_mask(table); s7_int hash = hash_map_ci_string(sc, table, key); for (hash_entry_t *x = hash_table_element(table, hash & hash_mask); x; x = hash_entry_next(x)) - if (scheme_strequal_ci(key, hash_entry_key(x))) - return(x); + if (scheme_strequal_ci(key, hash_entry_key(x))) + return(x); } return(sc->unentry); } @@ -44216,20 +44216,20 @@ static hash_entry_t *hash_eqv(s7_scheme *sc, s7_pointer table, s7_pointer key) { #if WITH_GMP for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (numbers_are_eqv(sc, key, hash_entry_key(x))) - return(x); + if (numbers_are_eqv(sc, key, hash_entry_key(x))) + return(x); #else uint8_t key_type = type(key); for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if ((key_type == type(hash_entry_key(x))) && - (numbers_are_eqv(sc, key, hash_entry_key(x)))) - return(x); + if ((key_type == type(hash_entry_key(x))) && + (numbers_are_eqv(sc, key, hash_entry_key(x)))) + return(x); #endif } else for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) if (s7_is_eqv(sc, key, hash_entry_key(x))) - return(x); + return(x); return(sc->unentry); } @@ -44252,19 +44252,19 @@ static s7_int hash_map_hash_table(s7_scheme *sc, s7_pointer table, s7_pointer ke for (s7_int i = 0; i < size; i++) for (hash_entry_t *x = els[i]; x; x = hash_entry_next(x)) { - if (len == 1) - return(((is_sequence_or_iterator(hash_entry_key(x))) ? 0 : hash_loc(sc, key, hash_entry_key(x))) + - ((is_sequence_or_iterator(hash_entry_value(x))) ? 0 : hash_loc(sc, key, hash_entry_value(x)))); - if (!key1) - { - key1 = hash_entry_key(x); - val1 = hash_entry_value(x); - } - else - return(((is_sequence_or_iterator(key1)) ? 0 : hash_loc(sc, key, key1)) + - ((is_sequence_or_iterator(val1)) ? 0 : hash_loc(sc, key, val1)) + - ((is_sequence_or_iterator(hash_entry_key(x))) ? 0 : hash_loc(sc, key, hash_entry_key(x))) + - ((is_sequence_or_iterator(hash_entry_value(x))) ? 0 : hash_loc(sc, key, hash_entry_value(x)))); + if (len == 1) + return(((is_sequence_or_iterator(hash_entry_key(x))) ? 0 : hash_loc(sc, key, hash_entry_key(x))) + + ((is_sequence_or_iterator(hash_entry_value(x))) ? 0 : hash_loc(sc, key, hash_entry_value(x)))); + if (!key1) + { + key1 = hash_entry_key(x); + val1 = hash_entry_value(x); + } + else + return(((is_sequence_or_iterator(key1)) ? 0 : hash_loc(sc, key, key1)) + + ((is_sequence_or_iterator(val1)) ? 0 : hash_loc(sc, key, val1)) + + ((is_sequence_or_iterator(hash_entry_key(x))) ? 0 : hash_loc(sc, key, hash_entry_key(x))) + + ((is_sequence_or_iterator(hash_entry_value(x))) ? 0 : hash_loc(sc, key, hash_entry_value(x)))); }} return(0); /* placate the compiler */ } @@ -44313,7 +44313,7 @@ static s7_int hash_map_closure(s7_scheme *sc, s7_pointer table, s7_pointer key) s7_pointer f = hash_table_procedures_mapper(table); if (f == sc->unused) error_nr(sc, make_symbol(sc, "hash-map-recursion", 18), - set_elist_1(sc, wrap_string(sc, "hash-table map function called recursively", 42))); + set_elist_1(sc, wrap_string(sc, "hash-table map function called recursively", 42))); /* check_stack_size(sc); -- perhaps clear typers as well here or save/restore hash-table-procedures */ gc_protect_via_stack(sc, f); hash_table_set_procedures_mapper(table, sc->F); @@ -44322,7 +44322,7 @@ static s7_int hash_map_closure(s7_scheme *sc, s7_pointer table, s7_pointer key) hash_table_set_procedures_mapper(table, f); if (!s7_is_integer(sc->value)) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "hash-table map function should return an integer: ~S", 52), sc->value)); + set_elist_2(sc, wrap_string(sc, "hash-table map function should return an integer: ~S", 52), sc->value)); return(integer(sc->value)); } @@ -44337,9 +44337,9 @@ static s7_int hash_map_let(s7_scheme *sc, s7_pointer table, s7_pointer key) for (slot = let_slots(key), slots = 0; tis_slot(slot); slot = next_slot(slot)) if (!is_matched_symbol(slot_symbol(slot))) { - if (!slot1) slot1 = slot; else slot2 = slot; - set_match_symbol(slot_symbol(slot)); - slots++; + if (!slot1) slot1 = slot; else slot2 = slot; + set_match_symbol(slot_symbol(slot)); + slots++; } for (slot = let_slots(key); tis_slot(slot); slot = next_slot(slot)) clear_match_symbol(slot_symbol(slot)); @@ -44349,7 +44349,7 @@ static s7_int hash_map_let(s7_scheme *sc, s7_pointer table, s7_pointer key) if (slots == 2) return(pointer_map(slot_symbol(slot1)) + ((is_sequence_or_iterator(slot_value(slot1))) ? 0 : hash_loc(sc, table, slot_value(slot1))) + - pointer_map(slot_symbol(slot2)) + ((is_sequence_or_iterator(slot_value(slot2))) ? 0 : hash_loc(sc, table, slot_value(slot2)))); + pointer_map(slot_symbol(slot2)) + ((is_sequence_or_iterator(slot_value(slot2))) ? 0 : hash_loc(sc, table, slot_value(slot2)))); return(slots); } @@ -44369,12 +44369,12 @@ static hash_entry_t *hash_equal_integer(s7_scheme *sc, s7_pointer table, s7_poin for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) { if ((is_t_integer(hash_entry_key(x))) && - (keyint == integer(hash_entry_key(x)))) - return(x); + (keyint == integer(hash_entry_key(x)))) + return(x); #if WITH_GMP if ((is_t_big_integer(hash_entry_key(x))) && - (mpz_cmp_si(big_integer(hash_entry_key(x)), keyint) == 0)) - return(x); + (mpz_cmp_si(big_integer(hash_entry_key(x)), keyint) == 0)) + return(x); #endif } return(sc->unentry); @@ -44387,14 +44387,14 @@ static hash_entry_t *hash_equal_ratio(s7_scheme *sc, s7_pointer table, s7_pointe for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) { if ((is_t_ratio(hash_entry_key(x))) && - (keynum == numerator(hash_entry_key(x))) && - (keyden == denominator(hash_entry_key(x)))) - return(x); + (keynum == numerator(hash_entry_key(x))) && + (keyden == denominator(hash_entry_key(x)))) + return(x); #if WITH_GMP if ((is_t_big_ratio(hash_entry_key(x))) && - (keynum == mpz_get_si(mpq_numref(big_ratio(hash_entry_key(x))))) && - (keyden == mpz_get_si(mpq_denref(big_ratio(hash_entry_key(x)))))) - return(x); + (keynum == mpz_get_si(mpq_numref(big_ratio(hash_entry_key(x))))) && + (keyden == mpz_get_si(mpq_denref(big_ratio(hash_entry_key(x)))))) + return(x); #endif } return(sc->unentry); @@ -44409,13 +44409,13 @@ static hash_entry_t *hash_equal_real(s7_scheme *sc, s7_pointer table, s7_pointer for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) { if ((is_t_real(hash_entry_key(x))) && - (keydbl == real(hash_entry_key(x)))) - return(x); + (keydbl == real(hash_entry_key(x)))) + return(x); #if WITH_GMP if ((is_t_big_real(hash_entry_key(x))) && - (mpfr_cmp_d(big_real(hash_entry_key(x)), keydbl) == 0) && - (!mpfr_nan_p(big_real(hash_entry_key(x))))) - return(x); + (mpfr_cmp_d(big_real(hash_entry_key(x)), keydbl) == 0) && + (!mpfr_nan_p(big_real(hash_entry_key(x))))) + return(x); #endif } return(sc->unentry); @@ -44434,16 +44434,16 @@ static hash_entry_t *hash_equal_complex(s7_scheme *sc, s7_pointer table, s7_poin for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) { if ((is_t_complex(hash_entry_key(x))) && - (keyrl == real_part(hash_entry_key(x))) && - (keyim == imag_part(hash_entry_key(x)))) - return(x); + (keyrl == real_part(hash_entry_key(x))) && + (keyim == imag_part(hash_entry_key(x)))) + return(x); #if WITH_GMP if ((is_t_big_complex(hash_entry_key(x))) && - (mpfr_cmp_d(mpc_realref(big_complex(hash_entry_key(x))), keyrl) == 0) && - (mpfr_cmp_d(mpc_imagref(big_complex(hash_entry_key(x))), keyim) == 0) && - (!mpfr_nan_p(mpc_realref(big_complex(hash_entry_key(x))))) && - (!mpfr_nan_p(mpc_imagref(big_complex(hash_entry_key(x)))))) - return(x); + (mpfr_cmp_d(mpc_realref(big_complex(hash_entry_key(x))), keyrl) == 0) && + (mpfr_cmp_d(mpc_imagref(big_complex(hash_entry_key(x))), keyim) == 0) && + (!mpfr_nan_p(mpc_realref(big_complex(hash_entry_key(x))))) && + (!mpfr_nan_p(mpc_imagref(big_complex(hash_entry_key(x)))))) + return(x); #endif } return(sc->unentry); @@ -44459,7 +44459,7 @@ static hash_entry_t *hash_equal_any(s7_scheme *sc, s7_pointer table, s7_pointer return(x); for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) if ((hash_entry_raw_hash(x) == hash) && - (equal(sc, key, hash_entry_key(x), NULL))) + (equal(sc, key, hash_entry_key(x), NULL))) return(x); return(sc->unentry); } @@ -44501,12 +44501,12 @@ static hash_entry_t *hash_c_function(s7_scheme *sc, s7_pointer table, s7_pointer s7_int loc = hash & hash_mask; set_car(sc->t2_1, key); for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if (hash_entry_raw_hash(x) == hash) - { - set_car(sc->t2_2, hash_entry_key(x)); - if (is_true(sc, f(sc, sc->t2_1))) - return(x); - } + if (hash_entry_raw_hash(x) == hash) + { + set_car(sc->t2_2, hash_entry_key(x)); + if (is_true(sc, f(sc, sc->t2_1))) + return(x); + } return(sc->unentry); } return(hash_equal(sc, table, key)); @@ -44533,16 +44533,16 @@ static s7_int hash_map_pair(s7_scheme *sc, s7_pointer table, s7_pointer key) loc = hash_loc(sc, table, car(key)) + 1; else if ((is_pair(car(key))) && - (!is_sequence_or_iterator(caar(key)))) + (!is_sequence_or_iterator(caar(key)))) loc = hash_loc(sc, table, caar(key)) + 1; if (is_pair(p1)) { if (!is_sequence_or_iterator(car(p1))) - loc += hash_loc(sc, table, car(p1)) + 1; + loc += hash_loc(sc, table, car(p1)) + 1; else - if ((is_pair(car(p1))) && - (!is_sequence_or_iterator(caar(p1)))) - loc += hash_loc(sc, table, caar(p1)) + 1; + if ((is_pair(car(p1))) && + (!is_sequence_or_iterator(caar(p1)))) + loc += hash_loc(sc, table, caar(p1)) + 1; } else if (!is_sequence_or_iterator(p1)) /* include () */ @@ -44559,9 +44559,9 @@ static hash_entry_t *hash_closure(s7_scheme *sc, s7_pointer table, s7_pointer ke s7_int hash = hash_loc(sc, table, key); s7_int loc = hash & hash_mask; for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) - if ((hash_entry_raw_hash(x) == hash) && - (is_true(sc, s7_call(sc, f, set_plist_2(sc, key, hash_entry_key(x)))))) - return(x); + if ((hash_entry_raw_hash(x) == hash) && + (is_true(sc, s7_call(sc, f, set_plist_2(sc, key, hash_entry_key(x)))))) + return(x); return(sc->unentry); } return(hash_equal(sc, table, key)); @@ -44582,15 +44582,15 @@ static hash_entry_t *hash_equivalent(s7_scheme *sc, s7_pointer table, s7_pointer { #if WITH_GMP if (!is_nan_b_7p(sc, key)) - return(hash_number_equivalent(sc, table, key)); + return(hash_number_equivalent(sc, table, key)); #else x = hash_number_equivalent(sc, table, key); if ((x != sc->unentry) || (!is_nan_b_7p(sc, key))) - return(x); + return(x); #endif for (x = hash_table_element(table, 0); x; x = hash_entry_next(x)) /* NaN is mapped to 0 */ - if (is_nan_b_7p(sc, hash_entry_key(x))) /* all NaN's are the same to equivalent? */ - return(x); + if (is_nan_b_7p(sc, hash_entry_key(x))) /* all NaN's are the same to equivalent? */ + return(x); return(sc->unentry); } hash = hash_loc(sc, table, key); @@ -44601,7 +44601,7 @@ static hash_entry_t *hash_equivalent(s7_scheme *sc, s7_pointer table, s7_pointer for (x = hash_table_element(table, loc); x; x = hash_entry_next(x)) if ((hash_entry_raw_hash(x) == hash) && - (s7_is_equivalent(sc, hash_entry_key(x), key))) + (s7_is_equivalent(sc, hash_entry_key(x), key))) return(x); return(sc->unentry); } @@ -44609,11 +44609,11 @@ static hash_entry_t *hash_equivalent(s7_scheme *sc, s7_pointer table, s7_pointer static bool hash_keys_not_cyclic(s7_scheme *sc, s7_pointer hash) { return((is_null(hash_table_procedures(hash))) && - (hash_table_mapper(hash) == default_hash_map) && - (hash_table_checker(hash) != hash_equal) && - (hash_table_checker(hash) != hash_equivalent) && - (hash_table_checker(hash) != hash_closure) && - (hash_table_checker(hash) != hash_c_function)); + (hash_table_mapper(hash) == default_hash_map) && + (hash_table_checker(hash) != hash_equal) && + (hash_table_checker(hash) != hash_equivalent) && + (hash_table_checker(hash) != hash_closure) && + (hash_table_checker(hash) != hash_c_function)); } @@ -44629,17 +44629,17 @@ s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size) else if ((size & (size - 1)) != 0) /* already 2^n ? */ { - if ((size & (size + 1)) != 0) /* already 2^n - 1 ? */ - { - size--; - size |= (size >> 1); - size |= (size >> 2); - size |= (size >> 4); - size |= (size >> 8); - size |= (size >> 16); - size |= (size >> 32); - } - size++; + if ((size & (size + 1)) != 0) /* already 2^n - 1 ? */ + { + size--; + size |= (size >> 1); + size |= (size >> 2); + size |= (size >> 4); + size |= (size >> 8); + size |= (size >> 16); + size |= (size >> 32); + } + size++; } els = (block_t *)callocate(sc, size * sizeof(hash_entry_t *)); new_cell(sc, table, T_HASH_TABLE | T_SAFE_PROCEDURE); @@ -44660,9 +44660,9 @@ static bool compatible_types(s7_scheme *sc, const s7_pointer eq_type, const s7_p if (eq_type == value_type) return(true); if (eq_type == sc->is_number_symbol) /* only = among built-ins, so other cases aren't needed */ return((value_type == sc->is_integer_symbol) || - (value_type == sc->is_real_symbol) || - (value_type == sc->is_complex_symbol) || - (value_type == sc->is_rational_symbol)); + (value_type == sc->is_real_symbol) || + (value_type == sc->is_complex_symbol) || + (value_type == sc->is_rational_symbol)); return(false); } @@ -44675,242 +44675,242 @@ static s7_pointer g_make_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer used to check equality of keys; it usually defaults to equal?. typer sets the types of the keys and values that are allowed \ in the table; it is a cons, defaulting to (cons #t #t) which means any types are allowed.\n" #define Q_make_hash_table s7_make_signature(sc, 4, sc->is_hash_table_symbol, sc->is_integer_symbol, \ - s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol)) + s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \ + s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol)) s7_int size = sc->default_hash_table_length; if (is_not_null(args)) { s7_pointer p = car(args); if (!s7_is_integer(p)) - return(method_or_bust(sc, p, caller, args, sc->type_names[T_INTEGER], 1)); + return(method_or_bust(sc, p, caller, args, sc->type_names[T_INTEGER], 1)); size = s7_integer_clamped_if_gmp(sc, p); if (size <= 0) /* we need s7_int here to catch (make-hash-table most-negative-fixnum) etc */ - out_of_range_error_nr(sc, caller, int_one, p, wrap_string(sc, "it should be a positive integer", 31)); + out_of_range_error_nr(sc, caller, int_one, p, wrap_string(sc, "it should be a positive integer", 31)); if ((size > sc->max_vector_length) || - (size >= (1LL << 32LL))) - out_of_range_error_nr(sc, caller, int_one, p, it_is_too_large_string); + (size >= (1LL << 32LL))) + out_of_range_error_nr(sc, caller, int_one, p, it_is_too_large_string); if (is_not_null(cdr(args))) - { - s7_pointer proc; - s7_pointer ht = s7_make_hash_table(sc, size); - /* check for typers */ - if (is_pair(cddr(args))) - { - s7_pointer typers = caddr(args); - if (is_pair(typers)) - { - s7_pointer keyp = car(typers), valp = cdr(typers); - if ((keyp != sc->T) || (valp != sc->T)) /* one of them is a type checker */ - { - if (((keyp != sc->T) && (!is_c_function(keyp)) && (!is_any_closure(keyp))) || - ((valp != sc->T) && (!is_c_function(valp)) && (!is_any_closure(valp)))) - wrong_type_error_nr(sc, caller, 3, typers, wrap_string(sc, "(key-type . value-type)", 23)); - - if ((keyp != sc->T) && - (!s7_is_aritable(sc, keyp, 1))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) both functions should take one argument", 100), - caller, typers)); - hash_table_set_procedures(ht, make_hash_table_procedures(sc)); - hash_table_set_key_typer(ht, keyp); - hash_table_set_value_typer(ht, valp); - if (is_c_function(keyp)) - { - if (!c_function_name(keyp)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the first function is anonymous", 92), - caller, typers)); - if (c_function_has_simple_elements(keyp)) - set_has_simple_keys(ht); - if (!c_function_symbol(keyp)) - c_function_symbol(keyp) = make_symbol(sc, c_function_name(keyp), c_function_name_length(keyp)); - if (symbol_type(c_function_symbol(keyp)) != T_FREE) - set_has_hash_key_type(ht); - /* c_function_marker is not currently used in this context */ - - /* now a consistency check for eq-func and key type */ - proc = cadr(args); - if (is_c_function(proc)) - { - s7_pointer eq_sig = c_function_signature(proc); - if ((eq_sig) && - (is_pair(eq_sig)) && - (is_pair(cdr(eq_sig))) && - (!compatible_types(sc, cadr(eq_sig), c_function_symbol(keyp)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, the key type function is not compatible with the equality function: ~S", 97), - caller, typers)); - }} - else - if ((is_any_closure(keyp)) && - (!is_symbol(find_closure(sc, keyp, closure_let(keyp))))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the first function is anonymous", 92), - caller, typers)); - if ((valp != sc->T) && - (!s7_is_aritable(sc, valp, 1))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) both functions should take one argument", 100), - caller, typers)); - if (is_c_function(valp)) - { - if (!c_function_name(valp)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the second function is anonymous", 93), - caller, typers)); - if (c_function_has_simple_elements(valp)) - set_has_simple_values(ht); - if (!c_function_symbol(valp)) - c_function_symbol(valp) = make_symbol(sc, c_function_name(valp), c_function_name_length(valp)); - if (symbol_type(c_function_symbol(valp)) != T_FREE) - set_has_hash_value_type(ht); - } - else - if ((is_any_closure(valp)) && - (!is_symbol(find_closure(sc, valp, closure_let(valp))))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the second function is anonymous", 93), - caller, typers)); - set_is_typed_hash_table(ht); - }} - else - if (typers != sc->F) - wrong_type_error_nr(sc, caller, 3, typers, wrap_string(sc, "either #f or (cons key-type-check value-type-check)", 51)); - } - - /* check eq_func */ - proc = cadr(args); - - if (is_c_function(proc)) - { - hash_set_chosen(ht); - - if (!s7_is_aritable(sc, proc, 2)) - wrong_type_error_nr(sc, caller, 2, proc, an_eq_func_string); - - if (c_function_call(proc) == g_is_equal) - { - hash_table_checker(ht) = hash_equal; - return(ht); - } - if (c_function_call(proc) == g_is_equivalent) - { - hash_table_checker(ht) = hash_equivalent; - hash_table_mapper(ht) = equivalent_hash_map; /* needed only by hash_table_equal_1 (checker_locked looks at mapper?!) */ - return(ht); - } - if (c_function_call(proc) == g_is_eq) - { - hash_table_checker(ht) = hash_eq; - hash_table_mapper(ht) = eq_hash_map; - return(ht); - } - if (c_function_call(proc) == g_strings_are_equal) - { - hash_table_checker(ht) = hash_string; - hash_table_mapper(ht) = string_eq_hash_map; - return(ht); - } + { + s7_pointer proc; + s7_pointer ht = s7_make_hash_table(sc, size); + /* check for typers */ + if (is_pair(cddr(args))) + { + s7_pointer typers = caddr(args); + if (is_pair(typers)) + { + s7_pointer keyp = car(typers), valp = cdr(typers); + if ((keyp != sc->T) || (valp != sc->T)) /* one of them is a type checker */ + { + if (((keyp != sc->T) && (!is_c_function(keyp)) && (!is_any_closure(keyp))) || + ((valp != sc->T) && (!is_c_function(valp)) && (!is_any_closure(valp)))) + wrong_type_error_nr(sc, caller, 3, typers, wrap_string(sc, "(key-type . value-type)", 23)); + + if ((keyp != sc->T) && + (!s7_is_aritable(sc, keyp, 1))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) both functions should take one argument", 100), + caller, typers)); + hash_table_set_procedures(ht, make_hash_table_procedures(sc)); + hash_table_set_key_typer(ht, keyp); + hash_table_set_value_typer(ht, valp); + if (is_c_function(keyp)) + { + if (!c_function_name(keyp)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the first function is anonymous", 92), + caller, typers)); + if (c_function_has_simple_elements(keyp)) + set_has_simple_keys(ht); + if (!c_function_symbol(keyp)) + c_function_symbol(keyp) = make_symbol(sc, c_function_name(keyp), c_function_name_length(keyp)); + if (symbol_type(c_function_symbol(keyp)) != T_FREE) + set_has_hash_key_type(ht); + /* c_function_marker is not currently used in this context */ + + /* now a consistency check for eq-func and key type */ + proc = cadr(args); + if (is_c_function(proc)) + { + s7_pointer eq_sig = c_function_signature(proc); + if ((eq_sig) && + (is_pair(eq_sig)) && + (is_pair(cdr(eq_sig))) && + (!compatible_types(sc, cadr(eq_sig), c_function_symbol(keyp)))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, the key type function is not compatible with the equality function: ~S", 97), + caller, typers)); + }} + else + if ((is_any_closure(keyp)) && + (!is_symbol(find_closure(sc, keyp, closure_let(keyp))))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the first function is anonymous", 92), + caller, typers)); + if ((valp != sc->T) && + (!s7_is_aritable(sc, valp, 1))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) both functions should take one argument", 100), + caller, typers)); + if (is_c_function(valp)) + { + if (!c_function_name(valp)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the second function is anonymous", 93), + caller, typers)); + if (c_function_has_simple_elements(valp)) + set_has_simple_values(ht); + if (!c_function_symbol(valp)) + c_function_symbol(valp) = make_symbol(sc, c_function_name(valp), c_function_name_length(valp)); + if (symbol_type(c_function_symbol(valp)) != T_FREE) + set_has_hash_value_type(ht); + } + else + if ((is_any_closure(valp)) && + (!is_symbol(find_closure(sc, valp, closure_let(valp))))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: in the third argument, ~S, (the key/value type checkers) the second function is anonymous", 93), + caller, typers)); + set_is_typed_hash_table(ht); + }} + else + if (typers != sc->F) + wrong_type_error_nr(sc, caller, 3, typers, wrap_string(sc, "either #f or (cons key-type-check value-type-check)", 51)); + } + + /* check eq_func */ + proc = cadr(args); + + if (is_c_function(proc)) + { + hash_set_chosen(ht); + + if (!s7_is_aritable(sc, proc, 2)) + wrong_type_error_nr(sc, caller, 2, proc, an_eq_func_string); + + if (c_function_call(proc) == g_is_equal) + { + hash_table_checker(ht) = hash_equal; + return(ht); + } + if (c_function_call(proc) == g_is_equivalent) + { + hash_table_checker(ht) = hash_equivalent; + hash_table_mapper(ht) = equivalent_hash_map; /* needed only by hash_table_equal_1 (checker_locked looks at mapper?!) */ + return(ht); + } + if (c_function_call(proc) == g_is_eq) + { + hash_table_checker(ht) = hash_eq; + hash_table_mapper(ht) = eq_hash_map; + return(ht); + } + if (c_function_call(proc) == g_strings_are_equal) + { + hash_table_checker(ht) = hash_string; + hash_table_mapper(ht) = string_eq_hash_map; + return(ht); + } #if (!WITH_PURE_S7) - if (c_function_call(proc) == g_strings_are_ci_equal) - { - hash_table_checker(ht) = hash_ci_string; - hash_table_mapper(ht) = string_ci_eq_hash_map; - return(ht); - } - if (c_function_call(proc) == g_chars_are_ci_equal) - { - hash_table_checker(ht) = hash_ci_char; - hash_table_mapper(ht) = char_ci_eq_hash_map; - return(ht); - } -#endif - if (c_function_call(proc) == g_chars_are_equal) - { - hash_table_checker(ht) = hash_char; - hash_table_mapper(ht) = char_eq_hash_map; - return(ht); - } - if (c_function_call(proc) == g_num_eq) - { - if ((is_typed_hash_table(ht)) && - (hash_table_key_typer(ht) == global_value(sc->is_integer_symbol))) - hash_table_checker(ht) = hash_int; - else hash_table_checker(ht) = hash_number_num_eq; - return(ht); - } - if (c_function_call(proc) == g_is_eqv) - { - hash_table_checker(ht) = hash_eqv; - return(ht); - } - error_nr(sc, sc->out_of_range_symbol, - set_elist_3(sc, wrap_string(sc, "~A second argument, ~S, is not a built-in function it can handle", 64), caller, proc)); - } - /* proc not c_function */ - else - { - if (is_pair(proc)) - { - s7_pointer checker = car(proc), mapper = cdr(proc); - - hash_set_chosen(ht); - if (!((is_any_c_function(checker)) || - (is_any_closure(checker)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: first entry of type info, ~A, is ~A, but should be a function", 65), - caller, checker, type_name_string(sc, checker))); - if (!((is_any_c_function(mapper)) || - (is_any_closure(mapper)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: second entry of type info, ~A, is ~A, but should be a function", 66), - caller, mapper, type_name_string(sc, mapper))); - - if (!(s7_is_aritable(sc, checker, 2))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A's equality function, ~A, (car of the second argument) should be a function of two arguments", 94), - caller, checker)); - if (!(s7_is_aritable(sc, mapper, 1))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A's mapping function, ~A, (cdr of the second argument) should be a function of one argument", 92), - caller, mapper)); - - if (is_any_c_function(checker)) - { - s7_pointer sig = c_function_signature(checker); - if ((sig) && - (is_pair(sig)) && - (car(sig) != sc->is_boolean_symbol)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A checker function, ~S, should return a boolean value", 54), caller, checker)); - hash_table_checker(ht) = hash_c_function; - } - else hash_table_checker(ht) = hash_closure; - - if (is_any_c_function(mapper)) - { - s7_pointer sig = c_function_signature(mapper); - if ((sig) && - (is_pair(sig)) && - (car(sig) != sc->is_integer_symbol)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A mapper function, ~S, should return an integer", 48), caller, mapper)); - hash_table_mapper(ht) = c_function_hash_map; - } - else hash_table_mapper(ht) = closure_hash_map; - - if (is_null(hash_table_procedures(ht))) - hash_table_set_procedures(ht, make_hash_table_procedures(sc)); - hash_table_set_procedures_checker(ht, car(proc)); /* proc = cadr(args) */ - hash_table_set_procedures_mapper(ht, cdr(proc)); - return(ht); - } - if (proc != sc->F) - wrong_type_error_nr(sc, caller, 2, proc, wrap_string(sc, "either #f or (cons equality-func map-func)", 42)); - return(ht); - }}} + if (c_function_call(proc) == g_strings_are_ci_equal) + { + hash_table_checker(ht) = hash_ci_string; + hash_table_mapper(ht) = string_ci_eq_hash_map; + return(ht); + } + if (c_function_call(proc) == g_chars_are_ci_equal) + { + hash_table_checker(ht) = hash_ci_char; + hash_table_mapper(ht) = char_ci_eq_hash_map; + return(ht); + } +#endif + if (c_function_call(proc) == g_chars_are_equal) + { + hash_table_checker(ht) = hash_char; + hash_table_mapper(ht) = char_eq_hash_map; + return(ht); + } + if (c_function_call(proc) == g_num_eq) + { + if ((is_typed_hash_table(ht)) && + (hash_table_key_typer(ht) == global_value(sc->is_integer_symbol))) + hash_table_checker(ht) = hash_int; + else hash_table_checker(ht) = hash_number_num_eq; + return(ht); + } + if (c_function_call(proc) == g_is_eqv) + { + hash_table_checker(ht) = hash_eqv; + return(ht); + } + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "~A second argument, ~S, is not a built-in function it can handle", 64), caller, proc)); + } + /* proc not c_function */ + else + { + if (is_pair(proc)) + { + s7_pointer checker = car(proc), mapper = cdr(proc); + + hash_set_chosen(ht); + if (!((is_any_c_function(checker)) || + (is_any_closure(checker)))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A: first entry of type info, ~A, is ~A, but should be a function", 65), + caller, checker, type_name_string(sc, checker))); + if (!((is_any_c_function(mapper)) || + (is_any_closure(mapper)))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A: second entry of type info, ~A, is ~A, but should be a function", 66), + caller, mapper, type_name_string(sc, mapper))); + + if (!(s7_is_aritable(sc, checker, 2))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A's equality function, ~A, (car of the second argument) should be a function of two arguments", 94), + caller, checker)); + if (!(s7_is_aritable(sc, mapper, 1))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A's mapping function, ~A, (cdr of the second argument) should be a function of one argument", 92), + caller, mapper)); + + if (is_any_c_function(checker)) + { + s7_pointer sig = c_function_signature(checker); + if ((sig) && + (is_pair(sig)) && + (car(sig) != sc->is_boolean_symbol)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A checker function, ~S, should return a boolean value", 54), caller, checker)); + hash_table_checker(ht) = hash_c_function; + } + else hash_table_checker(ht) = hash_closure; + + if (is_any_c_function(mapper)) + { + s7_pointer sig = c_function_signature(mapper); + if ((sig) && + (is_pair(sig)) && + (car(sig) != sc->is_integer_symbol)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A mapper function, ~S, should return an integer", 48), caller, mapper)); + hash_table_mapper(ht) = c_function_hash_map; + } + else hash_table_mapper(ht) = closure_hash_map; + + if (is_null(hash_table_procedures(ht))) + hash_table_set_procedures(ht, make_hash_table_procedures(sc)); + hash_table_set_procedures_checker(ht, car(proc)); /* proc = cadr(args) */ + hash_table_set_procedures_mapper(ht, cdr(proc)); + return(ht); + } + if (proc != sc->F) + wrong_type_error_nr(sc, caller, 2, proc, wrap_string(sc, "either #f or (cons equality-func map-func)", 42)); + return(ht); + }}} return(s7_make_hash_table(sc, size)); } @@ -44925,8 +44925,8 @@ static s7_pointer g_make_weak_hash_table(s7_scheme *sc, s7_pointer args) { #define H_make_weak_hash_table "(make-weak-hash-table (size 8) eq-func typers) returns a new weak hash table" #define Q_make_weak_hash_table s7_make_signature(sc, 4, sc->is_weak_hash_table_symbol, sc->is_integer_symbol, \ - s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \ - s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol)) + s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_pair_symbol, sc->not_symbol), \ + s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol)) s7_pointer table = g_make_hash_table_1(sc, args, sc->make_weak_hash_table_symbol); set_weak_hash_table(table); weak_hash_iters(table) = 0; @@ -45053,12 +45053,12 @@ static void resize_hash_table(s7_scheme *sc, s7_pointer table) { hash_entry_t *n; for (hash_entry_t *x = old_els[i]; x; x = n) - { - s7_int loc = hash_entry_raw_hash(x) & hash_mask; - n = hash_entry_next(x); - hash_entry_next(x) = new_els[loc]; - new_els[loc] = x; - }} + { + s7_int loc = hash_entry_raw_hash(x) & hash_mask; + n = hash_entry_next(x); + hash_entry_next(x) = new_els[loc]; + new_els[loc] = x; + }} liberate(sc, hash_table_block(table)); hash_table_set_block(table, np); hash_table_elements(table) = new_els; @@ -45144,7 +45144,7 @@ static s7_pointer hash_table_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t ar { s7_pointer key = caddr(expr); if ((is_pair(key)) && (car(key) == sc->substring_symbol) && (is_global(sc->substring_symbol))) - set_c_function(key, sc->substring_uncopied); + set_c_function(key, sc->substring_uncopied); return(sc->hash_table_ref_2); } return(f); @@ -45167,11 +45167,11 @@ static s7_pointer remove_from_hash_table(s7_scheme *sc, s7_pointer table, hash_e { hash_entry_t *y; for (y = x, x = hash_entry_next(x); x; y = x, x = hash_entry_next(x)) - if (x == p) - { - hash_entry_next(y) = hash_entry_next(x); - break; - }} + if (x == p) + { + hash_entry_next(y) = hash_entry_next(x); + break; + }} hash_table_entries(table)--; if ((hash_table_entries(table) == 0) && (hash_table_mapper(table) == default_hash_map)) @@ -45191,29 +45191,29 @@ static void cull_weak_hash_table(s7_scheme *sc, s7_pointer table) { hash_entry_t *nxp, *lxp = entries[i]; for (hash_entry_t *xp = entries[i]; xp; xp = nxp) - { - nxp = hash_entry_next(xp); - if (is_free_and_clear(hash_entry_key(xp))) - { - if (xp == entries[i]) - { - entries[i] = nxp; - lxp = nxp; - } - else hash_entry_next(lxp) = nxp; - liberate_block(sc, xp); - hash_table_entries(table)--; - if (hash_table_entries(table) == 0) - { - if (hash_table_mapper(table) == default_hash_map) - { - hash_table_checker(table) = hash_empty; - hash_clear_chosen(table); - } - return; - }} - else lxp = xp; - }} + { + nxp = hash_entry_next(xp); + if (is_free_and_clear(hash_entry_key(xp))) + { + if (xp == entries[i]) + { + entries[i] = nxp; + lxp = nxp; + } + else hash_entry_next(lxp) = nxp; + liberate_block(sc, xp); + hash_table_entries(table)--; + if (hash_table_entries(table) == 0) + { + if (hash_table_mapper(table) == default_hash_map) + { + hash_table_checker(table) = hash_empty; + hash_clear_chosen(table); + } + return; + }} + else lxp = xp; + }} } static void hash_table_set_default_checker(s7_pointer table, uint8_t typ) @@ -45221,12 +45221,12 @@ static void hash_table_set_default_checker(s7_pointer table, uint8_t typ) if (hash_table_checker(table) != default_hash_checks[typ]) { if (hash_table_checker(table) == hash_empty) - hash_table_checker(table) = default_hash_checks[typ]; + hash_table_checker(table) = default_hash_checks[typ]; else - { - hash_table_checker(table) = hash_equal; - hash_set_chosen(table); - }} + { + hash_table_checker(table) = hash_equal; + hash_set_chosen(table); + }} } static s7_pointer hash_table_typer_symbol(s7_scheme *sc, s7_pointer typer) @@ -45242,50 +45242,50 @@ static void check_hash_types(s7_scheme *sc, s7_pointer table, s7_pointer key, s7 { s7_pointer typer = hash_table_key_typer(table); if ((is_c_function(typer)) && ((uint8_t)symbol_type(c_function_symbol(typer)) != type(key))) - { - const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_key_typer(table)), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, wrap_string(sc, "hash-table-set! key", 19), 2, key, wrap_string(sc, tstr, safe_strlen(tstr))); - }} + { + const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_key_typer(table)), INDEFINITE_ARTICLE); + wrong_type_error_nr(sc, wrap_string(sc, "hash-table-set! key", 19), 2, key, wrap_string(sc, tstr, safe_strlen(tstr))); + }} else { s7_pointer kf = hash_table_key_typer(table); if (kf != sc->T) - { - s7_pointer type_ok; - if (is_c_function(kf)) - type_ok = c_function_call(kf)(sc, set_plist_1(sc, key)); - else type_ok = s7_apply_function(sc, kf, set_plist_1(sc, key)); - if (type_ok == sc->F) - { - const char *descr = hash_table_typer_name(sc, hash_table_key_typer(table)); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "hash-table-set! second argument ~$, is ~A, but the hash-table's key type checker, ~A, rejects it", 96), - key, type_name_string(sc, key), wrap_string(sc, descr, safe_strlen(descr)))); - }}} + { + s7_pointer type_ok; + if (is_c_function(kf)) + type_ok = c_function_call(kf)(sc, set_plist_1(sc, key)); + else type_ok = s7_apply_function(sc, kf, set_plist_1(sc, key)); + if (type_ok == sc->F) + { + const char *descr = hash_table_typer_name(sc, hash_table_key_typer(table)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "hash-table-set! second argument ~$, is ~A, but the hash-table's key type checker, ~A, rejects it", 96), + key, type_name_string(sc, key), wrap_string(sc, descr, safe_strlen(descr)))); + }}} if (has_hash_value_type(table)) { s7_pointer typer = hash_table_value_typer(table); if ((is_c_function(typer)) && ((uint8_t)symbol_type(c_function_symbol(typer)) != type(value))) - { - const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_value_typer(table)), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, sc->hash_table_set_symbol, 3, value, wrap_string(sc, tstr, safe_strlen(tstr))); - }} + { + const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_value_typer(table)), INDEFINITE_ARTICLE); + wrong_type_error_nr(sc, sc->hash_table_set_symbol, 3, value, wrap_string(sc, tstr, safe_strlen(tstr))); + }} else { s7_pointer vf = hash_table_value_typer(table); if (vf != sc->T) - { - s7_pointer type_ok; - if (is_c_function(vf)) - type_ok = c_function_call(vf)(sc, set_plist_1(sc, value)); - else type_ok = s7_apply_function(sc, vf, set_plist_1(sc, value)); - if (type_ok == sc->F) - { - const char *descr = hash_table_typer_name(sc, hash_table_value_typer(table)); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "hash-table-set! third argument ~$, is ~A, but the hash-table's value type checker, ~A, rejects it", 97), - value, type_name_string(sc, value), wrap_string(sc, descr, safe_strlen(descr)))); - }}} + { + s7_pointer type_ok; + if (is_c_function(vf)) + type_ok = c_function_call(vf)(sc, set_plist_1(sc, value)); + else type_ok = s7_apply_function(sc, vf, set_plist_1(sc, value)); + if (type_ok == sc->F) + { + const char *descr = hash_table_typer_name(sc, hash_table_value_typer(table)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "hash-table-set! third argument ~$, is ~A, but the hash-table's value type checker, ~A, rejects it", 97), + value, type_name_string(sc, value), wrap_string(sc, descr, safe_strlen(descr)))); + }}} } static void check_hash_table_checker(s7_scheme *sc, s7_pointer table, s7_pointer key) @@ -45294,37 +45294,37 @@ static void check_hash_table_checker(s7_scheme *sc, s7_pointer table, s7_pointer if (hash_table_checker(table) == hash_number_num_eq) { if (!is_number(key)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is =", 69), - key, type_name_string(sc, key))); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is =", 69), + key, type_name_string(sc, key))); } else if (hash_table_checker(table) == hash_eq) { - if (is_number(key)) /* (((type(key) >= T_INTEGER) && (type(key) < T_C_MACRO)) || (type(key) == T_PAIR)), but we might want eq? */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is eq?", 71), - key, type_name_string(sc, key))); + if (is_number(key)) /* (((type(key) >= T_INTEGER) && (type(key) < T_C_MACRO)) || (type(key) == T_PAIR)), but we might want eq? */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is eq?", 71), + key, type_name_string(sc, key))); } else #if WITH_PURE_S7 if (((hash_table_checker(table) == hash_string) && (!is_string(key))) || - ((hash_table_checker(table) == hash_char) && (!is_character(key)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A", 70), - key, type_name_string(sc, key), - (hash_table_checker(table) == hash_string) ? sc->string_eq_symbol : sc->char_eq_symbol)); + ((hash_table_checker(table) == hash_char) && (!is_character(key)))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A", 70), + key, type_name_string(sc, key), + (hash_table_checker(table) == hash_string) ? sc->string_eq_symbol : sc->char_eq_symbol)); #else if ((((hash_table_checker(table) == hash_string) || (hash_table_checker(table) == hash_ci_string)) && - (!is_string(key))) || - (((hash_table_checker(table) == hash_char) || (hash_table_checker(table) == hash_ci_char)) && - (!is_character(key)))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A", 70), - key, type_name_string(sc, key), - (hash_table_checker(table) == hash_string) ? sc->string_eq_symbol : - ((hash_table_checker(table) == hash_ci_string) ? sc->string_ci_eq_symbol : - ((hash_table_checker(table) == hash_char) ? sc->char_eq_symbol : sc->char_ci_eq_symbol)))); + (!is_string(key))) || + (((hash_table_checker(table) == hash_char) || (hash_table_checker(table) == hash_ci_char)) && + (!is_character(key)))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "hash-table-set! key ~S, is ~A, but the hash-table's key function is ~A", 70), + key, type_name_string(sc, key), + (hash_table_checker(table) == hash_string) ? sc->string_eq_symbol : + ((hash_table_checker(table) == hash_ci_string) ? sc->string_ci_eq_symbol : + ((hash_table_checker(table) == hash_char) ? sc->char_eq_symbol : sc->char_ci_eq_symbol)))); #endif } @@ -45392,18 +45392,18 @@ static s7_pointer hash_table_set_chooser(s7_scheme *sc, s7_pointer f, int32_t ar { s7_pointer val = cadddr(expr); if ((is_pair(val)) && (car(val) == sc->add_symbol) && (is_proper_list_3(sc, val)) && - ((cadr(val) == int_one) || (caddr(val) == int_one))) + ((cadr(val) == int_one) || (caddr(val) == int_one))) { - s7_pointer add1 = (cadr(val) == int_one) ? caddr(val) : cadr(val); - if ((is_pair(add1)) && (car(add1) == sc->or_symbol) && (is_proper_list_3(sc, add1)) && - (caddr(add1) == int_zero)) - { - s7_pointer or1 = cadr(add1); - if ((is_pair(or1)) && (car(or1) == sc->hash_table_ref_symbol) && (is_proper_list_3(sc, or1)) && - (cadr(or1) == cadr(expr)) && (caddr(or1) == caddr(expr))) - /* (hash-table-set! counts p (+ (or (hash-table-ref counts p) 0) 1)) */ - set_optimize_op(expr, HOP_HASH_TABLE_INCREMENT); - }}} + s7_pointer add1 = (cadr(val) == int_one) ? caddr(val) : cadr(val); + if ((is_pair(add1)) && (car(add1) == sc->or_symbol) && (is_proper_list_3(sc, add1)) && + (caddr(add1) == int_zero)) + { + s7_pointer or1 = cadr(add1); + if ((is_pair(or1)) && (car(or1) == sc->hash_table_ref_symbol) && (is_proper_list_3(sc, or1)) && + (cadr(or1) == cadr(expr)) && (caddr(or1) == caddr(expr))) + /* (hash-table-set! counts p (+ (or (hash-table-ref counts p) 0) 1)) */ + set_optimize_op(expr, HOP_HASH_TABLE_INCREMENT); + }}} return(f); } @@ -45423,7 +45423,7 @@ static inline s7_pointer hash_table_add(s7_scheme *sc, s7_pointer table, s7_poin for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x)) if ((hash_entry_raw_hash(x) == hash) && - (s7_is_equal(sc, hash_entry_key(x), key))) + (s7_is_equal(sc, hash_entry_key(x), key))) return(value); p = mallocate_block(sc); @@ -45444,18 +45444,18 @@ static s7_pointer g_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer call s7_int len = proper_list_length(args); if (len & 1) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~A got an odd number of arguments: ~S", 37), caller, args)); + set_elist_3(sc, wrap_string(sc, "~A got an odd number of arguments: ~S", 37), caller, args)); len /= 2; if (len > sc->max_vector_length) error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "~S passed too many entries (> ~D ~D) (*s7* 'max-vector-length)", 62), - caller, wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); + set_elist_4(sc, wrap_string(sc, "~S passed too many entries (> ~D ~D) (*s7* 'max-vector-length)", 62), + caller, wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); ht = s7_make_hash_table(sc, (len > sc->default_hash_table_length) ? len : sc->default_hash_table_length); if (len > 0) for (s7_pointer x = args, y = cdr(args); is_pair(x); x = cddr(x), y = unchecked_cdr(cdr(y))) if (car(y) != sc->F) - hash_table_add(sc, ht, car(x), car(y)); + hash_table_add(sc, ht, car(x), car(y)); return(ht); } @@ -45502,10 +45502,10 @@ static void check_old_hash(s7_scheme *sc, s7_pointer old_hash, s7_pointer new_ha for (s7_int i = 0; i < old_len; i++) for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) { - if (count >= end) - return; - if (count >= start) - check_hash_types(sc, new_hash, hash_entry_key(x), hash_entry_value(x)); + if (count >= end) + return; + if (count >= start) + check_hash_types(sc, new_hash, hash_entry_key(x), hash_entry_value(x)); } } @@ -45525,36 +45525,36 @@ static s7_pointer hash_table_copy(s7_scheme *sc, s7_pointer old_hash, s7_pointer if (hash_table_entries(new_hash) == 0) { if ((start == 0) && - (end >= hash_table_entries(old_hash))) - { - for (s7_int i = 0; i < old_len; i++) - for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) - { - s7_int loc = hash_entry_raw_hash(x) & new_mask; - hash_entry_t *p = make_hash_entry(sc, hash_entry_key(x), hash_entry_value(x), hash_entry_raw_hash(x)); - hash_entry_next(p) = new_lists[loc]; - new_lists[loc] = p; - } - hash_table_entries(new_hash) = hash_table_entries(old_hash); - return(new_hash); - } + (end >= hash_table_entries(old_hash))) + { + for (s7_int i = 0; i < old_len; i++) + for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) + { + s7_int loc = hash_entry_raw_hash(x) & new_mask; + hash_entry_t *p = make_hash_entry(sc, hash_entry_key(x), hash_entry_value(x), hash_entry_raw_hash(x)); + hash_entry_next(p) = new_lists[loc]; + new_lists[loc] = p; + } + hash_table_entries(new_hash) = hash_table_entries(old_hash); + return(new_hash); + } for (s7_int i = 0; i < old_len; i++) - for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) - { - if (count >= end) - { - hash_table_entries(new_hash) = end - start; - return(new_hash); - } - if (count >= start) - { - s7_int loc = hash_entry_raw_hash(x) & new_mask; - hash_entry_t *p = make_hash_entry(sc, hash_entry_key(x), hash_entry_value(x), hash_entry_raw_hash(x)); - hash_entry_next(p) = new_lists[loc]; - new_lists[loc] = p; - } - count++; - } + for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) + { + if (count >= end) + { + hash_table_entries(new_hash) = end - start; + return(new_hash); + } + if (count >= start) + { + s7_int loc = hash_entry_raw_hash(x) & new_mask; + hash_entry_t *p = make_hash_entry(sc, hash_entry_key(x), hash_entry_value(x), hash_entry_raw_hash(x)); + hash_entry_next(p) = new_lists[loc]; + new_lists[loc] = p; + } + count++; + } hash_table_entries(new_hash) = count - start; return(new_hash); } @@ -45563,24 +45563,24 @@ static s7_pointer hash_table_copy(s7_scheme *sc, s7_pointer old_hash, s7_pointer for (s7_int i = 0; i < old_len; i++) for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x)) { - if (count >= end) - return(new_hash); - if (count >= start) - { - hash_entry_t *y = (*hash_table_checker(new_hash))(sc, new_hash, hash_entry_key(x)); - if (y != sc->unentry) - hash_entry_set_value(y, hash_entry_value(x)); - else - { - s7_int loc = hash_entry_raw_hash(x) & new_mask; - hash_entry_t *p = make_hash_entry(sc, hash_entry_key(x), hash_entry_value(x), hash_entry_raw_hash(x)); - hash_entry_next(p) = new_lists[loc]; - new_lists[loc] = p; - hash_table_entries(new_hash)++; - if (!hash_chosen(new_hash)) - hash_table_set_default_checker(new_hash, type(hash_entry_key(x))); - }} - count++; + if (count >= end) + return(new_hash); + if (count >= start) + { + hash_entry_t *y = (*hash_table_checker(new_hash))(sc, new_hash, hash_entry_key(x)); + if (y != sc->unentry) + hash_entry_set_value(y, hash_entry_value(x)); + else + { + s7_int loc = hash_entry_raw_hash(x) & new_mask; + hash_entry_t *p = make_hash_entry(sc, hash_entry_key(x), hash_entry_value(x), hash_entry_raw_hash(x)); + hash_entry_next(p) = new_lists[loc]; + new_lists[loc] = p; + hash_table_entries(new_hash)++; + if (!hash_chosen(new_hash)) + hash_table_set_default_checker(new_hash, type(hash_entry_key(x))); + }} + count++; } return(new_hash); } @@ -45596,49 +45596,49 @@ static s7_pointer hash_table_fill(s7_scheme *sc, s7_pointer args) hash_entry_t **entries = hash_table_elements(table); s7_int len = hash_table_size(table); /* minimum len is 2 (see s7_make_hash_table) */ if (val == sc->F) /* hash-table-ref returns #f if it can't find a key, so val == #f here means empty the table */ - { - hash_entry_t **hp = entries; - hash_entry_t **hn = (hash_entry_t **)(hp + len); - for (; hp < hn; hp++) - { - if (*hp) - { - hash_entry_t *p = *hp; - while (hash_entry_next(p)) p = hash_entry_next(p); - hash_entry_next(p) = sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST] = *hp; - } - hp++; - if (*hp) - { - hash_entry_t *p = *hp; - while (hash_entry_next(p)) p = hash_entry_next(p); - hash_entry_next(p) = sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST] = *hp; - }} - if (len >= 8) - memclr64(entries, len * sizeof(hash_entry_t *)); - else memclr(entries, len * sizeof(hash_entry_t *)); - if (hash_table_mapper(table) == default_hash_map) - { - hash_table_checker(table) = hash_empty; - hash_clear_chosen(table); - } - hash_table_entries(table) = 0; - return(val); - } + { + hash_entry_t **hp = entries; + hash_entry_t **hn = (hash_entry_t **)(hp + len); + for (; hp < hn; hp++) + { + if (*hp) + { + hash_entry_t *p = *hp; + while (hash_entry_next(p)) p = hash_entry_next(p); + hash_entry_next(p) = sc->block_lists[BLOCK_LIST]; + sc->block_lists[BLOCK_LIST] = *hp; + } + hp++; + if (*hp) + { + hash_entry_t *p = *hp; + while (hash_entry_next(p)) p = hash_entry_next(p); + hash_entry_next(p) = sc->block_lists[BLOCK_LIST]; + sc->block_lists[BLOCK_LIST] = *hp; + }} + if (len >= 8) + memclr64(entries, len * sizeof(hash_entry_t *)); + else memclr(entries, len * sizeof(hash_entry_t *)); + if (hash_table_mapper(table) == default_hash_map) + { + hash_table_checker(table) = hash_empty; + hash_clear_chosen(table); + } + hash_table_entries(table) = 0; + return(val); + } if ((is_typed_hash_table(table)) && - (((is_c_function(hash_table_value_typer(table))) && - (c_function_call(hash_table_value_typer(table))(sc, set_plist_1(sc, val)) == sc->F)) || - ((is_any_closure(hash_table_value_typer(table))) && - (s7_apply_function(sc, hash_table_value_typer(table), set_plist_1(sc, val)) == sc->F)))) - { - const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_value_typer(table)), INDEFINITE_ARTICLE); - wrong_type_error_nr(sc, sc->fill_symbol, 2, val, wrap_string(sc, tstr, safe_strlen(tstr))); - } + (((is_c_function(hash_table_value_typer(table))) && + (c_function_call(hash_table_value_typer(table))(sc, set_plist_1(sc, val)) == sc->F)) || + ((is_any_closure(hash_table_value_typer(table))) && + (s7_apply_function(sc, hash_table_value_typer(table), set_plist_1(sc, val)) == sc->F)))) + { + const char *tstr = make_type_name(sc, hash_table_typer_name(sc, hash_table_value_typer(table)), INDEFINITE_ARTICLE); + wrong_type_error_nr(sc, sc->fill_symbol, 2, val, wrap_string(sc, tstr, safe_strlen(tstr))); + } for (s7_int i = 0; i < len; i++) - for (hash_entry_t *x = entries[i]; x; x = hash_entry_next(x)) - hash_entry_set_value(x, val); + for (hash_entry_t *x = entries[i]; x; x = hash_entry_next(x)) + hash_entry_set_value(x, val); /* keys haven't changed, so no need to mess with hash_table_checker */ } return(val); @@ -45715,7 +45715,7 @@ static c_proc_t *alloc_semipermanent_function(s7_scheme *sc) } s7_pointer s7_make_function(s7_scheme *sc, const char *name, s7_function f, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) + s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) { s7_pointer x = alloc_pointer(sc); x = make_function(sc, name, f, required_args, optional_args, rest_arg, doc, x, alloc_semipermanent_function(sc)); @@ -45724,7 +45724,7 @@ s7_pointer s7_make_function(s7_scheme *sc, const char *name, s7_function f, } s7_pointer s7_make_safe_function(s7_scheme *sc, const char *name, s7_function f, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) + s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) { s7_pointer p = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc); set_type_bit(p, T_SAFE_PROCEDURE); @@ -45732,7 +45732,7 @@ s7_pointer s7_make_safe_function(s7_scheme *sc, const char *name, s7_function f, } s7_pointer s7_make_typed_function(s7_scheme *sc, const char *name, s7_function f, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc, s7_pointer signature) + s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc, s7_pointer signature) { s7_pointer func = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc); set_type_bit(func, T_SAFE_PROCEDURE); @@ -45789,7 +45789,7 @@ static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args) if ((is_symbol(p)) && ((symbol_ctr(p) == 0) || ((p = s7_symbol_value(sc, p)) == sc->undefined))) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "procedure-source arg, '~S, is unbound", 37), car(args))); + set_elist_2(sc, wrap_string(sc, "procedure-source arg, '~S, is unbound", 37), car(args))); if ((is_c_function(p)) || (is_c_macro(p))) return(sc->nil); @@ -45799,7 +45799,7 @@ static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args) s7_pointer body = closure_body(p); /* perhaps if this function has been removed from the heap, it would be better to use copy_body (as in s7_copy)? */ if (is_safe_closure_body(body)) - clear_safe_closure_body(body); + clear_safe_closure_body(body); return(append_in_place(sc, list_2(sc, procedure_type_to_symbol(sc, type(p)), closure_args(p)), body)); } if (!is_procedure(p)) @@ -45837,8 +45837,8 @@ and 'arglist. (define (func x y) (*function* (curlet) 'arglist)) (func 1 2): '(x if (is_null(args)) /* (*function*) is akin to __func__ in C */ { for (e = sc->curlet; e; e = let_outlet(e)) - if ((is_funclet(e)) || (is_maclet(e))) - break; + if ((is_funclet(e)) || (is_maclet(e))) + break; return(let_to_function(sc, e)); } e = car(args); @@ -45848,7 +45848,7 @@ and 'arglist. (define (func x y) (*function* (curlet) 'arglist)) (func 1 2): '(x { sym = cadr(args); if (!is_symbol(sym)) - wrong_type_error_nr(sc, sc->_function__symbol, 2, sym, sc->type_names[T_SYMBOL]); + wrong_type_error_nr(sc, sc->_function__symbol, 2, sym, sc->type_names[T_SYMBOL]); } if (e == sc->rootlet) return(sc->F); @@ -45887,13 +45887,13 @@ static s7_pointer g_funclet(s7_scheme *sc, s7_pointer args) { #define H_funclet "(funclet func) tries to return a function's definition environment" #define Q_funclet s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), \ - s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_macro_symbol, sc->is_symbol_symbol)) + s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_macro_symbol, sc->is_symbol_symbol)) s7_pointer p = car(args); if (is_symbol(p)) { if ((symbol_ctr(p) == 0) || ((p = s7_symbol_value(sc, p)) == sc->undefined)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "funclet argument, '~S, is unbound", 33), car(args))); /* not p here */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "funclet argument, '~S, is unbound", 33), car(args))); /* not p here */ } check_method(sc, p, sc->funclet_symbol, args); if (!((is_any_procedure(p)) || (is_c_object(p)))) @@ -45908,7 +45908,7 @@ static s7_pointer g_funclet(s7_scheme *sc, s7_pointer args) * but there's no way to tell in general that the let is not exported. */ s7_pointer s7_define_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) + s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) { s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); s7_pointer sym = make_symbol_with_strlen(sc, name); @@ -45917,7 +45917,7 @@ s7_pointer s7_define_function(s7_scheme *sc, const char *name, s7_function fnc, } s7_pointer s7_define_safe_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) + s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) { /* returns (string->symbol name), not the c_proc_t func */ s7_pointer func = s7_make_safe_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); @@ -45927,8 +45927,8 @@ s7_pointer s7_define_safe_function(s7_scheme *sc, const char *name, s7_function } s7_pointer s7_define_typed_function(s7_scheme *sc, const char *name, s7_function fnc, /* same as above, but include sig */ - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature) + s7_int required_args, s7_int optional_args, bool rest_arg, + const char *doc, s7_pointer signature) { /* returns (string->symbol name), not the c_proc_t func */ s7_pointer func = s7_make_typed_function(sc, name, fnc, required_args, optional_args, rest_arg, doc, signature); /* includes "safe" bit */ @@ -45939,9 +45939,9 @@ s7_pointer s7_define_typed_function(s7_scheme *sc, const char *name, s7_function } static s7_pointer define_bool_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int optional_args, const char *doc, s7_pointer signature, int32_t sym_to_type, - void (*marker)(s7_pointer p, s7_int top), - bool simple, s7_function bool_setter) + s7_int optional_args, const char *doc, s7_pointer signature, int32_t sym_to_type, + void (*marker)(s7_pointer p, s7_int top), + bool simple, s7_function bool_setter) { s7_pointer bfunc; s7_pointer func = s7_make_typed_function(sc, name, fnc, 1, optional_args, false, doc, signature); /* includes "safe" bit */ @@ -45960,8 +45960,8 @@ static s7_pointer define_bool_function(s7_scheme *sc, const char *name, s7_funct } s7_pointer s7_define_unsafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature) + s7_int required_args, s7_int optional_args, bool rest_arg, + const char *doc, s7_pointer signature) { /* returns (string->symbol name), not the c_proc_t func */ s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); @@ -45972,8 +45972,8 @@ s7_pointer s7_define_unsafe_typed_function(s7_scheme *sc, const char *name, s7_f } s7_pointer s7_define_semisafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, - const char *doc, s7_pointer signature) + s7_int required_args, s7_int optional_args, bool rest_arg, + const char *doc, s7_pointer signature) { s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); s7_pointer sym = make_symbol_with_strlen(sc, name); @@ -46022,38 +46022,38 @@ s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fn /* (define* (f :allow-other-keys) 32) -> :allow-other-keys can't be the only parameter: (:allow-other-keys) */ for (s7_int i = 0; i < n_args; p = cdr(p), i++) - { - s7_pointer arg = car(p); - if (arg == sc->allow_other_keys_keyword) - { - if (is_not_null(cdr(p))) - s7_warn(sc, 256, "%s :allow-other-keys should be the last parameter: %s\n", name, arglist); - if (p == local_args) - s7_warn(sc, 256, "%s :allow-other-keys can't be the only parameter: %s\n", name, arglist); - c_function_set_allow_other_keys(func); /* local_args is local, so it can't carry the bit */ - n_args--; - c_function_optional_args(func) = n_args; - c_function_max_args(func) = n_args; /* apparently not counting keywords */ - } - else - if (is_pair(arg)) /* there is a default */ - { - names[i] = car(arg); /* key can be passed at runtime as :key or key: so we need both or the symbol */ - defaults[i] = cadr(arg); - remove_from_heap(sc, cadr(arg)); /* ?? */ - if ((is_pair(defaults[i])) || - (is_normal_symbol(defaults[i]))) - { - c_func_clear_simple_defaults(func); - mark_function[T_C_FUNCTION_STAR] = mark_c_proc_star; - }} - else - { - if (arg == sc->rest_keyword) - s7_warn(sc, 256, "%s :rest is not supported in C-side define*: %s\n", name, arglist); - names[i] = arg; - defaults[i] = sc->F; - }}} + { + s7_pointer arg = car(p); + if (arg == sc->allow_other_keys_keyword) + { + if (is_not_null(cdr(p))) + s7_warn(sc, 256, "%s :allow-other-keys should be the last parameter: %s\n", name, arglist); + if (p == local_args) + s7_warn(sc, 256, "%s :allow-other-keys can't be the only parameter: %s\n", name, arglist); + c_function_set_allow_other_keys(func); /* local_args is local, so it can't carry the bit */ + n_args--; + c_function_optional_args(func) = n_args; + c_function_max_args(func) = n_args; /* apparently not counting keywords */ + } + else + if (is_pair(arg)) /* there is a default */ + { + names[i] = car(arg); /* key can be passed at runtime as :key or key: so we need both or the symbol */ + defaults[i] = cadr(arg); + remove_from_heap(sc, cadr(arg)); /* ?? */ + if ((is_pair(defaults[i])) || + (is_normal_symbol(defaults[i]))) + { + c_func_clear_simple_defaults(func); + mark_function[T_C_FUNCTION_STAR] = mark_c_proc_star; + }} + else + { + if (arg == sc->rest_keyword) + s7_warn(sc, 256, "%s :rest is not supported in C-side define*: %s\n", name, arglist); + names[i] = arg; + defaults[i] = sc->F; + }}} else set_full_type(func, T_C_FUNCTION | T_UNHEAP); s7_gc_unprotect_at(sc, gc_loc); @@ -46096,7 +46096,7 @@ void s7_define_typed_function_star(s7_scheme *sc, const char *name, s7_function s7_pointer s7_define_macro(s7_scheme *sc, const char *name, s7_function fnc, - s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) + s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc) { s7_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc); s7_pointer sym = make_symbol_with_strlen(sc, name); @@ -46146,7 +46146,7 @@ const char *s7_documentation(s7_scheme *sc, s7_pointer x) { if (is_keyword(x)) return(NULL); if (symbol_has_help(x)) - return(symbol_help(x)); + return(symbol_help(x)); x = s7_symbol_value(sc, x); /* this is needed by Snd */ } if ((is_any_c_function(x)) || @@ -46164,7 +46164,7 @@ const char *s7_documentation(s7_scheme *sc, s7_pointer x) { val = closure_body(x); if ((is_pair(val)) && (is_string(car(val)))) - return((char *)string_value(car(val))); + return((char *)string_value(car(val))); } return(NULL); } @@ -46178,8 +46178,8 @@ static s7_pointer g_documentation(s7_scheme *sc, s7_pointer args) if (is_symbol(p)) { if ((symbol_has_help(p)) && - (is_global(p))) - return(s7_make_string(sc, symbol_help(p))); + (is_global(p))) + return(s7_make_string(sc, symbol_help(p))); p = s7_symbol_value(sc, p); } /* (documentation func) should act like (documentation abs) -- available without (openlet (funclet func)) or (openlet func) @@ -46190,10 +46190,10 @@ static s7_pointer g_documentation(s7_scheme *sc, s7_pointer args) { s7_pointer func = funclet_entry(sc, p, sc->documentation_symbol); if (func) - return(s7_apply_function(sc, func, args)); + return(s7_apply_function(sc, func, args)); func = closure_body(p); if ((is_pair(func)) && (is_string(car(func)))) - return(car(func)); + return(car(func)); } /* it would be neat if this would work (define x (let ((+documentation+ "hio")) (vector 1 2 3))) (documentation x) */ check_method(sc, p, sc->documentation_symbol, args); @@ -46223,7 +46223,7 @@ const char *s7_help(s7_scheme *sc, s7_pointer obj) { /* here look for name */ if (s7_documentation(sc, obj)) - return(s7_documentation(sc, obj)); + return(s7_documentation(sc, obj)); obj = s7_symbol_value(sc, obj); } if (is_any_procedure(obj)) @@ -46277,20 +46277,20 @@ static s7_pointer g_signature(s7_scheme *sc, s7_pointer args) case T_BACRO: case T_BACRO_STAR: case T_CLOSURE: case T_CLOSURE_STAR: { - s7_pointer func = funclet_entry(sc, p, sc->local_signature_symbol); - if (func) return(func); - func = funclet_entry(sc, p, sc->signature_symbol); - return((func) ? s7_apply_function(sc, func, args) : sc->F); + s7_pointer func = funclet_entry(sc, p, sc->local_signature_symbol); + if (func) return(func); + func = funclet_entry(sc, p, sc->signature_symbol); + return((func) ? s7_apply_function(sc, func, args) : sc->F); } case T_VECTOR: if (vector_length(p) == 0) return(sc->F); /* sig () is #f so sig #() should be #f */ if (!is_typed_vector(p)) - return(sc->vector_signature); + return(sc->vector_signature); { - s7_pointer lst = list_3(sc, typed_vector_typer_symbol(sc, p), sc->is_vector_symbol, sc->is_integer_symbol); - set_cdddr(lst, cddr(lst)); - return(lst); + s7_pointer lst = list_3(sc, typed_vector_typer_symbol(sc, p), sc->is_vector_symbol, sc->is_integer_symbol); + set_cdddr(lst, cddr(lst)); + return(lst); } case T_FLOAT_VECTOR: return((vector_length(p) == 0) ? sc->F : sc->float_vector_signature); @@ -46301,16 +46301,16 @@ static s7_pointer g_signature(s7_scheme *sc, s7_pointer args) case T_HASH_TABLE: if (is_typed_hash_table(p)) - return(list_3(sc, - hash_table_typer_symbol(sc, hash_table_value_typer(p)), - sc->is_hash_table_symbol, - hash_table_typer_symbol(sc, hash_table_key_typer(p)))); + return(list_3(sc, + hash_table_typer_symbol(sc, hash_table_value_typer(p)), + sc->is_hash_table_symbol, + hash_table_typer_symbol(sc, hash_table_key_typer(p)))); return(sc->hash_table_signature); case T_ITERATOR: p = iterator_sequence(p); if ((is_hash_table(p)) || (is_let(p))) /* cons returned -- would be nice to include the car/cdr types if known */ - return(list_1(sc, sc->is_pair_symbol)); + return(list_1(sc, sc->is_pair_symbol)); p = g_signature(sc, set_plist_1(sc, p)); return(list_1(sc, (is_pair(p)) ? car(p) : sc->T)); @@ -46325,14 +46325,14 @@ static s7_pointer g_signature(s7_scheme *sc, s7_pointer args) case T_SYMBOL: /* this used to get the symbol's value and call g_signature on that */ { - s7_pointer slot = s7_slot(sc, p); - if ((is_slot(slot)) && (slot_has_setter(slot))) - { - s7_pointer setter = slot_setter(slot); - p = g_signature(sc, set_plist_1(sc, setter)); - if (is_pair(p)) - return(list_1(sc, car(p))); - }} + s7_pointer slot = s7_slot(sc, p); + if ((is_slot(slot)) && (slot_has_setter(slot))) + { + s7_pointer setter = slot_setter(slot); + p = g_signature(sc, set_plist_1(sc, setter)); + if (is_pair(p)) + return(list_1(sc, car(p))); + }} break; default: break; @@ -46511,7 +46511,7 @@ s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_p if (jump_loc != NO_JUMP) { if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); + eval(sc, sc->cur_op); } else { @@ -46524,15 +46524,15 @@ s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_p dynamic_wind_out(p) = T_Ext(finish); push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p); if (init != sc->F) - { - dynamic_wind_state(p) = DWIND_INIT; - sc->code = init; - } + { + dynamic_wind_state(p) = DWIND_INIT; + sc->code = init; + } else - { - dynamic_wind_state(p) = DWIND_BODY; - sc->code = body; - } + { + dynamic_wind_state(p) = DWIND_BODY; + sc->code = body; + } eval(sc, OP_APPLY); } restore_jump_info(sc); @@ -46586,14 +46586,14 @@ static bool op_dynamic_wind(s7_scheme *sc) { dynamic_wind_state(dwind) = DWIND_FINISH; if (dynamic_wind_out(dwind) != sc->F) - { - push_stack(sc, OP_DYNAMIC_WIND, sc->value, dwind); - sc->code = dynamic_wind_out(dwind); - sc->args = sc->nil; - return(true); - } + { + push_stack(sc, OP_DYNAMIC_WIND, sc->value, dwind); + sc->code = dynamic_wind_out(dwind); + sc->args = sc->nil; + return(true); + } if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); + sc->value = splice_in_values(sc, multiple_value(sc->value)); return(false); /* goto start */ } if (is_multiple_value(sc->args)) /* (+ 1 (dynamic-wind (lambda () #f) (lambda () (values 2 3 4)) (lambda () #f)) 5) */ @@ -46621,10 +46621,10 @@ static s7_pointer g_is_c_object(s7_scheme *sc, s7_pointer args) static noreturn void apply_error_nr(s7_scheme *sc, s7_pointer obj, s7_pointer args) { error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "attempt to apply ~A ~$ in ~S?", 29), - (is_null(obj)) ? wrap_string(sc, "nil", 3) : ((is_symbol_and_keyword(obj)) ? wrap_string(sc, "a keyword", 9) : type_name_string(sc, obj)), - obj, - cons(sc, obj, args))); /* was current_code(sc) which is unreliable */ + set_elist_4(sc, wrap_string(sc, "attempt to apply ~A ~$ in ~S?", 29), + (is_null(obj)) ? wrap_string(sc, "nil", 3) : ((is_symbol_and_keyword(obj)) ? wrap_string(sc, "a keyword", 9) : type_name_string(sc, obj)), + obj, + cons(sc, obj, args))); /* was current_code(sc) which is unreliable */ } static void fallback_free(void *value) {} @@ -46667,15 +46667,15 @@ s7_int s7_make_c_type(s7_scheme *sc, const char *name) /* shouldn't this be s7_m if (tag >= sc->c_object_types_size) { if (sc->c_object_types_size == 0) - { - sc->c_object_types_size = 8; - sc->c_object_types = (c_object_t **)Calloc(sc->c_object_types_size, sizeof(c_object_t *)); - } + { + sc->c_object_types_size = 8; + sc->c_object_types = (c_object_t **)Calloc(sc->c_object_types_size, sizeof(c_object_t *)); + } else - { - sc->c_object_types_size = tag * 2; - sc->c_object_types = (c_object_t **)Realloc((void *)(sc->c_object_types), sc->c_object_types_size * sizeof(c_object_t *)); - }} + { + sc->c_object_types_size = tag * 2; + sc->c_object_types = (c_object_t **)Realloc((void *)(sc->c_object_types), sc->c_object_types_size * sizeof(c_object_t *)); + }} c_type = (c_object_t *)Calloc(1, sizeof(c_object_t)); /* Malloc+field=NULL is slightly faster here */ sc->c_object_types[tag] = c_type; c_type->type = tag; @@ -46823,9 +46823,9 @@ static s7_pointer c_object_type_to_let(s7_scheme *sc, s7_pointer cobj) c_object_t *c_type = sc->c_object_types[type]; return(internal_inlet(sc, 6, - sc->name_symbol, c_type->scheme_name, - make_symbol(sc, "getter", 6), s7_object_to_string(sc, c_type->getter, false), - sc->setter_symbol, s7_object_to_string(sc, c_type->setter, false))); + sc->name_symbol, c_type->scheme_name, + make_symbol(sc, "getter", 6), s7_object_to_string(sc, c_type->getter, false), + sc->setter_symbol, s7_object_to_string(sc, c_type->setter, false))); /* can't display equal et al in c_types -- maybe sc->F or the pointer? or add getter equivalent fields for equal et al? */ } @@ -46859,10 +46859,10 @@ static s7_pointer fx_implicit_c_object_ref_a(s7_scheme *sc, s7_pointer arg) /* -------- dilambda -------- */ s7_pointer s7_dilambda_with_environment(s7_scheme *sc, s7_pointer envir, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), s7_int set_req_args, s7_int set_opt_args, - const char *documentation) + const char *name, + s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), s7_int get_req_args, s7_int get_opt_args, + s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), s7_int set_req_args, s7_int set_opt_args, + const char *documentation) { s7_pointer get_func, set_func; char *internal_set_name; @@ -46882,20 +46882,20 @@ s7_pointer s7_dilambda_with_environment(s7_scheme *sc, s7_pointer envir, } s7_pointer s7_dilambda(s7_scheme *sc, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), s7_int set_req_args, s7_int set_opt_args, - const char *documentation) + const char *name, + s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), s7_int get_req_args, s7_int get_opt_args, + s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), s7_int set_req_args, s7_int set_opt_args, + const char *documentation) { return(s7_dilambda_with_environment(sc, sc->nil, name, getter, get_req_args, get_opt_args, setter, set_req_args, set_opt_args, documentation)); } s7_pointer s7_typed_dilambda(s7_scheme *sc, - const char *name, - s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), s7_int get_req_args, s7_int get_opt_args, - s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), s7_int set_req_args, s7_int set_opt_args, - const char *documentation, - s7_pointer get_sig, s7_pointer set_sig) + const char *name, + s7_pointer (*getter)(s7_scheme *sc, s7_pointer args), s7_int get_req_args, s7_int get_opt_args, + s7_pointer (*setter)(s7_scheme *sc, s7_pointer args), s7_int set_req_args, s7_int set_opt_args, + const char *documentation, + s7_pointer get_sig, s7_pointer set_sig) { s7_pointer get_func = s7_dilambda(sc, name, getter, get_req_args, get_opt_args, setter, set_req_args, set_opt_args, documentation); s7_pointer set_func = c_function_setter(get_func); @@ -46970,22 +46970,22 @@ static void closure_star_arity_1(s7_scheme *sc, s7_pointer x, s7_pointer args) if (closure_arity_unknown(x)) { if (is_null(args)) - closure_set_arity(x, 0); + closure_set_arity(x, 0); else - if ((is_symbol(args)) || (allows_other_keys(args))) - closure_set_arity(x, -1); - else - { - s7_pointer p; - int32_t i; - for (i = 0, p = args; is_pair(p); i++, p = cdr(p)) /* is_pair(p) so (f1 a . b) will end with b not null */ - { - s7_pointer arg = car(p); - if (arg == sc->rest_keyword) - break; - } - closure_set_arity(x, ((is_null(p)) ? i : -1)); /* see below */ - }} + if ((is_symbol(args)) || (allows_other_keys(args))) + closure_set_arity(x, -1); + else + { + s7_pointer p; + int32_t i; + for (i = 0, p = args; is_pair(p); i++, p = cdr(p)) /* is_pair(p) so (f1 a . b) will end with b not null */ + { + s7_pointer arg = car(p); + if (arg == sc->rest_keyword) + break; + } + closure_set_arity(x, ((is_null(p)) ? i : -1)); /* see below */ + }} } static s7_pointer closure_star_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer x_args) @@ -47003,13 +47003,13 @@ static int32_t closure_arity_to_int(s7_scheme *sc, s7_pointer x) s7_pointer b; for (i = 0, b = closure_args(x); is_pair(b); i++, b = cdr(b)) {}; if (is_null(b)) - closure_set_arity(x, i); + closure_set_arity(x, i); else - { - if (i == 0) - return(-1); - closure_set_arity(x, -i); - }} + { + if (i == 0) + return(-1); + closure_set_arity(x, -i); + }} return(closure_arity(x)); } @@ -47096,7 +47096,7 @@ static bool closure_star_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_a return(true); closure_star_arity_1(sc, x, x_args); return((closure_arity(x) == -1) || - (args <= closure_arity(x))); + (args <= closure_arity(x))); } bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args) @@ -47107,8 +47107,8 @@ bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args) return(c_function_is_aritable(x, args)); case T_C_RST_NO_REQ_FUNCTION: if ((x == initial_value(sc->hash_table_symbol)) || /* these two need a value for each key */ - (x == initial_value(sc->weak_hash_table_symbol))) - return((args & 1) == 0); + (x == initial_value(sc->weak_hash_table_symbol))) + return((args & 1) == 0); case T_C_FUNCTION_STAR: return(c_function_max_args(x) >= args); @@ -47120,7 +47120,7 @@ bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args) case T_C_MACRO: return((c_macro_min_args(x) <= args) && - (c_macro_max_args(x) >= args)); + (c_macro_max_args(x) >= args)); case T_GOTO: case T_CONTINUATION: return(true); @@ -47130,17 +47130,17 @@ bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args) case T_C_OBJECT: { - s7_pointer func; - if ((has_active_methods(sc, x)) && - ((func = find_method_with_let(sc, x, sc->is_aritable_symbol)) != sc->undefined)) - return(s7_apply_function(sc, func, set_plist_2(sc, x, make_integer(sc, args))) != sc->F); - return(is_safe_procedure(x)); + s7_pointer func; + if ((has_active_methods(sc, x)) && + ((func = find_method_with_let(sc, x, sc->is_aritable_symbol)) != sc->undefined)) + return(s7_apply_function(sc, func, set_plist_2(sc, x, make_integer(sc, args))) != sc->F); + return(is_safe_procedure(x)); } case T_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: return((args > 0) && - (vector_length(x) > 0) && /* (#() 0) -> error */ - (args <= vector_rank(x))); + (vector_length(x) > 0) && /* (#() 0) -> error */ + (args <= vector_rank(x))); case T_LET: case T_HASH_TABLE: case T_PAIR: /* for hash-table, this refers to (table 'key) */ return(args == 1); @@ -47215,8 +47215,8 @@ static s7_pointer b_simple_setter(s7_scheme *sc, int32_t typer, s7_pointer args) { if (type(cadr(args)) != typer) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), - car(args), cadr(args), sc->type_names[type(cadr(args))], sc->type_names[typer])); + set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), + car(args), cadr(args), sc->type_names[type(cadr(args))], sc->type_names[typer])); return(cadr(args)); } @@ -47244,13 +47244,13 @@ static s7_pointer b_is_unspecified_setter(s7_scheme *sc, s7_pointer args) {retu static s7_pointer b_is_c_object_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_C_OBJECT, args));} static s7_pointer b_is_goto_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_GOTO, args));} -#define b_setter(sc, typer, args, str, len) \ - do { \ - if (!typer(cadr(args))) \ - error_nr(sc, sc->wrong_type_arg_symbol, \ - set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), \ - car(args), cadr(args), sc->type_names[type(cadr(args))], wrap_string(sc, str, len))); \ - return(cadr(args)); \ +#define b_setter(sc, typer, args, str, len) \ + do { \ + if (!typer(cadr(args))) \ + error_nr(sc, sc->wrong_type_arg_symbol, \ + set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), \ + car(args), cadr(args), sc->type_names[type(cadr(args))], wrap_string(sc, str, len))); \ + return(cadr(args)); \ } while (0) static s7_pointer b_is_number_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_complex, args, "a number", 8);} @@ -47276,8 +47276,8 @@ static s7_pointer b_is_proper_list_setter(s7_scheme *sc, s7_pointer args) { if (!s7_is_proper_list(sc, car(args))) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), - car(args), cadr(args), sc->type_names[type(cadr(args))], wrap_string(sc, "a proper list", 13))); + set_elist_5(sc, wrap_string(sc, "set! ~S, ~S is ~A but should be ~A", 34), + car(args), cadr(args), sc->type_names[type(cadr(args))], wrap_string(sc, "a proper list", 13))); return(cadr(args)); } @@ -47289,17 +47289,17 @@ static s7_pointer lambda_setter(s7_scheme *sc, s7_pointer p) { s7_pointer f = funclet_entry(sc, p, sc->local_setter_symbol); /* look for +setter+, save value as closure_setter(p) */ if (f) - { - if (f == sc->F) - { - closure_set_no_setter(p); - return(sc->F); - } - if (!is_any_procedure(f)) - sole_arg_wrong_type_error_nr(sc, sc->setter_symbol, p, wrap_string(sc, "a procedure or a reasonable facsimile thereof", 45)); - closure_set_setter(p, f); - return(f); - } + { + if (f == sc->F) + { + closure_set_no_setter(p); + return(sc->F); + } + if (!is_any_procedure(f)) + sole_arg_wrong_type_error_nr(sc, sc->setter_symbol, p, wrap_string(sc, "a procedure or a reasonable facsimile thereof", 45)); + closure_set_setter(p, f); + return(f); + } /* we used to search for setter here, but that can find the built-in setter causing an infinite loop (maybe check for that??) */ closure_set_no_setter(p); } @@ -47405,10 +47405,10 @@ static void protect_setter(s7_scheme *sc, s7_pointer sym, s7_pointer fnc) vector_length(sc->protected_setter_symbols) = new_size; for (s7_int i = size; i < new_size; i++) - { - vector_element(sc->protected_setters, i) = sc->unused; - vector_element(sc->protected_setter_symbols, i) = sc->unused; - } + { + vector_element(sc->protected_setters, i) = sc->unused; + vector_element(sc->protected_setter_symbols, i) = sc->unused; + } sc->protected_setters_size = new_size; } loc = sc->protected_setters_loc++; @@ -47427,13 +47427,13 @@ static s7_pointer symbol_set_setter(s7_scheme *sc, s7_pointer sym, s7_pointer ar s7_pointer e = cadr(args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) ...))) */ func = caddr(args); if (e == sc->rootlet) - slot = global_slot(sym); + slot = global_slot(sym); else - { - if (!is_let(e)) - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 2, e, sc->type_names[T_LET]); - slot = lookup_slot_with_let(sc, sym, e); - }} + { + if (!is_let(e)) + wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 2, e, sc->type_names[T_LET]); + slot = lookup_slot_with_let(sc, sym, e); + }} else { slot = s7_slot(sc, sym); /* (set! (setter 'x) (lambda (s v) ...)) */ @@ -47445,23 +47445,23 @@ static s7_pointer symbol_set_setter(s7_scheme *sc, s7_pointer sym, s7_pointer ar if (func != sc->F) { if (sym == sc->setter_symbol) - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter 'setter) to ~S", 32), func)); + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter 'setter) to ~S", 32), func)); if (is_syntax_or_qq(slot_value(slot))) /* (set! (setter 'begin) ...), qq is syntax sez r7rs */ - immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't set (setter '~S) to ~S", 28), sym, func)); + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't set (setter '~S) to ~S", 28), sym, func)); if (!is_any_procedure(func)) /* disallow continuation/goto here */ - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 3, func, wrap_string(sc, "a function or #f", 16)); + wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 3, func, wrap_string(sc, "a function or #f", 16)); if (func == global_value(sc->values_symbol)) - error_nr(sc, make_symbol(sc, "invalid-setter", 14), - set_elist_2(sc, wrap_string(sc, "~S's setter can't be values", 27), sym)); + error_nr(sc, make_symbol(sc, "invalid-setter", 14), + set_elist_2(sc, wrap_string(sc, "~S's setter can't be values", 27), sym)); if ((!is_c_function(func)) || (!c_function_has_bool_setter(func))) - { - if (s7_is_aritable(sc, func, 3)) - set_has_let_arg(func); - else - if (!s7_is_aritable(sc, func, 2)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "symbol setter function, ~A, should take 2 or 3 arguments", 56), func)); - }} + { + if (s7_is_aritable(sc, func, 3)) + set_has_let_arg(func); + else + if (!s7_is_aritable(sc, func, 2)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "symbol setter function, ~A, should take 2 or 3 arguments", 56), func)); + }} if (slot == global_slot(sym)) s7_set_setter(sc, sym, func); /* special GC protection for global vars */ else slot_set_setter(slot, func); /* func might be #f */ @@ -47482,13 +47482,13 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) if (setter != sc->F) { if (!is_any_procedure(setter)) - wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 2, setter, wrap_string(sc, "a procedure or #f", 17)); + wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 2, setter, wrap_string(sc, "a procedure or #f", 17)); if (arity_to_int(sc, setter) < 1) /* we need at least an arg for the set! value */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "setter function, ~A, should take at least one argument", 54), setter)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "setter function, ~A, should take at least one argument", 54), setter)); if (setter == global_value(sc->values_symbol)) - error_nr(sc, make_symbol(sc, "invalid-setter", 14), - set_elist_2(sc, wrap_string(sc, "~S's setter can't be values", 27), p)); + error_nr(sc, make_symbol(sc, "invalid-setter", 14), + set_elist_2(sc, wrap_string(sc, "~S's setter can't be values", 27), p)); } switch (type(p)) { @@ -47497,25 +47497,25 @@ static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args) case T_CLOSURE: case T_CLOSURE_STAR: closure_set_setter(p, setter); if (setter == sc->F) - closure_set_no_setter(p); + closure_set_no_setter(p); break; case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_RST_NO_REQ_FUNCTION: if (p == global_value(sc->setter_symbol)) /* (immutable? (setter setter)) is #t, but we aren't checking immutable? here -- maybe we should? */ - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter setter) to ~S", 31), setter)); + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter setter) to ~S", 31), setter)); if (p == global_value(sc->values_symbol)) /* 6-Oct-23 (set! (setter values) ...) is problematic, see splice_in_values */ - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter values) to ~S", 31), setter)); + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (setter values) to ~S", 31), setter)); c_function_set_setter(p, setter); if ((is_any_closure(setter)) || - (is_any_macro(setter))) - add_setter(sc, p, setter); + (is_any_macro(setter))) + add_setter(sc, p, setter); break; case T_C_MACRO: c_macro_set_setter(p, setter); if ((is_any_closure(setter)) || - (is_any_macro(setter))) - add_setter(sc, p, setter); + (is_any_macro(setter))) + add_setter(sc, p, setter); break; default: /* (set! (setter 4) ...) or p==continuation etc */ @@ -47529,28 +47529,28 @@ s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter) if (is_symbol(p)) { if (slot_has_setter(global_slot(p))) - for (s7_int index = 0; index < sc->protected_setters_loc; index++) - if (vector_element(sc->protected_setter_symbols, index) == p) - { - s7_pointer old_func = vector_element(sc->protected_setters, index); - if ((is_any_procedure(old_func)) && /* i.e. not #f! */ - (is_immutable(old_func))) - return(setter); - vector_element(sc->protected_setters, index) = setter; - slot_set_setter(global_slot(p), setter); - if ((setter != sc->F) && (s7_is_aritable(sc, setter, 3))) - set_has_let_arg(setter); - return(setter); - } + for (s7_int index = 0; index < sc->protected_setters_loc; index++) + if (vector_element(sc->protected_setter_symbols, index) == p) + { + s7_pointer old_func = vector_element(sc->protected_setters, index); + if ((is_any_procedure(old_func)) && /* i.e. not #f! */ + (is_immutable(old_func))) + return(setter); + vector_element(sc->protected_setters, index) = setter; + slot_set_setter(global_slot(p), setter); + if ((setter != sc->F) && (s7_is_aritable(sc, setter, 3))) + set_has_let_arg(setter); + return(setter); + } if (setter != sc->F) - { - slot_set_has_setter(global_slot(p)); - if (!is_c_function(setter)) protect_setter(sc, p, T_Clo(setter)); /* these don't need GC protection */ - slot_set_setter(global_slot(p), setter); - if (s7_is_aritable(sc, setter, 3)) - set_has_let_arg(setter); - return(setter); - } + { + slot_set_has_setter(global_slot(p)); + if (!is_c_function(setter)) protect_setter(sc, p, T_Clo(setter)); /* these don't need GC protection */ + slot_set_setter(global_slot(p), setter); + if (s7_is_aritable(sc, setter, 3)) + set_has_let_arg(setter); + return(setter); + } slot_set_setter(global_slot(p), sc->F); return(sc->F); } @@ -47614,7 +47614,7 @@ s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer func bool s7_is_eq(s7_pointer obj1, s7_pointer obj2) { return((obj1 == obj2) || /* so floats and NaNs might be eq? but not eqv? */ - ((is_unspecified(obj1)) && (is_unspecified(obj2)))); /* this is needed because this function is used by s7_b_pp */ + ((is_unspecified(obj1)) && (is_unspecified(obj2)))); /* this is needed because this function is used by s7_b_pp */ } static s7_pointer is_eq_p_pp(s7_scheme *sc, s7_pointer obj1, s7_pointer obj2) @@ -47627,7 +47627,7 @@ static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args) #define H_is_eq "(eq? obj1 obj2) returns #t if obj1 is eq to (the same object as) obj2" #define Q_is_eq sc->pcl_bt return(make_boolean(sc, ((car(args) == cadr(args)) || - ((is_unspecified(car(args))) && (is_unspecified(cadr(args))))))); + ((is_unspecified(car(args))) && (is_unspecified(cadr(args))))))); /* (eq? (apply apply apply values '(())) #<unspecified>) should return #t */ } @@ -47684,10 +47684,10 @@ static bool symbol_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_ return((is_keyword(x)) && (keyword_symbol(x) == keyword_symbol(y))); /* (equivalent? key: :key) -> #t */ if (is_keyword(x)) return(false); return((is_slot(global_slot(x))) && /* the optimizer can replace the original symbol with its value */ - (is_syntax(global_value(x))) && - (is_slot(global_slot(y))) && - (is_syntax(global_value(y))) && - (syntax_symbol(global_value(x)) == syntax_symbol(global_value(y)))); + (is_syntax(global_value(x))) && + (is_slot(global_slot(y))) && + (is_syntax(global_value(y))) && + (syntax_symbol(global_value(x)) == syntax_symbol(global_value(y)))); } static bool unspecified_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) @@ -47698,8 +47698,8 @@ static bool unspecified_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_ static bool undefined_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) { return((x == y) || - ((is_undefined(y)) && (undefined_name_length(x) == undefined_name_length(y)) && - (safe_strcmp(undefined_name(x), undefined_name(y))))); + ((is_undefined(y)) && (undefined_name_length(x) == undefined_name_length(y)) && + (safe_strcmp(undefined_name(x), undefined_name(y))))); } static bool is_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) @@ -47722,13 +47722,13 @@ static bool c_pointer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shar { if (!nci) nci = clear_shared_info(sc->circle_info); if (!is_equivalent_1(sc, c_pointer_type(x), c_pointer_type(y), nci)) - return(false); + return(false); } if (c_pointer_info(x) != c_pointer_info(y)) { if (!nci) nci = clear_shared_info(sc->circle_info); if (!is_equivalent_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) - return(false); + return(false); } return(true); } @@ -47743,13 +47743,13 @@ static bool c_pointer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_in { if (!nci) nci = clear_shared_info(sc->circle_info); if (!is_equal_1(sc, c_pointer_type(x), c_pointer_type(y), nci)) - return(false); + return(false); } if (c_pointer_info(x) != c_pointer_info(y)) { if (!nci) nci = clear_shared_info(sc->circle_info); if (!is_equal_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) - return(false); + return(false); } return(true); } @@ -47777,15 +47777,15 @@ static bool port_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_in { case STRING_PORT: return((port_position(x) == port_position(y)) && - (port_data_size(x) == port_data_size(y)) && - (local_strncmp((const char *)port_data(x), (const char *)port_data(y), (is_input_port(x)) ? port_data_size(x) : port_position(x)))); + (port_data_size(x) == port_data_size(y)) && + (local_strncmp((const char *)port_data(x), (const char *)port_data(y), (is_input_port(x)) ? port_data_size(x) : port_position(x)))); case FILE_PORT: return((is_input_port(x)) && - (port_position(x) == port_position(y)) && - (local_strncmp((const char *)port_filename(x), (const char *)port_filename(y), port_filename_length(x)))); + (port_position(x) == port_position(y)) && + (local_strncmp((const char *)port_filename(x), (const char *)port_filename(y), port_filename_length(x)))); case FUNCTION_PORT: if (is_input_port(x)) - return(port_input_function(x) == port_input_function(y)); + return(port_input_function(x) == port_input_function(y)); return(port_output_function(x) == port_output_function(y)); } return(false); @@ -47809,24 +47809,24 @@ static Inline bool inline_equal_ref(s7_scheme *sc, s7_pointer x, s7_pointer y, s { int32_t ref_x = peek_shared_ref_1(ci, x); if (ref_y != 0) - return(ref_x == ref_y); /* this is a change from the macro version 16-Jan-20 -- only true returns from the caller */ + return(ref_x == ref_y); /* this is a change from the macro version 16-Jan-20 -- only true returns from the caller */ /* try to harmonize the new guy -- there can be more than one structure equal to the current one */ if (ref_x != 0) - add_shared_ref(ci, y, ref_x); + add_shared_ref(ci, y, ref_x); } else if (ref_y != 0) add_shared_ref(ci, x, ref_y); else { - /* assume neither x nor y is in the table, and that they should share a ref value, called only in equality check, not printer */ - if (ci->top >= ci->size2) enlarge_shared_info(ci); - set_collected(x); - set_collected(y); - ci->objs[ci->top] = x; - ci->refs[ci->top++] = ++ci->ref; - ci->objs[ci->top] = y; - ci->refs[ci->top++] = ci->ref; + /* assume neither x nor y is in the table, and that they should share a ref value, called only in equality check, not printer */ + if (ci->top >= ci->size2) enlarge_shared_info(ci); + set_collected(x); + set_collected(y); + ci->objs[ci->top] = x; + ci->refs[ci->top++] = ++ci->ref; + ci->objs[ci->top] = y; + ci->refs[ci->top++] = ci->ref; } return(false); } @@ -47867,13 +47867,13 @@ static bool c_objects_are_equal(s7_scheme *sc, s7_pointer a, s7_pointer b, share } #define check_equivalent_method(Sc, X, Y) \ - do { \ - if (has_active_methods(sc, X)) \ - { \ - s7_pointer 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, set_plist_2(Sc, X, Y)))); \ - }} \ + do { \ + if (has_active_methods(sc, X)) \ + { \ + s7_pointer 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, set_plist_2(Sc, X, Y)))); \ + }} \ while (0) static bool c_objects_are_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) @@ -47897,7 +47897,7 @@ static bool hash_table_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared if (!is_hash_table(y)) { if (equivalent) - check_equivalent_method(sc, y, x); + check_equivalent_method(sc, y, x); return(false); } if ((ci) && (equal_ref(sc, x, y, ci))) return(true); @@ -47909,9 +47909,9 @@ static bool hash_table_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared if ((!equivalent) && ((hash_table_mapper(x) != default_hash_map) || (hash_table_mapper(y) != default_hash_map))) { if (hash_table_checker(x) != hash_table_checker(y)) - return(false); + return(false); if (hash_table_mapper(x) != hash_table_mapper(y)) - return(false); + return(false); } len = hash_table_size(x); @@ -47923,14 +47923,14 @@ static bool hash_table_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared if ((hf != hash_equal) && (hf != hash_equivalent)) { for (s7_int i = 0; i < len; i++) - for (hash_entry_t *p = lists[i]; p; p = hash_entry_next(p)) - { - hash_entry_t *y_val = hf(sc, y, hash_entry_key(p)); - if (y_val == sc->unentry) - return(false); - if (!eqf(sc, hash_entry_value(p), hash_entry_value(y_val), nci)) - return(false); - } + for (hash_entry_t *p = lists[i]; p; p = hash_entry_next(p)) + { + hash_entry_t *y_val = hf(sc, y, hash_entry_key(p)); + if (y_val == sc->unentry) + return(false); + if (!eqf(sc, hash_entry_value(p), hash_entry_value(y_val), nci)) + return(false); + } /* if we get here, every key/value in x has a corresponding key/value in y, and the number of entries match, so surely the tables are equal?? * if ci not null or hash-table-checker is equal/eqivalent, can't use hf? */ @@ -47943,19 +47943,19 @@ static bool hash_table_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared for (s7_int i = 0; i < len; i++) for (hash_entry_t *p = lists[i]; p; p = hash_entry_next(p)) { - s7_pointer key = hash_entry_key(p); - s7_int hash = hash_loc(sc, y, key); - s7_int loc = hash & hash_table_mask(y); - hash_entry_t *xe; - - for (xe = hash_table_element(y, loc); xe; xe = hash_entry_next(xe)) - if ((hash_entry_raw_hash(xe) == hash) && - (eqf(sc, hash_entry_key(xe), key, nci))) - break; - if (!xe) - return(false); - if (!eqf(sc, hash_entry_value(p), hash_entry_value(xe), nci)) - return(false); + s7_pointer key = hash_entry_key(p); + s7_int hash = hash_loc(sc, y, key); + s7_int loc = hash & hash_table_mask(y); + hash_entry_t *xe; + + for (xe = hash_table_element(y, loc); xe; xe = hash_entry_next(xe)) + if ((hash_entry_raw_hash(xe) == hash) && + (eqf(sc, hash_entry_key(xe), key, nci))) + break; + if (!xe) + return(false); + if (!eqf(sc, hash_entry_value(p), hash_entry_value(xe), nci)) + return(false); } return(true); } @@ -47968,7 +47968,7 @@ static bool slots_match(s7_scheme *sc, s7_pointer px, s7_pointer y, shared_info_ for (s7_pointer ey = y; ey; ey = let_outlet(ey)) for (s7_pointer py = let_slots(ey); tis_slot(py); py = next_slot(py)) if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */ - return(is_equal_1(sc, slot_value(px), slot_value(py), nci)); + return(is_equal_1(sc, slot_value(px), slot_value(py), nci)); return(false); } @@ -47977,7 +47977,7 @@ static bool slots_equivalent_match(s7_scheme *sc, s7_pointer px, s7_pointer y, s for (s7_pointer ey = y; ey; ey = let_outlet(ey)) for (s7_pointer py = let_slots(ey); tis_slot(py); py = next_slot(py)) if (slot_symbol(px) == slot_symbol(py)) /* we know something will match */ - return(is_equivalent_1(sc, slot_value(px), slot_value(py), nci)); + return(is_equivalent_1(sc, slot_value(px), slot_value(py), nci)); return(false); } @@ -47996,23 +47996,23 @@ static bool let_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t for (x_len = 0, ex = x; ex; ex = let_outlet(ex)) for (px = let_slots(ex); tis_slot(px); px = next_slot(px)) if (!symbol_is_in_list(sc, slot_symbol(px))) - { - add_symbol_to_list(sc, slot_symbol(px)); - x_len++; - } + { + add_symbol_to_list(sc, slot_symbol(px)); + x_len++; + } for (ey = y; ey; ey = let_outlet(ey)) for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) if (!symbol_is_in_list(sc, slot_symbol(py))) /* symbol in y, not in x */ - return(false); + return(false); for (y_len = 0, ey = y; ey; ey = let_outlet(ey)) for (py = let_slots(ey); tis_slot(py); py = next_slot(py)) if (symbol_tag(slot_symbol(py)) != 0) - { - y_len++; - symbol_set_tag(slot_symbol(py), 0); - } + { + y_len++; + symbol_set_tag(slot_symbol(py), 0); + } if (x_len != y_len) /* symbol in x, not in y */ return(false); @@ -48022,12 +48022,12 @@ static bool let_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t for (ex = x; ex; ex = let_outlet(ex)) for (px = let_slots(ex); tis_slot(px); px = next_slot(px)) if (symbol_tag(slot_symbol(px)) == 0) /* unshadowed */ - { - symbol_set_tag(slot_symbol(px), sc->syms_tag); /* values don't match */ - if (((!equivalent) && (!slots_match(sc, px, y, nci))) || - ((equivalent) && (!slots_equivalent_match(sc, px, y, nci)))) - return(false); - } + { + symbol_set_tag(slot_symbol(px), sc->syms_tag); /* values don't match */ + if (((!equivalent) && (!slots_match(sc, px, y, nci))) || + ((equivalent) && (!slots_equivalent_match(sc, px, y, nci)))) + return(false); + } return(true); } @@ -48060,7 +48060,7 @@ static bool closure_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info { s7_pointer equal_func = find_method(sc, closure_let(x), sc->is_equal_symbol); if (equal_func != sc->undefined) - return(s7_boolean(sc, s7_apply_function(sc, equal_func, set_plist_2(sc, x, y)))); + return(s7_boolean(sc, s7_apply_function(sc, equal_func, set_plist_2(sc, x, y)))); } return(false); } @@ -48077,7 +48077,7 @@ static bool closure_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared * because locally defined constant functions on the second pass find the outer let. */ return((is_equivalent_1(sc, closure_args(x), closure_args(y), ci)) && - (is_equivalent_1(sc, closure_body(x), closure_body(y), ci))); + (is_equivalent_1(sc, closure_body(x), closure_body(y), ci))); } static bool pair_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) @@ -48179,13 +48179,13 @@ static bool biv_meq(s7_pointer x, s7_pointer y) return(true); } -#define base_vector_equal(sc, x, y) \ - do { \ - if (x == y) return(true); \ - len = vector_length(x); \ - if (len != vector_length(y)) return(false); \ - if (!vector_rank_match(sc, x, y)) return(false); \ - if (len == 0) return(true); \ +#define base_vector_equal(sc, x, y) \ + do { \ + if (x == y) return(true); \ + len = vector_length(x); \ + if (len != vector_length(y)) return(false); \ + if (!vector_rank_match(sc, x, y)) return(false); \ + if (len == 0) return(true); \ } while (0) static bool vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) @@ -48198,20 +48198,20 @@ static bool vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_ if (type(x) != type(y)) { if ((is_int_vector(x)) && (is_byte_vector(y))) - return(biv_meq(y, x)); + return(biv_meq(y, x)); if ((is_byte_vector(x)) && (is_int_vector(y))) - return(biv_meq(x, y)); + return(biv_meq(x, y)); for (s7_int i = 0; i < len; i++) - if (!is_equal_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */ - return(false); + if (!is_equal_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */ + return(false); return(true); } if (!has_simple_elements(x)) { if (ci) - { - if (equal_ref(sc, x, y, ci)) return(true); - } + { + if (equal_ref(sc, x, y, ci)) return(true); + } else nci = clear_shared_info(sc->circle_info); } for (s7_int i = 0; i < len; i++) @@ -48274,12 +48274,12 @@ static bool vector_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_ * (equivalent? (make-float-vector 3 1.0) (vector 1 1 1)) -> #t */ if ((is_int_vector(x)) && (is_byte_vector(y))) - return(biv_meq(y, x)); + return(biv_meq(y, x)); if ((is_byte_vector(x)) && (is_int_vector(y))) - return(biv_meq(x, y)); + return(biv_meq(x, y)); for (i = 0; i < len; i++) - if (!is_equivalent_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */ - return(false); + if (!is_equivalent_1(sc, vector_getter(x)(sc, x, i), vector_getter(y)(sc, y, i), NULL)) /* this could be greatly optimized */ + return(false); return(true); } @@ -48288,20 +48288,20 @@ static bool vector_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_ s7_double *arr1 = float_vector_floats(x), *arr2 = float_vector_floats(y); s7_double fudge = sc->equivalent_float_epsilon; if (fudge == 0.0) - { - for (i = 0; i < len; i++) - if ((arr1[i] != arr2[i]) && - ((!is_NaN(arr1[i])) || (!is_NaN(arr2[i])))) - return(false); - } + { + for (i = 0; i < len; i++) + if ((arr1[i] != arr2[i]) && + ((!is_NaN(arr1[i])) || (!is_NaN(arr2[i])))) + return(false); + } else - if ((len & 0x3) == 0) - for (i = 0; i < len; ) - LOOP_4(if (!floats_are_equivalent(sc, arr1[i], arr2[i])) return(false); i++); - else - for (i = 0; i < len; i++) - if (!floats_are_equivalent(sc, arr1[i], arr2[i])) - return(false); + if ((len & 0x3) == 0) + for (i = 0; i < len; ) + LOOP_4(if (!floats_are_equivalent(sc, arr1[i], arr2[i])) return(false); i++); + else + for (i = 0; i < len; i++) + if (!floats_are_equivalent(sc, arr1[i], arr2[i])) + return(false); return(true); } if (is_int_vector(x)) @@ -48312,9 +48312,9 @@ static bool vector_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_ if (!has_simple_elements(x)) { if (ci) - { - if (equal_ref(sc, x, y, ci)) return(true); - } + { + if (equal_ref(sc, x, y, ci)) return(true); + } else nci = clear_shared_info(sc->circle_info); } for (i = 0; i < len; i++) @@ -48337,35 +48337,35 @@ static bool iterator_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_i { case T_STRING: return((is_string(y_seq)) && - (iterator_position(x) == iterator_position(y)) && - (iterator_length(x) == iterator_length(y)) && - (string_equal(sc, x_seq, y_seq, ci))); + (iterator_position(x) == iterator_position(y)) && + (iterator_length(x) == iterator_length(y)) && + (string_equal(sc, x_seq, y_seq, ci))); case T_VECTOR: case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: return((is_any_vector(y_seq)) && - (iterator_position(x) == iterator_position(y)) && - (iterator_length(x) == iterator_length(y)) && - ((equivalent) ? (vector_equivalent(sc, x_seq, y_seq, ci)) : - ((is_t_vector(x_seq)) ? (vector_equal(sc, x_seq, y_seq, ci)) : - ((is_float_vector(x_seq)) ? (float_vector_equal(sc, x_seq, y_seq, ci)) : - ((is_int_vector(x_seq)) ? (int_vector_equal(sc, x_seq, y_seq, ci)) : - (byte_vector_equal(sc, x_seq, y_seq, ci))))))); + (iterator_position(x) == iterator_position(y)) && + (iterator_length(x) == iterator_length(y)) && + ((equivalent) ? (vector_equivalent(sc, x_seq, y_seq, ci)) : + ((is_t_vector(x_seq)) ? (vector_equal(sc, x_seq, y_seq, ci)) : + ((is_float_vector(x_seq)) ? (float_vector_equal(sc, x_seq, y_seq, ci)) : + ((is_int_vector(x_seq)) ? (int_vector_equal(sc, x_seq, y_seq, ci)) : + (byte_vector_equal(sc, x_seq, y_seq, ci))))))); /* iterator_next is a function (pair_iterate, iterator_finished etc) */ case T_PAIR: if (iterator_next(x) != iterator_next(y)) return(false); /* even if seqs are equal, one might be at end */ if (equivalent) - { - if (!pair_equivalent(sc, x_seq, y_seq, ci)) - return(false); - } + { + if (!pair_equivalent(sc, x_seq, y_seq, ci)) + return(false); + } else - if (!pair_equal(sc, x_seq, y_seq, ci)) - return(false); + if (!pair_equal(sc, x_seq, y_seq, ci)) + return(false); for (xs = x_seq, ys = y_seq; is_pair(xs) && is_pair(ys); xs = cdr(xs), ys = cdr(ys)) - if (xs == iterator_current(x)) - return(ys == iterator_current(y)); + if (xs == iterator_current(x)) + return(ys == iterator_current(y)); return(is_null(xs) && is_null(ys)); case T_NIL: /* (make-iterator #()) works, so () should too */ @@ -48373,32 +48373,32 @@ static bool iterator_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_i case T_C_OBJECT: if ((is_c_object(y_seq)) && - (iterator_position(x) == iterator_position(y)) && - (iterator_length(x) == iterator_length(y))) - { - if (equivalent) - return(c_objects_are_equivalent(sc, x_seq, y_seq, ci)); - return(c_objects_are_equal(sc, x_seq, y_seq, ci)); - } + (iterator_position(x) == iterator_position(y)) && + (iterator_length(x) == iterator_length(y))) + { + if (equivalent) + return(c_objects_are_equivalent(sc, x_seq, y_seq, ci)); + return(c_objects_are_equal(sc, x_seq, y_seq, ci)); + } return(false); case T_LET: if (!is_let(y_seq)) return(false); if (iterator_next(x) != iterator_next(y)) return(false); if (x_seq == sc->rootlet) - return(iterator_position(x) == iterator_position(y)); /* y_seq must also be sc->rootlet since nexts are the same (rootlet_iterate) */ + return(iterator_position(x) == iterator_position(y)); /* y_seq must also be sc->rootlet since nexts are the same (rootlet_iterate) */ if (equivalent) - { - if (!let_equivalent(sc, x_seq, y_seq, ci)) - return(false); - } + { + if (!let_equivalent(sc, x_seq, y_seq, ci)) + return(false); + } else - if (!let_equal(sc, x_seq, y_seq, ci)) - return(false); + if (!let_equal(sc, x_seq, y_seq, ci)) + return(false); for (xs = let_slots(x_seq), ys = let_slots(y_seq); tis_slot(xs) && tis_slot(ys); xs = next_slot(xs), ys = next_slot(ys)) - if (xs == iterator_current_slot(x)) - return(ys == iterator_current_slot(y)); + if (xs == iterator_current_slot(x)) + return(ys == iterator_current_slot(y)); return(is_slot_end(xs) && is_slot_end(ys)); case T_HASH_TABLE: @@ -48407,7 +48407,7 @@ static bool iterator_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_i if (hash_table_entries(x_seq) == 0) return(true); if (iterator_position(x) != iterator_position(y)) return(false); if (!equivalent) - return(hash_table_equal(sc, x_seq, y_seq, ci)); + return(hash_table_equal(sc, x_seq, y_seq, ci)); return(hash_table_equivalent(sc, x_seq, y_seq, ci)); case T_CLOSURE: case T_CLOSURE_STAR: @@ -48436,7 +48436,7 @@ static bool big_ratio_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_in return(mpq_equal(big_ratio(x), big_ratio(y))); if (is_t_ratio(y)) return((numerator(y) == mpz_get_si(mpq_numref(big_ratio(x)))) && - (denominator(y) == mpz_get_si(mpq_denref(big_ratio(x))))); + (denominator(y) == mpz_get_si(mpq_denref(big_ratio(x))))); return(false); } @@ -48448,7 +48448,7 @@ static bool big_real_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_inf { if (mpfr_nan_p(big_real(x))) return(false); return((!is_NaN(real(y))) && - (mpfr_cmp_d(big_real(x), real(y)) == 0)); + (mpfr_cmp_d(big_real(x), real(y)) == 0)); } return(false); } @@ -48459,13 +48459,13 @@ static bool big_complex_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_ return(false); if (is_t_big_complex(y)) return((!mpfr_nan_p(mpc_realref(big_complex(y)))) && - (!mpfr_nan_p(mpc_imagref(big_complex(y)))) && - (mpc_cmp(big_complex(x), big_complex(y)) == 0)); + (!mpfr_nan_p(mpc_imagref(big_complex(y)))) && + (mpc_cmp(big_complex(x), big_complex(y)) == 0)); if (is_t_complex(y)) return((!is_NaN(real_part(y))) && - (!is_NaN(imag_part(y))) && - (mpfr_cmp_d(mpc_realref(big_complex(x)), real_part(y)) == 0) && - (mpfr_cmp_d(mpc_imagref(big_complex(x)), imag_part(y)) == 0)); + (!is_NaN(imag_part(y))) && + (mpfr_cmp_d(mpc_realref(big_complex(x)), real_part(y)) == 0) && + (mpfr_cmp_d(mpc_imagref(big_complex(x)), imag_part(y)) == 0)); return(false); } #endif @@ -48486,11 +48486,11 @@ static bool fraction_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_inf { if (is_t_ratio(y)) return((numerator(x) == numerator(y)) && - (denominator(x) == denominator(y))); + (denominator(x) == denominator(y))); #if WITH_GMP if (is_t_big_ratio(y)) return((numerator(x) == mpz_get_si(mpq_numref(big_ratio(y)))) && - (denominator(x) == mpz_get_si(mpq_denref(big_ratio(y))))); + (denominator(x) == mpz_get_si(mpq_denref(big_ratio(y))))); #endif return(false); } @@ -48502,8 +48502,8 @@ static bool real_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t #if WITH_GMP if (is_t_big_real(y)) return((!is_NaN(real(x))) && - (!mpfr_nan_p(big_real(y))) && - (mpfr_cmp_d(big_real(y), real(x)) == 0)); + (!mpfr_nan_p(big_real(y))) && + (mpfr_cmp_d(big_real(y), real(x)) == 0)); #endif return(false); } @@ -48516,10 +48516,10 @@ static bool complex_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info if (is_t_big_complex(y)) { if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x))) || - (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) - return(false); + (mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) + return(false); return((mpfr_cmp_d(mpc_realref(big_complex(y)), real_part(x)) == 0) && - (mpfr_cmp_d(mpc_imagref(big_complex(y)), imag_part(x)) == 0)); + (mpfr_cmp_d(mpc_imagref(big_complex(y)), imag_part(x)) == 0)); } #endif return(false); @@ -48536,7 +48536,7 @@ static bool big_integer_or_ratio_equivalent(s7_scheme *sc, s7_pointer x, s7_poin { case T_INTEGER: if (int_case) - return(mpz_cmp_si(big_integer(x), integer(y)) == 0); + return(mpz_cmp_si(big_integer(x), integer(y)) == 0); mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN); return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); case T_RATIO: @@ -48548,14 +48548,14 @@ static bool big_integer_or_ratio_equivalent(s7_scheme *sc, s7_pointer x, s7_poin case T_COMPLEX: mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN); if (!big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) - return(false); + return(false); if (is_NaN(imag_part(y))) return(false); mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); mpfr_set_d(sc->mpfr_2, imag_part(y), MPFR_RNDN); return(mpfr_cmpabs(sc->mpfr_2, sc->mpfr_1) <= 0); case T_BIG_INTEGER: if (int_case) - return(mpz_cmp(big_integer(x), big_integer(y)) == 0); + return(mpz_cmp(big_integer(x), big_integer(y)) == 0); mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)); case T_BIG_RATIO: @@ -48565,11 +48565,11 @@ static bool big_integer_or_ratio_equivalent(s7_scheme *sc, s7_pointer x, s7_poin return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))); case T_BIG_COMPLEX: if (big_floats_are_equivalent(sc, sc->mpfr_1, mpc_realref(big_complex(y)))) - { - if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false); - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0); - }} + { + if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false); + mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); + return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0); + }} return(false); } @@ -48600,7 +48600,7 @@ static bool big_real_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, share case T_COMPLEX: mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN); if (!big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2)) - return(false); + return(false); if (is_NaN(imag_part(y))) return(false); mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); mpfr_set_d(sc->mpfr_2, imag_part(y), MPFR_RNDN); @@ -48615,11 +48615,11 @@ static bool big_real_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, share return(big_floats_are_equivalent(sc, big_real(x), big_real(y))); case T_BIG_COMPLEX: if (big_floats_are_equivalent(sc, big_real(x), mpc_realref(big_complex(y)))) - { - if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false); - mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); - return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0); - }} + { + if (mpfr_nan_p(mpc_imagref(big_complex(y)))) return(false); + mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN); + return(mpfr_cmpabs(mpc_imagref(big_complex(y)), sc->mpfr_1) <= 0); + }} return(false); } @@ -48631,34 +48631,34 @@ static bool big_complex_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, sh case T_INTEGER: mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN); return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); case T_RATIO: mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN); return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); case T_REAL: mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN); return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); case T_COMPLEX: mpfr_set_d(sc->mpfr_1, imag_part(y), MPFR_RNDN); mpfr_set_d(sc->mpfr_2, real_part(y), MPFR_RNDN); return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); case T_BIG_INTEGER: mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN); return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); case T_BIG_RATIO: mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), sc->mpfr_2)) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); case T_BIG_REAL: return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), big_real(y))) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); + (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), sc->mpfr_1))); case T_BIG_COMPLEX: return((big_floats_are_equivalent(sc, mpc_realref(big_complex(x)), mpc_realref(big_complex(y)))) && - (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), mpc_imagref(big_complex(y))))); + (big_floats_are_equivalent(sc, mpc_imagref(big_complex(x)), mpc_imagref(big_complex(y))))); } return(false); } @@ -48685,7 +48685,7 @@ static bool integer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared return(floats_are_equivalent(sc, (double)integer(x), real(y))); case T_COMPLEX: return((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) && - (floats_are_equivalent(sc, (double)integer(x), real_part(y)))); + (floats_are_equivalent(sc, (double)integer(x), real_part(y)))); #if WITH_GMP case T_BIG_INTEGER: return(mpz_cmp_si(big_integer(y), integer(x)) == 0); @@ -48716,7 +48716,7 @@ static bool fraction_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, share return(floats_are_equivalent(sc, (double)fraction(x), real(y))); case T_COMPLEX: return((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) && - (floats_are_equivalent(sc, fraction(x), real_part(y)))); + (floats_are_equivalent(sc, fraction(x), real_part(y)))); #if WITH_GMP case T_BIG_INTEGER: mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); @@ -48749,7 +48749,7 @@ static bool real_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_in return(floats_are_equivalent(sc, real(x), real(y))); case T_COMPLEX: return((fabs(imag_part(y)) <= sc->equivalent_float_epsilon) && - (floats_are_equivalent(sc, real(x), real_part(y)))); + (floats_are_equivalent(sc, real(x), real_part(y)))); #if WITH_GMP case T_BIG_INTEGER: mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); @@ -48776,36 +48776,36 @@ static bool complex_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared { case T_INTEGER: return((floats_are_equivalent(sc, real_part(x), integer(y))) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); + (floats_are_equivalent(sc, imag_part(x), 0.0))); case T_RATIO: return((floats_are_equivalent(sc, real_part(x), fraction(y))) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); + (floats_are_equivalent(sc, imag_part(x), 0.0))); case T_REAL: return((floats_are_equivalent(sc, real_part(x), real(y))) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); + (floats_are_equivalent(sc, imag_part(x), 0.0))); case T_COMPLEX: return((floats_are_equivalent(sc, real_part(x), real_part(y))) && - (floats_are_equivalent(sc, imag_part(x), imag_part(y)))); + (floats_are_equivalent(sc, imag_part(x), imag_part(y)))); #if WITH_GMP case T_BIG_INTEGER: mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN); mpfr_set_d(sc->mpfr_2, real_part(x), MPFR_RNDN); return((big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); + (floats_are_equivalent(sc, imag_part(x), 0.0))); case T_BIG_RATIO: mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN); mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN); return((big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2)) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); + (floats_are_equivalent(sc, imag_part(x), 0.0))); case T_BIG_REAL: mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN); return((big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y))) && - (floats_are_equivalent(sc, imag_part(x), 0.0))); + (floats_are_equivalent(sc, imag_part(x), 0.0))); case T_BIG_COMPLEX: mpfr_set_d(sc->mpfr_1, real_part(x), MPFR_RNDN); mpfr_set_d(sc->mpfr_2, imag_part(x), MPFR_RNDN); return((big_floats_are_equivalent(sc, sc->mpfr_1, mpc_realref(big_complex(y)))) && - (big_floats_are_equivalent(sc, sc->mpfr_2, mpc_imagref(big_complex(y))))); + (big_floats_are_equivalent(sc, sc->mpfr_2, mpc_imagref(big_complex(y))))); #endif } return(false); @@ -48817,9 +48817,9 @@ static bool random_state_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared return(x == y); #else return((x == y) || - ((is_random_state(y)) && - (random_seed(x) == random_seed(y)) && - (random_carry(x) == random_carry(y)))); + ((is_random_state(y)) && + (random_seed(x) == random_seed(y)) && + (random_carry(x) == random_carry(y)))); #endif } @@ -48931,7 +48931,7 @@ static s7_pointer pair_length(s7_scheme *sc, s7_pointer a) { LOOP_4(fast = cdr(fast); i++; if (!is_pair(fast)) return(make_integer(sc, (is_null(fast)) ? i : -i))); slow = cdr(slow); - if (fast == slow) return(real_infinity); + if (fast == slow) return(real_infinity); } return(real_infinity); } @@ -49065,15 +49065,15 @@ static s7_pointer let_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_pointer { s7_pointer sym = car(val); if (is_symbol(sym)) - { - s7_pointer slot; - if (is_keyword(sym)) sym = keyword_symbol(sym); /* else make_slot will mark the keyword as local confusing odd_bits etc */ - slot = slot_in_let(sc, e, sym); - if (is_slot(slot)) - checked_slot_set_value(sc, slot, cdr(val)); - else add_slot_checked_with_id(sc, e, sym, cdr(val)); - return(cdr(val)); - }} + { + s7_pointer slot; + if (is_keyword(sym)) sym = keyword_symbol(sym); /* else make_slot will mark the keyword as local confusing odd_bits etc */ + slot = slot_in_let(sc, e, sym); + if (is_slot(slot)) + checked_slot_set_value(sc, slot, cdr(val)); + else add_slot_checked_with_id(sc, e, sym, cdr(val)); + return(cdr(val)); + }} set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not (cons symbol value)", 33)); set_caddr(sc->elist_3, val); error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); @@ -49227,12 +49227,12 @@ static s7_pointer copy_c_object_to_same_type(s7_scheme *sc, s7_pointer dest, s7_ set_car(sc->t3_1, dest); set_car(sc->t3_2, mj); for (s7_int i = source_start, j = dest_start; i < dest_end; i++, j++) - { - set_integer(mi, i); - set_car(sc->t3_3, cref(sc, with_list_t2(source, mi))); - set_integer(mj, j); - cset(sc, sc->t3_1); - }} + { + set_integer(mi, i); + set_car(sc->t3_3, cref(sc, with_list_t2(source, mi))); + set_integer(mj, j); + cset(sc, sc->t3_1); + }} else { s7_pointer mi = make_mutable_integer(sc, 0); @@ -49240,14 +49240,14 @@ static s7_pointer copy_c_object_to_same_type(s7_scheme *sc, s7_pointer dest, s7_ s7_pointer mj = make_mutable_integer(sc, 0); s7_int gc_loc2 = gc_protect_1(sc, mj); for (s7_int i = source_start, j = dest_start; i < dest_end; i++, j++) - { - set_integer(mi, i); - set_car(sc->t3_3, cref(sc, with_list_t2(source, mi))); - set_car(sc->t3_1, dest); - set_car(sc->t3_2, mj); - set_integer(mj, j); - cset(sc, sc->t3_1); - } + { + set_integer(mi, i); + set_car(sc->t3_3, cref(sc, with_list_t2(source, mi))); + set_car(sc->t3_1, dest); + set_car(sc->t3_2, mj); + set_integer(mj, j); + cset(sc, sc->t3_1); + } s7_gc_unprotect_at(sc, gc_loc1); s7_gc_unprotect_at(sc, gc_loc2); free_cell(sc, mi); @@ -49264,24 +49264,24 @@ static s7_pointer copy_to_same_type(s7_scheme *sc, s7_pointer dest, s7_pointer s { case T_PAIR: { - s7_pointer pd = dest, ps = source; - s7_int i; - for (i = 0; i < source_start; i++) - ps = cdr(ps); - for (i = 0; i < dest_start; i++) - pd = cdr(pd); - for (; (i < dest_end) && is_pair(ps) && is_pair(pd); i++, ps = cdr(ps), pd = cdr(pd)) - set_car(pd, car(ps)); - return(dest); + s7_pointer pd = dest, ps = source; + s7_int i; + for (i = 0; i < source_start; i++) + ps = cdr(ps); + for (i = 0; i < dest_start; i++) + pd = cdr(pd); + for (; (i < dest_end) && is_pair(ps) && is_pair(pd); i++, ps = cdr(ps), pd = cdr(pd)) + set_car(pd, car(ps)); + return(dest); } case T_VECTOR: if (is_typed_vector(dest)) - { - s7_pointer *els = vector_elements(source); - for (s7_int i = source_start, j = dest_start; j < dest_end; i++, j++) - typed_vector_setter(sc, dest, j, els[i]); /* types are equal, so source is a normal vector */ - } + { + s7_pointer *els = vector_elements(source); + for (s7_int i = source_start, j = dest_start; j < dest_end; i++, j++) + typed_vector_setter(sc, dest, j, els[i]); /* types are equal, so source is a normal vector */ + } else memcpy((void *)((vector_elements(dest)) + dest_start), (void *)((vector_elements(source)) + source_start), source_len * sizeof(s7_pointer)); return(dest); @@ -49293,13 +49293,13 @@ static s7_pointer copy_to_same_type(s7_scheme *sc, s7_pointer dest, s7_pointer s return(dest); case T_BYTE_VECTOR: if (is_string(dest)) - memcpy((void *)(string_value(dest) + dest_start), (void *)((byte_vector_bytes(source)) + source_start), source_len * sizeof(uint8_t)); + memcpy((void *)(string_value(dest) + dest_start), (void *)((byte_vector_bytes(source)) + source_start), source_len * sizeof(uint8_t)); else memcpy((void *)(byte_vector_bytes(dest) + dest_start), (void *)((byte_vector_bytes(source)) + source_start), source_len * sizeof(uint8_t)); return(dest); case T_STRING: if (is_string(dest)) - memcpy((void *)(string_value(dest) + dest_start), (void *)((string_value(source)) + source_start), source_len); + memcpy((void *)(string_value(dest) + dest_start), (void *)((string_value(source)) + source_start), source_len); else memcpy((void *)(byte_vector_bytes(dest) + dest_start), (void *)((string_value(source)) + source_start), source_len); return(dest); @@ -49318,21 +49318,21 @@ static s7_pointer copy_to_same_type(s7_scheme *sc, s7_pointer dest, s7_pointer s case T_HASH_TABLE: { - s7_pointer p; - gc_protect_via_stack(sc, source); - p = hash_table_copy(sc, source, dest, source_start, source_start + source_len); - unstack_gc_protect(sc); - if ((hash_table_checker(source) != hash_table_checker(dest)) && - (hash_table_mapper(dest) == default_hash_map)) - { - if (hash_table_checker(dest) == hash_empty) - hash_table_checker(dest) = hash_table_checker(source); /* copy hash_table_procedures also? what about the mapper? see hash_table_copy */ - else - { - hash_table_checker(dest) = hash_equal; - hash_set_chosen(dest); - }} - return(p); + s7_pointer p; + gc_protect_via_stack(sc, source); + p = hash_table_copy(sc, source, dest, source_start, source_start + source_len); + unstack_gc_protect(sc); + if ((hash_table_checker(source) != hash_table_checker(dest)) && + (hash_table_mapper(dest) == default_hash_map)) + { + if (hash_table_checker(dest) == hash_empty) + hash_table_checker(dest) = hash_table_checker(source); /* copy hash_table_procedures also? what about the mapper? see hash_table_copy */ + else + { + hash_table_checker(dest) = hash_equal; + hash_set_chosen(dest); + }} + return(p); } default: @@ -49344,14 +49344,14 @@ static s7_pointer copy_to_same_type(s7_scheme *sc, s7_pointer dest, s7_pointer s static noreturn void copy_element_error_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer element, int32_t desired_type) { set_elist_6(sc, wrap_string(sc, "~A ~:D element, ~S, is ~A but should be ~A", 42), - caller, wrap_integer(sc, num), element, type_name_string(sc, element), sc->type_names[desired_type]); + caller, wrap_integer(sc, num), element, type_name_string(sc, element), sc->type_names[desired_type]); error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6); } static noreturn void copy_element_error_with_type_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer element, s7_pointer desired_type) { set_elist_6(sc, wrap_string(sc, "~A ~:D element, ~S, is ~A but should be ~A", 42), - caller, wrap_integer(sc, num), element, type_name_string(sc, element), desired_type); + caller, wrap_integer(sc, num), element, type_name_string(sc, element), desired_type); error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6); } @@ -49376,7 +49376,7 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) dest = T_Ext(cadr(args)); if ((dest == sc->readable_keyword) && (!is_pair(source))) error_nr(sc, sc->out_of_range_symbol, - set_elist_1(sc, wrap_string(sc, "copy argument 2, :readable, only works if the source is a pair", 62))); + set_elist_1(sc, wrap_string(sc, "copy argument 2, :readable, only works if the source is a pair", 62))); if ((is_immutable(dest)) && (dest != sc->readable_keyword) && @@ -49394,17 +49394,17 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) { case T_PAIR: if (dest == sc->readable_keyword) /* a kludge, but I can't think of anything less stupid */ - { - if (have_indices) /* it seems to me that the start/end args here don't make any sense so... */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S: start/end indices make no sense with :readable: ~S", 54), caller, args)); - return(copy_body(sc, source)); - } + { + if (have_indices) /* it seems to me that the start/end args here don't make any sense so... */ + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "~S: start/end indices make no sense with :readable: ~S", 54), caller, args)); + return(copy_body(sc, source)); + } end = s7_list_length(sc, source); if (end == 0) - end = circular_list_entries(source); + end = circular_list_entries(source); else - if (end < 0) end = -end; + if (end < 0) end = -end; break; case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: @@ -49429,10 +49429,10 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) case T_C_OBJECT: if (c_object_copy(sc, source)) - { - s7_pointer x = (*(c_object_copy(sc, source)))(sc, args); - if (x == dest) return(dest); /* this can happen (s7test block_copy) */ - } + { + s7_pointer x = (*(c_object_copy(sc, source)))(sc, args); + if (x == dest) return(dest); /* this can happen (s7test block_copy) */ + } check_method(sc, source, sc->copy_symbol, args); get = c_object_getter; end = c_object_length_to_int(sc, source); @@ -49442,36 +49442,36 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) if (source == dest) return(dest); check_method(sc, source, sc->copy_symbol, args); if (source == sc->rootlet) - wrong_type_error_nr(sc, caller, 1, source, wrap_string(sc, "a sequence other than the rootlet", 33)); + wrong_type_error_nr(sc, caller, 1, source, wrap_string(sc, "a sequence other than the rootlet", 33)); if ((!have_indices) && (is_let(dest)) && (dest != sc->s7_starlet)) - { - s7_pointer slot; - if (dest == sc->rootlet) /* (copy (inlet 'a 1) (rootlet)) */ - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - s7_make_slot(sc, dest, slot_symbol(slot), slot_value(slot)); - else - if ((has_let_fallback(source)) && - (has_let_fallback(dest))) - { - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) && - (slot_symbol(slot) != sc->let_set_fallback_symbol)) - add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); - } - else - /* this copies reversing the order -- if shadowing, this unshadows, tmp has in-order copy code, but it's too much effort */ - /* it also ignores possible slot setters */ - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); - return(dest); - } + { + s7_pointer slot; + if (dest == sc->rootlet) /* (copy (inlet 'a 1) (rootlet)) */ + for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) + s7_make_slot(sc, dest, slot_symbol(slot), slot_value(slot)); + else + if ((has_let_fallback(source)) && + (has_let_fallback(dest))) + { + for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) + if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) && + (slot_symbol(slot) != sc->let_set_fallback_symbol)) + add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); + } + else + /* this copies reversing the order -- if shadowing, this unshadows, tmp has in-order copy code, but it's too much effort */ + /* it also ignores possible slot setters */ + for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) + add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); + return(dest); + } end = let_length(sc, source); break; case T_NIL: end = 0; if (is_sequence(dest)) - break; + break; default: error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~S", 17), caller, source, dest)); @@ -49490,7 +49490,7 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) if (source_len == 0) { if (!is_sequence(dest)) - wrong_type_error_nr(sc, caller, 2, dest, a_sequence_string); + wrong_type_error_nr(sc, caller, 2, dest, a_sequence_string); return(dest); } @@ -49503,8 +49503,8 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) case T_INT_VECTOR: case T_BYTE_VECTOR: if (is_float_vector(source)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~A", 17), caller, source, sc->type_names[type(dest)])); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "can't ~S ~S to ~A", 17), caller, source, sc->type_names[type(dest)])); case T_FLOAT_VECTOR: set = vector_setter(dest); dest_len = vector_length(dest); @@ -49530,20 +49530,20 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) case T_C_OBJECT: /* if source or dest is c_object, call its copy function before falling back on the get/set functions */ if (c_object_copy(sc, dest)) - { - s7_pointer x = (*(c_object_copy(sc, dest)))(sc, args); - if (x == dest) - return(dest); - } + { + s7_pointer x = (*(c_object_copy(sc, dest)))(sc, args); + if (x == dest) + return(dest); + } set = c_object_setter; dest_len = c_object_length_to_int(sc, dest); break; case T_LET: if (dest == sc->rootlet) - wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a sequence other rootlet", 24)); + wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a sequence other rootlet", 24)); if (dest == sc->s7_starlet) - wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a sequence other than *s7*", 26)); + wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a sequence other than *s7*", 26)); set = let_setter; dest_len = source_len; /* grows via set, so dest_len isn't relevant */ set_cadr(sc->elist_3, caller); /* for possible error handling in let_setter */ @@ -49574,7 +49574,7 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) if ((source != dest) && ((type(source) == type(dest)) || ((is_string_or_byte_vector(source)) && - (is_string_or_byte_vector(dest))))) + (is_string_or_byte_vector(dest))))) { s7_pointer res = copy_to_same_type(sc, dest, source, 0, source_len, start); if (res) return(res); @@ -49584,316 +49584,316 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) { case T_PAIR: { - s7_pointer p = source; - i = 0; - if (start > 0) - for (i = 0; i < start; i++) - p = cdr(p); - /* dest won't be a pair here if source != dest -- the pair->pair case was caught above */ - if (source == dest) /* here start != 0 (see above) */ - for (s7_pointer dp = source /* i = start */; i < end; i++, p = cdr(p), dp = cdr(dp)) - set_car(dp, car(p)); - else - if (is_string(dest)) - { - char *dst = string_value(dest); - for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p)) - { - if (!is_character(car(p))) - copy_element_error_nr(sc, caller, i + 1, car(p), T_CHARACTER); - dst[j] = character(car(p)); - }} - else - if ((is_t_vector(dest)) && (set != typed_vector_setter)) - { - s7_pointer *els = vector_elements(dest); - for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p)) - els[j] = car(p); - } - else - for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p)) - set(sc, dest, j, car(p)); - return(dest); + s7_pointer p = source; + i = 0; + if (start > 0) + for (i = 0; i < start; i++) + p = cdr(p); + /* dest won't be a pair here if source != dest -- the pair->pair case was caught above */ + if (source == dest) /* here start != 0 (see above) */ + for (s7_pointer dp = source /* i = start */; i < end; i++, p = cdr(p), dp = cdr(dp)) + set_car(dp, car(p)); + else + if (is_string(dest)) + { + char *dst = string_value(dest); + for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p)) + { + if (!is_character(car(p))) + copy_element_error_nr(sc, caller, i + 1, car(p), T_CHARACTER); + dst[j] = character(car(p)); + }} + else + if ((is_t_vector(dest)) && (set != typed_vector_setter)) + { + s7_pointer *els = vector_elements(dest); + for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p)) + els[j] = car(p); + } + else + for (/* i = start */ j = 0; i < end; i++, j++, p = cdr(p)) + set(sc, dest, j, car(p)); + return(dest); } case T_LET: if (source == sc->s7_starlet) /* *s7* */ - { - s7_pointer iter = s7_make_iterator(sc, sc->s7_starlet); - s7_int gc_loc = gc_protect_1(sc, iter); - for (i = 0; i < start; i++) - { - s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) - { - s7_gc_unprotect_at(sc, gc_loc); - return(dest); - }} - if (is_pair(dest)) /* (append '(1) *s7* ()) */ - { - s7_pointer p; - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - { - s7_pointer val = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - set_car(p, val); - }} - else - for (i = start, j = 0; i < end; i++, j++) - { - s7_pointer val = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - set(sc, dest, j, val); - } - s7_gc_unprotect_at(sc, gc_loc); - } + { + s7_pointer iter = s7_make_iterator(sc, sc->s7_starlet); + s7_int gc_loc = gc_protect_1(sc, iter); + for (i = 0; i < start; i++) + { + s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) + { + s7_gc_unprotect_at(sc, gc_loc); + return(dest); + }} + if (is_pair(dest)) /* (append '(1) *s7* ()) */ + { + s7_pointer p; + for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) + { + s7_pointer val = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + set_car(p, val); + }} + else + for (i = start, j = 0; i < end; i++, j++) + { + s7_pointer val = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + set(sc, dest, j, val); + } + s7_gc_unprotect_at(sc, gc_loc); + } else - { - /* source and dest can't be rootlet (checked above), dest also can't be *s7* */ - s7_pointer slot = let_slots(source); - for (i = 0; i < start; i++) slot = next_slot(slot); - if (is_pair(dest)) - { - s7_pointer p; - check_free_heap_size(sc, end - start); - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p), slot = next_slot(slot)) - set_car(p, cons_unchecked(sc, slot_symbol(slot), slot_value(slot))); - } - else - if (is_let(dest)) /* this ignores slot setters */ - { - if ((has_let_fallback(source)) && - (has_let_fallback(dest))) - { - for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) - if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) && - (slot_symbol(slot) != sc->let_set_fallback_symbol)) - add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); - } - else - for (i = start; i < end; i++, slot = next_slot(slot)) - add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); - } - else - if (is_hash_table(dest)) - for (i = start; i < end; i++, slot = next_slot(slot)) - s7_hash_table_set(sc, dest, slot_symbol(slot), slot_value(slot)); /* if value=#f, dest will not contain symbol */ - else - if ((is_t_vector(dest)) && (set != typed_vector_setter)) - { - s7_pointer *els = vector_elements(dest); - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) - els[j] = cons_unchecked(sc, slot_symbol(slot), slot_value(slot)); - } - else - for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) - set(sc, dest, j, cons(sc, slot_symbol(slot), slot_value(slot))); - } + { + /* source and dest can't be rootlet (checked above), dest also can't be *s7* */ + s7_pointer slot = let_slots(source); + for (i = 0; i < start; i++) slot = next_slot(slot); + if (is_pair(dest)) + { + s7_pointer p; + check_free_heap_size(sc, end - start); + for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p), slot = next_slot(slot)) + set_car(p, cons_unchecked(sc, slot_symbol(slot), slot_value(slot))); + } + else + if (is_let(dest)) /* this ignores slot setters */ + { + if ((has_let_fallback(source)) && + (has_let_fallback(dest))) + { + for (slot = let_slots(source); tis_slot(slot); slot = next_slot(slot)) + if ((slot_symbol(slot) != sc->let_ref_fallback_symbol) && + (slot_symbol(slot) != sc->let_set_fallback_symbol)) + add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); + } + else + for (i = start; i < end; i++, slot = next_slot(slot)) + add_slot_checked_with_id(sc, dest, slot_symbol(slot), slot_value(slot)); + } + else + if (is_hash_table(dest)) + for (i = start; i < end; i++, slot = next_slot(slot)) + s7_hash_table_set(sc, dest, slot_symbol(slot), slot_value(slot)); /* if value=#f, dest will not contain symbol */ + else + if ((is_t_vector(dest)) && (set != typed_vector_setter)) + { + s7_pointer *els = vector_elements(dest); + check_free_heap_size(sc, end - start); + for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) + els[j] = cons_unchecked(sc, slot_symbol(slot), slot_value(slot)); + } + else + for (i = start, j = 0; i < end; i++, j++, slot = next_slot(slot)) + set(sc, dest, j, cons(sc, slot_symbol(slot), slot_value(slot))); + } return(dest); case T_HASH_TABLE: { - s7_int loc = -1, skip = start; - hash_entry_t **elements = hash_table_elements(source); - hash_entry_t *x = NULL; - - while (skip > 0) - { - while (!x) x = elements[++loc]; - skip--; - x = hash_entry_next(x); - } - if (is_pair(dest)) - { - s7_pointer p; - check_free_heap_size(sc, end - start); - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - { - while (!x) x = elements[++loc]; - set_car(p, cons_unchecked(sc, hash_entry_key(x), hash_entry_value(x))); - x = hash_entry_next(x); - }} - else - if (is_let(dest)) - { - for (i = start; i < end; i++) - { - s7_pointer symbol; - while (!x) x = elements[++loc]; - symbol = hash_entry_key(x); - if (!is_symbol(symbol)) - copy_element_error_nr(sc, caller, i + 1, symbol, T_SYMBOL); - if (is_constant_symbol(sc, symbol)) - error_nr(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)) - add_slot_checked_with_id(sc, dest, symbol, hash_entry_value(x)); /* ...unchecked... if size ok */ - x = hash_entry_next(x); - }} - else - { - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++) - { - while (!x) x = elements[++loc]; - set(sc, dest, j, cons_unchecked(sc, hash_entry_key(x), hash_entry_value(x))); - x = hash_entry_next(x); - }} + s7_int loc = -1, skip = start; + hash_entry_t **elements = hash_table_elements(source); + hash_entry_t *x = NULL; + + while (skip > 0) + { + while (!x) x = elements[++loc]; + skip--; + x = hash_entry_next(x); + } + if (is_pair(dest)) + { + s7_pointer p; + check_free_heap_size(sc, end - start); + for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) + { + while (!x) x = elements[++loc]; + set_car(p, cons_unchecked(sc, hash_entry_key(x), hash_entry_value(x))); + x = hash_entry_next(x); + }} + else + if (is_let(dest)) + { + for (i = start; i < end; i++) + { + s7_pointer symbol; + while (!x) x = elements[++loc]; + symbol = hash_entry_key(x); + if (!is_symbol(symbol)) + copy_element_error_nr(sc, caller, i + 1, symbol, T_SYMBOL); + if (is_constant_symbol(sc, symbol)) + error_nr(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)) + add_slot_checked_with_id(sc, dest, symbol, hash_entry_value(x)); /* ...unchecked... if size ok */ + x = hash_entry_next(x); + }} + else + { + check_free_heap_size(sc, end - start); + for (i = start, j = 0; i < end; i++, j++) + { + while (!x) x = elements[++loc]; + set(sc, dest, j, cons_unchecked(sc, hash_entry_key(x), hash_entry_value(x))); + x = hash_entry_next(x); + }} return(dest); } case T_VECTOR: { - s7_pointer *vals = vector_elements(source); - if (is_float_vector(dest)) - { - s7_double *dst = float_vector_floats(dest); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = real_to_double(sc, vals[i], symbol_name(caller)); - return(dest); - } - if (is_int_vector(dest)) - { - s7_int *dst = int_vector_ints(dest); - for (i = start, j = 0; i < end; i++, j++) - { - if (!s7_is_integer(vals[i])) - copy_element_error_nr(sc, caller, i + 1, vals[i], T_INTEGER); - dst[j] = s7_integer_clamped_if_gmp(sc, vals[i]); - } - return(dest); - } - if (is_string(dest)) - { - char *dst = string_value(dest); - for (i = start, j = 0; i < end; i++, j++) - { - if (!is_character(vals[i])) - copy_element_error_nr(sc, caller, i + 1, vals[i], T_CHARACTER); - dst[j] = character(vals[i]); - } - return(dest); - } - if (is_byte_vector(dest)) - { - uint8_t *dst = (uint8_t *)byte_vector_bytes(dest); - for (i = start, j = 0; i < end; i++, j++) - { - s7_int byte; - if (!s7_is_integer(vals[i])) - copy_element_error_with_type_nr(sc, caller, i + 1, vals[i], an_unsigned_byte_string); - byte = s7_integer_clamped_if_gmp(sc, vals[i]); - if ((byte >= 0) && (byte < 256)) - dst[j] = (uint8_t)byte; - else copy_element_error_with_type_nr(sc, caller, i + 1, vals[i], an_unsigned_byte_string); - } - return(dest); - }} + s7_pointer *vals = vector_elements(source); + if (is_float_vector(dest)) + { + s7_double *dst = float_vector_floats(dest); + for (i = start, j = 0; i < end; i++, j++) + dst[j] = real_to_double(sc, vals[i], symbol_name(caller)); + return(dest); + } + if (is_int_vector(dest)) + { + s7_int *dst = int_vector_ints(dest); + for (i = start, j = 0; i < end; i++, j++) + { + if (!s7_is_integer(vals[i])) + copy_element_error_nr(sc, caller, i + 1, vals[i], T_INTEGER); + dst[j] = s7_integer_clamped_if_gmp(sc, vals[i]); + } + return(dest); + } + if (is_string(dest)) + { + char *dst = string_value(dest); + for (i = start, j = 0; i < end; i++, j++) + { + if (!is_character(vals[i])) + copy_element_error_nr(sc, caller, i + 1, vals[i], T_CHARACTER); + dst[j] = character(vals[i]); + } + return(dest); + } + if (is_byte_vector(dest)) + { + uint8_t *dst = (uint8_t *)byte_vector_bytes(dest); + for (i = start, j = 0; i < end; i++, j++) + { + s7_int byte; + if (!s7_is_integer(vals[i])) + copy_element_error_with_type_nr(sc, caller, i + 1, vals[i], an_unsigned_byte_string); + byte = s7_integer_clamped_if_gmp(sc, vals[i]); + if ((byte >= 0) && (byte < 256)) + dst[j] = (uint8_t)byte; + else copy_element_error_with_type_nr(sc, caller, i + 1, vals[i], an_unsigned_byte_string); + } + return(dest); + }} break; case T_FLOAT_VECTOR: { - s7_double *src = float_vector_floats(source); - /* int-vector destination can't normally work, fractional parts get rounded away */ - if ((is_t_vector(dest)) && (!is_typed_vector(dest))) - { - s7_pointer *dst = vector_elements(dest); - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = make_real_unchecked(sc, src[i]); - return(dest); - }} + s7_double *src = float_vector_floats(source); + /* int-vector destination can't normally work, fractional parts get rounded away */ + if ((is_t_vector(dest)) && (!is_typed_vector(dest))) + { + s7_pointer *dst = vector_elements(dest); + check_free_heap_size(sc, end - start); + for (i = start, j = 0; i < end; i++, j++) + dst[j] = make_real_unchecked(sc, src[i]); + return(dest); + }} break; case T_INT_VECTOR: { - s7_int *src = int_vector_ints(source); - if (is_float_vector(dest)) - { - s7_double *dst = float_vector_floats(dest); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = (s7_double)(src[i]); - return(dest); - } - if ((is_t_vector(dest)) && (!is_typed_vector(dest))) - { - s7_pointer *dst = vector_elements(dest); - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = make_integer_unchecked(sc, src[i]); - return(dest); - } - if (is_string(dest)) - { - for (i = start, j = 0; i < end; i++, j++) - { - if ((src[i] < 0) || (src[i] > 255)) - copy_element_error_with_type_nr(sc, caller, i + 1, wrap_integer(sc, src[i]), an_unsigned_byte_string); - string_value(dest)[j] = (uint8_t)(src[i]); - } - return(dest); - } - if (is_byte_vector(dest)) - { - for (i = start, j = 0; i < end; i++, j++) - { - if ((src[i] < 0) || (src[i] > 255)) - copy_element_error_with_type_nr(sc, caller, i + 1, wrap_integer(sc, src[i]), an_unsigned_byte_string); - byte_vector(dest, j) = (uint8_t)(src[i]); - } - return(dest); - }} + s7_int *src = int_vector_ints(source); + if (is_float_vector(dest)) + { + s7_double *dst = float_vector_floats(dest); + for (i = start, j = 0; i < end; i++, j++) + dst[j] = (s7_double)(src[i]); + return(dest); + } + if ((is_t_vector(dest)) && (!is_typed_vector(dest))) + { + s7_pointer *dst = vector_elements(dest); + check_free_heap_size(sc, end - start); + for (i = start, j = 0; i < end; i++, j++) + dst[j] = make_integer_unchecked(sc, src[i]); + return(dest); + } + if (is_string(dest)) + { + for (i = start, j = 0; i < end; i++, j++) + { + if ((src[i] < 0) || (src[i] > 255)) + copy_element_error_with_type_nr(sc, caller, i + 1, wrap_integer(sc, src[i]), an_unsigned_byte_string); + string_value(dest)[j] = (uint8_t)(src[i]); + } + return(dest); + } + if (is_byte_vector(dest)) + { + for (i = start, j = 0; i < end; i++, j++) + { + if ((src[i] < 0) || (src[i] > 255)) + copy_element_error_with_type_nr(sc, caller, i + 1, wrap_integer(sc, src[i]), an_unsigned_byte_string); + byte_vector(dest, j) = (uint8_t)(src[i]); + } + return(dest); + }} break; case T_BYTE_VECTOR: if ((is_t_vector(dest)) && (!is_typed_vector(dest))) - { - s7_pointer *dst = vector_elements(dest); - check_free_heap_size(sc, end - start); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = small_int(byte_vector(source, i)); - return(dest); - } + { + s7_pointer *dst = vector_elements(dest); + check_free_heap_size(sc, end - start); + for (i = start, j = 0; i < end; i++, j++) + dst[j] = small_int(byte_vector(source, i)); + return(dest); + } if (is_int_vector(dest)) - { - s7_int *els = int_vector_ints(dest); - for (i = start, j = 0; i < end; i++, j++) - els[j] = (s7_int)((uint8_t)(byte_vector(source, i))); - return(dest); - } + { + s7_int *els = int_vector_ints(dest); + for (i = start, j = 0; i < end; i++, j++) + els[j] = (s7_int)((uint8_t)(byte_vector(source, i))); + return(dest); + } if (is_float_vector(dest)) - { - s7_double *els = float_vector_floats(dest); - for (i = start, j = 0; i < end; i++, j++) - els[j] = (s7_double)((uint8_t)(byte_vector(source, i))); - return(dest); - } + { + s7_double *els = float_vector_floats(dest); + for (i = start, j = 0; i < end; i++, j++) + els[j] = (s7_double)((uint8_t)(byte_vector(source, i))); + return(dest); + } break; case T_STRING: if ((is_t_vector(dest)) && (!is_typed_vector(dest))) - { - s7_pointer *dst = vector_elements(dest); - for (i = start, j = 0; i < end; i++, j++) - dst[j] = chars[(uint8_t)string_value(source)[i]]; - return(dest); - } + { + s7_pointer *dst = vector_elements(dest); + for (i = start, j = 0; i < end; i++, j++) + dst[j] = chars[(uint8_t)string_value(source)[i]]; + return(dest); + } if (is_int_vector(dest)) - { - s7_int *els = int_vector_ints(dest); - for (i = start, j = 0; i < end; i++, j++) - els[j] = (s7_int)((uint8_t)(string_value(source)[i])); - return(dest); - } + { + s7_int *els = int_vector_ints(dest); + for (i = start, j = 0; i < end; i++, j++) + els[j] = (s7_int)((uint8_t)(string_value(source)[i])); + return(dest); + } if (is_float_vector(dest)) - { - s7_double *els = float_vector_floats(dest); - for (i = start, j = 0; i < end; i++, j++) - els[j] = (s7_double)((uint8_t)(string_value(source)[i])); - return(dest); - } + { + s7_double *els = float_vector_floats(dest); + for (i = start, j = 0; i < end; i++, j++) + els[j] = (s7_double)((uint8_t)(string_value(source)[i])); + return(dest); + } break; } @@ -49901,23 +49901,23 @@ static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) { s7_pointer p; if (is_float_vector(source)) - { - s7_double *els = float_vector_floats(source); - check_free_heap_size(sc, end - start); - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - set_car(p, make_real_unchecked(sc, els[i])); - } + { + s7_double *els = float_vector_floats(source); + check_free_heap_size(sc, end - start); + for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) + set_car(p, make_real_unchecked(sc, els[i])); + } else - if (is_int_vector(source)) - { - s7_int *els = int_vector_ints(source); - check_free_heap_size(sc, end - start); - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - set_car(p, make_integer_unchecked(sc, els[i])); - } - else - for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) - set_car(p, get(sc, source, i)); + if (is_int_vector(source)) + { + s7_int *els = int_vector_ints(source); + check_free_heap_size(sc, end - start); + for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) + set_car(p, make_integer_unchecked(sc, els[i])); + } + else + for (i = start, p = dest; (i < end) && (is_pair(p)); i++, p = cdr(p)) + set_car(p, get(sc, source, i)); } else /* if source == dest here, we're moving data backwards, so this is safe in either case */ for (i = start, j = 0; i < end; i++, j++) @@ -49946,12 +49946,12 @@ s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a) /* just pairs */ { sc->w = cons(sc, car(x), sc->w); if (is_pair(cdr(x))) - { - x = cdr(x); - sc->w = cons_unchecked(sc, car(x), sc->w); - } + { + x = cdr(x); + sc->w = cons_unchecked(sc, car(x), sc->w); + } if (x == p) /* this can take awhile to notice there's a cycle, but what does the caller expect? */ - break; + break; } p = (is_null(x)) ? sc->w : cons(sc, x, sc->w); /* ?? this means that (reverse '(1 2 . 3)) returns '(3 2 1) -- we used to return () here */ sc->w = sc->unused; @@ -50052,7 +50052,7 @@ static s7_pointer reverse_p_p(s7_scheme *sc, s7_pointer p) case T_C_OBJECT: check_method(sc, p, sc->reverse_symbol, set_plist_1(sc, p)); if (!c_object_reverse(sc, p)) - syntax_error_nr(sc, "attempt to reverse ~S?", 22, p); + syntax_error_nr(sc, "attempt to reverse ~S?", 22, p); return((*(c_object_reverse(sc, p)))(sc, set_plist_1(sc, p))); case T_LET: check_method(sc, p, sc->reverse_symbol, set_plist_1(sc, p)); @@ -50081,16 +50081,16 @@ static s7_pointer any_list_reverse_in_place(s7_scheme *sc, s7_pointer term, s7_p { s7_pointer q = cdr(p); if (is_null(q)) - { - set_cdr(p, result); - return(p); - } + { + set_cdr(p, result); + return(p); + } if ((is_pair(q)) && (!is_immutable_pair(q))) - { - set_cdr(p, result); - result = p; - p = q; - } + { + set_cdr(p, result); + result = p; + p = q; + } else return(sc->nil); /* improper or immutable */ } return(result); @@ -50124,29 +50124,29 @@ static s7_pointer string_or_byte_vector_reverse_in_place(s7_scheme *sc, s7_point uint32_t *dst = (uint32_t *)(bytes + len - 4); uint32_t *src = (uint32_t *)bytes; while (src < dst) - { - uint32_t a, b; - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - }} + { + uint32_t a, b; + LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); + LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); + LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); + LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); + }} else if ((len & 0x1f) == 0) /* 4-bytes at a time, 4 times per loop == 16 */ { - uint32_t *dst = (uint32_t *)(bytes + len - 4); - uint32_t *src = (uint32_t *)bytes; - while (src < dst) - { - uint32_t a, b; - LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); - }} + uint32_t *dst = (uint32_t *)(bytes + len - 4); + uint32_t *src = (uint32_t *)bytes; + while (src < dst) + { + uint32_t a, b; + LOOP_4(a = *src; b = *dst; *src++ = bswap_32(b); *dst-- = bswap_32(a)); + }} else #endif { - char *s1 = (char *)bytes; - char *s2 = (char *)(s1 + len - 1); - while (s1 < s2) {char c; c = *s1; *s1++ = *s2; *s2-- = c;} + char *s1 = (char *)bytes; + char *s2 = (char *)(s1 + len - 1); + while (s1 < s2) {char c; c = *s1; *s1++ = *s2; *s2-- = c;} } return(p); } @@ -50164,19 +50164,19 @@ static s7_pointer int_vector_reverse_in_place(s7_scheme *sc, s7_pointer p) if ((len & 0x3f) == 0) /* 63 for 2 32's */ while (s1 < s2) { - s7_int c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + s7_int c; + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); } else if ((len & 0xf) == 0) /* not 0x7 -- odd multiple of 8 will leave center ints unreversed (we're moving 2 at a time) */ while (s1 < s2) - { - s7_int c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } + { + s7_int c; + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + } else while (s1 < s2) {s7_int c; c = *s1; *s1++ = *s2; *s2-- = c;} return(p); } @@ -50192,19 +50192,19 @@ static s7_pointer float_vector_reverse_in_place(s7_scheme *sc, s7_pointer p) if ((len & 0x3f) == 0) /* 63 for 2 32's */ while (s1 < s2) { - s7_double c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + s7_double c; + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); } else if ((len & 0xf) == 0) while (s1 < s2) - { - s7_double c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } + { + s7_double c; + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + } else while (s1 < s2) {s7_double c; c = *s1; *s1++ = *s2; *s2-- = c;} return(p); } @@ -50220,19 +50220,19 @@ static s7_pointer vector_reverse_in_place(s7_scheme *sc, s7_pointer p) if ((len & 0x3f) == 0) /* 63 for 2 32's */ while (s1 < s2) { - s7_pointer c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + s7_pointer c; + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); } else if ((len & 0xf) == 0) while (s1 < s2) - { - s7_pointer c; - LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); - } + { + s7_pointer c; + LOOP_8(c = *s1; *s1++ = *s2; *s2-- = c); + } else while (s1 < s2) {s7_pointer c; c = *s1; *s1++ = *s2; *s2-- = c;} return(p); } @@ -50251,16 +50251,16 @@ static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) case T_PAIR: if (is_immutable_pair(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); { - s7_pointer np = any_list_reverse_in_place(sc, sc->nil, p); - if (is_null(np)) - { - if (!s7_is_proper_list(sc, p)) - wrong_type_error_nr(sc, sc->reverseb_symbol, 1, car(args), wrap_string(sc, "a proper list", 13)); - wrong_type_error_nr(sc, sc->reverseb_symbol, 1, car(args), wrap_string(sc, "a mutable proper list", 21)); - } - return(np); + s7_pointer np = any_list_reverse_in_place(sc, sc->nil, p); + if (is_null(np)) + { + if (!s7_is_proper_list(sc, p)) + wrong_type_error_nr(sc, sc->reverseb_symbol, 1, car(args), wrap_string(sc, "a proper list", 13)); + wrong_type_error_nr(sc, sc->reverseb_symbol, 1, car(args), wrap_string(sc, "a mutable proper list", 21)); + } + return(np); } /* (reverse! p) is supposed to change p directly and lisp programmers expect reverse! to be fast * so in a sense this is different from the other cases: it assumes (set! p (reverse! p)) @@ -50279,14 +50279,14 @@ static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args) default: if (is_immutable(p)) - { - if (is_simple_sequence(p)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); - sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, p, a_sequence_string); - } + { + if (is_simple_sequence(p)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p)); + sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, p, a_sequence_string); + } if ((is_simple_sequence(p)) && - (!has_active_methods(sc, p))) - sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, p, wrap_string(sc, "a vector, string, or list", 25)); + (!has_active_methods(sc, p))) + sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, p, wrap_string(sc, "a vector, string, or list", 25)); return(method_or_bust_p(sc, p, sc->reverseb_symbol, a_sequence_string)); } return(p); @@ -50333,18 +50333,18 @@ static s7_pointer pair_fill(s7_scheme *sc, s7_pointer args) /* args=(list tree-t for (s7_pointer x = obj, y = obj; ; i++) { if ((end > 0) && (i >= end)) - return(val); + return(val); if (i >= start) set_car(x, val); if (!is_pair(cdr(x))) - { - if (!is_null(cdr(x))) - set_cdr(x, val); - return(val); - } + { + if (!is_null(cdr(x))) + set_cdr(x, val); + return(val); + } x = cdr(x); if ((i & 1) != 0) y = cdr(y); if (x == y) - return(val); + return(val); } return(val); } @@ -50367,7 +50367,7 @@ s7_pointer s7_fill(s7_scheme *sc, s7_pointer args) case T_HASH_TABLE: return(hash_table_fill(sc, args)); case T_NIL: if (!is_null(cddr(args))) /* (fill! () 1 21 #\a)? */ - syntax_error_nr(sc, "fill! () ... includes indices: ~S?", 34, cddr(args)); + syntax_error_nr(sc, "fill! () ... includes indices: ~S?", 34, cddr(args)); return(cadr(args)); /* this parallels the empty vector case */ case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: return(g_vector_fill_1(sc, sc->fill_symbol, args)); @@ -50377,7 +50377,7 @@ s7_pointer s7_fill(s7_scheme *sc, s7_pointer args) case T_C_OBJECT: check_method(sc, p, sc->fill_symbol, args); if (!c_object_fill(sc, p)) /* default is NULL (s7_make_c_type) */ - syntax_error_nr(sc, "attempt to fill ~S?", 19, p); + syntax_error_nr(sc, "attempt to fill ~S?", 19, p); return((*(c_object_fill(sc, p)))(sc, args)); default: check_method(sc, p, sc->fill_symbol, args); @@ -50400,19 +50400,19 @@ static s7_int total_sequence_length(s7_scheme *sc, s7_pointer args, s7_pointer c s7_pointer seq = car(p); s7_int n = sequence_length(sc, seq); if ((n > 0) && - (typ != T_FREE) && - ((type(seq) == T_HASH_TABLE) || /* can't append hash-tables (no obvious meaning to the operation) */ - ((type(seq) == T_LET) && /* similarly for lets, unless this is a mock-string or something similar */ - ((!has_active_methods(sc, seq)) || (find_method(sc, seq, caller) == sc->undefined))))) - { - wrong_type_error_nr(sc, caller, i, seq, sc->type_names[typ]); - return(0); - } + (typ != T_FREE) && + ((type(seq) == T_HASH_TABLE) || /* can't append hash-tables (no obvious meaning to the operation) */ + ((type(seq) == T_LET) && /* similarly for lets, unless this is a mock-string or something similar */ + ((!has_active_methods(sc, seq)) || (find_method(sc, seq, caller) == sc->undefined))))) + { + wrong_type_error_nr(sc, caller, i, seq, sc->type_names[typ]); + return(0); + } if (n < 0) - { - wrong_type_error_nr(sc, caller, i, seq, (is_pair(seq)) ? a_proper_list_string : a_sequence_string); - return(0); - } + { + wrong_type_error_nr(sc, caller, i, seq, (is_pair(seq)) ? a_proper_list_string : a_sequence_string); + return(0); + } len += n; } return(len); @@ -50434,10 +50434,10 @@ static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_ { unstack_gc_protect(sc); error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "~S new vector length, ~D, is larger than (*s7* 'max-vector-length): ~D", 70), - caller, - wrap_integer(sc, len), - wrap_integer(sc, sc->max_vector_length))); + set_elist_4(sc, wrap_string(sc, "~S new vector length, ~D, is larger than (*s7* 'max-vector-length): ~D", 70), + caller, + wrap_integer(sc, len), + wrap_integer(sc, sc->max_vector_length))); } new_vec = make_vector_1(sc, len, (typ == T_VECTOR) ? FILLED : NOT_FILLED, typ); /* might hit GC in loop below so we can't use NOT_FILLED here (??) */ typed = (typ == T_VECTOR); @@ -50455,7 +50455,7 @@ static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_ fv_elements = float_vector_floats(new_vec); else if (typ == T_INT_VECTOR) - iv_elements = int_vector_ints(new_vec); + iv_elements = int_vector_ints(new_vec); else byte_elements = byte_vector_bytes(new_vec); pargs = list_2(sc, sc->F, new_vec); /* car set below */ @@ -50466,31 +50466,31 @@ static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_ s7_pointer x = car(p); s7_int n = sequence_length(sc, x); if (n > 0) - { - if ((typed) && (is_typed_t_vector(x))) - { - if (!vtyper) - vtyper = typed_vector_typer(x); - else - if (vtyper != typed_vector_typer(x)) - typed = false; - } - else typed = false; - vector_length(new_vec) = n; - set_car(pargs, x); - s7_copy_1(sc, caller, pargs); /* not set_plist_2 here! */ - vector_length(new_vec) = 0; /* so GC doesn't march off the end */ - i += n; - if (typ == T_VECTOR) - vector_elements(new_vec) = (s7_pointer *)(v_elements + i); - else - if (typ == T_FLOAT_VECTOR) - float_vector_floats(new_vec) = (s7_double *)(fv_elements + i); - else - if (typ == T_INT_VECTOR) - int_vector_ints(new_vec) = (s7_int *)(iv_elements + i); - else byte_vector_bytes(new_vec) = (uint8_t *)(byte_elements + i); - }} + { + if ((typed) && (is_typed_t_vector(x))) + { + if (!vtyper) + vtyper = typed_vector_typer(x); + else + if (vtyper != typed_vector_typer(x)) + typed = false; + } + else typed = false; + vector_length(new_vec) = n; + set_car(pargs, x); + s7_copy_1(sc, caller, pargs); /* not set_plist_2 here! */ + vector_length(new_vec) = 0; /* so GC doesn't march off the end */ + i += n; + if (typ == T_VECTOR) + vector_elements(new_vec) = (s7_pointer *)(v_elements + i); + else + if (typ == T_FLOAT_VECTOR) + float_vector_floats(new_vec) = (s7_double *)(fv_elements + i); + else + if (typ == T_INT_VECTOR) + int_vector_ints(new_vec) = (s7_int *)(iv_elements + i); + else byte_vector_bytes(new_vec) = (uint8_t *)(byte_elements + i); + }} /* unstack_gc_protect(sc); */ /* free_cell(sc, pargs); */ /* this is trouble if any arg is openlet with append method -- e.g. block */ if (typ == T_VECTOR) @@ -50500,7 +50500,7 @@ static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_ float_vector_floats(new_vec) = fv_elements; else if (typ == T_INT_VECTOR) - int_vector_ints(new_vec) = iv_elements; + int_vector_ints(new_vec) = iv_elements; else byte_vector_bytes(new_vec) = byte_elements; vector_length(new_vec) = len; if ((typed) && (vtyper)) @@ -50524,23 +50524,23 @@ static s7_pointer hash_table_append(s7_scheme *sc, s7_pointer args) { s7_pointer seq = car(p); if (!sequence_is_empty(sc, seq)) - { - /* perhaps check seq-length+hash_table_entries(new_hash) > sc->max_vector_length here? */ - s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, seq, new_hash)); - if ((typed) && (is_hash_table(seq)) && (is_typed_hash_table(seq))) - { - if (!key_typer) - { /* the equality/mapping procedures are either partly implicit or in hash-table-procedures -- a bit of a mess currently */ - key_typer = hash_table_key_typer(seq); - value_typer = hash_table_value_typer(seq); - } - else - if ((hash_table_key_typer(seq) != key_typer) || - (hash_table_value_typer(seq) != value_typer)) - typed = false; - } - else typed = false; - }} + { + /* perhaps check seq-length+hash_table_entries(new_hash) > sc->max_vector_length here? */ + s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, seq, new_hash)); + if ((typed) && (is_hash_table(seq)) && (is_typed_hash_table(seq))) + { + if (!key_typer) + { /* the equality/mapping procedures are either partly implicit or in hash-table-procedures -- a bit of a mess currently */ + key_typer = hash_table_key_typer(seq); + value_typer = hash_table_value_typer(seq); + } + else + if ((hash_table_key_typer(seq) != key_typer) || + (hash_table_value_typer(seq) != value_typer)) + typed = false; + } + else typed = false; + }} if ((typed) && (key_typer)) { hash_table_set_procedures(new_hash, make_hash_table_procedures(sc)); @@ -50607,17 +50607,17 @@ s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b) { s7_pointer q, p, np, op; if ((!is_pair(b)) && (!is_null(b))) - return(g_list_append(sc, list_2(sc, a, b))); + return(g_list_append(sc, list_2(sc, a, b))); q = list_1(sc, car(a)); sc->temp8 = q; for (op = a, p = cdr(a), np = q; (is_pair(p)) && (p != op); p = cdr(p), np = cdr(np), op = cdr(op)) - { - set_cdr(np, list_1_unchecked(sc, car(p))); p = cdr(p); np = cdr(np); - if (!is_pair(p)) break; - set_cdr(np, list_1(sc, car(p))); - } + { + set_cdr(np, list_1_unchecked(sc, car(p))); p = cdr(p); np = cdr(np); + if (!is_pair(p)) break; + set_cdr(np, list_1(sc, car(p))); + } if (!is_null(p)) - wrong_type_error_nr(sc, sc->append_symbol, 1, a, a_proper_list_string); + wrong_type_error_nr(sc, sc->append_symbol, 1, a, a_proper_list_string); set_cdr(np, b); sc->temp8 = sc->unused; return(q); @@ -50676,48 +50676,48 @@ static s7_pointer iterator_to_list(s7_scheme *sc, s7_pointer obj) { s7_pointer val = s7_iterate(sc, obj); if ((val == ITERATOR_END) && - (iterator_is_at_end(obj))) - { - if (is_pair(result)) unstack_gc_protect(sc); - return(result); - } + (iterator_is_at_end(obj))) + { + if (is_pair(result)) unstack_gc_protect(sc); + return(result); + } if (sc->safety > NO_SAFETY) - { - results++; - if (results > 10000) - { - s7_warn(sc, 256, "iterator is creating a very long list!\n"); - results = S7_INT32_MIN; - }} + { + results++; + if (results > 10000) + { + s7_warn(sc, 256, "iterator is creating a very long list!\n"); + results = S7_INT32_MIN; + }} if (val != sc->no_value) - { - if (is_null(result)) - { - if (is_multiple_value(val)) - { - result = multiple_value(val); - clear_multiple_value(val); - for (p = result; is_pair(cdr(p)); p = cdr(p)); - } - else - { - result = list_1(sc, val); - p = result; - } - gc_protect_via_stack(sc, result); /* unstacked above */ - } - else - if (is_multiple_value(val)) - { - set_cdr(p, multiple_value(val)); - clear_multiple_value(val); - for (; is_pair(cdr(p)); p = cdr(p)); - } - else - { - set_cdr(p, list_1(sc, val)); - p = cdr(p); - }}} + { + if (is_null(result)) + { + if (is_multiple_value(val)) + { + result = multiple_value(val); + clear_multiple_value(val); + for (p = result; is_pair(cdr(p)); p = cdr(p)); + } + else + { + result = list_1(sc, val); + p = result; + } + gc_protect_via_stack(sc, result); /* unstacked above */ + } + else + if (is_multiple_value(val)) + { + set_cdr(p, multiple_value(val)); + clear_multiple_value(val); + for (; is_pair(cdr(p)); p = cdr(p)); + } + else + { + set_cdr(p, list_1(sc, val)); + p = cdr(p); + }}} } static s7_pointer c_obj_to_list(s7_scheme *sc, s7_pointer obj) /* "c_object_to_list" is the ->list method mentioned below */ @@ -50778,23 +50778,23 @@ static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj) /* used only in static s7_pointer symbol_to_let(s7_scheme *sc, s7_pointer obj) { s7_pointer let = internal_inlet(sc, 4, sc->value_symbol, obj, - sc->type_symbol, (is_keyword(obj)) ? sc->is_keyword_symbol : - ((is_gensym(obj)) ? sc->is_gensym_symbol : sc->is_symbol_symbol)); + sc->type_symbol, (is_keyword(obj)) ? sc->is_keyword_symbol : + ((is_gensym(obj)) ? sc->is_gensym_symbol : sc->is_symbol_symbol)); if (!is_keyword(obj)) { s7_int gc_loc = gc_protect_1(sc, let); s7_pointer val = s7_symbol_value(sc, obj); if (!sc->current_value_symbol) - sc->current_value_symbol = make_symbol(sc, "current-value", 13); + sc->current_value_symbol = make_symbol(sc, "current-value", 13); s7_varlet(sc, let, sc->current_value_symbol, val); s7_varlet(sc, let, sc->setter_symbol, setter_p_pp(sc, obj, sc->curlet)); s7_varlet(sc, let, sc->is_mutable_symbol, make_boolean(sc, !is_immutable_symbol(obj))); if (!is_undefined(val)) - { - const char *doc = s7_documentation(sc, obj); - if (doc) - s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc)); - } + { + const char *doc = s7_documentation(sc, obj); + if (doc) + s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc)); + } s7_gc_unprotect_at(sc, gc_loc); } return(let); @@ -50811,9 +50811,9 @@ static s7_pointer random_state_to_let(s7_scheme *sc, s7_pointer obj) sc->carry_symbol = make_symbol(sc, "carry", 5); } return(internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, sc->is_random_state_symbol, - sc->seed_symbol, make_integer(sc, random_seed(obj)), - sc->carry_symbol, make_integer(sc, random_carry(obj)))); + sc->type_symbol, sc->is_random_state_symbol, + sc->seed_symbol, make_integer(sc, random_seed(obj)), + sc->carry_symbol, make_integer(sc, random_carry(obj)))); #endif } @@ -50823,21 +50823,21 @@ static s7_pointer vector_to_let(s7_scheme *sc, s7_pointer obj) if (!sc->dimensions_symbol) sc->dimensions_symbol = make_symbol(sc, "dimensions", 10); if (!sc->original_vector_symbol) sc->original_vector_symbol = make_symbol(sc, "original-vector", 15); let = internal_inlet(sc, 10, sc->value_symbol, obj, - sc->type_symbol, (is_subvector(obj)) ? cons(sc, sc->is_subvector_symbol, s7_type_of(sc, subvector_vector(obj))) : s7_type_of(sc, obj), - sc->size_symbol, s7_length(sc, obj), - sc->dimensions_symbol, g_vector_dimensions(sc, set_plist_1(sc, obj)), - sc->is_mutable_symbol, make_boolean(sc, !is_immutable_vector(obj))); + sc->type_symbol, (is_subvector(obj)) ? cons(sc, sc->is_subvector_symbol, s7_type_of(sc, subvector_vector(obj))) : s7_type_of(sc, obj), + sc->size_symbol, s7_length(sc, obj), + sc->dimensions_symbol, g_vector_dimensions(sc, set_plist_1(sc, obj)), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_vector(obj))); gc_protect_via_stack(sc, let); if (is_subvector(obj)) { s7_int pos = 0; switch (type(obj)) /* correct type matters here: gcc 10.2 with -O2 segfaults otherwise, cast to intptr_t has a similar role in earlier gcc's */ - { - case T_VECTOR: pos = (s7_int)((intptr_t)(vector_elements(obj) - vector_elements(subvector_vector(obj)))); break; - case T_INT_VECTOR: pos = (s7_int)((intptr_t)(int_vector_ints(obj) - int_vector_ints(subvector_vector(obj)))); break; - case T_FLOAT_VECTOR: pos = (s7_int)((intptr_t)(float_vector_floats(obj) - float_vector_floats(subvector_vector(obj)))); break; - case T_BYTE_VECTOR: pos = (s7_int)((intptr_t)(byte_vector_bytes(obj) - byte_vector_bytes(subvector_vector(obj)))); break; - } + { + case T_VECTOR: pos = (s7_int)((intptr_t)(vector_elements(obj) - vector_elements(subvector_vector(obj)))); break; + case T_INT_VECTOR: pos = (s7_int)((intptr_t)(int_vector_ints(obj) - int_vector_ints(subvector_vector(obj)))); break; + case T_FLOAT_VECTOR: pos = (s7_int)((intptr_t)(float_vector_floats(obj) - float_vector_floats(subvector_vector(obj)))); break; + case T_BYTE_VECTOR: pos = (s7_int)((intptr_t)(byte_vector_bytes(obj) - byte_vector_bytes(subvector_vector(obj)))); break; + } s7_varlet(sc, let, sc->position_symbol, make_integer(sc, pos)); s7_varlet(sc, let, sc->original_vector_symbol, subvector_vector(obj)); } @@ -50849,22 +50849,22 @@ static s7_pointer vector_to_let(s7_scheme *sc, s7_pointer obj) { s7_int max_len = 0, zeros = 0, ones = 0, twos = 0, biggies = 0; for (s7_int i = 0; i < SYMBOL_TABLE_SIZE; i++) - { - s7_int j; - s7_pointer p; - for (p = vector_element(sc->symbol_table, i), j = 0; is_pair(p); p = cdr(p), j++); - if (j == 0) zeros++; else - if (j == 1) ones++; else - if (j == 2) twos++; else - biggies++; - if (j > max_len) max_len = j; - } + { + s7_int j; + s7_pointer p; + for (p = vector_element(sc->symbol_table, i), j = 0; is_pair(p); p = cdr(p), j++); + if (j == 0) zeros++; else + if (j == 1) ones++; else + if (j == 2) twos++; else + biggies++; + if (j > max_len) max_len = j; + } s7_varlet(sc, let, make_symbol(sc, "stats:0|1|2|n|max", 17), - cons(sc, make_integer(sc, zeros), - cons(sc, make_integer(sc, ones), - cons(sc, make_integer(sc, twos), - cons(sc, make_integer(sc, biggies), - cons(sc, make_integer(sc, max_len), sc->nil)))))); + cons(sc, make_integer(sc, zeros), + cons(sc, make_integer(sc, ones), + cons(sc, make_integer(sc, twos), + cons(sc, make_integer(sc, biggies), + cons(sc, make_integer(sc, max_len), sc->nil)))))); } #endif @@ -50886,29 +50886,29 @@ static void hash_table_checker_to_let(s7_scheme *sc, s7_pointer let, s7_pointer s7_varlet(sc, let, sc->function_symbol, sc->is_eqv_symbol); else if ((hash_table_checker(obj) == hash_equal) || - (hash_table_checker(obj) == hash_empty)) - s7_varlet(sc, let, sc->function_symbol, sc->is_equal_symbol); + (hash_table_checker(obj) == hash_empty)) + s7_varlet(sc, let, sc->function_symbol, sc->is_equal_symbol); else - if (hash_table_checker(obj) == hash_equivalent) - s7_varlet(sc, let, sc->function_symbol, sc->is_equivalent_symbol); - else - if ((hash_table_checker(obj) == hash_number_num_eq) || - (hash_table_checker(obj) == hash_int) || - (hash_table_checker(obj) == hash_float)) - s7_varlet(sc, let, sc->function_symbol, sc->num_eq_symbol); - else - if (hash_table_checker(obj) == hash_string) - s7_varlet(sc, let, sc->function_symbol, sc->string_eq_symbol); - else - if (hash_table_checker(obj) == hash_char) - s7_varlet(sc, let, sc->function_symbol, sc->char_eq_symbol); + if (hash_table_checker(obj) == hash_equivalent) + s7_varlet(sc, let, sc->function_symbol, sc->is_equivalent_symbol); + else + if ((hash_table_checker(obj) == hash_number_num_eq) || + (hash_table_checker(obj) == hash_int) || + (hash_table_checker(obj) == hash_float)) + s7_varlet(sc, let, sc->function_symbol, sc->num_eq_symbol); + else + if (hash_table_checker(obj) == hash_string) + s7_varlet(sc, let, sc->function_symbol, sc->string_eq_symbol); + else + if (hash_table_checker(obj) == hash_char) + s7_varlet(sc, let, sc->function_symbol, sc->char_eq_symbol); #if (!WITH_PURE_S7) - else - if (hash_table_checker(obj) == hash_ci_char) - s7_varlet(sc, let, sc->function_symbol, sc->char_ci_eq_symbol); - else - if (hash_table_checker(obj) == hash_ci_string) - s7_varlet(sc, let, sc->function_symbol, sc->string_ci_eq_symbol); + else + if (hash_table_checker(obj) == hash_ci_char) + s7_varlet(sc, let, sc->function_symbol, sc->char_ci_eq_symbol); + else + if (hash_table_checker(obj) == hash_ci_string) + s7_varlet(sc, let, sc->function_symbol, sc->string_ci_eq_symbol); #endif } @@ -50922,10 +50922,10 @@ static s7_pointer hash_table_to_let(s7_scheme *sc, s7_pointer obj) sc->weak_symbol = make_symbol(sc, "weak", 4); } let = internal_inlet(sc, 10, sc->value_symbol, obj, - sc->type_symbol, sc->is_hash_table_symbol, - sc->size_symbol, s7_length(sc, obj), - sc->entries_symbol, make_integer(sc, hash_table_entries(obj)), - sc->is_mutable_symbol, make_boolean(sc, !is_immutable_hash_table(obj))); + sc->type_symbol, sc->is_hash_table_symbol, + sc->size_symbol, s7_length(sc, obj), + sc->entries_symbol, make_integer(sc, hash_table_entries(obj)), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_hash_table(obj))); gc_loc = gc_protect_1(sc, let); if (is_weak_hash_table(obj)) s7_varlet(sc, let, sc->weak_symbol, sc->T); @@ -50934,15 +50934,15 @@ static s7_pointer hash_table_to_let(s7_scheme *sc, s7_pointer obj) { s7_pointer checker = hash_table_procedures_checker(obj); if (checker == sc->T) /* perhaps typed because typers were set, but not checker/mapper */ - hash_table_checker_to_let(sc, let, obj); + hash_table_checker_to_let(sc, let, obj); else s7_varlet(sc, let, sc->function_symbol, list_2(sc, checker, hash_table_procedures_mapper(obj))); s7_varlet(sc, let, sc->signature_symbol, - (is_typed_hash_table(obj)) ? - list_3(sc, - hash_table_typer_symbol(sc, hash_table_value_typer(obj)), - sc->is_hash_table_symbol, - hash_table_typer_symbol(sc, hash_table_key_typer(obj))) : - sc->hash_table_signature); + (is_typed_hash_table(obj)) ? + list_3(sc, + hash_table_typer_symbol(sc, hash_table_value_typer(obj)), + sc->is_hash_table_symbol, + hash_table_typer_symbol(sc, hash_table_key_typer(obj))) : + sc->hash_table_signature); } else hash_table_checker_to_let(sc, let, obj); @@ -50951,22 +50951,22 @@ static s7_pointer hash_table_to_let(s7_scheme *sc, s7_pointer obj) { s7_int max_len = 0, zeros = 0, ones = 0, twos = 0, biggies = 0, hash_len = hash_table_size(obj); for (s7_int i = 0; i < hash_len; i++) - { - hash_entry_t *p; - s7_int j; - for (p = hash_table_element(obj, i), j = 0; p; p = hash_entry_next(p), j++); - if (j == 0) zeros++; else - if (j == 1) ones++; else - if (j == 2) twos++; else - biggies++; - if (j > max_len) max_len = j; - } + { + hash_entry_t *p; + s7_int j; + for (p = hash_table_element(obj, i), j = 0; p; p = hash_entry_next(p), j++); + if (j == 0) zeros++; else + if (j == 1) ones++; else + if (j == 2) twos++; else + biggies++; + if (j > max_len) max_len = j; + } s7_varlet(sc, let, make_symbol(sc, "stats:0|1|2|n|max", 17), - cons(sc, make_integer(sc, zeros), - cons(sc, make_integer(sc, ones), - cons(sc, make_integer(sc, twos), - cons(sc, make_integer(sc, biggies), - cons(sc, make_integer(sc, max_len), sc->nil)))))); + cons(sc, make_integer(sc, zeros), + cons(sc, make_integer(sc, ones), + cons(sc, make_integer(sc, twos), + cons(sc, make_integer(sc, biggies), + cons(sc, make_integer(sc, max_len), sc->nil)))))); } #endif @@ -50983,9 +50983,9 @@ static s7_pointer iterator_to_let(s7_scheme *sc, s7_pointer obj) sc->sequence_symbol = make_symbol(sc, "sequence", 8); } let = internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, sc->is_iterator_symbol, - sc->at_end_symbol, make_boolean(sc, iterator_is_at_end(obj)), - sc->sequence_symbol, iterator_sequence(obj)); + sc->type_symbol, sc->is_iterator_symbol, + sc->at_end_symbol, make_boolean(sc, iterator_is_at_end(obj)), + sc->sequence_symbol, iterator_sequence(obj)); gc_protect_via_stack(sc, let); if (is_pair(seq)) s7_varlet(sc, let, sc->size_symbol, s7_length(sc, seq)); @@ -51020,11 +51020,11 @@ static s7_pointer let_to_let(s7_scheme *sc, s7_pointer obj) sc->alias_symbol = make_symbol(sc, "alias", 5); } let = internal_inlet(sc, 12, sc->value_symbol, obj, - sc->type_symbol, sc->is_let_symbol, - sc->size_symbol, s7_length(sc, obj), - sc->open_symbol, make_boolean(sc, is_openlet(obj)), - sc->outlet_symbol, (obj == sc->rootlet) ? sc->nil : let_outlet(obj), - sc->is_mutable_symbol, make_boolean(sc, !is_immutable_let(obj))); + sc->type_symbol, sc->is_let_symbol, + sc->size_symbol, s7_length(sc, obj), + sc->open_symbol, make_boolean(sc, is_openlet(obj)), + sc->outlet_symbol, (obj == sc->rootlet) ? sc->nil : let_outlet(obj), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_let(obj))); gc_loc = gc_protect_1(sc, let); if (obj == sc->rootlet) s7_varlet(sc, let, sc->alias_symbol, sc->rootlet_symbol); @@ -51033,34 +51033,34 @@ static s7_pointer let_to_let(s7_scheme *sc, s7_pointer obj) s7_varlet(sc, let, sc->alias_symbol, sc->owlet_symbol); else if (is_funclet(obj)) - { - s7_varlet(sc, let, sc->function_symbol, funclet_function(obj)); - if ((has_let_file(obj)) && - (let_file(obj) <= (s7_int)sc->file_names_top) && - (let_line(obj) > 0) && - (let_line(obj) < 1000000)) - { - s7_varlet(sc, let, sc->file_symbol, sc->file_names[let_file(obj)]); - s7_varlet(sc, let, sc->line_symbol, make_integer(sc, let_line(obj))); - }} + { + s7_varlet(sc, let, sc->function_symbol, funclet_function(obj)); + if ((has_let_file(obj)) && + (let_file(obj) <= (s7_int)sc->file_names_top) && + (let_line(obj) > 0) && + (let_line(obj) < 1000000)) + { + s7_varlet(sc, let, sc->file_symbol, sc->file_names[let_file(obj)]); + s7_varlet(sc, let, sc->line_symbol, make_integer(sc, let_line(obj))); + }} else - if (obj == sc->s7_starlet) - { - s7_pointer iter = s7_make_iterator(sc, obj); - s7_int gc_loc1 = gc_protect_1(sc, iter); - while (true) - { - s7_pointer x = s7_iterate(sc, iter); - if (iterator_is_at_end(iter)) break; - s7_varlet(sc, let, car(x), cdr(x)); - } - s7_gc_unprotect_at(sc, gc_loc1); - } + if (obj == sc->s7_starlet) + { + s7_pointer iter = s7_make_iterator(sc, obj); + s7_int gc_loc1 = gc_protect_1(sc, iter); + while (true) + { + s7_pointer x = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + s7_varlet(sc, let, car(x), cdr(x)); + } + s7_gc_unprotect_at(sc, gc_loc1); + } if (has_active_methods(sc, obj)) { s7_pointer func = find_method(sc, obj, sc->object_to_let_symbol); if (func != sc->undefined) - s7_apply_function(sc, func, set_plist_2(sc, obj, let)); + s7_apply_function(sc, func, set_plist_2(sc, obj, let)); } s7_gc_unprotect_at(sc, gc_loc); return(let); @@ -51075,17 +51075,17 @@ static s7_pointer c_object_to_let(s7_scheme *sc, s7_pointer obj) sc->c_object_let_symbol = make_symbol(sc, "c-object-let", 12); } let = internal_inlet(sc, 10, sc->value_symbol, obj, - sc->type_symbol, sc->is_c_object_symbol, - sc->c_object_type_symbol, make_integer(sc, c_object_type(obj)), - sc->c_object_let_symbol, clet, - sc->class_symbol, c_object_type_to_let(sc, obj)); + sc->type_symbol, sc->is_c_object_symbol, + sc->c_object_type_symbol, make_integer(sc, c_object_type(obj)), + sc->c_object_let_symbol, clet, + sc->class_symbol, c_object_type_to_let(sc, obj)); if ((is_let(clet)) && ((has_active_methods(sc, clet)) || (has_active_methods(sc, obj)))) { s7_int gc_loc = gc_protect_1(sc, let); s7_pointer func = find_method(sc, clet, sc->object_to_let_symbol); if (func != sc->undefined) - s7_apply_function(sc, func, set_plist_2(sc, obj, let)); + s7_apply_function(sc, func, set_plist_2(sc, obj, let)); s7_gc_unprotect_at(sc, gc_loc); } return(let); @@ -51103,36 +51103,36 @@ static s7_pointer port_to_let(s7_scheme *sc, s7_pointer obj) /* note the underba sc->file_info_symbol = make_symbol(sc, "file-info", 9); } let = internal_inlet(sc, 10, sc->value_symbol, obj, - /* obj as 'value means it will say "(closed)" when subsequently the let is displayed */ - sc->type_symbol, (is_input_port(obj)) ? sc->is_input_port_symbol : sc->is_output_port_symbol, - sc->port_type_symbol, (is_string_port(obj)) ? sc->string_symbol : ((is_file_port(obj)) ? sc->file_symbol : sc->function_symbol), - sc->closed_symbol, make_boolean(sc, port_is_closed(obj)), - sc->is_mutable_symbol, make_boolean(sc, !is_immutable_port(obj))); + /* obj as 'value means it will say "(closed)" when subsequently the let is displayed */ + sc->type_symbol, (is_input_port(obj)) ? sc->is_input_port_symbol : sc->is_output_port_symbol, + sc->port_type_symbol, (is_string_port(obj)) ? sc->string_symbol : ((is_file_port(obj)) ? sc->file_symbol : sc->function_symbol), + sc->closed_symbol, make_boolean(sc, port_is_closed(obj)), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_port(obj))); gc_loc = gc_protect_1(sc, let); if (is_file_port(obj)) { s7_varlet(sc, let, sc->file_symbol, g_port_filename(sc, set_plist_1(sc, obj))); if (is_input_port(obj)) - s7_varlet(sc, let, sc->line_symbol, g_port_line_number(sc, set_plist_1(sc, obj))); + s7_varlet(sc, let, sc->line_symbol, g_port_line_number(sc, set_plist_1(sc, obj))); #if (!MS_WINDOWS) if ((!port_is_closed(obj)) && (obj != sc->standard_error) && (obj != sc->standard_input) && (obj != sc->standard_output)) - { - struct stat sb; - s7_varlet(sc, let, sc->file_symbol, make_integer(sc, fileno(port_file(obj)))); - if (fstat(fileno(port_file(obj)), &sb) != -1) - { - char c1[64], c2[64], str[512]; - int32_t bytes; - strftime(c1, 64, "%a %d-%b-%Y %H:%M", localtime(&sb.st_atime)); - strftime(c2, 64, "%a %d-%b-%Y %H:%M", localtime(&sb.st_mtime)); - bytes = snprintf(str, 512, "mode: #o%u, links: %ld, owner uid: %d gid: %d, size: %ld bytes, last file access: %s, last file modification: %s", - sb.st_mode, - (long)sb.st_nlink, - (int)sb.st_uid, (int)sb.st_gid, - (long)sb.st_size, - c1, c2); - s7_varlet(sc, let, sc->file_info_symbol, make_string_with_length(sc, (const char *)str, bytes)); - }} + { + struct stat sb; + s7_varlet(sc, let, sc->file_symbol, make_integer(sc, fileno(port_file(obj)))); + if (fstat(fileno(port_file(obj)), &sb) != -1) + { + char c1[64], c2[64], str[512]; + int32_t bytes; + strftime(c1, 64, "%a %d-%b-%Y %H:%M", localtime(&sb.st_atime)); + strftime(c2, 64, "%a %d-%b-%Y %H:%M", localtime(&sb.st_mtime)); + bytes = snprintf(str, 512, "mode: #o%u, links: %ld, owner uid: %d gid: %d, size: %ld bytes, last file access: %s, last file modification: %s", + sb.st_mode, + (long)sb.st_nlink, + (int)sb.st_uid, (int)sb.st_gid, + (long)sb.st_size, + c1, c2); + s7_varlet(sc, let, sc->file_info_symbol, make_string_with_length(sc, (const char *)str, bytes)); + }} #endif } if ((is_string_port(obj)) && /* file port might not have a data buffer */ @@ -51145,7 +51145,7 @@ static s7_pointer port_to_let(s7_scheme *sc, s7_pointer obj) /* note the underba * both valgrind and lib*san complain about the uninitialized data during strlen. */ s7_varlet(sc, let, sc->data_symbol, - make_string_with_length(sc, (const char *)port_data(obj), ((port_position(obj)) > 16) ? 16 : port_position(obj))); /* sc->print_length? */ + make_string_with_length(sc, (const char *)port_data(obj), ((port_position(obj)) > 16) ? 16 : port_position(obj))); /* sc->print_length? */ } if (is_function_port(obj)) s7_varlet(sc, let, sc->function_symbol, port_string_or_function(obj)); @@ -51158,9 +51158,9 @@ static s7_pointer closure_to_let(s7_scheme *sc, s7_pointer obj) const char *doc = s7_documentation(sc, obj); s7_pointer sig = s7_signature(sc, obj); s7_pointer let = internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, (is_t_procedure(obj)) ? sc->is_procedure_symbol : sc->is_macro_symbol, - sc->arity_symbol, s7_arity(sc, obj), - sc->is_mutable_symbol, make_boolean(sc, !is_immutable(obj))); + sc->type_symbol, (is_t_procedure(obj)) ? sc->is_procedure_symbol : sc->is_macro_symbol, + sc->arity_symbol, s7_arity(sc, obj), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable(obj))); gc_protect_via_stack(sc, let); if (is_pair(sig)) s7_varlet(sc, let, sc->local_signature_symbol, sig); @@ -51171,12 +51171,12 @@ static s7_pointer closure_to_let(s7_scheme *sc, s7_pointer obj) { s7_pointer flet = closure_let(obj); if ((has_let_file(flet)) && - (let_file(flet) <= (s7_int)sc->file_names_top) && - (let_line(flet) > 0)) - { - s7_varlet(sc, let, sc->file_symbol, sc->file_names[let_file(flet)]); - s7_varlet(sc, let, sc->line_symbol, make_integer(sc, let_line(flet))); - }} + (let_file(flet) <= (s7_int)sc->file_names_top) && + (let_line(flet) > 0)) + { + s7_varlet(sc, let, sc->file_symbol, sc->file_names[let_file(flet)]); + s7_varlet(sc, let, sc->line_symbol, make_integer(sc, let_line(flet))); + }} if (closure_setter(obj) != sc->F) s7_varlet(sc, let, sc->local_setter_symbol, closure_setter(obj)); @@ -51184,8 +51184,8 @@ static s7_pointer closure_to_let(s7_scheme *sc, s7_pointer obj) if (!sc->source_symbol) sc->source_symbol = make_symbol(sc, "source", 6); s7_varlet(sc, let, sc->source_symbol, - append_in_place(sc, list_2(sc, procedure_type_to_symbol(sc, type(obj)), closure_args(obj)), - closure_body(obj))); + append_in_place(sc, list_2(sc, procedure_type_to_symbol(sc, type(obj)), closure_args(obj)), + closure_body(obj))); unstack_gc_protect(sc); return(let); } @@ -51200,10 +51200,10 @@ static s7_pointer c_pointer_to_let(s7_scheme *sc, s7_pointer obj) } if (!sc->pointer_symbol) sc->pointer_symbol = make_symbol(sc, "pointer", 7); return(internal_inlet(sc, 10, sc->value_symbol, obj, - sc->type_symbol, sc->is_c_pointer_symbol, - sc->pointer_symbol, make_integer(sc, (s7_int)((intptr_t)c_pointer(obj))), - sc->c_type_symbol, c_pointer_type(obj), - sc->info_symbol, c_pointer_info(obj))); + sc->type_symbol, sc->is_c_pointer_symbol, + sc->pointer_symbol, make_integer(sc, (s7_int)((intptr_t)c_pointer(obj))), + sc->c_type_symbol, c_pointer_type(obj), + sc->info_symbol, c_pointer_info(obj))); } static s7_pointer c_function_to_let(s7_scheme *sc, s7_pointer obj) @@ -51211,9 +51211,9 @@ static s7_pointer c_function_to_let(s7_scheme *sc, s7_pointer obj) const char *doc = s7_documentation(sc, obj); s7_pointer sig = c_function_signature(obj); s7_pointer let = internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, (is_t_procedure(obj)) ? sc->is_procedure_symbol : sc->is_macro_symbol, - sc->arity_symbol, s7_arity(sc, obj), - sc->is_mutable_symbol, make_boolean(sc, !is_immutable(obj))); + sc->type_symbol, (is_t_procedure(obj)) ? sc->is_procedure_symbol : sc->is_macro_symbol, + sc->arity_symbol, s7_arity(sc, obj), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable(obj))); gc_protect_via_stack(sc, let); if (is_pair(sig)) s7_varlet(sc, let, sc->local_signature_symbol, sig); @@ -51233,10 +51233,10 @@ static s7_pointer goto_to_let(s7_scheme *sc, s7_pointer obj) sc->active_symbol = make_symbol(sc, "active", 6); if (is_symbol(call_exit_name(obj))) return(internal_inlet(sc, 8, sc->value_symbol, obj, sc->type_symbol, sc->is_goto_symbol, - sc->active_symbol, make_boolean(sc, call_exit_active(obj)), - sc->name_symbol, call_exit_name(obj))); + sc->active_symbol, make_boolean(sc, call_exit_active(obj)), + sc->name_symbol, call_exit_name(obj))); return(internal_inlet(sc, 6, sc->value_symbol, obj, sc->type_symbol, sc->is_goto_symbol, - sc->active_symbol, make_boolean(sc, call_exit_active(obj)))); + sc->active_symbol, make_boolean(sc, call_exit_active(obj)))); } static s7_pointer object_to_let_p_p(s7_scheme *sc, s7_pointer obj) @@ -51265,24 +51265,24 @@ static s7_pointer object_to_let_p_p(s7_scheme *sc, s7_pointer obj) case T_STRING: return(internal_inlet(sc, 8, sc->value_symbol, obj, - sc->type_symbol, sc->is_string_symbol, - sc->size_symbol, str_length(sc, obj), - sc->is_mutable_symbol, make_boolean(sc, !is_immutable_string(obj)))); + sc->type_symbol, sc->is_string_symbol, + sc->size_symbol, str_length(sc, obj), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_string(obj)))); case T_PAIR: return(internal_inlet(sc, 6, sc->value_symbol, obj, - sc->type_symbol, sc->is_pair_symbol, - sc->size_symbol, pair_length(sc, obj))); + sc->type_symbol, sc->is_pair_symbol, + sc->size_symbol, pair_length(sc, obj))); case T_SYNTAX: return(internal_inlet(sc, 6, sc->value_symbol, obj, - sc->type_symbol, sc->is_syntax_symbol, - sc->documentation_symbol, s7_make_string(sc, syntax_documentation(obj)))); + sc->type_symbol, sc->is_syntax_symbol, + sc->documentation_symbol, s7_make_string(sc, syntax_documentation(obj)))); case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_VECTOR: return(vector_to_let(sc, obj)); case T_CONTINUATION: /* perhaps include the continuation-key */ if (is_symbol(continuation_name(obj))) - return(internal_inlet(sc, 6, sc->value_symbol, obj, sc->type_symbol, sc->is_continuation_symbol, sc->name_symbol, continuation_name(obj))); + return(internal_inlet(sc, 6, sc->value_symbol, obj, sc->type_symbol, sc->is_continuation_symbol, sc->name_symbol, continuation_name(obj))); return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_continuation_symbol)); case T_INPUT_PORT: case T_OUTPUT_PORT: @@ -51320,8 +51320,8 @@ static s7_pointer stacktrace_find_caller(s7_scheme *sc, s7_pointer e) static bool stacktrace_find_let(s7_scheme *sc, int64_t loc, s7_pointer e) { return((loc > 0) && - ((stack_let(sc->stack, loc) == e) || - (stacktrace_find_let(sc, loc - 4, e)))); + ((stack_let(sc->stack, loc) == e) || + (stacktrace_find_let(sc, loc - 4, e)))); } static int64_t stacktrace_find_error_hook_quit(s7_scheme *sc) @@ -51335,8 +51335,8 @@ static int64_t stacktrace_find_error_hook_quit(s7_scheme *sc) static bool stacktrace_in_error_handler(s7_scheme *sc, int64_t loc) { return((let_outlet(sc->owlet) == sc->curlet) || - (stacktrace_find_let(sc, loc * 4, let_outlet(sc->owlet))) || - (stacktrace_find_error_hook_quit(sc) > 0)); + (stacktrace_find_let(sc, loc * 4, let_outlet(sc->owlet))) || + (stacktrace_find_error_hook_quit(sc) > 0)); } static bool stacktrace_error_hook_function(s7_scheme *sc, s7_pointer sym) @@ -51345,98 +51345,98 @@ static bool stacktrace_error_hook_function(s7_scheme *sc, s7_pointer sym) { s7_pointer f = s7_symbol_value(sc, sym); return((is_procedure(f)) && - (hook_has_functions(sc->error_hook)) && - (direct_memq(f, s7_hook_functions(sc, sc->error_hook)))); + (hook_has_functions(sc->error_hook)) && + (direct_memq(f, s7_hook_functions(sc, sc->error_hook)))); } return(false); } static char *stacktrace_walker(s7_scheme *sc, s7_pointer code, s7_pointer e, char *notes, - s7_int code_cols, s7_int total_cols, s7_int notes_start_col, - bool as_comment, int32_t depth) + s7_int code_cols, s7_int total_cols, s7_int notes_start_col, + bool as_comment, int32_t depth) { if (is_symbol(code)) { if ((!symbol_is_in_list(sc, code)) && - (!is_slot(global_slot(code)))) - { - s7_pointer val; - add_symbol_to_list(sc, code); - val = s7_symbol_local_value(sc, code, e); - if ((val) && - (val != sc->undefined) && - (!is_any_macro(val))) - { - int32_t typ = type(val); - if (typ < T_CONTINUATION) - { - char *objstr, *str; - s7_pointer objp; - s7_int new_note_len, notes_max; - bool new_notes_line = false, old_short_print = sc->short_print; - s7_int old_len = sc->print_length, objlen; - - if (notes_start_col < 0) notes_start_col = 50; - if (notes_start_col > total_cols) notes_start_col = 0; - notes_max = total_cols - notes_start_col; - sc->short_print = true; - if (sc->print_length > 4) sc->print_length = 4; - objp = s7_object_to_string(sc, val, true); - objstr = string_value(objp); - objlen = string_length(objp); - if ((objlen > notes_max) && - (notes_max > 5)) - { - objstr[notes_max - 4] = '.'; - objstr[notes_max - 3] = '.'; - objstr[notes_max - 2] = '.'; - objstr[notes_max - 1] = '\0'; - objlen = notes_max; - } - sc->short_print = old_short_print; - sc->print_length = old_len; - - new_note_len = symbol_name_length(code) + 3 + objlen; - /* we want to append this much info to the notes, but does it need a new line? */ - if (notes_start_col < code_cols) - new_notes_line = true; - else - if (notes) - { - char *last_newline = strrchr(notes, (int)'\n'); /* returns ptr to end if none = nil if not found? */ - s7_int cur_line_len = (last_newline) ? (strlen(notes) - strlen(last_newline)) : strlen(notes); - new_notes_line = ((cur_line_len + new_note_len) > notes_max); - } - if (new_notes_line) - { - const char *spaces = " "; - s7_int spaces_len = 80; - new_note_len += (4 + notes_start_col + ((notes) ? strlen(notes) : 0)); - str = (char *)Malloc(new_note_len); /* str[0] = '\0'; */ - catstrs_direct(str, - (notes) ? notes : "", - "\n", - (as_comment) ? "; " : "", - (spaces_len >= notes_start_col) ? (const char *)(spaces + spaces_len - notes_start_col) : "", - (as_comment) ? "" : " ; ", - symbol_name(code), - ": ", - objstr, (const char *)NULL); - } - else - { - new_note_len += ((notes) ? strlen(notes) : 0) + 4; - str = (char *)Malloc(new_note_len); /* str[0] = '\0'; */ - catstrs_direct(str, - (notes) ? notes : "", - (notes) ? ", " : " ; ", - symbol_name(code), - ": ", - objstr, (const char *)NULL); - } - if (notes) free(notes); - return(str); - }}} + (!is_slot(global_slot(code)))) + { + s7_pointer val; + add_symbol_to_list(sc, code); + val = s7_symbol_local_value(sc, code, e); + if ((val) && + (val != sc->undefined) && + (!is_any_macro(val))) + { + int32_t typ = type(val); + if (typ < T_CONTINUATION) + { + char *objstr, *str; + s7_pointer objp; + s7_int new_note_len, notes_max; + bool new_notes_line = false, old_short_print = sc->short_print; + s7_int old_len = sc->print_length, objlen; + + if (notes_start_col < 0) notes_start_col = 50; + if (notes_start_col > total_cols) notes_start_col = 0; + notes_max = total_cols - notes_start_col; + sc->short_print = true; + if (sc->print_length > 4) sc->print_length = 4; + objp = s7_object_to_string(sc, val, true); + objstr = string_value(objp); + objlen = string_length(objp); + if ((objlen > notes_max) && + (notes_max > 5)) + { + objstr[notes_max - 4] = '.'; + objstr[notes_max - 3] = '.'; + objstr[notes_max - 2] = '.'; + objstr[notes_max - 1] = '\0'; + objlen = notes_max; + } + sc->short_print = old_short_print; + sc->print_length = old_len; + + new_note_len = symbol_name_length(code) + 3 + objlen; + /* we want to append this much info to the notes, but does it need a new line? */ + if (notes_start_col < code_cols) + new_notes_line = true; + else + if (notes) + { + char *last_newline = strrchr(notes, (int)'\n'); /* returns ptr to end if none = nil if not found? */ + s7_int cur_line_len = (last_newline) ? (strlen(notes) - strlen(last_newline)) : strlen(notes); + new_notes_line = ((cur_line_len + new_note_len) > notes_max); + } + if (new_notes_line) + { + const char *spaces = " "; + s7_int spaces_len = 80; + new_note_len += (4 + notes_start_col + ((notes) ? strlen(notes) : 0)); + str = (char *)Malloc(new_note_len); /* str[0] = '\0'; */ + catstrs_direct(str, + (notes) ? notes : "", + "\n", + (as_comment) ? "; " : "", + (spaces_len >= notes_start_col) ? (const char *)(spaces + spaces_len - notes_start_col) : "", + (as_comment) ? "" : " ; ", + symbol_name(code), + ": ", + objstr, (const char *)NULL); + } + else + { + new_note_len += ((notes) ? strlen(notes) : 0) + 4; + str = (char *)Malloc(new_note_len); /* str[0] = '\0'; */ + catstrs_direct(str, + (notes) ? notes : "", + (notes) ? ", " : " ; ", + symbol_name(code), + ": ", + objstr, (const char *)NULL); + } + if (notes) free(notes); + return(str); + }}} return(notes); } if ((is_pair(code)) && @@ -51470,10 +51470,10 @@ static block_t *stacktrace_add_func(s7_scheme *sc, s7_pointer f, s7_pointer code if ((errlen > 2) && (errstr[2] == '(')) errlen = catstrs_direct(newstr, " ", errstr, (const char *)NULL); else - { - memcpy((void *)newstr, (const void *)errstr, errlen); - newstr[errlen] = '\0'; - }} + { + memcpy((void *)newstr, (const void *)errstr, errlen); + newstr[errlen] = '\0'; + }} newlen = code_max + 8 + ((notes) ? strlen(notes) : 0); b = mallocate(sc, newlen); str = (char *)block_data(b); /* str[0] = '\0'; */ @@ -51491,12 +51491,12 @@ static block_t *stacktrace_add_func(s7_scheme *sc, s7_pointer f, s7_pointer code /* send out newstr, pad with spaces to code_max, then notes */ s7_int len = catstrs_direct(str, (as_comment) ? "; " : "", newstr, (const char *)NULL); if (notes) - { - s7_int i; - for (i = len; i < code_max - 1; i++) str[i] = ' '; - str[i] = '\0'; - catstrs(str, newlen, notes, "\n", (char *)NULL); - } + { + s7_int i; + for (i = len; i < code_max - 1; i++) str[i] = ' '; + str[i] = '\0'; + catstrs(str, newlen, notes, "\n", (char *)NULL); + } else catstrs(str, newlen, "\n", (char *)NULL); } liberate(sc, newp); @@ -51515,20 +51515,20 @@ static s7_pointer stacktrace_1(s7_scheme *sc, s7_int frames_max, s7_int code_col { s7_pointer err_code = slot_value(sc->error_code); if ((is_pair(err_code)) && - (!tree_is_cyclic(sc, err_code))) - { - char *notes = NULL; - s7_pointer current_let = let_outlet(sc->owlet); - s7_pointer errstr = s7_object_to_string(sc, err_code, false); - s7_pointer f = stacktrace_find_caller(sc, current_let); /* this is a symbol */ - if ((is_let(current_let)) && - (current_let != sc->rootlet)) - notes = stacktrace_walker(sc, err_code, current_let, NULL, code_cols, total_cols, notes_start_col, as_comment, 0); - strp = stacktrace_add_func(sc, f, err_code, string_value(errstr), notes, code_cols, as_comment); - str = (char *)block_data(strp); - if ((S7_DEBUGGING) && (notes == str)) fprintf(stderr, "%s[%d]: notes==str\n", __func__, __LINE__); - if (notes) free(notes); /* copied into strp, 29-Sep-23 -- see below: maybe check that notes!=str? */ - } + (!tree_is_cyclic(sc, err_code))) + { + char *notes = NULL; + s7_pointer current_let = let_outlet(sc->owlet); + s7_pointer errstr = s7_object_to_string(sc, err_code, false); + s7_pointer f = stacktrace_find_caller(sc, current_let); /* this is a symbol */ + if ((is_let(current_let)) && + (current_let != sc->rootlet)) + notes = stacktrace_walker(sc, err_code, current_let, NULL, code_cols, total_cols, notes_start_col, as_comment, 0); + strp = stacktrace_add_func(sc, f, err_code, string_value(errstr), notes, code_cols, as_comment); + str = (char *)block_data(strp); + if ((S7_DEBUGGING) && (notes == str)) fprintf(stderr, "%s[%d]: notes==str\n", __func__, __LINE__); + if (notes) free(notes); /* copied into strp, 29-Sep-23 -- see below: maybe check that notes!=str? */ + } loc = stacktrace_find_error_hook_quit(sc); /* if OP_ERROR_HOOK_QUIT is in the stack, jump past it! */ if (loc > 0) top = (loc + 1) / 4; } @@ -51537,57 +51537,57 @@ static s7_pointer stacktrace_1(s7_scheme *sc, s7_int frames_max, s7_int code_col s7_int true_loc = (loc + 1) * 4 - 1; s7_pointer code = stack_code(sc->stack, true_loc); if ((is_pair(code)) && - (!tree_is_cyclic(sc, code))) - { - s7_pointer codep = s7_object_to_string(sc, code, false); - if (string_length(codep) > 0) - { - char *codestr = string_value(codep); - if ((!local_strcmp(codestr, "(result)")) && - (!local_strcmp(codestr, "(#f)")) && - (!strstr(codestr, "(stacktrace)")) && - (!strstr(codestr, "(stacktrace "))) - { - s7_pointer e = stack_let(sc->stack, true_loc); /* might not be let (gc stack protection etc) */ - s7_pointer f = stacktrace_find_caller(sc, e); - if (!stacktrace_error_hook_function(sc, f)) - { - char *notes = NULL, *newstr, *catstr; - block_t *newp, *catp; - s7_int newlen; - - frames++; - if (frames > frames_max) - return(block_to_string(sc, strp, safe_strlen((char *)block_data(strp)))); - - if ((is_let(e)) && (e != sc->rootlet)) - notes = stacktrace_walker(sc, code, e, NULL, code_cols, total_cols, notes_start_col, as_comment, 0); - newp = stacktrace_add_func(sc, f, code, codestr, notes, code_cols, as_comment); - newstr = (char *)block_data(newp); - if ((S7_DEBUGGING) && (notes == newstr)) fprintf(stderr, "%s[%d]: notes=newstr\n", __func__, __LINE__); - if ((notes) && (notes != newstr) && (is_let(e)) && (e != sc->rootlet)) - free(notes); - - newlen = strlen(newstr) + 1 + ((str) ? strlen(str) : 0); - catp = mallocate(sc, newlen); - catstr = (char *)block_data(catp); - catstrs_direct(catstr, (str) ? str : "", newstr, (const char *)NULL); - liberate(sc, newp); - if (strp) liberate(sc, strp); - strp = catp; - str = (char *)block_data(strp); - }}}}} + (!tree_is_cyclic(sc, code))) + { + s7_pointer codep = s7_object_to_string(sc, code, false); + if (string_length(codep) > 0) + { + char *codestr = string_value(codep); + if ((!local_strcmp(codestr, "(result)")) && + (!local_strcmp(codestr, "(#f)")) && + (!strstr(codestr, "(stacktrace)")) && + (!strstr(codestr, "(stacktrace "))) + { + s7_pointer e = stack_let(sc->stack, true_loc); /* might not be let (gc stack protection etc) */ + s7_pointer f = stacktrace_find_caller(sc, e); + if (!stacktrace_error_hook_function(sc, f)) + { + char *notes = NULL, *newstr, *catstr; + block_t *newp, *catp; + s7_int newlen; + + frames++; + if (frames > frames_max) + return(block_to_string(sc, strp, safe_strlen((char *)block_data(strp)))); + + if ((is_let(e)) && (e != sc->rootlet)) + notes = stacktrace_walker(sc, code, e, NULL, code_cols, total_cols, notes_start_col, as_comment, 0); + newp = stacktrace_add_func(sc, f, code, codestr, notes, code_cols, as_comment); + newstr = (char *)block_data(newp); + if ((S7_DEBUGGING) && (notes == newstr)) fprintf(stderr, "%s[%d]: notes=newstr\n", __func__, __LINE__); + if ((notes) && (notes != newstr) && (is_let(e)) && (e != sc->rootlet)) + free(notes); + + newlen = strlen(newstr) + 1 + ((str) ? strlen(str) : 0); + catp = mallocate(sc, newlen); + catstr = (char *)block_data(catp); + catstrs_direct(catstr, (str) ? str : "", newstr, (const char *)NULL); + liberate(sc, newp); + if (strp) liberate(sc, strp); + strp = catp; + str = (char *)block_data(strp); + }}}}} return((strp) ? block_to_string(sc, strp, safe_strlen((char *)block_data(strp))) : nil_string); } s7_pointer s7_stacktrace(s7_scheme *sc) { return(stacktrace_1(sc, - s7_integer_clamped_if_gmp(sc, car(sc->stacktrace_defaults)), - s7_integer_clamped_if_gmp(sc, cadr(sc->stacktrace_defaults)), - s7_integer_clamped_if_gmp(sc, caddr(sc->stacktrace_defaults)), - s7_integer_clamped_if_gmp(sc, cadddr(sc->stacktrace_defaults)), - s7_boolean(sc, s7_list_ref(sc, sc->stacktrace_defaults, 4)))); + s7_integer_clamped_if_gmp(sc, car(sc->stacktrace_defaults)), + s7_integer_clamped_if_gmp(sc, cadr(sc->stacktrace_defaults)), + s7_integer_clamped_if_gmp(sc, caddr(sc->stacktrace_defaults)), + s7_integer_clamped_if_gmp(sc, cadddr(sc->stacktrace_defaults)), + s7_boolean(sc, s7_list_ref(sc, sc->stacktrace_defaults, 4)))); } static s7_pointer g_stacktrace(s7_scheme *sc, s7_pointer args) @@ -51607,41 +51607,41 @@ line to be preceded by a semicolon." if (!is_null(args)) { if (!s7_is_integer(car(args))) - return(method_or_bust(sc, car(args), sc->stacktrace_symbol, args, sc->type_names[T_INTEGER], 1)); + return(method_or_bust(sc, car(args), sc->stacktrace_symbol, args, sc->type_names[T_INTEGER], 1)); max_frames = s7_integer_clamped_if_gmp(sc, car(args)); if ((max_frames <= 0) || (max_frames > S7_INT32_MAX)) - max_frames = 30; + max_frames = 30; args = cdr(args); if (!is_null(args)) - { - if (!s7_is_integer(car(args))) - wrong_type_error_nr(sc, sc->stacktrace_symbol, 2, car(args), sc->type_names[T_INTEGER]); - code_cols = s7_integer_clamped_if_gmp(sc, car(args)); - if ((code_cols <= 8) || (code_cols > 1024)) - code_cols = 50; - args = cdr(args); - if (!is_null(args)) - { - if (!s7_is_integer(car(args))) - wrong_type_error_nr(sc, sc->stacktrace_symbol, 3, car(args), sc->type_names[T_INTEGER]); - total_cols = s7_integer_clamped_if_gmp(sc, car(args)); - if ((total_cols <= code_cols) || (total_cols > S7_INT32_MAX)) - total_cols = 80; - args = cdr(args); - if (!is_null(args)) - { - if (!s7_is_integer(car(args))) - wrong_type_error_nr(sc, sc->stacktrace_symbol, 4, car(args), sc->type_names[T_INTEGER]); - notes_start_col = s7_integer_clamped_if_gmp(sc, car(args)); - if ((notes_start_col <= 0) || (notes_start_col > S7_INT32_MAX)) - notes_start_col = 50; - args = cdr(args); - if (!is_null(args)) - { - if (!is_boolean(car(args))) - wrong_type_error_nr(sc, sc->stacktrace_symbol, 5, car(args), sc->type_names[T_BOOLEAN]); - as_comment = s7_boolean(sc, car(args)); - }}}}} + { + if (!s7_is_integer(car(args))) + wrong_type_error_nr(sc, sc->stacktrace_symbol, 2, car(args), sc->type_names[T_INTEGER]); + code_cols = s7_integer_clamped_if_gmp(sc, car(args)); + if ((code_cols <= 8) || (code_cols > 1024)) + code_cols = 50; + args = cdr(args); + if (!is_null(args)) + { + if (!s7_is_integer(car(args))) + wrong_type_error_nr(sc, sc->stacktrace_symbol, 3, car(args), sc->type_names[T_INTEGER]); + total_cols = s7_integer_clamped_if_gmp(sc, car(args)); + if ((total_cols <= code_cols) || (total_cols > S7_INT32_MAX)) + total_cols = 80; + args = cdr(args); + if (!is_null(args)) + { + if (!s7_is_integer(car(args))) + wrong_type_error_nr(sc, sc->stacktrace_symbol, 4, car(args), sc->type_names[T_INTEGER]); + notes_start_col = s7_integer_clamped_if_gmp(sc, car(args)); + if ((notes_start_col <= 0) || (notes_start_col > S7_INT32_MAX)) + notes_start_col = 50; + args = cdr(args); + if (!is_null(args)) + { + if (!is_boolean(car(args))) + wrong_type_error_nr(sc, sc->stacktrace_symbol, 5, car(args), sc->type_names[T_BOOLEAN]); + as_comment = s7_boolean(sc, car(args)); + }}}}} return(stacktrace_1(sc, max_frames, code_cols, total_cols, notes_start_col, as_comment)); } @@ -51683,8 +51683,8 @@ bool s7_set_history_enabled(s7_scheme *sc, bool enabled) else if (sc->cur_code != sc->history_sink) { - sc->old_cur_code = sc->cur_code; - sc->cur_code = sc->history_sink; + sc->old_cur_code = sc->cur_code; + sc->cur_code = sc->history_sink; } return(old_enabled); #else @@ -51775,66 +51775,66 @@ static s7_pointer g_profile_in(s7_scheme *sc, s7_pointer args) /* only external profile_data_t *pd = sc->profile_data; if (pos >= pd->size) - { - s7_int new_size = 2 * pos; - pd->funcs = (s7_pointer *)Realloc(pd->funcs, new_size * sizeof(s7_pointer)); - memclr((void *)(pd->funcs + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); - pd->timing_data = (s7_int *)Realloc(pd->timing_data, new_size * PD_BLOCK_SIZE * sizeof(s7_int)); + { + s7_int new_size = 2 * pos; + pd->funcs = (s7_pointer *)Realloc(pd->funcs, new_size * sizeof(s7_pointer)); + memclr((void *)(pd->funcs + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); + pd->timing_data = (s7_int *)Realloc(pd->timing_data, new_size * PD_BLOCK_SIZE * sizeof(s7_int)); memclr((void *)(pd->timing_data + (pd->size * PD_BLOCK_SIZE)), (new_size - pd->size) * PD_BLOCK_SIZE * sizeof(s7_int)); - pd->let_names = (s7_pointer *)Realloc(pd->let_names, new_size * sizeof(s7_pointer)); - memclr((void *)(pd->let_names + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); - pd->files = (s7_pointer *)Realloc(pd->files, new_size * sizeof(s7_pointer)); - memclr((void *)(pd->files + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); - pd->lines = (s7_int *)Realloc(pd->lines, new_size * sizeof(s7_int)); - memclr((void *)(pd->lines + pd->size), (new_size - pd->size) * sizeof(s7_int)); - pd->size = new_size; - } + pd->let_names = (s7_pointer *)Realloc(pd->let_names, new_size * sizeof(s7_pointer)); + memclr((void *)(pd->let_names + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); + pd->files = (s7_pointer *)Realloc(pd->files, new_size * sizeof(s7_pointer)); + memclr((void *)(pd->files + pd->size), (new_size - pd->size) * sizeof(s7_pointer)); + pd->lines = (s7_int *)Realloc(pd->lines, new_size * sizeof(s7_int)); + memclr((void *)(pd->lines + pd->size), (new_size - pd->size) * sizeof(s7_int)); + pd->size = new_size; + } if (pd->funcs[pos] == NULL) - { - pd->funcs[pos] = func_name; - if (is_gensym(func_name)) sc->profiling_gensyms = true; - if (pos >= pd->top) pd->top = (pos + 1); - - /* perhaps add_profile needs to reuse ints if file/line exists? */ - if (is_symbol(sc->profile_prefix)) - { - s7_pointer let_name = s7_symbol_local_value(sc, sc->profile_prefix, e); - if (is_symbol(let_name)) pd->let_names[pos] = let_name; - } - if (has_let_file(e)) - { - pd->files[pos] = sc->file_names[let_file(e)]; - pd->lines[pos] = let_line(e); - }} + { + pd->funcs[pos] = func_name; + if (is_gensym(func_name)) sc->profiling_gensyms = true; + if (pos >= pd->top) pd->top = (pos + 1); + + /* perhaps add_profile needs to reuse ints if file/line exists? */ + if (is_symbol(sc->profile_prefix)) + { + s7_pointer let_name = s7_symbol_local_value(sc, sc->profile_prefix, e); + if (is_symbol(let_name)) pd->let_names[pos] = let_name; + } + if (has_let_file(e)) + { + pd->files[pos] = sc->file_names[let_file(e)]; + pd->lines[pos] = let_line(e); + }} v = (s7_int *)(sc->profile_data->timing_data + (pos * PD_BLOCK_SIZE)); v[PD_CALLS]++; if (v[PD_RECUR] == 0) - { - v[PD_START] = my_clock(); - pd->excl_top++; - if (pd->excl_top == pd->excl_size) - { - pd->excl_size *= 2; - pd->excl = (s7_int *)Realloc(pd->excl, pd->excl_size * sizeof(s7_int)); - } - pd->excl[pd->excl_top] = 0; - } + { + v[PD_START] = my_clock(); + pd->excl_top++; + if (pd->excl_top == pd->excl_size) + { + pd->excl_size *= 2; + pd->excl = (s7_int *)Realloc(pd->excl, pd->excl_size * sizeof(s7_int)); + } + pd->excl[pd->excl_top] = 0; + } v[PD_RECUR]++; /* this doesn't work in "continuation passing" code (e.g. cpstak.scm in the so-called standard benchmarks). * swap_stack pushes dynamic_unwind, but we don't pop back to it, so the stack grows to the recursion depth. */ if (sc->stack_end >= sc->stack_resize_trigger) - { - #define PROFILE_MAX_STACK_SIZE 10000000 /* around 5G counting lets/arglists/slots, maybe an *s7* field for this? */ - if (sc->stack_size > PROFILE_MAX_STACK_SIZE) - error_nr(sc, make_symbol(sc, "stack-too-big", 13), - set_elist_2(sc, wrap_string(sc, "profiling stack size has grown past ~D", 38), wrap_integer(sc, PROFILE_MAX_STACK_SIZE))); - /* rather than raise an error, we could unwind the stack here, popping off all unwind entries, but this is - * a very rare problem, and the results will be confusing anyway. - */ - resize_stack(sc); - } + { + #define PROFILE_MAX_STACK_SIZE 10000000 /* around 5G counting lets/arglists/slots, maybe an *s7* field for this? */ + if (sc->stack_size > PROFILE_MAX_STACK_SIZE) + error_nr(sc, make_symbol(sc, "stack-too-big", 13), + set_elist_2(sc, wrap_string(sc, "profiling stack size has grown past ~D", 38), wrap_integer(sc, PROFILE_MAX_STACK_SIZE))); + /* rather than raise an error, we could unwind the stack here, popping off all unwind entries, but this is + * a very rare problem, and the results will be confusing anyway. + */ + resize_stack(sc); + } swap_stack(sc, OP_DYNAMIC_UNWIND_PROFILE, sc->profile_out, car(args)); } return(sc->F); @@ -51860,13 +51860,13 @@ static s7_pointer profile_info_out(s7_scheme *sc) for (i = 0; i < pd->top; i++) { if (pd->funcs[i]) - { - vector_element(vs, i) = pd->funcs[i]; - if ((is_matched_symbol(pd->funcs[i])) && /* find ambiguous names */ - (!direct_memq(pd->funcs[i], car(matches)))) - set_car(matches, cons(sc, pd->funcs[i], car(matches))); - set_match_symbol(pd->funcs[i]); - } + { + vector_element(vs, i) = pd->funcs[i]; + if ((is_matched_symbol(pd->funcs[i])) && /* find ambiguous names */ + (!direct_memq(pd->funcs[i], car(matches)))) + set_car(matches, cons(sc, pd->funcs[i], car(matches))); + set_match_symbol(pd->funcs[i]); + } else vector_element(vs, i) = sc->F; vector_element(vn, i) = (!pd->let_names[i]) ? sc->F : pd->let_names[i]; vector_element(vf, i) = (!pd->files[i]) ? sc->F : pd->files[i]; @@ -51890,7 +51890,7 @@ static s7_pointer clear_profile_info(s7_scheme *sc) memclr(pd->lines, pd->top * sizeof(s7_int)); pd->top = 0; for (int32_t i = 0; i < pd->excl_top; i++) - pd->excl[i] = 0; + pd->excl[i] = 0; pd->excl_top = 0; sc->profiling_gensyms = false; } @@ -51962,21 +51962,21 @@ static s7_pointer g_catch(s7_scheme *sc, s7_pointer args) if (!is_pair(cdr(args))) /* (let ((mlet (openlet (inlet 'abs catch)))) (abs mlet)) -- this is a special case, avoid calling this everywhere */ error_nr(sc, sc->syntax_error_symbol, - set_elist_2(sc, wrap_string(sc, "catch: function missing: ~S", 27), set_ulist_1(sc, sc->catch_symbol, args))); + set_elist_2(sc, wrap_string(sc, "catch: function missing: ~S", 27), set_ulist_1(sc, sc->catch_symbol, args))); proc = cadr(args); if (!is_thunk(sc, proc)) { if (is_any_procedure(proc)) /* i.e. c_function, lambda, macro, etc */ - { - s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but catch's second argument should be a thunk", 72), proc, req_args, req_args)); - } + { + s7_pointer req_args = wrap_integer(sc, procedure_required_args(sc, proc)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A requires ~D argument~P, but catch's second argument should be a thunk", 72), proc, req_args, req_args)); + } else wrong_type_error_nr(sc, sc->catch_symbol, 2, proc, a_thunk_string); } if (!is_pair(cddr(args))) error_nr(sc, sc->syntax_error_symbol, - set_elist_2(sc, wrap_string(sc, "catch: error handler missing: ~S", 32), set_ulist_1(sc, sc->catch_symbol, args))); + set_elist_2(sc, wrap_string(sc, "catch: error handler missing: ~S", 32), set_ulist_1(sc, sc->catch_symbol, args))); err = caddr(args); if (!is_applicable(err)) wrong_type_error_nr(sc, sc->catch_symbol, 3, err, something_applicable_string); @@ -51999,7 +51999,7 @@ static s7_pointer g_catch(s7_scheme *sc, s7_pointer args) */ sc->code = closure_body(proc); if (is_symbol(closure_args(proc))) - set_curlet(sc, make_let_with_slot(sc, closure_let(proc), closure_args(proc), sc->nil)); + set_curlet(sc, make_let_with_slot(sc, closure_let(proc), closure_args(proc), sc->nil)); else set_curlet(sc, inline_make_let(sc, closure_let(proc))); push_stack_no_args_direct(sc, sc->begin_op); } @@ -52030,22 +52030,22 @@ s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7 if (SHOW_EVAL_OPS) fprintf(stderr, "jump_loc: %s\n", jump_string[(int)jump_loc]); if (jump_loc == NO_JUMP) { - catch_cstack(p) = &new_goto_start; - if (SHOW_EVAL_OPS) fprintf(stderr, " longjmp call %s\n", display_truncated(body)); - push_stack(sc, OP_CATCH, error_handler, p); - result = s7_call(sc, body, sc->nil); - if (stack_top_op(sc) == OP_CATCH) sc->stack_end -= 4; + catch_cstack(p) = &new_goto_start; + if (SHOW_EVAL_OPS) fprintf(stderr, " longjmp call %s\n", display_truncated(body)); + push_stack(sc, OP_CATCH, error_handler, p); + result = s7_call(sc, body, sc->nil); + if (stack_top_op(sc) == OP_CATCH) sc->stack_end -= 4; } else { - if (SHOW_EVAL_OPS) fprintf(stderr, " jump back with %s (%d)\n", jump_string[(int)jump_loc], (sc->stack_end == sc->stack_start)); - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); - if ((jump_loc == CATCH_JUMP) && /* we're returning from an error in catch */ - ((sc->stack_end == sc->stack_start) || - (((sc->stack_end - 4) == sc->stack_start) && (stack_top_op(sc) == OP_GC_PROTECT)))) /* s7_apply_function probably */ - push_stack_op(sc, OP_ERROR_QUIT); - result = sc->value; + if (SHOW_EVAL_OPS) fprintf(stderr, " jump back with %s (%d)\n", jump_string[(int)jump_loc], (sc->stack_end == sc->stack_start)); + if (jump_loc != ERROR_JUMP) + eval(sc, sc->cur_op); + if ((jump_loc == CATCH_JUMP) && /* we're returning from an error in catch */ + ((sc->stack_end == sc->stack_start) || + (((sc->stack_end - 4) == sc->stack_start) && (stack_top_op(sc) == OP_GC_PROTECT)))) /* s7_apply_function probably */ + push_stack_op(sc, OP_ERROR_QUIT); + result = sc->value; } restore_jump_info(sc); } @@ -52133,7 +52133,7 @@ static s7_pointer cull_history(s7_scheme *sc, s7_pointer code) for (s7_pointer p = code; is_pair(p); p = cdr(p)) { if ((is_pair(car(p))) && (!is_quote(car(p))) && (pair_set_memq(sc, car(p)))) - set_car(p, sc->nil); + set_car(p, sc->nil); if (cdr(p) == code) break; } return(code); @@ -52168,28 +52168,28 @@ It has the additional local variables: error-type, error-data, error-code, error for (s7_pointer x = let_slots(e); tis_slot(x); x = next_slot(x)) if (is_pair(slot_value(x))) { - s7_pointer new_list = copy_any_list(sc, slot_value(x)); - slot_set_value(x, new_list); - for (s7_pointer p = new_list, sp = p; is_pair(p); p = cdr(p), sp = cdr(sp)) - { - s7_pointer val = car(p); - if (is_t_real(val)) - set_car(p, make_real(sc, real(val))); - else - if (is_string(val)) - set_car(p, make_string_with_length(sc, string_value(val), string_length(val))); - else - if (is_t_integer(val)) - set_car(p, make_integer(sc, integer(val))); - p = cdr(p); - if ((!is_pair(p)) || (p == sp)) break; - val = car(p); - if (is_t_real(val)) - set_car(p, make_real(sc, real(val))); - else - if (is_string(val)) - set_car(p, make_string_with_length(sc, string_value(val), string_length(val))); - }} + s7_pointer new_list = copy_any_list(sc, slot_value(x)); + slot_set_value(x, new_list); + for (s7_pointer p = new_list, sp = p; is_pair(p); p = cdr(p), sp = cdr(sp)) + { + s7_pointer val = car(p); + if (is_t_real(val)) + set_car(p, make_real(sc, real(val))); + else + if (is_string(val)) + set_car(p, make_string_with_length(sc, string_value(val), string_length(val))); + else + if (is_t_integer(val)) + set_car(p, make_integer(sc, integer(val))); + p = cdr(p); + if ((!is_pair(p)) || (p == sp)) break; + val = car(p); + if (is_t_real(val)) + set_car(p, make_real(sc, real(val))); + else + if (is_string(val)) + set_car(p, make_string_with_length(sc, string_value(val), string_length(val))); + }} sc->gc_off = old_gc; unstack_gc_protect(sc); return(e); @@ -52230,7 +52230,7 @@ static bool catch_2_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s sc->code = catch_handler(x); load_catch_cstack(sc, x); if (needs_copied_args(sc->code)) - sc->args = list_2(sc, type, info); + sc->args = list_2(sc, type, info); else sc->args = with_list_t2(type, info); /* very unlikely: need c_macro as error catcher: (catch #t (lambda () (error 'oops)) require) */ sc->cur_op = OP_APPLY; return(true); @@ -52269,96 +52269,96 @@ static bool catch_1_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s /* if OP_CATCH_1, we deferred making the error handler until it is actually needed */ if (op == OP_CATCH_1) - { - error_body = cdr(error_func); - error_args = car(error_func); - } + { + error_body = cdr(error_func); + error_args = car(error_func); + } else - if (is_closure(error_func)) - { - error_body = closure_body(error_func); - error_args = closure_args(error_func); - } - else - { - error_body = NULL; - error_args = NULL; - } + if (is_closure(error_func)) + { + error_body = closure_body(error_func); + error_args = closure_args(error_func); + } + else + { + error_body = NULL; + error_args = NULL; + } if ((error_body) && (is_null(cdr(error_body)))) - { - s7_pointer y = NULL; - error_body = car(error_body); - if (is_pair(error_body)) - { - if (is_quote(car(error_body))) - y = cadr(error_body); - else - if ((car(error_body) == sc->car_symbol) && - (is_pair(cdr(error_body))) && /* catch: (lambda (type info) (car)) */ - (cadr(error_body) == error_args)) - y = type; - } - else - if (!is_symbol(error_body)) - y = error_body; /* not pair or symbol */ - else - if (error_body == error_args) - y = list_2(sc, type, info); - else - if (is_keyword(error_body)) - y = error_body; - else - if ((is_pair(error_args)) && - (error_body == car(error_args))) - y = type; - if (y) - { - if ((SHOW_EVAL_OPS) && (loc > 4)) {fprintf(stderr, " about to pop_stack: \n"); s7_show_stack(sc);} - if (loc > 4) - pop_stack(sc); - /* we're at OP_CATCH, normally we want to pop that away, but (handwaving...) if we're coming - * from s7_eval (indirectly perhaps through s7_eval_c_string), we might push the OP_EVAL_DONE - * to end that call, but it's pushed at the precatch stack end (far beyond the catch loc). - * If we catch an error, catch unwinds to its starting point, and the pop_stack above - * puts us at the bottom of the stack (i.e. stack_end == stack_start), OP_EVAL_DONE. - * Now we return true, ending up back in eval, because the error handler jumped out of eval, - * back to wherever we were in eval when we hit the error. eval jumps back to the start - * of its loop, and pops the stack to see what to do next! So the (loc > 4) at least - * protects against stack underflow, but ideally we'd know we came from OP_CATCH+s7_eval. - * We can't do anything fancy here because we have to unwind the C stack as well as s7's stack. - * s7_eval doesn't know anything about the catches on the stack. We can't look back for - * OP_EVAL_DONE -- segfault in OP_BEGIN. Hmmmm. Perhaps catch should not unwind until the - * end? But we want the error handler to run as a part of the calling expression, and - * in any case the OP_EVAL_DONE is not useful (it marks the end of the no-error case). - */ - sc->value = y; - sc->y = sc->unused; - sc->temp4 = sc->unused; - sc->w = sc->unused; - if (loc == 4) - sc->code = cons(sc, sc->value, sc->nil); /* if we end up at op_begin, give it something it can handle */ - return(true); - }} + { + s7_pointer y = NULL; + error_body = car(error_body); + if (is_pair(error_body)) + { + if (is_quote(car(error_body))) + y = cadr(error_body); + else + if ((car(error_body) == sc->car_symbol) && + (is_pair(cdr(error_body))) && /* catch: (lambda (type info) (car)) */ + (cadr(error_body) == error_args)) + y = type; + } + else + if (!is_symbol(error_body)) + y = error_body; /* not pair or symbol */ + else + if (error_body == error_args) + y = list_2(sc, type, info); + else + if (is_keyword(error_body)) + y = error_body; + else + if ((is_pair(error_args)) && + (error_body == car(error_args))) + y = type; + if (y) + { + if ((SHOW_EVAL_OPS) && (loc > 4)) {fprintf(stderr, " about to pop_stack: \n"); s7_show_stack(sc);} + if (loc > 4) + pop_stack(sc); + /* we're at OP_CATCH, normally we want to pop that away, but (handwaving...) if we're coming + * from s7_eval (indirectly perhaps through s7_eval_c_string), we might push the OP_EVAL_DONE + * to end that call, but it's pushed at the precatch stack end (far beyond the catch loc). + * If we catch an error, catch unwinds to its starting point, and the pop_stack above + * puts us at the bottom of the stack (i.e. stack_end == stack_start), OP_EVAL_DONE. + * Now we return true, ending up back in eval, because the error handler jumped out of eval, + * back to wherever we were in eval when we hit the error. eval jumps back to the start + * of its loop, and pops the stack to see what to do next! So the (loc > 4) at least + * protects against stack underflow, but ideally we'd know we came from OP_CATCH+s7_eval. + * We can't do anything fancy here because we have to unwind the C stack as well as s7's stack. + * s7_eval doesn't know anything about the catches on the stack. We can't look back for + * OP_EVAL_DONE -- segfault in OP_BEGIN. Hmmmm. Perhaps catch should not unwind until the + * end? But we want the error handler to run as a part of the calling expression, and + * in any case the OP_EVAL_DONE is not useful (it marks the end of the no-error case). + */ + sc->value = y; + sc->y = sc->unused; + sc->temp4 = sc->unused; + sc->w = sc->unused; + if (loc == 4) + sc->code = cons(sc, sc->value, sc->nil); /* if we end up at op_begin, give it something it can handle */ + return(true); + }} /* here type and info need to be GC protected (new_cell below), g_throw and error_nr, throw sc->w for type, but error_nr nothing currently */ if (op == OP_CATCH_1) - { - s7_pointer p; - new_cell(sc, p, T_CLOSURE); - closure_set_args(p, car(error_func)); - closure_set_body(p, cdr(error_func)); - closure_set_setter(p, sc->F); - closure_set_arity(p, CLOSURE_ARITY_NOT_SET); - closure_set_let(p, sc->temp4); - sc->code = p; - if ((S7_DEBUGGING) && (!s7_is_aritable(sc, sc->code, 2))) fprintf(stderr, "%s[%d]: errfunc not aritable(2)!\n", __func__, __LINE__); - } + { + s7_pointer p; + new_cell(sc, p, T_CLOSURE); + closure_set_args(p, car(error_func)); + closure_set_body(p, cdr(error_func)); + closure_set_setter(p, sc->F); + closure_set_arity(p, CLOSURE_ARITY_NOT_SET); + closure_set_let(p, sc->temp4); + sc->code = p; + if ((S7_DEBUGGING) && (!s7_is_aritable(sc, sc->code, 2))) fprintf(stderr, "%s[%d]: errfunc not aritable(2)!\n", __func__, __LINE__); + } else - { - sc->code = error_func; - sc->y = sc->unused; - if (!s7_is_aritable(sc, sc->code, 2)) /* op_catch_1 from op_c_catch already checks this */ - wrong_number_of_arguments_error_nr(sc, "catch error handler should accept two arguments: ~S", 51, sc->code); - } + { + sc->code = error_func; + sc->y = sc->unused; + if (!s7_is_aritable(sc, sc->code, 2)) /* op_catch_1 from op_c_catch already checks this */ + wrong_number_of_arguments_error_nr(sc, "catch error handler should accept two arguments: ~S", 51, sc->code); + } sc->temp4 = sc->unused; /* if user (i.e. yers truly!) copies/pastes the preceding lambda () into the * error handler portion of the catch, he gets the inexplicable message: @@ -52386,7 +52386,7 @@ static bool catch_dynamic_wind_function(s7_scheme *sc, s7_int catch_loc, s7_poin { 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) - sc->value = s7_call(sc, dynamic_wind_out(x), sc->nil); + sc->value = s7_call(sc, dynamic_wind_out(x), sc->nil); } return(false); } @@ -52432,7 +52432,7 @@ static bool catch_barrier_function(s7_scheme *sc, s7_int catch_loc, s7_pointer t if (is_input_port(stack_args(sc->stack, catch_loc))) { if (current_input_port(sc) == stack_args(sc->stack, catch_loc)) - pop_input_port(sc); + pop_input_port(sc); s7_close_input_port(sc, stack_args(sc->stack, catch_loc)); } return(false); @@ -52492,10 +52492,10 @@ static bool catch_let_temporarily_function(s7_scheme *sc, s7_int catch_loc, s7_p push_stack_direct(sc, OP_GC_PROTECT); if (!op_let_temp_done1(sc)) - { - push_stack_direct(sc, OP_EVAL_DONE); - eval(sc, OP_SET_UNCHECKED); - }} + { + push_stack_direct(sc, OP_EVAL_DONE); + eval(sc, OP_SET_UNCHECKED); + }} else let_temp_done(sc, stack_args(sc->stack, catch_loc), T_Let(stack_let(sc->stack, catch_loc))); return(false); } @@ -52538,7 +52538,7 @@ static bool catch_dynamic_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_po { s7_pointer spaces = lookup_slot_with_let(sc, make_symbol(sc, "*debug-spaces*", 14), T_Let(stack_let(sc->stack, catch_loc))); if (is_slot(spaces)) - slot_set_value(spaces, make_integer(sc, max_i_ii(0LL, integer(slot_value(spaces)) - 2))); /* should involve only small_ints */ + slot_set_value(spaces, make_integer(sc, max_i_ii(0LL, integer(slot_value(spaces)) - 2))); /* should involve only small_ints */ } return(false); } @@ -52586,15 +52586,15 @@ It looks for an existing catch with a matching tag, and jumps to it if found. O { catch_function_t catcher = catchers[stack_op(sc->stack, i)]; if ((catcher) && - (catcher(sc, i, type, info, &ignored_flag))) - { - if (sc->longjmp_ok) LongJmp(*(sc->goto_start), THROW_JUMP); - return(sc->value); - }} + (catcher(sc, i, type, info, &ignored_flag))) + { + if (sc->longjmp_ok) LongJmp(*(sc->goto_start), THROW_JUMP); + return(sc->value); + }} if (is_let(car(args))) check_method(sc, car(args), sc->throw_symbol, args); error_nr(sc, make_symbol(sc, "uncaught-throw", 14), - set_elist_3(sc, wrap_string(sc, "no catch found for (throw ~W~{~^ ~S~})", 38), type, info)); + set_elist_3(sc, wrap_string(sc, "no catch found for (throw ~W~{~^ ~S~})", 38), type, info)); return(sc->F); } @@ -52617,9 +52617,9 @@ static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...) /* len = m bytes = vsnprintf(str, len, ctrl, ap); va_end(ap); if (port_is_closed(current_error_port(sc))) - set_current_error_port(sc, sc->standard_error); + set_current_error_port(sc, sc->standard_error); if ((bytes > 0) && (current_error_port(sc) != sc->F)) - port_write_string(current_error_port(sc))(sc, str, bytes, current_error_port(sc)); + port_write_string(current_error_port(sc))(sc, str, bytes, current_error_port(sc)); liberate(sc, b); } } @@ -52683,40 +52683,40 @@ static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) { s7_int line = -1, file, position; if (has_location(cur_code)) - { - line = pair_line_number(cur_code); - file = pair_file_number(cur_code); - position = pair_position(cur_code); - } + { + line = pair_line_number(cur_code); + file = pair_file_number(cur_code); + position = pair_position(cur_code); + } else /* try to find a plausible line number! */ - for (s7_pointer p = cur_code, sp = cur_code; is_pair(p); p = cdr(p), sp = cdr(sp)) - { - if ((is_pair(car(p))) && /* what about p itself? */ - (has_location(car(p)))) - { - line = pair_line_number(car(p)); - file = pair_file_number(car(p)); - position = pair_position(car(p)); - break; - } - p = cdr(p); - if ((!is_pair(p)) || (p == sp)) break; - if ((is_pair(car(p))) && - (has_location(car(p)))) - { - line = pair_line_number(car(p)); - file = pair_file_number(car(p)); - position = pair_position(car(p)); - break; - }} + for (s7_pointer p = cur_code, sp = cur_code; is_pair(p); p = cdr(p), sp = cdr(sp)) + { + if ((is_pair(car(p))) && /* what about p itself? */ + (has_location(car(p)))) + { + line = pair_line_number(car(p)); + file = pair_file_number(car(p)); + position = pair_position(car(p)); + break; + } + p = cdr(p); + if ((!is_pair(p)) || (p == sp)) break; + if ((is_pair(car(p))) && + (has_location(car(p)))) + { + line = pair_line_number(car(p)); + file = pair_file_number(car(p)); + position = pair_position(car(p)); + break; + }} if ((line <= 0) || (file < 0)) - fill_error_location(sc); + fill_error_location(sc); else - { - set_integer(slot_value(sc->error_line), line); - set_integer(slot_value(sc->error_position), position); - slot_set_value(sc->error_file, sc->file_names[file]); - }} + { + set_integer(slot_value(sc->error_line), line); + set_integer(slot_value(sc->error_position), position); + slot_set_value(sc->error_file, sc->file_names[file]); + }} else fill_error_location(sc); /* look for a catcher, call catch*function in the error context (before unwinding the stack), outlet(owlet) is curlet */ @@ -52726,12 +52726,12 @@ static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) catch_function_t catcher = catchers[stack_op(sc->stack, i)]; if ((SHOW_EVAL_OPS) && (catcher)) {fprintf(stderr, "before catch:\n"); s7_show_stack(sc);} if ((catcher) && - (catcher(sc, i, type, info, &reset_error_hook))) - { - if (SHOW_EVAL_OPS) {fprintf(stderr, " after catch: \n"); s7_show_stack(sc);} - if ((S7_DEBUGGING) && (!sc->longjmp_ok)) fprintf(stderr, "s7_error jump not available?\n"); - LongJmp(*(sc->goto_start), CATCH_JUMP); - }} + (catcher(sc, i, type, info, &reset_error_hook))) + { + if (SHOW_EVAL_OPS) {fprintf(stderr, " after catch: \n"); s7_show_stack(sc);} + if ((S7_DEBUGGING) && (!sc->longjmp_ok)) fprintf(stderr, "s7_error jump not available?\n"); + LongJmp(*(sc->goto_start), CATCH_JUMP); + }} /* error not caught (but catcher might have been called and returned false) */ if ((!reset_error_hook) && @@ -52760,104 +52760,104 @@ static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) if (op < 32) sc->print_length = 32; if ((!is_output_port(current_error_port(sc))) || /* error-port can be #f */ - (port_is_closed(current_error_port(sc)))) - set_current_error_port(sc, sc->standard_error); + (port_is_closed(current_error_port(sc)))) + set_current_error_port(sc, sc->standard_error); /* if info is not a list, send object->string to current error port, * else assume car(info) is a format control string, and cdr(info) are its args * if at all possible, get some indication of where we are! */ if ((!is_pair(info)) || - (!is_string(car(info)))) - format_to_error_port(sc, "\n;~S ~S", set_plist_2(sc, type, info), 7); + (!is_string(car(info)))) + format_to_error_port(sc, "\n;~S ~S", set_plist_2(sc, type, info), 7); else - { - /* it's possible that the error string is just a string -- not intended for format */ - if ((type != sc->format_error_symbol) && /* avoid an infinite loop of format errors */ - (strchr(string_value(car(info)), '~'))) - { - s7_int len = string_length(car(info)) + 8; - block_t *b = mallocate(sc, len); - char *errstr = (char *)block_data(b); - s7_int str_len = catstrs_direct(errstr, "\n;", string_value(car(info)), (const char *)NULL); - format_to_error_port(sc, errstr, cdr(info), str_len); - liberate(sc, b); - } - else format_to_error_port(sc, "\n;~S ~S", set_plist_2(sc, type, info), 7); /* 7 = ctrl str len */ - } + { + /* it's possible that the error string is just a string -- not intended for format */ + if ((type != sc->format_error_symbol) && /* avoid an infinite loop of format errors */ + (strchr(string_value(car(info)), '~'))) + { + s7_int len = string_length(car(info)) + 8; + block_t *b = mallocate(sc, len); + char *errstr = (char *)block_data(b); + s7_int str_len = catstrs_direct(errstr, "\n;", string_value(car(info)), (const char *)NULL); + format_to_error_port(sc, errstr, cdr(info), str_len); + liberate(sc, b); + } + else format_to_error_port(sc, "\n;~S ~S", set_plist_2(sc, type, info), 7); /* 7 = ctrl str len */ + } if (op < 32) sc->print_length = op; /* now display location at end */ if (is_string(slot_value(sc->error_file))) - { - s7_newline(sc, current_error_port(sc)); - format_to_error_port(sc, "; ~A\n", set_plist_1(sc, object_to_string_truncated(sc, cur_code)), 8); - format_to_error_port(sc, "; ~A, line ~D, position: ~D\n", - set_plist_3(sc, slot_value(sc->error_file), slot_value(sc->error_line), slot_value(sc->error_position)), 31); - } + { + s7_newline(sc, current_error_port(sc)); + format_to_error_port(sc, "; ~A\n", set_plist_1(sc, object_to_string_truncated(sc, cur_code)), 8); + format_to_error_port(sc, "; ~A, line ~D, position: ~D\n", + set_plist_3(sc, slot_value(sc->error_file), slot_value(sc->error_line), slot_value(sc->error_position)), 31); + } else - { - if ((is_input_port(current_input_port(sc))) && - (port_file(current_input_port(sc)) != stdin) && - (!port_is_closed(current_input_port(sc)))) - { - const char *filename = port_filename(current_input_port(sc)); - int32_t line = port_line_number(current_input_port(sc)); - - if (filename) - format_to_error_port(sc, "\n; ~A[~D]", - set_plist_2(sc, wrap_string(sc, filename, port_filename_length(current_input_port(sc))), - wrap_integer(sc, line)), 10); - else - if ((line > 0) && - (integer(slot_value(sc->error_line)) > 0)) - format_to_error_port(sc, "\n; line ~D", set_plist_1(sc, wrap_integer(sc, line)), 11); - else - if (sc->input_port_stack_loc > 0) - { - s7_pointer p = sc->input_port_stack[sc->input_port_stack_loc - 1]; - if ((is_input_port(p)) && - (port_file(p) != stdin) && - (!port_is_closed(p))) - { - filename = port_filename(p); - line = port_line_number(p); - if (filename) - format_to_error_port(sc, "\n; ~A[~D]", - set_plist_2(sc, wrap_string(sc, filename, port_filename_length(current_input_port(sc))), - wrap_integer(sc, line)), 10); - }}} - else - { - const char *call_name = sc->s7_call_name; - if (call_name) - { - sc->s7_call_name = NULL; - if ((sc->s7_call_file) && - (sc->s7_call_line >= 0)) - format_to_error_port(sc, "\n; ~A ~A[~D]", - set_plist_3(sc, - s7_make_string_wrapper(sc, call_name), - s7_make_string_wrapper(sc, sc->s7_call_file), - wrap_integer(sc, sc->s7_call_line)), 13); - }} - s7_newline(sc, current_error_port(sc)); - } + { + if ((is_input_port(current_input_port(sc))) && + (port_file(current_input_port(sc)) != stdin) && + (!port_is_closed(current_input_port(sc)))) + { + const char *filename = port_filename(current_input_port(sc)); + int32_t line = port_line_number(current_input_port(sc)); + + if (filename) + format_to_error_port(sc, "\n; ~A[~D]", + set_plist_2(sc, wrap_string(sc, filename, port_filename_length(current_input_port(sc))), + wrap_integer(sc, line)), 10); + else + if ((line > 0) && + (integer(slot_value(sc->error_line)) > 0)) + format_to_error_port(sc, "\n; line ~D", set_plist_1(sc, wrap_integer(sc, line)), 11); + else + if (sc->input_port_stack_loc > 0) + { + s7_pointer p = sc->input_port_stack[sc->input_port_stack_loc - 1]; + if ((is_input_port(p)) && + (port_file(p) != stdin) && + (!port_is_closed(p))) + { + filename = port_filename(p); + line = port_line_number(p); + if (filename) + format_to_error_port(sc, "\n; ~A[~D]", + set_plist_2(sc, wrap_string(sc, filename, port_filename_length(current_input_port(sc))), + wrap_integer(sc, line)), 10); + }}} + else + { + const char *call_name = sc->s7_call_name; + if (call_name) + { + sc->s7_call_name = NULL; + if ((sc->s7_call_file) && + (sc->s7_call_line >= 0)) + format_to_error_port(sc, "\n; ~A ~A[~D]", + set_plist_3(sc, + s7_make_string_wrapper(sc, call_name), + s7_make_string_wrapper(sc, sc->s7_call_file), + wrap_integer(sc, sc->s7_call_line)), 13); + }} + s7_newline(sc, current_error_port(sc)); + } /* look for __func__ in the error environment etc */ if (current_error_port(sc) != sc->F) - { - s7_pointer errp = s7_stacktrace(sc); - if (string_length(errp) > 0) - { - port_write_string(current_error_port(sc))(sc, string_value(errp), string_length(errp), current_error_port(sc)); - port_write_character(current_error_port(sc))(sc, '\n', current_error_port(sc)); - }} + { + s7_pointer errp = s7_stacktrace(sc); + if (string_length(errp) > 0) + { + port_write_string(current_error_port(sc))(sc, string_value(errp), string_length(errp), current_error_port(sc)); + port_write_character(current_error_port(sc))(sc, '\n', current_error_port(sc)); + }} else - if (is_pair(slot_value(sc->error_code))) - { - format_to_error_port(sc, "; ~S", set_plist_1(sc, slot_value(sc->error_code)), 7); - s7_newline(sc, current_error_port(sc)); - } + if (is_pair(slot_value(sc->error_code))) + { + format_to_error_port(sc, "; ~S", set_plist_1(sc, slot_value(sc->error_code)), 7); + s7_newline(sc, current_error_port(sc)); + } /* if (is_continuation(type)) * go into repl here with access to continuation? Or expect *error-handler* to deal with it? */ @@ -52886,64 +52886,64 @@ static noreturn void read_error_1_nr(s7_scheme *sc, const char *errmsg, bool str { /* make an heroic effort to find where we slid off the tracks */ if (is_string_port(current_input_port(sc))) - { + { #define QUOTE_SIZE 40 - s7_int i, j, start = 0, end, slen, size; - char *recent_input = NULL; - - /* we can run off the end in cases like (eval-string "(. . ,.)") or (eval-string " (@ . ,.)") */ - if (port_position(pt) >= port_data_size(pt)) - port_position(pt) = port_data_size(pt) - 1; - - /* start at current position and look back a few chars */ - for (i = port_position(pt), j = 0; (i > 0) && (j < QUOTE_SIZE); i--, j++) - if ((port_data(pt)[i] == '\0') || (port_data(pt)[i] == '\n') || (port_data(pt)[i] == '\r')) - break; - start = i; - - /* start at current position and look ahead a few chars */ - size = port_data_size(pt); - for (i = port_position(pt), j = 0; (i < size) && (j < QUOTE_SIZE); i++, j++) - if ((port_data(pt)[i] == '\0') || (port_data(pt)[i] == '\n') || (port_data(pt)[i] == '\r')) - break; - end = i; - - slen = end - start; /* hopefully this is more or less the current line where the read error happened */ - if (slen > 0) - { - recent_input = (char *)Calloc(slen + 9, 1); - for (i = 0; i < (slen + 8); i++) recent_input[i] = '.'; - recent_input[3] = ' '; - recent_input[slen + 4] = ' '; - for (i = 0; i < slen; i++) recent_input[i + 4] = port_data(pt)[start + i]; - } - - if ((port_line_number(pt) > 0) && - (port_filename(pt))) - { - s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + port_filename_length(pt) + safe_strlen(sc->current_file) + 64; - s7_pointer p = make_empty_string(sc, len, '\0'); - char *msg = string_value(p); - string_length(p) = snprintf(msg, len, "%s: %s %s[%u], last top-level form at: %s[%" ld64 "]", - errmsg, (recent_input) ? recent_input : "", port_filename(pt), port_line_number(pt), - sc->current_file, sc->current_line); - if (recent_input) free(recent_input); - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - } - else - { - s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + safe_strlen(sc->current_file) + 64; - s7_pointer p = make_empty_string(sc, len, '\0'); - char *msg = string_value(p); - if ((sc->current_file) && - (sc->current_line >= 0)) - string_length(p) = snprintf(msg, len, "%s: %s, last top-level form at %s[%" ld64 "]", - errmsg, (recent_input) ? recent_input : "", - sc->current_file, sc->current_line); - else string_length(p) = snprintf(msg, len, "%s: %s", errmsg, (recent_input) ? recent_input : ""); - if (recent_input) free(recent_input); - error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); - }}} + s7_int i, j, start = 0, end, slen, size; + char *recent_input = NULL; + + /* we can run off the end in cases like (eval-string "(. . ,.)") or (eval-string " (@ . ,.)") */ + if (port_position(pt) >= port_data_size(pt)) + port_position(pt) = port_data_size(pt) - 1; + + /* start at current position and look back a few chars */ + for (i = port_position(pt), j = 0; (i > 0) && (j < QUOTE_SIZE); i--, j++) + if ((port_data(pt)[i] == '\0') || (port_data(pt)[i] == '\n') || (port_data(pt)[i] == '\r')) + break; + start = i; + + /* start at current position and look ahead a few chars */ + size = port_data_size(pt); + for (i = port_position(pt), j = 0; (i < size) && (j < QUOTE_SIZE); i++, j++) + if ((port_data(pt)[i] == '\0') || (port_data(pt)[i] == '\n') || (port_data(pt)[i] == '\r')) + break; + end = i; + + slen = end - start; /* hopefully this is more or less the current line where the read error happened */ + if (slen > 0) + { + recent_input = (char *)Calloc(slen + 9, 1); + for (i = 0; i < (slen + 8); i++) recent_input[i] = '.'; + recent_input[3] = ' '; + recent_input[slen + 4] = ' '; + for (i = 0; i < slen; i++) recent_input[i + 4] = port_data(pt)[start + i]; + } + + if ((port_line_number(pt) > 0) && + (port_filename(pt))) + { + s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + port_filename_length(pt) + safe_strlen(sc->current_file) + 64; + s7_pointer p = make_empty_string(sc, len, '\0'); + char *msg = string_value(p); + string_length(p) = snprintf(msg, len, "%s: %s %s[%u], last top-level form at: %s[%" ld64 "]", + errmsg, (recent_input) ? recent_input : "", port_filename(pt), port_line_number(pt), + sc->current_file, sc->current_line); + if (recent_input) free(recent_input); + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); + } + else + { + s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + safe_strlen(sc->current_file) + 64; + s7_pointer p = make_empty_string(sc, len, '\0'); + char *msg = string_value(p); + if ((sc->current_file) && + (sc->current_line >= 0)) + string_length(p) = snprintf(msg, len, "%s: %s, last top-level form at %s[%" ld64 "]", + errmsg, (recent_input) ? recent_input : "", + sc->current_file, sc->current_line); + else string_length(p) = snprintf(msg, len, "%s: %s", errmsg, (recent_input) ? recent_input : ""); + if (recent_input) free(recent_input); + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); + }}} if ((port_line_number(pt) > 0) && (port_filename(pt))) @@ -52953,17 +52953,17 @@ static noreturn void read_error_1_nr(s7_scheme *sc, const char *errmsg, bool str s7_pointer p = make_empty_string(sc, len, '\0'); char *msg = string_value(p); if (string_error) - nlen = snprintf(msg, len, "%s %s[%u],\n; possible culprit: \"%s...\"\n; last top-level form at %s[%" ld64 "]", - errmsg, port_filename(pt), port_line_number(pt), - sc->strbuf, sc->current_file, sc->current_line); + nlen = snprintf(msg, len, "%s %s[%u],\n; possible culprit: \"%s...\"\n; last top-level form at %s[%" ld64 "]", + errmsg, port_filename(pt), port_line_number(pt), + sc->strbuf, sc->current_file, sc->current_line); else nlen = snprintf(msg, len, "%s %s[%u], last top-level form at %s[%" ld64 "]", - errmsg, port_filename(pt), port_line_number(pt), - sc->current_file, sc->current_line); + errmsg, port_filename(pt), port_line_number(pt), + sc->current_file, sc->current_line); string_length(p) = nlen; error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); } error_nr(sc, (string_error) ? sc->string_read_error_symbol : sc->read_error_symbol, - set_elist_1(sc, s7_make_string_wrapper(sc, errmsg))); + set_elist_1(sc, s7_make_string_wrapper(sc, errmsg))); } static noreturn void read_error_nr(s7_scheme *sc, const char *errmsg) {read_error_1_nr(sc, errmsg, false);} @@ -52990,24 +52990,24 @@ static char *truncate_string(char *form, s7_int len, use_write_t use_write) { /* I guess we need to protect the outer double quotes in this case */ for (i = len - 5; i >= (len / 2); i--) - if (is_white_space((int32_t)f[i])) - return(form); + if (is_white_space((int32_t)f[i])) + return(form); i = len - 5; if (i > 0) {form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '"'; form[i + 4] = '\0';} else - if (len >= 2) - { - form[len - 1] = '"'; - form[len] = '\0'; - }} + if (len >= 2) + { + form[len - 1] = '"'; + form[len] = '\0'; + }} else { for (i = len - 4; i >= (len / 2); i--) - if (is_white_space((int32_t)f[i])) - { - form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '\0'; - return(form); - } + if (is_white_space((int32_t)f[i])) + { + form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '\0'; + return(form); + } i = len - 4; if (i >= 0) {form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '\0';} else form[len] = '\0'; @@ -53036,13 +53036,13 @@ static s7_pointer tree_descend(s7_scheme *sc, s7_pointer p, uint32_t line) { uint32_t x = (uint32_t)pair_line_number(p); if (x > 0) - { - if (line == 0) /* first line number we encounter will be the current reader location (i.e. the end of the form) */ - line = x; - else - if (x < line) - return(p); - }} + { + if (line == 0) /* first line number we encounter will be the current reader location (i.e. the end of the form) */ + line = x; + else + if (x < line) + return(p); + }} tp = tree_descend(sc, car(p), line); return((tp) ? tp : tree_descend(sc, cdr(p), line)); } @@ -53060,30 +53060,30 @@ static noreturn void missing_close_paren_error_nr(s7_scheme *sc) { s7_pointer result; if ((port_line_number(pt) > 0) && - (port_filename(pt))) - { - set_integer(slot_value(sc->error_line), port_line_number(pt)); - set_integer(slot_value(sc->error_position), port_position(pt)); - slot_set_value(sc->error_file, wrap_string(sc, port_filename(pt), port_filename_length(pt))); - } + (port_filename(pt))) + { + set_integer(slot_value(sc->error_line), port_line_number(pt)); + set_integer(slot_value(sc->error_position), port_position(pt)); + slot_set_value(sc->error_file, wrap_string(sc, port_filename(pt), port_filename_length(pt))); + } result = s7_call(sc, sc->missing_close_paren_hook, sc->nil); if (result != sc->unspecified) - g_throw(sc, list_1(sc, result)); + g_throw(sc, list_1(sc, result)); } if (is_pair(sc->args)) { s7_pointer p = tree_descend(sc, sc->args, 0); if ((p) && (is_pair(p)) && - (has_location(p))) - { - s7_pointer strp = object_to_string_truncated(sc, p); - char *form = string_value(strp); - s7_int form_len = string_length(strp); - s7_int msg_len = form_len + 128; - syntax_msg = (char *)Malloc(msg_len); - snprintf(syntax_msg, msg_len, "; current form awaiting a close paren starts around line %u: %s", (uint32_t)pair_line_number(p), form); - }} + (has_location(p))) + { + s7_pointer strp = object_to_string_truncated(sc, p); + char *form = string_value(strp); + s7_int form_len = string_length(strp); + s7_int msg_len = form_len + 128; + syntax_msg = (char *)Malloc(msg_len); + snprintf(syntax_msg, msg_len, "; current form awaiting a close paren starts around line %u: %s", (uint32_t)pair_line_number(p), form); + }} if ((port_line_number(pt) > 0) && (port_filename(pt))) @@ -53093,15 +53093,15 @@ static noreturn void missing_close_paren_error_nr(s7_scheme *sc) s7_pointer p = make_empty_string(sc, len, '\0'); char *msg = string_value(p); if (syntax_msg) - { - nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" ld64 "]\n%s", - port_filename(pt), port_line_number(pt), - sc->current_file, sc->current_line, syntax_msg); - free(syntax_msg); - } + { + nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" ld64 "]\n%s", + port_filename(pt), port_line_number(pt), + sc->current_file, sc->current_line, syntax_msg); + free(syntax_msg); + } else nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" ld64 "]", - port_filename(pt), port_line_number(pt), - sc->current_file, sc->current_line); + port_filename(pt), port_line_number(pt), + sc->current_file, sc->current_line); string_length(p) = nlen; error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p)); } @@ -53142,10 +53142,10 @@ static noreturn void improper_arglist_error_nr(s7_scheme *sc) s7_pointer func = pop_op_stack(sc); if (sc->args == sc->nil) /* (abs . 1) */ error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "attempt to evaluate (~S . ~S)?", 30), func, sc->code)); + set_elist_3(sc, wrap_string(sc, "attempt to evaluate (~S . ~S)?", 30), func, sc->code)); error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "attempt to evaluate (~S ~S . ~S)?", 33), - func, sc->args = proper_list_reverse_in_place(sc, sc->args), sc->code)); + set_elist_4(sc, wrap_string(sc, "attempt to evaluate (~S ~S . ~S)?", 33), + func, sc->args = proper_list_reverse_in_place(sc, sc->args), sc->code)); } static void op_error_hook_quit(s7_scheme *sc) @@ -53202,17 +53202,17 @@ static bool call_begin_hook(s7_scheme *sc) slot_set_value(sc->error_data, sc->value); /* was sc->F but we now clobber this below */ slot_set_value(sc->error_code, cur_code); if (has_location(cur_code)) - { - set_integer(slot_value(sc->error_line), (s7_int)pair_line_number(cur_code)); - slot_set_value(sc->error_file, sc->file_names[pair_file_number(cur_code)]); - set_integer(slot_value(sc->error_position), (s7_int)pair_position(cur_code)); - } + { + set_integer(slot_value(sc->error_line), (s7_int)pair_line_number(cur_code)); + slot_set_value(sc->error_file, sc->file_names[pair_file_number(cur_code)]); + set_integer(slot_value(sc->error_position), (s7_int)pair_position(cur_code)); + } else - { - set_integer(slot_value(sc->error_line), 0); - set_integer(slot_value(sc->error_position), 0); - slot_set_value(sc->error_file, sc->F); - } + { + set_integer(slot_value(sc->error_line), 0); + set_integer(slot_value(sc->error_position), 0); + slot_set_value(sc->error_file, sc->F); + } #if WITH_HISTORY slot_set_value(sc->error_history, sc->F); #endif @@ -53243,7 +53243,7 @@ static s7_pointer apply_list_star(s7_scheme *sc, s7_pointer d) d = cdr(d); set_cdr(p, cons(sc, car(d), cdr(d))); if (is_not_null(cdr(d))) - p = cdr(p); + p = cdr(p); } unstack_gc_protect(sc); set_cdr(p, cadr(p)); @@ -53253,7 +53253,7 @@ static s7_pointer apply_list_star(s7_scheme *sc, s7_pointer d) static noreturn void apply_list_error_nr(s7_scheme *sc, s7_pointer lst) { error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "apply's last argument should be a proper list: ~S", 49), lst)); + set_elist_2(sc, wrap_string(sc, "apply's last argument should be a proper list: ~S", 49), lst)); } static s7_pointer g_apply(s7_scheme *sc, s7_pointer args) @@ -53280,25 +53280,25 @@ static s7_pointer g_apply(s7_scheme *sc, s7_pointer args) /* the last arg is supposed to be a list, it will be spliced onto the end of the previous arg list (if any) below */ if (!s7_is_proper_list(sc, car(p))) /* (apply + #f) etc, the cycle protection here is checked in s7test */ - apply_list_error_nr(sc, args); + apply_list_error_nr(sc, args); set_cdr(q, car(p)); /* args affected, so don't depend on cdr(args) from above */ if (is_c_function(func)) /* handle in-place to get better error messages */ - { - s7_int len; - uint8_t typ = type(func); - if (typ == T_C_RST_NO_REQ_FUNCTION) - return(c_function_call(func)(sc, cdr(args))); - len = proper_list_length(cdr(args)); - if (c_function_max_args(func) < len) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, too_many_arguments_string, func, set_ulist_1(sc, sc->apply_symbol, args))); - if ((typ == T_C_FUNCTION) && - (len < c_function_min_args(func))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, not_enough_arguments_string, func, set_ulist_1(sc, sc->apply_symbol, args))); - return(c_function_call(func)(sc, cdr(args))); - } + { + s7_int len; + uint8_t typ = type(func); + if (typ == T_C_RST_NO_REQ_FUNCTION) + return(c_function_call(func)(sc, cdr(args))); + len = proper_list_length(cdr(args)); + if (c_function_max_args(func) < len) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, too_many_arguments_string, func, set_ulist_1(sc, sc->apply_symbol, args))); + if ((typ == T_C_FUNCTION) && + (len < c_function_min_args(func))) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, not_enough_arguments_string, func, set_ulist_1(sc, sc->apply_symbol, args))); + return(c_function_call(func)(sc, cdr(args))); + } push_stack(sc, OP_APPLY, cdr(args), func); return(sc->nil); } @@ -53351,8 +53351,8 @@ static s7_pointer implicit_index_checked(s7_scheme *sc, s7_pointer obj, s7_point { if (!is_applicable(in_obj)) error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), - set_ulist_1(sc, obj, indices), cons(sc, in_obj, cdr(indices)), in_obj)); + set_elist_4(sc, wrap_string(sc, "~$ becomes ~$, but ~S can't take arguments", 42), + set_ulist_1(sc, obj, indices), cons(sc, in_obj, cdr(indices)), in_obj)); return(implicit_index(sc, in_obj, cdr(indices))); } @@ -53389,27 +53389,27 @@ static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indic case T_STRING: /* (#("12" "34") 0 1) -> #\2 */ if (!is_null(cdr(indices))) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, obj, indices)); + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, obj, indices)); if (!is_t_integer(car(indices))) - wrong_type_error_nr(sc, sc->string_ref_symbol, 2, car(indices), sc->type_names[T_INTEGER]); + wrong_type_error_nr(sc, sc->string_ref_symbol, 2, car(indices), sc->type_names[T_INTEGER]); return(string_ref_p_pi_unchecked(sc, obj, integer(car(indices)))); case T_PAIR: /* (#((1 2) (3 4)) 1 0) -> 3, (#((1 (2 3))) 0 1 0) -> 2 */ in_obj = list_ref_1(sc, obj, car(indices)); if (is_pair(cdr(indices))) - return(implicit_index_checked(sc, obj, in_obj, indices)); + return(implicit_index_checked(sc, obj, in_obj, indices)); return(in_obj); case T_HASH_TABLE: /* ((vector (hash-table '(a . 1) '(b . 2))) 0 'a) -> 1 */ in_obj = s7_hash_table_ref(sc, obj, car(indices)); if (is_pair(cdr(indices))) - return(implicit_index_checked(sc, obj, in_obj, indices)); + return(implicit_index_checked(sc, obj, in_obj, indices)); return(in_obj); case T_LET: in_obj = let_ref(sc, obj, car(indices)); if (is_pair(cdr(indices))) - return(implicit_index_checked(sc, obj, in_obj, indices)); + return(implicit_index_checked(sc, obj, in_obj, indices)); return(in_obj); case T_C_OBJECT: @@ -53422,8 +53422,8 @@ static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indic case T_CLOSURE: case T_CLOSURE_STAR: if (!is_safe_closure(obj)) /* s7_call can't work in general with unsafe stuff */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "can't call a (possibly unsafe) function implicitly: ~S ~S", 57), obj, indices)); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "can't call a (possibly unsafe) function implicitly: ~S ~S", 57), obj, indices)); check_stack_size(sc); sc->temp10 = indices; /* (needs_copied_args(obj)) ? copy_proper_list(sc, indices) : indices; */ /* s7_call copies and this is safe? 2-Oct-22 (and below) */ sc->value = s7_call(sc, obj, sc->temp10); @@ -53440,12 +53440,12 @@ static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indic default: if (!is_applicable(obj)) /* (#2d((0 0)(0 0)) 0 0 0) */ - apply_error_nr(sc, obj, indices); + apply_error_nr(sc, obj, indices); sc->temp10 = indices; /* (needs_copied_args(obj)) ? copy_proper_list(sc, indices) : indices; */ /* do not use sc->args here! */ sc->value = s7_call(sc, obj, sc->temp10); sc->temp10 = sc->unused; if (is_multiple_value(sc->value)) - sc->value = splice_in_values(sc, multiple_value(sc->value)); + sc->value = splice_in_values(sc, multiple_value(sc->value)); return(sc->value); } } @@ -53459,10 +53459,10 @@ static inline void fill_star_defaults(s7_scheme *sc, s7_pointer func, int32_t st else for (int32_t i = start_arg; i < n_args; i++, par = cdr(par)) { - s7_pointer defval = df[i]; - if (is_symbol(defval)) - set_car(par, lookup_checked(sc, defval)); - else set_car(par, (is_pair(defval)) ? s7_eval(sc, defval, sc->rootlet) : defval); + s7_pointer defval = df[i]; + if (is_symbol(defval)) + set_car(par, lookup_checked(sc, defval)); + else set_car(par, (is_pair(defval)) ? s7_eval(sc, defval, sc->rootlet) : defval); } } @@ -53487,102 +53487,102 @@ static s7_pointer set_c_function_star_args(s7_scheme *sc) set_car(par, car(arg)); else { - s7_pointer kpar, karg; - int32_t ki; - /* oops -- there are keywords, change scanners (much duplicated code...) - * setting checked on the call_args here rather than parsing the parameters to use add_symbol_to_list - */ - for (kpar = call_args; kpar != par; kpar = cdr(kpar)) - set_checked(kpar); - for (; is_pair(kpar); kpar = cdr(kpar)) - clear_checked(kpar); - df = c_function_arg_names(func); /* changed to use symbols here, not keywords 2-Jan-24 */ - for (ki = i, karg = arg, kpar = par; (ki < n_args) && (is_pair(karg)); ki++, karg = cdr(karg)) - if (!is_symbol_and_keyword(car(karg))) - { - if (is_checked(kpar)) - { - if (!is_safe_procedure(func)) unstack_gc_protect(sc); - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, parameter_set_twice_string, car(kpar), sc->args)); - } - set_checked(kpar); - set_car(kpar, car(karg)); - kpar = cdr(kpar); - } - else - { - s7_pointer p; - for (j = 0, p = call_args; j < n_args; j++, p = cdr(p)) - if (df[j] == keyword_symbol(car(karg))) - break; - if (j == n_args) - { - if (!c_function_allows_other_keys(func)) - { - if (!is_safe_procedure(func)) unstack_gc_protect(sc); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "~A is not a parameter name?", 27), car(karg))); - } - karg = cdr(karg); - if (is_null(karg)) /* (f :x) where f arglist includes :allow-other-keys */ - { - if (!is_safe_procedure(func)) unstack_gc_protect(sc); - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: key ~S, but no value: ~S", 28), func, car(arg), sc->args)); - } - ki--; - } - else - { - if (is_checked(p)) - { - if (!is_safe_procedure(func)) unstack_gc_protect(sc); - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, parameter_set_twice_string, car(p), sc->args)); - } - if (!is_pair(cdr(karg))) - { - if (!is_safe_procedure(func)) unstack_gc_protect(sc); - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: key ~S, but no value: ~S", 28), func, car(karg), sc->args)); - } - set_checked(p); - karg = cdr(karg); - set_car(p, car(karg)); - kpar = cdr(kpar); - }} - if ((!is_null(karg)) && (!c_function_allows_other_keys(func))) - { - if (!is_safe_procedure(func)) unstack_gc_protect(sc); - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, sc->args)); - } - if (ki < n_args) - { - df = c_function_arg_defaults(func); - if (c_func_has_simple_defaults(func)) - { - for (ki = i, kpar = par; ki < n_args; ki++, kpar = cdr(kpar)) - if (!is_checked(kpar)) - set_car(kpar, df[ki]); - } - else - for (ki = i, kpar = par; ki < n_args; ki++, kpar = cdr(kpar)) - if (!is_checked(kpar)) - { - s7_pointer defval = df[ki]; - if (is_symbol(defval)) - set_car(kpar, lookup_checked(sc, defval)); - else set_car(kpar, (is_pair(defval)) ? s7_eval(sc, defval, sc->rootlet) : defval); - }} - if (!is_safe_procedure(func)) unstack_gc_protect(sc); - return(call_args); + s7_pointer kpar, karg; + int32_t ki; + /* oops -- there are keywords, change scanners (much duplicated code...) + * setting checked on the call_args here rather than parsing the parameters to use add_symbol_to_list + */ + for (kpar = call_args; kpar != par; kpar = cdr(kpar)) + set_checked(kpar); + for (; is_pair(kpar); kpar = cdr(kpar)) + clear_checked(kpar); + df = c_function_arg_names(func); /* changed to use symbols here, not keywords 2-Jan-24 */ + for (ki = i, karg = arg, kpar = par; (ki < n_args) && (is_pair(karg)); ki++, karg = cdr(karg)) + if (!is_symbol_and_keyword(car(karg))) + { + if (is_checked(kpar)) + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, parameter_set_twice_string, car(kpar), sc->args)); + } + set_checked(kpar); + set_car(kpar, car(karg)); + kpar = cdr(kpar); + } + else + { + s7_pointer p; + for (j = 0, p = call_args; j < n_args; j++, p = cdr(p)) + if (df[j] == keyword_symbol(car(karg))) + break; + if (j == n_args) + { + if (!c_function_allows_other_keys(func)) + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "~A is not a parameter name?", 27), car(karg))); + } + karg = cdr(karg); + if (is_null(karg)) /* (f :x) where f arglist includes :allow-other-keys */ + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A: key ~S, but no value: ~S", 28), func, car(arg), sc->args)); + } + ki--; + } + else + { + if (is_checked(p)) + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, parameter_set_twice_string, car(p), sc->args)); + } + if (!is_pair(cdr(karg))) + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A: key ~S, but no value: ~S", 28), func, car(karg), sc->args)); + } + set_checked(p); + karg = cdr(karg); + set_car(p, car(karg)); + kpar = cdr(kpar); + }} + if ((!is_null(karg)) && (!c_function_allows_other_keys(func))) + { + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, sc->args)); + } + if (ki < n_args) + { + df = c_function_arg_defaults(func); + if (c_func_has_simple_defaults(func)) + { + for (ki = i, kpar = par; ki < n_args; ki++, kpar = cdr(kpar)) + if (!is_checked(kpar)) + set_car(kpar, df[ki]); + } + else + for (ki = i, kpar = par; ki < n_args; ki++, kpar = cdr(kpar)) + if (!is_checked(kpar)) + { + s7_pointer defval = df[ki]; + if (is_symbol(defval)) + set_car(kpar, lookup_checked(sc, defval)); + else set_car(kpar, (is_pair(defval)) ? s7_eval(sc, defval, sc->rootlet) : defval); + }} + if (!is_safe_procedure(func)) unstack_gc_protect(sc); + return(call_args); } if (!is_null(arg)) { if (!is_safe_procedure(func)) unstack_gc_protect(sc); error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, sc->args)); + set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, sc->args)); } if (i < n_args) fill_star_defaults(sc, func, i, n_args, par); @@ -53645,16 +53645,16 @@ s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e) if (sc->safety > NO_SAFETY) { if (!s7_is_valid(sc, code)) - s7_warn(sc, 256, "the second argument to %s (the code to be evaluated): %p, is not an s7 object\n", __func__, code); + s7_warn(sc, 256, "the second argument to %s (the code to be evaluated): %p, is not an s7 object\n", __func__, code); if (!s7_is_valid(sc, e)) - s7_warn(sc, 256, "the third argument to %s (the environment): %p, is not an s7 object\n", __func__, e); + s7_warn(sc, 256, "the third argument to %s (the environment): %p, is not an s7 object\n", __func__, e); } store_jump_info(sc); set_jump_info(sc, EVAL_SET_JUMP); if (jump_loc != NO_JUMP) { if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); + eval(sc, sc->cur_op); } else { @@ -53706,7 +53706,7 @@ pass (rootlet):\n\ { s7_pointer e = cadr(args); if (!is_let(e)) - wrong_type_error_nr(sc, sc->eval_symbol, 2, e, a_let_string); + wrong_type_error_nr(sc, sc->eval_symbol, 2, e, a_let_string); set_curlet(sc, e); } sc->code = car(args); @@ -53746,21 +53746,21 @@ s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args) set_jump_info(sc, S7_CALL_SET_JUMP); if (jump_loc != NO_JUMP) { - if (jump_loc != ERROR_JUMP) - eval(sc, sc->cur_op); + if (jump_loc != ERROR_JUMP) + eval(sc, sc->cur_op); - if ((jump_loc == CATCH_JUMP) && /* we're returning (back to eval) from an error in catch */ - (sc->stack_end == sc->stack_start)) - push_stack_op(sc, OP_ERROR_QUIT); + if ((jump_loc == CATCH_JUMP) && /* we're returning (back to eval) from an error in catch */ + (sc->stack_end == sc->stack_start)) + push_stack_op(sc, OP_ERROR_QUIT); } else { - if (sc->safety > NO_SAFETY) - check_list_validity(sc, __func__, args); - push_stack_direct(sc, OP_EVAL_DONE); /* this saves the current evaluation and will eventually finish this (possibly) nested call */ - sc->code = func; - sc->args = (needs_copied_args(func)) ? copy_proper_list(sc, args) : args; - eval(sc, OP_APPLY); + if (sc->safety > NO_SAFETY) + check_list_validity(sc, __func__, args); + push_stack_direct(sc, OP_EVAL_DONE); /* this saves the current evaluation and will eventually finish this (possibly) nested call */ + sc->code = func; + sc->args = (needs_copied_args(func)) ? copy_proper_list(sc, args) : args; + eval(sc, OP_APPLY); } restore_jump_info(sc); /* don't clear temp4 or temp2 here -- lots of (Snd) code calls s7_call repeatedly and assumes the "func" arg is protected between calls */ @@ -53793,8 +53793,8 @@ s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args static inline bool gen_type_match(s7_scheme *sc, s7_pointer val, uint8_t typ) /* opt3_byte = uint8_t */ { return((type(val) == typ) || - ((has_active_methods(sc, val)) && - (apply_boolean_method(sc, val, sc->type_to_typers[typ]) != sc->F))); + ((has_active_methods(sc, val)) && + (apply_boolean_method(sc, val, sc->type_to_typers[typ]) != sc->F))); } #else #define gen_type_match(Sc, Val, Typ) \ @@ -53912,13 +53912,13 @@ static s7_pointer g_exit(s7_scheme *sc, s7_pointer args) for (int64_t i = stack_top(sc) - 1; i > 0; i -= 4) if (stack_op(sc->stack, i) == OP_DYNAMIC_WIND) { - s7_pointer dwind = T_Dyn(stack_code(sc->stack, i)); - if (dynamic_wind_state(dwind) == DWIND_BODY) /* otherwise init func never ran? */ - { - dynamic_wind_state(dwind) = DWIND_FINISH; - if (dynamic_wind_out(dwind) != sc->F) - s7_call(sc, dynamic_wind_out(dwind), sc->nil); - }} + s7_pointer dwind = T_Dyn(stack_code(sc->stack, i)); + if (dynamic_wind_state(dwind) == DWIND_BODY) /* otherwise init func never ran? */ + { + dynamic_wind_state(dwind) = DWIND_FINISH; + if (dynamic_wind_out(dwind) != sc->F) + s7_call(sc, dynamic_wind_out(dwind), sc->nil); + }} s7_quit(sc); if (show_gc_stats(sc)) @@ -53949,7 +53949,7 @@ static void check_t_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer if (let_slots(e) != s7_slot(sc, var)) { fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, func, display(expr), display(var), display(sc->curlet), - (tis_slot(let_slots(e))) ? display(let_slots(e)) : "no slots", unbold_text); + (tis_slot(let_slots(e))) ? display(let_slots(e)) : "no slots", unbold_text); if (sc->stop_at_error) abort(); } } @@ -53971,7 +53971,7 @@ static void check_u_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer if (next_slot(let_slots(e)) != s7_slot(sc, var)) { fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, func, display(expr), display(var), display(e), - (tis_slot(next_slot(let_slots(e)))) ? display(next_slot(let_slots(e))) : "no next slot", unbold_text); + (tis_slot(next_slot(let_slots(e)))) ? display(next_slot(let_slots(e))) : "no next slot", unbold_text); if (sc->stop_at_error) abort(); } } @@ -53993,7 +53993,7 @@ static void check_v_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer if (next_slot(next_slot(let_slots(e))) != s7_slot(sc, var)) { fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, func, display(expr), display(var), display(e), - (tis_slot(next_slot(next_slot(let_slots(e))))) ? display(next_slot(next_slot(let_slots(e)))) : "no next slot", unbold_text); + (tis_slot(next_slot(next_slot(let_slots(e))))) ? display(next_slot(next_slot(let_slots(e)))) : "no next slot", unbold_text); if (sc->stop_at_error) abort(); } } @@ -54016,7 +54016,7 @@ static void check_o_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer if (lookup_slot_with_let(sc, var, e) != slot) { fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, func, display(expr), display(var), display(e), - (tis_slot(slot)) ? display(slot) : "undefined", unbold_text); + (tis_slot(slot)) ? display(slot) : "undefined", unbold_text); if (sc->stop_at_error) abort(); } } @@ -54091,7 +54091,7 @@ static s7_pointer fx_c_v_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_ #define fx_car_any(Name, Lookup) \ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ + { \ s7_pointer val = Lookup(sc, cadr(arg), arg); \ return((is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \ } @@ -54107,8 +54107,8 @@ fx_car_any(fx_car_U, U_lookup) #define fx_cdr_any(Name, Lookup) \ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer val = Lookup(sc, cadr(arg), arg); \ + { \ + s7_pointer val = Lookup(sc, cadr(arg), arg); \ return((is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val))); \ } @@ -54256,11 +54256,11 @@ static s7_pointer fx_add_ft(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, if ((!WITH_GMP) && (is_t_integer(x))) \ { \ if (HAVE_OVERFLOW_CHECKS) \ - { \ - s7_int val; \ - if (!add_overflow(integer(x), integer(opt2_con(cdr(arg))), &val)) \ - return(make_integer(sc, val)); \ - } \ + { \ + s7_int val; \ + if (!add_overflow(integer(x), integer(opt2_con(cdr(arg))), &val)) \ + return(make_integer(sc, val)); \ + } \ else return(make_integer(sc, integer(x) + integer(opt2_con(cdr(arg))))); \ } \ return(add_p_pp(sc, x, opt2_con(cdr(arg)))); /* caddr(arg) */ \ @@ -54300,11 +54300,11 @@ fx_subtract_s1_any(fx_subtract_U1, U_lookup) if ((!WITH_GMP) && (is_t_integer(x))) \ { \ if (HAVE_OVERFLOW_CHECKS) \ - { \ - s7_int val; \ - if (!subtract_overflow(integer(x), integer(opt2_con(cdr(arg))), &val)) \ - return(make_integer(sc, val)); \ - } \ + { \ + s7_int val; \ + if (!subtract_overflow(integer(x), integer(opt2_con(cdr(arg))), &val)) \ + return(make_integer(sc, val)); \ + } \ else return(make_integer(sc, integer(x) - integer(opt2_con(cdr(arg))))); \ } \ return(subtract_p_pp(sc, x, opt2_con(cdr(arg)))); /* caddr(arg) */ \ @@ -54584,14 +54584,14 @@ static s7_pointer fx_num_eq_length_i(s7_scheme *sc, s7_pointer arg) case T_ITERATOR: { - s7_pointer len = s7_length(sc, iterator_sequence(val)); - return(make_boolean(sc, (is_t_integer(len)) && (integer(len) == ilen))); + s7_pointer len = s7_length(sc, iterator_sequence(val)); + return(make_boolean(sc, (is_t_integer(len)) && (integer(len) == ilen))); } case T_CLOSURE: case T_CLOSURE_STAR: if (has_active_methods(sc, val)) - return(make_boolean(sc, closure_length(sc, val) == ilen)); + return(make_boolean(sc, closure_length(sc, val) == ilen)); /* fall through */ default: @@ -54620,14 +54620,14 @@ static s7_pointer fx_less_length_i(s7_scheme *sc, s7_pointer arg) case T_ITERATOR: { - s7_pointer len = s7_length(sc, iterator_sequence(val)); - return(make_boolean(sc, (is_t_integer(len)) && (integer(len) < ilen))); + s7_pointer len = s7_length(sc, iterator_sequence(val)); + return(make_boolean(sc, (is_t_integer(len)) && (integer(len) < ilen))); } case T_CLOSURE: case T_CLOSURE_STAR: if (has_active_methods(sc, val)) - return(make_boolean(sc, closure_length(sc, val) < ilen)); + return(make_boolean(sc, closure_length(sc, val) < ilen)); /* fall through */ default: @@ -54821,21 +54821,21 @@ static inline s7_pointer fx_sqr_1(s7_scheme *sc, s7_pointer x) #if HAVE_OVERFLOW_CHECKS case T_INTEGER: { - s7_int val; - if (multiply_overflow(integer(x), integer(x), &val)) - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer sqr overflow: (* %" ld64 " %" ld64 ")\n", integer(x), integer(x)); - return(make_real(sc, (long_double)integer(x) * (long_double)integer(x))); - } - return(make_integer(sc, val)); + s7_int val; + if (multiply_overflow(integer(x), integer(x), &val)) + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer sqr overflow: (* %" ld64 " %" ld64 ")\n", integer(x), integer(x)); + return(make_real(sc, (long_double)integer(x) * (long_double)integer(x))); + } + return(make_integer(sc, val)); } case T_RATIO: { - s7_int num, den; - if ((multiply_overflow(numerator(x), numerator(x), &num)) || - (multiply_overflow(denominator(x), denominator(x), &den))) - return(make_real(sc, fraction(x) * fraction(x))); - return(make_ratio_with_div_check(sc, sc->multiply_symbol, num, den)); + s7_int num, den; + if ((multiply_overflow(numerator(x), numerator(x), &num)) || + (multiply_overflow(denominator(x), denominator(x), &den))) + return(make_real(sc, fraction(x) * fraction(x))); + return(make_ratio_with_div_check(sc, sc->multiply_symbol, num, den)); } #else case T_INTEGER: return(make_integer(sc, integer(x) * integer(x))); @@ -55018,7 +55018,7 @@ static s7_pointer fx_geq_t0(s7_scheme *sc, s7_pointer arg) static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ { \ s7_pointer x = Lookup1(sc, cadr(arg), arg); \ - s7_pointer y = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ + s7_pointer y = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ return(make_boolean(sc, ((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) == integer(y)) : num_eq_b_7pp(sc, x, y))); \ } @@ -55039,7 +55039,7 @@ fx_num_eq_ss_any(fx_num_eq_vU, v_lookup, U_lookup) #define fx_is_eq_ss_any(Name, Lookup1, Lookup2) \ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ { \ - s7_pointer x = Lookup1(sc, cadr(arg), arg); \ + s7_pointer x = Lookup1(sc, cadr(arg), arg); \ s7_pointer y = Lookup2(sc, opt2_sym(cdr(arg)), arg); \ return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y))))); \ } @@ -55092,7 +55092,7 @@ static inline s7_pointer fx_hash_table_increment_1(s7_scheme *sc, s7_pointer tab if (val != sc->unentry) { if (!is_t_integer(hash_entry_value(val))) - sole_arg_wrong_type_error_nr(sc, sc->add_symbol, cadddr(arg), sc->type_names[T_INTEGER]); + sole_arg_wrong_type_error_nr(sc, sc->add_symbol, cadddr(arg), sc->type_names[T_INTEGER]); hash_entry_set_value(val, make_integer(sc, integer(hash_entry_value(val)) + 1)); return(hash_entry_value(val)); } @@ -55112,7 +55112,7 @@ static s7_pointer fx_simple_let_ref_s(s7_scheme *sc, s7_pointer arg) s7_pointer lt = s_lookup(sc, opt2_sym(arg), arg); /* (var-ref local-var) -> local-var, opt_sym2(arg) == cadr(arg) */ if (!is_pair(lt)) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~S should be (cons name let), but it is ~S", 42), opt2_sym(arg), lt)); + set_elist_3(sc, wrap_string(sc, "~S should be (cons name let), but it is ~S", 42), opt2_sym(arg), lt)); lt = cdr(lt); if (!is_let(lt)) wrong_type_error_nr(sc, sc->let_ref_symbol, 1, lt, a_let_string); sym = opt2_sym(cdr(arg)); /* (let-ref (cdr v) 'ref) -> ref == opt3_sym(cdar(closure_body(opt1_lambda(arg)))); */ @@ -55298,8 +55298,8 @@ static s7_pointer fx_is_type_car_s(s7_scheme *sc, s7_pointer arg) { s7_pointer val = lookup(sc, opt3_sym(arg)); return(make_boolean(sc, (is_pair(val)) ? - ((uint8_t)(opt3_byte(cdr(arg))) == type(car(val))) : - ((uint8_t)(opt3_byte(cdr(arg))) == type(g_car(sc, set_plist_1(sc, val)))))); + ((uint8_t)(opt3_byte(cdr(arg))) == type(car(val))) : + ((uint8_t)(opt3_byte(cdr(arg))) == type(g_car(sc, set_plist_1(sc, val)))))); } static s7_pointer fx_is_type_car_t(s7_scheme *sc, s7_pointer arg) @@ -55482,8 +55482,8 @@ static s7_pointer fx_c_opssq_s_direct(s7_scheme *sc, s7_pointer arg) { s7_pointer 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)))); + ((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_add_mul_opssq_s(s7_scheme *sc, s7_pointer arg) @@ -55497,11 +55497,11 @@ static s7_pointer fx_add_mul_opssq_s(s7_scheme *sc, s7_pointer arg) { s7_int val; if ((multiply_overflow(integer(a), integer(b), &val)) || - (add_overflow(val, integer(c), &val))) - { - if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply/add overflow: (+ (* %" ld64 " %" ld64 ") %" ld64 ")\n", integer(a), integer(b), integer(c)); - return(make_real(sc, ((long_double)integer(a) * (long_double)integer(b)) + (long_double)integer(c))); - } + (add_overflow(val, integer(c), &val))) + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply/add overflow: (+ (* %" ld64 " %" ld64 ") %" ld64 ")\n", integer(a), integer(b), integer(c)); + return(make_real(sc, ((long_double)integer(a) * (long_double)integer(b)) + (long_double)integer(c))); + } return(make_integer(sc, val)); } #else @@ -55631,11 +55631,11 @@ static inline s7_pointer fx_vref_vref_3(s7_scheme *sc, s7_pointer v1, s7_pointer { s7_int i1 = integer(p1), i2 = integer(p2); if ((i1 >= 0) && (i2 >= 0) && (i1 < vector_length(v1))) - { - s7_pointer v2 = vector_element(v1, i1); - if ((is_t_vector(v2)) && (vector_rank(v2) == 1) && (i2 < vector_length(v2))) - return(vector_element(v2, i2)); - }} + { + s7_pointer v2 = vector_element(v1, i1); + if ((is_t_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, p1), p2)); } @@ -55710,8 +55710,8 @@ fx_c_opsq_s_any(fx_c_opuq_t, u_lookup, t_lookup) static s7_pointer Name(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, Lookup1(sc, opt1_sym(cdr(arg)), arg)), \ - Lookup2(sc, opt3_sym(arg), arg))); \ + ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, opt1_sym(cdr(arg)), arg)), \ + Lookup2(sc, opt3_sym(arg), arg))); \ } fx_c_opsq_s_direct_any(fx_c_opsq_s_direct, s_lookup, s_lookup) @@ -55804,7 +55804,7 @@ static s7_pointer fx_c_s_opssq(s7_scheme *sc, s7_pointer arg) s7_pointer largs = opt3_pair(arg); /* cdaddr(arg) */ \ arg = cdr(arg); \ return(((s7_p_pp_t)opt2_direct(arg))(sc, Lookup1(sc, car(arg), arg), \ - ((s7_p_pp_t)opt3_direct(arg))(sc, lookup(sc, car(largs)), Lookup2(sc, opt2_sym(largs), largs)))); \ + ((s7_p_pp_t)opt3_direct(arg))(sc, lookup(sc, car(largs)), Lookup2(sc, opt2_sym(largs), largs)))); \ } fx_c_s_opssq_direct_any(fx_c_s_opssq_direct, s_lookup, s_lookup) @@ -55814,13 +55814,13 @@ fx_c_s_opssq_direct_any(fx_c_t_opsuq_direct, t_lookup, u_lookup) static s7_pointer fx_vref_g_vref_gs(s7_scheme *sc, s7_pointer arg) { return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), - vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); + vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))))); } static s7_pointer fx_vref_g_vref_gt(s7_scheme *sc, s7_pointer arg) { return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), - vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), t_lookup(sc, opt2_sym(opt3_pair(arg)), arg)))); + vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), t_lookup(sc, opt2_sym(opt3_pair(arg)), arg)))); } static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer arg) @@ -55834,7 +55834,7 @@ static s7_pointer fx_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)))))); + ((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_nc_opssq_direct(s7_scheme *sc, s7_pointer arg) /* clm2xen (* 1.0 (oscil g2 x2)) */ @@ -55851,15 +55851,15 @@ static s7_pointer fx_multiply_c_opssq(s7_scheme *sc, s7_pointer arg) /* (* c=flo return(multiply_p_pp(sc, cadr(arg), multiply_p_pp(sc, x1, x2))); } -#define fx_c_s_opscq_any(Name, Lookup1, Lookup2) \ - static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ - { \ - s7_pointer largs = caddr(arg); \ - set_car(sc->t2_1, Lookup2(sc, cadr(largs), arg)); \ - set_car(sc->t2_2, opt2_con(cdr(largs))); \ - set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1)); \ - set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \ - return(fn_proc(arg)(sc, sc->t2_1)); \ +#define fx_c_s_opscq_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer largs = caddr(arg); \ + set_car(sc->t2_1, Lookup2(sc, cadr(largs), arg)); \ + set_car(sc->t2_2, opt2_con(cdr(largs))); \ + set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1)); \ + set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \ + return(fn_proc(arg)(sc, sc->t2_1)); \ } fx_c_s_opscq_any(fx_c_s_opscq, s_lookup, s_lookup) @@ -55874,19 +55874,19 @@ static s7_pointer fx_c_s_opscq_direct(s7_scheme *sc, s7_pointer 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)))))); + ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), integer(opt1_con(cdr(arg)))))); } static s7_pointer fx_c_u_optiq_direct(s7_scheme *sc, s7_pointer arg) { return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, u_lookup(sc, cadr(arg), arg), - ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt3_sym(arg), arg), integer(opt1_con(cdr(arg)))))); + ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt3_sym(arg), arg), integer(opt1_con(cdr(arg)))))); } static s7_pointer fx_c_t_opoiq_direct(s7_scheme *sc, s7_pointer arg) { return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), - ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, o_lookup(sc, opt3_sym(arg), arg), integer(opt1_con(cdr(arg)))))); + ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, o_lookup(sc, opt3_sym(arg), arg), integer(opt1_con(cdr(arg)))))); } static s7_pointer fx_vref_p1(s7_scheme *sc, s7_pointer arg) @@ -55897,7 +55897,7 @@ static s7_pointer fx_vref_p1(s7_scheme *sc, s7_pointer arg) { s7_int index = integer(i) + 1; if ((index >= 0) && (vector_length(v) > index)) - return(vector_element(v, index)); + return(vector_element(v, index)); } return(vector_ref_p_pp(sc, v, g_add_xi(sc, i, 1, 2))); } @@ -55924,7 +55924,7 @@ static s7_pointer fx_num_eq_subtract_s_si(s7_scheme *sc, s7_pointer arg) static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ { \ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), \ - ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup(sc, opt3_sym(arg), arg), opt1_con(cdr(arg))))); \ + ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup(sc, opt3_sym(arg), arg), opt1_con(cdr(arg))))); \ } fx_c_t_opscq_direct_any(fx_c_t_opscq_direct, s_lookup) @@ -56052,7 +56052,7 @@ static s7_pointer fx_c_opsq_opsq(s7_scheme *sc, s7_pointer arg) static s7_pointer fx_c_opsq_opsq_direct(s7_scheme *sc, s7_pointer arg) { return(((s7_p_pp_t)opt3_direct(arg))(sc, - ((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadadr(arg))), /* no free field in arg or cdr(arg) */ + ((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadadr(arg))), /* no free field in arg or cdr(arg) */ ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt1_sym(cdr(arg)))))); /* cadaddr(arg) */ } @@ -56080,7 +56080,7 @@ static s7_pointer fx_cdr_s_cdr_s(s7_scheme *sc, s7_pointer arg) s7_pointer p1 = lookup(sc, opt1_sym(cdr(arg))); s7_pointer p2 = lookup(sc, opt2_sym(cdr(arg))); /* cadaddr(arg) */ return(((s7_p_pp_t)opt3_direct(arg))(sc, (is_pair(p1)) ? cdr(p1) : g_cdr(sc, set_plist_1(sc, p1)), - (is_pair(p2)) ? cdr(p2) : g_cdr(sc, set_plist_1(sc, p2)))); + (is_pair(p2)) ? cdr(p2) : g_cdr(sc, set_plist_1(sc, p2)))); } static s7_pointer fx_is_eq_car_car_tu(s7_scheme *sc, s7_pointer arg) @@ -56109,7 +56109,7 @@ static s7_pointer fx_c_opsq_optuq_direct(s7_scheme *sc, s7_pointer arg) { s7_pointer 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)opt2_direct(largs))(sc, lookup(sc, cadar(largs))), ((s7_p_pp_t)opt3_direct(largs))(sc, t_lookup(sc, opt2_sym(cdr(largs)), arg), u_lookup(sc, opt1_sym(largs), arg)))); } @@ -56221,7 +56221,7 @@ static s7_pointer fx_sub_vref2(s7_scheme *sc, s7_pointer arg) { s7_int 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_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))); } @@ -56656,7 +56656,7 @@ static s7_pointer fx_c_op_opssqq_s_direct(s7_scheme *sc, s7_pointer code) return(((s7_p_pp_t)opt3_direct(code))(sc, ((s7_p_p_t)opt2_direct(cdr(code)))(sc, ((s7_p_pp_t)opt3_direct(cdr(code)))(sc, lookup(sc, cadr(arg)), lookup(sc, caddr(arg)))), - lookup(sc, caddr(code)))); + lookup(sc, caddr(code)))); } static s7_pointer fx_c_ns(s7_scheme *sc, s7_pointer arg) @@ -56715,16 +56715,16 @@ static s7_pointer fx_inlet_ca(s7_scheme *sc, s7_pointer code) s7_pointer symbol = car(x), value; symbol = (is_symbol_and_keyword(symbol)) ? keyword_symbol(symbol) : cadr(symbol); /* (inlet ':allow-other-keys 3) */ if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */ - { - unstack_gc_protect(sc); - wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); - } + { + unstack_gc_protect(sc); + wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string); + } value = fx_call(sc, cdr(x)); /* it's necessary to do this first, before add_slot_unchecked */ if (!sp) - { - add_slot_unchecked_no_local(sc, new_e, symbol, value); - sp = let_slots(new_e); - } + { + add_slot_unchecked_no_local(sc, new_e, symbol, value); + sp = let_slots(new_e); + } else sp = add_slot_at_end_no_local(sc, sp, symbol, value); } id = ++sc->let_number; @@ -56836,18 +56836,18 @@ static s7_pointer fx_and_or_2a_vref(s7_scheme *sc, s7_pointer arg) s7_pointer ip = lookup(sc, opt3_sym(or1)); s7_pointer jp = lookup(sc, opt1_sym(or1)); if ((is_t_integer(ip)) && (is_t_integer(jp))) - { - s7_int 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)))) - { - s7_pointer xp = lookup(sc, cadr(arg11)); - if (is_t_real(xp)) - { - s7_double 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)))); - }}}} + { + s7_int 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)))) + { + s7_pointer xp = lookup(sc, cadr(arg11)); + if (is_t_real(xp)) + { + s7_double 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_2a(sc, arg)); } @@ -57156,9 +57156,9 @@ static inline s7_pointer fx_cond_na_na(s7_scheme *sc, s7_pointer code) /* all t for (s7_pointer p = cdr(code); is_pair(p); p = cdr(p)) if (is_true(sc, fx_call(sc, car(p)))) { - for (p = cdar(p); is_pair(cdr(p)); p = cdr(p)) - fx_call(sc, p); - return(fx_call(sc, p)); + for (p = cdar(p); is_pair(cdr(p)); p = cdr(p)) + fx_call(sc, p); + return(fx_call(sc, p)); } return(sc->unspecified); } @@ -57215,729 +57215,729 @@ static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer cur_en if (!is_pair(arg)) { if (is_symbol(arg)) - { - if (is_keyword(arg)) return(fx_c); - if (arg == sc->else_symbol) - { - if (is_let(cur_env)) {if (s7_symbol_local_value(sc, arg, cur_env) == sc->else_symbol) return(fx_c);} - else if ((is_pair(cur_env)) && (!direct_memq(arg, cur_env))) return(fx_c); - } - return((is_global(arg)) ? fx_g : ((checker(sc, arg, cur_env)) ? fx_s : fx_unsafe_s)); - } + { + if (is_keyword(arg)) return(fx_c); + if (arg == sc->else_symbol) + { + if (is_let(cur_env)) {if (s7_symbol_local_value(sc, arg, cur_env) == sc->else_symbol) return(fx_c);} + else if ((is_pair(cur_env)) && (!direct_memq(arg, cur_env))) return(fx_c); + } + return((is_global(arg)) ? fx_g : ((checker(sc, arg, cur_env)) ? fx_s : fx_unsafe_s)); + } return(fx_c); } if (is_optimized(arg)) { switch (optimize_op(arg)) - { - case HOP_SAFE_C_NC: /* includes 0-arg cases, newline/current-input|output-port, [make-]hash-table?, read-line, [float-]vector/list, gensym */ - if (cdr(arg) == sc->nil) return((fn_proc(arg) == g_read_char) ? fx_read_char_0 : fx_c_0c); + { + case HOP_SAFE_C_NC: /* includes 0-arg cases, newline/current-input|output-port, [make-]hash-table?, read-line, [float-]vector/list, gensym */ + if (cdr(arg) == sc->nil) return((fn_proc(arg) == g_read_char) ? fx_read_char_0 : fx_c_0c); #if (!WITH_GMP) - if (fn_proc(arg) == g_add_i_random) return(fx_add_i_random); -#endif - return((fn_proc(arg) == g_random_i) ? fx_random_i : ((fn_proc(arg) == g_cons) ? fx_cons_cc : fx_c_nc)); - - case OP_OR_2A: - if (fx_proc(cddr(arg)) == fx_and_2a) {set_opt3_pair(arg, cdaddr(arg)); return(fx_or_and_2a);} - if (fx_proc(cddr(arg)) == fx_and_3a) {set_opt3_pair(arg, cdaddr(arg)); return(fx_or_and_3a);} - if ((fx_proc(cdr(arg)) == fx_not_is_symbol_s) && (fx_proc(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_2a); - - case OP_AND_2A: - if ((fx_proc(cdr(arg)) == fx_or_2a) && (fx_proc(cddr(arg)) == fx_or_2a)) - { - s7_pointer o1 = cadr(arg), o2 = caddr(arg); - if ((fx_proc(cdr(o1)) == fx_gt_vref_s) && - (fx_proc(cddr(o1)) == fx_geq_s_vref) && - (fx_proc(cdr(o2)) == fx_gt_vref_s) && - (fx_proc(cddr(o2)) == fx_geq_s_vref)) - { - s7_pointer v = cadr(cadadr(o1)); - if ((v == cadr(cadadr(o2))) && (v == (cadr(caddaddr(o1)))) && (v == (cadr(caddaddr(o2))))) - { - s7_pointer x = caddadr(o1); - if ((x == caddadr(o2)) && (x == cadaddr(o1)) && (x == cadaddr(o2))) - { - s7_pointer i = caddr(cadadr(o1)), j = caddaddr(caddr(o1)); - if ((j == caddr(cadadr(o2))) && (i == caddaddr(caddr(o2)))) - { - set_opt1_sym(o1, j); - set_opt3_sym(o1, i); - return(fx_and_or_2a_vref); - }}}}} - return(fx_and_2a); - - case HOP_SAFE_C_S: - if (is_unchanged_global(car(arg))) /* mus-copy would work here but in tgen (for example) it's loading generators.scm with local mus-copy methods */ - { - uint8_t typ; - if (car(arg) == sc->cdr_symbol) return(fx_cdr_s); - if (car(arg) == sc->car_symbol) return(fx_car_s); - if (car(arg) == sc->cadr_symbol) return(fx_cadr_s); - if (car(arg) == sc->cddr_symbol) return(fx_cddr_s); - 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); - if (car(arg) == sc->is_proper_list_symbol) return(fx_is_proper_list_s); - if (car(arg) == sc->is_vector_symbol) return(fx_is_vector_s); - if (car(arg) == sc->is_keyword_symbol) return(fx_is_keyword_s); - if (car(arg) == sc->is_procedure_symbol) return(fx_is_procedure_s); - if (car(arg) == sc->length_symbol) return(fx_length_s); - /* not read_char here... */ - typ = symbol_type(car(arg)); - if (typ > 0) - { - set_opt3_byte(cdr(arg), typ); - return(fx_is_type_s); - } - /* 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))))) - * "kar" fails but not "car" because symbol_id(kar) == 0! symbol_id(car) > 0 because mockery provides a method for it. - */ - if (symbol_id(c_function_name_to_symbol(sc, global_value(car(arg)))) == 0) - { - s7_p_p_t f = s7_p_p_function(global_value(car(arg))); - if (f) - { - set_opt2_direct(cdr(arg), (s7_pointer)f); - if (f == real_part_p_p) return(fx_real_part_s); - if (f == imag_part_p_p) return(fx_imag_part_s); - if (f == iterate_p_p) return(fx_iterate_s); - if (f == car_p_p) return(fx_car_s); /* can happen if (define var-name car) etc */ - return((is_global(cadr(arg))) ? fx_c_g_direct : fx_c_s_direct); - }}} - return((is_global(cadr(arg))) ? fx_c_g : fx_c_s); - - case HOP_SAFE_C_SS: - if (fn_proc(arg) == g_cons) return(fx_cons_ss); - if (fx_matches(car(arg), sc->num_eq_symbol)) return(fx_num_eq_ss); - if (fn_proc(arg) == g_geq_2) return(fx_geq_ss); - if (fn_proc(arg) == g_greater_2) return(fx_gt_ss); - if (fn_proc(arg) == g_leq_2) return(fx_leq_ss); - if (fn_proc(arg) == g_less_2) return((is_global(caddr(arg))) ? fx_lt_sg : fx_lt_ss); - if ((fx_matches(car(arg), sc->multiply_symbol)) && (cadr(arg) == caddr(arg))) return(fx_sqr_s); - if (fn_proc(arg) == g_multiply_2) return(fx_multiply_ss); - if (fn_proc(arg) == g_is_eq) return(fx_is_eq_ss); - if (fn_proc(arg) == g_add_2) return(fx_add_ss); - if (fn_proc(arg) == g_subtract_2) return(fx_subtract_ss); - if (fn_proc(arg) == g_hash_table_ref_2) return(fx_hash_table_ref_ss); - - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - if (car(arg) == sc->assq_symbol) return(fx_assq_ss); - if (car(arg) == sc->memq_symbol) return(fx_memq_ss); - if (car(arg) == sc->vector_ref_symbol) return(fx_vref_ss); - if (car(arg) == sc->string_ref_symbol) return(fx_sref_ss); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - return(fx_c_ss_direct); - } - /* fx_c_ss_direct via b_7pp is slower than fx_c_ss + g_<> */ - return(fx_c_ss); + if (fn_proc(arg) == g_add_i_random) return(fx_add_i_random); +#endif + return((fn_proc(arg) == g_random_i) ? fx_random_i : ((fn_proc(arg) == g_cons) ? fx_cons_cc : fx_c_nc)); + + case OP_OR_2A: + if (fx_proc(cddr(arg)) == fx_and_2a) {set_opt3_pair(arg, cdaddr(arg)); return(fx_or_and_2a);} + if (fx_proc(cddr(arg)) == fx_and_3a) {set_opt3_pair(arg, cdaddr(arg)); return(fx_or_and_3a);} + if ((fx_proc(cdr(arg)) == fx_not_is_symbol_s) && (fx_proc(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_2a); + + case OP_AND_2A: + if ((fx_proc(cdr(arg)) == fx_or_2a) && (fx_proc(cddr(arg)) == fx_or_2a)) + { + s7_pointer o1 = cadr(arg), o2 = caddr(arg); + if ((fx_proc(cdr(o1)) == fx_gt_vref_s) && + (fx_proc(cddr(o1)) == fx_geq_s_vref) && + (fx_proc(cdr(o2)) == fx_gt_vref_s) && + (fx_proc(cddr(o2)) == fx_geq_s_vref)) + { + s7_pointer v = cadr(cadadr(o1)); + if ((v == cadr(cadadr(o2))) && (v == (cadr(caddaddr(o1)))) && (v == (cadr(caddaddr(o2))))) + { + s7_pointer x = caddadr(o1); + if ((x == caddadr(o2)) && (x == cadaddr(o1)) && (x == cadaddr(o2))) + { + s7_pointer i = caddr(cadadr(o1)), j = caddaddr(caddr(o1)); + if ((j == caddr(cadadr(o2))) && (i == caddaddr(caddr(o2)))) + { + set_opt1_sym(o1, j); + set_opt3_sym(o1, i); + return(fx_and_or_2a_vref); + }}}}} + return(fx_and_2a); + + case HOP_SAFE_C_S: + if (is_unchanged_global(car(arg))) /* mus-copy would work here but in tgen (for example) it's loading generators.scm with local mus-copy methods */ + { + uint8_t typ; + if (car(arg) == sc->cdr_symbol) return(fx_cdr_s); + if (car(arg) == sc->car_symbol) return(fx_car_s); + if (car(arg) == sc->cadr_symbol) return(fx_cadr_s); + if (car(arg) == sc->cddr_symbol) return(fx_cddr_s); + 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); + if (car(arg) == sc->is_proper_list_symbol) return(fx_is_proper_list_s); + if (car(arg) == sc->is_vector_symbol) return(fx_is_vector_s); + if (car(arg) == sc->is_keyword_symbol) return(fx_is_keyword_s); + if (car(arg) == sc->is_procedure_symbol) return(fx_is_procedure_s); + if (car(arg) == sc->length_symbol) return(fx_length_s); + /* not read_char here... */ + typ = symbol_type(car(arg)); + if (typ > 0) + { + set_opt3_byte(cdr(arg), typ); + return(fx_is_type_s); + } + /* 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))))) + * "kar" fails but not "car" because symbol_id(kar) == 0! symbol_id(car) > 0 because mockery provides a method for it. + */ + if (symbol_id(c_function_name_to_symbol(sc, global_value(car(arg)))) == 0) + { + s7_p_p_t f = s7_p_p_function(global_value(car(arg))); + if (f) + { + set_opt2_direct(cdr(arg), (s7_pointer)f); + if (f == real_part_p_p) return(fx_real_part_s); + if (f == imag_part_p_p) return(fx_imag_part_s); + if (f == iterate_p_p) return(fx_iterate_s); + if (f == car_p_p) return(fx_car_s); /* can happen if (define var-name car) etc */ + return((is_global(cadr(arg))) ? fx_c_g_direct : fx_c_s_direct); + }}} + return((is_global(cadr(arg))) ? fx_c_g : fx_c_s); + + case HOP_SAFE_C_SS: + if (fn_proc(arg) == g_cons) return(fx_cons_ss); + if (fx_matches(car(arg), sc->num_eq_symbol)) return(fx_num_eq_ss); + if (fn_proc(arg) == g_geq_2) return(fx_geq_ss); + if (fn_proc(arg) == g_greater_2) return(fx_gt_ss); + if (fn_proc(arg) == g_leq_2) return(fx_leq_ss); + if (fn_proc(arg) == g_less_2) return((is_global(caddr(arg))) ? fx_lt_sg : fx_lt_ss); + if ((fx_matches(car(arg), sc->multiply_symbol)) && (cadr(arg) == caddr(arg))) return(fx_sqr_s); + if (fn_proc(arg) == g_multiply_2) return(fx_multiply_ss); + if (fn_proc(arg) == g_is_eq) return(fx_is_eq_ss); + if (fn_proc(arg) == g_add_2) return(fx_add_ss); + if (fn_proc(arg) == g_subtract_2) return(fx_subtract_ss); + if (fn_proc(arg) == g_hash_table_ref_2) return(fx_hash_table_ref_ss); + + if (is_global_and_has_func(car(arg), s7_p_pp_function)) + { + if (car(arg) == sc->assq_symbol) return(fx_assq_ss); + if (car(arg) == sc->memq_symbol) return(fx_memq_ss); + if (car(arg) == sc->vector_ref_symbol) return(fx_vref_ss); + if (car(arg) == sc->string_ref_symbol) return(fx_sref_ss); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + return(fx_c_ss_direct); + } + /* fx_c_ss_direct via b_7pp is slower than fx_c_ss + g_<> */ + return(fx_c_ss); case HOP_SAFE_C_NS: - if (fn_proc(arg) == g_list) return(fx_list_ns); /* it is no faster here to divide out the big list cases!? */ - return((fn_proc(arg) == g_vector) ? fx_vector_ns : fx_c_ns); - - 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_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); - return(((car(arg) == sc->cons_symbol) && (caadr(arg) == sc->car_symbol)) ? fx_cons_car_s_s : fx_c_opsq_s_direct); - } - return(fx_c_opsq_s); - - case HOP_SAFE_C_SSS: - if ((fn_proc(arg) == g_less) && (is_global(cadr(arg))) && (is_global(cadddr(arg)))) return(fx_lt_gsg); - if (is_global_and_has_func(car(arg), s7_p_ppp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(car(arg))))); - return(fx_c_sss_direct); - } - return(fx_c_sss); - - case HOP_SAFE_C_SSA: - if (is_global_and_has_func(car(arg), s7_p_ppp_function)) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(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(global_value(car(arg))))); - return(fx_c_scs_direct); - } - return(fx_c_scs); - - case HOP_SAFE_C_AAA: - if ((fx_proc(cdr(arg)) == fx_g) && (fx_proc(cdddr(arg)) == fx_c)) return(fx_c_gac); - if ((is_unquoted_pair(cadr(arg))) || (is_unquoted_pair(caddr(arg))) || (is_unquoted_pair(cadddr(arg)))) return(fx_c_aaa); - return(fx_c_3g); - - case HOP_SAFE_C_4A: - set_opt3_pair(arg, cdddr(arg)); - for (s7_pointer p = cdr(arg); is_pair(p); p = cdr(p)) - if (is_unquoted_pair(car(p))) - return(fx_c_4a); - return(fx_c_4g); /* fx_c_ssaa doesn't save much */ - - case HOP_SAFE_C_S_opSSq: - { - s7_pointer s2 = caddr(arg); - if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) return(fx_c_s_sqr); - - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(car(s2), s7_p_pp_function))) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(s2))))); - set_opt3_pair(arg, cdr(s2)); - if (car(s2) == sc->vector_ref_symbol) - { - if (car(arg) == sc->add_symbol) return(fx_add_s_vref); - if (car(arg) == sc->subtract_symbol) return(fx_subtract_s_vref); - if (car(arg) == sc->multiply_symbol) return(fx_multiply_s_vref); - if (car(arg) == sc->geq_symbol) return(fx_geq_s_vref); - if (car(arg) == sc->is_eq_symbol) return(fx_is_eq_s_vref); - if (car(arg) == sc->hash_table_ref_symbol) return(fx_href_s_vref); - if (car(arg) == sc->let_ref_symbol) return(fx_lref_s_vref); - if ((is_global(cadr(arg))) && (is_global(cadr(s2))) && (car(arg) == sc->vector_ref_symbol)) return(fx_vref_g_vref_gs); - } - if ((car(arg) == sc->vector_ref_symbol) && (car(s2) == sc->add_symbol)) return(fx_vref_s_add); - return(fx_c_s_opssq_direct); - } - return(fx_c_s_opssq); - } - - case HOP_SAFE_C_opSSq_S: - 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_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caadr(arg))))); - set_opt3_pair(arg, cdadr(arg)); - if (caadr(arg) == sc->vector_ref_symbol) - { - if (car(arg) == sc->subtract_symbol) return(fx_subtract_vref_s); - if (car(arg) == sc->gt_symbol) return(fx_gt_vref_s); - if (car(arg) == sc->vector_ref_symbol) return(fx_vref_vref_ss_s); - if (car(arg) == sc->add_symbol) return(fx_add_vref_s); - } - if (car(arg) == sc->add_symbol) - { - if ((caadr(arg) == sc->multiply_symbol) && (cadadr(arg) == caddadr(arg))) return(fx_add_sqr_s); - if (caadr(arg) == sc->subtract_symbol) return(fx_add_sub_s); - } - if ((car(arg) == sc->cons_symbol) && (caadr(arg) == sc->cons_symbol)) return(fx_cons_cons_s); - /* also div(sub)[2] mul(div) */ - return(((car(arg) == sc->gt_symbol) && (caadr(arg) == sc->add_symbol)) ? fx_gt_add_s : - (((car(arg) == sc->add_symbol) && (caadr(arg) == sc->multiply_symbol)) ? fx_add_mul_opssq_s : fx_c_opssq_s_direct)); - } - return(fx_c_opssq_s); - - case HOP_SAFE_C_opSSq_opSSq: - { - s7_pointer s1 = cadr(arg), s2 = caddr(arg); - set_opt3_pair(arg, cdr(s2)); - if ((fx_matches(car(s1), sc->multiply_symbol)) && (car(s2) == sc->multiply_symbol)) - { - set_opt1_pair(cdr(arg), cdr(s1)); - if (car(arg) == sc->subtract_symbol) return(fx_sub_mul_mul); - if (car(arg) == sc->add_symbol) - return(((cadr(s1) == caddr(s1)) && (cadr(s2) == caddr(s2))) ? fx_add_sqr_sqr : fx_add_mul_mul); - } - if ((fx_matches(car(s1), sc->subtract_symbol)) && (car(s2) == sc->subtract_symbol)) - { - set_opt1_pair(cdr(arg), cdr(s1)); - if (car(arg) == sc->multiply_symbol) return(fx_mul_sub_sub); - if (car(arg) == sc->lt_symbol) return(fx_lt_sub2); - } - if ((fx_matches(car(arg), sc->subtract_symbol)) && - (fx_matches(car(s1), sc->vector_ref_symbol)) && - (car(s2) == sc->vector_ref_symbol) && - (cadr(s1) == cadr(s2))) - { - set_opt3_sym(arg, cadr(cdaddr(arg))); - return(fx_sub_vref2); - } - return(fx_c_opssq_opssq); - } - - case HOP_SAFE_C_opSq: - if (is_unchanged_global(caadr(arg))) - { - if (fx_matches(car(arg), sc->is_pair_symbol)) - { - if (caadr(arg) == sc->car_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_pair_car_s);} /* (pair? ...) is ok, so loc can be sym? 7 in lg */ - if (caadr(arg) == sc->cdr_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_pair_cdr_s);} - if (caadr(arg) == sc->cadr_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_pair_cadr_s);} - if (caadr(arg) == sc->cddr_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_pair_cddr_s);} - } - if (fx_matches(car(arg), sc->is_null_symbol)) - { - if (caadr(arg) == sc->cdr_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_null_cdr_s);} - if (caadr(arg) == sc->cadr_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_null_cadr_s);} - if (caadr(arg) == sc->cddr_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_null_cddr_s);} - } - if ((fx_matches(car(arg), sc->is_symbol_symbol)) && - (caadr(arg) == sc->cadr_symbol)) - {set_opt3_sym(arg, cadadr(arg)); return(fx_is_symbol_cadr_s);} - - if (fx_matches(car(arg), sc->not_symbol)) - { - if (caadr(arg) == sc->is_pair_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_pair_s);} - if (caadr(arg) == sc->is_null_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_null_s);} - if (caadr(arg) == sc->is_symbol_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_symbol_s);} - return(fx_not_opsq); - } - if ((fx_matches(car(arg), sc->floor_symbol)) && (caadr(arg) == sc->sqrt_symbol)) - {set_opt3_sym(arg, cadadr(arg)); return(fx_floor_sqrt_s);} - } - if (is_unchanged_global(car(arg))) /* (? (op arg)) where (op arg) might return a let with a ? method etc */ - { /* other possibility: fx_c_a */ - uint8_t typ = symbol_type(car(arg)); - if (typ > 0) /* h_safe_c here so the type checker isn't shadowed */ - { - set_opt3_sym(arg, cadadr(arg)); - set_opt3_byte(cdr(arg), typ); - if (fn_proc(cadr(arg)) == (s7_function)g_c_pointer_weak1) - return(fx_eq_weak1_type_s); - return(fx_matches(caadr(arg), sc->car_symbol) ? fx_is_type_car_s : fx_is_type_opsq); - }} - /* this should follow the is_type* check above */ - if (fx_matches(caadr(arg), sc->car_symbol)) - { - set_opt3_sym(arg, cadadr(arg)); - return(fx_c_car_s); - } - if (fx_matches(caadr(arg), sc->cdr_symbol)) - { - set_opt3_sym(arg, cadadr(arg)); - return(fx_c_cdr_s); - } - return(fx_c_opsq); - - case HOP_SAFE_C_SC: - if (is_unchanged_global(car(arg))) - { - if (car(arg) == sc->add_symbol) - { - if (is_t_real(caddr(arg))) return(fx_add_sf); - if (is_t_integer(caddr(arg))) return((integer(caddr(arg)) == 1) ? fx_add_s1 : fx_add_si); - } - if (car(arg) == sc->subtract_symbol) - { - if (is_t_real(caddr(arg))) return(fx_subtract_sf); - if (is_t_integer(caddr(arg))) return((integer(caddr(arg)) == 1) ? fx_subtract_s1 : fx_subtract_si); - } - if (car(arg) == sc->multiply_symbol) - { - if (is_t_real(caddr(arg))) return(fx_multiply_sf); - if (is_t_integer(caddr(arg))) return(fx_multiply_si); - } - if ((fn_proc(arg) == g_memq_2) && (is_pair(caddr(arg)))) return(fx_memq_sq_2); - if ((fn_proc(arg) == g_is_eq) && (!is_unspecified(caddr(arg)))) return(fx_is_eq_sc); - - if ((is_t_integer(caddr(arg))) && (s7_p_pi_function(global_value(car(arg))))) - { - if (car(arg) == sc->num_eq_symbol) return((integer(caddr(arg)) == 0) ? fx_num_eq_s0 : fx_num_eq_si); - if (car(arg) == sc->lt_symbol) return(fx_lt_si); - if (car(arg) == sc->leq_symbol) return(fx_leq_si); - if (car(arg) == sc->gt_symbol) return(fx_gt_si); - if (car(arg) == sc->geq_symbol) return(fx_geq_si); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(global_value(car(arg))))); - return(fx_c_si_direct); - } - if ((is_t_real(caddr(arg))) && (real(caddr(arg)) == 0.0) && (car(arg) == sc->num_eq_symbol)) return(fx_num_eq_s0f); - if ((s7_p_pp_function(global_value(car(arg)))) && (fn_proc(arg) != g_divide_by_2)) - { - if (car(arg) == sc->memq_symbol) - { - if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadaddr(arg)))) return(fx_memq_sc_3); - return(fx_memq_sc); - } - if ((car(arg) == sc->char_eq_symbol) && (is_character(caddr(arg)))) return(fx_char_eq_sc); /* maybe fx_char_eq_newline */ - if (car(arg) == sc->lt_symbol) return(fx_lt_sc); /* integer case handled above */ - if (car(arg) == sc->leq_symbol) return(fx_leq_sc); - if (car(arg) == sc->gt_symbol) return(fx_gt_sc); - if (car(arg) == sc->geq_symbol) return(fx_geq_sc); - if (car(arg) == sc->list_symbol) return(fx_list_sc); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - return(fx_c_sc_direct); - }} - return(fx_c_sc); - - case HOP_SAFE_C_CS: - if (is_unchanged_global(car(arg))) - { - if (car(arg) == sc->cons_symbol) return(fx_cons_cs); - if ((car(arg) == sc->add_symbol) && (is_t_real(cadr(arg)))) return(fx_add_fs); - if ((car(arg) == sc->subtract_symbol) && (is_t_real(cadr(arg)))) return(fx_subtract_fs); - if ((car(arg) == sc->num_eq_symbol) && (cadr(arg) == int_zero)) - { - set_opt3_sym(arg, caddr(arg)); /* opt3_location is in use, but the num_eq is ok, so only symbol might care about that info? (or use cdr(arg)) */ - return(fx_num_eq_0s); - } - if (car(arg) == sc->multiply_symbol) - { - if (is_t_real(cadr(arg))) return(fx_multiply_fs); - if (is_t_integer(cadr(arg))) return(fx_multiply_is); - }} - return(fx_c_cs); - - case HOP_SAFE_C_S_opSq: - if (fx_matches(car(caddr(arg)), sc->car_symbol)) - { - set_opt2_sym(cdr(arg), cadaddr(arg)); - if (fx_matches(car(arg), sc->hash_table_ref_symbol)) return(fx_hash_table_ref_car); - return(fx_matches(car(arg), sc->add_symbol) ? fx_add_s_car_s : fx_c_s_car_s); - } - if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && - (is_global_and_has_func(caaddr(arg), s7_p_p_function))) - { - if ((car(arg) == sc->cons_symbol) && (caaddr(arg) == sc->cdr_symbol)) {set_opt2_sym(cdr(arg), cadaddr(arg)); return(fx_cons_s_cdr_s);} - set_opt1_sym(cdr(arg), cadaddr(arg)); - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caaddr(arg))))); /* arg opt3 only location, but no change in callgrind */ - return(fx_c_s_opsq_direct); - } - return(fx_c_s_opsq); - - case HOP_SAFE_C_C_opSq: - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - s7_pointer arg2 = caddr(arg); - if (is_global_and_has_func(car(arg2), s7_p_p_function)) - { - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(car(arg2))))); - set_opt1_sym(cdr(arg), cadr(arg2)); - return(fx_c_c_opsq_direct); - }} - return(fx_c_c_opsq); - - case HOP_SAFE_C_opSq_C: - if (is_unchanged_global(car(arg))) - { - if ((car(arg) == sc->memq_symbol) && - (fx_matches(caadr(arg), sc->car_symbol)) && - (is_proper_quote(sc, caddr(arg))) && - (is_pair(cadaddr(arg)))) - return((s7_list_length(sc, opt2_con(cdr(arg))) == 2) ? fx_memq_car_s_2 : fx_memq_car_s); - - if (car(arg) == sc->is_eq_symbol) - { - if (((fx_matches(caadr(arg), sc->car_symbol)) || (fx_matches(caadr(arg), sc->caar_symbol))) && - (is_proper_quote(sc, caddr(arg)))) - { - set_opt3_sym(cdr(arg), cadadr(arg)); - set_opt2_con(cdr(arg), cadaddr(arg)); - return((caadr(arg) == sc->car_symbol) ? fx_is_eq_car_sq : fx_is_eq_caar_sq); - }} - if (((car(arg) == sc->lt_symbol) || (car(arg) == sc->num_eq_symbol)) && - (is_t_integer(caddr(arg))) && - (fx_matches(caadr(arg), sc->length_symbol))) - { - set_opt3_sym(cdr(arg), cadadr(arg)); - set_opt3_con(arg, caddr(arg)); - return((car(arg) == sc->lt_symbol) ? fx_less_length_i : fx_num_eq_length_i); - }} - set_opt1_sym(cdr(arg), cadadr(arg)); - return(fx_c_opsq_c); - - case HOP_SAFE_C_op_opSqq: - return((fx_matches(car(arg), sc->not_symbol)) ? ((fn_proc(cadr(arg)) == g_is_pair) ? fx_not_is_pair_opsq : fx_not_op_opsqq) : fx_c_op_opsqq); - - case HOP_SAFE_C_opSCq: - if (fx_matches(car(arg), sc->not_symbol)) - { - if (fn_proc(cadr(arg)) == g_is_eq) - { - set_opt3_sym(arg, cadadr(arg)); - set_opt3_con(cdr(arg), (is_pair(caddadr(arg))) ? cadaddr(cadr(arg)) : caddadr(arg)); - return(fx_not_is_eq_sq); - } - return(fx_not_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 = 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(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(global_value(car(arg2))))); - set_opt3_sym(arg, cadr(arg2)); - set_opt1_con(cdr(arg), caddr(arg2)); - if (car(arg) == sc->num_eq_symbol) - { - if (car(arg2) == sc->add_symbol) return(fx_num_eq_add_s_si); - if (car(arg2) == sc->subtract_symbol) return(fx_num_eq_subtract_s_si); - } - if ((car(arg) == sc->vector_ref_symbol) && (car(arg2) == sc->add_symbol) && (integer(caddr(arg2)) == 1)) - return(fx_vref_p1); - 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(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg2))))); - set_opt3_sym(arg, cadr(arg2)); - set_opt1_con(cdr(arg), (is_pair(caddr(arg2))) ? cadaddr(arg2) : caddr(arg2)); - return(fx_c_s_opscq_direct); - }} - return(fx_c_s_opscq); - - case HOP_SAFE_C_opSSq: - if (fx_matches(car(arg), sc->not_symbol)) - { - if (fn_proc(cadr(arg)) == g_is_eq) 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(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caadr(arg))))); - return(fx_c_opssq_direct); - } - return(fx_c_opssq); - - case HOP_SAFE_C_C_opSSq: - { - s7_pointer s2 = caddr(arg); - if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) - return(fx_c_c_sqr); - } - if ((is_small_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))) /* not * currently (this is for clm) */ - { - set_opt3_direct(cdr(arg), s7_d_pd_function(global_value(caaddr(arg)))); - set_opt2_direct(cdr(arg), s7_p_dd_function(global_value(car(arg)))); - set_opt3_sym(arg, cadaddr(arg)); - set_opt1_sym(cdr(arg), caddaddr(arg)); - return(fx_c_nc_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(global_value(car(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caaddr(arg))))); - set_opt3_sym(arg, cadaddr(arg)); - set_opt1_sym(cdr(arg), caddaddr(arg)); - if ((is_t_real(cadr(arg))) && (car(arg) == caaddr(arg)) && (car(arg) == sc->multiply_symbol)) return(fx_multiply_c_opssq); - return(fx_c_c_opssq_direct); - } - return(fx_c_c_opssq); - - case HOP_SAFE_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(global_value(car(arg))))); - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caaddr(arg))))); - if ((caadr(arg) == caaddr(arg)) && ((caadr(arg) == sc->cdr_symbol) || (caadr(arg) == sc->car_symbol))) - { - set_opt1_sym(cdr(arg), cadadr(arg)); - set_opt2_sym(cdr(arg), cadaddr(arg)); /* usable because we know func is cdr|car */ - return((caadr(arg) == sc->cdr_symbol) ? fx_cdr_s_cdr_s : fx_car_s_car_s); - } - set_opt1_sym(cdr(arg), cadaddr(arg)); /* opt2 is taken by second func */ - return(fx_c_opsq_opsq_direct); - } - return(fx_c_opsq_opsq); - - case HOP_SAFE_C_op_S_opSqq: - return((fx_matches(car(arg), sc->not_symbol)) ? fx_not_op_s_opsqq : fx_c_op_s_opsqq); - - case HOP_SAFE_C_op_opSSqq_S: - 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(car(cadadr(arg)), s7_p_pp_function))) - { - set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caadr(cadr(arg)))))); - return(fx_c_op_opssqq_s_direct); - } - return(fx_c_op_opssqq_s); - - case HOP_SAFE_C_A: - if (fx_matches(car(arg), sc->not_symbol)) - { - if (fx_proc(cdr(arg)) == fx_is_eq_car_sq) - { - set_opt1_sym(cdr(arg), cadadr(cadr(arg))); - set_opt3_con(cdr(arg), cadaddr(cadr(arg))); - return(fx_not_is_eq_car_sq); - } - return(fx_not_a); - } - if (is_global_and_has_func(car(arg), s7_p_p_function)) - { - set_opt3_direct(arg, (s7_pointer)(s7_p_p_function(global_value(car(arg))))); - return(fx_c_a_direct); - } - return(fx_c_a); - - case HOP_SAFE_C_AC: - if (fn_proc(arg) == g_cons) return(fx_cons_ac); - if (fx_matches(car(arg), sc->is_eq_symbol)) return(fx_is_eq_ac); - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - if ((opt3_direct(cdr(arg)) == (s7_pointer)string_ref_p_pp) && (is_t_integer(caddr(arg))) && (integer(caddr(arg)) == 0)) - set_opt3_direct(cdr(arg), string_ref_p_p0); - if (opt3_direct(cdr(arg)) == (s7_pointer)memq_p_pp) - { - if (fn_proc(arg) == g_memq_2) - set_opt3_direct(cdr(arg), (s7_pointer)memq_2_p_pp); - else - if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadaddr(arg)))) - set_opt3_direct(cdr(arg), memq_3_p_pp); - else - if (fn_proc(arg) == g_memq_4) - set_opt3_direct(cdr(arg), memq_4_p_pp); /* this does not parallel 2 and 3 above (sigh) */ - } - else - if ((is_t_real(opt3_con(arg))) && (opt3_direct(cdr(arg)) == (s7_pointer)lt_p_pp)) - return(fx_lt_ad); - if ((is_t_integer(opt3_con(arg))) && (s7_p_pi_function(global_value(car(arg))))) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(global_value(car(arg))))); - if (integer(opt3_con(arg)) == 1) - { - if (opt3_direct(cdr(arg)) == (s7_pointer)g_sub_xi) - return(fx_sub_a1); - if (opt3_direct(cdr(arg)) == (s7_pointer)add_p_pi) - return(fx_add_a1); - } - return(fx_c_ai_direct); - } - return(fx_c_ac_direct); - } - return(fx_c_ac); - - case HOP_SAFE_C_CA: - return((fn_proc(arg) == g_cons) ? fx_cons_ca : fx_c_ca); - - case HOP_SAFE_C_SA: - if (fn_proc(arg) == g_multiply_2) return(fx_multiply_sa); - if (fn_proc(arg) == g_add_2) return(fx_add_sa); - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - return((fn_proc(arg) == g_cons) ? fx_cons_sa : fx_c_sa_direct); - } - return(fx_c_sa); - - case HOP_SAFE_C_AS: - if (fn_proc(arg) == g_add_2) return(fx_add_as); - if (is_global_and_has_func(car(arg), s7_p_pp_function)) - { - set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); - return((fn_proc(arg) == g_cons) ? fx_cons_as : fx_c_as_direct); - } - return(fx_c_as); - - case HOP_SAFE_C_AA: /* (* wr (float-vector-ref rl 0 j)) (* wr (block-ref (vector-ref rl j) 0)) (- (float-vector-ref rl 0 i) tempr) */ - if (fn_proc(arg) == g_add_2) return(fx_add_aa); - if (fn_proc(arg) == g_subtract_2) return(fx_subtract_aa); - if (fn_proc(arg) == g_multiply_2) return(fx_multiply_aa); - if (fn_proc(arg) == g_number_to_string) return(fx_number_to_string_aa); - if (fn_proc(arg) == g_cons) return(fx_cons_aa); - return(fx_c_aa); - - case HOP_SAFE_C_opAAq: - return((fx_proc(cdadr(arg)) == fx_s) ? fx_c_opsaq : fx_c_opaaq); - - case HOP_SAFE_C_NA: - return((fn_proc(arg) == g_vector) ? fx_vector_na : fx_c_na); - - case HOP_SAFE_C_ALL_CA: - return((fn_proc(arg) == g_simple_inlet) ? fx_inlet_ca : fx_c_all_ca); - - case HOP_SAFE_CLOSURE_S_A: - { - s7_pointer body = car(closure_body(opt1_lambda(arg))); - if (is_pair(body)) - { - if (optimize_op(body) == OP_AND_2A) - { - if ((fx_matches(caadr(body), sc->is_pair_symbol)) && - (cadadr(body) == car(closure_args(opt1_lambda(arg))))) - return(fx_safe_closure_s_and_pair); /* lint arg: (len>1? init), args: (x) body: (and (pair? x) (pair? (cdr x))) */ - return(fx_safe_closure_s_and_2a); - } - if (optimize_op(body) == HOP_SAFE_C_opSq_C) - { - if ((fn_proc(body) == g_simple_let_ref) && - (cadadr(body) == car(closure_args(opt1_lambda(arg))))) - { - set_opt2_sym(cdr(arg), cadaddr(body)); - return(fx_simple_let_ref_s); /* (var-ref local-var) -> (let-ref (cdr v=local_var) 'ref) */ - }}} - return((fx_proc(closure_body(opt1_lambda(arg))) == fx_sqr_t) ? fx_safe_closure_s_sqr : fx_safe_closure_s_a); - } - - case HOP_SAFE_CLOSURE_S_TO_SC: - { - s7_pointer body = car(closure_body(opt1_lambda(arg))); - if (fn_proc(body) == g_vector_ref_2) return(fx_safe_closure_s_to_vref); - if ((is_t_integer(caddr(body))) && (integer(caddr(body)) == 1)) - { - if (car(body) == sc->subtract_symbol) return(fx_safe_closure_s_to_sub1); - if (car(body) == sc->add_symbol) return(fx_safe_closure_s_to_add1); - } - return(fx_safe_closure_s_to_sc); - } - - case HOP_SAFE_CLOSURE_A_TO_SC: - return((fn_proc(car(closure_body(opt1_lambda(arg)))) == g_vector_ref_2) ? fx_safe_closure_a_to_vref : fx_safe_closure_a_to_sc); - - case HOP_SAFE_CLOSURE_A_A: - if (fx_proc(closure_body(opt1_lambda(arg))) == fx_and_2a) - return(fx_safe_closure_a_and_2a); - return((fx_proc(closure_body(opt1_lambda(arg))) == fx_sqr_t) ? fx_safe_closure_a_sqr : fx_safe_closure_a_a); - - case HOP_SAFE_CLOSURE_3S_A: - if (fx_proc(closure_body(opt1_lambda(arg))) == fx_vref_vref_tu_v) return(fx_vref_vref_3_no_let); - return(fx_function[optimize_op(arg)]); - - case OP_IMPLICIT_S7_STARLET_REF_S: - if (opt3_int(arg) == SL_PRINT_LENGTH) return(fx_implicit_s7_starlet_print_length); - if (opt3_int(arg) == SL_SAFETY) return(fx_implicit_s7_starlet_safety); - return(fx_implicit_s7_starlet_ref_s); - - case HOP_C: - if ((is_unchanged_global(car(arg))) && (car(arg) == sc->curlet_symbol)) return(fx_curlet); - /* fall through */ - - default: - /* if ((S7_DEBUGGING) && (!fx_function[optimize_op(arg)]) && (is_h_optimized(arg))) fprintf(stderr, "fx_choose %s %s\n", op_names[optimize_op(arg)], display(arg)); */ - /* this includes unsafe c funcs (hop_c_a) and p-arg safe funcs (hop_safe_c_p) -- name needs "safe" and no "p" */ - return(fx_function[optimize_op(arg)]); - }} /* is_optimized */ + if (fn_proc(arg) == g_list) return(fx_list_ns); /* it is no faster here to divide out the big list cases!? */ + return((fn_proc(arg) == g_vector) ? fx_vector_ns : fx_c_ns); + + 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_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); + return(((car(arg) == sc->cons_symbol) && (caadr(arg) == sc->car_symbol)) ? fx_cons_car_s_s : fx_c_opsq_s_direct); + } + return(fx_c_opsq_s); + + case HOP_SAFE_C_SSS: + if ((fn_proc(arg) == g_less) && (is_global(cadr(arg))) && (is_global(cadddr(arg)))) return(fx_lt_gsg); + if (is_global_and_has_func(car(arg), s7_p_ppp_function)) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(car(arg))))); + return(fx_c_sss_direct); + } + return(fx_c_sss); + + case HOP_SAFE_C_SSA: + if (is_global_and_has_func(car(arg), s7_p_ppp_function)) + { + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(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(global_value(car(arg))))); + return(fx_c_scs_direct); + } + return(fx_c_scs); + + case HOP_SAFE_C_AAA: + if ((fx_proc(cdr(arg)) == fx_g) && (fx_proc(cdddr(arg)) == fx_c)) return(fx_c_gac); + if ((is_unquoted_pair(cadr(arg))) || (is_unquoted_pair(caddr(arg))) || (is_unquoted_pair(cadddr(arg)))) return(fx_c_aaa); + return(fx_c_3g); + + case HOP_SAFE_C_4A: + set_opt3_pair(arg, cdddr(arg)); + for (s7_pointer p = cdr(arg); is_pair(p); p = cdr(p)) + if (is_unquoted_pair(car(p))) + return(fx_c_4a); + return(fx_c_4g); /* fx_c_ssaa doesn't save much */ + + case HOP_SAFE_C_S_opSSq: + { + s7_pointer s2 = caddr(arg); + if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) return(fx_c_s_sqr); + + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(car(s2), s7_p_pp_function))) + { + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(s2))))); + set_opt3_pair(arg, cdr(s2)); + if (car(s2) == sc->vector_ref_symbol) + { + if (car(arg) == sc->add_symbol) return(fx_add_s_vref); + if (car(arg) == sc->subtract_symbol) return(fx_subtract_s_vref); + if (car(arg) == sc->multiply_symbol) return(fx_multiply_s_vref); + if (car(arg) == sc->geq_symbol) return(fx_geq_s_vref); + if (car(arg) == sc->is_eq_symbol) return(fx_is_eq_s_vref); + if (car(arg) == sc->hash_table_ref_symbol) return(fx_href_s_vref); + if (car(arg) == sc->let_ref_symbol) return(fx_lref_s_vref); + if ((is_global(cadr(arg))) && (is_global(cadr(s2))) && (car(arg) == sc->vector_ref_symbol)) return(fx_vref_g_vref_gs); + } + if ((car(arg) == sc->vector_ref_symbol) && (car(s2) == sc->add_symbol)) return(fx_vref_s_add); + return(fx_c_s_opssq_direct); + } + return(fx_c_s_opssq); + } + + case HOP_SAFE_C_opSSq_S: + 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_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caadr(arg))))); + set_opt3_pair(arg, cdadr(arg)); + if (caadr(arg) == sc->vector_ref_symbol) + { + if (car(arg) == sc->subtract_symbol) return(fx_subtract_vref_s); + if (car(arg) == sc->gt_symbol) return(fx_gt_vref_s); + if (car(arg) == sc->vector_ref_symbol) return(fx_vref_vref_ss_s); + if (car(arg) == sc->add_symbol) return(fx_add_vref_s); + } + if (car(arg) == sc->add_symbol) + { + if ((caadr(arg) == sc->multiply_symbol) && (cadadr(arg) == caddadr(arg))) return(fx_add_sqr_s); + if (caadr(arg) == sc->subtract_symbol) return(fx_add_sub_s); + } + if ((car(arg) == sc->cons_symbol) && (caadr(arg) == sc->cons_symbol)) return(fx_cons_cons_s); + /* also div(sub)[2] mul(div) */ + return(((car(arg) == sc->gt_symbol) && (caadr(arg) == sc->add_symbol)) ? fx_gt_add_s : + (((car(arg) == sc->add_symbol) && (caadr(arg) == sc->multiply_symbol)) ? fx_add_mul_opssq_s : fx_c_opssq_s_direct)); + } + return(fx_c_opssq_s); + + case HOP_SAFE_C_opSSq_opSSq: + { + s7_pointer s1 = cadr(arg), s2 = caddr(arg); + set_opt3_pair(arg, cdr(s2)); + if ((fx_matches(car(s1), sc->multiply_symbol)) && (car(s2) == sc->multiply_symbol)) + { + set_opt1_pair(cdr(arg), cdr(s1)); + if (car(arg) == sc->subtract_symbol) return(fx_sub_mul_mul); + if (car(arg) == sc->add_symbol) + return(((cadr(s1) == caddr(s1)) && (cadr(s2) == caddr(s2))) ? fx_add_sqr_sqr : fx_add_mul_mul); + } + if ((fx_matches(car(s1), sc->subtract_symbol)) && (car(s2) == sc->subtract_symbol)) + { + set_opt1_pair(cdr(arg), cdr(s1)); + if (car(arg) == sc->multiply_symbol) return(fx_mul_sub_sub); + if (car(arg) == sc->lt_symbol) return(fx_lt_sub2); + } + if ((fx_matches(car(arg), sc->subtract_symbol)) && + (fx_matches(car(s1), sc->vector_ref_symbol)) && + (car(s2) == sc->vector_ref_symbol) && + (cadr(s1) == cadr(s2))) + { + set_opt3_sym(arg, cadr(cdaddr(arg))); + return(fx_sub_vref2); + } + return(fx_c_opssq_opssq); + } + + case HOP_SAFE_C_opSq: + if (is_unchanged_global(caadr(arg))) + { + if (fx_matches(car(arg), sc->is_pair_symbol)) + { + if (caadr(arg) == sc->car_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_pair_car_s);} /* (pair? ...) is ok, so loc can be sym? 7 in lg */ + if (caadr(arg) == sc->cdr_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_pair_cdr_s);} + if (caadr(arg) == sc->cadr_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_pair_cadr_s);} + if (caadr(arg) == sc->cddr_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_pair_cddr_s);} + } + if (fx_matches(car(arg), sc->is_null_symbol)) + { + if (caadr(arg) == sc->cdr_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_null_cdr_s);} + if (caadr(arg) == sc->cadr_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_null_cadr_s);} + if (caadr(arg) == sc->cddr_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_is_null_cddr_s);} + } + if ((fx_matches(car(arg), sc->is_symbol_symbol)) && + (caadr(arg) == sc->cadr_symbol)) + {set_opt3_sym(arg, cadadr(arg)); return(fx_is_symbol_cadr_s);} + + if (fx_matches(car(arg), sc->not_symbol)) + { + if (caadr(arg) == sc->is_pair_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_pair_s);} + if (caadr(arg) == sc->is_null_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_null_s);} + if (caadr(arg) == sc->is_symbol_symbol) {set_opt3_sym(arg, cadadr(arg)); return(fx_not_is_symbol_s);} + return(fx_not_opsq); + } + if ((fx_matches(car(arg), sc->floor_symbol)) && (caadr(arg) == sc->sqrt_symbol)) + {set_opt3_sym(arg, cadadr(arg)); return(fx_floor_sqrt_s);} + } + if (is_unchanged_global(car(arg))) /* (? (op arg)) where (op arg) might return a let with a ? method etc */ + { /* other possibility: fx_c_a */ + uint8_t typ = symbol_type(car(arg)); + if (typ > 0) /* h_safe_c here so the type checker isn't shadowed */ + { + set_opt3_sym(arg, cadadr(arg)); + set_opt3_byte(cdr(arg), typ); + if (fn_proc(cadr(arg)) == (s7_function)g_c_pointer_weak1) + return(fx_eq_weak1_type_s); + return(fx_matches(caadr(arg), sc->car_symbol) ? fx_is_type_car_s : fx_is_type_opsq); + }} + /* this should follow the is_type* check above */ + if (fx_matches(caadr(arg), sc->car_symbol)) + { + set_opt3_sym(arg, cadadr(arg)); + return(fx_c_car_s); + } + if (fx_matches(caadr(arg), sc->cdr_symbol)) + { + set_opt3_sym(arg, cadadr(arg)); + return(fx_c_cdr_s); + } + return(fx_c_opsq); + + case HOP_SAFE_C_SC: + if (is_unchanged_global(car(arg))) + { + if (car(arg) == sc->add_symbol) + { + if (is_t_real(caddr(arg))) return(fx_add_sf); + if (is_t_integer(caddr(arg))) return((integer(caddr(arg)) == 1) ? fx_add_s1 : fx_add_si); + } + if (car(arg) == sc->subtract_symbol) + { + if (is_t_real(caddr(arg))) return(fx_subtract_sf); + if (is_t_integer(caddr(arg))) return((integer(caddr(arg)) == 1) ? fx_subtract_s1 : fx_subtract_si); + } + if (car(arg) == sc->multiply_symbol) + { + if (is_t_real(caddr(arg))) return(fx_multiply_sf); + if (is_t_integer(caddr(arg))) return(fx_multiply_si); + } + if ((fn_proc(arg) == g_memq_2) && (is_pair(caddr(arg)))) return(fx_memq_sq_2); + if ((fn_proc(arg) == g_is_eq) && (!is_unspecified(caddr(arg)))) return(fx_is_eq_sc); + + if ((is_t_integer(caddr(arg))) && (s7_p_pi_function(global_value(car(arg))))) + { + if (car(arg) == sc->num_eq_symbol) return((integer(caddr(arg)) == 0) ? fx_num_eq_s0 : fx_num_eq_si); + if (car(arg) == sc->lt_symbol) return(fx_lt_si); + if (car(arg) == sc->leq_symbol) return(fx_leq_si); + if (car(arg) == sc->gt_symbol) return(fx_gt_si); + if (car(arg) == sc->geq_symbol) return(fx_geq_si); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(global_value(car(arg))))); + return(fx_c_si_direct); + } + if ((is_t_real(caddr(arg))) && (real(caddr(arg)) == 0.0) && (car(arg) == sc->num_eq_symbol)) return(fx_num_eq_s0f); + if ((s7_p_pp_function(global_value(car(arg)))) && (fn_proc(arg) != g_divide_by_2)) + { + if (car(arg) == sc->memq_symbol) + { + if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadaddr(arg)))) return(fx_memq_sc_3); + return(fx_memq_sc); + } + if ((car(arg) == sc->char_eq_symbol) && (is_character(caddr(arg)))) return(fx_char_eq_sc); /* maybe fx_char_eq_newline */ + if (car(arg) == sc->lt_symbol) return(fx_lt_sc); /* integer case handled above */ + if (car(arg) == sc->leq_symbol) return(fx_leq_sc); + if (car(arg) == sc->gt_symbol) return(fx_gt_sc); + if (car(arg) == sc->geq_symbol) return(fx_geq_sc); + if (car(arg) == sc->list_symbol) return(fx_list_sc); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + return(fx_c_sc_direct); + }} + return(fx_c_sc); + + case HOP_SAFE_C_CS: + if (is_unchanged_global(car(arg))) + { + if (car(arg) == sc->cons_symbol) return(fx_cons_cs); + if ((car(arg) == sc->add_symbol) && (is_t_real(cadr(arg)))) return(fx_add_fs); + if ((car(arg) == sc->subtract_symbol) && (is_t_real(cadr(arg)))) return(fx_subtract_fs); + if ((car(arg) == sc->num_eq_symbol) && (cadr(arg) == int_zero)) + { + set_opt3_sym(arg, caddr(arg)); /* opt3_location is in use, but the num_eq is ok, so only symbol might care about that info? (or use cdr(arg)) */ + return(fx_num_eq_0s); + } + if (car(arg) == sc->multiply_symbol) + { + if (is_t_real(cadr(arg))) return(fx_multiply_fs); + if (is_t_integer(cadr(arg))) return(fx_multiply_is); + }} + return(fx_c_cs); + + case HOP_SAFE_C_S_opSq: + if (fx_matches(car(caddr(arg)), sc->car_symbol)) + { + set_opt2_sym(cdr(arg), cadaddr(arg)); + if (fx_matches(car(arg), sc->hash_table_ref_symbol)) return(fx_hash_table_ref_car); + return(fx_matches(car(arg), sc->add_symbol) ? fx_add_s_car_s : fx_c_s_car_s); + } + if ((is_global_and_has_func(car(arg), s7_p_pp_function)) && + (is_global_and_has_func(caaddr(arg), s7_p_p_function))) + { + if ((car(arg) == sc->cons_symbol) && (caaddr(arg) == sc->cdr_symbol)) {set_opt2_sym(cdr(arg), cadaddr(arg)); return(fx_cons_s_cdr_s);} + set_opt1_sym(cdr(arg), cadaddr(arg)); + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caaddr(arg))))); /* arg opt3 only location, but no change in callgrind */ + return(fx_c_s_opsq_direct); + } + return(fx_c_s_opsq); + + case HOP_SAFE_C_C_opSq: + if (is_global_and_has_func(car(arg), s7_p_pp_function)) + { + s7_pointer arg2 = caddr(arg); + if (is_global_and_has_func(car(arg2), s7_p_p_function)) + { + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(car(arg2))))); + set_opt1_sym(cdr(arg), cadr(arg2)); + return(fx_c_c_opsq_direct); + }} + return(fx_c_c_opsq); + + case HOP_SAFE_C_opSq_C: + if (is_unchanged_global(car(arg))) + { + if ((car(arg) == sc->memq_symbol) && + (fx_matches(caadr(arg), sc->car_symbol)) && + (is_proper_quote(sc, caddr(arg))) && + (is_pair(cadaddr(arg)))) + return((s7_list_length(sc, opt2_con(cdr(arg))) == 2) ? fx_memq_car_s_2 : fx_memq_car_s); + + if (car(arg) == sc->is_eq_symbol) + { + if (((fx_matches(caadr(arg), sc->car_symbol)) || (fx_matches(caadr(arg), sc->caar_symbol))) && + (is_proper_quote(sc, caddr(arg)))) + { + set_opt3_sym(cdr(arg), cadadr(arg)); + set_opt2_con(cdr(arg), cadaddr(arg)); + return((caadr(arg) == sc->car_symbol) ? fx_is_eq_car_sq : fx_is_eq_caar_sq); + }} + if (((car(arg) == sc->lt_symbol) || (car(arg) == sc->num_eq_symbol)) && + (is_t_integer(caddr(arg))) && + (fx_matches(caadr(arg), sc->length_symbol))) + { + set_opt3_sym(cdr(arg), cadadr(arg)); + set_opt3_con(arg, caddr(arg)); + return((car(arg) == sc->lt_symbol) ? fx_less_length_i : fx_num_eq_length_i); + }} + set_opt1_sym(cdr(arg), cadadr(arg)); + return(fx_c_opsq_c); + + case HOP_SAFE_C_op_opSqq: + return((fx_matches(car(arg), sc->not_symbol)) ? ((fn_proc(cadr(arg)) == g_is_pair) ? fx_not_is_pair_opsq : fx_not_op_opsqq) : fx_c_op_opsqq); + + case HOP_SAFE_C_opSCq: + if (fx_matches(car(arg), sc->not_symbol)) + { + if (fn_proc(cadr(arg)) == g_is_eq) + { + set_opt3_sym(arg, cadadr(arg)); + set_opt3_con(cdr(arg), (is_pair(caddadr(arg))) ? cadaddr(cadr(arg)) : caddadr(arg)); + return(fx_not_is_eq_sq); + } + return(fx_not_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 = 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(global_value(car(arg))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(global_value(car(arg2))))); + set_opt3_sym(arg, cadr(arg2)); + set_opt1_con(cdr(arg), caddr(arg2)); + if (car(arg) == sc->num_eq_symbol) + { + if (car(arg2) == sc->add_symbol) return(fx_num_eq_add_s_si); + if (car(arg2) == sc->subtract_symbol) return(fx_num_eq_subtract_s_si); + } + if ((car(arg) == sc->vector_ref_symbol) && (car(arg2) == sc->add_symbol) && (integer(caddr(arg2)) == 1)) + return(fx_vref_p1); + 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(global_value(car(arg))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg2))))); + set_opt3_sym(arg, cadr(arg2)); + set_opt1_con(cdr(arg), (is_pair(caddr(arg2))) ? cadaddr(arg2) : caddr(arg2)); + return(fx_c_s_opscq_direct); + }} + return(fx_c_s_opscq); + + case HOP_SAFE_C_opSSq: + if (fx_matches(car(arg), sc->not_symbol)) + { + if (fn_proc(cadr(arg)) == g_is_eq) 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(global_value(car(arg))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caadr(arg))))); + return(fx_c_opssq_direct); + } + return(fx_c_opssq); + + case HOP_SAFE_C_C_opSSq: + { + s7_pointer s2 = caddr(arg); + if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) + return(fx_c_c_sqr); + } + if ((is_small_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))) /* not * currently (this is for clm) */ + { + set_opt3_direct(cdr(arg), s7_d_pd_function(global_value(caaddr(arg)))); + set_opt2_direct(cdr(arg), s7_p_dd_function(global_value(car(arg)))); + set_opt3_sym(arg, cadaddr(arg)); + set_opt1_sym(cdr(arg), caddaddr(arg)); + return(fx_c_nc_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(global_value(car(arg))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caaddr(arg))))); + set_opt3_sym(arg, cadaddr(arg)); + set_opt1_sym(cdr(arg), caddaddr(arg)); + if ((is_t_real(cadr(arg))) && (car(arg) == caaddr(arg)) && (car(arg) == sc->multiply_symbol)) return(fx_multiply_c_opssq); + return(fx_c_c_opssq_direct); + } + return(fx_c_c_opssq); + + case HOP_SAFE_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(global_value(car(arg))))); + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caaddr(arg))))); + if ((caadr(arg) == caaddr(arg)) && ((caadr(arg) == sc->cdr_symbol) || (caadr(arg) == sc->car_symbol))) + { + set_opt1_sym(cdr(arg), cadadr(arg)); + set_opt2_sym(cdr(arg), cadaddr(arg)); /* usable because we know func is cdr|car */ + return((caadr(arg) == sc->cdr_symbol) ? fx_cdr_s_cdr_s : fx_car_s_car_s); + } + set_opt1_sym(cdr(arg), cadaddr(arg)); /* opt2 is taken by second func */ + return(fx_c_opsq_opsq_direct); + } + return(fx_c_opsq_opsq); + + case HOP_SAFE_C_op_S_opSqq: + return((fx_matches(car(arg), sc->not_symbol)) ? fx_not_op_s_opsqq : fx_c_op_s_opsqq); + + case HOP_SAFE_C_op_opSSqq_S: + 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(car(cadadr(arg)), s7_p_pp_function))) + { + set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(caadr(cadr(arg)))))); + return(fx_c_op_opssqq_s_direct); + } + return(fx_c_op_opssqq_s); + + case HOP_SAFE_C_A: + if (fx_matches(car(arg), sc->not_symbol)) + { + if (fx_proc(cdr(arg)) == fx_is_eq_car_sq) + { + set_opt1_sym(cdr(arg), cadadr(cadr(arg))); + set_opt3_con(cdr(arg), cadaddr(cadr(arg))); + return(fx_not_is_eq_car_sq); + } + return(fx_not_a); + } + if (is_global_and_has_func(car(arg), s7_p_p_function)) + { + set_opt3_direct(arg, (s7_pointer)(s7_p_p_function(global_value(car(arg))))); + return(fx_c_a_direct); + } + return(fx_c_a); + + case HOP_SAFE_C_AC: + if (fn_proc(arg) == g_cons) return(fx_cons_ac); + if (fx_matches(car(arg), sc->is_eq_symbol)) return(fx_is_eq_ac); + if (is_global_and_has_func(car(arg), s7_p_pp_function)) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + if ((opt3_direct(cdr(arg)) == (s7_pointer)string_ref_p_pp) && (is_t_integer(caddr(arg))) && (integer(caddr(arg)) == 0)) + set_opt3_direct(cdr(arg), string_ref_p_p0); + if (opt3_direct(cdr(arg)) == (s7_pointer)memq_p_pp) + { + if (fn_proc(arg) == g_memq_2) + set_opt3_direct(cdr(arg), (s7_pointer)memq_2_p_pp); + else + if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadaddr(arg)))) + set_opt3_direct(cdr(arg), memq_3_p_pp); + else + if (fn_proc(arg) == g_memq_4) + set_opt3_direct(cdr(arg), memq_4_p_pp); /* this does not parallel 2 and 3 above (sigh) */ + } + else + if ((is_t_real(opt3_con(arg))) && (opt3_direct(cdr(arg)) == (s7_pointer)lt_p_pp)) + return(fx_lt_ad); + if ((is_t_integer(opt3_con(arg))) && (s7_p_pi_function(global_value(car(arg))))) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(global_value(car(arg))))); + if (integer(opt3_con(arg)) == 1) + { + if (opt3_direct(cdr(arg)) == (s7_pointer)g_sub_xi) + return(fx_sub_a1); + if (opt3_direct(cdr(arg)) == (s7_pointer)add_p_pi) + return(fx_add_a1); + } + return(fx_c_ai_direct); + } + return(fx_c_ac_direct); + } + return(fx_c_ac); + + case HOP_SAFE_C_CA: + return((fn_proc(arg) == g_cons) ? fx_cons_ca : fx_c_ca); + + case HOP_SAFE_C_SA: + if (fn_proc(arg) == g_multiply_2) return(fx_multiply_sa); + if (fn_proc(arg) == g_add_2) return(fx_add_sa); + if (is_global_and_has_func(car(arg), s7_p_pp_function)) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + return((fn_proc(arg) == g_cons) ? fx_cons_sa : fx_c_sa_direct); + } + return(fx_c_sa); + + case HOP_SAFE_C_AS: + if (fn_proc(arg) == g_add_2) return(fx_add_as); + if (is_global_and_has_func(car(arg), s7_p_pp_function)) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(car(arg))))); + return((fn_proc(arg) == g_cons) ? fx_cons_as : fx_c_as_direct); + } + return(fx_c_as); + + case HOP_SAFE_C_AA: /* (* wr (float-vector-ref rl 0 j)) (* wr (block-ref (vector-ref rl j) 0)) (- (float-vector-ref rl 0 i) tempr) */ + if (fn_proc(arg) == g_add_2) return(fx_add_aa); + if (fn_proc(arg) == g_subtract_2) return(fx_subtract_aa); + if (fn_proc(arg) == g_multiply_2) return(fx_multiply_aa); + if (fn_proc(arg) == g_number_to_string) return(fx_number_to_string_aa); + if (fn_proc(arg) == g_cons) return(fx_cons_aa); + return(fx_c_aa); + + case HOP_SAFE_C_opAAq: + return((fx_proc(cdadr(arg)) == fx_s) ? fx_c_opsaq : fx_c_opaaq); + + case HOP_SAFE_C_NA: + return((fn_proc(arg) == g_vector) ? fx_vector_na : fx_c_na); + + case HOP_SAFE_C_ALL_CA: + return((fn_proc(arg) == g_simple_inlet) ? fx_inlet_ca : fx_c_all_ca); + + case HOP_SAFE_CLOSURE_S_A: + { + s7_pointer body = car(closure_body(opt1_lambda(arg))); + if (is_pair(body)) + { + if (optimize_op(body) == OP_AND_2A) + { + if ((fx_matches(caadr(body), sc->is_pair_symbol)) && + (cadadr(body) == car(closure_args(opt1_lambda(arg))))) + return(fx_safe_closure_s_and_pair); /* lint arg: (len>1? init), args: (x) body: (and (pair? x) (pair? (cdr x))) */ + return(fx_safe_closure_s_and_2a); + } + if (optimize_op(body) == HOP_SAFE_C_opSq_C) + { + if ((fn_proc(body) == g_simple_let_ref) && + (cadadr(body) == car(closure_args(opt1_lambda(arg))))) + { + set_opt2_sym(cdr(arg), cadaddr(body)); + return(fx_simple_let_ref_s); /* (var-ref local-var) -> (let-ref (cdr v=local_var) 'ref) */ + }}} + return((fx_proc(closure_body(opt1_lambda(arg))) == fx_sqr_t) ? fx_safe_closure_s_sqr : fx_safe_closure_s_a); + } + + case HOP_SAFE_CLOSURE_S_TO_SC: + { + s7_pointer body = car(closure_body(opt1_lambda(arg))); + if (fn_proc(body) == g_vector_ref_2) return(fx_safe_closure_s_to_vref); + if ((is_t_integer(caddr(body))) && (integer(caddr(body)) == 1)) + { + if (car(body) == sc->subtract_symbol) return(fx_safe_closure_s_to_sub1); + if (car(body) == sc->add_symbol) return(fx_safe_closure_s_to_add1); + } + return(fx_safe_closure_s_to_sc); + } + + case HOP_SAFE_CLOSURE_A_TO_SC: + return((fn_proc(car(closure_body(opt1_lambda(arg)))) == g_vector_ref_2) ? fx_safe_closure_a_to_vref : fx_safe_closure_a_to_sc); + + case HOP_SAFE_CLOSURE_A_A: + if (fx_proc(closure_body(opt1_lambda(arg))) == fx_and_2a) + return(fx_safe_closure_a_and_2a); + return((fx_proc(closure_body(opt1_lambda(arg))) == fx_sqr_t) ? fx_safe_closure_a_sqr : fx_safe_closure_a_a); + + case HOP_SAFE_CLOSURE_3S_A: + if (fx_proc(closure_body(opt1_lambda(arg))) == fx_vref_vref_tu_v) return(fx_vref_vref_3_no_let); + return(fx_function[optimize_op(arg)]); + + case OP_IMPLICIT_S7_STARLET_REF_S: + if (opt3_int(arg) == SL_PRINT_LENGTH) return(fx_implicit_s7_starlet_print_length); + if (opt3_int(arg) == SL_SAFETY) return(fx_implicit_s7_starlet_safety); + return(fx_implicit_s7_starlet_ref_s); + + case HOP_C: + if ((is_unchanged_global(car(arg))) && (car(arg) == sc->curlet_symbol)) return(fx_curlet); + /* fall through */ + + default: + /* if ((S7_DEBUGGING) && (!fx_function[optimize_op(arg)]) && (is_h_optimized(arg))) fprintf(stderr, "fx_choose %s %s\n", op_names[optimize_op(arg)], display(arg)); */ + /* this includes unsafe c funcs (hop_c_a) and p-arg safe funcs (hop_safe_c_p) -- name needs "safe" and no "p" */ + return(fx_function[optimize_op(arg)]); + }} /* is_optimized */ if (is_safe_quote(car(arg))) { @@ -57966,69 +57966,69 @@ static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, const s7_pointer var1, c if (is_symbol(p)) { if ((fx_proc(tree) == fx_s) || (fx_proc(tree) == fx_o)) - { - if (p == var1) return(with_fx(tree, fx_T)); - if (p == var2) return(with_fx(tree, fx_U)); - if (p == var3) return(with_fx(tree, fx_V)); - } + { + if (p == var1) return(with_fx(tree, fx_T)); + if (p == var2) return(with_fx(tree, fx_U)); + if (p == var3) return(with_fx(tree, fx_V)); + } return(false); } if ((is_pair(p)) && (is_pair(cdr(p)))) { if (cadr(p) == var1) - { - if ((fx_proc(tree) == fx_c_s) || (fx_proc(tree) == fx_c_o)) return(with_fx(tree, fx_c_T)); /* fx_c_T_direct got no hits */ - if ((fx_proc(tree) == fx_car_s) || (fx_proc(tree) == fx_car_o)) return(with_fx(tree, fx_car_T)); - if ((fx_proc(tree) == fx_cdr_s) || (fx_proc(tree) == fx_cdr_o)) return(with_fx(tree, fx_cdr_T)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_T)); - if (fx_proc(tree) == fx_iterate_o) return(with_fx(tree, fx_iterate_T)); - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_T1)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_T1)); - if (fx_proc(tree) == fx_c_sca) return(with_fx(tree, fx_c_Tca)); - if ((fx_proc(tree) == fx_num_eq_si) || (fx_proc(tree) == fx_num_eq_s0) || (fx_proc(tree) == fx_num_eq_oi)) return(with_fx(tree, fx_num_eq_Ti)); - /* if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, fx_cons_Ts)); */ /* can be fooled -- there is no fx_cons_us etc -- need fx_cons_os */ - /* if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_Ts)); */ /* this also can be fooled? */ - if ((fx_proc(tree) == fx_c_scs_direct) && (cadddr(p) == var2)) return(with_fx(tree, fx_c_TcU_direct)); - if ((fx_proc(tree) == fx_hash_table_ref_ss) && (var3 == caddr(p))) return(with_fx(tree, fx_hash_table_ref_TV)); - if ((fx_proc(tree) == fx_geq_ss) && (var2 == caddr(p))) return(with_fx(tree, fx_geq_TU)); - } + { + if ((fx_proc(tree) == fx_c_s) || (fx_proc(tree) == fx_c_o)) return(with_fx(tree, fx_c_T)); /* fx_c_T_direct got no hits */ + if ((fx_proc(tree) == fx_car_s) || (fx_proc(tree) == fx_car_o)) return(with_fx(tree, fx_car_T)); + if ((fx_proc(tree) == fx_cdr_s) || (fx_proc(tree) == fx_cdr_o)) return(with_fx(tree, fx_cdr_T)); + if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_T)); + if (fx_proc(tree) == fx_iterate_o) return(with_fx(tree, fx_iterate_T)); + if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_T1)); + if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_T1)); + if (fx_proc(tree) == fx_c_sca) return(with_fx(tree, fx_c_Tca)); + if ((fx_proc(tree) == fx_num_eq_si) || (fx_proc(tree) == fx_num_eq_s0) || (fx_proc(tree) == fx_num_eq_oi)) return(with_fx(tree, fx_num_eq_Ti)); + /* if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, fx_cons_Ts)); */ /* can be fooled -- there is no fx_cons_us etc -- need fx_cons_os */ + /* if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_Ts)); */ /* this also can be fooled? */ + if ((fx_proc(tree) == fx_c_scs_direct) && (cadddr(p) == var2)) return(with_fx(tree, fx_c_TcU_direct)); + if ((fx_proc(tree) == fx_hash_table_ref_ss) && (var3 == caddr(p))) return(with_fx(tree, fx_hash_table_ref_TV)); + if ((fx_proc(tree) == fx_geq_ss) && (var2 == caddr(p))) return(with_fx(tree, fx_geq_TU)); + } else - if (cadr(p) == var2) - { - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_U1)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_U1)); - if ((fx_proc(tree) == fx_car_s) || (fx_proc(tree) == fx_car_o)) return(with_fx(tree, fx_car_U)); - if ((fx_proc(tree) == fx_cdr_s) || (fx_proc(tree) == fx_cdr_o)) return(with_fx(tree, fx_cdr_U)); - } - else - if (cadr(p) == var3) - { - if ((fx_proc(tree) == fx_c_s) || (fx_proc(tree) == fx_c_o)) return(with_fx(tree, fx_c_V)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_V1)); - } - else - if (is_pair(cddr(p))) - { - if (caddr(p) == var1) - { - if ((fx_proc(tree) == fx_num_eq_ts) || (fx_proc(tree) == fx_num_eq_to)) return(with_fx(tree, fx_num_eq_tT)); - if ((fx_proc(tree) == fx_gt_ts) || (fx_proc(tree) == fx_gt_to)) return(with_fx(tree, fx_gt_tT)); - if (fx_proc(tree) == fx_lt_ts) return(with_fx(tree, fx_lt_tT)); - if ((fx_proc(tree) == fx_geq_ts) || (fx_proc(tree) == fx_geq_to)) return(with_fx(tree, fx_geq_tT)); - } - else - if (caddr(p) == var2) - { - if (fx_proc(tree) == fx_c_ts) return(with_fx(tree, fx_c_tU)); - if (fx_proc(tree) == fx_cons_ts) return(with_fx(tree, fx_cons_tU)); - if (fx_proc(tree) == fx_c_ts_direct) return(with_fx(tree, fx_c_tU_direct)); - if (fx_proc(tree) == fx_lt_ts) return(with_fx(tree, fx_lt_tU)); - if (fx_proc(tree) == fx_num_eq_us) return(with_fx(tree, fx_num_eq_uU)); - if (fx_proc(tree) == fx_num_eq_vs) return(with_fx(tree, fx_num_eq_vU)); - } - else - if ((fx_proc(tree) == fx_add_sqr_s) && (cadadr(p) == var1)) return(with_fx(tree, fx_add_sqr_T)); - }} + if (cadr(p) == var2) + { + if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_U1)); + if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_U1)); + if ((fx_proc(tree) == fx_car_s) || (fx_proc(tree) == fx_car_o)) return(with_fx(tree, fx_car_U)); + if ((fx_proc(tree) == fx_cdr_s) || (fx_proc(tree) == fx_cdr_o)) return(with_fx(tree, fx_cdr_U)); + } + else + if (cadr(p) == var3) + { + if ((fx_proc(tree) == fx_c_s) || (fx_proc(tree) == fx_c_o)) return(with_fx(tree, fx_c_V)); + if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_V1)); + } + else + if (is_pair(cddr(p))) + { + if (caddr(p) == var1) + { + if ((fx_proc(tree) == fx_num_eq_ts) || (fx_proc(tree) == fx_num_eq_to)) return(with_fx(tree, fx_num_eq_tT)); + if ((fx_proc(tree) == fx_gt_ts) || (fx_proc(tree) == fx_gt_to)) return(with_fx(tree, fx_gt_tT)); + if (fx_proc(tree) == fx_lt_ts) return(with_fx(tree, fx_lt_tT)); + if ((fx_proc(tree) == fx_geq_ts) || (fx_proc(tree) == fx_geq_to)) return(with_fx(tree, fx_geq_tT)); + } + else + if (caddr(p) == var2) + { + if (fx_proc(tree) == fx_c_ts) return(with_fx(tree, fx_c_tU)); + if (fx_proc(tree) == fx_cons_ts) return(with_fx(tree, fx_cons_tU)); + if (fx_proc(tree) == fx_c_ts_direct) return(with_fx(tree, fx_c_tU_direct)); + if (fx_proc(tree) == fx_lt_ts) return(with_fx(tree, fx_lt_tU)); + if (fx_proc(tree) == fx_num_eq_us) return(with_fx(tree, fx_num_eq_uU)); + if (fx_proc(tree) == fx_num_eq_vs) return(with_fx(tree, fx_num_eq_vU)); + } + else + if ((fx_proc(tree) == fx_add_sqr_s) && (cadadr(p) == var1)) return(with_fx(tree, fx_add_sqr_T)); + }} return(false); } @@ -58050,13 +58050,13 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point if (is_symbol(p)) { if (fx_proc(tree) == fx_s) - { - if (p == var1) return(with_fx(tree, fx_t)); - if (p == var2) return(with_fx(tree, fx_u)); - if (p == var3) return(with_fx(tree, fx_v)); - if (is_global(p)) return(with_fx(tree, fx_g)); - if (!more_vars) return(with_fx(tree, fx_o)); - } + { + if (p == var1) return(with_fx(tree, fx_t)); + if (p == var2) return(with_fx(tree, fx_u)); + if (p == var3) return(with_fx(tree, fx_v)); + if (is_global(p)) return(with_fx(tree, fx_g)); + if (!more_vars) return(with_fx(tree, fx_o)); + } return(false); } if ((!is_pair(p)) || (is_fx_treed(tree)) || (!has_fx(tree))) return(false); @@ -58065,267 +58065,267 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point { case HOP_SAFE_C_S: if (cadr(p) == var1) - { - if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_t)); - if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, (opt2_direct(cdr(p)) == (s7_pointer)cddr_p_p) ? fx_cddr_t : fx_c_t_direct)); - if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_t)); - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_t)); - if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_t)); - if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_t)); - if (fx_proc(tree) == fx_not_s) return(with_fx(tree, fx_not_t)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_t)); - if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_t)); - if (fx_proc(tree) == fx_is_symbol_s) return(with_fx(tree, fx_is_symbol_t)); - if (fx_proc(tree) == fx_is_eof_s) return(with_fx(tree, fx_is_eof_t)); - if (fx_proc(tree) == fx_is_string_s) return(with_fx(tree, fx_is_string_t)); - if (fx_proc(tree) == fx_is_vector_s) return(with_fx(tree, fx_is_vector_t)); - if (fx_proc(tree) == fx_is_integer_s) return(with_fx(tree, fx_is_integer_t)); - if (fx_proc(tree) == fx_is_procedure_s) return(with_fx(tree, fx_is_procedure_t)); - if (fx_proc(tree) == fx_is_type_s) return(with_fx(tree, fx_is_type_t)); - if (fx_proc(tree) == fx_length_s) return(with_fx(tree, fx_length_t)); - if (fx_proc(tree) == fx_real_part_s) return(with_fx(tree, fx_real_part_t)); - if (fx_proc(tree) == fx_imag_part_s) return(with_fx(tree, fx_imag_part_t)); - return(false); - } + { + if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_t)); + if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, (opt2_direct(cdr(p)) == (s7_pointer)cddr_p_p) ? fx_cddr_t : fx_c_t_direct)); + if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_t)); + if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_t)); + if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_t)); + if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_t)); + if (fx_proc(tree) == fx_not_s) return(with_fx(tree, fx_not_t)); + if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_t)); + if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_t)); + if (fx_proc(tree) == fx_is_symbol_s) return(with_fx(tree, fx_is_symbol_t)); + if (fx_proc(tree) == fx_is_eof_s) return(with_fx(tree, fx_is_eof_t)); + if (fx_proc(tree) == fx_is_string_s) return(with_fx(tree, fx_is_string_t)); + if (fx_proc(tree) == fx_is_vector_s) return(with_fx(tree, fx_is_vector_t)); + if (fx_proc(tree) == fx_is_integer_s) return(with_fx(tree, fx_is_integer_t)); + if (fx_proc(tree) == fx_is_procedure_s) return(with_fx(tree, fx_is_procedure_t)); + if (fx_proc(tree) == fx_is_type_s) return(with_fx(tree, fx_is_type_t)); + if (fx_proc(tree) == fx_length_s) return(with_fx(tree, fx_length_t)); + if (fx_proc(tree) == fx_real_part_s) return(with_fx(tree, fx_real_part_t)); + if (fx_proc(tree) == fx_imag_part_s) return(with_fx(tree, fx_imag_part_t)); + return(false); + } if (cadr(p) == var2) - { - if (fx_proc(tree) == fx_c_s) - { - if (is_global_and_has_func(car(p), s7_p_p_function)) - { - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(car(p))))); - return(with_fx(tree, (car(p) == sc->cddr_symbol) ? fx_cddr_u : - ((car(p) == sc->is_positive_symbol) ? fx_is_positive_u : - ((car(p) == sc->is_zero_symbol) ? fx_is_zero_u : fx_c_u_direct)))); - } - return(with_fx(tree, fx_c_u)); - } - if (fx_proc(tree) == fx_c_s_direct) - return(with_fx(tree, (car(p) == sc->cddr_symbol) ? fx_cddr_u : - ((car(p) == sc->is_positive_symbol) ? fx_is_positive_u : - ((car(p) == sc->is_zero_symbol) ? fx_is_zero_u : fx_c_u_direct)))); - - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_u)); - if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_u)); - if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_u)); - if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_u)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_u)); - if (fx_proc(tree) == fx_is_type_s) return(with_fx(tree, fx_is_type_u)); - if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_u)); - if (fx_proc(tree) == fx_is_symbol_s) return(with_fx(tree, fx_is_symbol_u)); - if (fx_proc(tree) == fx_is_eof_s) return(with_fx(tree, fx_is_eof_u)); - return(false); - } + { + if (fx_proc(tree) == fx_c_s) + { + if (is_global_and_has_func(car(p), s7_p_p_function)) + { + set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(car(p))))); + return(with_fx(tree, (car(p) == sc->cddr_symbol) ? fx_cddr_u : + ((car(p) == sc->is_positive_symbol) ? fx_is_positive_u : + ((car(p) == sc->is_zero_symbol) ? fx_is_zero_u : fx_c_u_direct)))); + } + return(with_fx(tree, fx_c_u)); + } + if (fx_proc(tree) == fx_c_s_direct) + return(with_fx(tree, (car(p) == sc->cddr_symbol) ? fx_cddr_u : + ((car(p) == sc->is_positive_symbol) ? fx_is_positive_u : + ((car(p) == sc->is_zero_symbol) ? fx_is_zero_u : fx_c_u_direct)))); + + if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_u)); + if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_u)); + if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_u)); + if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_u)); + if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_u)); + if (fx_proc(tree) == fx_is_type_s) return(with_fx(tree, fx_is_type_u)); + if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_u)); + if (fx_proc(tree) == fx_is_symbol_s) return(with_fx(tree, fx_is_symbol_u)); + if (fx_proc(tree) == fx_is_eof_s) return(with_fx(tree, fx_is_eof_u)); + return(false); + } if (cadr(p) == var3) - { - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_v)); - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_v)); - if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_v)); - if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_v)); - if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, fx_c_v_direct)); - return(false); - } + { + if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_v)); + if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_v)); + if (fx_proc(tree) == fx_is_pair_s) return(with_fx(tree, fx_is_pair_v)); + if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_v)); + if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, fx_c_v_direct)); + return(false); + } if (!more_vars) - { - if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_o)); - if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_o)); - if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_o)); - if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_o)); - if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_o)); - if (fx_proc(tree) == fx_iterate_s) return(with_fx(tree, fx_iterate_o)); - if (fx_proc(tree) == fx_not_s) return(with_fx(tree, fx_not_o)); - if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, fx_c_o_direct)); - if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_o)); - } + { + if (fx_proc(tree) == fx_is_null_s) return(with_fx(tree, fx_is_null_o)); + if (fx_proc(tree) == fx_car_s) return(with_fx(tree, fx_car_o)); + if (fx_proc(tree) == fx_cdr_s) return(with_fx(tree, fx_cdr_o)); + if (fx_proc(tree) == fx_cadr_s) return(with_fx(tree, fx_cadr_o)); + if (fx_proc(tree) == fx_cddr_s) return(with_fx(tree, fx_cddr_o)); + if (fx_proc(tree) == fx_iterate_s) return(with_fx(tree, fx_iterate_o)); + if (fx_proc(tree) == fx_not_s) return(with_fx(tree, fx_not_o)); + if (fx_proc(tree) == fx_c_s_direct) return(with_fx(tree, fx_c_o_direct)); + if (fx_proc(tree) == fx_c_s) return(with_fx(tree, fx_c_o)); + } break; case HOP_SAFE_C_SC: if (cadr(p) == var1) - { - if ((fx_proc(tree) == fx_char_eq_sc) || (fn_proc(p) == g_char_equal_2)) return(with_fx(tree, fx_char_eq_tc)); - if (fx_proc(tree) == fx_c_sc) return(with_fx(tree, fx_c_tc)); - if (fx_proc(tree) == fx_add_sf) return(with_fx(tree, fx_add_tf)); - if (fn_proc(p) == g_less_xf) return(with_fx(tree, fx_lt_tf)); - if (fn_proc(p) == g_less_x0) return(with_fx(tree, fx_lt_t0)); - if (fn_proc(p) == g_less_xi) - return(with_fx(tree, (integer(caddr(p)) == 2) ? fx_lt_t2 : ((integer(caddr(p)) == 1) ? fx_lt_t1 : fx_lt_ti))); - if (fn_proc(p) == g_geq_xf) return(with_fx(tree, fx_geq_tf)); - if (fn_proc(p) == g_geq_xi) return(with_fx(tree, (integer(caddr(p)) == 0) ? fx_geq_t0 : fx_geq_ti)); - if (fn_proc(p) == g_leq_xi) return(with_fx(tree, fx_leq_ti)); - if (fn_proc(p) == g_greater_xi) return(with_fx(tree, fx_gt_ti)); - if (fx_proc(tree) == fx_leq_si) return(with_fx(tree, fx_leq_ti)); - if (fx_proc(tree) == fx_gt_si) return(with_fx(tree, fx_gt_ti)); - - if (fx_proc(tree) == fx_c_sc_direct) /* p_pp cases */ - { - if ((opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp) && (is_t_integer(caddr(p)))) - return(with_fx(tree, fx_vector_ref_tc)); - if ((opt3_direct(cdr(p)) == (s7_pointer)string_ref_p_pp) && (is_t_integer(caddr(p))) && (integer(caddr(p)) == 0)) - set_opt3_direct(cdr(p), string_ref_p_p0); - return(with_fx(tree, fx_c_tc_direct)); - } - if (fx_proc(tree) == fx_c_si_direct) /* p_pi cases */ - { - if (opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pi) - return(with_fx(tree, fx_vector_ref_tc)); - if ((opt3_direct(cdr(p)) == (s7_pointer)string_ref_p_pi) && (integer(caddr(p)) == 0)) - set_opt3_direct(cdr(p), string_ref_p_p0); - return(with_fx(tree, (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pi) ? fx_c_ti_remainder : fx_c_ti_direct)); - } - - if (fx_proc(tree) == fx_is_eq_sc) return(with_fx(tree, fx_is_eq_tc)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_t1)); - if (fx_proc(tree) == fx_add_si) return(with_fx(tree, fx_add_ti)); - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_t1)); - if (fx_proc(tree) == fx_subtract_si) return(with_fx(tree, fx_subtract_ti)); - if (fx_proc(tree) == fx_subtract_sf) return(with_fx(tree, fx_subtract_tf)); - if (fx_proc(tree) == fx_multiply_sf) return(with_fx(tree, fx_multiply_tf)); - if (fx_proc(tree) == fx_multiply_si) return(with_fx(tree, fx_multiply_ti)); - if (fx_proc(tree) == fx_lt_si) /* is this ever hit? */ - return(with_fx(tree, (integer(caddr(p)) == 2) ? fx_lt_t2 : ((integer(caddr(p)) == 1) ? fx_lt_t1 : fx_lt_ti))); - if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_ti)); - if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_t0)); - if (fx_proc(tree) == fx_memq_sc) return(with_fx(tree, fx_memq_tc)); - return(false); - } + { + if ((fx_proc(tree) == fx_char_eq_sc) || (fn_proc(p) == g_char_equal_2)) return(with_fx(tree, fx_char_eq_tc)); + if (fx_proc(tree) == fx_c_sc) return(with_fx(tree, fx_c_tc)); + if (fx_proc(tree) == fx_add_sf) return(with_fx(tree, fx_add_tf)); + if (fn_proc(p) == g_less_xf) return(with_fx(tree, fx_lt_tf)); + if (fn_proc(p) == g_less_x0) return(with_fx(tree, fx_lt_t0)); + if (fn_proc(p) == g_less_xi) + return(with_fx(tree, (integer(caddr(p)) == 2) ? fx_lt_t2 : ((integer(caddr(p)) == 1) ? fx_lt_t1 : fx_lt_ti))); + if (fn_proc(p) == g_geq_xf) return(with_fx(tree, fx_geq_tf)); + if (fn_proc(p) == g_geq_xi) return(with_fx(tree, (integer(caddr(p)) == 0) ? fx_geq_t0 : fx_geq_ti)); + if (fn_proc(p) == g_leq_xi) return(with_fx(tree, fx_leq_ti)); + if (fn_proc(p) == g_greater_xi) return(with_fx(tree, fx_gt_ti)); + if (fx_proc(tree) == fx_leq_si) return(with_fx(tree, fx_leq_ti)); + if (fx_proc(tree) == fx_gt_si) return(with_fx(tree, fx_gt_ti)); + + if (fx_proc(tree) == fx_c_sc_direct) /* p_pp cases */ + { + if ((opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pp) && (is_t_integer(caddr(p)))) + return(with_fx(tree, fx_vector_ref_tc)); + if ((opt3_direct(cdr(p)) == (s7_pointer)string_ref_p_pp) && (is_t_integer(caddr(p))) && (integer(caddr(p)) == 0)) + set_opt3_direct(cdr(p), string_ref_p_p0); + return(with_fx(tree, fx_c_tc_direct)); + } + if (fx_proc(tree) == fx_c_si_direct) /* p_pi cases */ + { + if (opt3_direct(cdr(p)) == (s7_pointer)vector_ref_p_pi) + return(with_fx(tree, fx_vector_ref_tc)); + if ((opt3_direct(cdr(p)) == (s7_pointer)string_ref_p_pi) && (integer(caddr(p)) == 0)) + set_opt3_direct(cdr(p), string_ref_p_p0); + return(with_fx(tree, (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pi) ? fx_c_ti_remainder : fx_c_ti_direct)); + } + + if (fx_proc(tree) == fx_is_eq_sc) return(with_fx(tree, fx_is_eq_tc)); + if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_t1)); + if (fx_proc(tree) == fx_add_si) return(with_fx(tree, fx_add_ti)); + if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_t1)); + if (fx_proc(tree) == fx_subtract_si) return(with_fx(tree, fx_subtract_ti)); + if (fx_proc(tree) == fx_subtract_sf) return(with_fx(tree, fx_subtract_tf)); + if (fx_proc(tree) == fx_multiply_sf) return(with_fx(tree, fx_multiply_tf)); + if (fx_proc(tree) == fx_multiply_si) return(with_fx(tree, fx_multiply_ti)); + if (fx_proc(tree) == fx_lt_si) /* is this ever hit? */ + return(with_fx(tree, (integer(caddr(p)) == 2) ? fx_lt_t2 : ((integer(caddr(p)) == 1) ? fx_lt_t1 : fx_lt_ti))); + if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_ti)); + if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_t0)); + if (fx_proc(tree) == fx_memq_sc) return(with_fx(tree, fx_memq_tc)); + return(false); + } if (cadr(p) == var2) - { - if (fx_proc(tree) == fx_c_sc) return(with_fx(tree, fx_c_uc)); - if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_u0)); - if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_ui)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_u1)); - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_u1)); - if (fx_proc(tree) == fx_subtract_si) return(with_fx(tree, fx_subtract_ui)); - if (fx_proc(tree) == fx_multiply_si) return(with_fx(tree, fx_multiply_ui)); - if (fx_proc(tree) == fx_is_eq_sc) return(with_fx(tree, fx_is_eq_uc)); - if (fx_proc(tree) == fx_leq_si) return(with_fx(tree, fx_leq_ui)); - if (fx_proc(tree) == fx_gt_si) return(with_fx(tree, fx_gt_ui)); - return(false); - } + { + if (fx_proc(tree) == fx_c_sc) return(with_fx(tree, fx_c_uc)); + if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_u0)); + if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_ui)); + if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_u1)); + if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_u1)); + if (fx_proc(tree) == fx_subtract_si) return(with_fx(tree, fx_subtract_ui)); + if (fx_proc(tree) == fx_multiply_si) return(with_fx(tree, fx_multiply_ui)); + if (fx_proc(tree) == fx_is_eq_sc) return(with_fx(tree, fx_is_eq_uc)); + if (fx_proc(tree) == fx_leq_si) return(with_fx(tree, fx_leq_ui)); + if (fx_proc(tree) == fx_gt_si) return(with_fx(tree, fx_gt_ui)); + return(false); + } if (cadr(p) == var3) - { - if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_v0)); - if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_vi)); - if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_v1)); - if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_v1)); - if (fx_proc(tree) == fx_leq_si) return(with_fx(tree, fx_leq_vi)); - if (fx_proc(tree) == fx_c_sc) return(with_fx(tree, fx_c_vc)); - return(false); - } + { + if (fx_proc(tree) == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_v0)); + if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_vi)); + if (fx_proc(tree) == fx_add_s1) return(with_fx(tree, fx_add_v1)); + if (fx_proc(tree) == fx_subtract_s1) return(with_fx(tree, fx_subtract_v1)); + if (fx_proc(tree) == fx_leq_si) return(with_fx(tree, fx_leq_vi)); + if (fx_proc(tree) == fx_c_sc) return(with_fx(tree, fx_c_vc)); + return(false); + } if (!more_vars) - { - if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_oi)); - if ((fx_proc(tree) == fx_c_sc) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_c_oc)); - } + { + if (fx_proc(tree) == fx_num_eq_si) return(with_fx(tree, fx_num_eq_oi)); + if ((fx_proc(tree) == fx_c_sc) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_c_oc)); + } break; case HOP_SAFE_C_CS: if (caddr(p) == var1) - { - if ((car(p) == sc->cons_symbol) && (is_unchanged_global(sc->cons_symbol))) return(with_fx(tree, fx_cons_ct)); - if (fx_proc(tree) == fx_multiply_is) return(with_fx(tree, fx_multiply_it)); - if (fx_proc(tree) == fx_add_fs) return(with_fx(tree, fx_add_ft)); - if (fx_proc(tree) == fx_c_cs) - { - if (is_global_and_has_func(car(p), s7_p_pp_function)) - { - if (fn_proc(p) == g_tree_set_memq_syms) - set_opt3_direct(cdr(p), (s7_pointer)tree_set_memq_syms_direct); - else set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_fx_direct(tree, fx_c_ct_direct); - } - else set_fx_direct(tree, fx_c_ct); - return(true); - }} + { + if ((car(p) == sc->cons_symbol) && (is_unchanged_global(sc->cons_symbol))) return(with_fx(tree, fx_cons_ct)); + if (fx_proc(tree) == fx_multiply_is) return(with_fx(tree, fx_multiply_it)); + if (fx_proc(tree) == fx_add_fs) return(with_fx(tree, fx_add_ft)); + if (fx_proc(tree) == fx_c_cs) + { + if (is_global_and_has_func(car(p), s7_p_pp_function)) + { + if (fn_proc(p) == g_tree_set_memq_syms) + set_opt3_direct(cdr(p), (s7_pointer)tree_set_memq_syms_direct); + else set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(car(p))))); + set_fx_direct(tree, fx_c_ct_direct); + } + else set_fx_direct(tree, fx_c_ct); + return(true); + }} if ((caddr(p) == var2) && (fx_proc(tree) == fx_c_cs)) return(with_fx(tree, fx_c_cu)); break; case HOP_SAFE_C_SS: if (cadr(p) == var1) - { - if (fx_proc(tree) == fx_c_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_c_tu : fx_c_ts)); - if (fx_proc(tree) == fx_c_ss_direct) return(with_fx(tree, (caddr(p) == var2) ? fx_c_tu_direct : fx_c_ts_direct)); - if (fx_proc(tree) == fx_add_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_add_tu : fx_add_ts)); - if (fx_proc(tree) == fx_subtract_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_subtract_tu : fx_subtract_ts)); - if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_cons_tu : fx_cons_ts)); - if (caddr(p) == var2) - { - if (fx_proc(tree) == fx_gt_ss) return(with_fx(tree, fx_gt_tu)); - if (fx_proc(tree) == fx_lt_ss) return(with_fx(tree, fx_lt_tu)); - if (fx_proc(tree) == fx_leq_ss) return(with_fx(tree, fx_leq_tu)); - if (fx_proc(tree) == fx_geq_ss) return(with_fx(tree, fx_geq_tu)); - if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_tu)); - if (fx_proc(tree) == fx_num_eq_ss) return(with_fx(tree, fx_num_eq_tu)); - if (fx_proc(tree) == fx_memq_ss) return(with_fx(tree, fx_memq_tu)); - } - if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_ts)); - if (fx_proc(tree) == fx_num_eq_ss) - { - if (caddr(p) == var3) return(with_fx(tree, fx_num_eq_tv)); - if (is_global(caddr(p))) return(with_fx(tree, fx_num_eq_tg)); - if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_num_eq_to)); - return(with_fx(tree, fx_num_eq_ts)); - } - if (fx_proc(tree) == fx_geq_ss) - { - if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_geq_to)); - return(with_fx(tree, fx_geq_ts)); - } - if (fx_proc(tree) == fx_leq_ss) return(with_fx(tree, fx_leq_ts)); - if (fx_proc(tree) == fx_lt_ss) return(with_fx(tree, fx_lt_ts)); - if (fx_proc(tree) == fx_lt_sg) return(with_fx(tree, fx_lt_tg)); - if (fx_proc(tree) == fx_gt_ss) - { - if (is_global(caddr(p))) return(with_fx(tree, fx_gt_tg)); - if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_gt_to)); - return(with_fx(tree, fx_gt_ts)); - } - if (fx_proc(tree) == fx_sqr_s) return(with_fx(tree, fx_sqr_t)); - if (fx_proc(tree) == fx_is_eq_ss) - { - if (caddr(p) == var2) return(with_fx(tree, fx_is_eq_tu)); - if ((!more_vars) && (caddr(p) != var3) && (caddr(p) != var1)) return(with_fx(tree, fx_is_eq_to)); - return(with_fx(tree, fx_is_eq_ts)); - } - if (fx_proc(tree) == fx_vref_ss) - { - if (caddr(p) == var2) return(with_fx(tree, fx_vref_tu)); - return(with_fx(tree, fx_vref_ts)); - }} + { + if (fx_proc(tree) == fx_c_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_c_tu : fx_c_ts)); + if (fx_proc(tree) == fx_c_ss_direct) return(with_fx(tree, (caddr(p) == var2) ? fx_c_tu_direct : fx_c_ts_direct)); + if (fx_proc(tree) == fx_add_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_add_tu : fx_add_ts)); + if (fx_proc(tree) == fx_subtract_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_subtract_tu : fx_subtract_ts)); + if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, (caddr(p) == var2) ? fx_cons_tu : fx_cons_ts)); + if (caddr(p) == var2) + { + if (fx_proc(tree) == fx_gt_ss) return(with_fx(tree, fx_gt_tu)); + if (fx_proc(tree) == fx_lt_ss) return(with_fx(tree, fx_lt_tu)); + if (fx_proc(tree) == fx_leq_ss) return(with_fx(tree, fx_leq_tu)); + if (fx_proc(tree) == fx_geq_ss) return(with_fx(tree, fx_geq_tu)); + if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_tu)); + if (fx_proc(tree) == fx_num_eq_ss) return(with_fx(tree, fx_num_eq_tu)); + if (fx_proc(tree) == fx_memq_ss) return(with_fx(tree, fx_memq_tu)); + } + if (fx_proc(tree) == fx_multiply_ss) return(with_fx(tree, fx_multiply_ts)); + if (fx_proc(tree) == fx_num_eq_ss) + { + if (caddr(p) == var3) return(with_fx(tree, fx_num_eq_tv)); + if (is_global(caddr(p))) return(with_fx(tree, fx_num_eq_tg)); + if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_num_eq_to)); + return(with_fx(tree, fx_num_eq_ts)); + } + if (fx_proc(tree) == fx_geq_ss) + { + if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_geq_to)); + return(with_fx(tree, fx_geq_ts)); + } + if (fx_proc(tree) == fx_leq_ss) return(with_fx(tree, fx_leq_ts)); + if (fx_proc(tree) == fx_lt_ss) return(with_fx(tree, fx_lt_ts)); + if (fx_proc(tree) == fx_lt_sg) return(with_fx(tree, fx_lt_tg)); + if (fx_proc(tree) == fx_gt_ss) + { + if (is_global(caddr(p))) return(with_fx(tree, fx_gt_tg)); + if ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) return(with_fx(tree, fx_gt_to)); + return(with_fx(tree, fx_gt_ts)); + } + if (fx_proc(tree) == fx_sqr_s) return(with_fx(tree, fx_sqr_t)); + if (fx_proc(tree) == fx_is_eq_ss) + { + if (caddr(p) == var2) return(with_fx(tree, fx_is_eq_tu)); + if ((!more_vars) && (caddr(p) != var3) && (caddr(p) != var1)) return(with_fx(tree, fx_is_eq_to)); + return(with_fx(tree, fx_is_eq_ts)); + } + if (fx_proc(tree) == fx_vref_ss) + { + if (caddr(p) == var2) return(with_fx(tree, fx_vref_tu)); + return(with_fx(tree, fx_vref_ts)); + }} if (caddr(p) == var1) - { - if (fx_proc(tree) == fx_c_ss) return(with_fx(tree, fx_c_st)); - if (fx_proc(tree) == fx_c_ss_direct) {return(with_fx(tree, (is_global(cadr(p))) ? fx_c_gt_direct : fx_c_st_direct));} - if (fx_proc(tree) == fx_hash_table_ref_ss) return(with_fx(tree, fx_hash_table_ref_st)); - if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, fx_cons_st)); - if (fx_proc(tree) == fx_vref_ss) - { - if (is_global(cadr(p))) return(with_fx(tree, fx_vref_gt)); - if ((!more_vars) && (cadr(p) != var2) && (cadr(p) != var3)) return(with_fx(tree, fx_vref_ot)); - return(with_fx(tree, fx_vref_st)); - } - if ((fx_proc(tree) == fx_gt_ss) && (cadr(p) == var2)) return(with_fx(tree, fx_gt_ut)); - if ((fx_proc(tree) == fx_lt_ss) && (cadr(p) == var2)) return(with_fx(tree, fx_lt_ut)); - if ((fx_proc(tree) == fx_geq_ss)) - { - if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_geq_ot)); - return(with_fx(tree, fx_geq_st)); - }} + { + if (fx_proc(tree) == fx_c_ss) return(with_fx(tree, fx_c_st)); + if (fx_proc(tree) == fx_c_ss_direct) {return(with_fx(tree, (is_global(cadr(p))) ? fx_c_gt_direct : fx_c_st_direct));} + if (fx_proc(tree) == fx_hash_table_ref_ss) return(with_fx(tree, fx_hash_table_ref_st)); + if (fx_proc(tree) == fx_cons_ss) return(with_fx(tree, fx_cons_st)); + if (fx_proc(tree) == fx_vref_ss) + { + if (is_global(cadr(p))) return(with_fx(tree, fx_vref_gt)); + if ((!more_vars) && (cadr(p) != var2) && (cadr(p) != var3)) return(with_fx(tree, fx_vref_ot)); + return(with_fx(tree, fx_vref_st)); + } + if ((fx_proc(tree) == fx_gt_ss) && (cadr(p) == var2)) return(with_fx(tree, fx_gt_ut)); + if ((fx_proc(tree) == fx_lt_ss) && (cadr(p) == var2)) return(with_fx(tree, fx_lt_ut)); + if ((fx_proc(tree) == fx_geq_ss)) + { + if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_geq_ot)); + return(with_fx(tree, fx_geq_st)); + }} if (cadr(p) == var2) - { - if (fx_proc(tree) == fx_num_eq_ss) return(with_fx(tree, (caddr(p) == var1) ? fx_num_eq_ut : fx_num_eq_us)); - if (fx_proc(tree) == fx_geq_ss) return(with_fx(tree, fx_geq_us)); - if (fx_proc(tree) == fx_add_ss) return(with_fx(tree, (caddr(p) == var1) ? fx_add_ut : ((caddr(p) == var3) ? fx_add_uv : fx_add_us))); - if (fx_proc(tree) == fx_subtract_ss) return(with_fx(tree, (caddr(p) == var1) ? fx_subtract_ut : fx_subtract_us)); - if (caddr(p) == var3) return(with_fx(tree, fx_c_uv)); - } + { + if (fx_proc(tree) == fx_num_eq_ss) return(with_fx(tree, (caddr(p) == var1) ? fx_num_eq_ut : fx_num_eq_us)); + if (fx_proc(tree) == fx_geq_ss) return(with_fx(tree, fx_geq_us)); + if (fx_proc(tree) == fx_add_ss) return(with_fx(tree, (caddr(p) == var1) ? fx_add_ut : ((caddr(p) == var3) ? fx_add_uv : fx_add_us))); + if (fx_proc(tree) == fx_subtract_ss) return(with_fx(tree, (caddr(p) == var1) ? fx_subtract_ut : fx_subtract_us)); + if (caddr(p) == var3) return(with_fx(tree, fx_c_uv)); + } if ((caddr(p) == var2) && (fx_proc(tree) == fx_sref_ss)) return(with_fx(tree, fx_sref_su)); if (cadr(p) == var3) - { - if (fx_proc(tree) == fx_num_eq_ss) return(with_fx(tree, fx_num_eq_vs)); - if ((fx_proc(tree) == fx_add_ss) && (caddr(p) == var2)) return(with_fx(tree, fx_add_vu)); - if (fx_proc(tree) == fx_geq_ss) return(with_fx(tree, ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) ? fx_geq_vo : fx_geq_vs)); - } + { + if (fx_proc(tree) == fx_num_eq_ss) return(with_fx(tree, fx_num_eq_vs)); + if ((fx_proc(tree) == fx_add_ss) && (caddr(p) == var2)) return(with_fx(tree, fx_add_vu)); + if (fx_proc(tree) == fx_geq_ss) return(with_fx(tree, ((!more_vars) && (o_var_ok(caddr(p), var1, var2, var3))) ? fx_geq_vo : fx_geq_vs)); + } break; case HOP_SAFE_C_AS: @@ -58334,30 +58334,30 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point case HOP_SAFE_C_SA: if (cadr(p) == var1) - { - if ((fx_proc(cddr(p)) == fx_c_opsq_c) && - (cadadr(caddr(p)) == var1) && - (is_t_integer(caddaddr(p))) && - (integer(caddaddr(p)) == 1) && - (car(p) == sc->string_ref_symbol) && - (caaddr(p) == sc->subtract_symbol) && + { + if ((fx_proc(cddr(p)) == fx_c_opsq_c) && + (cadadr(caddr(p)) == var1) && + (is_t_integer(caddaddr(p))) && + (integer(caddaddr(p)) == 1) && + (car(p) == sc->string_ref_symbol) && + (caaddr(p) == sc->subtract_symbol) && #if (!WITH_PURE_S7) - ((caadr(caddr(p)) == sc->string_length_symbol) || (caadr(caddr(p)) == sc->length_symbol))) + ((caadr(caddr(p)) == sc->string_length_symbol) || (caadr(caddr(p)) == sc->length_symbol))) #else - (caadr(caddr(p)) == sc->length_symbol)) + (caadr(caddr(p)) == sc->length_symbol)) #endif - return(with_fx(tree, fx_sref_t_last)); - return(with_fx(tree, fx_c_ta)); - } + return(with_fx(tree, fx_sref_t_last)); + return(with_fx(tree, fx_c_ta)); + } if (cadr(p) == var2) return(with_fx(tree, (fx_proc(tree) == fx_c_sa_direct) ? fx_c_ua_direct : fx_c_ua)); break; case HOP_SAFE_C_SCS: if (cadr(p) == var1) - { - if (fx_proc(tree) == fx_c_scs) return(with_fx(tree, fx_c_tcs)); - if (fx_proc(tree) == fx_c_scs_direct) return(with_fx(tree, (cadddr(p) == var2) ? fx_c_tcu_direct : fx_c_tcs_direct)); - } + { + if (fx_proc(tree) == fx_c_scs) return(with_fx(tree, fx_c_tcs)); + if (fx_proc(tree) == fx_c_scs_direct) return(with_fx(tree, (cadddr(p) == var2) ? fx_c_tcu_direct : fx_c_tcs_direct)); + } break; case HOP_SAFE_C_SSC: @@ -58370,16 +58370,16 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point case HOP_SAFE_C_SSS: if ((cadr(p) == var1) && ((caddr(p) == var2) && ((fx_proc(tree) == fx_c_sss) || (fx_proc(tree) == fx_c_sss_direct)))) - return(with_fx(tree, (cadddr(p) == var3) ? ((fx_proc(tree) == fx_c_sss_direct) ? fx_c_tuv_direct : fx_c_tuv) : fx_c_tus)); + return(with_fx(tree, (cadddr(p) == var3) ? ((fx_proc(tree) == fx_c_sss_direct) ? fx_c_tuv_direct : fx_c_tuv) : fx_c_tus)); if (caddr(p) == var1) - { - if (car(p) == sc->vector_set_symbol) - { - if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3)) && (o_var_ok(cadddr(p), var1, var2, var3))) return(with_fx(tree, fx_vset_oto)); - return(with_fx(tree, fx_vset_sts)); - } - return(with_fx(tree, fx_c_sts)); - } + { + if (car(p) == sc->vector_set_symbol) + { + if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3)) && (o_var_ok(cadddr(p), var1, var2, var3))) return(with_fx(tree, fx_vset_oto)); + return(with_fx(tree, fx_vset_sts)); + } + return(with_fx(tree, fx_c_sts)); + } break; case HOP_SAFE_C_SSA: @@ -58389,225 +58389,225 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point case HOP_SAFE_C_opSq: if (cadadr(p) == var1) - { - if (fx_proc(tree) == fx_is_pair_car_s) return(with_fx(tree, fx_is_pair_car_t)); - if (fx_proc(tree) == fx_is_pair_cdr_s) return(with_fx(tree, fx_is_pair_cdr_t)); - if (fx_proc(tree) == fx_is_pair_cadr_s) return(with_fx(tree, fx_is_pair_cadr_t)); - if (fx_proc(tree) == fx_is_symbol_cadr_s) return(with_fx(tree, fx_is_symbol_cadr_t)); - if (fx_proc(tree) == fx_is_pair_cddr_s) return(with_fx(tree, fx_is_pair_cddr_t)); - if (fx_proc(tree) == fx_is_null_cdr_s) return(with_fx(tree, fx_is_null_cdr_t)); - if (fx_proc(tree) == fx_is_null_cadr_s) return(with_fx(tree, fx_is_null_cadr_t)); - if (fx_proc(tree) == fx_is_null_cddr_s) return(with_fx(tree, fx_is_null_cddr_t)); - if (fx_proc(tree) == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_t)); - if (fx_proc(tree) == fx_not_is_null_s) return(with_fx(tree, fx_not_is_null_t)); - if (fx_proc(tree) == fx_not_is_symbol_s) return(with_fx(tree, fx_not_is_symbol_t)); - if (fx_proc(tree) == fx_is_type_car_s) - return(with_fx(tree, (car(p) == sc->is_symbol_symbol) ? fx_is_symbol_car_t : fx_is_type_car_t)); - if (fx_proc(tree) == fx_c_opsq) - { - set_opt1_sym(cdr(p), cadadr(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_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - return(with_fx(tree, fx_c_optq_direct)); - } - return(with_fx(tree, fx_c_optq)); - } - if (fx_proc(tree) == fx_c_car_s) return(with_fx(tree, fx_c_car_t)); - if (fx_proc(tree) == fx_c_cdr_s) return(with_fx(tree, fx_c_cdr_t)); - if (fx_proc(tree) == fx_is_type_opsq) return(with_fx(tree, fx_is_type_optq)); - if (fx_proc(tree) == fx_not_opsq) - { - set_opt3_sym(p, cadadr(p)); - return(with_fx(tree, (caadr(p) == sc->car_symbol) ? fx_not_car_t : fx_not_optq)); - }} + { + if (fx_proc(tree) == fx_is_pair_car_s) return(with_fx(tree, fx_is_pair_car_t)); + if (fx_proc(tree) == fx_is_pair_cdr_s) return(with_fx(tree, fx_is_pair_cdr_t)); + if (fx_proc(tree) == fx_is_pair_cadr_s) return(with_fx(tree, fx_is_pair_cadr_t)); + if (fx_proc(tree) == fx_is_symbol_cadr_s) return(with_fx(tree, fx_is_symbol_cadr_t)); + if (fx_proc(tree) == fx_is_pair_cddr_s) return(with_fx(tree, fx_is_pair_cddr_t)); + if (fx_proc(tree) == fx_is_null_cdr_s) return(with_fx(tree, fx_is_null_cdr_t)); + if (fx_proc(tree) == fx_is_null_cadr_s) return(with_fx(tree, fx_is_null_cadr_t)); + if (fx_proc(tree) == fx_is_null_cddr_s) return(with_fx(tree, fx_is_null_cddr_t)); + if (fx_proc(tree) == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_t)); + if (fx_proc(tree) == fx_not_is_null_s) return(with_fx(tree, fx_not_is_null_t)); + if (fx_proc(tree) == fx_not_is_symbol_s) return(with_fx(tree, fx_not_is_symbol_t)); + if (fx_proc(tree) == fx_is_type_car_s) + return(with_fx(tree, (car(p) == sc->is_symbol_symbol) ? fx_is_symbol_car_t : fx_is_type_car_t)); + if (fx_proc(tree) == fx_c_opsq) + { + set_opt1_sym(cdr(p), cadadr(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_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(car(p))))); + set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); + return(with_fx(tree, fx_c_optq_direct)); + } + return(with_fx(tree, fx_c_optq)); + } + if (fx_proc(tree) == fx_c_car_s) return(with_fx(tree, fx_c_car_t)); + if (fx_proc(tree) == fx_c_cdr_s) return(with_fx(tree, fx_c_cdr_t)); + if (fx_proc(tree) == fx_is_type_opsq) return(with_fx(tree, fx_is_type_optq)); + if (fx_proc(tree) == fx_not_opsq) + { + set_opt3_sym(p, cadadr(p)); + return(with_fx(tree, (caadr(p) == sc->car_symbol) ? fx_not_car_t : fx_not_optq)); + }} if (cadadr(p) == var2) - { - if (fx_proc(tree) == fx_c_car_s) return(with_fx(tree, fx_c_car_u)); - if (fx_proc(tree) == fx_not_is_null_s) return(with_fx(tree, fx_not_is_null_u)); - if (fx_proc(tree) == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_u)); - if (fx_proc(tree) == fx_is_pair_cdr_s) return(with_fx(tree, fx_is_pair_cdr_u)); - } + { + if (fx_proc(tree) == fx_c_car_s) return(with_fx(tree, fx_c_car_u)); + if (fx_proc(tree) == fx_not_is_null_s) return(with_fx(tree, fx_not_is_null_u)); + if (fx_proc(tree) == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_u)); + if (fx_proc(tree) == fx_is_pair_cdr_s) return(with_fx(tree, fx_is_pair_cdr_u)); + } if (cadadr(p) == var3) - { - if (fx_proc(tree) == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_v)); - } + { + if (fx_proc(tree) == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_v)); + } break; case HOP_SAFE_C_opSq_S: if (cadadr(p) == var1) - { - if (fx_proc(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(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - return(with_fx(tree, fx_c_optq_s_direct)); - } - return(with_fx(tree, fx_c_optq_s)); - } - if (fx_proc(tree) == fx_c_opsq_s_direct) return(with_fx(tree, fx_c_optq_s_direct)); - if (fx_proc(tree) == fx_cons_car_s_s) - { - set_opt1_sym(cdr(p), var1); - return(with_fx(tree, (caddr(p) == var3) ? fx_cons_car_t_v : fx_cons_car_t_s)); - }} + { + if (fx_proc(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(global_value(car(p))))); + set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); + return(with_fx(tree, fx_c_optq_s_direct)); + } + return(with_fx(tree, fx_c_optq_s)); + } + if (fx_proc(tree) == fx_c_opsq_s_direct) return(with_fx(tree, fx_c_optq_s_direct)); + if (fx_proc(tree) == fx_cons_car_s_s) + { + set_opt1_sym(cdr(p), var1); + return(with_fx(tree, (caddr(p) == var3) ? fx_cons_car_t_v : fx_cons_car_t_s)); + }} if (cadadr(p) == var2) - { - if ((fx_proc(tree) == fx_c_opsq_s) && (caddr(p) == var1)) - { - 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_opt2_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - return(with_fx(tree, (car(p) == sc->cons_symbol) ? - ((caadr(p) == sc->car_symbol) ? fx_cons_car_u_t : fx_cons_opuq_t) : fx_c_opuq_t_direct)); - } - return(with_fx(tree, fx_c_opuq_t)); - } - if (((fx_proc(tree) == fx_c_opsq_s_direct) || (fx_proc(tree) == fx_cons_car_s_s)) && - (caddr(p) == var1)) - return(with_fx(tree, (car(p) == sc->cons_symbol) ? - ((caadr(p) == sc->car_symbol) ? fx_cons_car_u_t : fx_cons_opuq_t) : fx_c_opuq_t_direct)); - } + { + if ((fx_proc(tree) == fx_c_opsq_s) && (caddr(p) == var1)) + { + 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_opt2_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(car(p))))); + set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); + return(with_fx(tree, (car(p) == sc->cons_symbol) ? + ((caadr(p) == sc->car_symbol) ? fx_cons_car_u_t : fx_cons_opuq_t) : fx_c_opuq_t_direct)); + } + return(with_fx(tree, fx_c_opuq_t)); + } + if (((fx_proc(tree) == fx_c_opsq_s_direct) || (fx_proc(tree) == fx_cons_car_s_s)) && + (caddr(p) == var1)) + return(with_fx(tree, (car(p) == sc->cons_symbol) ? + ((caadr(p) == sc->car_symbol) ? fx_cons_car_u_t : fx_cons_opuq_t) : fx_c_opuq_t_direct)); + } break; case HOP_SAFE_C_S_opSq: if (cadr(p) == var1) - { - if (cadaddr(p) == var2) - { - if (fx_proc(tree) == fx_c_s_car_s) return(with_fx(tree, fx_c_t_car_u)); - if (fx_proc(tree) == fx_c_s_opsq_direct) return(with_fx(tree, fx_c_t_opuq_direct)); - } - if (cadaddr(p) == var3) - { - if (fx_proc(tree) == fx_add_s_car_s) return(with_fx(tree, fx_add_t_car_v)); - if (fx_proc(tree) == fx_c_s_car_s) return(with_fx(tree, fx_c_t_car_v)); /* ideally eq_p_pp not g_is_eq */ - } - if (fx_proc(tree) == fx_c_s_opsq_direct) return(with_fx(tree, fx_c_t_opsq_direct)); - } + { + if (cadaddr(p) == var2) + { + if (fx_proc(tree) == fx_c_s_car_s) return(with_fx(tree, fx_c_t_car_u)); + if (fx_proc(tree) == fx_c_s_opsq_direct) return(with_fx(tree, fx_c_t_opuq_direct)); + } + if (cadaddr(p) == var3) + { + if (fx_proc(tree) == fx_add_s_car_s) return(with_fx(tree, fx_add_t_car_v)); + if (fx_proc(tree) == fx_c_s_car_s) return(with_fx(tree, fx_c_t_car_v)); /* ideally eq_p_pp not g_is_eq */ + } + if (fx_proc(tree) == fx_c_s_opsq_direct) return(with_fx(tree, fx_c_t_opsq_direct)); + } if (cadr(p) == var2) - { - if ((fx_proc(tree) == fx_add_s_car_s) && (cadaddr(p) == var1)) return(with_fx(tree, fx_add_u_car_t)); - if ((fx_proc(tree) == fx_c_s_opsq_direct) && (cadaddr(p) == var3)) return(with_fx(tree, fx_c_u_opvq_direct)); - } + { + if ((fx_proc(tree) == fx_add_s_car_s) && (cadaddr(p) == var1)) return(with_fx(tree, fx_add_u_car_t)); + if ((fx_proc(tree) == fx_c_s_opsq_direct) && (cadaddr(p) == var3)) return(with_fx(tree, fx_c_u_opvq_direct)); + } if ((cadaddr(p) == var1) && (fx_proc(tree) == fx_c_s_car_s)) return(with_fx(tree, fx_c_s_car_t)); break; case HOP_SAFE_C_opSq_opSq: if ((fx_proc(tree) == fx_c_opsq_opsq_direct) && (cadadr(p) == var1) && (cadadr(p) == cadaddr(p))) - { - set_opt1_sym(cdr(p), cadadr(p)); - return(with_fx(tree, fx_c_optq_optq_direct)); /* opuq got few hits */ - } + { + set_opt1_sym(cdr(p), cadadr(p)); + return(with_fx(tree, fx_c_optq_optq_direct)); /* opuq got few hits */ + } if (((fx_proc(tree) == fx_c_opsq_opsq_direct) || (fx_proc(tree) == fx_car_s_car_s)) && - ((caadr(p) == sc->car_symbol) && (caadr(p) == caaddr(p)))) - { - set_opt1_sym(cdr(p), cadadr(p)); - set_opt2_sym(cdr(p), cadaddr(p)); - return(with_fx(tree, ((cadadr(p) == var1) && (cadaddr(p) == var2)) ? - ((opt3_direct(p) == (s7_pointer)is_eq_p_pp) ? fx_is_eq_car_car_tu : fx_car_t_car_u) : fx_car_s_car_s)); - } + ((caadr(p) == sc->car_symbol) && (caadr(p) == caaddr(p)))) + { + set_opt1_sym(cdr(p), cadadr(p)); + set_opt2_sym(cdr(p), cadaddr(p)); + return(with_fx(tree, ((cadadr(p) == var1) && (cadaddr(p) == var2)) ? + ((opt3_direct(p) == (s7_pointer)is_eq_p_pp) ? fx_is_eq_car_car_tu : fx_car_t_car_u) : fx_car_s_car_s)); + } break; case HOP_SAFE_C_opSq_C: if (cadadr(p) == var1) - { - if (fx_proc(tree) == fx_is_eq_car_sq) return(with_fx(tree, fx_is_eq_car_tq)); - if ((fx_proc(tree) == fx_c_opsq_c) || (fx_proc(tree) == fx_c_optq_c)) - { - if (fn_proc(p) != g_simple_let_ref) /* don't step on opt3_sym */ - { - if ((is_global_and_has_func(car(p), s7_p_pp_function)) && - (is_global_and_has_func(caadr(p), s7_p_p_function))) - { - if (fn_proc(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(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - set_fx_direct(tree, fx_c_optq_c_direct); - return(true); - } - if ((is_t_integer(caddr(p))) && - (is_global_and_has_func(caadr(p), s7_i_7p_function)) && - (is_global_and_has_func(car(p), s7_p_ii_function))) - { - set_opt3_direct(p, (s7_pointer)(s7_p_ii_function(global_value(car(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_i_7p_function(global_value(caadr(p))))); - set_fx_direct(tree, fx_c_optq_i_direct); - } - else set_fx_direct(tree, fx_c_optq_c); - } - return(true); - }} + { + if (fx_proc(tree) == fx_is_eq_car_sq) return(with_fx(tree, fx_is_eq_car_tq)); + if ((fx_proc(tree) == fx_c_opsq_c) || (fx_proc(tree) == fx_c_optq_c)) + { + if (fn_proc(p) != g_simple_let_ref) /* don't step on opt3_sym */ + { + if ((is_global_and_has_func(car(p), s7_p_pp_function)) && + (is_global_and_has_func(caadr(p), s7_p_p_function))) + { + if (fn_proc(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(global_value(car(p))))); + set_opt3_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); + set_fx_direct(tree, fx_c_optq_c_direct); + return(true); + } + if ((is_t_integer(caddr(p))) && + (is_global_and_has_func(caadr(p), s7_i_7p_function)) && + (is_global_and_has_func(car(p), s7_p_ii_function))) + { + set_opt3_direct(p, (s7_pointer)(s7_p_ii_function(global_value(car(p))))); + set_opt3_direct(cdr(p), (s7_pointer)(s7_i_7p_function(global_value(caadr(p))))); + set_fx_direct(tree, fx_c_optq_i_direct); + } + else set_fx_direct(tree, fx_c_optq_c); + } + return(true); + }} break; case HOP_SAFE_C_opSSq: if (fx_proc(tree) == fx_c_opssq) - { - if (caddadr(p) == var1) return(with_fx(tree, fx_c_opstq)); - if ((cadadr(p) == var1) && (caddadr(p) == var2)) return(with_fx(tree, fx_c_optuq)); - } + { + if (caddadr(p) == var1) return(with_fx(tree, fx_c_opstq)); + if ((cadadr(p) == var1) && (caddadr(p) == var2)) return(with_fx(tree, fx_c_optuq)); + } if (fx_proc(tree) == fx_c_opssq_direct) - { - if ((cadadr(p) == var1) && (caddadr(p) == var2)) return(with_fx(tree, fx_c_optuq_direct)); - if (caddadr(p) == var1) - { - if ((opt2_direct(cdr(p)) == (s7_pointer)is_zero_p_p) && (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pp) && - (!more_vars) && (o_var_ok(cadadr(p), var1, var2, var3))) - return(with_fx(tree, fx_is_zero_remainder_o)); - return(with_fx(tree, fx_c_opstq_direct)); - }} + { + if ((cadadr(p) == var1) && (caddadr(p) == var2)) return(with_fx(tree, fx_c_optuq_direct)); + if (caddadr(p) == var1) + { + if ((opt2_direct(cdr(p)) == (s7_pointer)is_zero_p_p) && (opt3_direct(cdr(p)) == (s7_pointer)remainder_p_pp) && + (!more_vars) && (o_var_ok(cadadr(p), var1, var2, var3))) + return(with_fx(tree, fx_is_zero_remainder_o)); + return(with_fx(tree, fx_c_opstq_direct)); + }} if ((cadadr(p) == var2) && (fx_proc(tree) == fx_not_opssq) && (caddadr(p) == var1)) - { - set_fx_direct(tree, (fn_proc(cadr(p)) == g_less_2) ? fx_not_lt_ut : fx_not_oputq); - return(true); - } + { + set_fx_direct(tree, (fn_proc(cadr(p)) == g_less_2) ? fx_not_lt_ut : fx_not_oputq); + return(true); + } break; case HOP_SAFE_C_opSCq: if (cadadr(p) == var1) - { - if ((fn_proc(p) == g_is_zero) && (fn_proc(cadr(p)) == g_remainder) && - (is_t_integer(caddadr(p))) && (integer(caddadr(p)) > 1)) - return(with_fx(tree, fx_is_zero_remainder_ti)); - return(with_fx(tree, fx_c_optcq)); /* there currently isn't any fx_c_opscq_direct */ - } + { + if ((fn_proc(p) == g_is_zero) && (fn_proc(cadr(p)) == g_remainder) && + (is_t_integer(caddadr(p))) && (integer(caddadr(p)) > 1)) + return(with_fx(tree, fx_is_zero_remainder_ti)); + return(with_fx(tree, fx_c_optcq)); /* there currently isn't any fx_c_opscq_direct */ + } break; case HOP_SAFE_C_opSSq_C: if ((fx_proc(tree) == fx_c_opssq_c) && (caddadr(p) == var1)) - { - if (is_global_and_has_func(car(p), s7_p_pp_function)) - { - if ((car(p) == sc->is_eq_symbol) && (!is_unspecified(caddr(p))) && (caadr(p) == sc->vector_ref_symbol) && - (!more_vars) && (o_var_ok(cadadr(p), var1, var2, var3))) - return(with_fx(tree, fx_is_eq_vref_opotq_c)); - set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - return(with_fx(tree, fx_c_opstq_c_direct)); - } - return(with_fx(tree, fx_c_opstq_c)); - } + { + if (is_global_and_has_func(car(p), s7_p_pp_function)) + { + if ((car(p) == sc->is_eq_symbol) && (!is_unspecified(caddr(p))) && (caadr(p) == sc->vector_ref_symbol) && + (!more_vars) && (o_var_ok(cadadr(p), var1, var2, var3))) + return(with_fx(tree, fx_is_eq_vref_opotq_c)); + set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); + return(with_fx(tree, fx_c_opstq_c_direct)); + } + return(with_fx(tree, fx_c_opstq_c)); + } break; case HOP_SAFE_C_S_opSCq: if (cadr(p) == var1) - { - if (fx_proc(tree) == fx_c_s_opscq_direct) return(with_fx(tree, (cadaddr(p) == var2) ? fx_c_t_opucq_direct : fx_c_t_opscq_direct)); - if ((fx_proc(tree) == fx_c_s_opsiq_direct) && (!more_vars) && (o_var_ok(cadaddr(p), var1, var2, var3))) return(with_fx(tree, fx_c_t_opoiq_direct)); - } + { + if (fx_proc(tree) == fx_c_s_opscq_direct) return(with_fx(tree, (cadaddr(p) == var2) ? fx_c_t_opucq_direct : fx_c_t_opscq_direct)); + if ((fx_proc(tree) == fx_c_s_opsiq_direct) && (!more_vars) && (o_var_ok(cadaddr(p), var1, var2, var3))) return(with_fx(tree, fx_c_t_opoiq_direct)); + } else - if ((cadr(p) == var2) && (cadaddr(p) == var1)) - { - if (fx_proc(tree) == fx_c_s_opsiq_direct) return(with_fx(tree, fx_c_u_optiq_direct)); - if (fx_proc(tree) == fx_c_s_opscq) return(with_fx(tree, fx_c_u_optcq)); - } + if ((cadr(p) == var2) && (cadaddr(p) == var1)) + { + if (fx_proc(tree) == fx_c_s_opsiq_direct) return(with_fx(tree, fx_c_u_optiq_direct)); + if (fx_proc(tree) == fx_c_s_opscq) return(with_fx(tree, fx_c_u_optcq)); + } break; case HOP_SAFE_C_opSq_CS: @@ -58616,67 +58616,67 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point case HOP_SAFE_C_opSq_opSSq: if ((fx_proc(tree) == fx_c_opsq_opssq) && (cadaddr(p) == var1) && (caddaddr(p) == var2) && - (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_opt3_direct(p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); - set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); - set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(caaddr(p))))); - set_opt1_sym(cdr(p), var2); /* caddaddr(p) */ - - set_opt2_sym(cddr(p), var1); - if ((car(p) == sc->num_eq_symbol) && (caadr(p) == sc->car_symbol) && (cadadr(p) == var3)) - { - if (caaddr(p) == sc->add_symbol) return(with_fx(tree, fx_num_eq_car_v_add_tu)); - if (caaddr(p) == sc->subtract_symbol) return(with_fx(tree, fx_num_eq_car_v_subtract_tu)); - } - return(with_fx(tree, fx_c_opsq_optuq_direct)); - } + (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_opt3_direct(p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); + set_opt2_direct(cdr(p), (s7_pointer)(s7_p_p_function(global_value(caadr(p))))); + set_opt3_direct(cdr(p), (s7_pointer)(s7_p_pp_function(global_value(caaddr(p))))); + set_opt1_sym(cdr(p), var2); /* caddaddr(p) */ + + set_opt2_sym(cddr(p), var1); + if ((car(p) == sc->num_eq_symbol) && (caadr(p) == sc->car_symbol) && (cadadr(p) == var3)) + { + if (caaddr(p) == sc->add_symbol) return(with_fx(tree, fx_num_eq_car_v_add_tu)); + if (caaddr(p) == sc->subtract_symbol) return(with_fx(tree, fx_num_eq_car_v_subtract_tu)); + } + return(with_fx(tree, fx_c_opsq_optuq_direct)); + } break; case HOP_SAFE_C_opSSq_S: if (fx_proc(tree) == fx_vref_vref_ss_s) - { - if ((caddr(p) == var1) && (is_global(cadadr(p)))) - { - if ((!more_vars) && (o_var_ok(caddadr(p), var1, var2, var3))) return(with_fx(tree, fx_vref_vref_go_t)); - return(with_fx(tree, fx_vref_vref_gs_t)); - } - if ((cadadr(p) == var1) && (caddadr(p) == var2) && (caddr(p) == var3)) return(with_fx(tree, fx_vref_vref_tu_v)); - } + { + if ((caddr(p) == var1) && (is_global(cadadr(p)))) + { + if ((!more_vars) && (o_var_ok(caddadr(p), var1, var2, var3))) return(with_fx(tree, fx_vref_vref_go_t)); + return(with_fx(tree, fx_vref_vref_gs_t)); + } + if ((cadadr(p) == var1) && (caddadr(p) == var2) && (caddr(p) == var3)) return(with_fx(tree, fx_vref_vref_tu_v)); + } if ((fx_proc(tree) == fx_gt_add_s) && (cadadr(p) == var1) && (caddadr(p) == var2)) - return(with_fx(tree, fx_gt_add_tu_s)); + return(with_fx(tree, fx_gt_add_tu_s)); if ((fx_proc(tree) == fx_add_sub_s) && (cadadr(p) == var1) && (caddadr(p) == var2)) - return(with_fx(tree, fx_add_sub_tu_s)); + return(with_fx(tree, fx_add_sub_tu_s)); break; case HOP_SAFE_C_S_opSSq: if (caddaddr(p) == var1) - { - if ((fn_proc(p) == g_vector_ref_2) && (is_global(cadr(p)) && (is_global(cadaddr(p))))) - { - set_opt3_pair(p, cdaddr(p)); - return(with_fx(tree, fx_vref_g_vref_gt)); - } - if (fx_proc(tree) == fx_c_s_opssq_direct) return(with_fx(tree, fx_c_s_opstq_direct)); - } + { + if ((fn_proc(p) == g_vector_ref_2) && (is_global(cadr(p)) && (is_global(cadaddr(p))))) + { + set_opt3_pair(p, cdaddr(p)); + return(with_fx(tree, fx_vref_g_vref_gt)); + } + if (fx_proc(tree) == fx_c_s_opssq_direct) return(with_fx(tree, fx_c_s_opstq_direct)); + } if ((fx_proc(tree) == fx_c_s_opssq_direct) && (cadr(p) == var1) && (caddaddr(p) == var2)) return(with_fx(tree, fx_c_t_opsuq_direct)); break; case HOP_SAFE_C_op_opSq_Sq: if ((car(p) == sc->not_symbol) && (is_global(sc->not_symbol)) && (var1 == cadr(cadadr(p)))) - return(with_fx(tree, fx_not_op_optq_sq)); + return(with_fx(tree, fx_not_op_optq_sq)); break; case HOP_SAFE_C_AC: if (((fx_proc(tree) == fx_c_ac) || (fx_proc(tree) == fx_c_ac_direct)) && (fn_proc(p) == g_num_eq_xi) && (caddr(p) == int_zero) && - (fx_proc(cdr(p)) == fx_c_opuq_t_direct) && (caadr(p) == sc->remainder_symbol) && (fn_proc(cadadr(p)) == g_car)) - { - set_opt3_sym(p, cadr(cadadr(p))); - set_opt1_sym(cdr(p), caddadr(p)); - return(with_fx(tree, fx_is_zero_remainder_car)); - } + (fx_proc(cdr(p)) == fx_c_opuq_t_direct) && (caadr(p) == sc->remainder_symbol) && (fn_proc(cadadr(p)) == g_car)) + { + set_opt3_sym(p, cadr(cadadr(p))); + set_opt1_sym(cdr(p), caddadr(p)); + return(with_fx(tree, fx_is_zero_remainder_car)); + } break; case HOP_SAFE_CLOSURE_S_A: @@ -58689,17 +58689,17 @@ static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_point case OP_AND_3A: if ((fx_proc(tree) == fx_and_3a) && - (is_pair(cadr(p))) && - (is_pair(cdadr(p))) && (cadadr(p) == var1) && /* so "s" below is "t" */ - (((fx_proc(cdr(p)) == fx_is_pair_t) && (fx_proc(cddr(p)) == fx_is_pair_cdr_t)) || - ((fx_proc(cdr(p)) == fx_is_pair_s) && (fx_proc(cddr(p)) == fx_is_pair_cdr_s)))) - { - set_opt1_sym(cdr(p), cadadr(p)); - if ((fx_proc(cdddr(p)) == fx_is_null_cddr_t) || (fx_proc(cdddr(p)) == fx_is_null_cddr_s)) - return(with_fx(tree, fx_len2_t)); - if ((fx_proc(cdddr(p)) == fx_is_pair_cddr_t) || (fx_proc(cdddr(p)) == fx_is_pair_cddr_s)) - return(with_fx(tree, fx_len3_t)); - } + (is_pair(cadr(p))) && + (is_pair(cdadr(p))) && (cadadr(p) == var1) && /* so "s" below is "t" */ + (((fx_proc(cdr(p)) == fx_is_pair_t) && (fx_proc(cddr(p)) == fx_is_pair_cdr_t)) || + ((fx_proc(cdr(p)) == fx_is_pair_s) && (fx_proc(cddr(p)) == fx_is_pair_cdr_s)))) + { + set_opt1_sym(cdr(p), cadadr(p)); + if ((fx_proc(cdddr(p)) == fx_is_null_cddr_t) || (fx_proc(cdddr(p)) == fx_is_null_cddr_s)) + return(with_fx(tree, fx_len2_t)); + if ((fx_proc(cdddr(p)) == fx_is_pair_cddr_t) || (fx_proc(cdddr(p)) == fx_is_pair_cddr_s)) + return(with_fx(tree, fx_len3_t)); + } break; } return(false); @@ -58713,8 +58713,8 @@ static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer (is_definer_or_binder(car(tree)))) { if ((car(tree) == sc->let_symbol) && (is_pair(cdr(tree))) && (is_pair(cadr(tree))) && - (is_null(cdadr(tree))) && (is_pair(caadr(tree)))) /* (let (a) ...) */ - fx_tree(sc, cddr(tree), caaadr(tree), NULL, NULL, more_vars); + (is_null(cdadr(tree))) && (is_pair(caadr(tree)))) /* (let (a) ...) */ + fx_tree(sc, cddr(tree), caaadr(tree), NULL, NULL, more_vars); return; } if (is_syntax(car(tree))) return; /* someday let #_when/#_if etc through -- the symbol 'if, for example, is not syntax */ @@ -58742,11 +58742,11 @@ static void add_opt_func(s7_scheme *sc, s7_pointer f, opt_func_t typ, void *func opt_funcs_t *op; #if S7_DEBUGGING static const char *o_names[] = {"o_d_v", "o_d_vd", "o_d_vdd", "o_d_vid", "o_d_id", "o_d_7pi", "o_d_7pii", "o_d_7piid", "o_d_7piii", "o_d_7piiid", - "o_d_ip", "o_d_pd", "o_d_7pid", "o_d", "o_d_d", "o_d_dd", "o_d_7dd", "o_d_ddd", "o_d_dddd", - "o_i_i", "o_i_7i", "o_i_ii", "o_i_7ii", "o_i_iii", "o_i_7pi", "o_i_7pii", "o_i_7_piii", "o_d_p", - "o_b_p", "o_b_7p", "o_b_pp", "o_b_7pp", "o_b_pp_unchecked", "o_b_pi", "o_b_ii", "o_b_7ii", "o_b_dd", - "o_p", "o_p_p", "o_p_ii", "o_p_d", "o_p_dd", "o_i_7d", "o_i_7p", "o_d_7d", "o_p_pp", "o_p_ppp", "o_p_pi", "o_p_pi_unchecked", - "o_p_ppi", "o_p_i", "o_p_pii", "o_p_pip", "o_p_pip_unchecked", "o_p_piip", "o_b_i", "o_b_d"}; + "o_d_ip", "o_d_pd", "o_d_7pid", "o_d", "o_d_d", "o_d_dd", "o_d_7dd", "o_d_ddd", "o_d_dddd", + "o_i_i", "o_i_7i", "o_i_ii", "o_i_7ii", "o_i_iii", "o_i_7pi", "o_i_7pii", "o_i_7_piii", "o_d_p", + "o_b_p", "o_b_7p", "o_b_pp", "o_b_7pp", "o_b_pp_unchecked", "o_b_pi", "o_b_ii", "o_b_7ii", "o_b_dd", + "o_p", "o_p_p", "o_p_ii", "o_p_d", "o_p_dd", "o_i_7d", "o_i_7p", "o_d_7d", "o_p_pp", "o_p_ppp", "o_p_pi", "o_p_pi_unchecked", + "o_p_ppi", "o_p_i", "o_p_pii", "o_p_pip", "o_p_pip_unchecked", "o_p_piip", "o_b_i", "o_b_d"}; if (!is_c_function(f)) { fprintf(stderr, "%s[%d]: %s is not a c_function\n", __func__, __LINE__, display(f)); @@ -58755,14 +58755,14 @@ static void add_opt_func(s7_scheme *sc, s7_pointer f, opt_func_t typ, void *func else if (c_function_opt_data(f)) for (opt_funcs_t *p = c_function_opt_data(f); p; p = p->next) - { - if (p->typ == typ) - fprintf(stderr, "%s[%d]: %s has a function of type %d (%s)\n", - __func__, __LINE__, display(f), typ, o_names[typ]); - if (p->func == func) - fprintf(stderr, "%s[%d]: %s already has this function as type %d %s (current: %d %s)\n", - __func__, __LINE__, display(f), p->typ, o_names[p->typ], typ, o_names[typ]); - } + { + if (p->typ == typ) + fprintf(stderr, "%s[%d]: %s has a function of type %d (%s)\n", + __func__, __LINE__, display(f), typ, o_names[typ]); + if (p->func == func) + fprintf(stderr, "%s[%d]: %s already has this function as type %d %s (current: %d %s)\n", + __func__, __LINE__, display(f), p->typ, o_names[p->typ], typ, o_names[typ]); + } #endif op = alloc_semipermanent_opt_func(sc); op->typ = typ; @@ -58776,7 +58776,7 @@ static void *opt_func(s7_pointer f, opt_func_t typ) if (is_c_function(f)) for (opt_funcs_t *p = c_function_opt_data(f); p; p = p->next) if (p->typ == typ) - return(p->func); + return(p->func); return(NULL); } @@ -59013,8 +59013,8 @@ static s7_pointer opt_integer_symbol(s7_scheme *sc, s7_pointer sym) { s7_pointer p = s7_slot(sc, sym); if ((is_slot(p)) && - (is_t_integer(slot_value(p)))) - return(p); + (is_t_integer(slot_value(p)))) + return(p); } return(NULL); } @@ -59025,8 +59025,8 @@ static s7_pointer opt_real_symbol(s7_scheme *sc, s7_pointer sym) { s7_pointer p = s7_slot(sc, sym); if ((is_slot(p)) && - (is_small_real(slot_value(p)))) - return(p); + (is_small_real(slot_value(p)))) + return(p); } return(NULL); } @@ -59037,8 +59037,8 @@ static s7_pointer opt_float_symbol(s7_scheme *sc, s7_pointer sym) { s7_pointer p = s7_slot(sc, sym); if ((is_slot(p)) && - (is_t_real(slot_value(p)))) - return(p); + (is_t_real(slot_value(p)))) + return(p); } return(NULL); } @@ -59060,7 +59060,7 @@ static s7_pointer opt_types_match(s7_scheme *sc, s7_pointer check, s7_pointer sy { s7_pointer obj = slot_value(slot); if (s7_apply_function(sc, checker, set_plist_1(sc, obj)) == sc->T) - return(slot); + return(slot); } return(NULL); } @@ -59141,74 +59141,74 @@ static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if ((func) || (func7)) { if (func) - opc->v[2].i_i_f = func; + opc->v[2].i_i_f = func; else opc->v[2].i_7i_f = func7; if (is_t_integer(arg1)) - { - if (opc->v[2].i_i_f == subtract_i_i) - { - opc->v[1].i = -integer(arg1); - opc->v[0].fi = opt_i_c; - } - else - { - opc->v[1].i = integer(arg1); - opc->v[0].fi = (func) ? opt_i_i_c : opt_i_7i_c; - } - return_true(sc, car_x); - } + { + if (opc->v[2].i_i_f == subtract_i_i) + { + opc->v[1].i = -integer(arg1); + opc->v[0].fi = opt_i_c; + } + else + { + opc->v[1].i = integer(arg1); + opc->v[0].fi = (func) ? opt_i_i_c : opt_i_7i_c; + } + return_true(sc, car_x); + } p = opt_integer_symbol(sc, arg1); if (p) - { - opc->v[1].p = p; - opc->v[0].fi = (func) ? ((func == abs_i_i) ? opt_i_i_s_abs : opt_i_i_s) : ((func7 == random_i_7i) ? opt_i_7i_s_rand : opt_i_7i_s); - return_true(sc, car_x); - } + { + opc->v[1].p = p; + opc->v[0].fi = (func) ? ((func == abs_i_i) ? opt_i_i_s_abs : opt_i_i_s) : ((func7 == random_i_7i) ? opt_i_7i_s_rand : opt_i_7i_s); + return_true(sc, car_x); + } if (int_optimize(sc, cdr(car_x))) - { - opc->v[4].fi = sc->opts[start]->v[0].fi; - opc->v[0].fi = (func) ? ((func == abs_i_i) ? opt_i_i_f_abs : opt_i_i_f) : opt_i_7i_f; - return_true(sc, car_x); - } + { + opc->v[4].fi = sc->opts[start]->v[0].fi; + opc->v[0].fi = (func) ? ((func == abs_i_i) ? opt_i_i_f_abs : opt_i_i_f) : opt_i_7i_f; + return_true(sc, car_x); + } sc->pc = start; } if (!is_t_ratio(arg1)) { s7_i_7d_t idf = s7_i_7d_function(s_func); if (idf) - { - opc->v[2].i_7d_f = idf; - if (is_small_real(arg1)) - { - opc->v[1].x = s7_number_to_real(sc, arg1); - opc->v[0].fi = opt_i_d_c; - return_true(sc, car_x); - } - p = opt_float_symbol(sc, arg1); - if (p) - { - opc->v[1].p = p; - opc->v[0].fi = opt_i_d_s; - return_true(sc, car_x); - } - if (float_optimize(sc, cdr(car_x))) - { - opc->v[0].fi = opt_i_7d_f; - opc->v[4].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - } - sc->pc = start; - }} + { + opc->v[2].i_7d_f = idf; + if (is_small_real(arg1)) + { + opc->v[1].x = s7_number_to_real(sc, arg1); + opc->v[0].fi = opt_i_d_c; + return_true(sc, car_x); + } + p = opt_float_symbol(sc, arg1); + if (p) + { + opc->v[1].p = p; + opc->v[0].fi = opt_i_d_s; + return_true(sc, car_x); + } + if (float_optimize(sc, cdr(car_x))) + { + opc->v[0].fi = opt_i_7d_f; + opc->v[4].fd = sc->opts[start]->v[0].fd; + return_true(sc, car_x); + } + sc->pc = start; + }} ipf = s7_i_7p_function(s_func); if (ipf) { opc->v[2].i_7p_f = ipf; if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fi = (ipf == char_to_integer_i_7p) ? opt_i_7p_f_cint : opt_i_7p_f; - opc->v[4].fp = sc->opts[start]->v[0].fp; - return_true(sc, car_x); - } + { + opc->v[0].fi = (ipf == char_to_integer_i_7p) ? opt_i_7p_f_cint : opt_i_7p_f; + opc->v[4].fp = sc->opts[start]->v[0].fp; + return_true(sc, car_x); + } sc->pc = start; } return_false(sc, car_x); @@ -59229,23 +59229,23 @@ static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (!pfunc) { if ((s_func == initial_value(sc->vector_ref_symbol)) && (is_normal_symbol(cadr(car_x)))) /* (vector-ref <int-vector> <int>)? */ - { - s7_pointer v_slot = s7_slot(sc, cadr(car_x)); - if (is_slot(v_slot)) - { - s7_pointer v = slot_value(v_slot); - if (is_int_vector(v)) - { - pfunc = int_vector_ref_i_7pi; - s_func = initial_value(sc->int_vector_ref_symbol); - /* a normal vector can have vector-typer integer? if it's set after vector creation, but that can't be optimized much */ - } - else - if (is_byte_vector(v)) - { - pfunc = byte_vector_ref_i_7pi; - s_func = initial_value(sc->byte_vector_ref_symbol); - }}} + { + s7_pointer v_slot = s7_slot(sc, cadr(car_x)); + if (is_slot(v_slot)) + { + s7_pointer v = slot_value(v_slot); + if (is_int_vector(v)) + { + pfunc = int_vector_ref_i_7pi; + s_func = initial_value(sc->int_vector_ref_symbol); + /* a normal vector can have vector-typer integer? if it's set after vector creation, but that can't be optimized much */ + } + else + if (is_byte_vector(v)) + { + pfunc = byte_vector_ref_i_7pi; + s_func = initial_value(sc->byte_vector_ref_symbol); + }}} if (!pfunc) return_false(sc, car_x); } sig = c_function_signature(s_func); @@ -59254,50 +59254,50 @@ static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x); int32_t start = sc->pc; if ((is_symbol(cadr(sig))) && - (is_symbol(arg1)) && - (slot = opt_types_match(sc, cadr(sig), arg1))) - { - s7_pointer p; - opc->v[1].p = slot; - if ((s_func == global_value(sc->int_vector_ref_symbol)) && /* ivref etc */ - ((!is_int_vector(slot_value(slot))) || - (vector_rank(slot_value(slot)) > 1))) - return_false(sc, car_x); - if ((s_func == global_value(sc->byte_vector_ref_symbol)) && /* bvref etc */ - ((!is_byte_vector(slot_value(slot))) || - (vector_rank(slot_value(slot)) > 1))) - return_false(sc, car_x); - - opc->v[3].i_7pi_f = pfunc; - p = opt_integer_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - opc->v[0].fi = opt_i_7pi_ss; - if ((s_func == global_value(sc->int_vector_ref_symbol)) && - (loop_end_fits(opc->v[2].p, vector_length(slot_value(opc->v[1].p))))) - { - opc->v[0].fi = opt_i_pi_ss_ivref; - opc->v[3].i_7pi_f = int_vector_ref_i_pi_direct; - } - else - if ((s_func == global_value(sc->byte_vector_ref_symbol)) && - (loop_end_fits(opc->v[2].p, vector_length(slot_value(opc->v[1].p))))) - { - opc->v[0].fi = opt_i_pi_ss_bvref; - opc->v[3].i_7pi_f = byte_vector_ref_i_7pi_direct; - } - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fi = opt_i_7pi_sf; - opc->v[5].fi = opc->v[4].o1->v[0].fi; - return_true(sc, car_x); - } - sc->pc = start; - }} + (is_symbol(arg1)) && + (slot = opt_types_match(sc, cadr(sig), arg1))) + { + s7_pointer p; + opc->v[1].p = slot; + if ((s_func == global_value(sc->int_vector_ref_symbol)) && /* ivref etc */ + ((!is_int_vector(slot_value(slot))) || + (vector_rank(slot_value(slot)) > 1))) + return_false(sc, car_x); + if ((s_func == global_value(sc->byte_vector_ref_symbol)) && /* bvref etc */ + ((!is_byte_vector(slot_value(slot))) || + (vector_rank(slot_value(slot)) > 1))) + return_false(sc, car_x); + + opc->v[3].i_7pi_f = pfunc; + p = opt_integer_symbol(sc, arg2); + if (p) + { + opc->v[2].p = p; + opc->v[0].fi = opt_i_7pi_ss; + if ((s_func == global_value(sc->int_vector_ref_symbol)) && + (loop_end_fits(opc->v[2].p, vector_length(slot_value(opc->v[1].p))))) + { + opc->v[0].fi = opt_i_pi_ss_ivref; + opc->v[3].i_7pi_f = int_vector_ref_i_pi_direct; + } + else + if ((s_func == global_value(sc->byte_vector_ref_symbol)) && + (loop_end_fits(opc->v[2].p, vector_length(slot_value(opc->v[1].p))))) + { + opc->v[0].fi = opt_i_pi_ss_bvref; + opc->v[3].i_7pi_f = byte_vector_ref_i_7pi_direct; + } + return_true(sc, car_x); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) + { + opc->v[0].fi = opt_i_7pi_sf; + opc->v[5].fi = opc->v[4].o1->v[0].fi; + return_true(sc, car_x); + } + sc->pc = start; + }} return_false(sc, car_x); } @@ -59338,17 +59338,17 @@ static bool i_ii_fc_combinable(s7_scheme *sc, opt_info *opc, s7_i_ii_t func) { opt_info *o1 = sc->opts[sc->pc - 1]; if ((o1->v[0].fi == opt_i_7pi_ss) || (o1->v[0].fi == opt_i_pi_ss_ivref)) - { - opc->v[5].i = opc->v[2].i; /* move v2.i ("c" in fc = arg2) out of the symbols' way */ - opc->v[4].i_7pi_f = o1->v[3].i_7pi_f; - opc->v[1].p = o1->v[1].p; - opc->v[2].p = o1->v[2].p; - if (func) - opc->v[0].fi = ((opc->v[3].i_ii_f == add_i_ii) && (opc->v[4].i_7pi_f == int_vector_ref_i_pi_direct)) ? opt_i_ii_fco_ivref_add : opt_i_ii_fco; - else opc->v[0].fi = opt_i_7ii_fco; - backup_pc(sc); - return_true(sc, NULL); - }} + { + opc->v[5].i = opc->v[2].i; /* move v2.i ("c" in fc = arg2) out of the symbols' way */ + opc->v[4].i_7pi_f = o1->v[3].i_7pi_f; + opc->v[1].p = o1->v[1].p; + opc->v[2].p = o1->v[2].p; + if (func) + opc->v[0].fi = ((opc->v[3].i_ii_f == add_i_ii) && (opc->v[4].i_7pi_f == int_vector_ref_i_pi_direct)) ? opt_i_ii_fco_ivref_add : opt_i_ii_fco; + else opc->v[0].fi = opt_i_7ii_fco; + backup_pc(sc); + return_true(sc, NULL); + }} return_false(sc, NULL); } @@ -59384,7 +59384,7 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { ifunc7 = s7_i_7ii_function(s_func); if (!ifunc7) - return_false(sc, car_x); + return_false(sc, car_x); } sig = c_function_signature(s_func); if (is_pair(sig)) @@ -59394,191 +59394,191 @@ static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer int32_t start = sc->pc; s7_pointer p; if (ifunc) - opc->v[3].i_ii_f = ifunc; + opc->v[3].i_ii_f = ifunc; else opc->v[3].i_7ii_f = ifunc7; if (is_t_integer(arg1)) - { - opc->v[1].i = integer(arg1); - if (is_t_integer(arg2)) - { - if (opc->v[3].i_ii_f == add_i_ii) - { - opc->v[1].i = integer(arg1) + integer(arg2); /* no overflow check for sc_add case above */ - opc->v[0].fi = opt_i_c; - } - else - { - opc->v[2].i = integer(arg2); - opc->v[0].fi = (ifunc) ? opt_i_ii_cc : opt_i_7ii_cc; - } - return_true(sc, car_x); - } - p = opt_integer_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - if (ifunc) - opc->v[0].fi = (opc->v[3].i_ii_f == multiply_i_ii) ? opt_i_ii_cs_mul : opt_i_ii_cs; - else opc->v[0].fi = opt_i_7ii_cs; - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - if (ifunc) - { - opc->v[0].fi = opt_i_ii_cf; /* sc->opts[start]->v[0].fi -> opt_i_7i_c -> same_opt->v[2].i_7i_f = random_i_7i tmap */ - if ((ifunc == add_i_ii) && (opc == sc->opts[sc->pc - 2]) && - (sc->opts[start]->v[0].fi == opt_i_7i_c) && - (sc->opts[start]->v[2].i_7i_f == random_i_7i)) - { - opc->v[0].fi = opt_add_i_random_i; - opc->v[2].i = sc->opts[start]->v[1].i; - backup_pc(sc); - } - else if (ifunc == multiply_i_ii) opc->v[0].fi = opt_i_ii_cf_mul; - } - else opc->v[0].fi = opt_i_7ii_cf; - opc->v[5].fi = opc->v[4].o1->v[0].fi; - return_true(sc, car_x); - } - sc->pc = start; - return_false(sc, car_x); - } + { + opc->v[1].i = integer(arg1); + if (is_t_integer(arg2)) + { + if (opc->v[3].i_ii_f == add_i_ii) + { + opc->v[1].i = integer(arg1) + integer(arg2); /* no overflow check for sc_add case above */ + opc->v[0].fi = opt_i_c; + } + else + { + opc->v[2].i = integer(arg2); + opc->v[0].fi = (ifunc) ? opt_i_ii_cc : opt_i_7ii_cc; + } + return_true(sc, car_x); + } + p = opt_integer_symbol(sc, arg2); + if (p) + { + opc->v[2].p = p; + if (ifunc) + opc->v[0].fi = (opc->v[3].i_ii_f == multiply_i_ii) ? opt_i_ii_cs_mul : opt_i_ii_cs; + else opc->v[0].fi = opt_i_7ii_cs; + return_true(sc, car_x); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) + { + if (ifunc) + { + opc->v[0].fi = opt_i_ii_cf; /* sc->opts[start]->v[0].fi -> opt_i_7i_c -> same_opt->v[2].i_7i_f = random_i_7i tmap */ + if ((ifunc == add_i_ii) && (opc == sc->opts[sc->pc - 2]) && + (sc->opts[start]->v[0].fi == opt_i_7i_c) && + (sc->opts[start]->v[2].i_7i_f == random_i_7i)) + { + opc->v[0].fi = opt_add_i_random_i; + opc->v[2].i = sc->opts[start]->v[1].i; + backup_pc(sc); + } + else if (ifunc == multiply_i_ii) opc->v[0].fi = opt_i_ii_cf_mul; + } + else opc->v[0].fi = opt_i_7ii_cf; + opc->v[5].fi = opc->v[4].o1->v[0].fi; + return_true(sc, car_x); + } + sc->pc = start; + return_false(sc, car_x); + } /* arg1 not integer */ p = opt_integer_symbol(sc, arg1); if (p) - { - opc->v[1].p = p; - if (is_t_integer(arg2)) - { - opc->v[2].i = integer(arg2); - if (ifunc) - { - if (opc->v[3].i_ii_f == add_i_ii) - opc->v[0].fi = opt_i_ii_sc_add; - else opc->v[0].fi = (opc->v[3].i_ii_f == subtract_i_ii) ? opt_i_ii_sc_sub : opt_i_ii_sc; /* add1/sub1 are not faster */ - } - else opc->v[0].fi = opt_i_7ii_sc; - if ((car(car_x) == sc->modulo_symbol) && - (integer(arg2) > 1)) - opc->v[3].i_ii_f = modulo_i_ii_unchecked; - else - { - if (car(car_x) == sc->ash_symbol) - { - if (opc->v[2].i < 0) - { - opc->v[3].i_ii_f = (opc->v[2].i == -1) ? rsh_i_i2_direct : rsh_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_sc; - } - else - if (opc->v[2].i < S7_INT_BITS) - { - opc->v[3].i_ii_f = lsh_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_sc; - }} - else - if (opc->v[2].i > 0) - { - /* these assume vunion is a union, not a struct; i_7ii_f otherwise might be leftover from a previous use */ - if (opc->v[3].i_7ii_f == quotient_i_7ii) - { - opc->v[3].i_ii_f = quotient_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_sc; - } - else - if ((opc->v[2].i > 1) && (opc->v[3].i_7ii_f == remainder_i_7ii)) - { - opc->v[3].i_ii_f = remainder_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_sc; - }}} - return_true(sc, car_x); - } - - /* arg2 not integer, arg1 is int symbol */ - p = opt_integer_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - if (ifunc) - opc->v[0].fi = (opc->v[3].i_ii_f == add_i_ii) ? opt_i_ii_ss_add : opt_i_ii_ss; - else opc->v[0].fi = opt_i_7ii_ss; - return_true(sc, car_x); - } - if (int_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fi = sc->opts[start]->v[0].fi; - if (ifunc) - opc->v[0].fi = (opc->v[3].i_ii_f == add_i_ii) ? opt_i_ii_sf_add : opt_i_ii_sf; - else opc->v[0].fi = opt_i_7ii_sf; - return_true(sc, car_x); - } - sc->pc = start; - return_false(sc, car_x); - } + { + opc->v[1].p = p; + if (is_t_integer(arg2)) + { + opc->v[2].i = integer(arg2); + if (ifunc) + { + if (opc->v[3].i_ii_f == add_i_ii) + opc->v[0].fi = opt_i_ii_sc_add; + else opc->v[0].fi = (opc->v[3].i_ii_f == subtract_i_ii) ? opt_i_ii_sc_sub : opt_i_ii_sc; /* add1/sub1 are not faster */ + } + else opc->v[0].fi = opt_i_7ii_sc; + if ((car(car_x) == sc->modulo_symbol) && + (integer(arg2) > 1)) + opc->v[3].i_ii_f = modulo_i_ii_unchecked; + else + { + if (car(car_x) == sc->ash_symbol) + { + if (opc->v[2].i < 0) + { + opc->v[3].i_ii_f = (opc->v[2].i == -1) ? rsh_i_i2_direct : rsh_i_ii_unchecked; + opc->v[0].fi = opt_i_ii_sc; + } + else + if (opc->v[2].i < S7_INT_BITS) + { + opc->v[3].i_ii_f = lsh_i_ii_unchecked; + opc->v[0].fi = opt_i_ii_sc; + }} + else + if (opc->v[2].i > 0) + { + /* these assume vunion is a union, not a struct; i_7ii_f otherwise might be leftover from a previous use */ + if (opc->v[3].i_7ii_f == quotient_i_7ii) + { + opc->v[3].i_ii_f = quotient_i_ii_unchecked; + opc->v[0].fi = opt_i_ii_sc; + } + else + if ((opc->v[2].i > 1) && (opc->v[3].i_7ii_f == remainder_i_7ii)) + { + opc->v[3].i_ii_f = remainder_i_ii_unchecked; + opc->v[0].fi = opt_i_ii_sc; + }}} + return_true(sc, car_x); + } + + /* arg2 not integer, arg1 is int symbol */ + p = opt_integer_symbol(sc, arg2); + if (p) + { + opc->v[2].p = p; + if (ifunc) + opc->v[0].fi = (opc->v[3].i_ii_f == add_i_ii) ? opt_i_ii_ss_add : opt_i_ii_ss; + else opc->v[0].fi = opt_i_7ii_ss; + return_true(sc, car_x); + } + if (int_optimize(sc, cddr(car_x))) + { + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fi = sc->opts[start]->v[0].fi; + if (ifunc) + opc->v[0].fi = (opc->v[3].i_ii_f == add_i_ii) ? opt_i_ii_sf_add : opt_i_ii_sf; + else opc->v[0].fi = opt_i_7ii_sf; + return_true(sc, car_x); + } + sc->pc = start; + return_false(sc, car_x); + } /* arg1 not int symbol */ if (is_t_integer(arg2)) - { - opc->v[2].i = integer(arg2); - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - if (!i_ii_fc_combinable(sc, opc, ifunc)) - { - if (ifunc) - { - if (opc->v[3].i_ii_f == add_i_ii) {opc->v[0].fi = opt_i_ii_fc_add; return_true(sc, car_x);} - if (opc->v[3].i_ii_f == multiply_i_ii) {opc->v[0].fi = opt_i_ii_fc_mul; return_true(sc, car_x);} - opc->v[0].fi = opt_i_ii_fc; - - if ((opc->v[3].i_ii_f == subtract_i_ii) && (opc == sc->opts[sc->pc - 2]) && - (sc->opts[start]->v[0].fi == opt_i_7i_c) && - (sc->opts[start]->v[2].i_7i_f == random_i_7i)) - { - opc->v[0].fi = opt_subtract_random_i_i; - opc->v[1].i = sc->opts[start]->v[1].i; - backup_pc(sc); - }} - else opc->v[0].fi = opt_i_7ii_fc; - if (opc->v[2].i > 0) - { - if (opc->v[3].i_7ii_f == quotient_i_7ii) - { - opc->v[3].i_ii_f = quotient_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_fc; - } - else - if ((opc->v[2].i > 1) && (opc->v[3].i_7ii_f == remainder_i_7ii)) - { - opc->v[3].i_ii_f = remainder_i_ii_unchecked; - opc->v[0].fi = opt_i_ii_fc; - }}} - return_true(sc, car_x); - } - sc->pc = start; - return_false(sc, car_x); - } + { + opc->v[2].i = integer(arg2); + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) + { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + if (!i_ii_fc_combinable(sc, opc, ifunc)) + { + if (ifunc) + { + if (opc->v[3].i_ii_f == add_i_ii) {opc->v[0].fi = opt_i_ii_fc_add; return_true(sc, car_x);} + if (opc->v[3].i_ii_f == multiply_i_ii) {opc->v[0].fi = opt_i_ii_fc_mul; return_true(sc, car_x);} + opc->v[0].fi = opt_i_ii_fc; + + if ((opc->v[3].i_ii_f == subtract_i_ii) && (opc == sc->opts[sc->pc - 2]) && + (sc->opts[start]->v[0].fi == opt_i_7i_c) && + (sc->opts[start]->v[2].i_7i_f == random_i_7i)) + { + opc->v[0].fi = opt_subtract_random_i_i; + opc->v[1].i = sc->opts[start]->v[1].i; + backup_pc(sc); + }} + else opc->v[0].fi = opt_i_7ii_fc; + if (opc->v[2].i > 0) + { + if (opc->v[3].i_7ii_f == quotient_i_7ii) + { + opc->v[3].i_ii_f = quotient_i_ii_unchecked; + opc->v[0].fi = opt_i_ii_fc; + } + else + if ((opc->v[2].i > 1) && (opc->v[3].i_7ii_f == remainder_i_7ii)) + { + opc->v[3].i_ii_f = remainder_i_ii_unchecked; + opc->v[0].fi = opt_i_ii_fc; + }}} + return_true(sc, car_x); + } + sc->pc = start; + return_false(sc, car_x); + } /* arg1 not integer or symbol, arg2 not integer */ opc->v[10].o1 = sc->opts[sc->pc]; if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[0].fi = (ifunc) ? opt_i_ii_ff : ((opc->v[3].i_7ii_f == quotient_i_7ii) ? opt_i_7ii_ff_quo : opt_i_7ii_ff); - return_true(sc, car_x); - } - sc->pc = start; - }} + { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) + { + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[0].fi = (ifunc) ? opt_i_ii_ff : ((opc->v[3].i_7ii_f == quotient_i_7ii) ? opt_i_7ii_ff_quo : opt_i_7ii_ff); + return_true(sc, car_x); + } + sc->pc = start; + }} return_false(sc, car_x); } @@ -59602,17 +59602,17 @@ static bool i_iii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { opc->v[8].o1 = sc->opts[sc->pc]; if (int_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdddr(car_x))) - { - opc->v[3].i_iii_f = ifunc; - opc->v[0].fi = opt_i_iii_fff; - 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; - return_true(sc, car_x); - }}} + { + opc->v[4].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(car_x))) + { + opc->v[3].i_iii_f = ifunc; + opc->v[0].fi = opt_i_iii_fff; + 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; + return_true(sc, car_x); + }}} sc->pc = start; return_false(sc, car_x); } @@ -59678,32 +59678,32 @@ static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s opc->v[3].p = slot; slot = opt_integer_symbol(sc, car(indexp1)); if (slot) - { - opc->v[2].p = slot; - if (is_t_integer(car(valp))) - { - opc->v[0].fi = opt_i_7piii_sssc; - opc->v[4].i = integer(car(valp)); - return_true(sc, NULL); - } - slot = opt_integer_symbol(sc, car(valp)); - if (slot) - { - opc->v[4].p = slot; - opc->v[0].fi = opt_i_7piii_ssss; - return_true(sc, NULL); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, valp)) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[0].fi = opt_i_7piii_sssf; - if ((opc->v[5].i_7piii_f == int_vector_set_i_7piii) && - (loop_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && - (loop_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) - opc->v[0].fi = opt_i_piii_sssf_ivset_unchecked; - return_true(sc, NULL); - }} + { + opc->v[2].p = slot; + if (is_t_integer(car(valp))) + { + opc->v[0].fi = opt_i_7piii_sssc; + opc->v[4].i = integer(car(valp)); + return_true(sc, NULL); + } + slot = opt_integer_symbol(sc, car(valp)); + if (slot) + { + opc->v[4].p = slot; + opc->v[0].fi = opt_i_7piii_ssss; + return_true(sc, NULL); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, valp)) + { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[0].fi = opt_i_7piii_sssf; + if ((opc->v[5].i_7piii_f == int_vector_set_i_7piii) && + (loop_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && + (loop_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) + opc->v[0].fi = opt_i_piii_sssf_ivset_unchecked; + return_true(sc, NULL); + }} return_false(sc, NULL); } opc->v[10].o1 = sc->opts[sc->pc]; @@ -59711,16 +59711,16 @@ static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s { opc->v[8].o1 = sc->opts[sc->pc]; if (int_optimize(sc, indexp2)) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, valp)) - { - 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[6].fi = opc->v[4].o1->v[0].fi; /* v[5] is in use */ - return_true(sc, NULL); - }}} + { + opc->v[4].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, valp)) + { + 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[6].fi = opc->v[4].o1->v[0].fi; /* v[5] is in use */ + return_true(sc, NULL); + }}} return_false(sc, indexp1); } @@ -59734,59 +59734,59 @@ static bool opt_int_vector_set(s7_scheme *sc, int32_t otype, opt_info *opc, s7_p bool int_case = (is_int_vector(vect)); opc->v[1].p = settee; if ((int_case) || (is_byte_vector(vect))) - { - if ((otype >= 0) && (otype != ((int_case) ? 1 : 0))) - return_false(sc, indexp1); - if ((!indexp2) && - (vector_rank(vect) == 1)) - { - opc->v[3].i_7pii_f = (int_case) ? int_vector_set_i_7pii : byte_vector_set_i_7pii; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - int32_t start = sc->pc; - opc->v[2].p = slot; - if (loop_end_fits(opc->v[2].p, vector_length(vect))) - opc->v[3].i_7pii_f = (int_case) ? int_vector_set_i_7pii_direct : byte_vector_set_i_7pii_direct; - if ((is_pair(valp)) && - (is_null(cdr(valp))) && - (is_t_integer(car(valp)))) - { - opc->v[4].i = integer(car(valp)); - opc->v[0].fi = opt_i_7pii_ssc; - return_true(sc, NULL); - } - if (!int_optimize(sc, valp)) - return_false(sc, NULL); - opc->v[0].fi = (opc->v[3].i_7pii_f == int_vector_set_i_7pii_direct) ? opt_i_7pii_ssf_vset : opt_i_7pii_ssf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fi = sc->opts[start]->v[0].fi; - return_true(sc, NULL); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, valp)) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - if (opc->v[11].fi == opt_i_c) /* (int-vector-set! v 0 (floor (sqrt i))) */ - { - opc->v[0].fi = opt_i_7pii_sif; - opc->v[12].i = opc->v[10].o1->v[1].i; - } - else opc->v[0].fi = opt_i_7pii_sff; - return_true(sc, NULL); - }} - return_false(sc, NULL); - } - if ((indexp2) && - (vector_rank(vect) == 2)) - { - opc->v[5].i_7piii_f = (int_case) ? int_vector_set_i_7piii : byte_vector_set_i_7piii; - return(opt_i_7piii_args(sc, opc, indexp1, indexp2, valp)); - }}} + { + if ((otype >= 0) && (otype != ((int_case) ? 1 : 0))) + return_false(sc, indexp1); + if ((!indexp2) && + (vector_rank(vect) == 1)) + { + opc->v[3].i_7pii_f = (int_case) ? int_vector_set_i_7pii : byte_vector_set_i_7pii; + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) + { + int32_t start = sc->pc; + opc->v[2].p = slot; + if (loop_end_fits(opc->v[2].p, vector_length(vect))) + opc->v[3].i_7pii_f = (int_case) ? int_vector_set_i_7pii_direct : byte_vector_set_i_7pii_direct; + if ((is_pair(valp)) && + (is_null(cdr(valp))) && + (is_t_integer(car(valp)))) + { + opc->v[4].i = integer(car(valp)); + opc->v[0].fi = opt_i_7pii_ssc; + return_true(sc, NULL); + } + if (!int_optimize(sc, valp)) + return_false(sc, NULL); + opc->v[0].fi = (opc->v[3].i_7pii_f == int_vector_set_i_7pii_direct) ? opt_i_7pii_ssf_vset : opt_i_7pii_ssf; + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fi = sc->opts[start]->v[0].fi; + return_true(sc, NULL); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, valp)) + { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + if (opc->v[11].fi == opt_i_c) /* (int-vector-set! v 0 (floor (sqrt i))) */ + { + opc->v[0].fi = opt_i_7pii_sif; + opc->v[12].i = opc->v[10].o1->v[1].i; + } + else opc->v[0].fi = opt_i_7pii_sff; + return_true(sc, NULL); + }} + return_false(sc, NULL); + } + if ((indexp2) && + (vector_rank(vect) == 2)) + { + opc->v[5].i_7piii_f = (int_case) ? int_vector_set_i_7piii : byte_vector_set_i_7piii; + return(opt_i_7piii_args(sc, opc, indexp1, indexp2, valp)); + }}} return_false(sc, v); } @@ -59808,62 +59808,62 @@ static bool i_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe s7_pointer slot, fname = car(car_x); if ((is_target_or_its_alias(fname, s_func, sc->int_vector_set_symbol)) || - (is_target_or_its_alias(fname, s_func, sc->byte_vector_set_symbol))) - return(opt_int_vector_set(sc, (fname == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(car_x), cddr(car_x), NULL, cdddr(car_x))); + (is_target_or_its_alias(fname, s_func, sc->byte_vector_set_symbol))) + return(opt_int_vector_set(sc, (fname == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(car_x), cddr(car_x), NULL, cdddr(car_x))); slot = opt_types_match(sc, cadr(sig), cadr(car_x)); if (slot) - { - s7_pointer arg2, p; - int32_t start = sc->pc; - opc->v[1].p = slot; - - if (((is_target_or_its_alias(fname, s_func, sc->int_vector_ref_symbol)) || - (is_target_or_its_alias(fname, s_func, sc->byte_vector_ref_symbol))) && - (vector_rank(slot_value(slot)) != 2)) - return_false(sc, car_x); - - arg2 = caddr(car_x); - p = opt_integer_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - p = opt_integer_symbol(sc, cadddr(car_x)); - if (p) - { - opc->v[3].p = p; - opc->v[4].i_7pii_f = pfunc; - opc->v[0].fi = opt_i_7pii_sss; - if ((pfunc == int_vector_ref_i_7pii) && - (loop_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && - (loop_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) - opc->v[0].fi = opt_i_pii_sss_ivref_unchecked; - return_true(sc, car_x); - } - if (int_optimize(sc, cdddr(car_x))) - { - opc->v[3].i_7pii_f = pfunc; - opc->v[0].fi = opt_i_7pii_ssf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fi = sc->opts[start]->v[0].fi; - return_true(sc, car_x); - } - return_false(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdddr(car_x))) - { - opc->v[3].i_7pii_f = pfunc; - opc->v[0].fi = opt_i_7pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }} - sc->pc = start; - }} + { + s7_pointer arg2, p; + int32_t start = sc->pc; + opc->v[1].p = slot; + + if (((is_target_or_its_alias(fname, s_func, sc->int_vector_ref_symbol)) || + (is_target_or_its_alias(fname, s_func, sc->byte_vector_ref_symbol))) && + (vector_rank(slot_value(slot)) != 2)) + return_false(sc, car_x); + + arg2 = caddr(car_x); + p = opt_integer_symbol(sc, arg2); + if (p) + { + opc->v[2].p = p; + p = opt_integer_symbol(sc, cadddr(car_x)); + if (p) + { + opc->v[3].p = p; + opc->v[4].i_7pii_f = pfunc; + opc->v[0].fi = opt_i_7pii_sss; + if ((pfunc == int_vector_ref_i_7pii) && + (loop_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && + (loop_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) + opc->v[0].fi = opt_i_pii_sss_ivref_unchecked; + return_true(sc, car_x); + } + if (int_optimize(sc, cdddr(car_x))) + { + opc->v[3].i_7pii_f = pfunc; + opc->v[0].fi = opt_i_7pii_ssf; + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fi = sc->opts[start]->v[0].fi; + return_true(sc, car_x); + } + return_false(sc, car_x); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(car_x))) + { + opc->v[3].i_7pii_f = pfunc; + opc->v[0].fi = opt_i_7pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + return_true(sc, car_x); + }} + sc->pc = start; + }} return_false(sc, car_x); } @@ -59875,19 +59875,19 @@ static bool i_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point { s7_pointer settee; if ((is_target_or_its_alias(car(car_x), s_func, sc->int_vector_set_symbol)) || - (is_target_or_its_alias(car(car_x), s_func, sc->byte_vector_set_symbol))) - return(opt_int_vector_set(sc, (car(car_x) == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(car_x), cddr(car_x), cdddr(car_x), cddddr(car_x))); + (is_target_or_its_alias(car(car_x), s_func, sc->byte_vector_set_symbol))) + return(opt_int_vector_set(sc, (car(car_x) == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(car_x), cddr(car_x), cdddr(car_x), cddddr(car_x))); settee = s7_slot(sc, cadr(car_x)); if (is_slot(settee)) - { - s7_pointer vect = slot_value(settee); - if ((is_int_vector(vect)) && (vector_rank(vect) == 3)) - { - opc->v[5].i_7piii_f = f; - opc->v[1].p = settee; - return(opt_i_7piii_args(sc, opc, cddr(car_x), cdddr(car_x), cddddr(car_x))); - }}} + { + s7_pointer vect = slot_value(settee); + if ((is_int_vector(vect)) && (vector_rank(vect) == 3)) + { + opc->v[5].i_7piii_f = f; + opc->v[1].p = settee; + return(opt_i_7piii_args(sc, opc, cddr(car_x), cdddr(car_x), cddddr(car_x))); + }}} return_false(sc, car_x); } @@ -59964,23 +59964,23 @@ static bool i_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x) { opc->v[cur_len + 2].o1 = sc->opts[sc->pc]; if (!int_optimize(sc, p)) - break; + break; } if (is_null(p)) { opc->v[1].i = cur_len; if (cur_len <= 4) - for (int32_t i = 0; i < cur_len; i++) - opc->v[i + 6].fi = opc->v[i + 2].o1->v[0].fi; + for (int32_t i = 0; i < cur_len; i++) + opc->v[i + 6].fi = opc->v[i + 2].o1->v[0].fi; if (cur_len == 2) - opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add2 : opt_i_mul2; + opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add2 : opt_i_mul2; else - if (cur_len == 3) - opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add3 : opt_i_mul3; - else - if (cur_len == 4) - opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add4 : opt_i_mul4; - else opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add_any_f : opt_i_multiply_any_f; + if (cur_len == 3) + opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add3 : opt_i_mul3; + else + if (cur_len == 4) + opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add4 : opt_i_mul4; + else opc->v[0].fi = (head == sc->add_symbol) ? opt_i_add_any_f : opt_i_multiply_any_f; return_true(sc, car_x); } sc->pc = start; @@ -60039,14 +60039,14 @@ static bool set_i_i_f_combinable(s7_scheme *sc, opt_info *opc) { opt_info *o1 = sc->opts[sc->pc - 1]; if (o1->v[0].fi == opt_i_ii_sc_add) - { - /* opc->v[4].i_ii_f = o1->v[3].i_ii_f; */ - opc->v[3].p = o1->v[1].p; - opc->v[2].i = o1->v[2].i; - opc->v[0].fi = opt_set_i_i_fo; - backup_pc(sc); - return_true(sc, NULL); /* ii_sc v[1].p is a slot */ - }} + { + /* opc->v[4].i_ii_f = o1->v[3].i_ii_f; */ + opc->v[3].p = o1->v[1].p; + opc->v[2].i = o1->v[2].i; + opc->v[0].fi = opt_set_i_i_fo; + backup_pc(sc); + return_true(sc, NULL); /* ii_sc v[1].p is a slot */ + }} return_false(sc, NULL); } @@ -60058,42 +60058,42 @@ static bool i_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) s7_pointer arg1 = cadr(car_x); opt_info *opc = alloc_opt_info(sc); if (is_symbol(arg1)) /* (set! i 3) */ - { - s7_pointer settee; - if (is_immutable(arg1)) - return_false(sc, car_x); - settee = s7_slot(sc, arg1); - if ((is_slot(settee)) && - (is_t_integer(slot_value(settee))) && - (!is_immutable_slot(settee)) && - ((!slot_has_setter(settee)) || - ((is_c_function(slot_setter(settee))) && - ((slot_setter(settee) == initial_value(sc->is_integer_symbol)) || - (c_function_call(slot_setter(settee)) == b_is_integer_setter))))) - /* opt set! won't change type, and it is an integer now (and we might not hit opt_cell_set) */ - { - opt_info *o1 = sc->opts[sc->pc]; - opc->v[1].p = settee; - if (int_optimize(sc, cddr(car_x))) - { - if (set_i_i_f_combinable(sc, opc)) - return_true(sc, car_x); - opc->v[0].fi = (is_mutable_integer(slot_value(opc->v[1].p))) ? opt_set_i_i_fm : opt_set_i_i_f; - /* only a few opt_set_i_i_f|fo's remain in valcall suite */ - opc->v[2].o1 = o1; - opc->v[3].fi = o1->v[0].fi; - return_true(sc, car_x); - }}} + { + s7_pointer settee; + if (is_immutable(arg1)) + return_false(sc, car_x); + settee = s7_slot(sc, arg1); + if ((is_slot(settee)) && + (is_t_integer(slot_value(settee))) && + (!is_immutable_slot(settee)) && + ((!slot_has_setter(settee)) || + ((is_c_function(slot_setter(settee))) && + ((slot_setter(settee) == initial_value(sc->is_integer_symbol)) || + (c_function_call(slot_setter(settee)) == b_is_integer_setter))))) + /* opt set! won't change type, and it is an integer now (and we might not hit opt_cell_set) */ + { + opt_info *o1 = sc->opts[sc->pc]; + opc->v[1].p = settee; + if (int_optimize(sc, cddr(car_x))) + { + if (set_i_i_f_combinable(sc, opc)) + return_true(sc, car_x); + opc->v[0].fi = (is_mutable_integer(slot_value(opc->v[1].p))) ? opt_set_i_i_fm : opt_set_i_i_f; + /* only a few opt_set_i_i_f|fo's remain in valcall suite */ + opc->v[2].o1 = o1; + opc->v[3].fi = o1->v[0].fi; + return_true(sc, car_x); + }}} else - if ((is_pair(arg1)) && /* if is_pair(settee) get setter */ - (is_symbol(car(arg1))) && - (is_pair(cdr(arg1)))) - { - if (is_null(cddr(arg1))) - return(opt_int_vector_set(sc, -1, opc, car(arg1), cdr(arg1), NULL, cddr(car_x))); - if (is_null(cdddr(arg1))) - return(opt_int_vector_set(sc, -1, opc, car(arg1), cdr(arg1), cddr(arg1), cddr(car_x))); - }} + if ((is_pair(arg1)) && /* if is_pair(settee) get setter */ + (is_symbol(car(arg1))) && + (is_pair(cdr(arg1)))) + { + if (is_null(cddr(arg1))) + return(opt_int_vector_set(sc, -1, opc, car(arg1), cdr(arg1), NULL, cddr(car_x))); + if (is_null(cdddr(arg1))) + return(opt_int_vector_set(sc, -1, opc, car(arg1), cdr(arg1), cddr(arg1), cddr(car_x))); + }} return_false(sc, car_x); } @@ -60106,62 +60106,62 @@ static bool i_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, in s7_pointer slot; if ((len == 2) && - (vector_rank(obj) == 1)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[0].fi = opt_i_7pi_ss; - opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; - opc->v[2].p = slot; - if (loop_end_fits(opc->v[2].p, vector_length(obj))) - opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_i_pi_direct : byte_vector_ref_i_7pi_direct; - /* not opc->v[0].fi = opt_i_pi_ss_ivref -- this causes a huge slowdown in dup.scm?? */ - return_true(sc, car_x); - } - opc->v[4].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[0].fi = opt_i_7pi_sf; - opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; - opc->v[5].fi = opc->v[4].o1->v[0].fi; - return_true(sc, car_x); - } + (vector_rank(obj) == 1)) + { + opt_info *opc = alloc_opt_info(sc); + opc->v[1].p = s_slot; + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) + { + opc->v[0].fi = opt_i_7pi_ss; + opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; + opc->v[2].p = slot; + if (loop_end_fits(opc->v[2].p, vector_length(obj))) + opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_i_pi_direct : byte_vector_ref_i_7pi_direct; + /* not opc->v[0].fi = opt_i_pi_ss_ivref -- this causes a huge slowdown in dup.scm?? */ + return_true(sc, car_x); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(car_x))) + return_false(sc, car_x); + opc->v[0].fi = opt_i_7pi_sf; + opc->v[3].i_7pi_f = (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; + opc->v[5].fi = opc->v[4].o1->v[0].fi; + return_true(sc, car_x); + } if ((len == 3) && - (vector_rank(obj) == 2)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (!slot) - return_false(sc, car_x); - opc->v[4].i_7pii_f = (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; - opc->v[3].p = slot; - opc->v[0].fi = opt_i_7pii_sss; - if ((int_case) && - (loop_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (loop_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) - opc->v[0].fi = opt_i_pii_sss_ivref_unchecked; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[3].i_7pii_f = (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; - opc->v[0].fi = opt_i_7pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }}}} + (vector_rank(obj) == 2)) + { + opt_info *opc = alloc_opt_info(sc); + opc->v[1].p = s_slot; + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) + { + opc->v[2].p = slot; + slot = opt_integer_symbol(sc, caddr(car_x)); + if (!slot) + return_false(sc, car_x); + opc->v[4].i_7pii_f = (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; + opc->v[3].p = slot; + opc->v[0].fi = opt_i_7pii_sss; + if ((int_case) && + (loop_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && + (loop_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) + opc->v[0].fi = opt_i_pii_sss_ivref_unchecked; + return_true(sc, car_x); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) + { + opc->v[3].i_7pii_f = (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; + opc->v[0].fi = opt_i_7pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + return_true(sc, car_x); + }}}} return_false(sc, car_x); } @@ -60240,38 +60240,38 @@ static bool d_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c { s7_pointer p, arg1 = cadr(car_x); if (func) - opc->v[3].d_d_f = func; + opc->v[3].d_d_f = func; else opc->v[3].d_7d_f = func7; if (is_small_real(arg1)) - { - if ((!is_t_real(arg1)) && /* (random 1) != (random 1.0) */ - ((car(car_x) == sc->random_symbol) || - (car(car_x) == sc->sin_symbol) || (car(car_x) == sc->cos_symbol))) - return_false(sc, car_x); - opc->v[1].x = s7_number_to_real(sc, arg1); - opc->v[0].fd = (func) ? opt_d_d_c : opt_d_7d_c; - return_true(sc, car_x); - } + { + if ((!is_t_real(arg1)) && /* (random 1) != (random 1.0) */ + ((car(car_x) == sc->random_symbol) || + (car(car_x) == sc->sin_symbol) || (car(car_x) == sc->cos_symbol))) + return_false(sc, car_x); + opc->v[1].x = s7_number_to_real(sc, arg1); + opc->v[0].fd = (func) ? opt_d_d_c : opt_d_7d_c; + return_true(sc, car_x); + } p = opt_float_symbol(sc, arg1); if ((p) && - (!has_methods(slot_value(p)))) - { - opc->v[1].p = p; - opc->v[0].fd = (func) ? ((func == abs_d_d) ? opt_d_d_s_abs : opt_d_d_s) : opt_d_7d_s; - return_true(sc, car_x); - } + (!has_methods(slot_value(p)))) + { + opc->v[1].p = p; + opc->v[0].fd = (func) ? ((func == abs_d_d) ? opt_d_d_s_abs : opt_d_d_s) : opt_d_7d_s; + return_true(sc, car_x); + } opc->v[4].o1 = sc->opts[sc->pc]; if (float_optimize(sc, cdr(car_x))) - { - opc->v[0].fd = (func) ? ((func == abs_d_d) ? opt_d_d_f_abs : ((func == sin_d_d) ? opt_d_d_f_sin : - ((func == cos_d_d) ? opt_d_d_f_cos : opt_d_d_f))) : - ((func7 == divide_d_7d) ? opt_d_7d_f_divide : opt_d_7d_f); - /* if (opc->v[0].fd == opt_d_7d_f_divide) in tnum we know the arg is not 0.0, so it could be further optimized (but it's the loop stepper) */ - opc->v[5].fd = opc->v[4].o1->v[0].fd; - if ((func == abs_d_d) && (opc->v[5].fd == opt_d_7pi_ss_fvref_direct)) - opc->v[0].fd = opt_abs_d_ss_fvref; - return_true(sc, car_x); - } + { + opc->v[0].fd = (func) ? ((func == abs_d_d) ? opt_d_d_f_abs : ((func == sin_d_d) ? opt_d_d_f_sin : + ((func == cos_d_d) ? opt_d_d_f_cos : opt_d_d_f))) : + ((func7 == divide_d_7d) ? opt_d_7d_f_divide : opt_d_7d_f); + /* if (opc->v[0].fd == opt_d_7d_f_divide) in tnum we know the arg is not 0.0, so it could be further optimized (but it's the loop stepper) */ + opc->v[5].fd = opc->v[4].o1->v[0].fd; + if ((func == abs_d_d) && (opc->v[5].fd == opt_d_7pi_ss_fvref_direct)) + opc->v[0].fd = opt_abs_d_ss_fvref; + return_true(sc, car_x); + } sc->pc = start; } return_false(sc, car_x); @@ -60293,13 +60293,13 @@ static bool d_v_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c { s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(car_x)); if (slot) - { - opc->v[1].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(slot)); - opc->v[3].d_v_f = flt_func; - opc->v[0].fd = opt_d_v; - return_true(sc, car_x); - }} + { + opc->v[1].p = slot; + opc->v[5].obj = (void *)c_object_value(slot_value(slot)); + opc->v[3].d_v_f = flt_func; + opc->v[0].fd = opt_d_v; + return_true(sc, car_x); + }} return_false(sc, car_x); } @@ -60318,7 +60318,7 @@ static bool d_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c { s7_pointer slot = opt_simple_symbol(sc, cadr(car_x)); if (!slot) - return_false(sc, car_x); + return_false(sc, car_x); opc->v[1].p = slot; opc->v[0].fd = opt_d_p_s; return_true(sc, car_x); @@ -60356,17 +60356,17 @@ static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (!ifunc) { if ((s_func == initial_value(sc->vector_ref_symbol)) && (is_normal_symbol(cadr(car_x)))) /* (vector-ref <float-vector> <int>)? */ - { - s7_pointer v_slot = s7_slot(sc, cadr(car_x)); - if (is_slot(v_slot)) - { - s7_pointer v = slot_value(v_slot); - if ((is_float_vector(v)) || - ((is_typed_t_vector(v)) && (typed_vector_typer_symbol(sc, v) == sc->is_float_symbol))) - { - ifunc = float_vector_ref_d_7pi; - if (is_float_vector(v)) s_func = initial_value(sc->float_vector_ref_symbol); - }}} + { + s7_pointer v_slot = s7_slot(sc, cadr(car_x)); + if (is_slot(v_slot)) + { + s7_pointer v = slot_value(v_slot); + if ((is_float_vector(v)) || + ((is_typed_t_vector(v)) && (typed_vector_typer_symbol(sc, v) == sc->is_float_symbol))) + { + ifunc = float_vector_ref_d_7pi; + if (is_float_vector(v)) s_func = initial_value(sc->float_vector_ref_symbol); + }}} if (!ifunc) return_false(sc, car_x); } opc->v[3].d_7pi_f = ifunc; @@ -60375,42 +60375,42 @@ static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_pointer arg2, p, obj; opc->v[1].p = s7_slot(sc, cadr(car_x)); if (!is_slot(opc->v[1].p)) - return_false(sc, car_x); + return_false(sc, car_x); obj = slot_value(opc->v[1].p); if ((is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) && - ((!is_float_vector(obj)) || /* if it's float-vector-ref, make sure obj is a float-vector */ - (vector_rank(obj) > 1))) - return_false(sc, car_x); /* but if it's e.g. (block-ref...), go on */ + ((!is_float_vector(obj)) || /* if it's float-vector-ref, make sure obj is a float-vector */ + (vector_rank(obj) > 1))) + return_false(sc, car_x); /* but if it's e.g. (block-ref...), go on */ arg2 = caddr(car_x); if (!is_pair(arg2)) - { - if (is_t_integer(arg2)) - { - opc->v[2].i = integer(arg2); - opc->v[0].fd = opt_d_7pi_sc; - return_true(sc, car_x); - } - p = opt_integer_symbol(sc, arg2); - if (!p) - return_false(sc, car_x); - opc->v[2].p = p; - opc->v[0].fd = opt_d_7pi_ss; - if (is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) - { - opc->v[0].fd = (loop_end_fits(opc->v[2].p, vector_length(obj))) ? opt_d_7pi_ss_fvref_direct : opt_d_7pi_ss_fvref; - if (opc->v[0].fd == opt_d_7pi_ss_fvref_direct) opc->v[3].d_7pi_f = float_vector_ref_d_7pi_direct; - } - return_true(sc, car_x); - } + { + if (is_t_integer(arg2)) + { + opc->v[2].i = integer(arg2); + opc->v[0].fd = opt_d_7pi_sc; + return_true(sc, car_x); + } + p = opt_integer_symbol(sc, arg2); + if (!p) + return_false(sc, car_x); + opc->v[2].p = p; + opc->v[0].fd = opt_d_7pi_ss; + if (is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) + { + opc->v[0].fd = (loop_end_fits(opc->v[2].p, vector_length(obj))) ? opt_d_7pi_ss_fvref_direct : opt_d_7pi_ss_fvref; + if (opc->v[0].fd == opt_d_7pi_ss_fvref_direct) opc->v[3].d_7pi_f = float_vector_ref_d_7pi_direct; + } + return_true(sc, car_x); + } if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_7pi_sf; - opc->v[10].o1 = sc->opts[start]; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - return_true(sc, car_x); - } + { + opc->v[0].fd = opt_d_7pi_sf; + opc->v[10].o1 = sc->opts[start]; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + return_true(sc, car_x); + } sc->pc = start; return_false(sc, car_x); } @@ -60424,14 +60424,14 @@ static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { opt_info *o2 = sc->opts[sc->pc]; if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_7pi_ff; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = sc->opts[start]->v[0].fp; - opc->v[8].o1 = o2; - opc->v[9].fi = o2->v[0].fi; - return_true(sc, car_x); - }} + { + opc->v[0].fd = opt_d_7pi_ff; + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fp = sc->opts[start]->v[0].fp; + opc->v[8].o1 = o2; + opc->v[9].fi = o2->v[0].fi; + return_true(sc, car_x); + }} sc->pc = start; return_false(sc, car_x); } @@ -60447,15 +60447,15 @@ static bool d_ip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { s7_pointer p = opt_integer_symbol(sc, cadr(car_x)); if (p) - { - opc->v[3].d_ip_f = pfunc; - opc->v[1].p = p; - opc->v[2].p = s7_slot(sc, caddr(car_x)); - if (is_slot(opc->v[2].p)) /* (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .4 :reverb-amount .5)) */ - { - opc->v[0].fd = opt_d_ip_ss; - return_true(sc, car_x); - }}} + { + opc->v[3].d_ip_f = pfunc; + opc->v[1].p = p; + opc->v[2].p = s7_slot(sc, caddr(car_x)); + if (is_slot(opc->v[2].p)) /* (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .4 :reverb-amount .5)) */ + { + opc->v[0].fd = opt_d_ip_ss; + return_true(sc, car_x); + }}} return_false(sc, car_x); } @@ -60469,29 +60469,29 @@ static bool d_pd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { s7_d_pd_t func = s7_d_pd_function(s_func); if (func) - { - s7_pointer p, arg2 = caddr(car_x); - int32_t start = sc->pc; - opc->v[3].d_pd_f = func; - opc->v[1].p = s7_slot(sc, cadr(car_x)); - if (!is_slot(opc->v[1].p)) - return_false(sc, car_x); - p = opt_float_symbol(sc, arg2); - if (p) - { - opc->v[2].p = p; - opc->v[0].fd = opt_d_pd_ss; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_pd_sf; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - return_true(sc, car_x); - } - sc->pc = start; - }} + { + s7_pointer p, arg2 = caddr(car_x); + int32_t start = sc->pc; + opc->v[3].d_pd_f = func; + opc->v[1].p = s7_slot(sc, cadr(car_x)); + if (!is_slot(opc->v[1].p)) + return_false(sc, car_x); + p = opt_float_symbol(sc, arg2); + if (p) + { + opc->v[2].p = p; + opc->v[0].fd = opt_d_pd_ss; + return_true(sc, car_x); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(car_x))) + { + opc->v[0].fd = opt_d_pd_sf; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + return_true(sc, car_x); + } + sc->pc = start; + }} return_false(sc, car_x); } @@ -60581,52 +60581,52 @@ static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(car_x)); if (slot) - { - s7_pointer arg2 = caddr(car_x); - int32_t start = sc->pc; - opc->v[3].d_vd_f = vfunc; - if (!is_pair(arg2)) - { - opc->v[1].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(slot)); - if (is_small_real(arg2)) - { - opc->v[2].x = s7_number_to_real(sc, arg2); - opc->v[0].fd = opt_d_vd_c; - return_true(sc, car_x); - } - opc->v[2].p = s7_slot(sc, arg2); - if (is_slot(opc->v[2].p)) - { - if (is_t_real(slot_value(opc->v[2].p))) - { - opc->v[0].fd = opt_d_vd_s; - return_true(sc, car_x); - } - if (!float_optimize(sc, cddr(car_x))) - return_false(sc, car_x); - if (d_vd_f_combinable(sc, start)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_vd_f; - opc->v[8].o1 = sc->opts[start]; - opc->v[9].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - }} - else /* is pair arg2 */ - { - if (float_optimize(sc, cddr(car_x))) - { - opc->v[1].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(slot)); - if (d_vd_f_combinable(sc, start)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_vd_f; - opc->v[8].o1 = sc->opts[start]; - opc->v[9].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - } - sc->pc = start; - }}} + { + s7_pointer arg2 = caddr(car_x); + int32_t start = sc->pc; + opc->v[3].d_vd_f = vfunc; + if (!is_pair(arg2)) + { + opc->v[1].p = slot; + opc->v[5].obj = (void *)c_object_value(slot_value(slot)); + if (is_small_real(arg2)) + { + opc->v[2].x = s7_number_to_real(sc, arg2); + opc->v[0].fd = opt_d_vd_c; + return_true(sc, car_x); + } + opc->v[2].p = s7_slot(sc, arg2); + if (is_slot(opc->v[2].p)) + { + if (is_t_real(slot_value(opc->v[2].p))) + { + opc->v[0].fd = opt_d_vd_s; + return_true(sc, car_x); + } + if (!float_optimize(sc, cddr(car_x))) + return_false(sc, car_x); + if (d_vd_f_combinable(sc, start)) + return_true(sc, car_x); + opc->v[0].fd = opt_d_vd_f; + opc->v[8].o1 = sc->opts[start]; + opc->v[9].fd = sc->opts[start]->v[0].fd; + return_true(sc, car_x); + }} + else /* is pair arg2 */ + { + if (float_optimize(sc, cddr(car_x))) + { + opc->v[1].p = slot; + opc->v[5].obj = (void *)c_object_value(slot_value(slot)); + if (d_vd_f_combinable(sc, start)) + return_true(sc, car_x); + opc->v[0].fd = opt_d_vd_f; + opc->v[8].o1 = sc->opts[start]; + opc->v[9].fd = sc->opts[start]->v[0].fd; + return_true(sc, car_x); + } + sc->pc = start; + }}} return_false(sc, car_x); } @@ -60652,25 +60652,25 @@ static bool d_id_sf_combinable(s7_scheme *sc, opt_info *opc) { opt_info *o1 = sc->opts[sc->pc - 1]; if (o1->v[0].fd == opt_d_vd_s) - { - opc->v[4].d_id_f = opc->v[3].d_id_f; - opc->v[2].p = o1->v[1].p; - opc->v[6].obj = o1->v[5].obj; - opc->v[5].d_vd_f = o1->v[3].d_vd_f; - opc->v[3].p = o1->v[2].p; - opc->v[0].fd = opt_d_id_sfo; - backup_pc(sc); - return_true(sc, NULL); - } + { + opc->v[4].d_id_f = opc->v[3].d_id_f; + opc->v[2].p = o1->v[1].p; + opc->v[6].obj = o1->v[5].obj; + opc->v[5].d_vd_f = o1->v[3].d_vd_f; + opc->v[3].p = o1->v[2].p; + opc->v[0].fd = opt_d_id_sfo; + backup_pc(sc); + return_true(sc, NULL); + } if (o1->v[0].fd == opt_d_v) - { - opc->v[6].p = o1->v[1].p; - opc->v[2].obj = o1->v[5].obj; - opc->v[5].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = opt_d_id_sfo1; - backup_pc(sc); - return_true(sc, NULL); - }} + { + opc->v[6].p = o1->v[1].p; + opc->v[2].obj = o1->v[5].obj; + opc->v[5].d_v_f = o1->v[3].d_v_f; + opc->v[0].fd = opt_d_id_sfo1; + backup_pc(sc); + return_true(sc, NULL); + }} return_false(sc, NULL); } @@ -60688,44 +60688,44 @@ static bool d_id_ok_1(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe s7_pointer arg2 = caddr(car_x); opc->v[1].p = p; if (is_t_real(arg2)) - { - opc->v[0].fd = opt_d_id_sc; - opc->v[2].x = real(arg2); - return_true(sc, car_x); - } + { + opc->v[0].fd = opt_d_id_sc; + opc->v[2].x = real(arg2); + return_true(sc, car_x); + } if ((cadr(car_x) == arg2) && (flt_func == multiply_d_id)) - { - opc->v[0].fd = opt_d_i2_mul; - return_true(sc, car_x); - } + { + opc->v[0].fd = opt_d_i2_mul; + return_true(sc, car_x); + } p = opt_float_symbol(sc, arg2); if (p) - { - opc->v[0].fd = opt_d_id_ss; - opc->v[2].p = p; - return_true(sc, car_x); - } + { + opc->v[0].fd = opt_d_id_ss; + opc->v[2].p = p; + return_true(sc, car_x); + } if (float_optimize(sc, cddr(car_x))) - { - if (d_id_sf_combinable(sc, opc)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_id_sf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - } + { + if (d_id_sf_combinable(sc, opc)) + return_true(sc, car_x); + opc->v[0].fd = opt_d_id_sf; + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + return_true(sc, car_x); + } sc->pc = start; } if (is_t_integer(cadr(car_x))) { if (float_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_id_cf; - opc->v[1].i = integer(cadr(car_x)); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - return_true(sc, car_x); - } + { + opc->v[0].fd = opt_d_id_cf; + opc->v[1].i = integer(cadr(car_x)); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + return_true(sc, car_x); + } sc->pc = start; } if (!expr_case) return_false(sc, car_x); @@ -60735,11 +60735,11 @@ static bool d_id_ok_1(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe opc->v[9].fi = opc->v[8].o1->v[0].fi; opc->v[10].o1 = sc->opts[sc->pc]; if (float_optimize(sc, cddr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[0].fd = opt_d_id_ff; - return_true(sc, car_x); - } + { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[0].fd = opt_d_id_ff; + return_true(sc, car_x); + } sc->pc = start; } return_false(sc, car_x); @@ -60810,23 +60810,23 @@ static bool d_dd_sf_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func) { opt_info *o1 = sc->opts[sc->pc - 1]; if ((o1->v[0].fd == opt_d_7pi_ss) || (o1->v[0].fd == opt_d_7pi_ss_fvref) || (o1->v[0].fd == opt_d_7pi_ss_fvref_direct)) - { - if (func) - { - opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* need room for 3 symbols */ - opc->v[0].fd = opt_d_dd_sfo; - } - else - { - opc->v[4].d_7dd_f = opc->v[3].d_7dd_f; /* need room for 3 symbols */ - opc->v[0].fd = opt_d_7dd_sfo; - } - opc->v[2].p = o1->v[1].p; - opc->v[3].p = o1->v[2].p; - opc->v[5].d_7pi_f = o1->v[3].d_7pi_f; - backup_pc(sc); - return_true(sc, NULL); - }} + { + if (func) + { + opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* need room for 3 symbols */ + opc->v[0].fd = opt_d_dd_sfo; + } + else + { + opc->v[4].d_7dd_f = opc->v[3].d_7dd_f; /* need room for 3 symbols */ + opc->v[0].fd = opt_d_7dd_sfo; + } + opc->v[2].p = o1->v[1].p; + opc->v[3].p = o1->v[2].p; + opc->v[5].d_7pi_f = o1->v[3].d_7pi_f; + backup_pc(sc); + return_true(sc, NULL); + }} return_false(sc, NULL); } @@ -60859,23 +60859,23 @@ static bool d_dd_fs_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func) { opt_info *o1 = sc->opts[sc->pc - 1]; if ((o1->v[0].fd == opt_d_7pi_ss) || (o1->v[0].fd == opt_d_7pi_ss_fvref) || (o1->v[0].fd == opt_d_7pi_ss_fvref_direct)) - { - if (func) - { - opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* need room for 3 symbols */ - opc->v[0].fd = opt_d_dd_fso; - } - else - { - opc->v[4].d_7dd_f = opc->v[3].d_7dd_f; - opc->v[0].fd = opt_d_7dd_fso; - } - opc->v[2].p = o1->v[1].p; - opc->v[3].p = o1->v[2].p; - opc->v[5].d_7pi_f = o1->v[3].d_7pi_f; - backup_pc(sc); - return_true(sc, NULL); - }} + { + if (func) + { + opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* need room for 3 symbols */ + opc->v[0].fd = opt_d_dd_fso; + } + else + { + opc->v[4].d_7dd_f = opc->v[3].d_7dd_f; + opc->v[0].fd = opt_d_7dd_fso; + } + opc->v[2].p = o1->v[1].p; + opc->v[3].p = o1->v[2].p; + opc->v[5].d_7pi_f = o1->v[3].d_7pi_f; + backup_pc(sc); + return_true(sc, NULL); + }} return_false(sc, NULL); } @@ -61037,49 +61037,49 @@ static bool d_dd_ff_combinable(s7_scheme *sc, opt_info *opc, int32_t start) { /* opc->v[3] is in use */ if ((o2->v[0].fd == opt_d_v) && - (sc->pc == start + 2)) - { - opc->v[1].obj = o1->v[5].obj; - opc->v[6].p = o1->v[1].p; - opc->v[4].d_v_f = o1->v[3].d_v_f; - opc->v[2].obj = o2->v[5].obj; - opc->v[7].p = o2->v[1].p; - opc->v[5].d_v_f = o2->v[3].d_v_f; - opc->v[0].fd = (opc->v[3].d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul2 : opt_d_dd_ff_o2; - sc->pc -= 2; - return_true(sc, NULL); - } + (sc->pc == start + 2)) + { + opc->v[1].obj = o1->v[5].obj; + opc->v[6].p = o1->v[1].p; + opc->v[4].d_v_f = o1->v[3].d_v_f; + opc->v[2].obj = o2->v[5].obj; + opc->v[7].p = o2->v[1].p; + opc->v[5].d_v_f = o2->v[3].d_v_f; + opc->v[0].fd = (opc->v[3].d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul2 : opt_d_dd_ff_o2; + sc->pc -= 2; + return_true(sc, NULL); + } if ((o2->v[0].fd == opt_d_vd_s) && - (sc->pc == start + 2)) - { - opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* make room for symbols */ - opc->v[1].obj = o1->v[5].obj; - opc->v[7].p = o1->v[1].p; - opc->v[5].d_v_f = o1->v[3].d_v_f; - opc->v[2].obj = o2->v[5].obj; - opc->v[8].p = o2->v[1].p; - opc->v[6].d_vd_f = o2->v[3].d_vd_f; - opc->v[3].p = o2->v[2].p; - opc->v[0].fd = opt_d_dd_ff_o3; - sc->pc -= 2; - return_true(sc, NULL); - } + (sc->pc == start + 2)) + { + opc->v[4].d_dd_f = opc->v[3].d_dd_f; /* make room for symbols */ + opc->v[1].obj = o1->v[5].obj; + opc->v[7].p = o1->v[1].p; + opc->v[5].d_v_f = o1->v[3].d_v_f; + opc->v[2].obj = o2->v[5].obj; + opc->v[8].p = o2->v[1].p; + opc->v[6].d_vd_f = o2->v[3].d_vd_f; + opc->v[3].p = o2->v[2].p; + opc->v[0].fd = opt_d_dd_ff_o3; + sc->pc -= 2; + return_true(sc, NULL); + } if ((o2->v[0].fd == opt_d_vd_o) && - (sc->pc == start + 2)) - { - opc->v[1].obj = o1->v[5].obj; - opc->v[8].p = o1->v[1].p; - opc->v[2].d_v_f = o1->v[3].d_v_f; - opc->v[7].d_vd_f = o2->v[3].d_vd_f; - opc->v[4].d_v_f = o2->v[4].d_v_f; - opc->v[5].obj = o2->v[5].obj; - opc->v[9].p = o2->v[1].p; - opc->v[6].obj = o2->v[6].obj; - opc->v[10].p = o2->v[2].p; - opc->v[0].fd = (opc->v[3].d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul4 : opt_d_dd_ff_o4; - sc->pc -= 2; - return_true(sc, NULL); - } + (sc->pc == start + 2)) + { + opc->v[1].obj = o1->v[5].obj; + opc->v[8].p = o1->v[1].p; + opc->v[2].d_v_f = o1->v[3].d_v_f; + opc->v[7].d_vd_f = o2->v[3].d_vd_f; + opc->v[4].d_v_f = o2->v[4].d_v_f; + opc->v[5].obj = o2->v[5].obj; + opc->v[9].p = o2->v[1].p; + opc->v[6].obj = o2->v[6].obj; + opc->v[10].p = o2->v[2].p; + opc->v[0].fd = (opc->v[3].d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul4 : opt_d_dd_ff_o4; + sc->pc -= 2; + return_true(sc, NULL); + } opc->v[1].obj = o1->v[5].obj; opc->v[4].p = o1->v[1].p; opc->v[2].d_v_f = o1->v[3].d_v_f; @@ -61089,27 +61089,27 @@ static bool d_dd_ff_combinable(s7_scheme *sc, opt_info *opc, int32_t start) if (o1->v[0].fd == opt_d_dd_fso) { if (o2->v[0].fd == opt_d_dd_fso) - { - if ((o1->v[4].d_dd_f == multiply_d_dd) && - (o2->v[4].d_dd_f == multiply_d_dd) && - ((o1->v[5].d_7pi_f == float_vector_ref_d_7pi) || (o1->v[5].d_7pi_f == float_vector_ref_d_7pi_direct)) && - ((o2->v[5].d_7pi_f == float_vector_ref_d_7pi) || (o2->v[5].d_7pi_f == float_vector_ref_d_7pi_direct))) - opc->v[0].fd = opt_d_mm_fff; /* a placeholder (never called) */ - else opc->v[0].fd = opt_d_dd_fff; - return(finish_dd_fso(opc, o1, o2)); - }} + { + if ((o1->v[4].d_dd_f == multiply_d_dd) && + (o2->v[4].d_dd_f == multiply_d_dd) && + ((o1->v[5].d_7pi_f == float_vector_ref_d_7pi) || (o1->v[5].d_7pi_f == float_vector_ref_d_7pi_direct)) && + ((o2->v[5].d_7pi_f == float_vector_ref_d_7pi) || (o2->v[5].d_7pi_f == float_vector_ref_d_7pi_direct))) + opc->v[0].fd = opt_d_mm_fff; /* a placeholder (never called) */ + else opc->v[0].fd = opt_d_dd_fff; + return(finish_dd_fso(opc, o1, o2)); + }} if (o1->v[0].fd == opt_d_dd_sfo) { if (o2->v[0].fd == opt_d_dd_sfo) - { - if ((o1->v[4].d_dd_f == multiply_d_dd) && - (o2->v[4].d_dd_f == multiply_d_dd) && - ((o1->v[5].d_7pi_f == float_vector_ref_d_7pi) || (o1->v[5].d_7pi_f == float_vector_ref_d_7pi_direct)) && - ((o2->v[5].d_7pi_f == float_vector_ref_d_7pi) || (o2->v[5].d_7pi_f == float_vector_ref_d_7pi_direct))) - opc->v[0].fd = opt_d_mm_fff; /* multiply is commutative */ - else opc->v[0].fd = opt_d_dd_fff_rev; - return(finish_dd_fso(opc, o1, o2)); - }} + { + if ((o1->v[4].d_dd_f == multiply_d_dd) && + (o2->v[4].d_dd_f == multiply_d_dd) && + ((o1->v[5].d_7pi_f == float_vector_ref_d_7pi) || (o1->v[5].d_7pi_f == float_vector_ref_d_7pi_direct)) && + ((o2->v[5].d_7pi_f == float_vector_ref_d_7pi) || (o2->v[5].d_7pi_f == float_vector_ref_d_7pi_direct))) + opc->v[0].fd = opt_d_mm_fff; /* multiply is commutative */ + else opc->v[0].fd = opt_d_dd_fff_rev; + return(finish_dd_fso(opc, o1, o2)); + }} return_false(sc, NULL); } @@ -61125,26 +61125,26 @@ static bool d_dd_call_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func) { opt_info *o1 = sc->opts[sc->pc - 1]; if (o1->v[0].fd == opt_d_v) - { - opc->v[2].x = opc->v[1].x; - opc->v[6].p = o1->v[1].p; - opc->v[1].obj = o1->v[5].obj; - opc->v[4].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = (func) ? opt_d_dd_cfo : opt_d_7dd_cfo; - backup_pc(sc); - return_true(sc, NULL); - } + { + opc->v[2].x = opc->v[1].x; + opc->v[6].p = o1->v[1].p; + opc->v[1].obj = o1->v[5].obj; + opc->v[4].d_v_f = o1->v[3].d_v_f; + opc->v[0].fd = (func) ? opt_d_dd_cfo : opt_d_7dd_cfo; + backup_pc(sc); + return_true(sc, NULL); + } if (o1->v[0].fd == opt_d_vd_s) - { - opc->v[4].x = opc->v[1].x; - opc->v[1].p = o1->v[1].p; - opc->v[6].obj = o1->v[5].obj; - opc->v[2].p = o1->v[2].p; - opc->v[5].d_vd_f = o1->v[3].d_vd_f; - opc->v[0].fd = (func) ? opt_d_dd_cfo1 : opt_d_7dd_cfo1; - backup_pc(sc); - return_true(sc, NULL); - }} + { + opc->v[4].x = opc->v[1].x; + opc->v[1].p = o1->v[1].p; + opc->v[6].obj = o1->v[5].obj; + opc->v[2].p = o1->v[2].p; + opc->v[5].d_vd_f = o1->v[3].d_vd_f; + opc->v[0].fd = (func) ? opt_d_dd_cfo1 : opt_d_7dd_cfo1; + backup_pc(sc); + return_true(sc, NULL); + }} return_false(sc, NULL); } @@ -61172,33 +61172,33 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (is_small_real(arg1)) { if (is_small_real(arg2)) - { - if ((!is_t_real(arg1)) && (!is_t_real(arg2))) - return_false(sc, car_x); - opc->v[1].x = s7_number_to_real(sc, arg1); - opc->v[2].x = s7_number_to_real(sc, arg2); - opc->v[0].fd = (func) ? opt_d_dd_cc : opt_d_7dd_cc; - return_true(sc, car_x); - } + { + if ((!is_t_real(arg1)) && (!is_t_real(arg2))) + return_false(sc, car_x); + opc->v[1].x = s7_number_to_real(sc, arg1); + opc->v[2].x = s7_number_to_real(sc, arg2); + opc->v[0].fd = (func) ? opt_d_dd_cc : opt_d_7dd_cc; + return_true(sc, car_x); + } slot = opt_float_symbol(sc, arg2); if (slot) - { - opc->v[1].p = slot; - opc->v[2].x = s7_number_to_real(sc, arg1); /* move arg1? */ - opc->v[0].fd = (func) ? opt_d_dd_cs : opt_d_7dd_cs; - return_true(sc, car_x); - } + { + opc->v[1].p = slot; + opc->v[2].x = s7_number_to_real(sc, arg1); /* move arg1? */ + opc->v[0].fd = (func) ? opt_d_dd_cs : opt_d_7dd_cs; + return_true(sc, car_x); + } if (float_optimize(sc, cddr(car_x))) - { - opc->v[1].x = s7_number_to_real(sc, arg1); - if (d_dd_call_combinable(sc, opc, func)) - return_true(sc, car_x); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - opc->v[0].fd = (func) ? opt_d_dd_cf : opt_d_7dd_cf; - if ((opc->v[1].x == 1.0) && (func == subtract_d_dd)) opc->v[0].fd = opt_d_dd_1f_subtract; - return_true(sc, car_x); - } + { + opc->v[1].x = s7_number_to_real(sc, arg1); + if (d_dd_call_combinable(sc, opc, func)) + return_true(sc, car_x); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + opc->v[0].fd = (func) ? opt_d_dd_cf : opt_d_7dd_cf; + if ((opc->v[1].x == 1.0) && (func == subtract_d_dd)) opc->v[0].fd = opt_d_dd_1f_subtract; + return_true(sc, car_x); + } sc->pc = start; return_false(sc, car_x); } @@ -61209,43 +61209,43 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { opc->v[1].p = slot; if (is_small_real(arg2)) - { - opc->v[2].x = s7_number_to_real(sc, arg2); - if (func) - opc->v[0].fd = (func == subtract_d_dd) ? opt_d_dd_sc_sub : opt_d_dd_sc; - else opc->v[0].fd = opt_d_7dd_sc; - return_true(sc, car_x); - } + { + opc->v[2].x = s7_number_to_real(sc, arg2); + if (func) + opc->v[0].fd = (func == subtract_d_dd) ? opt_d_dd_sc_sub : opt_d_dd_sc; + else opc->v[0].fd = opt_d_7dd_sc; + return_true(sc, car_x); + } slot = opt_float_symbol(sc, arg2); if (slot) - { - opc->v[2].p = slot; - if (func) - { - if (func == multiply_d_dd) - opc->v[0].fd = opt_d_dd_ss_mul; - else opc->v[0].fd = (func == add_d_dd) ? opt_d_dd_ss_add : opt_d_dd_ss; - } - else opc->v[0].fd = opt_d_7dd_ss; - return_true(sc, car_x); - } + { + opc->v[2].p = slot; + if (func) + { + if (func == multiply_d_dd) + opc->v[0].fd = opt_d_dd_ss_mul; + else opc->v[0].fd = (func == add_d_dd) ? opt_d_dd_ss_add : opt_d_dd_ss; + } + else opc->v[0].fd = opt_d_7dd_ss; + return_true(sc, car_x); + } if (float_optimize(sc, cddr(car_x))) - { - if (d_dd_sf_combinable(sc, opc, func)) - return_true(sc, car_x); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - if (func) - { - opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_sf_mul : - ((func == add_d_dd) ? opt_d_dd_sf_add : - ((func == subtract_d_dd) ? opt_d_dd_sf_sub : opt_d_dd_sf)); - if ((func == multiply_d_dd) && (opc->v[5].fd == opt_d_7pii_scs)) - opc->v[0].fd = opt_d_dd_sf_mul_fvref; - } - else opc->v[0].fd = opt_d_7dd_sf; - return_true(sc, car_x); - } + { + if (d_dd_sf_combinable(sc, opc, func)) + return_true(sc, car_x); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + if (func) + { + opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_sf_mul : + ((func == add_d_dd) ? opt_d_dd_sf_add : + ((func == subtract_d_dd) ? opt_d_dd_sf_sub : opt_d_dd_sf)); + if ((func == multiply_d_dd) && (opc->v[5].fd == opt_d_7pii_scs)) + opc->v[0].fd = opt_d_dd_sf_mul_fvref; + } + else opc->v[0].fd = opt_d_7dd_sf; + return_true(sc, car_x); + } sc->pc = start; return_false(sc, car_x); } @@ -61262,137 +61262,137 @@ static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { int32_t start2 = sc->pc; if (is_small_real(arg2)) - { - opc->v[2].x = s7_number_to_real(sc, arg2); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - if (func) - { - if (func == add_d_dd) - { - opc->v[0].fd = (opc->v[5].fd == opt_d_7pi_ss_fvref_direct) ? opt_d_dd_fc_fvref_add : opt_d_dd_fc_add; - return_true(sc, car_x); - } - if (func == subtract_d_dd) - { - opc->v[0].fd = opt_d_dd_fc_subtract; - /* if o1->v[0].fd = opt_d_7d_c and its o->v[3].d_7d_f = random_d_7d it's (- (random f1) f2) */ - if ((opc == sc->opts[sc->pc - 2]) && - (sc->opts[start]->v[0].fd == opt_d_7d_c) && - (sc->opts[start]->v[3].d_7d_f == random_d_7d)) - { - opc->v[0].fd = opt_subtract_random_f_f; - opc->v[1].x = sc->opts[start]->v[1].x; /* random arg */ - backup_pc(sc); - }} - else opc->v[0].fd = opt_d_dd_fc; - } - else opc->v[0].fd = opt_d_7dd_fc; - return_true(sc, car_x); - } + { + opc->v[2].x = s7_number_to_real(sc, arg2); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + if (func) + { + if (func == add_d_dd) + { + opc->v[0].fd = (opc->v[5].fd == opt_d_7pi_ss_fvref_direct) ? opt_d_dd_fc_fvref_add : opt_d_dd_fc_add; + return_true(sc, car_x); + } + if (func == subtract_d_dd) + { + opc->v[0].fd = opt_d_dd_fc_subtract; + /* if o1->v[0].fd = opt_d_7d_c and its o->v[3].d_7d_f = random_d_7d it's (- (random f1) f2) */ + if ((opc == sc->opts[sc->pc - 2]) && + (sc->opts[start]->v[0].fd == opt_d_7d_c) && + (sc->opts[start]->v[3].d_7d_f == random_d_7d)) + { + opc->v[0].fd = opt_subtract_random_f_f; + opc->v[1].x = sc->opts[start]->v[1].x; /* random arg */ + backup_pc(sc); + }} + else opc->v[0].fd = opt_d_dd_fc; + } + else opc->v[0].fd = opt_d_7dd_fc; + return_true(sc, car_x); + } slot = opt_float_symbol(sc, arg2); if (slot) - { - opc->v[1].p = slot; - if (d_dd_fs_combinable(sc, opc, func)) - return_true(sc, car_x); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fd = sc->opts[start]->v[0].fd; - if (func) - { - opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_fs_mul : - ((func == add_d_dd) ? opt_d_dd_fs_add : - ((func == subtract_d_dd) ? opt_d_dd_fs_sub : opt_d_dd_fs)); - if ((func == add_d_dd) && (opc->v[5].fd == opt_d_7pii_scs)) - opc->v[0].fd = opt_d_dd_fs_add_fvref; - } - else opc->v[0].fd = opt_d_7dd_fs; - return_true(sc, car_x); - } + { + opc->v[1].p = slot; + if (d_dd_fs_combinable(sc, opc, func)) + return_true(sc, car_x); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + if (func) + { + opc->v[0].fd = (func == multiply_d_dd) ? opt_d_dd_fs_mul : + ((func == add_d_dd) ? opt_d_dd_fs_add : + ((func == subtract_d_dd) ? opt_d_dd_fs_sub : opt_d_dd_fs)); + if ((func == add_d_dd) && (opc->v[5].fd == opt_d_7pii_scs)) + opc->v[0].fd = opt_d_dd_fs_add_fvref; + } + else opc->v[0].fd = opt_d_7dd_fs; + return_true(sc, car_x); + } opc->v[10].o1 = sc->opts[sc->pc]; if (float_optimize(sc, cddr(car_x))) - { - opt_info *o2; - opc->v[8].o1 = o1; - opc->v[9].fd = o1->v[0].fd; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - if (func) - { - if (d_dd_ff_combinable(sc, opc, start)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_dd_ff; - if (func == multiply_d_dd) - { - if (arg1 == arg2) - opc->v[0].fd = opt_d_dd_ff_square; - else - if ((opc->v[9].fd == opt_d_7pii_sss_unchecked) && (opc->v[11].fd == opt_d_7pii_sss_unchecked) && - (o1->v[4].d_7pii_f == float_vector_ref_d_7pii)) - opc->v[0].fd = opt_d_dd_ff_mul_sss_unchecked; - else opc->v[0].fd = opt_d_dd_ff_mul; - return_true(sc, car_x); - } - o2 = sc->opts[start2]; /* this is opc->v[10].o1 */ - if (func == add_d_dd) - { - if (o2->v[0].fd == opt_d_dd_ff_mul) - { - opc->v[0].fd = opt_d_dd_ff_add_mul; - opc->v[4].o1 = o1; /* add first arg */ - opc->v[5].fd = o1->v[0].fd; - opc->v[8].o1 = o2->v[8].o1; /* mul first arg */ - opc->v[9].fd = o2->v[9].fd; - opc->v[10].o1 = o2->v[10].o1; /* mul second arg */ - opc->v[11].fd = o2->v[11].fd; - return_true(sc, car_x); - } - if ((o2->v[0].fd == opt_d_7pi_sf) && - ((o2->v[3].d_7pi_f == float_vector_ref_d_7pi) || (o2->v[3].d_7pi_f == float_vector_ref_d_7pi_direct))) - { - opc->v[0].fd = opt_d_dd_ff_add_fv_ref; - opc->v[6].p = o2->v[1].p; - opc->v[8].o1 = o2->v[10].o1; /* sc->opts[start2 + 1]; */ - opc->v[9].fi = o2->v[11].fi; /* sc->opts[start2 + 1]->v[0].fi; */ - } - else - { - opc->v[0].fd = opt_d_dd_ff_add; - opc->v[10].o1 = o2; - opc->v[11].fd = o2->v[0].fd; - - if ((o1->v[0].fd == opt_d_7pi_ss_fvref_direct) && (opc->v[11].fd == opt_d_7dd_ff)) - { - opt_info *ov = opc->v[10].o1; - if ((ov->v[3].d_7dd_f == divide_d_7dd) && (ov->v[11].fd == opt_d_id_sf) && (ov->v[9].fd == opt_d_7pi_ss_fvref_direct)) - { - opc->v[8].o1 = ov->v[8].o1; - opc->v[10].o1 = ov->v[10].o1; - opc->v[0].fd = opt_d_7dd_ff_add_div; - } - else opc->v[0].fd = opt_d_7dd_ff_add_fv_ref_direct; - }} - opc->v[4].o1 = o1; /* sc->opts[start]; */ - opc->v[5].fd = o1->v[0].fd; /* sc->opts[start]->v[0].fd; */ - return_true(sc, car_x); - } - if (func == subtract_d_dd) - { - opc->v[0].fd = opt_d_dd_ff_sub; - opc->v[4].o1 = o1; /* sc->opts[start]; */ - opc->v[5].fd = o1->v[0].fd; /* sc->opts[start]->v[0].fd; */ - opc->v[10].o1 = o2; - opc->v[11].fd = o2->v[0].fd; - return_true(sc, car_x); - }} - else - { - opc->v[0].fd = opt_d_7dd_ff; - if ((opc->v[11].fd == opt_d_dd_ff_add_fv_ref) && - (opc->v[3].d_7dd_f == divide_d_7dd)) - opc->v[0].fd = opt_d_7dd_ff_div_add; - } - return_true(sc, car_x); - }} + { + opt_info *o2; + opc->v[8].o1 = o1; + opc->v[9].fd = o1->v[0].fd; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + if (func) + { + if (d_dd_ff_combinable(sc, opc, start)) + return_true(sc, car_x); + opc->v[0].fd = opt_d_dd_ff; + if (func == multiply_d_dd) + { + if (arg1 == arg2) + opc->v[0].fd = opt_d_dd_ff_square; + else + if ((opc->v[9].fd == opt_d_7pii_sss_unchecked) && (opc->v[11].fd == opt_d_7pii_sss_unchecked) && + (o1->v[4].d_7pii_f == float_vector_ref_d_7pii)) + opc->v[0].fd = opt_d_dd_ff_mul_sss_unchecked; + else opc->v[0].fd = opt_d_dd_ff_mul; + return_true(sc, car_x); + } + o2 = sc->opts[start2]; /* this is opc->v[10].o1 */ + if (func == add_d_dd) + { + if (o2->v[0].fd == opt_d_dd_ff_mul) + { + opc->v[0].fd = opt_d_dd_ff_add_mul; + opc->v[4].o1 = o1; /* add first arg */ + opc->v[5].fd = o1->v[0].fd; + opc->v[8].o1 = o2->v[8].o1; /* mul first arg */ + opc->v[9].fd = o2->v[9].fd; + opc->v[10].o1 = o2->v[10].o1; /* mul second arg */ + opc->v[11].fd = o2->v[11].fd; + return_true(sc, car_x); + } + if ((o2->v[0].fd == opt_d_7pi_sf) && + ((o2->v[3].d_7pi_f == float_vector_ref_d_7pi) || (o2->v[3].d_7pi_f == float_vector_ref_d_7pi_direct))) + { + opc->v[0].fd = opt_d_dd_ff_add_fv_ref; + opc->v[6].p = o2->v[1].p; + opc->v[8].o1 = o2->v[10].o1; /* sc->opts[start2 + 1]; */ + opc->v[9].fi = o2->v[11].fi; /* sc->opts[start2 + 1]->v[0].fi; */ + } + else + { + opc->v[0].fd = opt_d_dd_ff_add; + opc->v[10].o1 = o2; + opc->v[11].fd = o2->v[0].fd; + + if ((o1->v[0].fd == opt_d_7pi_ss_fvref_direct) && (opc->v[11].fd == opt_d_7dd_ff)) + { + opt_info *ov = opc->v[10].o1; + if ((ov->v[3].d_7dd_f == divide_d_7dd) && (ov->v[11].fd == opt_d_id_sf) && (ov->v[9].fd == opt_d_7pi_ss_fvref_direct)) + { + opc->v[8].o1 = ov->v[8].o1; + opc->v[10].o1 = ov->v[10].o1; + opc->v[0].fd = opt_d_7dd_ff_add_div; + } + else opc->v[0].fd = opt_d_7dd_ff_add_fv_ref_direct; + }} + opc->v[4].o1 = o1; /* sc->opts[start]; */ + opc->v[5].fd = o1->v[0].fd; /* sc->opts[start]->v[0].fd; */ + return_true(sc, car_x); + } + if (func == subtract_d_dd) + { + opc->v[0].fd = opt_d_dd_ff_sub; + opc->v[4].o1 = o1; /* sc->opts[start]; */ + opc->v[5].fd = o1->v[0].fd; /* sc->opts[start]->v[0].fd; */ + opc->v[10].o1 = o2; + opc->v[11].fd = o2->v[0].fd; + return_true(sc, car_x); + }} + else + { + opc->v[0].fd = opt_d_7dd_ff; + if ((opc->v[11].fd == opt_d_dd_ff_add_fv_ref) && + (opc->v[3].d_7dd_f == divide_d_7dd)) + opc->v[0].fd = opt_d_7dd_ff_div_add; + } + return_true(sc, car_x); + }} sc->pc = start; return_false(sc, car_x); } @@ -61487,54 +61487,54 @@ static bool d_ddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[1].p = slot; slot = opt_float_symbol(sc, arg2); if (slot) - { - s7_pointer arg3 = cadddr(car_x); - opc->v[2].p = slot; - slot = opt_float_symbol(sc, arg3); - if (slot) - { - opc->v[3].p = slot; - opc->v[0].fd = opt_d_ddd_sss; - return_true(sc, car_x); - } - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[0].fd = opt_d_ddd_ssf; - return_true(sc, car_x); - } - sc->pc = start; - } + { + s7_pointer arg3 = cadddr(car_x); + opc->v[2].p = slot; + slot = opt_float_symbol(sc, arg3); + if (slot) + { + opc->v[3].p = slot; + opc->v[0].fd = opt_d_ddd_sss; + return_true(sc, car_x); + } + if (float_optimize(sc, cdddr(car_x))) + { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[0].fd = opt_d_ddd_ssf; + return_true(sc, car_x); + } + sc->pc = start; + } if (float_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[0].fd = opt_d_ddd_sff; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - return_true(sc, car_x); - }} + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(car_x))) + { + opc->v[0].fd = opt_d_ddd_sff; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + return_true(sc, car_x); + }} sc->pc = start; } if (float_optimize(sc, cdr(car_x))) { opc->v[8].o1 = sc->opts[sc->pc]; if (float_optimize(sc, cddr(car_x))) - { - opc->v[5].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - if (d_ddd_fff_combinable(sc, opc, start)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_ddd_fff; /* tfft: (* xout xin iw) (+ (* xout xin iw) (* yout yin ih) (* zout zin id)) */ - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[6].fd = opc->v[5].o1->v[0].fd; - if ((f == multiply_d_ddd) && (opc->v[11].fd == opt_D_s) && (opc->v[9].fd == opt_D_s) && (opc->v[6].fd == opt_d_s)) - opc->v[0].fd = opt_d_ddd_fff_mul; - return_true(sc, car_x); - }}} + { + opc->v[5].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(car_x))) + { + if (d_ddd_fff_combinable(sc, opc, start)) + return_true(sc, car_x); + opc->v[0].fd = opt_d_ddd_fff; /* tfft: (* xout xin iw) (+ (* xout xin iw) (* yout yin ih) (* zout zin id)) */ + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + opc->v[6].fd = opc->v[5].o1->v[0].fd; + if ((f == multiply_d_ddd) && (opc->v[11].fd == opt_D_s) && (opc->v[9].fd == opt_D_s) && (opc->v[6].fd == opt_d_s)) + opc->v[0].fd = opt_d_ddd_fff_mul; + return_true(sc, car_x); + }}} sc->pc = start; return_false(sc, car_x); } @@ -61581,15 +61581,15 @@ static s7_double opt_d_7pid_sso(opt_info *o) static s7_double opt_d_7pid_ss_ss(opt_info *o) { return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), - integer(slot_value(o->v[2].p)), - o->v[3].d_7pi_f(o->sc, slot_value(o->v[5].p), integer(slot_value(o->v[6].p))))); + integer(slot_value(o->v[2].p)), + o->v[3].d_7pi_f(o->sc, slot_value(o->v[5].p), integer(slot_value(o->v[6].p))))); } static s7_double opt_d_7pid_ssfo(opt_info *o) { s7_pointer fv = slot_value(o->v[1].p); return(o->v[4].d_7pid_f(o->sc, fv, integer(slot_value(o->v[2].p)), - o->v[6].d_dd_f(o->v[5].d_7pi_f(o->sc, fv, integer(slot_value(o->v[3].p))), real(slot_value(o->v[8].p))))); + o->v[6].d_dd_f(o->v[5].d_7pi_f(o->sc, fv, integer(slot_value(o->v[3].p))), real(slot_value(o->v[8].p))))); } static s7_double opt_d_7pid_ssfo_fv(opt_info *o) @@ -61628,40 +61628,40 @@ static bool d_7pid_ssf_combinable(s7_scheme *sc, opt_info *opc) { opt_info *o1 = sc->opts[sc->pc - 1]; if (o1->v[0].fd == opt_d_v) - { - opc->v[6].p = o1->v[1].p; - opc->v[3].obj = o1->v[5].obj; - opc->v[5].d_v_f = o1->v[3].d_v_f; - opc->v[0].fd = opt_d_7pid_sso; - backup_pc(sc); - return_true(sc, NULL); - } + { + opc->v[6].p = o1->v[1].p; + opc->v[3].obj = o1->v[5].obj; + opc->v[5].d_v_f = o1->v[3].d_v_f; + opc->v[0].fd = opt_d_7pid_sso; + backup_pc(sc); + return_true(sc, NULL); + } if ((o1->v[0].fd == opt_d_7pi_ss) || (o1->v[0].fd == opt_d_7pi_ss_fvref) || (o1->v[0].fd == opt_d_7pi_ss_fvref_direct)) - { - opc->v[3].d_7pi_f = o1->v[3].d_7pi_f; - opc->v[5].p = o1->v[1].p; - opc->v[6].p = o1->v[2].p; - opc->v[0].fd = opt_d_7pid_ss_ss; - backup_pc(sc); - return_true(sc, NULL); - } + { + opc->v[3].d_7pi_f = o1->v[3].d_7pi_f; + opc->v[5].p = o1->v[1].p; + opc->v[6].p = o1->v[2].p; + opc->v[0].fd = opt_d_7pid_ss_ss; + backup_pc(sc); + return_true(sc, NULL); + } if ((o1->v[0].fd == opt_d_dd_fso) && - (opc->v[1].p == o1->v[2].p)) - { - /* opc: pid_ssf: o->v[4].d_7pid_f(slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o1->v[0].fd(o1)) - * o1: d_dd_fso: o->v[4].d_dd_f(o->v[5].d_7pi_f(slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p)))) - */ - opc->v[6].d_dd_f = o1->v[4].d_dd_f; - opc->v[5].d_7pi_f = o1->v[5].d_7pi_f; - opc->v[3].p = o1->v[3].p; - opc->v[8].p = o1->v[1].p; - opc->v[0].fd = opt_d_7pid_ssfo; - if (((opc->v[5].d_7pi_f == float_vector_ref_d_7pi) || (opc->v[5].d_7pi_f == float_vector_ref_d_7pi_direct)) && - ((opc->v[4].d_7pid_f == float_vector_set_d_7pid_direct) || (opc->v[4].d_7pid_f == float_vector_set_d_7pid))) - opc->v[0].fd = opt_d_7pid_ssfo_fv; /* actually if either is *_d, we need to check the indices */ - backup_pc(sc); - return_true(sc, NULL); - }} + (opc->v[1].p == o1->v[2].p)) + { + /* opc: pid_ssf: o->v[4].d_7pid_f(slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o1->v[0].fd(o1)) + * o1: d_dd_fso: o->v[4].d_dd_f(o->v[5].d_7pi_f(slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p)))) + */ + opc->v[6].d_dd_f = o1->v[4].d_dd_f; + opc->v[5].d_7pi_f = o1->v[5].d_7pi_f; + opc->v[3].p = o1->v[3].p; + opc->v[8].p = o1->v[1].p; + opc->v[0].fd = opt_d_7pid_ssfo; + if (((opc->v[5].d_7pi_f == float_vector_ref_d_7pi) || (opc->v[5].d_7pi_f == float_vector_ref_d_7pi_direct)) && + ((opc->v[4].d_7pid_f == float_vector_set_d_7pid_direct) || (opc->v[4].d_7pid_f == float_vector_set_d_7pid))) + opc->v[0].fd = opt_d_7pid_ssfo_fv; /* actually if either is *_d, we need to check the indices */ + backup_pc(sc); + return_true(sc, NULL); + }} return_false(sc, NULL); } @@ -61678,45 +61678,45 @@ static bool d_7pid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe opc->v[4].d_7pid_f = f; if (is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) - return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), NULL, NULL, cdddr(car_x))); + return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), NULL, NULL, cdddr(car_x))); opc->v[1].p = s7_slot(sc, cadr(car_x)); opc->v[10].o1 = sc->opts[start]; if (is_slot(opc->v[1].p)) - { - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[2].p = slot; - slot = opt_float_symbol(sc, cadddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - opc->v[0].fd = opt_d_7pid_sss; - return_true(sc, car_x); - } - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[11].fd = sc->opts[start]->v[0].fd; - if (d_7pid_ssf_combinable(sc, opc)) - return_true(sc, car_x); - opc->v[0].fd = opt_d_7pid_ssf; - return_true(sc, car_x); - } - sc->pc = start; - } - if (int_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[0].fd = opt_d_7pid_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - return_true(sc, car_x); - }} - sc->pc = start; - }} + { + slot = opt_integer_symbol(sc, caddr(car_x)); + if (slot) + { + opc->v[2].p = slot; + slot = opt_float_symbol(sc, cadddr(car_x)); + if (slot) + { + opc->v[3].p = slot; + opc->v[0].fd = opt_d_7pid_sss; + return_true(sc, car_x); + } + if (float_optimize(sc, cdddr(car_x))) + { + opc->v[11].fd = sc->opts[start]->v[0].fd; + if (d_7pid_ssf_combinable(sc, opc)) + return_true(sc, car_x); + opc->v[0].fd = opt_d_7pid_ssf; + return_true(sc, car_x); + } + sc->pc = start; + } + if (int_optimize(sc, cddr(car_x))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(car_x))) + { + opc->v[0].fd = opt_d_7pid_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + return_true(sc, car_x); + }} + sc->pc = start; + }} return_false(sc, car_x); } @@ -61754,42 +61754,42 @@ static bool d_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe int32_t start = sc->pc; opc->v[1].p = s7_slot(sc, cadr(car_x)); if ((!is_slot(opc->v[1].p)) || - (!is_float_vector(slot_value(opc->v[1].p))) || - (vector_rank(slot_value(opc->v[1].p)) != 2)) - return_false(sc, car_x); + (!is_float_vector(slot_value(opc->v[1].p))) || + (vector_rank(slot_value(opc->v[1].p)) != 2)) + return_false(sc, car_x); opc->v[4].d_7pii_f = ifunc; /* currently pointless */ slot = opt_integer_symbol(sc, cadddr(car_x)); if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[2].p = slot; - opc->v[0].fd = opt_d_7pii_sss; - if ((loop_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && - (loop_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) - opc->v[0].fd = opt_d_7pii_sss_unchecked; - return_true(sc, car_x); - } - if (is_t_integer(caddr(car_x))) - { - opc->v[2].i = integer(caddr(car_x)); - opc->v[0].fd = opt_d_7pii_scs; - return_true(sc, car_x); - }} + { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, caddr(car_x)); + if (slot) + { + opc->v[2].p = slot; + opc->v[0].fd = opt_d_7pii_sss; + if ((loop_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && + (loop_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) + opc->v[0].fd = opt_d_7pii_sss_unchecked; + return_true(sc, car_x); + } + if (is_t_integer(caddr(car_x))) + { + opc->v[2].i = integer(caddr(car_x)); + opc->v[0].fd = opt_d_7pii_scs; + return_true(sc, car_x); + }} opc->v[10].o1 = sc->opts[start]; if (int_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdddr(car_x))) - { - opc->v[0].fd = opt_d_7pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }} + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(car_x))) + { + opc->v[0].fd = opt_d_7pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + return_true(sc, car_x); + }} sc->pc = start; } return_false(sc, car_x); @@ -61837,7 +61837,7 @@ static bool d_7piid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point { opc->v[4].d_7piid_f = f; if (is_target_or_its_alias(car(car_x), s_func, sc->float_vector_set_symbol)) - return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x), NULL, cddddr(car_x))); + return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x), NULL, cddddr(car_x))); } return_false(sc, car_x); } @@ -61846,7 +61846,7 @@ static bool d_7piid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point static s7_double opt_d_7piii_ssss(opt_info *o) { return(float_vector_ref_d_7piii(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), - integer(slot_value(o->v[3].p)), integer(slot_value(o->v[5].p)))); + integer(slot_value(o->v[3].p)), integer(slot_value(o->v[5].p)))); } static s7_double opt_d_7piii_ssss_unchecked(opt_info *o) @@ -61866,31 +61866,31 @@ static bool d_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point s7_pointer slot; opc->v[1].p = s7_slot(sc, cadr(car_x)); if ((!is_slot(opc->v[1].p)) || - (!is_float_vector(slot_value(opc->v[1].p))) || - (vector_rank(slot_value(opc->v[1].p)) != 3)) - return_false(sc, car_x); + (!is_float_vector(slot_value(opc->v[1].p))) || + (vector_rank(slot_value(opc->v[1].p)) != 3)) + return_false(sc, car_x); opc->v[4].d_7piii_f = ifunc; /* currently ignored */ slot = opt_integer_symbol(sc, car(cddddr(car_x))); if (slot) - { - opc->v[5].p = slot; - slot = opt_integer_symbol(sc, cadddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - s7_pointer vect = slot_value(opc->v[1].p); - opc->v[2].p = slot; - opc->v[0].fd = opt_d_7piii_ssss; - if ((loop_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && - (loop_end_fits(opc->v[3].p, vector_dimension(vect, 1))) && - (loop_end_fits(opc->v[5].p, vector_dimension(vect, 2)))) - opc->v[0].fd = opt_d_7piii_ssss_unchecked; - return_true(sc, car_x); - }}}} + { + opc->v[5].p = slot; + slot = opt_integer_symbol(sc, cadddr(car_x)); + if (slot) + { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, caddr(car_x)); + if (slot) + { + s7_pointer vect = slot_value(opc->v[1].p); + opc->v[2].p = slot; + opc->v[0].fd = opt_d_7piii_ssss; + if ((loop_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && + (loop_end_fits(opc->v[3].p, vector_dimension(vect, 1))) && + (loop_end_fits(opc->v[5].p, vector_dimension(vect, 2)))) + opc->v[0].fd = opt_d_7piii_ssss_unchecked; + return_true(sc, car_x); + }}}} return_false(sc, car_x); } @@ -61898,7 +61898,7 @@ static bool d_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_point static s7_double opt_d_7piiid_ssssf(opt_info *o) { return(float_vector_set_d_7piiid(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), - integer(slot_value(o->v[3].p)), integer(slot_value(o->v[5].p)), o->v[11].fd(o->v[10].o1))); + integer(slot_value(o->v[3].p)), integer(slot_value(o->v[5].p)), o->v[11].fd(o->v[10].o1))); } static s7_double opt_d_7piiid_ssssf_unchecked(opt_info *o) @@ -61920,7 +61920,7 @@ static bool d_7piiid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poin { opc->v[4].d_7piiid_f = f; if (is_target_or_its_alias(car(car_x), s_func, sc->float_vector_set_symbol)) - return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x), cddddr(car_x), cdr(cddddr(car_x)))); + return(opt_float_vector_set(sc, opc, cadr(car_x), cddr(car_x), cdddr(car_x), cddddr(car_x), cdr(cddddr(car_x)))); } return_false(sc, car_x); } @@ -61935,138 +61935,138 @@ static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_ int32_t start = sc->pc; opc->v[1].p = settee; if (!is_float_vector(vect)) - return_false(sc, NULL); + return_false(sc, NULL); opc->v[10].o1 = sc->opts[start]; if ((!indexp2) && - (vector_rank(vect) == 1)) - { - opc->v[4].d_7pid_f = float_vector_set_d_7pid; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if (loop_end_fits(opc->v[2].p, vector_length(vect))) - opc->v[4].d_7pid_f = float_vector_set_d_7pid_direct; - slot = opt_float_symbol(sc, car(valp)); - if (slot) - { - opc->v[3].p = slot; - opc->v[0].fd = opt_d_7pid_sss; - return_true(sc, NULL); - } - if (is_small_real(car(valp))) - { - opc->v[3].x = s7_real(car(valp)); - opc->v[0].fd = opt_d_7pid_ssc; - return_true(sc, NULL); - } - if (float_optimize(sc, valp)) - { - opc->v[11].fd = sc->opts[start]->v[0].fd; - if (d_7pid_ssf_combinable(sc, opc)) - return_true(sc, NULL); - opc->v[0].fd = opt_d_7pid_ssf; - return_true(sc, NULL); - } - sc->pc = start; - } - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, valp)) - { - opc->v[0].fd = (opc->v[4].d_7pid_f == float_vector_set_d_7pid) ? opt_d_7pid_sff_fvset : opt_d_7pid_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - return_true(sc, NULL); - }} - return_false(sc, NULL); - } + (vector_rank(vect) == 1)) + { + opc->v[4].d_7pid_f = float_vector_set_d_7pid; + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) + { + opc->v[2].p = slot; + if (loop_end_fits(opc->v[2].p, vector_length(vect))) + opc->v[4].d_7pid_f = float_vector_set_d_7pid_direct; + slot = opt_float_symbol(sc, car(valp)); + if (slot) + { + opc->v[3].p = slot; + opc->v[0].fd = opt_d_7pid_sss; + return_true(sc, NULL); + } + if (is_small_real(car(valp))) + { + opc->v[3].x = s7_real(car(valp)); + opc->v[0].fd = opt_d_7pid_ssc; + return_true(sc, NULL); + } + if (float_optimize(sc, valp)) + { + opc->v[11].fd = sc->opts[start]->v[0].fd; + if (d_7pid_ssf_combinable(sc, opc)) + return_true(sc, NULL); + opc->v[0].fd = opt_d_7pid_ssf; + return_true(sc, NULL); + } + sc->pc = start; + } + if (int_optimize(sc, indexp1)) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, valp)) + { + opc->v[0].fd = (opc->v[4].d_7pid_f == float_vector_set_d_7pid) ? opt_d_7pid_sff_fvset : opt_d_7pid_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + return_true(sc, NULL); + }} + return_false(sc, NULL); + } if ((indexp2) && (!indexp3) && - (vector_rank(vect) == 2)) - { - opc->v[5].d_7piid_f = float_vector_set_d_7piid; - /* could check for loop_end/end-ok here for both indices, but the d_7pii* functions currently assume fv_d_7piid - * perhaps set a different fd? so opc->v[0].fd = fvset_unchecked_d_7piid or whatever - */ - slot = opt_integer_symbol(sc, car(indexp2)); - if (slot) - { - opc->v[3].p = slot; - if (is_t_integer(car(indexp1))) - { - if (!float_optimize(sc, valp)) - return_false(sc, NULL); - opc->v[0].fd = opt_d_7piid_scsf; - opc->v[2].i = integer(car(indexp1)); - opc->v[11].fd = opc->v[10].o1->v[0].fd; - return_true(sc, NULL); - } - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if (is_small_real(car(valp))) - { - opc->v[0].fd = opt_d_7piid_sssc; - opc->v[4].x = s7_real(car(valp)); - return_true(sc, NULL); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, valp)) - { - opc->v[0].fd = opt_d_7piid_sssf; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - - if ((loop_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && - (loop_end_fits(opc->v[3].p, vector_dimension(vect, 1)))) - opc->v[0].fd = opt_d_7piid_sssf_unchecked; - return_true(sc, NULL); - } - sc->pc = start; - }} - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp2)) - { - opc->v[3].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, valp)) - { - opc->v[0].fd = opt_d_7piid_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[4].fd = opc->v[3].o1->v[0].fd; - return_true(sc, NULL); - }}} - return_false(sc, NULL); - } + (vector_rank(vect) == 2)) + { + opc->v[5].d_7piid_f = float_vector_set_d_7piid; + /* could check for loop_end/end-ok here for both indices, but the d_7pii* functions currently assume fv_d_7piid + * perhaps set a different fd? so opc->v[0].fd = fvset_unchecked_d_7piid or whatever + */ + slot = opt_integer_symbol(sc, car(indexp2)); + if (slot) + { + opc->v[3].p = slot; + if (is_t_integer(car(indexp1))) + { + if (!float_optimize(sc, valp)) + return_false(sc, NULL); + opc->v[0].fd = opt_d_7piid_scsf; + opc->v[2].i = integer(car(indexp1)); + opc->v[11].fd = opc->v[10].o1->v[0].fd; + return_true(sc, NULL); + } + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) + { + opc->v[2].p = slot; + if (is_small_real(car(valp))) + { + opc->v[0].fd = opt_d_7piid_sssc; + opc->v[4].x = s7_real(car(valp)); + return_true(sc, NULL); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, valp)) + { + opc->v[0].fd = opt_d_7piid_sssf; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + + if ((loop_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && + (loop_end_fits(opc->v[3].p, vector_dimension(vect, 1)))) + opc->v[0].fd = opt_d_7piid_sssf_unchecked; + return_true(sc, NULL); + } + sc->pc = start; + }} + if (int_optimize(sc, indexp1)) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) + { + opc->v[3].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, valp)) + { + opc->v[0].fd = opt_d_7piid_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[4].fd = opc->v[3].o1->v[0].fd; + return_true(sc, NULL); + }}} + return_false(sc, NULL); + } if ((indexp3) && - (vector_rank(vect) == 3)) - { - opc->v[4].d_7piiid_f = float_vector_set_d_7piiid; - slot = opt_integer_symbol(sc, car(indexp3)); - if (slot) - { - opc->v[5].p = slot; - slot = opt_integer_symbol(sc, car(indexp2)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - if (float_optimize(sc, valp)) - { - opc->v[0].fd = opt_d_7piiid_ssssf; - opc->v[11].fd = sc->opts[start]->v[0].fd; - if ((loop_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && - (loop_end_fits(opc->v[3].p, vector_dimension(vect, 1))) && - (loop_end_fits(opc->v[5].p, vector_dimension(vect, 2)))) - opc->v[0].fd = opt_d_7piiid_ssssf_unchecked; - return_true(sc, NULL); - }}}}}} + (vector_rank(vect) == 3)) + { + opc->v[4].d_7piiid_f = float_vector_set_d_7piiid; + slot = opt_integer_symbol(sc, car(indexp3)); + if (slot) + { + opc->v[5].p = slot; + slot = opt_integer_symbol(sc, car(indexp2)); + if (slot) + { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) + { + opc->v[2].p = slot; + if (float_optimize(sc, valp)) + { + opc->v[0].fd = opt_d_7piiid_ssssf; + opc->v[11].fd = sc->opts[start]->v[0].fd; + if ((loop_end_fits(opc->v[2].p, vector_dimension(vect, 0))) && + (loop_end_fits(opc->v[3].p, vector_dimension(vect, 1))) && + (loop_end_fits(opc->v[5].p, vector_dimension(vect, 2)))) + opc->v[0].fd = opt_d_7piiid_ssssf_unchecked; + return_true(sc, NULL); + }}}}}} return_false(sc, NULL); } @@ -62084,9 +62084,9 @@ static inline s7_double opt_fmv(opt_info *o) s7_double vib = real(slot_value(o2->v[2].p)); s7_double index_env = o3->v[5].d_v_f(o3->v[1].obj); return(o->v[4].d_vid_f(o->v[5].obj, - integer(slot_value(o->v[2].p)), - amp_env * o2->v[3].d_vd_f(o2->v[5].obj, - vib + (index_env * o3->v[6].d_vd_f(o3->v[2].obj, vib))))); + integer(slot_value(o->v[2].p)), + amp_env * o2->v[3].d_vd_f(o2->v[5].obj, + vib + (index_env * o3->v[6].d_vd_f(o3->v[2].obj, vib))))); } static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x) @@ -62097,47 +62097,47 @@ static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_pointer sig; s7_d_vid_t flt = s7_d_vid_function(s_func); if (!flt) - return_false(sc, car_x); + return_false(sc, car_x); opc->v[4].d_vid_f = flt; sig = c_function_signature(s_func); if (is_pair(sig)) - { - int32_t start = sc->pc; - s7_pointer vslot = opt_types_match(sc, cadr(sig), cadr(car_x)); - if (vslot) - { - s7_pointer slot; - opc->v[0].fd = opt_d_vid_ssf; - opc->v[1].p = vslot; - opc->v[10].o1 = sc->opts[start]; - slot = opt_integer_symbol(sc, caddr(car_x)); - if ((slot) && - (float_optimize(sc, cdddr(car_x)))) - { - opt_info *o2; - opc->v[2].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(vslot)); - opc->v[11].fd = opc->v[10].o1->v[0].fd; - o2 = sc->opts[start]; - if (o2->v[0].fd == opt_d_dd_ff_mul1) - { - opt_info *o3 = sc->opts[start + 2]; - if (o3->v[0].fd == opt_d_vd_o1) - { - opt_info *o1 = sc->opts[start + 4]; - 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[12].o1 = o2; - opc->v[13].o1 = o3; - opc->v[14].o1 = o1; - }}} - return_true(sc, car_x); - }} - sc->pc = start; - }} + { + int32_t start = sc->pc; + s7_pointer vslot = opt_types_match(sc, cadr(sig), cadr(car_x)); + if (vslot) + { + s7_pointer slot; + opc->v[0].fd = opt_d_vid_ssf; + opc->v[1].p = vslot; + opc->v[10].o1 = sc->opts[start]; + slot = opt_integer_symbol(sc, caddr(car_x)); + if ((slot) && + (float_optimize(sc, cdddr(car_x)))) + { + opt_info *o2; + opc->v[2].p = slot; + opc->v[5].obj = (void *)c_object_value(slot_value(vslot)); + opc->v[11].fd = opc->v[10].o1->v[0].fd; + o2 = sc->opts[start]; + if (o2->v[0].fd == opt_d_dd_ff_mul1) + { + opt_info *o3 = sc->opts[start + 2]; + if (o3->v[0].fd == opt_d_vd_o1) + { + opt_info *o1 = sc->opts[start + 4]; + 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[12].o1 = o2; + opc->v[13].o1 = o3; + opc->v[14].o1 = o1; + }}} + return_true(sc, car_x); + }} + sc->pc = start; + }} return_false(sc, car_x); } @@ -62157,26 +62157,26 @@ static bool d_vdd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_pointer sig = c_function_signature(s_func); opc->v[4].d_vdd_f = flt; if (is_pair(sig)) - { - s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(car_x)); - if (slot) - { - int32_t start = sc->pc; - opc->v[10].o1 = sc->opts[start]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[1].p = slot; - opc->v[5].obj = (void *)c_object_value(slot_value(slot)); - opc->v[0].fd = opt_d_vdd_ff; - return_true(sc, car_x); - }} - sc->pc = start; - }}} + { + s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(car_x)); + if (slot) + { + int32_t start = sc->pc; + opc->v[10].o1 = sc->opts[start]; + if (float_optimize(sc, cddr(car_x))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(car_x))) + { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + opc->v[1].p = slot; + opc->v[5].obj = (void *)c_object_value(slot_value(slot)); + opc->v[0].fd = opt_d_vdd_ff; + return_true(sc, car_x); + }} + sc->pc = start; + }}} return_false(sc, car_x); } @@ -62201,21 +62201,21 @@ static bool d_dddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe { opc->v[8].o1 = sc->opts[sc->pc]; if (float_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdddr(car_x))) - { - opc->v[2].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddddr(car_x))) - { - opc->v[1].d_dddd_f = f; - opc->v[0].fd = opt_d_dddd_ffff; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[5].fd = opc->v[4].o1->v[0].fd; - opc->v[3].fd = opc->v[2].o1->v[0].fd; - return_true(sc, car_x); - }}}} + { + opc->v[4].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(car_x))) + { + opc->v[2].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddddr(car_x))) + { + opc->v[1].d_dddd_f = f; + opc->v[0].fd = opt_d_dddd_ffff; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + opc->v[5].fd = opc->v[4].o1->v[0].fd; + opc->v[3].fd = opc->v[2].o1->v[0].fd; + return_true(sc, car_x); + }}}} return_false(sc, car_x); } @@ -62252,17 +62252,17 @@ static bool d_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x) s7_pointer p; int32_t cur_len; for (cur_len = 0, p = cdr(car_x); (is_pair(p)) && (cur_len < 12); p = cdr(p), cur_len++) - { - opc->v[cur_len + 2].o1 = sc->opts[sc->pc]; - if (!float_optimize(sc, p)) - break; - } + { + opc->v[cur_len + 2].o1 = sc->opts[sc->pc]; + if (!float_optimize(sc, p)) + break; + } if (is_null(p)) - { - opc->v[1].i = cur_len; - opc->v[0].fd = (head == sc->add_symbol) ? opt_d_add_any_f : opt_d_multiply_any_f; - return_true(sc, car_x); - }} + { + opc->v[1].i = cur_len; + opc->v[0].fd = (head == sc->add_symbol) ? opt_d_add_any_f : opt_d_multiply_any_f; + return_true(sc, car_x); + }} sc->pc = start; return_false(sc, car_x); } @@ -62292,46 +62292,46 @@ static bool d_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len) s7_pointer arg1 = cadr(car_x); opt_info *opc = alloc_opt_info(sc); if (is_symbol(arg1)) - { - s7_pointer settee; - if (is_immutable(arg1)) - return_false(sc, car_x); - settee = s7_slot(sc, arg1); - if ((is_slot(settee)) && - (is_t_real(slot_value(settee))) && - (!is_immutable_slot(settee)) && - ((!slot_has_setter(settee)) || - ((is_c_function(slot_setter(settee))) && - ((slot_setter(settee) == initial_value(sc->is_float_symbol)) || - (c_function_call(slot_setter(settee)) == b_is_float_setter))))) - { - opt_info *o1 = sc->opts[sc->pc]; - opc->v[1].p = settee; - if ((!is_t_integer(caddr(car_x))) && - (float_optimize(sc, cddr(car_x)))) - { /* tari: (set! rlo (min rlo (real-part (v i)))) -- can't tell here that it is used only in this line in the do body */ - /* PERHAPS: if tree_count(body) - tree_count(line) == 0 and no setters within line it's safe as mutable? use the two_sets bit as before? */ - /* but we also need a list of such opt_info ptrs to cancel mutability at the end */ - /* tall: (set! la ca)! (How?) - * (set! temp1 (one-zero dryTap0 (one-pole dryTap1 (piano-noise pnoise amp)))) - * and many more, but none will be self-contained I think - */ - opc->v[0].fd = (is_mutable_number(slot_value(opc->v[1].p))) ? opt_set_d_d_fm : opt_set_d_d_f; - /* if (opc->v[0].fd == opt_set_d_d_f) fprintf(stderr, "%d: %s\n", __LINE__, display(car_x)); */ - opc->v[2].o1 = o1; - opc->v[3].fd = o1->v[0].fd; - return_true(sc, car_x); - }}} + { + s7_pointer settee; + if (is_immutable(arg1)) + return_false(sc, car_x); + settee = s7_slot(sc, arg1); + if ((is_slot(settee)) && + (is_t_real(slot_value(settee))) && + (!is_immutable_slot(settee)) && + ((!slot_has_setter(settee)) || + ((is_c_function(slot_setter(settee))) && + ((slot_setter(settee) == initial_value(sc->is_float_symbol)) || + (c_function_call(slot_setter(settee)) == b_is_float_setter))))) + { + opt_info *o1 = sc->opts[sc->pc]; + opc->v[1].p = settee; + if ((!is_t_integer(caddr(car_x))) && + (float_optimize(sc, cddr(car_x)))) + { /* tari: (set! rlo (min rlo (real-part (v i)))) -- can't tell here that it is used only in this line in the do body */ + /* PERHAPS: if tree_count(body) - tree_count(line) == 0 and no setters within line it's safe as mutable? use the two_sets bit as before? */ + /* but we also need a list of such opt_info ptrs to cancel mutability at the end */ + /* tall: (set! la ca)! (How?) + * (set! temp1 (one-zero dryTap0 (one-pole dryTap1 (piano-noise pnoise amp)))) + * and many more, but none will be self-contained I think + */ + opc->v[0].fd = (is_mutable_number(slot_value(opc->v[1].p))) ? opt_set_d_d_fm : opt_set_d_d_f; + /* if (opc->v[0].fd == opt_set_d_d_f) fprintf(stderr, "%d: %s\n", __LINE__, display(car_x)); */ + opc->v[2].o1 = o1; + opc->v[3].fd = o1->v[0].fd; + return_true(sc, car_x); + }}} else /* if is_pair(settee) get setter */ - if ((is_pair(arg1)) && - (is_symbol(car(arg1))) && - (is_pair(cdr(arg1)))) - { - if (is_null(cddr(arg1))) - return(opt_float_vector_set(sc, opc, car(arg1), cdr(arg1), NULL, NULL, cddr(car_x))); - if (is_null(cdddr(arg1))) - return(opt_float_vector_set(sc, opc, car(arg1), cdr(arg1), cddr(arg1), NULL, cddr(car_x))); - }} + if ((is_pair(arg1)) && + (is_symbol(car(arg1))) && + (is_pair(cdr(arg1)))) + { + if (is_null(cddr(arg1))) + return(opt_float_vector_set(sc, opc, car(arg1), cdr(arg1), NULL, NULL, cddr(car_x))); + if (is_null(cdddr(arg1))) + return(opt_float_vector_set(sc, opc, car(arg1), cdr(arg1), cddr(arg1), NULL, cddr(car_x))); + }} return_false(sc, car_x); } @@ -62342,110 +62342,110 @@ static bool d_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, in { /* implicit float-vector-ref */ if ((len == 2) && - (vector_rank(obj) == 1)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - opc->v[3].d_7pi_f = float_vector_ref_d_7pi; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - if (loop_end_fits(opc->v[2].p, vector_length(obj))) - opc->v[0].fd = opt_d_7pi_ss_fvref_direct; - else opc->v[0].fd = opt_d_7pi_ss_fvref; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[0].fd = opt_d_7pi_sf; - return_true(sc, car_x); - } + (vector_rank(obj) == 1)) + { + opt_info *opc = alloc_opt_info(sc); + opc->v[1].p = s_slot; + opc->v[3].d_7pi_f = float_vector_ref_d_7pi; + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) + { + opc->v[2].p = slot; + if (loop_end_fits(opc->v[2].p, vector_length(obj))) + opc->v[0].fd = opt_d_7pi_ss_fvref_direct; + else opc->v[0].fd = opt_d_7pi_ss_fvref; + return_true(sc, car_x); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(car_x))) + return_false(sc, car_x); + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[0].fd = opt_d_7pi_sf; + return_true(sc, car_x); + } if ((len == 3) && - (vector_rank(obj) == 2)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - opc->v[4].d_7pii_f = float_vector_ref_d_7pii; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - opc->v[0].fd = opt_d_7pii_sss; - if ((loop_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (loop_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) - opc->v[0].fd = opt_d_7pii_sss_unchecked; - return_true(sc, car_x); - }} - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fd = opt_d_7pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }}} + (vector_rank(obj) == 2)) + { + opt_info *opc = alloc_opt_info(sc); + opc->v[1].p = s_slot; + opc->v[4].d_7pii_f = float_vector_ref_d_7pii; + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) + { + opc->v[2].p = slot; + slot = opt_integer_symbol(sc, caddr(car_x)); + if (slot) + { + opc->v[3].p = slot; + opc->v[0].fd = opt_d_7pii_sss; + if ((loop_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && + (loop_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) + opc->v[0].fd = opt_d_7pii_sss_unchecked; + return_true(sc, car_x); + }} + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) + { + opc->v[0].fd = opt_d_7pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + return_true(sc, car_x); + }}} if ((len == 4) && - (vector_rank(obj) == 3)) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - opc->v[4].d_7piii_f = float_vector_ref_d_7piii; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[2].p = slot; - slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, cadddr(car_x)); - if (slot) - { - opc->v[5].p = slot; - opc->v[0].fd = opt_d_7piii_ssss; - if ((loop_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (loop_end_fits(opc->v[3].p, vector_dimension(obj, 1))) && - (loop_end_fits(opc->v[5].p, vector_dimension(obj, 2)))) - opc->v[0].fd = opt_d_7piii_ssss_unchecked; - return_true(sc, car_x); - }}}}} + (vector_rank(obj) == 3)) + { + opt_info *opc = alloc_opt_info(sc); + opc->v[1].p = s_slot; + opc->v[4].d_7piii_f = float_vector_ref_d_7piii; + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) + { + opc->v[2].p = slot; + slot = opt_integer_symbol(sc, caddr(car_x)); + if (slot) + { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, cadddr(car_x)); + if (slot) + { + opc->v[5].p = slot; + opc->v[0].fd = opt_d_7piii_ssss; + if ((loop_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && + (loop_end_fits(opc->v[3].p, vector_dimension(obj, 1))) && + (loop_end_fits(opc->v[5].p, vector_dimension(obj, 2)))) + opc->v[0].fd = opt_d_7piii_ssss_unchecked; + return_true(sc, car_x); + }}}}} if ((is_c_object(obj)) && (len == 2)) { s7_pointer getf = c_object_getf(sc, obj); if (is_c_function(getf)) /* default is #f */ - { - s7_d_7pi_t func = s7_d_7pi_function(getf); - if (func) - { - opt_info *opc = alloc_opt_info(sc); - opc->v[1].p = s_slot; - opc->v[4].obj = (void *)c_object_value(obj); - opc->v[3].d_7pi_f = func; - slot = opt_integer_symbol(sc, cadr(car_x)); - if (slot) - { - opc->v[0].fd = opt_d_7pi_ss; - opc->v[2].p = slot; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[0].fd = opt_d_7pi_sf; - return_true(sc, car_x); - }}}} + { + s7_d_7pi_t func = s7_d_7pi_function(getf); + if (func) + { + opt_info *opc = alloc_opt_info(sc); + opc->v[1].p = s_slot; + opc->v[4].obj = (void *)c_object_value(obj); + opc->v[3].d_7pi_f = func; + slot = opt_integer_symbol(sc, cadr(car_x)); + if (slot) + { + opc->v[0].fd = opt_d_7pi_ss; + opc->v[2].p = slot; + return_true(sc, car_x); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) + { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[0].fd = opt_d_7pi_sf; + return_true(sc, car_x); + }}}} return_false(sc, car_x); } @@ -62504,52 +62504,52 @@ static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, const s { s7_b_i_t bif = s7_b_i_function(s_func); if (bif) - { - opc->v[2].b_i_f = bif; - if (is_symbol(cadr(car_x))) - { - opc->v[1].p = s7_slot(sc, cadr(car_x)); - opc->v[0].fb = opt_b_i_s; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opt_info *o1 = sc->opts[sc->pc - 1]; - if ((car(car_x) == sc->is_zero_symbol) && - (o1->v[0].fi == opt_i_ii_sc) && - (o1->v[3].i_ii_f == modulo_i_ii_unchecked)) - { - opc->v[0].fb = opt_zero_mod; - opc->v[1].p = o1->v[1].p; - opc->v[2].i = o1->v[2].i; - backup_pc(sc); - return_true(sc, car_x); - } - opc->v[0].fb = opt_b_i_f; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - return_true(sc, car_x); - }}} + { + opc->v[2].b_i_f = bif; + if (is_symbol(cadr(car_x))) + { + opc->v[1].p = s7_slot(sc, cadr(car_x)); + opc->v[0].fb = opt_b_i_s; + return_true(sc, car_x); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) + { + opt_info *o1 = sc->opts[sc->pc - 1]; + if ((car(car_x) == sc->is_zero_symbol) && + (o1->v[0].fi == opt_i_ii_sc) && + (o1->v[3].i_ii_f == modulo_i_ii_unchecked)) + { + opc->v[0].fb = opt_zero_mod; + opc->v[1].p = o1->v[1].p; + opc->v[2].i = o1->v[2].i; + backup_pc(sc); + return_true(sc, car_x); + } + opc->v[0].fb = opt_b_i_f; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + return_true(sc, car_x); + }}} else if (arg_type == sc->is_float_symbol) { - s7_b_d_t bdf = s7_b_d_function(s_func); - if (bdf) - { - opc->v[2].b_d_f = bdf; - if (is_symbol(cadr(car_x))) - { - opc->v[1].p = s7_slot(sc, cadr(car_x)); - opc->v[0].fb = (bdf == is_positive_d) ? opt_b_d_s_is_positive : opt_b_d_s; - return_true(sc, car_x); - } - opc->v[10].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(car_x))) - { - opc->v[0].fb = opt_b_d_f; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - return_true(sc, car_x); - }}} + s7_b_d_t bdf = s7_b_d_function(s_func); + if (bdf) + { + opc->v[2].b_d_f = bdf; + if (is_symbol(cadr(car_x))) + { + opc->v[1].p = s7_slot(sc, cadr(car_x)); + opc->v[0].fb = (bdf == is_positive_d) ? opt_b_d_s_is_positive : opt_b_d_s; + return_true(sc, car_x); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(car_x))) + { + opc->v[0].fb = opt_b_d_f; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + return_true(sc, car_x); + }}} sc->pc = cur_index; bpf = s7_b_p_function(s_func); @@ -62557,25 +62557,25 @@ static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, const s if ((bpf) || (bpf7)) { if (bpf) - opc->v[2].b_p_f = bpf; + opc->v[2].b_p_f = bpf; else opc->v[2].b_7p_f = bpf7; if (is_symbol(cadr(car_x))) - { - s7_pointer p = opt_simple_symbol(sc, cadr(car_x)); - if (!p) return_false(sc, car_x); - opc->v[1].p = p; - opc->v[0].fb = (bpf) ? ((bpf == s7_is_integer) ? opt_b_p_s_is_integer : ((bpf == s7_is_pair) ? opt_b_p_s_is_pair : opt_b_p_s)) : - (((bpf7 == iterator_is_at_end_b_7p) && (is_iterator(slot_value(p)))) ? opt_b_7p_s_iter_at_end : - ((bpf7 == not_b_7p) ? opt_b_7p_s_not : opt_b_7p_s)); - return_true(sc, car_x); - } + { + s7_pointer p = opt_simple_symbol(sc, cadr(car_x)); + if (!p) return_false(sc, car_x); + opc->v[1].p = p; + opc->v[0].fb = (bpf) ? ((bpf == s7_is_integer) ? opt_b_p_s_is_integer : ((bpf == s7_is_pair) ? opt_b_p_s_is_pair : opt_b_p_s)) : + (((bpf7 == iterator_is_at_end_b_7p) && (is_iterator(slot_value(p)))) ? opt_b_7p_s_iter_at_end : + ((bpf7 == not_b_7p) ? opt_b_7p_s_not : opt_b_7p_s)); + return_true(sc, car_x); + } opc->v[3].o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fb = (bpf) ? ((bpf == s7_is_string) ? opt_b_p_f_is_string : opt_b_p_f) : (bpf7 == not_b_7p) ? opt_b_7p_f_not : opt_b_7p_f; - opc->v[4].fp = opc->v[3].o1->v[0].fp; - return_true(sc, car_x); - }} + { + opc->v[0].fb = (bpf) ? ((bpf == s7_is_string) ? opt_b_p_f_is_string : opt_b_p_f) : (bpf7 == not_b_7p) ? opt_b_7p_f_not : opt_b_7p_f; + opc->v[4].fp = opc->v[3].o1->v[0].fp; + return_true(sc, car_x); + }} return_false(sc, car_x); } @@ -62587,86 +62587,86 @@ static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) if (is_pair(arg)) { if (is_symbol(car(arg))) - { - if ((is_global(car(arg))) || - ((is_slot(global_slot(car(arg)))) && - (s7_slot(sc, car(arg)) == global_slot(car(arg))))) - { - s7_pointer a_func = global_value(car(arg)); - if (is_c_function(a_func)) - { - s7_pointer sig = c_function_signature(a_func); - if (is_pair(sig)) - { - if ((car(sig) == sc->is_integer_symbol) || - ((is_pair(car(sig))) && (direct_memq(sc->is_integer_symbol, car(sig))))) /* multidim vector for example with too few indices */ - return(sc->is_integer_symbol); - if ((car(sig) == sc->is_float_symbol) || - ((is_pair(car(sig))) && (direct_memq(sc->is_float_symbol, car(sig))))) - return(sc->is_float_symbol); - if ((car(sig) == sc->is_byte_symbol) || - ((is_pair(car(sig))) && (direct_memq(sc->is_byte_symbol, car(sig))))) - return(sc->is_integer_symbol); /* or '(integer? byte)? */ - if ((car(sig) == sc->is_real_symbol) || - (car(sig) == sc->is_number_symbol)) - { - int32_t start = sc->pc; - if (int_optimize(sc, argp)) - { - sc->pc = start; - return(sc->is_integer_symbol); - } - if (float_optimize(sc, argp)) - { - sc->pc = start; - return(sc->is_float_symbol); - } - sc->pc = start; - } - - if (((car(arg) == sc->vector_ref_symbol) || (car(arg) == sc->hash_table_ref_symbol)) && - (is_pair(cdr(arg))) && (is_normal_symbol(cadr(arg)))) /* (vector-ref) -> is_pair check */ - { - s7_pointer v_slot = s7_slot(sc, cadr(arg)); /* (vector-ref not-a-var ...) -> is_slot check, not #<undefined> */ - if (is_slot(v_slot)) - { - s7_pointer v = slot_value(v_slot); - if (car(arg) == sc->vector_ref_symbol) - { - if (is_int_vector(v)) return(sc->is_integer_symbol); - if (is_float_vector(v)) return(sc->is_float_symbol); - if (is_byte_vector(v)) return(sc->is_byte_symbol); - if (is_typed_t_vector(v)) return(typed_vector_typer_symbol(sc, v)); /* includes closure name ?? */ - } - else - if ((is_hash_table(v)) && (is_typed_hash_table(v)) && (is_c_function(hash_table_value_typer(v)))) - return(c_function_symbol(hash_table_value_typer(v))); - }} - return(car(sig)); /* we want the function's return type in this context */ - } - return(sc->T); - } - if ((is_quote(car(arg))) && (is_pair(cdr(arg)))) - return(s7_type_of(sc, cadr(arg))); - } - slot = s7_slot(sc, car(arg)); - if ((is_slot(slot)) && - (is_sequence(slot_value(slot)))) - { - s7_pointer sig = s7_signature(sc, slot_value(slot)); - if (is_pair(sig)) - return(car(sig)); - }} + { + if ((is_global(car(arg))) || + ((is_slot(global_slot(car(arg)))) && + (s7_slot(sc, car(arg)) == global_slot(car(arg))))) + { + s7_pointer a_func = global_value(car(arg)); + if (is_c_function(a_func)) + { + s7_pointer sig = c_function_signature(a_func); + if (is_pair(sig)) + { + if ((car(sig) == sc->is_integer_symbol) || + ((is_pair(car(sig))) && (direct_memq(sc->is_integer_symbol, car(sig))))) /* multidim vector for example with too few indices */ + return(sc->is_integer_symbol); + if ((car(sig) == sc->is_float_symbol) || + ((is_pair(car(sig))) && (direct_memq(sc->is_float_symbol, car(sig))))) + return(sc->is_float_symbol); + if ((car(sig) == sc->is_byte_symbol) || + ((is_pair(car(sig))) && (direct_memq(sc->is_byte_symbol, car(sig))))) + return(sc->is_integer_symbol); /* or '(integer? byte)? */ + if ((car(sig) == sc->is_real_symbol) || + (car(sig) == sc->is_number_symbol)) + { + int32_t start = sc->pc; + if (int_optimize(sc, argp)) + { + sc->pc = start; + return(sc->is_integer_symbol); + } + if (float_optimize(sc, argp)) + { + sc->pc = start; + return(sc->is_float_symbol); + } + sc->pc = start; + } + + if (((car(arg) == sc->vector_ref_symbol) || (car(arg) == sc->hash_table_ref_symbol)) && + (is_pair(cdr(arg))) && (is_normal_symbol(cadr(arg)))) /* (vector-ref) -> is_pair check */ + { + s7_pointer v_slot = s7_slot(sc, cadr(arg)); /* (vector-ref not-a-var ...) -> is_slot check, not #<undefined> */ + if (is_slot(v_slot)) + { + s7_pointer v = slot_value(v_slot); + if (car(arg) == sc->vector_ref_symbol) + { + if (is_int_vector(v)) return(sc->is_integer_symbol); + if (is_float_vector(v)) return(sc->is_float_symbol); + if (is_byte_vector(v)) return(sc->is_byte_symbol); + if (is_typed_t_vector(v)) return(typed_vector_typer_symbol(sc, v)); /* includes closure name ?? */ + } + else + if ((is_hash_table(v)) && (is_typed_hash_table(v)) && (is_c_function(hash_table_value_typer(v)))) + return(c_function_symbol(hash_table_value_typer(v))); + }} + return(car(sig)); /* we want the function's return type in this context */ + } + return(sc->T); + } + if ((is_quote(car(arg))) && (is_pair(cdr(arg)))) + return(s7_type_of(sc, cadr(arg))); + } + slot = s7_slot(sc, car(arg)); + if ((is_slot(slot)) && + (is_sequence(slot_value(slot)))) + { + s7_pointer sig = s7_signature(sc, slot_value(slot)); + if (is_pair(sig)) + return(car(sig)); + }} else - if ((car(arg) == sc->quote_function) && (is_pair(cdr(arg)))) - return(s7_type_of(sc, cadr(arg))); - else - if (is_c_function(car(arg))) - { - s7_pointer sig = c_function_signature(car(arg)); - if (is_pair(sig)) - return(car(sig)); - } + if ((car(arg) == sc->quote_function) && (is_pair(cdr(arg)))) + return(s7_type_of(sc, cadr(arg))); + else + if (is_c_function(car(arg))) + { + s7_pointer sig = c_function_signature(car(arg)); + if (is_pair(sig)) + return(car(sig)); + } return(sc->T); } if (is_symbol(arg)) @@ -62675,13 +62675,13 @@ static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) if (!slot) return(sc->T); #if WITH_GMP if (is_big_number(slot_value(slot))) - return(sc->T); + return(sc->T); if ((is_t_integer(slot_value(slot))) && - (integer(slot_value(slot)) > QUOTIENT_INT_LIMIT)) - return(sc->T); + (integer(slot_value(slot)) > QUOTIENT_INT_LIMIT)) + return(sc->T); if ((is_t_real(slot_value(slot))) && - (real(slot_value(slot)) > QUOTIENT_FLOAT_LIMIT)) - return(sc->T); + (real(slot_value(slot)) > QUOTIENT_FLOAT_LIMIT)) + return(sc->T); #endif return(s7_type_of(sc, slot_value(slot))); } @@ -62745,20 +62745,20 @@ static bool b_pp_sf_combinable(s7_scheme *sc, opt_info *opc, bool bpf_case) { opt_info *o1 = sc->opts[sc->pc - 1]; if (o1->v[0].fp == opt_p_p_s) - { - opc->v[2].p = o1->v[1].p; - opc->v[4].p_p_f = o1->v[2].p_p_f; - if (bpf_case) - opc->v[0].fb = opt_b_pp_sfo; - else - if (opc->v[4].p_p_f == car_p_p) - opc->v[0].fb = ((opc->v[3].b_7pp_f == s7_is_equal) ? opt_car_equal_sf : - ((opc->v[3].b_7pp_f == s7_is_equivalent) ? opt_car_equivalent_sf : opt_b_7pp_car_sf)); - else opc->v[0].fb = ((opc->v[3].b_7pp_f == s7_is_equal) ? opt_is_equal_sfo : - ((opc->v[3].b_7pp_f == s7_is_equivalent) ? opt_is_equivalent_sfo : opt_b_7pp_sfo)); - backup_pc(sc); - return_true(sc, NULL); - }} + { + opc->v[2].p = o1->v[1].p; + opc->v[4].p_p_f = o1->v[2].p_p_f; + if (bpf_case) + opc->v[0].fb = opt_b_pp_sfo; + else + if (opc->v[4].p_p_f == car_p_p) + opc->v[0].fb = ((opc->v[3].b_7pp_f == s7_is_equal) ? opt_car_equal_sf : + ((opc->v[3].b_7pp_f == s7_is_equivalent) ? opt_car_equivalent_sf : opt_b_7pp_car_sf)); + else opc->v[0].fb = ((opc->v[3].b_7pp_f == s7_is_equal) ? opt_is_equal_sfo : + ((opc->v[3].b_7pp_f == s7_is_equivalent) ? opt_is_equivalent_sfo : opt_b_7pp_sfo)); + backup_pc(sc); + return_true(sc, NULL); + }} return_false(sc, NULL); } @@ -62797,16 +62797,16 @@ static bool b_pp_ff_combinable(s7_scheme *sc, opt_info *opc, bool bpf_case) { opt_info *o1 = sc->opts[sc->pc - 2], *o2 = sc->opts[sc->pc - 1]; if ((o1->v[0].fp == opt_p_p_s) && (o2->v[0].fp == opt_p_p_s)) - { - opc->v[1].p = o1->v[1].p; - opc->v[4].p_p_f = o1->v[2].p_p_f; - opc->v[2].p = o2->v[1].p; - opc->v[5].p_p_f = o2->v[2].p_p_f; - opc->v[0].fb = (bpf_case) ? ((opc->v[3].b_pp_f == s7_is_eq) ? opt_b_pp_ffo_is_eq : opt_b_pp_ffo) : - (((opc->v[4].p_p_f == cadr_p_p) && (opc->v[5].p_p_f == cadr_p_p)) ? opt_b_cadr_cadr : opt_b_7pp_ffo); - sc->pc -= 2; - return_true(sc, NULL); - }} + { + opc->v[1].p = o1->v[1].p; + opc->v[4].p_p_f = o1->v[2].p_p_f; + opc->v[2].p = o2->v[1].p; + opc->v[5].p_p_f = o2->v[2].p_p_f; + opc->v[0].fb = (bpf_case) ? ((opc->v[3].b_pp_f == s7_is_eq) ? opt_b_pp_ffo_is_eq : opt_b_pp_ffo) : + (((opc->v[4].p_p_f == cadr_p_p) && (opc->v[5].p_p_f == cadr_p_p)) ? opt_b_cadr_cadr : opt_b_7pp_ffo); + sc->pc -= 2; + return_true(sc, NULL); + }} return_false(sc, NULL); } @@ -62818,11 +62818,11 @@ static void check_b_types(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_po s7_pointer arg1_type = opt_arg_type(sc, cdr(car_x)); s7_pointer arg2_type = opt_arg_type(sc, cddr(car_x)); if ((cadr(call_sig) == arg1_type) && /* not car(arg1_type) here: (string>? (string) (read-line)) */ - (caddr(call_sig) == arg2_type)) - { - opc->v[0].fb = fb; - opc->v[3].b_pp_f = s7_b_pp_unchecked_function(s_func); - }} + (caddr(call_sig) == arg2_type)) + { + opc->v[0].fb = fb; + opc->v[3].b_pp_f = s7_b_pp_unchecked_function(s_func); + }} } static s7_pointer opt_p_c(opt_info *o); @@ -62838,92 +62838,92 @@ static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opc->v[1].p = opt_simple_symbol(sc, arg1); opc->v[2].p = opt_simple_symbol(sc, arg2); if ((opc->v[1].p) && - (opc->v[2].p)) - { - s7_b_7pp_t b7f = (bpf_case) ? NULL : opc->v[3].b_7pp_f; - opc->v[0].fb = (bpf_case) ? opt_b_pp_ss : - ((b7f == lt_b_7pp) ? opt_b_7pp_ss_lt : ((b7f == gt_b_7pp) ? opt_b_7pp_ss_gt : + (opc->v[2].p)) + { + s7_b_7pp_t b7f = (bpf_case) ? NULL : opc->v[3].b_7pp_f; + opc->v[0].fb = (bpf_case) ? opt_b_pp_ss : + ((b7f == lt_b_7pp) ? opt_b_7pp_ss_lt : ((b7f == gt_b_7pp) ? opt_b_7pp_ss_gt : ((b7f == char_lt_b_7pp) ? opt_b_7pp_ss_char_lt : opt_b_7pp_ss))); - return_true(sc, car_x); - }} + return_true(sc, car_x); + }} if (is_symbol(arg1)) { opc->v[1].p = opt_simple_symbol(sc, arg1); if (!opc->v[1].p) - return_false(sc, car_x); + return_false(sc, car_x); if ((!is_symbol(arg2)) && - (!is_pair(arg2))) - { - opc->v[2].p = arg2; - opc->v[0].fb = (bpf_case) ? opt_b_pp_sc : opt_b_7pp_sc; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_sc); - return_true(sc, car_x); - } + (!is_pair(arg2))) + { + opc->v[2].p = arg2; + opc->v[0].fb = (bpf_case) ? opt_b_pp_sc : opt_b_7pp_sc; + check_b_types(sc, opc, s_func, car_x, opt_b_pp_sc); + return_true(sc, car_x); + } if (cell_optimize(sc, cddr(car_x))) - { - if (!b_pp_sf_combinable(sc, opc, bpf_case)) - { - opc->v[10].o1 = sc->opts[cur_index]; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[0].fb = (bpf_case) ? opt_b_pp_sf : opt_b_7pp_sf; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_sf); /* this finds b_pp_unchecked cases */ - if ((opc->v[11].fp == opt_p_substring_uncopied_ssf) && (opc->v[3].b_pp_f == string_eq_b_unchecked)) - opc->v[0].fb = opt_substring_equal_sf; - else if (opc->v[3].b_pp_f == char_eq_b_unchecked) opc->v[0].fb = opt_b_pp_sf_char_eq; - } - return_true(sc, car_x); - } + { + if (!b_pp_sf_combinable(sc, opc, bpf_case)) + { + opc->v[10].o1 = sc->opts[cur_index]; + opc->v[11].fp = opc->v[10].o1->v[0].fp; + opc->v[0].fb = (bpf_case) ? opt_b_pp_sf : opt_b_7pp_sf; + check_b_types(sc, opc, s_func, car_x, opt_b_pp_sf); /* this finds b_pp_unchecked cases */ + if ((opc->v[11].fp == opt_p_substring_uncopied_ssf) && (opc->v[3].b_pp_f == string_eq_b_unchecked)) + opc->v[0].fb = opt_substring_equal_sf; + else if (opc->v[3].b_pp_f == char_eq_b_unchecked) opc->v[0].fb = opt_b_pp_sf_char_eq; + } + return_true(sc, car_x); + } sc->pc = cur_index; } else if ((is_symbol(arg2)) && - (is_pair(arg1))) + (is_pair(arg1))) { - opc->v[10].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[1].p = s7_slot(sc, arg2); - if ((!is_slot(opc->v[1].p)) || - (has_methods(slot_value(opc->v[1].p)))) - return_false(sc, car_x); - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[0].fb = (bpf_case) ? opt_b_pp_fs : opt_b_7pp_fs; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_fs); - return_true(sc, car_x); - } - sc->pc = cur_index; + opc->v[10].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(car_x))) + { + opc->v[1].p = s7_slot(sc, arg2); + if ((!is_slot(opc->v[1].p)) || + (has_methods(slot_value(opc->v[1].p)))) + return_false(sc, car_x); + opc->v[11].fp = opc->v[10].o1->v[0].fp; + opc->v[0].fb = (bpf_case) ? opt_b_pp_fs : opt_b_7pp_fs; + check_b_types(sc, opc, s_func, car_x, opt_b_pp_fs); + return_true(sc, car_x); + } + sc->pc = cur_index; } o1 = sc->opts[sc->pc]; /* used below opc->v[8].o1 etc */ if (cell_optimize(sc, cdr(car_x))) { opc->v[10].o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cddr(car_x))) - { - if (b_pp_ff_combinable(sc, opc, bpf_case)) - return_true(sc, car_x); - opc->v[0].fb = (bpf_case) ? opt_b_pp_ff : opt_b_7pp_ff; - opc->v[8].o1 = o1; - opc->v[9].fp = o1->v[0].fp; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - check_b_types(sc, opc, s_func, car_x, opt_b_pp_ff); - - if (opc->v[3].b_pp_f == char_eq_b_unchecked) - { - if (opc->v[11].fp == opt_p_c) /* opc->v[11].fp can be opt_p_c where opc->v[10].o1->v[1].p is the char */ - { - opc->v[0].fb = opt_b_pp_fc_char_eq; - opc->v[11].p = opc->v[10].o1->v[1].p; - } - else opc->v[0].fb = opt_b_pp_ff_char_eq; - } - else - if (opc->v[11].fp == opt_p_c) - { - opc->v[0].fb = (opc->v[0].fb == opt_b_pp_ff) ? opt_b_pp_fc : opt_b_7pp_fc; /* can't use bpf_case here -- check_b_types can use the other form */ - opc->v[11].p = opc->v[10].o1->v[1].p; - } - return_true(sc, car_x); - }} + { + if (b_pp_ff_combinable(sc, opc, bpf_case)) + return_true(sc, car_x); + opc->v[0].fb = (bpf_case) ? opt_b_pp_ff : opt_b_7pp_ff; + opc->v[8].o1 = o1; + opc->v[9].fp = o1->v[0].fp; + opc->v[11].fp = opc->v[10].o1->v[0].fp; + check_b_types(sc, opc, s_func, car_x, opt_b_pp_ff); + + if (opc->v[3].b_pp_f == char_eq_b_unchecked) + { + if (opc->v[11].fp == opt_p_c) /* opc->v[11].fp can be opt_p_c where opc->v[10].o1->v[1].p is the char */ + { + opc->v[0].fb = opt_b_pp_fc_char_eq; + opc->v[11].p = opc->v[10].o1->v[1].p; + } + else opc->v[0].fb = opt_b_pp_ff_char_eq; + } + else + if (opc->v[11].fp == opt_p_c) + { + opc->v[0].fb = (opc->v[0].fb == opt_b_pp_ff) ? opt_b_pp_fc : opt_b_7pp_fc; /* can't use bpf_case here -- check_b_types can use the other form */ + opc->v[11].p = opc->v[10].o1->v[1].p; + } + return_true(sc, car_x); + }} return_false(sc, car_x); } @@ -62940,29 +62940,29 @@ static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { opc->v[10].o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cdr(car_x))) - { - opt_info *o1 = sc->opts[sc->pc]; - opc->v[2].b_pi_f = bpif; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - if (is_symbol(arg2)) - { - opc->v[1].p = s7_slot(sc, arg2); /* slot checked in opt_arg_type */ - opc->v[0].fb = (bpif == num_eq_b_pi) ? opt_b_pi_fs_num_eq : opt_b_pi_fs; - return_true(sc, car_x); - } - if (is_t_integer(arg2)) - { - opc->v[1].i = integer(arg2); - opc->v[0].fb = opt_b_pi_fi; - return_true(sc, car_x); - } - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fb = opt_b_pi_ff; - opc->v[8].o1 = o1; - opc->v[9].fp = o1->v[0].fp; - return_true(sc, car_x); - }}} + { + opt_info *o1 = sc->opts[sc->pc]; + opc->v[2].b_pi_f = bpif; + opc->v[11].fp = opc->v[10].o1->v[0].fp; + if (is_symbol(arg2)) + { + opc->v[1].p = s7_slot(sc, arg2); /* slot checked in opt_arg_type */ + opc->v[0].fb = (bpif == num_eq_b_pi) ? opt_b_pi_fs_num_eq : opt_b_pi_fs; + return_true(sc, car_x); + } + if (is_t_integer(arg2)) + { + opc->v[1].i = integer(arg2); + opc->v[0].fb = opt_b_pi_fi; + return_true(sc, car_x); + } + if (int_optimize(sc, cddr(car_x))) + { + opc->v[0].fb = opt_b_pi_ff; + opc->v[8].o1 = o1; + opc->v[9].fp = o1->v[0].fp; + return_true(sc, car_x); + }}} return_false(sc, car_x); } @@ -63001,48 +63001,48 @@ static bool b_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { opc->v[1].p = s7_slot(sc, arg1); if (is_symbol(arg2)) - { - opc->v[2].p = s7_slot(sc, arg2); - opc->v[0].fb = (bif == lt_b_dd) ? opt_b_dd_ss_lt : ((bif == gt_b_dd) ? opt_b_dd_ss_gt : opt_b_dd_ss); - return_true(sc, car_x); - } + { + opc->v[2].p = s7_slot(sc, arg2); + opc->v[0].fb = (bif == lt_b_dd) ? opt_b_dd_ss_lt : ((bif == gt_b_dd) ? opt_b_dd_ss_gt : opt_b_dd_ss); + return_true(sc, car_x); + } if (is_t_real(arg2)) - { - opc->v[2].x = s7_number_to_real(sc, arg2); - opc->v[0].fb = (bif == lt_b_dd) ? opt_b_dd_sc_lt : ((bif == geq_b_dd) ? opt_b_dd_sc_geq : ((bif == num_eq_b_dd) ? opt_b_dd_sc_eq : opt_b_dd_sc)); - return_true(sc, car_x); - } + { + opc->v[2].x = s7_number_to_real(sc, arg2); + opc->v[0].fb = (bif == lt_b_dd) ? opt_b_dd_sc_lt : ((bif == geq_b_dd) ? opt_b_dd_sc_geq : ((bif == num_eq_b_dd) ? opt_b_dd_sc_eq : opt_b_dd_sc)); + return_true(sc, car_x); + } opc->v[10].o1 = sc->opts[sc->pc]; if (float_optimize(sc, cddr(car_x))) - { - opc->v[11].fd = opc->v[10].o1->v[0].fd; - opc->v[0].fb = opt_b_dd_sf; - return_true(sc, car_x); - }} + { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[0].fb = opt_b_dd_sf; + return_true(sc, car_x); + }} sc->pc = cur_index; opc->v[10].o1 = sc->opts[sc->pc]; if (float_optimize(sc, cdr(car_x))) { opc->v[11].fd = opc->v[10].o1->v[0].fd; if (is_symbol(arg2)) - { - opc->v[1].p = s7_slot(sc, arg2); - opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs; - return_true(sc, car_x); - } + { + opc->v[1].p = s7_slot(sc, arg2); + opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs; + return_true(sc, car_x); + } if (is_small_real(arg2)) - { - opc->v[1].x = s7_number_to_real(sc, arg2); - opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fc_gt : opt_b_dd_fc; - return_true(sc, car_x); - } + { + opc->v[1].x = s7_number_to_real(sc, arg2); + opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fc_gt : opt_b_dd_fc; + return_true(sc, car_x); + } opc->v[8].o1 = sc->opts[sc->pc]; if (float_optimize(sc, cddr(car_x))) - { - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[0].fb = opt_b_dd_ff; - return_true(sc, car_x); - }} + { + opc->v[9].fd = opc->v[8].o1->v[0].fd; + opc->v[0].fb = opt_b_dd_ff; + return_true(sc, car_x); + }} sc->pc = cur_index; return_false(sc, car_x); } @@ -63095,44 +63095,44 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { b7if = s7_b_7ii_function(s_func); if (!b7if) - return_false(sc, car_x); + return_false(sc, car_x); } if (bif) opc->v[3].b_ii_f = bif; else opc->v[3].b_7ii_f = b7if; if (is_symbol(arg1)) { opc->v[1].p = s7_slot(sc, arg1); if (is_symbol(arg2)) - { - opc->v[2].p = s7_slot(sc, arg2); - - 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 : - ((bif) ? opt_b_ii_ss : opt_b_7ii_ss))))); - return_true(sc, car_x); - } + { + opc->v[2].p = s7_slot(sc, arg2); + + 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 : + ((bif) ? opt_b_ii_ss : opt_b_7ii_ss))))); + return_true(sc, car_x); + } if (is_t_integer(arg2)) - { - s7_int i2 = integer(arg2); - opc->v[2].i = i2; - opc->v[0].fb = (bif == num_eq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_eq_0 : ((i2 == 1) ? opt_b_ii_sc_eq_1 : opt_b_ii_sc_eq)) : - ((bif == lt_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_lt_0 : ((i2 == 1) ? opt_b_ii_sc_lt_1 : ((i2 == 2) ? opt_b_ii_sc_lt_2 : opt_b_ii_sc_lt))) : - ((bif == gt_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_gt_0 : opt_b_ii_sc_gt) : - ((bif == leq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_leq_0 : opt_b_ii_sc_leq) : - ((bif == geq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_geq_0 : opt_b_ii_sc_geq) : - (((b7if == logbit_b_7ii) && (i2 >= 0) && (i2 < S7_INT_BITS)) ? opt_b_7ii_sc_bit : - ((bif) ? opt_b_ii_sc : opt_b_7ii_sc)))))); - return_true(sc, car_x); - } + { + s7_int i2 = integer(arg2); + opc->v[2].i = i2; + opc->v[0].fb = (bif == num_eq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_eq_0 : ((i2 == 1) ? opt_b_ii_sc_eq_1 : opt_b_ii_sc_eq)) : + ((bif == lt_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_lt_0 : ((i2 == 1) ? opt_b_ii_sc_lt_1 : ((i2 == 2) ? opt_b_ii_sc_lt_2 : opt_b_ii_sc_lt))) : + ((bif == gt_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_gt_0 : opt_b_ii_sc_gt) : + ((bif == leq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_leq_0 : opt_b_ii_sc_leq) : + ((bif == geq_b_ii) ? ((i2 == 0) ? opt_b_ii_sc_geq_0 : opt_b_ii_sc_geq) : + (((b7if == logbit_b_7ii) && (i2 >= 0) && (i2 < S7_INT_BITS)) ? opt_b_7ii_sc_bit : + ((bif) ? opt_b_ii_sc : opt_b_7ii_sc)))))); + return_true(sc, car_x); + } opc->v[10].o1 = sc->opts[sc->pc]; if ((bif) && (int_optimize(sc, cddr(car_x)))) - { - 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_true(sc, car_x); - } + { + 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_true(sc, car_x); + } return_false(sc, car_x); } if (!bif) return_false(sc, car_x); @@ -63141,7 +63141,7 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { opc->v[10].o1 = sc->opts[sc->pc]; if (!int_optimize(sc, cdr(car_x))) - return_false(sc, car_x); + return_false(sc, car_x); opc->v[11].fi = opc->v[10].o1->v[0].fi; opc->v[2].p = s7_slot(sc, arg2); opc->v[0].fb = opt_b_ii_fs; @@ -63152,18 +63152,18 @@ static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { opc->v[11].fi = opc->v[10].o1->v[0].fi; if (is_t_integer(arg2)) - { - opc->v[2].i = integer(arg2); - opc->v[0].fb = (bif == num_eq_b_ii) ? opt_b_ii_fc_eq : opt_b_ii_fc; - return_true(sc, car_x); - } + { + opc->v[2].i = integer(arg2); + opc->v[0].fb = (bif == num_eq_b_ii) ? opt_b_ii_fc_eq : opt_b_ii_fc; + return_true(sc, car_x); + } opc->v[8].o1 = sc->opts[sc->pc]; if (int_optimize(sc, cddr(car_x))) - { - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[0].fb = opt_b_ii_ff; - return_true(sc, car_x); - }} + { + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[0].fb = opt_b_ii_ff; + return_true(sc, car_x); + }} return_false(sc, car_x); } @@ -63176,7 +63176,7 @@ static bool opt_and_any_b(opt_info *o) { opt_info *o1 = o->v[i + 3].o1; if (!o1->v[0].fb(o1)) - return(false); + return(false); } return(true); } @@ -63189,7 +63189,7 @@ static bool opt_or_any_b(opt_info *o) { opt_info *o1 = o->v[i + 3].o1; if (o1->v[0].fb(o1)) - return(true); + return(true); } return(false); } @@ -63202,17 +63202,17 @@ static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t i { opt_info *o1 = sc->opts[sc->pc]; if (bool_optimize_nw(sc, cdr(car_x))) - { - opt_info *o2 = sc->opts[sc->pc]; - if (bool_optimize_nw(sc, cddr(car_x))) - { - opc->v[10].o1 = o2; - opc->v[11].fb = o2->v[0].fb; - opc->v[0].fb = (is_and) ? opt_and_bb : opt_or_bb; - opc->v[2].o1 = o1; - opc->v[3].fb = o1->v[0].fb; - return_true(sc, car_x); - }} + { + opt_info *o2 = sc->opts[sc->pc]; + if (bool_optimize_nw(sc, cddr(car_x))) + { + opc->v[10].o1 = o2; + opc->v[11].fb = o2->v[0].fb; + opc->v[0].fb = (is_and) ? opt_and_bb : opt_or_bb; + opc->v[2].o1 = o1; + opc->v[3].fb = o1->v[0].fb; + return_true(sc, car_x); + }} return_false(sc, car_x); } opc->v[1].i = (len - 1); @@ -63220,7 +63220,7 @@ static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t i { opc->v[i + 3].o1 = sc->opts[sc->pc]; if (!bool_optimize_nw(sc, p)) - break; + break; } if (!is_null(p)) return_false(sc, car_x); @@ -63321,13 +63321,13 @@ static bool p_p_f_combinable(s7_scheme *sc, opt_info *opc) { opt_info *o1 = sc->opts[sc->pc - 1]; if (o1->v[0].fp == opt_p_p_s) - { - opc->v[3].p_p_f = o1->v[2].p_p_f; - opc->v[1].p = o1->v[1].p; - opc->v[0].fp = opt_p_p_f1; - backup_pc(sc); - return_true(sc, NULL); - }} + { + opc->v[3].p_p_f = o1->v[2].p_p_f; + opc->v[1].p = o1->v[1].p; + opc->v[0].fp = opt_p_p_f1; + backup_pc(sc); + return_true(sc, NULL); + }} return_false(sc, NULL); } @@ -63346,127 +63346,127 @@ static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer c s7_i_7i_t i7if; opc->v[1].i = integer(arg1); if (iif) - { - opc->v[2].i_i_f = iif; - opc->v[0].fp = opt_p_i_c; - return_true(sc, car_x); - } + { + opc->v[2].i_i_f = iif; + opc->v[0].fp = opt_p_i_c; + return_true(sc, car_x); + } i7if = s7_i_7i_function(s_func); if (i7if) - { - opc->v[2].i_7i_f = i7if; - opc->v[0].fp = opt_p_7i_c; - return_true(sc, car_x); - }} + { + opc->v[2].i_7i_f = i7if; + opc->v[0].fp = opt_p_7i_c; + return_true(sc, car_x); + }} if (is_t_real(arg1)) { s7_d_d_t ddf = s7_d_d_function(s_func); s7_d_7d_t d7df; opc->v[1].x = real(arg1); if (ddf) - { - opc->v[2].d_d_f = ddf; - opc->v[0].fp = opt_p_d_c; - return_true(sc, car_x); - } + { + opc->v[2].d_d_f = ddf; + opc->v[0].fp = opt_p_d_c; + return_true(sc, car_x); + } d7df = s7_d_7d_function(s_func); if (d7df) - { - opc->v[2].d_7d_f = d7df; - opc->v[0].fp = (d7df == random_d_7d) ? opt_p_7d_c_random : opt_p_7d_c; - return_true(sc, car_x); - }} + { + opc->v[2].d_7d_f = d7df; + opc->v[0].fp = (d7df == random_d_7d) ? opt_p_7d_c_random : opt_p_7d_c; + return_true(sc, car_x); + }} ppf = s7_p_p_function(s_func); if (ppf) { opt_info *o1; opc->v[2].p_p_f = ppf; if ((ppf == symbol_to_string_p_p) && - (is_optimized(car_x)) && - (fn_proc(car_x) == g_symbol_to_string_uncopied)) - opc->v[2].p_p_f = symbol_to_string_uncopied_p; + (is_optimized(car_x)) && + (fn_proc(car_x) == g_symbol_to_string_uncopied)) + opc->v[2].p_p_f = symbol_to_string_uncopied_p; if (is_symbol(arg1)) - { - opc->v[1].p = opt_simple_symbol(sc, arg1); - if (!opc->v[1].p) - return_false(sc, car_x); - opc->v[0].fp = (ppf == abs_p_p) ? opt_p_p_s_abs : ((ppf == cdr_p_p) ? opt_p_p_s_cdr : - ((ppf == iterate_p_p) ? ((is_iterator(slot_value(opc->v[1].p))) ? opt_p_p_s_iterate_unchecked : opt_p_p_s_iterate) : opt_p_p_s)); - return_true(sc, car_x); - } + { + opc->v[1].p = opt_simple_symbol(sc, arg1); + if (!opc->v[1].p) + return_false(sc, car_x); + opc->v[0].fp = (ppf == abs_p_p) ? opt_p_p_s_abs : ((ppf == cdr_p_p) ? opt_p_p_s_cdr : + ((ppf == iterate_p_p) ? ((is_iterator(slot_value(opc->v[1].p))) ? opt_p_p_s_iterate_unchecked : opt_p_p_s_iterate) : opt_p_p_s)); + return_true(sc, car_x); + } if (!is_pair(arg1)) - { - if (opc->v[2].p_p_f == s7_length) - { - opc->v[1].p = s7_length(sc, arg1); - opc->v[0].fp = opt_p_c; - } - else - { - opc->v[1].p = arg1; - opc->v[0].fp = opt_p_p_c; - } - return_true(sc, car_x); - } + { + if (opc->v[2].p_p_f == s7_length) + { + opc->v[1].p = s7_length(sc, arg1); + opc->v[0].fp = opt_p_c; + } + else + { + opc->v[1].p = arg1; + opc->v[0].fp = opt_p_p_c; + } + return_true(sc, car_x); + } o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cdr(car_x))) - { - if (!p_p_f_combinable(sc, opc)) - { - s7_pointer (*fp)(opt_info *o); - opc->v[0].fp = (ppf == exp_p_p) ? opt_p_p_f_exp : ((ppf == iterate_p_p) ? opt_p_p_f_iterate : - ((ppf == string_to_number_p_p) ? opt_p_p_f_string_to_number : opt_p_p_f)); - if (caadr(car_x) == sc->string_ref_symbol) - { - if (opc->v[2].p_p_f == char_upcase_p_p) - opc->v[2].p_p_f = char_upcase_p_p_unchecked; - else - if (opc->v[2].p_p_f == is_char_whitespace_p_p) - opc->v[2].p_p_f = is_char_whitespace_p_p_unchecked; - } - opc->v[3].o1 = o1; - fp = o1->v[0].fp; - opc->v[4].fp = fp; - if (fp == opt_p_pi_ss_fvref_direct) opc->v[0].fp = opt_p_p_fvref; - else if (fp == opt_p_pi_ss_vref_direct) opc->v[0].fp = opt_p_p_vref; - else if (fp == opt_p_pi_ss_ivref_direct) opc->v[0].fp = opt_p_p_ivref; - } - return_true(sc, car_x); - }} + { + if (!p_p_f_combinable(sc, opc)) + { + s7_pointer (*fp)(opt_info *o); + opc->v[0].fp = (ppf == exp_p_p) ? opt_p_p_f_exp : ((ppf == iterate_p_p) ? opt_p_p_f_iterate : + ((ppf == string_to_number_p_p) ? opt_p_p_f_string_to_number : opt_p_p_f)); + if (caadr(car_x) == sc->string_ref_symbol) + { + if (opc->v[2].p_p_f == char_upcase_p_p) + opc->v[2].p_p_f = char_upcase_p_p_unchecked; + else + if (opc->v[2].p_p_f == is_char_whitespace_p_p) + opc->v[2].p_p_f = is_char_whitespace_p_p_unchecked; + } + opc->v[3].o1 = o1; + fp = o1->v[0].fp; + opc->v[4].fp = fp; + if (fp == opt_p_pi_ss_fvref_direct) opc->v[0].fp = opt_p_p_fvref; + else if (fp == opt_p_pi_ss_vref_direct) opc->v[0].fp = opt_p_p_vref; + else if (fp == opt_p_pi_ss_ivref_direct) opc->v[0].fp = opt_p_p_ivref; + } + return_true(sc, car_x); + }} sc->pc = start; if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 1))) { opc->v[2].call = cf_call(sc, car_x, s_func, 1); if (is_symbol(arg1)) - { - s7_pointer slot = opt_simple_symbol(sc, arg1); - if (slot) - { - opc->v[1].p = slot; - opc->v[0].fp = opt_p_call_s; - return_true(sc, car_x); - }} + { + s7_pointer slot = opt_simple_symbol(sc, arg1); + if (slot) + { + opc->v[1].p = slot; + opc->v[0].fp = opt_p_call_s; + return_true(sc, car_x); + }} else - { - opt_info *o1; - if (!is_pair(arg1)) - { - opc->v[1].p = arg1; - opc->v[0].fp = opt_p_call_c; - return_true(sc, car_x); - } - o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(car_x))) - { - opc->v[0].fp = opt_p_call_f; - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - if (opc->v[5].fp == opt_p_pi_ss_fvref_direct) opc->v[5].fp = opt_p_pi_ss_fvref_direct_wrapped; - else if (opc->v[5].fp == opt_p_pi_ss_ivref_direct) opc->v[5].fp = opt_p_pi_ss_ivref_direct_wrapped; - return_true(sc, car_x); - }}} + { + opt_info *o1; + if (!is_pair(arg1)) + { + opc->v[1].p = arg1; + opc->v[0].fp = opt_p_call_c; + return_true(sc, car_x); + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(car_x))) + { + opc->v[0].fp = opt_p_call_f; + opc->v[4].o1 = o1; + opc->v[5].fp = o1->v[0].fp; + if (opc->v[5].fp == opt_p_pi_ss_fvref_direct) opc->v[5].fp = opt_p_pi_ss_fvref_direct_wrapped; + else if (opc->v[5].fp == opt_p_pi_ss_ivref_direct) opc->v[5].fp = opt_p_pi_ss_ivref_direct_wrapped; + return_true(sc, car_x); + }}} return_false(sc, car_x); } @@ -63523,22 +63523,22 @@ static bool p_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { s7_pointer p1 = opt_integer_symbol(sc, cadr(car_x)); if (p1) - { - opc->v[1].p = p1; - opc->v[2].p = p2; - opc->v[3].p_ii_f = ifunc; - opc->v[0].fp = opt_p_ii_ss; - return_true(sc, car_x); - } + { + opc->v[1].p = p1; + opc->v[2].p = p2; + opc->v[3].p_ii_f = ifunc; + opc->v[0].fp = opt_p_ii_ss; + return_true(sc, car_x); + } opc->v[10].o1 = sc->opts[sc->pc]; if (int_optimize(sc, cdr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[2].p = p2; - opc->v[3].p_ii_f = ifunc; - opc->v[0].fp = opt_p_ii_fs; - return_true(sc, car_x); - } + { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[2].p = p2; + opc->v[3].p_ii_f = ifunc; + opc->v[0].fp = opt_p_ii_fs; + return_true(sc, car_x); + } sc->pc = pstart; return_false(sc, car_x); } @@ -63547,13 +63547,13 @@ static bool p_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { opc->v[8].o1 = sc->opts[sc->pc]; if (int_optimize(sc, cddr(car_x))) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[3].p_ii_f = ifunc; - opc->v[0].fp = (ifunc == divide_p_ii) ? opt_p_ii_ff_divide : opt_p_ii_ff; - return_true(sc, car_x); - }} + { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[3].p_ii_f = ifunc; + opc->v[0].fp = (ifunc == divide_p_ii) ? opt_p_ii_ff_divide : opt_p_ii_ff; + return_true(sc, car_x); + }} sc->pc = pstart; return_false(sc, car_x); } @@ -63608,33 +63608,33 @@ static bool p_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (is_t_real(arg2)) { if (is_t_real(arg1)) - { - opc->v[1].x = real(arg1); - opc->v[2].x = real(arg2); - opc->v[3].p_dd_f = ifunc; - opc->v[0].fp = opt_p_dd_cc; - return_true(sc, car_x); - } + { + opc->v[1].x = real(arg1); + opc->v[2].x = real(arg2); + opc->v[3].p_dd_f = ifunc; + opc->v[0].fp = opt_p_dd_cc; + return_true(sc, car_x); + } slot = opt_real_symbol(sc, arg1); if (slot) - { - opc->v[2].x = real(arg2); - opc->v[1].p = slot; - opc->v[3].p_dd_f = ifunc; - opc->v[0].fp = opt_p_dd_sc; - return_true(sc, car_x); - }} + { + opc->v[2].x = real(arg2); + opc->v[1].p = slot; + opc->v[3].p_dd_f = ifunc; + opc->v[0].fp = opt_p_dd_sc; + return_true(sc, car_x); + }} if (is_t_real(arg1)) { slot = opt_real_symbol(sc, arg2); if (slot) - { - opc->v[2].x = real(arg1); - opc->v[1].p = slot; - opc->v[3].p_dd_f = ifunc; - opc->v[0].fp = opt_p_dd_cs; - return_true(sc, car_x); - }} + { + opc->v[2].x = real(arg1); + opc->v[1].p = slot; + opc->v[3].p_dd_f = ifunc; + opc->v[0].fp = opt_p_dd_cs; + return_true(sc, car_x); + }} sc->pc = pstart; return_false(sc, car_x); } @@ -63680,26 +63680,26 @@ static void check_unchecked(s7_scheme *sc, s7_pointer obj, s7_pointer slot, opt_ { case T_STRING: if (((!expr) || (car(expr) == sc->string_ref_symbol)) && (loop_end(slot) <= string_length(obj))) - opc->v[3].p_pi_f = string_ref_p_pi_direct; + opc->v[3].p_pi_f = string_ref_p_pi_direct; break; case T_BYTE_VECTOR: if (((!expr) || (car(expr) == sc->byte_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && - (loop_end(slot) <= byte_vector_length(obj))) - opc->v[3].p_pi_f = byte_vector_ref_p_pi_direct; + (loop_end(slot) <= byte_vector_length(obj))) + opc->v[3].p_pi_f = byte_vector_ref_p_pi_direct; break; case T_VECTOR: if (((!expr) || (car(expr) == sc->vector_ref_symbol)) && (loop_end(slot) <= vector_length(obj))) - opc->v[3].p_pi_f = t_vector_ref_p_pi_direct; + opc->v[3].p_pi_f = t_vector_ref_p_pi_direct; break; case T_FLOAT_VECTOR: if (((!expr) || (car(expr) == sc->float_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && - (loop_end(slot) <= vector_length(obj))) - opc->v[3].p_pi_f = float_vector_ref_p_pi_direct; + (loop_end(slot) <= vector_length(obj))) + opc->v[3].p_pi_f = float_vector_ref_p_pi_direct; break; case T_INT_VECTOR: if (((!expr) || (car(expr) == sc->int_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && - (loop_end(slot) <= vector_length(obj))) - opc->v[3].p_pi_f = int_vector_ref_p_pi_direct; + (loop_end(slot) <= vector_length(obj))) + opc->v[3].p_pi_f = int_vector_ref_p_pi_direct; break; } } @@ -63711,8 +63711,8 @@ static void fixup_p_pi_ss(opt_info *opc) ((opc->v[3].p_pi_f == t_vector_ref_p_pi_unchecked) ? opt_p_pi_ss_vref : ((opc->v[3].p_pi_f == float_vector_ref_p_pi_direct) ? opt_p_pi_ss_fvref_direct : ((opc->v[3].p_pi_f == int_vector_ref_p_pi_direct) ? opt_p_pi_ss_ivref_direct : - ((opc->v[3].p_pi_f == t_vector_ref_p_pi_direct) ? opt_p_pi_ss_vref_direct : - ((opc->v[3].p_pi_f == list_ref_p_pi_unchecked) ? opt_p_pi_ss_pref : opt_p_pi_ss)))))); + ((opc->v[3].p_pi_f == t_vector_ref_p_pi_direct) ? opt_p_pi_ss_vref_direct : + ((opc->v[3].p_pi_f == list_ref_p_pi_unchecked) ? opt_p_pi_ss_pref : opt_p_pi_ss)))))); } static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer sig, s7_pointer car_x) @@ -63741,22 +63741,22 @@ static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { obj = slot_value(opc->v[1].p); if ((is_string(obj)) || - (is_pair(obj)) || - (is_any_vector(obj))) - { - if (((is_string(obj)) && (checker == sc->is_string_symbol)) || - ((is_any_vector(obj)) && (checker == sc->is_vector_symbol)) || - ((is_pair(obj)) && (checker == sc->is_pair_symbol)) || - ((is_byte_vector(obj)) && (checker == sc->is_byte_vector_symbol))) - opc->v[3].p_pi_f = (is_t_vector(obj)) ? t_vector_ref_p_pi_unchecked : s7_p_pi_unchecked_function(s_func); - }} + (is_pair(obj)) || + (is_any_vector(obj))) + { + if (((is_string(obj)) && (checker == sc->is_string_symbol)) || + ((is_any_vector(obj)) && (checker == sc->is_vector_symbol)) || + ((is_pair(obj)) && (checker == sc->is_pair_symbol)) || + ((is_byte_vector(obj)) && (checker == sc->is_byte_vector_symbol))) + opc->v[3].p_pi_f = (is_t_vector(obj)) ? t_vector_ref_p_pi_unchecked : s7_p_pi_unchecked_function(s_func); + }} slot1 = opt_integer_symbol(sc, caddr(car_x)); if (slot1) { opc->v[2].p = slot1; if ((obj) && - (has_loop_end(slot1))) - check_unchecked(sc, obj, slot1, opc, car_x); + (has_loop_end(slot1))) + check_unchecked(sc, obj, slot1, opc, car_x); fixup_p_pi_ss(opc); return_true(sc, car_x); } @@ -63770,7 +63770,7 @@ static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (int_optimize(sc, cddr(car_x))) { opc->v[0].fp = (opc->v[3].p_pi_f == string_ref_p_pi_unchecked) ? opt_p_pi_sf_sref : - ((opc->v[3].p_pi_f == string_ref_p_pi_direct) ? opt_p_pi_sf_sref_direct : opt_p_pi_sf); + ((opc->v[3].p_pi_f == string_ref_p_pi_direct) ? opt_p_pi_sf_sref_direct : opt_p_pi_sf); opc->v[4].o1 = o1; opc->v[5].fi = o1->v[0].fi; return_true(sc, car_x); @@ -63787,13 +63787,13 @@ static bool p_pi_fc_combinable(s7_scheme *sc, opt_info *opc) { opt_info *o1 = sc->opts[sc->pc - 1]; if (o1->v[0].fp == opt_p_p_s) - { - opc->v[4].p_p_f = o1->v[2].p_p_f; - opc->v[1].p = o1->v[1].p; - opc->v[0].fp = opt_p_pi_fco; - backup_pc(sc); - return_true(sc, NULL); - }} + { + opc->v[4].p_p_f = o1->v[2].p_p_f; + opc->v[1].p = o1->v[1].p; + opc->v[0].fp = opt_p_pi_fco; + backup_pc(sc); + return_true(sc, NULL); + }} return_false(sc, NULL); } @@ -63859,7 +63859,7 @@ static s7_pointer opt_p_pp_ff_add_mul_mul_1(opt_info *o, bool add_case) /* (+|- s7_double r2 = real(f2); f4 = o2->v[5].fp(o2->v[4].o1); if (is_t_real(f4)) - return(make_real(sc, (add_case) ? ((real(s1) * r2) + (real(s3) * real(f4))) : ((real(s1) * r2) - (real(s3) * real(f4))))); + return(make_real(sc, (add_case) ? ((real(s1) * r2) + (real(s3) * real(f4))) : ((real(s1) * r2) - (real(s3) * real(f4))))); gc_protect_via_stack_no_let(sc, f2); } else @@ -63911,161 +63911,161 @@ static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_pointer obj; slot = opt_simple_symbol(sc, arg1); if (!slot) - { - sc->pc = pstart; - return_false(sc, car_x); - } + { + sc->pc = pstart; + return_false(sc, car_x); + } obj = slot_value(slot); if ((is_any_vector(obj)) && (vector_rank(obj) > 1)) - { - sc->pc = pstart; - return_false(sc, car_x); - } + { + sc->pc = pstart; + return_false(sc, car_x); + } opc->v[1].p = slot; if ((func == hash_table_ref_p_pp) && (is_hash_table(obj))) - opc->v[3].p_pp_f = s7_hash_table_ref; + opc->v[3].p_pp_f = s7_hash_table_ref; if (is_symbol(arg2)) - { - opc->v[2].p = opt_simple_symbol(sc, arg2); - if (opc->v[2].p) - { - opc->v[0].fp = (func == set_car_p_pp) ? opt_set_car_pp_ss : - (((is_hash_table(obj)) && (func == hash_table_ref_p_pp)) ? opt_p_pp_ss_href : - (((is_let(obj)) && (func == let_ref)) ? opt_p_pp_ss_lref : opt_p_pp_ss)); - - /* if ss = s+k use slot_ref */ - if ((opc->v[0].fp == opt_p_pp_ss_lref) && (is_keyword(arg2))) - use_slot_ref(sc, opc, obj, keyword_symbol(arg2)); - - return_true(sc, car_x); - } - sc->pc = pstart; - return_false(sc, car_x); - } + { + opc->v[2].p = opt_simple_symbol(sc, arg2); + if (opc->v[2].p) + { + opc->v[0].fp = (func == set_car_p_pp) ? opt_set_car_pp_ss : + (((is_hash_table(obj)) && (func == hash_table_ref_p_pp)) ? opt_p_pp_ss_href : + (((is_let(obj)) && (func == let_ref)) ? opt_p_pp_ss_lref : opt_p_pp_ss)); + + /* if ss = s+k use slot_ref */ + if ((opc->v[0].fp == opt_p_pp_ss_lref) && (is_keyword(arg2))) + use_slot_ref(sc, opc, obj, keyword_symbol(arg2)); + + return_true(sc, car_x); + } + sc->pc = pstart; + return_false(sc, car_x); + } if ((!is_pair(arg2)) || - (is_proper_quote(sc, arg2))) - { - opc->v[2].p = (!is_pair(arg2)) ? arg2 : cadr(arg2); - opc->v[0].fp = opt_p_pp_sc; - if ((is_pair(arg2)) && (is_symbol(opc->v[2].p)) && (is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) - use_slot_ref(sc, opc, obj, cadr(arg2)); /* car_x: (let-ref L 'a), can't be keyword here (handled above) */ - return_true(sc, car_x); - } + (is_proper_quote(sc, arg2))) + { + opc->v[2].p = (!is_pair(arg2)) ? arg2 : cadr(arg2); + opc->v[0].fp = opt_p_pp_sc; + if ((is_pair(arg2)) && (is_symbol(opc->v[2].p)) && (is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) + use_slot_ref(sc, opc, obj, cadr(arg2)); /* car_x: (let-ref L 'a), can't be keyword here (handled above) */ + return_true(sc, car_x); + } if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = (func == add_p_pp) ? opt_p_pp_sf_add : ((func == subtract_p_pp) ? opt_p_pp_sf_sub : ((func == multiply_p_pp) ? opt_p_pp_sf_mul : + { + opc->v[0].fp = (func == add_p_pp) ? opt_p_pp_sf_add : ((func == subtract_p_pp) ? opt_p_pp_sf_sub : ((func == multiply_p_pp) ? opt_p_pp_sf_mul : ((func == set_car_p_pp) ? opt_p_pp_sf_set_car : ((func == set_cdr_p_pp) ? opt_p_pp_sf_set_cdr : (((is_hash_table(obj)) && (opc->v[3].p_pp_f == s7_hash_table_ref)) ? opt_p_pp_sf_href : - (((is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) ? opt_p_pp_sf_lref : opt_p_pp_sf)))))); - opc->v[4].o1 = sc->opts[pstart]; - opc->v[5].fp = sc->opts[pstart]->v[0].fp; - if (opc->v[5].fp == opt_p_pi_ss_ivref_direct) opc->v[5].fp = opt_p_pi_ss_ivref_direct_wrapped; - return_true(sc, car_x); - }} + (((is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) ? opt_p_pp_sf_lref : opt_p_pp_sf)))))); + opc->v[4].o1 = sc->opts[pstart]; + opc->v[5].fp = sc->opts[pstart]->v[0].fp; + if (opc->v[5].fp == opt_p_pi_ss_ivref_direct) opc->v[5].fp = opt_p_pi_ss_ivref_direct_wrapped; + return_true(sc, car_x); + }} else /* cadr not a symbol */ { opt_info *o1 = sc->opts[sc->pc]; if ((!is_pair(arg1)) || - (is_proper_quote(sc, arg1))) - { - opc->v[1].p = (!is_pair(arg1)) ? arg1 : cadr(arg1); - if ((!is_symbol(arg2)) && - ((!is_pair(arg2)) || - (is_proper_quote(sc, arg2)))) - { - opc->v[2].p = (!is_pair(arg2)) ? arg2 : cadr(arg2); - if ((opc->v[3].p_pp_f == make_list_p_pp) && - (is_t_integer(opc->v[1].p)) && (integer(opc->v[1].p) >= 0) && (integer(opc->v[1].p) < sc->max_list_length)) - { - opc->v[0].fp = opt_p_pp_cc_make_list; - opc->v[1].i = integer(opc->v[1].p); - } - else opc->v[0].fp = opt_p_pp_cc; - return_true(sc, car_x); - } - if (is_symbol(arg2)) - { - opc->v[2].p = opc->v[1].p; - opc->v[1].p = opt_simple_symbol(sc, arg2); - if (opc->v[1].p) - { - opc->v[0].fp = opt_p_pp_cs; - if (is_pair(slot_value(opc->v[1].p))) - { - if (func == assq_p_pp) opc->v[3].p_pp_f = s7_assq; - else - if (func == memq_p_pp) opc->v[3].p_pp_f = s7_memq; - else - if ((func == member_p_pp) && (is_simple(opc->v[2].p))) opc->v[3].p_pp_f = s7_memq; - else - if (func == assoc_p_pp) - { - if (is_simple(opc->v[2].p)) opc->v[3].p_pp_f = s7_assq; - else if (is_pair(car(slot_value(opc->v[1].p)))) opc->v[3].p_pp_f = assoc_1; - }} - return_true(sc, car_x); - } - sc->pc = pstart; - return_false(sc, car_x); - }} + (is_proper_quote(sc, arg1))) + { + opc->v[1].p = (!is_pair(arg1)) ? arg1 : cadr(arg1); + if ((!is_symbol(arg2)) && + ((!is_pair(arg2)) || + (is_proper_quote(sc, arg2)))) + { + opc->v[2].p = (!is_pair(arg2)) ? arg2 : cadr(arg2); + if ((opc->v[3].p_pp_f == make_list_p_pp) && + (is_t_integer(opc->v[1].p)) && (integer(opc->v[1].p) >= 0) && (integer(opc->v[1].p) < sc->max_list_length)) + { + opc->v[0].fp = opt_p_pp_cc_make_list; + opc->v[1].i = integer(opc->v[1].p); + } + else opc->v[0].fp = opt_p_pp_cc; + return_true(sc, car_x); + } + if (is_symbol(arg2)) + { + opc->v[2].p = opc->v[1].p; + opc->v[1].p = opt_simple_symbol(sc, arg2); + if (opc->v[1].p) + { + opc->v[0].fp = opt_p_pp_cs; + if (is_pair(slot_value(opc->v[1].p))) + { + if (func == assq_p_pp) opc->v[3].p_pp_f = s7_assq; + else + if (func == memq_p_pp) opc->v[3].p_pp_f = s7_memq; + else + if ((func == member_p_pp) && (is_simple(opc->v[2].p))) opc->v[3].p_pp_f = s7_memq; + else + if (func == assoc_p_pp) + { + if (is_simple(opc->v[2].p)) opc->v[3].p_pp_f = s7_assq; + else if (is_pair(car(slot_value(opc->v[1].p)))) opc->v[3].p_pp_f = assoc_1; + }} + return_true(sc, car_x); + } + sc->pc = pstart; + return_false(sc, car_x); + }} if (cell_optimize(sc, cdr(car_x))) - { - if (is_symbol(arg2)) - { - opc->v[1].p = opt_simple_symbol(sc, arg2); - if (opc->v[1].p) - { - opc->v[0].fp = (func == add_p_pp) ? opt_p_pp_fs_add : ((func == subtract_p_pp) ? opt_p_pp_fs_sub : + { + if (is_symbol(arg2)) + { + opc->v[1].p = opt_simple_symbol(sc, arg2); + if (opc->v[1].p) + { + opc->v[0].fp = (func == add_p_pp) ? opt_p_pp_fs_add : ((func == subtract_p_pp) ? opt_p_pp_fs_sub : ((func == vector_ref_p_pp) ? opt_p_pp_fs_vref : ((func == cons_p_pp) ? opt_p_pp_fs_cons : opt_p_pp_fs))); - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - } - sc->pc = pstart; - return_false(sc, car_x); - } - if ((!is_pair(arg2)) || - (is_proper_quote(sc, arg2))) - { - if (is_t_integer(arg2)) - { - s7_p_pi_t ifunc = s7_p_pi_function(s_func); - if (ifunc) - { - opc->v[2].i = integer(arg2); - opc->v[3].p_pi_f = ifunc; - if (!p_pi_fc_combinable(sc, opc)) - { - opc->v[0].fp = opt_p_pi_fc; - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - } - return_true(sc, car_x); - }} - opc->v[2].p = (!is_pair(arg2)) ? arg2 : cadr(arg2); - opc->v[0].fp = opt_p_pp_fc; - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[10].o1 = o1; - opc->v[11].fp = o1->v[0].fp; - opc->v[9].fp = opc->v[8].o1->v[0].fp; - opc->v[0].fp = opt_p_pp_ff; - - if ((opc->v[9].fp == opt_p_pp_sf_mul) && (opc->v[11].fp == opt_p_pp_sf_mul)) - { - if (func == add_p_pp) opc->v[0].fp = opt_p_pp_ff_add_mul_mul; - else if (func == subtract_p_pp) opc->v[0].fp = opt_p_pp_ff_sub_mul_mul; - } - check_opc_vector_wraps(opc); - return_true(sc, car_x); - }}} + opc->v[4].o1 = o1; + opc->v[5].fp = o1->v[0].fp; + return_true(sc, car_x); + } + sc->pc = pstart; + return_false(sc, car_x); + } + if ((!is_pair(arg2)) || + (is_proper_quote(sc, arg2))) + { + if (is_t_integer(arg2)) + { + s7_p_pi_t ifunc = s7_p_pi_function(s_func); + if (ifunc) + { + opc->v[2].i = integer(arg2); + opc->v[3].p_pi_f = ifunc; + if (!p_pi_fc_combinable(sc, opc)) + { + opc->v[0].fp = opt_p_pi_fc; + opc->v[4].o1 = o1; + opc->v[5].fp = o1->v[0].fp; + } + return_true(sc, car_x); + }} + opc->v[2].p = (!is_pair(arg2)) ? arg2 : cadr(arg2); + opc->v[0].fp = opt_p_pp_fc; + opc->v[4].o1 = o1; + opc->v[5].fp = o1->v[0].fp; + return_true(sc, car_x); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) + { + opc->v[10].o1 = o1; + opc->v[11].fp = o1->v[0].fp; + opc->v[9].fp = opc->v[8].o1->v[0].fp; + opc->v[0].fp = opt_p_pp_ff; + + if ((opc->v[9].fp == opt_p_pp_sf_mul) && (opc->v[11].fp == opt_p_pp_sf_mul)) + { + if (func == add_p_pp) opc->v[0].fp = opt_p_pp_ff_add_mul_mul; + else if (func == subtract_p_pp) opc->v[0].fp = opt_p_pp_ff_sub_mul_mul; + } + check_opc_vector_wraps(opc); + return_true(sc, car_x); + }}} sc->pc = pstart; return_false(sc, car_x); } @@ -64112,77 +64112,77 @@ static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_poi s7_pointer arg2 = caddr(car_x); opc->v[3].call = cf_call(sc, car_x, s_func, 2); if ((is_code_constant(sc, arg1)) && (is_code_constant(sc, arg2))) - { - opc->v[0].fp = opt_p_call_cc; - opc->v[1].p = (is_pair(arg1)) ? cadr(arg1) : arg1; - opc->v[2].p = (is_pair(arg2)) ? cadr(arg2) : arg2; - return_true(sc, car_x); - } + { + opc->v[0].fp = opt_p_call_cc; + opc->v[1].p = (is_pair(arg1)) ? cadr(arg1) : arg1; + opc->v[2].p = (is_pair(arg2)) ? cadr(arg2) : arg2; + return_true(sc, car_x); + } if (is_symbol(arg1)) - { - opc->v[1].p = s7_slot(sc, arg1); - if ((is_slot(opc->v[1].p)) && - (!has_methods(slot_value(opc->v[1].p)))) - { - if (is_symbol(arg2)) - { - opc->v[2].p = opt_simple_symbol(sc, arg2); - if (opc->v[2].p) - { - opc->v[0].fp = opt_p_call_ss; - return_true(sc, car_x); - } - sc->pc = pstart; - return_false(sc, car_x); - } - if (!is_pair(arg2)) - { - opc->v[2].p = arg2; - opc->v[0].fp = opt_p_call_sc; - return_true(sc, car_x); - } - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[10].o1 = sc->opts[pstart]; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[0].fp = opt_p_call_sf; - return_true(sc, car_x); - }} - else - { - sc->pc = pstart; - return_false(sc, car_x); - }} + { + opc->v[1].p = s7_slot(sc, arg1); + if ((is_slot(opc->v[1].p)) && + (!has_methods(slot_value(opc->v[1].p)))) + { + if (is_symbol(arg2)) + { + opc->v[2].p = opt_simple_symbol(sc, arg2); + if (opc->v[2].p) + { + opc->v[0].fp = opt_p_call_ss; + return_true(sc, car_x); + } + sc->pc = pstart; + return_false(sc, car_x); + } + if (!is_pair(arg2)) + { + opc->v[2].p = arg2; + opc->v[0].fp = opt_p_call_sc; + return_true(sc, car_x); + } + if (cell_optimize(sc, cddr(car_x))) + { + opc->v[10].o1 = sc->opts[pstart]; + opc->v[11].fp = opc->v[10].o1->v[0].fp; + opc->v[0].fp = opt_p_call_sf; + return_true(sc, car_x); + }} + else + { + sc->pc = pstart; + return_false(sc, car_x); + }} opc->v[10].o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cdr(car_x))) - { - opc->v[11].fp = opc->v[10].o1->v[0].fp; - if (is_symbol(arg2)) - { - opc->v[1].p = opt_simple_symbol(sc, arg2); - if (opc->v[1].p) - { - opc->v[0].fp = opt_p_call_fs; - return_true(sc, car_x); - } - sc->pc = pstart; - return_false(sc, car_x); - } - if ((!is_pair(arg2)) || (is_proper_quote(sc, arg2))) /* (char-ci<? (null? i) (quote . let)) t101-43.scm */ - { - opc->v[0].fp = opt_p_call_fc; - opc->v[2].p = (is_pair(arg2)) ? cadr(arg2) : arg2; - check_opc_vector_wraps(opc); - return_true(sc, car_x); - } - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[9].fp = opc->v[8].o1->v[0].fp; - opc->v[0].fp = opt_p_call_ff; - check_opc_vector_wraps(opc); - return_true(sc, car_x); - }}} + { + opc->v[11].fp = opc->v[10].o1->v[0].fp; + if (is_symbol(arg2)) + { + opc->v[1].p = opt_simple_symbol(sc, arg2); + if (opc->v[1].p) + { + opc->v[0].fp = opt_p_call_fs; + return_true(sc, car_x); + } + sc->pc = pstart; + return_false(sc, car_x); + } + if ((!is_pair(arg2)) || (is_proper_quote(sc, arg2))) /* (char-ci<? (null? i) (quote . let)) t101-43.scm */ + { + opc->v[0].fp = opt_p_call_fc; + opc->v[2].p = (is_pair(arg2)) ? cadr(arg2) : arg2; + check_opc_vector_wraps(opc); + return_true(sc, car_x); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) + { + opc->v[9].fp = opc->v[8].o1->v[0].fp; + opc->v[0].fp = opt_p_call_ff; + check_opc_vector_wraps(opc); + return_true(sc, car_x); + }}} sc->pc = pstart; return_false(sc, car_x); } @@ -64213,7 +64213,7 @@ static s7_pointer opt_p_pip_sff_lset(opt_info *o) static s7_pointer opt_p_pip_sso(opt_info *o) { return(o->v[5].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), - o->v[6].p_pi_f(o->sc, slot_value(o->v[3].p), integer(slot_value(o->v[4].p))))); + o->v[6].p_pi_f(o->sc, slot_value(o->v[3].p), integer(slot_value(o->v[4].p))))); } static s7_pointer opt_p_pip_ssf1(opt_info *o) @@ -64229,26 +64229,26 @@ static bool p_pip_ssf_combinable(s7_scheme *sc, opt_info *opc, int32_t start) { o1 = sc->opts[sc->pc - 1]; if ((o1->v[0].fp == opt_p_pi_ss) || (o1->v[0].fp == opt_p_pi_ss_sref) || (o1->v[0].fp == opt_p_pi_ss_vref) || - (o1->v[0].fp == opt_p_pi_ss_sref_direct) || (o1->v[0].fp == opt_p_pi_ss_vref_direct) || - (o1->v[0].fp == opt_p_pi_ss_fvref_direct) || (o1->v[0].fp == opt_p_pi_ss_ivref_direct) || - (o1->v[0].fp == opt_p_pi_ss_pref)) - { - opc->v[5].p_pip_f = opc->v[3].p_pip_f; - opc->v[6].p_pi_f = o1->v[3].p_pi_f; - opc->v[3].p = o1->v[1].p; - opc->v[4].p = o1->v[2].p; - opc->v[0].fp = opt_p_pip_sso; - backup_pc(sc); - return_true(sc, NULL); - } + (o1->v[0].fp == opt_p_pi_ss_sref_direct) || (o1->v[0].fp == opt_p_pi_ss_vref_direct) || + (o1->v[0].fp == opt_p_pi_ss_fvref_direct) || (o1->v[0].fp == opt_p_pi_ss_ivref_direct) || + (o1->v[0].fp == opt_p_pi_ss_pref)) + { + opc->v[5].p_pip_f = opc->v[3].p_pip_f; + opc->v[6].p_pi_f = o1->v[3].p_pi_f; + opc->v[3].p = o1->v[1].p; + opc->v[4].p = o1->v[2].p; + opc->v[0].fp = opt_p_pip_sso; + backup_pc(sc); + return_true(sc, NULL); + } if (o1->v[0].fp == opt_p_p_c) - { - opc->v[5].p_p_f = o1->v[2].p_p_f; - opc->v[4].p = o1->v[1].p; - backup_pc(sc); - opc->v[0].fp = opt_p_pip_c; - return_true(sc, NULL); - }} + { + opc->v[5].p_p_f = o1->v[2].p_p_f; + opc->v[4].p = o1->v[1].p; + backup_pc(sc); + opc->v[0].fp = opt_p_pip_c; + return_true(sc, NULL); + }} o1 = sc->opts[start]; if (o1->v[0].fp != opt_p_p_f) return_false(sc, NULL); @@ -64290,17 +64290,17 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer (checker)) { if ((is_t_vector(obj)) && (checker == sc->is_vector_symbol)) - opc->v[3].p_pip_f = (is_typed_vector(obj)) ? typed_vector_set_p_pip_unchecked : vector_set_p_pip_unchecked; + opc->v[3].p_pip_f = (is_typed_vector(obj)) ? typed_vector_set_p_pip_unchecked : vector_set_p_pip_unchecked; else - if ((is_pair(obj)) && (checker == sc->is_pair_symbol)) /* avoid dumb mismatch in val_type and sig below, #t integer:any? and integer? integer:any? */ - opc->v[3].p_pip_f = s7_p_pip_unchecked_function(s_func); - else - if ((val_type == cadddr(sig)) && - (((is_string(obj)) && (checker == sc->is_string_symbol)) || - ((is_float_vector(obj)) && (checker == sc->is_float_vector_symbol)) || - ((is_int_vector(obj)) && (checker == sc->is_int_vector_symbol)) || - ((is_byte_vector(obj)) && (checker == sc->is_byte_vector_symbol)))) - opc->v[3].p_pip_f = s7_p_pip_unchecked_function(s_func); + if ((is_pair(obj)) && (checker == sc->is_pair_symbol)) /* avoid dumb mismatch in val_type and sig below, #t integer:any? and integer? integer:any? */ + opc->v[3].p_pip_f = s7_p_pip_unchecked_function(s_func); + else + if ((val_type == cadddr(sig)) && + (((is_string(obj)) && (checker == sc->is_string_symbol)) || + ((is_float_vector(obj)) && (checker == sc->is_float_vector_symbol)) || + ((is_int_vector(obj)) && (checker == sc->is_int_vector_symbol)) || + ((is_byte_vector(obj)) && (checker == sc->is_byte_vector_symbol)))) + opc->v[3].p_pip_f = s7_p_pip_unchecked_function(s_func); } if (is_symbol(caddr(car_x))) { @@ -64308,78 +64308,78 @@ static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_pointer arg3 = cadddr(car_x); /* see val_type above */ s7_pointer slot2 = opt_integer_symbol(sc, caddr(car_x)); if (slot2) - { - opc->v[2].p = slot2; - if (has_loop_end(slot2)) - switch (type(obj)) - { - case T_VECTOR: - if (loop_end(slot2) <= vector_length(obj)) - opc->v[3].p_pip_f = (is_typed_vector(obj)) ? typed_t_vector_set_p_pip_direct : t_vector_set_p_pip_direct; - break; - case T_BYTE_VECTOR: - if ((val_type != sc->is_integer_symbol) && (val_type != sc->is_byte_symbol)) return_false(sc, car_x); - if (loop_end(slot2) <= vector_length(obj)) - opc->v[3].p_pip_f = byte_vector_set_p_pip_direct; - break; - case T_INT_VECTOR: - if ((val_type != sc->is_integer_symbol) && (val_type != sc->is_byte_symbol)) return_false(sc, car_x); - if (loop_end(slot2) <= vector_length(obj)) - opc->v[3].p_pip_f = int_vector_set_p_pip_direct; - break; - case T_FLOAT_VECTOR: - if ((val_type != sc->is_float_symbol) && (val_type != sc->is_real_symbol)) return_false(sc, car_x); - if (loop_end(slot2) <= vector_length(obj)) - opc->v[3].p_pip_f = float_vector_set_p_pip_direct; - break; - case T_STRING: - if (loop_end(slot2) <= string_length(obj)) - opc->v[3].p_pip_f = string_set_p_pip_direct; - break; - } /* T_PAIR here would require list_length check which sort of defeats the purpose */ - - if (is_symbol(arg3)) - { - s7_pointer val_slot = opt_simple_symbol(sc, arg3); - /* TODO: for int|byte|float-vector and string need opt_arg_type check?? see val_type above, if vector-set! but have int-vector sig is wrong */ - if (val_slot) - { - opc->v[4].p_pip_f = opc->v[3].p_pip_f; - opc->v[3].p = val_slot; - opc->v[0].fp = (opc->v[4].p_pip_f == vector_set_p_pip_unchecked) ? opt_p_pip_sss_vset : opt_p_pip_sss; - return_true(sc, car_x); - }} - else - if ((!is_pair(arg3)) || - (is_proper_quote(sc, arg3))) - { - opc->v[4].p = (is_pair(arg3)) ? cadr(arg3) : arg3; - opc->v[0].fp = opt_p_pip_ssc; - return_true(sc, car_x); - } - if (cell_optimize(sc, cdddr(car_x))) - { - if (p_pip_ssf_combinable(sc, opc, start)) - return_true(sc, car_x); - opc->v[0].fp = (opc->v[3].p_pip_f == string_set_p_pip_direct) ? opt_p_pip_ssf_sset : + { + opc->v[2].p = slot2; + if (has_loop_end(slot2)) + switch (type(obj)) + { + case T_VECTOR: + if (loop_end(slot2) <= vector_length(obj)) + opc->v[3].p_pip_f = (is_typed_vector(obj)) ? typed_t_vector_set_p_pip_direct : t_vector_set_p_pip_direct; + break; + case T_BYTE_VECTOR: + if ((val_type != sc->is_integer_symbol) && (val_type != sc->is_byte_symbol)) return_false(sc, car_x); + if (loop_end(slot2) <= vector_length(obj)) + opc->v[3].p_pip_f = byte_vector_set_p_pip_direct; + break; + case T_INT_VECTOR: + if ((val_type != sc->is_integer_symbol) && (val_type != sc->is_byte_symbol)) return_false(sc, car_x); + if (loop_end(slot2) <= vector_length(obj)) + opc->v[3].p_pip_f = int_vector_set_p_pip_direct; + break; + case T_FLOAT_VECTOR: + if ((val_type != sc->is_float_symbol) && (val_type != sc->is_real_symbol)) return_false(sc, car_x); + if (loop_end(slot2) <= vector_length(obj)) + opc->v[3].p_pip_f = float_vector_set_p_pip_direct; + break; + case T_STRING: + if (loop_end(slot2) <= string_length(obj)) + opc->v[3].p_pip_f = string_set_p_pip_direct; + break; + } /* T_PAIR here would require list_length check which sort of defeats the purpose */ + + if (is_symbol(arg3)) + { + s7_pointer val_slot = opt_simple_symbol(sc, arg3); + /* TODO: for int|byte|float-vector and string need opt_arg_type check?? see val_type above, if vector-set! but have int-vector sig is wrong */ + if (val_slot) + { + opc->v[4].p_pip_f = opc->v[3].p_pip_f; + opc->v[3].p = val_slot; + opc->v[0].fp = (opc->v[4].p_pip_f == vector_set_p_pip_unchecked) ? opt_p_pip_sss_vset : opt_p_pip_sss; + return_true(sc, car_x); + }} + else + if ((!is_pair(arg3)) || + (is_proper_quote(sc, arg3))) + { + opc->v[4].p = (is_pair(arg3)) ? cadr(arg3) : arg3; + opc->v[0].fp = opt_p_pip_ssc; + return_true(sc, car_x); + } + if (cell_optimize(sc, cdddr(car_x))) + { + if (p_pip_ssf_combinable(sc, opc, start)) + return_true(sc, car_x); + opc->v[0].fp = (opc->v[3].p_pip_f == string_set_p_pip_direct) ? opt_p_pip_ssf_sset : ((opc->v[3].p_pip_f == vector_set_p_pip_unchecked) ? opt_p_pip_ssf_vset : opt_p_pip_ssf); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = sc->opts[start]->v[0].fp; - return_true(sc, car_x); - }}} + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fp = sc->opts[start]->v[0].fp; + return_true(sc, car_x); + }}} else /* not symbol caddr */ { opc->v[10].o1 = sc->opts[sc->pc]; if (int_optimize(sc, cddr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[0].fp = (opc->v[3].p_pip_f == list_set_p_pip_unchecked) ? opt_p_pip_sff_lset : opt_p_pip_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fp = opc->v[8].o1->v[0].fp; - return_true(sc, car_x); - }}} + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(car_x))) + { + opc->v[0].fp = (opc->v[3].p_pip_f == list_set_p_pip_unchecked) ? opt_p_pip_sff_lset : opt_p_pip_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fp = opc->v[8].o1->v[0].fp; + return_true(sc, car_x); + }}} return_false(sc, car_x); } @@ -64420,19 +64420,19 @@ static bool p_piip_to_sx(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_po { opc->v[2].p = slot; if ((is_symbol(car(valp))) || - (is_unquoted_pair(car(valp)))) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, valp)) - return_false(sc, indexp1); - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[0].fp = opt_p_piip_sssf; - if ((is_t_vector(obj)) && - (loop_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (loop_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) - opc->v[0].fp = vector_set_piip_sssf_unchecked; - return_true(sc, NULL); - } + (is_unquoted_pair(car(valp)))) + { + opc->v[10].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, valp)) + return_false(sc, indexp1); + opc->v[11].fp = opc->v[10].o1->v[0].fp; + opc->v[0].fp = opt_p_piip_sssf; + if ((is_t_vector(obj)) && + (loop_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && + (loop_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) + opc->v[0].fp = vector_set_piip_sssf_unchecked; + return_true(sc, NULL); + } opc->v[0].fp = opt_p_piip_sssc; opc->v[4].p = (is_pair(car(valp))) ? cadar(valp) : car(valp); return_true(sc, NULL); @@ -64442,16 +64442,16 @@ static bool p_piip_to_sx(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_po { opc->v[8].o1 = sc->opts[sc->pc]; if (int_optimize(sc, indexp2)) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, valp)) - { - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - opc->v[3].fp = opc->v[4].o1->v[0].fp; - opc->v[0].fp = opt_p_piip_sfff; - return_true(sc, NULL); - }}} + { + opc->v[4].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, valp)) + { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[3].fp = opc->v[4].o1->v[0].fp; + opc->v[0].fp = opt_p_piip_sfff; + return_true(sc, NULL); + }}} return_false(sc, NULL); } @@ -64463,17 +64463,17 @@ static bool p_piip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointe s7_pointer obj; s7_pointer slot1 = s7_slot(sc, cadr(car_x)); if (!is_slot(slot1)) - return_false(sc, car_x); + return_false(sc, car_x); obj = slot_value(slot1); if ((has_methods(obj)) || (is_immutable(obj))) - return_false(sc, car_x); + return_false(sc, car_x); if ((is_any_vector(obj)) && /* vector_set_p_piip calls vector_setter(obj) */ - (vector_rank(obj) == 2)) - { - opc->v[1].p = slot1; - opc->v[5].p_piip_f = vector_set_p_piip; - return(p_piip_to_sx(sc, opc, cddr(car_x), cdddr(car_x), cddddr(car_x), obj)); - }} + (vector_rank(obj) == 2)) + { + opc->v[1].p = slot1; + opc->v[5].p_piip_f = vector_set_p_piip; + return(p_piip_to_sx(sc, opc, cddr(car_x), cdddr(car_x), cddddr(car_x), obj)); + }} return_false(sc, car_x); } @@ -64505,42 +64505,42 @@ static bool p_pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer s7_pointer obj; s7_pointer slot1 = s7_slot(sc, cadr(car_x)); if (!is_slot(slot1)) - return_false(sc, car_x); + return_false(sc, car_x); obj = slot_value(slot1); if ((has_methods(obj)) || (is_immutable(obj))) - return_false(sc, car_x); + return_false(sc, car_x); if ((is_t_vector(obj)) && - (vector_rank(obj) == 2)) - { - s7_pointer slot, indexp1 = cddr(car_x), indexp2 = cdddr(car_x); - opc->v[1].p = slot1; - opc->v[4].p_pii_f = vector_ref_p_pii; - slot = opt_integer_symbol(sc, car(indexp2)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, car(indexp1)); - if (slot) - { - opc->v[2].p = slot; - opc->v[0].fp = opt_p_pii_sss; - /* normal vector rank 2 (see above) */ - if ((loop_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && - (loop_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) - opc->v[0].fp = vector_ref_pii_sss_unchecked; - return_true(sc, car_x); - }} - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp1)) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, indexp2)) - { - opc->v[0].fp = opt_p_pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - return_true(sc, car_x); - }}}} + (vector_rank(obj) == 2)) + { + s7_pointer slot, indexp1 = cddr(car_x), indexp2 = cdddr(car_x); + opc->v[1].p = slot1; + opc->v[4].p_pii_f = vector_ref_p_pii; + slot = opt_integer_symbol(sc, car(indexp2)); + if (slot) + { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, car(indexp1)); + if (slot) + { + opc->v[2].p = slot; + opc->v[0].fp = opt_p_pii_sss; + /* normal vector rank 2 (see above) */ + if ((loop_end_fits(opc->v[2].p, vector_dimension(slot_value(opc->v[1].p), 0))) && + (loop_end_fits(opc->v[3].p, vector_dimension(slot_value(opc->v[1].p), 1)))) + opc->v[0].fp = vector_ref_pii_sss_unchecked; + return_true(sc, car_x); + }} + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) + { + opc->v[0].fp = opt_p_pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + return_true(sc, car_x); + }}}} return_false(sc, car_x); } @@ -64561,14 +64561,14 @@ static bool p_ppi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer { s7_pointer slot = opt_simple_symbol(sc, caddr(car_x)); if (slot) - { - opc->v[2].p = cadr(car_x); - opc->v[1].p = slot; - opc->v[0].fp = (ifunc == char_position_p_ppi) ? opt_p_ppi_psf_cpos : opt_p_ppi_psf; - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fi = sc->opts[start]->v[0].fi; - return_true(sc, car_x); - }} + { + opc->v[2].p = cadr(car_x); + opc->v[1].p = slot; + opc->v[0].fp = (ifunc == char_position_p_ppi) ? opt_p_ppi_psf_cpos : opt_p_ppi_psf; + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fi = sc->opts[start]->v[0].fi; + return_true(sc, car_x); + }} sc->pc = start; return_false(sc, car_x); } @@ -64662,154 +64662,154 @@ static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer opt_info *o1; s7_pointer slot = s7_slot(sc, arg1); if ((!is_slot(slot)) || - (has_methods(slot_value(slot)))) - return_false(sc, car_x); + (has_methods(slot_value(slot)))) + return_false(sc, car_x); obj = slot_value(slot); if ((is_any_vector(obj)) && - (vector_rank(obj) > 1)) - return_false(sc, car_x); + (vector_rank(obj) > 1)) + return_false(sc, car_x); if (is_target_or_its_alias(car(car_x), s_func, sc->hash_table_set_symbol)) - { - if ((!is_hash_table(obj)) || (is_immutable_hash_table(obj))) - return_false(sc, car_x); - } + { + if ((!is_hash_table(obj)) || (is_immutable_hash_table(obj))) + return_false(sc, car_x); + } else - if ((is_target_or_its_alias(car(car_x), s_func, sc->let_set_symbol)) && - ((!is_let(obj)) || (is_immutable(obj)))) - return_false(sc, car_x); + if ((is_target_or_its_alias(car(car_x), s_func, sc->let_set_symbol)) && + ((!is_let(obj)) || (is_immutable(obj)))) + return_false(sc, car_x); opc->v[1].p = slot; if ((func == hash_table_set_p_ppp) && (is_hash_table(obj))) - opc->v[3].p_ppp_f = s7_hash_table_set; + opc->v[3].p_ppp_f = s7_hash_table_set; if (is_symbol(arg2)) - { - if ((is_keyword(arg2)) && (is_symbol(arg3)) && (is_let(obj)) && (opc->v[3].p_ppp_f == let_set_2)) - { - s7_pointer val_slot = opt_simple_symbol(sc, arg3); - if ((val_slot) && (use_pps_slot_set(sc, opc, obj, keyword_symbol(arg2), val_slot))) - return_true(sc, car_x); - } - slot = opt_simple_symbol(sc, arg2); - if (slot) - { - opc->v[2].p = slot; - arg2 = slot_value(slot); - if (is_symbol(arg3)) - { - slot = opt_simple_symbol(sc, arg3); - if (slot) - { - s7_p_ppp_t func1 = opc->v[3].p_ppp_f; - opc->v[4].p_ppp_f = func1; - opc->v[3].p = slot; - opc->v[0].fp = (func1 == multiply_p_ppp) ? opt_p_ppp_sss_mul : ((func1 == s7_hash_table_set) ? opt_p_ppp_sss_hset : opt_p_ppp_sss); - return_true(sc, car_x); - }} - else - if ((!is_pair(arg3)) || - (is_proper_quote(sc, arg3))) - { - opc->v[4].p = (is_pair(arg3)) ? cadr(arg3) : arg3; - opc->v[0].fp = opt_p_ppp_ssc; - if ((is_let(obj)) && (opc->v[3].p_ppp_f == let_set_2) && (is_symbol(arg2))) /* (let-set! L3 :x 0) */ - use_ppc_slot_set(sc, opc, obj, (is_keyword(arg2)) ? keyword_symbol(arg2) : arg2, opc->v[4].p); - return_true(sc, car_x); - } - if (optimize_op(car_x) == HOP_HASH_TABLE_INCREMENT) - { - opc->v[0].fp = opt_p_ppp_hash_table_increment; - opc->v[5].p = car_x; - return_true(sc, car_x); - } - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = opc->v[4].o1->v[0].fp; - opc->v[0].fp = opt_p_ppp_ssf; - if ((is_let(obj)) && (is_symbol_and_keyword(arg2)) && (opc->v[3].p_ppp_f == let_set_2)) /* (let-set! L3 :x (+ (L3 'x) 1)) */ - use_ppf_slot_set(sc, opc, obj, keyword_symbol(arg2)); - return_true(sc, car_x); - } - sc->pc = start; - }} + { + if ((is_keyword(arg2)) && (is_symbol(arg3)) && (is_let(obj)) && (opc->v[3].p_ppp_f == let_set_2)) + { + s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if ((val_slot) && (use_pps_slot_set(sc, opc, obj, keyword_symbol(arg2), val_slot))) + return_true(sc, car_x); + } + slot = opt_simple_symbol(sc, arg2); + if (slot) + { + opc->v[2].p = slot; + arg2 = slot_value(slot); + if (is_symbol(arg3)) + { + slot = opt_simple_symbol(sc, arg3); + if (slot) + { + s7_p_ppp_t func1 = opc->v[3].p_ppp_f; + opc->v[4].p_ppp_f = func1; + opc->v[3].p = slot; + opc->v[0].fp = (func1 == multiply_p_ppp) ? opt_p_ppp_sss_mul : ((func1 == s7_hash_table_set) ? opt_p_ppp_sss_hset : opt_p_ppp_sss); + return_true(sc, car_x); + }} + else + if ((!is_pair(arg3)) || + (is_proper_quote(sc, arg3))) + { + opc->v[4].p = (is_pair(arg3)) ? cadr(arg3) : arg3; + opc->v[0].fp = opt_p_ppp_ssc; + if ((is_let(obj)) && (opc->v[3].p_ppp_f == let_set_2) && (is_symbol(arg2))) /* (let-set! L3 :x 0) */ + use_ppc_slot_set(sc, opc, obj, (is_keyword(arg2)) ? keyword_symbol(arg2) : arg2, opc->v[4].p); + return_true(sc, car_x); + } + if (optimize_op(car_x) == HOP_HASH_TABLE_INCREMENT) + { + opc->v[0].fp = opt_p_ppp_hash_table_increment; + opc->v[5].p = car_x; + return_true(sc, car_x); + } + if (cell_optimize(sc, cdddr(car_x))) + { + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + opc->v[0].fp = opt_p_ppp_ssf; + if ((is_let(obj)) && (is_symbol_and_keyword(arg2)) && (opc->v[3].p_ppp_f == let_set_2)) /* (let-set! L3 :x (+ (L3 'x) 1)) */ + use_ppf_slot_set(sc, opc, obj, keyword_symbol(arg2)); + return_true(sc, car_x); + } + sc->pc = start; + }} if ((is_proper_quote(sc, arg2)) && - (is_symbol(arg3))) - { - s7_pointer val_slot = opt_simple_symbol(sc, arg3); - if (val_slot) - { - opc->v[2].p = cadr(arg2); - opc->v[4].p = val_slot; - opc->v[0].fp = opt_p_ppp_scs; - if ((is_let(obj)) && (opc->v[3].p_ppp_f == let_set_2) && (is_symbol(cadr(arg2)))) - use_pps_slot_set(sc, opc, obj, cadr(arg2), val_slot); - return_true(sc, car_x); - }} + (is_symbol(arg3))) + { + s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) + { + opc->v[2].p = cadr(arg2); + opc->v[4].p = val_slot; + opc->v[0].fp = opt_p_ppp_scs; + if ((is_let(obj)) && (opc->v[3].p_ppp_f == let_set_2) && (is_symbol(cadr(arg2)))) + use_pps_slot_set(sc, opc, obj, cadr(arg2), val_slot); + return_true(sc, car_x); + }} o1 = sc->opts[sc->pc]; if (cell_optimize(sc, cddr(car_x))) - { - opt_info *o2 = sc->opts[sc->pc]; - if (is_symbol(arg3)) - { - s7_pointer val_slot = opt_simple_symbol(sc, arg3); - if (val_slot) - { - opc->v[2].p = val_slot; - opc->v[0].fp = opt_p_ppp_sfs; /* hset case goes through the case below */ - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - }} - if ((!is_pair(arg3)) && (is_let(obj)) && (is_quoted_symbol(arg2)) && - (opc->v[3].p_ppp_f == let_set_2) && /* (let-set! L3 'x 0) */ - (use_ppc_slot_set(sc, opc, obj, cadr(arg2), arg3))) - return_true(sc, car_x); - - if (cell_optimize(sc, cdddr(car_x))) - { - if ((is_let(obj)) && (is_quoted_symbol(arg2)) && (opc->v[3].p_ppp_f == let_set_2) && /* (let-set! L3 'x (+ (L3 'x) 1)) */ - (use_ppf_slot_set(sc, opc, obj, cadr(arg2)))) - { - opc->v[4].o1 = o2; - opc->v[5].fp = opc->v[4].o1->v[0].fp; - return_true(sc, car_x); - } - opc->v[0].fp = opt_p_ppp_sff; - opc->v[10].o1 = o1; - opc->v[11].fp = o1->v[0].fp; - opc->v[8].o1 = o2; - opc->v[9].fp = o2->v[0].fp; - return_true(sc, car_x); - }}} + { + opt_info *o2 = sc->opts[sc->pc]; + if (is_symbol(arg3)) + { + s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) + { + opc->v[2].p = val_slot; + opc->v[0].fp = opt_p_ppp_sfs; /* hset case goes through the case below */ + opc->v[4].o1 = o1; + opc->v[5].fp = o1->v[0].fp; + return_true(sc, car_x); + }} + if ((!is_pair(arg3)) && (is_let(obj)) && (is_quoted_symbol(arg2)) && + (opc->v[3].p_ppp_f == let_set_2) && /* (let-set! L3 'x 0) */ + (use_ppc_slot_set(sc, opc, obj, cadr(arg2), arg3))) + return_true(sc, car_x); + + if (cell_optimize(sc, cdddr(car_x))) + { + if ((is_let(obj)) && (is_quoted_symbol(arg2)) && (opc->v[3].p_ppp_f == let_set_2) && /* (let-set! L3 'x (+ (L3 'x) 1)) */ + (use_ppf_slot_set(sc, opc, obj, cadr(arg2)))) + { + opc->v[4].o1 = o2; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + return_true(sc, car_x); + } + opc->v[0].fp = opt_p_ppp_sff; + opc->v[10].o1 = o1; + opc->v[11].fp = o1->v[0].fp; + opc->v[8].o1 = o2; + opc->v[9].fp = o2->v[0].fp; + return_true(sc, car_x); + }}} else /* arg1 not symbol */ { opc->v[10].o1 = sc->opts[start]; if (cell_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[0].fp = opt_p_ppp_fff; - opc->v[11].fp = opc->v[10].o1->v[0].fp; - opc->v[9].fp = opc->v[8].o1->v[0].fp; - opc->v[5].fp = opc->v[4].o1->v[0].fp; - if ((opc->v[3].p_ppp_f == list_p_ppp) && - (opc->v[5].fp == opt_p_c) && (opc->v[9].fp == opt_p_c) && (opc->v[11].fp == opt_p_c)) - { - opc->v[0].fp = opt_list_3c; - opc->v[4].p = opc->v[4].o1->v[1].p; - opc->v[8].p = opc->v[8].o1->v[1].p; - opc->v[10].p = opc->v[10].o1->v[1].p; - } - return_true(sc, car_x); - }}}} + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) + { + opc->v[4].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(car_x))) + { + opc->v[0].fp = opt_p_ppp_fff; + opc->v[11].fp = opc->v[10].o1->v[0].fp; + opc->v[9].fp = opc->v[8].o1->v[0].fp; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + if ((opc->v[3].p_ppp_f == list_p_ppp) && + (opc->v[5].fp == opt_p_c) && (opc->v[9].fp == opt_p_c) && (opc->v[11].fp == opt_p_c)) + { + opc->v[0].fp = opt_list_3c; + opc->v[4].p = opc->v[4].o1->v[1].p; + opc->v[8].p = opc->v[8].o1->v[1].p; + opc->v[10].p = opc->v[10].o1->v[1].p; + } + return_true(sc, car_x); + }}}} sc->pc = start; return_false(sc, car_x); } @@ -64857,96 +64857,96 @@ static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_po opt_info *o1 = sc->opts[sc->pc]; if (!is_pair(arg1)) - { - if (is_normal_symbol(arg1)) - { - slot = opt_simple_symbol(sc, arg1); - if (slot) - { - opc->v[1].p = slot; - if ((s_func == global_value(sc->vector_ref_symbol)) && - (is_t_vector(slot_value(slot))) && (vector_rank(slot_value(slot)) != 2)) - return_false(sc, car_x); - } - else return_false(sc, car_x); /* no need for sc->pc = start here, I think */ - } - else - { - if ((is_code_constant(sc, arg1)) && (is_code_constant(sc, arg2)) && (is_normal_symbol(arg3))) - { - s7_pointer val_slot = opt_simple_symbol(sc, arg3); - if (val_slot) - { - opc->v[1].p = (is_pair(arg1)) ? cadr(arg1) : arg1; - opc->v[2].p = (is_pair(arg2)) ? cadr(arg2) : arg2; - opc->v[3].p = val_slot; - opc->v[4].call = cf_call(sc, car_x, s_func, 3); - opc->v[0].fp = opt_p_call_ccs; - return_true(sc, car_x); - }} - opc->v[1].p = arg1; - if (s_func == global_value(sc->vector_ref_symbol)) - return_false(sc, car_x); - } - if (is_normal_symbol(arg2)) - { - slot = opt_simple_symbol(sc, arg2); - if (slot) - { - opc->v[2].p = slot; - if (is_normal_symbol(arg3)) - { - slot = opt_simple_symbol(sc, arg3); - if (slot) - { - opc->v[3].p = slot; - opc->v[4].call = cf_call(sc, car_x, s_func, 3); - opc->v[0].fp = (is_slot(opc->v[1].p)) ? opt_p_call_sss : opt_p_call_css; - return_true(sc, car_x); - }} - else - if (is_slot(opc->v[1].p)) - { - int32_t start1 = sc->pc; - if ((cf_call(sc, car_x, s_func, 3) == g_substring_uncopied) && /* opc->v[4].call is unsafe -- might not be set */ - (is_t_integer(slot_value(opc->v[2].p))) && - (is_string(slot_value(opc->v[1].p))) && - (int_optimize(sc, cdddr(car_x)))) - { - opc->v[0].fp = opt_p_substring_uncopied_ssf; - opc->v[5].o1 = o1; - opc->v[6].fi = o1->v[0].fi; - return_true(sc, car_x); - } - sc->pc = start1; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[4].call = cf_call(sc, car_x, s_func, 3); - opc->v[0].fp = opt_p_call_ssf; - opc->v[5].o1 = o1; - opc->v[6].fp = o1->v[0].fp; - return_true(sc, car_x); - }}}}} + { + if (is_normal_symbol(arg1)) + { + slot = opt_simple_symbol(sc, arg1); + if (slot) + { + opc->v[1].p = slot; + if ((s_func == global_value(sc->vector_ref_symbol)) && + (is_t_vector(slot_value(slot))) && (vector_rank(slot_value(slot)) != 2)) + return_false(sc, car_x); + } + else return_false(sc, car_x); /* no need for sc->pc = start here, I think */ + } + else + { + if ((is_code_constant(sc, arg1)) && (is_code_constant(sc, arg2)) && (is_normal_symbol(arg3))) + { + s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) + { + opc->v[1].p = (is_pair(arg1)) ? cadr(arg1) : arg1; + opc->v[2].p = (is_pair(arg2)) ? cadr(arg2) : arg2; + opc->v[3].p = val_slot; + opc->v[4].call = cf_call(sc, car_x, s_func, 3); + opc->v[0].fp = opt_p_call_ccs; + return_true(sc, car_x); + }} + opc->v[1].p = arg1; + if (s_func == global_value(sc->vector_ref_symbol)) + return_false(sc, car_x); + } + if (is_normal_symbol(arg2)) + { + slot = opt_simple_symbol(sc, arg2); + if (slot) + { + opc->v[2].p = slot; + if (is_normal_symbol(arg3)) + { + slot = opt_simple_symbol(sc, arg3); + if (slot) + { + opc->v[3].p = slot; + opc->v[4].call = cf_call(sc, car_x, s_func, 3); + opc->v[0].fp = (is_slot(opc->v[1].p)) ? opt_p_call_sss : opt_p_call_css; + return_true(sc, car_x); + }} + else + if (is_slot(opc->v[1].p)) + { + int32_t start1 = sc->pc; + if ((cf_call(sc, car_x, s_func, 3) == g_substring_uncopied) && /* opc->v[4].call is unsafe -- might not be set */ + (is_t_integer(slot_value(opc->v[2].p))) && + (is_string(slot_value(opc->v[1].p))) && + (int_optimize(sc, cdddr(car_x)))) + { + opc->v[0].fp = opt_p_substring_uncopied_ssf; + opc->v[5].o1 = o1; + opc->v[6].fi = o1->v[0].fi; + return_true(sc, car_x); + } + sc->pc = start1; + if (cell_optimize(sc, cdddr(car_x))) + { + opc->v[4].call = cf_call(sc, car_x, s_func, 3); + opc->v[0].fp = opt_p_call_ssf; + opc->v[5].o1 = o1; + opc->v[6].fp = o1->v[0].fp; + return_true(sc, car_x); + }}}}} if (s_func == global_value(sc->vector_ref_symbol)) - return_false(sc, car_x); + return_false(sc, car_x); if (cell_optimize(sc, cdr(car_x))) - { - opt_info *o2 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opt_info *o3 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[2].call = cf_call(sc, car_x, s_func, 3); - opc->v[0].fp = opt_p_call_ppp; - opc->v[3].o1 = o1; - opc->v[4].fp = o1->v[0].fp; - opc->v[5].o1 = o2; - opc->v[6].fp = o2->v[0].fp; - opc->v[10].o1 = o3; - opc->v[11].fp = o3->v[0].fp; - return_true(sc, car_x); - }}}} + { + opt_info *o2 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) + { + opt_info *o3 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(car_x))) + { + opc->v[2].call = cf_call(sc, car_x, s_func, 3); + opc->v[0].fp = opt_p_call_ppp; + opc->v[3].o1 = o1; + opc->v[4].fp = o1->v[0].fp; + opc->v[5].o1 = o2; + opc->v[6].fp = o2->v[0].fp; + opc->v[10].o1 = o3; + opc->v[11].fp = o3->v[0].fp; + return_true(sc, car_x); + }}}} sc->pc = start; return_false(sc, car_x); } @@ -64981,17 +64981,17 @@ static bool p_call_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_po s7_pointer p = cdr(car_x); /* (vector-set! v k i 2) gets here */ opc->v[1].i = (len - 1); for (int32_t pctr = P_CALL_O1; is_pair(p); pctr++, p = cdr(p)) - { - opc->v[pctr].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - } + { + 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; - opc->v[2].call = cf_call(sc, car_x, s_func, len - 1); - return_true(sc, car_x); - }} + { + opc->v[0].fp = opt_p_call_any; + opc->v[2].call = cf_call(sc, car_x, s_func, len - 1); + return_true(sc, car_x); + }} return_false(sc, car_x); } @@ -65030,161 +65030,161 @@ static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, in if (len == 2) { switch (type(obj)) - { - case T_PAIR: opc->v[3].p_pi_f = list_ref_p_pi_unchecked; break; - case T_HASH_TABLE: opc->v[3].p_pp_f = s7_hash_table_ref; break; - case T_LET: opc->v[3].p_pp_f = let_ref; break; - case T_STRING: opc->v[3].p_pi_f = string_ref_p_pi_unchecked; break; - case T_C_OBJECT: return_false(sc, car_x); /* no pi_ref because ref assumes pp */ - - case T_VECTOR: - if (vector_rank(obj) != 1) - return_false(sc, car_x); - opc->v[3].p_pi_f = t_vector_ref_p_pi_unchecked; - break; - - case T_BYTE_VECTOR: - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - if (vector_rank(obj) != 1) - return_false(sc, car_x); - opc->v[3].p_pi_f = vector_ref_p_pi_unchecked; - break; - - default: - return_false(sc, car_x); - } + { + case T_PAIR: opc->v[3].p_pi_f = list_ref_p_pi_unchecked; break; + case T_HASH_TABLE: opc->v[3].p_pp_f = s7_hash_table_ref; break; + case T_LET: opc->v[3].p_pp_f = let_ref; break; + case T_STRING: opc->v[3].p_pi_f = string_ref_p_pi_unchecked; break; + case T_C_OBJECT: return_false(sc, car_x); /* no pi_ref because ref assumes pp */ + + case T_VECTOR: + if (vector_rank(obj) != 1) + return_false(sc, car_x); + opc->v[3].p_pi_f = t_vector_ref_p_pi_unchecked; + break; + + case T_BYTE_VECTOR: + case T_INT_VECTOR: + case T_FLOAT_VECTOR: + if (vector_rank(obj) != 1) + return_false(sc, car_x); + opc->v[3].p_pi_f = vector_ref_p_pi_unchecked; + break; + + default: + return_false(sc, car_x); + } /* now v3.p_pi|pp.f is set */ if (is_symbol(arg1)) - { - s7_pointer slot = s7_slot(sc, arg1); /* not the desired slot if let+keyword, see below */ - if (is_slot(slot)) - { - opc->v[2].p = slot; - if ((!is_hash_table(obj)) && /* these because opt_int below */ - (!is_let(obj))) - { - if (!is_t_integer(slot_value(slot))) - return_false(sc, car_x); /* I think this reflects that a non-int index is an error for list-ref et al */ - opc->v[0].fp = opt_p_pi_ss; - if (has_loop_end(opc->v[2].p)) - check_unchecked(sc, obj, opc->v[2].p, opc, NULL); - fixup_p_pi_ss(opc); - return_true(sc, car_x); - } - opc->v[0].fp = ((is_hash_table(obj)) && (opc->v[3].p_pp_f == s7_hash_table_ref)) ? opt_p_pp_ss_href : - (((is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) ? opt_p_pp_ss_lref : opt_p_pp_ss); - if ((opc->v[0].fp == opt_p_pp_ss_lref) && (is_keyword(arg1))) - use_slot_ref(sc, opc, obj, keyword_symbol(arg1)); /* if keyword, slot is: (L3 :x) -> #<slot: :x :x> */ - return_true(sc, car_x); - }} + { + s7_pointer slot = s7_slot(sc, arg1); /* not the desired slot if let+keyword, see below */ + if (is_slot(slot)) + { + opc->v[2].p = slot; + if ((!is_hash_table(obj)) && /* these because opt_int below */ + (!is_let(obj))) + { + if (!is_t_integer(slot_value(slot))) + return_false(sc, car_x); /* I think this reflects that a non-int index is an error for list-ref et al */ + opc->v[0].fp = opt_p_pi_ss; + if (has_loop_end(opc->v[2].p)) + check_unchecked(sc, obj, opc->v[2].p, opc, NULL); + fixup_p_pi_ss(opc); + return_true(sc, car_x); + } + opc->v[0].fp = ((is_hash_table(obj)) && (opc->v[3].p_pp_f == s7_hash_table_ref)) ? opt_p_pp_ss_href : + (((is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) ? opt_p_pp_ss_lref : opt_p_pp_ss); + if ((opc->v[0].fp == opt_p_pp_ss_lref) && (is_keyword(arg1))) + use_slot_ref(sc, opc, obj, keyword_symbol(arg1)); /* if keyword, slot is: (L3 :x) -> #<slot: :x :x> */ + return_true(sc, car_x); + }} else /* arg1 not a symbol */ - { - if ((!is_hash_table(obj)) && - (!is_let(obj))) - { - opt_info *o1; - if (is_t_integer(arg1)) - { - opc->v[2].i = integer(arg1); - opc->v[0].fp = opt_p_pi_sc; - return_true(sc, car_x); - } - o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cdr(car_x))) - return_false(sc, car_x); - opc->v[0].fp = opt_p_pi_sf; - opc->v[4].o1 = o1; - opc->v[5].fi = o1->v[0].fi; - return_true(sc, car_x); - } - - if ((!is_pair(arg1)) || - (is_proper_quote(sc, arg1))) - { - opc->v[2].p = (!is_pair(arg1)) ? arg1 : cadr(arg1); - opc->v[0].fp = opt_p_pp_sc; - if ((is_pair(arg1)) && (is_symbol(opc->v[2].p)) && (is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) - use_slot_ref(sc, opc, obj, cadr(arg1)); - return_true(sc, car_x); - } - - if (cell_optimize(sc, cdr(car_x))) - { /* need both type check and func check! (hash-table-ref or 123) */ - opc->v[0].fp = ((is_hash_table(obj)) && (opc->v[3].p_pp_f == s7_hash_table_ref)) ? opt_p_pp_sf_href : - (((is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) ? opt_p_pp_sf_lref : opt_p_pp_sf); - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = sc->opts[start]->v[0].fp; - return_true(sc, car_x); - }}} /* len==2 */ + { + if ((!is_hash_table(obj)) && + (!is_let(obj))) + { + opt_info *o1; + if (is_t_integer(arg1)) + { + opc->v[2].i = integer(arg1); + opc->v[0].fp = opt_p_pi_sc; + return_true(sc, car_x); + } + o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(car_x))) + return_false(sc, car_x); + opc->v[0].fp = opt_p_pi_sf; + opc->v[4].o1 = o1; + opc->v[5].fi = o1->v[0].fi; + return_true(sc, car_x); + } + + if ((!is_pair(arg1)) || + (is_proper_quote(sc, arg1))) + { + opc->v[2].p = (!is_pair(arg1)) ? arg1 : cadr(arg1); + opc->v[0].fp = opt_p_pp_sc; + if ((is_pair(arg1)) && (is_symbol(opc->v[2].p)) && (is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) + use_slot_ref(sc, opc, obj, cadr(arg1)); + return_true(sc, car_x); + } + + if (cell_optimize(sc, cdr(car_x))) + { /* need both type check and func check! (hash-table-ref or 123) */ + opc->v[0].fp = ((is_hash_table(obj)) && (opc->v[3].p_pp_f == s7_hash_table_ref)) ? opt_p_pp_sf_href : + (((is_let(obj)) && (opc->v[3].p_pp_f == let_ref)) ? opt_p_pp_sf_lref : opt_p_pp_sf); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fp = sc->opts[start]->v[0].fp; + return_true(sc, car_x); + }}} /* len==2 */ else { /* len > 2 */ if ((is_t_vector(obj)) && (len == 3) && (vector_rank(obj) == 2)) - { - s7_pointer slot = opt_integer_symbol(sc, caddr(car_x)); - if (slot) - { - opc->v[3].p = slot; - slot = opt_integer_symbol(sc, arg1); - if (slot) - { - opc->v[2].p = slot; - opc->v[4].p_pii_f = vector_ref_p_pii; - opc->v[0].fp = opt_p_pii_sss; - if ((loop_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && - (loop_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) - opc->v[0].fp = vector_ref_pii_sss_unchecked; - return_true(sc, car_x); - }} - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(car_x))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_p_pii_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fi = opc->v[8].o1->v[0].fi; - /* opc->v[1].p set above */ - opc->v[4].p_pii_f = vector_ref_p_pii_direct; - return_true(sc, car_x); - }} - sc->pc = start; - } + { + s7_pointer slot = opt_integer_symbol(sc, caddr(car_x)); + if (slot) + { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, arg1); + if (slot) + { + opc->v[2].p = slot; + opc->v[4].p_pii_f = vector_ref_p_pii; + opc->v[0].fp = opt_p_pii_sss; + if ((loop_end_fits(opc->v[2].p, vector_dimension(obj, 0))) && + (loop_end_fits(opc->v[3].p, vector_dimension(obj, 1)))) + opc->v[0].fp = vector_ref_pii_sss_unchecked; + return_true(sc, car_x); + }} + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(car_x))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(car_x))) + { + opc->v[0].fp = opt_p_pii_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fi = opc->v[8].o1->v[0].fi; + /* opc->v[1].p set above */ + opc->v[4].p_pii_f = vector_ref_p_pii_direct; + return_true(sc, car_x); + }} + sc->pc = start; + } #define P_IMPLICIT_CALL_O1 4 if (len < (NUM_VUNIONS - P_IMPLICIT_CALL_O1)) /* mimic p_call_any_ok */ - { - s7_pointer p = car_x; - opc->v[1].i = len; - for (int32_t pctr = (P_IMPLICIT_CALL_O1 - 1); 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)) - { - /* here we know the vector rank/type, probably can handle the new value type, and maybe indices/dimensions, - * so at least forgo the vec type/rank + immutable checks, the *_set cases are from p_call_any_ok called in cell_optimize, - * but this is called very rarely mainly because hi-rank implicit refs are rare, and check_type_uncertainty is unhappy - * if there are multiple sets of a var. - * hash-tables, lets, lists, and vectors with extra (implicit) args can't be handled because we have no way to tell - * what the implicit call will do, and in the opt_* context, everything must be "safe" (i.e. no defines or - * hidden multiple-values, etc). - */ - if ((!is_any_vector(obj)) || (vector_rank(obj) != (len - 1))) return_false(sc, car_x); /* (* i (P2 1 1)) in timp.scm where P2 is a list */ - opc->v[0].fp = opt_p_call_any; - switch (type(obj)) /* string can't happen here (no multidimensional strings), for pair/hash/let see above */ - { - case T_INT_VECTOR: opc->v[2].call = g_int_vector_ref; break; - case T_BYTE_VECTOR: opc->v[2].call = g_byte_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_false(sc, car_x); - } - return_true(sc, car_x); - }}} + { + s7_pointer p = car_x; + opc->v[1].i = len; + for (int32_t pctr = (P_IMPLICIT_CALL_O1 - 1); 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)) + { + /* here we know the vector rank/type, probably can handle the new value type, and maybe indices/dimensions, + * so at least forgo the vec type/rank + immutable checks, the *_set cases are from p_call_any_ok called in cell_optimize, + * but this is called very rarely mainly because hi-rank implicit refs are rare, and check_type_uncertainty is unhappy + * if there are multiple sets of a var. + * hash-tables, lets, lists, and vectors with extra (implicit) args can't be handled because we have no way to tell + * what the implicit call will do, and in the opt_* context, everything must be "safe" (i.e. no defines or + * hidden multiple-values, etc). + */ + if ((!is_any_vector(obj)) || (vector_rank(obj) != (len - 1))) return_false(sc, car_x); /* (* i (P2 1 1)) in timp.scm where P2 is a list */ + opc->v[0].fp = opt_p_call_any; + switch (type(obj)) /* string can't happen here (no multidimensional strings), for pair/hash/let see above */ + { + case T_INT_VECTOR: opc->v[2].call = g_int_vector_ref; break; + case T_BYTE_VECTOR: opc->v[2].call = g_byte_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_false(sc, car_x); + } + return_true(sc, car_x); + }}} return_false(sc, car_x); } @@ -65351,25 +65351,25 @@ static bool set_p_i_f_combinable(s7_scheme *sc, opt_info *opc) { opt_info *o1 = sc->opts[sc->pc - 1]; if ((o1->v[0].fi == opt_i_ii_ss) || - (o1->v[0].fi == opt_i_ii_ss_add)) - { - opc->v[4].i_ii_f = o1->v[3].i_ii_f; - opc->v[2].p = o1->v[1].p; - opc->v[3].p = o1->v[2].p; - opc->v[0].fp = (o1->v[0].fi == opt_i_ii_ss_add) ? opt_set_p_i_fo_add : opt_set_p_i_fo; - backup_pc(sc); - return_true(sc, NULL); - } + (o1->v[0].fi == opt_i_ii_ss_add)) + { + opc->v[4].i_ii_f = o1->v[3].i_ii_f; + opc->v[2].p = o1->v[1].p; + opc->v[3].p = o1->v[2].p; + opc->v[0].fp = (o1->v[0].fi == opt_i_ii_ss_add) ? opt_set_p_i_fo_add : opt_set_p_i_fo; + backup_pc(sc); + return_true(sc, NULL); + } if ((o1->v[0].fi == opt_i_ii_sc) || (o1->v[0].fi == opt_i_ii_sc_add) || (o1->v[0].fi == opt_i_ii_sc_sub)) - { - opc->v[4].i_ii_f = o1->v[3].i_ii_f; - opc->v[2].p = o1->v[1].p; - opc->v[3].i = o1->v[2].i; - opc->v[0].fp = (o1->v[0].fi == opt_i_ii_sc_add) ? opt_set_p_i_fo1_add : opt_set_p_i_fo1; - /* opt_if_nbp: opt_set_p_i_fo1_add b/shoot */ - backup_pc(sc); - return_true(sc, NULL); - }} + { + opc->v[4].i_ii_f = o1->v[3].i_ii_f; + opc->v[2].p = o1->v[1].p; + opc->v[3].i = o1->v[2].i; + opc->v[0].fp = (o1->v[0].fi == opt_i_ii_sc_add) ? opt_set_p_i_fo1_add : opt_set_p_i_fo1; + /* opt_if_nbp: opt_set_p_i_fo1_add b/shoot */ + backup_pc(sc); + return_true(sc, NULL); + }} return_false(sc, NULL); } @@ -65380,32 +65380,32 @@ static bool set_p_d_f_combinable(s7_scheme *sc, opt_info *opc) { opt_info *o1 = sc->opts[sc->pc - 3]; if ((o1->v[0].fd == opt_d_mm_fff) && - ((o1->v[3].d_dd_f == add_d_dd) || (o1->v[3].d_dd_f == subtract_d_dd))) - { - opt_info *o2 = sc->opts[sc->pc - 2]; - opc->v[0].fp = (o1->v[3].d_dd_f == add_d_dd) ? opt_set_p_d_f_mm_add : opt_set_p_d_f_mm_subtract; - opc->v[3].p = o2->v[1].p; - opc->v[4].p = o2->v[2].p; - opc->v[5].p = o2->v[3].p; - o1 = sc->opts[sc->pc - 1]; - opc->v[9].p = o1->v[1].p; - opc->v[10].p = o1->v[2].p; - opc->v[11].p = o1->v[3].p; - sc->pc -= 3; - return_true(sc, NULL); - }} + ((o1->v[3].d_dd_f == add_d_dd) || (o1->v[3].d_dd_f == subtract_d_dd))) + { + opt_info *o2 = sc->opts[sc->pc - 2]; + opc->v[0].fp = (o1->v[3].d_dd_f == add_d_dd) ? opt_set_p_d_f_mm_add : opt_set_p_d_f_mm_subtract; + opc->v[3].p = o2->v[1].p; + opc->v[4].p = o2->v[2].p; + opc->v[5].p = o2->v[3].p; + o1 = sc->opts[sc->pc - 1]; + opc->v[9].p = o1->v[1].p; + opc->v[10].p = o1->v[2].p; + opc->v[11].p = o1->v[3].p; + sc->pc -= 3; + return_true(sc, NULL); + }} return_false(sc, NULL); } static bool is_some_number(s7_scheme *sc, const s7_pointer tp) { return((tp == sc->is_integer_symbol) || - (tp == sc->is_float_symbol) || - (tp == sc->is_real_symbol) || - (tp == sc->is_complex_symbol) || - (tp == sc->is_number_symbol) || - (tp == sc->is_byte_symbol) || - (tp == sc->is_rational_symbol)); + (tp == sc->is_float_symbol) || + (tp == sc->is_real_symbol) || + (tp == sc->is_complex_symbol) || + (tp == sc->is_number_symbol) || + (tp == sc->is_byte_symbol) || + (tp == sc->is_rational_symbol)); } static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer car_x, opt_info *opc, int32_t start_pc) @@ -65421,35 +65421,35 @@ static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer { s7_int counts; if ((!has_low_count(code)) && /* only set below */ - (s7_tree_memq(sc, car_x, code))) - { - if (is_pair(caar(code))) - { - counts = tree_count(sc, target, car(code), 0) + - tree_count(sc, target, caadr(code), 0) + - tree_count(sc, target, cddr(code), 0); - for (s7_pointer p = car(code); is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((is_proper_list_2(sc, var)) && - (car(var) == target)) - counts--; - }} - else counts = tree_count(sc, target, code, 0); - } + (s7_tree_memq(sc, car_x, code))) + { + if (is_pair(caar(code))) + { + counts = tree_count(sc, target, car(code), 0) + + tree_count(sc, target, caadr(code), 0) + + tree_count(sc, target, cddr(code), 0); + for (s7_pointer p = car(code); is_pair(p); p = cdr(p)) + { + s7_pointer var = car(p); + if ((is_proper_list_2(sc, var)) && + (car(var) == target)) + counts--; + }} + else counts = tree_count(sc, target, code, 0); + } else counts = 2; /* can be from lambda: (lambda (n)...): ((n) (set! sum (+ sum n))) etc */ if (counts <= 2) - { - set_has_low_count(code); - sc->pc = start_pc; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_set_p_p_f; - opc->v[3].o1 = sc->opts[start_pc]; - opc->v[4].fp = sc->opts[start_pc]->v[0].fp; - return_true(sc, car_x); - }}} + { + set_has_low_count(code); + sc->pc = start_pc; + if (cell_optimize(sc, cddr(car_x))) + { + opc->v[0].fp = opt_set_p_p_f; + opc->v[3].o1 = sc->opts[start_pc]; + opc->v[4].fp = sc->opts[start_pc]->v[0].fp; + return_true(sc, car_x); + }}} return_false(sc, car_x); } @@ -65462,111 +65462,111 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy { s7_pointer settee; if ((is_constant_symbol(sc, target)) || - ((is_slot(global_slot(target))) && (slot_has_setter(global_slot(target))))) - return_false(sc, car_x); + ((is_slot(global_slot(target))) && (slot_has_setter(global_slot(target))))) + return_false(sc, car_x); settee = s7_slot(sc, target); if ((is_slot(settee)) && - (!is_immutable_slot(settee)) && - (!is_syntax(slot_value(settee)))) - { - int32_t start_pc = sc->pc; - s7_pointer stype = s7_type_of(sc, slot_value(settee)); - s7_pointer atype; - opc->v[1].p = settee; - if (slot_has_setter(settee)) - { - if ((is_c_function(slot_setter(settee))) && - (is_bool_function(slot_setter(settee))) && - (stype == opt_arg_type(sc, cddr(car_x))) && - (cell_optimize(sc, cddr(car_x)))) - { - opc->v[1].p = settee; - opc->v[0].fp = opt_set_p_p_f_with_setter; - opc->v[3].o1 = sc->opts[start_pc]; - opc->v[4].fp = sc->opts[start_pc]->v[0].fp; - return_true(sc, car_x); - } - return_false(sc, car_x); - } - - if (stype == sc->is_integer_symbol) - { - if (is_symbol(value)) - { - s7_pointer val_slot = opt_integer_symbol(sc, value); - if (val_slot) - { - opc->v[2].p = val_slot; - opc->v[0].fp = opt_set_p_i_s; - return_true(sc, car_x); - }} - else - { - opc->v[5].o1 = sc->opts[sc->pc]; - if (!int_optimize(sc, cddr(car_x))) - return(check_type_uncertainty(sc, target, car_x, opc, start_pc)); - if (!set_p_i_f_combinable(sc, opc)) - { - opc->v[0].fp = opt_set_p_i_f; - opc->v[6].fi = opc->v[5].o1->v[0].fi; - } - return_true(sc, car_x); - } - return_false(sc, car_x); - } - if (stype == sc->is_float_symbol) - { - if (is_t_real(value)) - { - opc->v[2].p = value; - opc->v[0].fp = opt_set_p_c; - return_true(sc, car_x); - } - if (is_symbol(caddr(car_x))) - { - s7_pointer val_slot = opt_float_symbol(sc, value); - if (val_slot) - { - opc->v[2].p = val_slot; - opc->v[0].fp = opt_set_p_d_s; - return_true(sc, car_x); - }} - else - { - if ((is_pair(value)) && - (float_optimize(sc, cddr(car_x)))) - { - if (!set_p_d_f_combinable(sc, opc)) - { - opc->v[4].o1 = sc->opts[start_pc]; - opc->v[5].fd = sc->opts[start_pc]->v[0].fd; - opc->v[0].fp = (opc->v[5].fd == opt_d_dd_sf_add) ? opt_set_p_d_f_sf_add : opt_set_p_d_f; - } - return_true(sc, car_x); - } - return(check_type_uncertainty(sc, target, car_x, opc, start_pc)); - } - return_false(sc, car_x); - } - - atype = opt_arg_type(sc, cddr(car_x)); - if ((is_some_number(sc, atype)) && (!is_some_number(sc, stype))) - return_false(sc, car_x); - if ((stype != atype) && - (is_symbol(stype)) && - (((t_sequence_p[symbol_type(stype)]) && - (stype != sc->is_null_symbol) && (stype != sc->is_pair_symbol) && - (stype != sc->is_list_symbol) && (stype != sc->is_proper_list_symbol)) || - (stype == sc->is_iterator_symbol))) - return_false(sc, car_x); - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_set_p_p_f; - opc->v[3].o1 = sc->opts[start_pc]; - opc->v[4].fp = sc->opts[start_pc]->v[0].fp; - return_true(sc, car_x); - }} + (!is_immutable_slot(settee)) && + (!is_syntax(slot_value(settee)))) + { + int32_t start_pc = sc->pc; + s7_pointer stype = s7_type_of(sc, slot_value(settee)); + s7_pointer atype; + opc->v[1].p = settee; + if (slot_has_setter(settee)) + { + if ((is_c_function(slot_setter(settee))) && + (is_bool_function(slot_setter(settee))) && + (stype == opt_arg_type(sc, cddr(car_x))) && + (cell_optimize(sc, cddr(car_x)))) + { + opc->v[1].p = settee; + opc->v[0].fp = opt_set_p_p_f_with_setter; + opc->v[3].o1 = sc->opts[start_pc]; + opc->v[4].fp = sc->opts[start_pc]->v[0].fp; + return_true(sc, car_x); + } + return_false(sc, car_x); + } + + if (stype == sc->is_integer_symbol) + { + if (is_symbol(value)) + { + s7_pointer val_slot = opt_integer_symbol(sc, value); + if (val_slot) + { + opc->v[2].p = val_slot; + opc->v[0].fp = opt_set_p_i_s; + return_true(sc, car_x); + }} + else + { + opc->v[5].o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cddr(car_x))) + return(check_type_uncertainty(sc, target, car_x, opc, start_pc)); + if (!set_p_i_f_combinable(sc, opc)) + { + opc->v[0].fp = opt_set_p_i_f; + opc->v[6].fi = opc->v[5].o1->v[0].fi; + } + return_true(sc, car_x); + } + return_false(sc, car_x); + } + if (stype == sc->is_float_symbol) + { + if (is_t_real(value)) + { + opc->v[2].p = value; + opc->v[0].fp = opt_set_p_c; + return_true(sc, car_x); + } + if (is_symbol(caddr(car_x))) + { + s7_pointer val_slot = opt_float_symbol(sc, value); + if (val_slot) + { + opc->v[2].p = val_slot; + opc->v[0].fp = opt_set_p_d_s; + return_true(sc, car_x); + }} + else + { + if ((is_pair(value)) && + (float_optimize(sc, cddr(car_x)))) + { + if (!set_p_d_f_combinable(sc, opc)) + { + opc->v[4].o1 = sc->opts[start_pc]; + opc->v[5].fd = sc->opts[start_pc]->v[0].fd; + opc->v[0].fp = (opc->v[5].fd == opt_d_dd_sf_add) ? opt_set_p_d_f_sf_add : opt_set_p_d_f; + } + return_true(sc, car_x); + } + return(check_type_uncertainty(sc, target, car_x, opc, start_pc)); + } + return_false(sc, car_x); + } + + atype = opt_arg_type(sc, cddr(car_x)); + if ((is_some_number(sc, atype)) && (!is_some_number(sc, stype))) + return_false(sc, car_x); + if ((stype != atype) && + (is_symbol(stype)) && + (((t_sequence_p[symbol_type(stype)]) && + (stype != sc->is_null_symbol) && (stype != sc->is_pair_symbol) && + (stype != sc->is_list_symbol) && (stype != sc->is_proper_list_symbol)) || + (stype == sc->is_iterator_symbol))) + return_false(sc, car_x); + if (cell_optimize(sc, cddr(car_x))) + { + opc->v[0].fp = opt_set_p_p_f; + opc->v[3].o1 = sc->opts[start_pc]; + opc->v[4].fp = sc->opts[start_pc]->v[0].fp; + return_true(sc, car_x); + }} return_false(sc, car_x); } if ((is_pair(target)) && @@ -65576,304 +65576,304 @@ static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_sy { s7_pointer obj, index, index_type, s_slot = s7_slot(sc, car(target)); if (!is_slot(s_slot)) - return_false(sc, car_x); + return_false(sc, car_x); obj = slot_value(s_slot); opc->v[1].p = s_slot; if (!is_mutable_sequence(obj)) - return_false(sc, car_x); + return_false(sc, car_x); index = cadr(target); index_type = opt_arg_type(sc, cdr(target)); switch (type(obj)) - { - case T_STRING: - { - s7_pointer val_type; - if ((index_type != sc->is_integer_symbol) || (is_pair(cddr(target)))) return_false(sc, car_x); - val_type = opt_arg_type(sc, cddr(car_x)); - if (val_type != sc->is_char_symbol) - return_false(sc, car_x); - opc->v[3].p_pip_f = string_set_p_pip_unchecked; - } - break; - - case T_VECTOR: - if (index_type != sc->is_integer_symbol) return_false(sc, car_x); - if (is_null(cddr(target))) - { - if (vector_rank(obj) != 1) return_false(sc, car_x); - opc->v[3].p_pip_f = (is_typed_vector(obj)) ? typed_vector_set_p_pip_unchecked : vector_set_p_pip_unchecked; - } - else - { - if (vector_rank(obj) != 2) - return_false(sc, car_x); - opc->v[5].p_piip_f = (is_typed_vector(obj)) ? typed_vector_set_p_piip_direct : vector_set_p_piip_direct; - return(p_piip_to_sx(sc, opc, cdr(target), cddr(target), cddr(car_x), obj)); - } - break; - - case T_FLOAT_VECTOR: - if (opt_float_vector_set(sc, opc, car(target), cdr(target), - (is_null(cddr(target))) ? NULL : cddr(target), - ((!is_pair(cddr(target))) || (is_null(cdddr(target)))) ? NULL : cdddr(target), - cddr(car_x))) - { - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return_true(sc, car_x); - } - return_false(sc, car_x); - - case T_BYTE_VECTOR: - case T_INT_VECTOR: - if (opt_int_vector_set(sc, -1, opc, car(target), cdr(target), (is_null(cddr(target))) ? NULL : cddr(target), cddr(car_x))) - { - opc->v[O_WRAP].fi = opc->v[0].fi; - opc->v[0].fp = i_to_p; - return_true(sc, car_x); - } - return_false(sc, car_x); - - case T_C_OBJECT: - if ((is_null(cddr(target))) && - (is_c_function(c_object_setf(sc, obj)))) - { - /* d_7pid_ok assumes cadr is the target, not car etc */ - s7_d_7pid_t func = s7_d_7pid_function(c_object_setf(sc, obj)); - if (func) - { - s7_pointer slot = opt_integer_symbol(sc, cadr(target)); - opc->v[4].d_7pid_f = func; - opc->v[10].o1 = sc->opts[sc->pc]; - if (slot) - { - if (float_optimize(sc, cddr(car_x))) - { - opc->v[O_WRAP].fd = opt_d_7pid_ssf; - opc->v[0].fp = d_to_p; /* cell_optimize, so need to return s7_pointer */ - opc->v[2].p = slot; - opc->v[11].fd = opc->v[10].o1->v[0].fd; - return_true(sc, car_x); - }} - else - if (int_optimize(sc, cdr(target))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (float_optimize(sc, cddr(car_x))) - { - opc->v[O_WRAP].fd = opt_d_7pid_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fd = opc->v[8].o1->v[0].fd; - opc->v[0].fp = d_to_p; - return_true(sc, car_x); - }}}} - return_false(sc, car_x); - - case T_PAIR: - if (index_type != sc->is_integer_symbol) return_false(sc, car_x); /* (let ((tf13 '(()))) (define (f) (do ((i 0 (+ i 1))) ((= i 1)) (set! (tf13 letrec*) 0))) (f)) */ - if (is_pair(cddr(target))) return_false(sc, car_x); - opc->v[3].p_pip_f = list_set_p_pip_unchecked; - - { /* an experiment -- is this ever hit in normal code? (for tref.scm) */ - if ((is_pair(value)) && (car(value) == sc->add_symbol) && (is_t_integer(caddr(value))) && (is_null(cdddr(value))) && (is_symbol(cadr(target))) && - (car(target) == (caadr(value))) && (is_pair(cdadr(value))) && (is_null(cddadr(value))) && (cadr(target) == cadadr(value))) - { - s7_pointer slot = opt_simple_symbol(sc, index); - if ((slot) && (is_t_integer(slot_value(slot)))) - { - opc->v[2].p = slot; - opc->v[3].p = caddr(value); - opc->v[0].fp = list_increment_p_pip_unchecked; - return_true(sc, car_x); - }}} - break; - - case T_HASH_TABLE: - if (is_pair(cddr(target))) return_false(sc, car_x); - opc->v[3].p_ppp_f = s7_hash_table_set; - break; - - case T_LET: - /* here we know the let is a covered mutable let -- ?? not true if s7-optimize called explicitly */ - if ((is_pair(cddr(target))) || (is_openlet(obj))) - return_false(sc, car_x); - if ((is_symbol_and_keyword(cadr(target))) || - ((is_quoted_symbol(cadr(target))))) - opc->v[3].p_ppp_f = let_set_1; - else opc->v[3].p_ppp_f = let_set_p_ppp_2; /* (set! (L3 'x) (+ (L3 'x) 1)) */ - break; - - default: - return_false(sc, car_x); - } + { + case T_STRING: + { + s7_pointer val_type; + if ((index_type != sc->is_integer_symbol) || (is_pair(cddr(target)))) return_false(sc, car_x); + val_type = opt_arg_type(sc, cddr(car_x)); + if (val_type != sc->is_char_symbol) + return_false(sc, car_x); + opc->v[3].p_pip_f = string_set_p_pip_unchecked; + } + break; + + case T_VECTOR: + if (index_type != sc->is_integer_symbol) return_false(sc, car_x); + if (is_null(cddr(target))) + { + if (vector_rank(obj) != 1) return_false(sc, car_x); + opc->v[3].p_pip_f = (is_typed_vector(obj)) ? typed_vector_set_p_pip_unchecked : vector_set_p_pip_unchecked; + } + else + { + if (vector_rank(obj) != 2) + return_false(sc, car_x); + opc->v[5].p_piip_f = (is_typed_vector(obj)) ? typed_vector_set_p_piip_direct : vector_set_p_piip_direct; + return(p_piip_to_sx(sc, opc, cdr(target), cddr(target), cddr(car_x), obj)); + } + break; + + case T_FLOAT_VECTOR: + if (opt_float_vector_set(sc, opc, car(target), cdr(target), + (is_null(cddr(target))) ? NULL : cddr(target), + ((!is_pair(cddr(target))) || (is_null(cdddr(target)))) ? NULL : cdddr(target), + cddr(car_x))) + { + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; + return_true(sc, car_x); + } + return_false(sc, car_x); + + case T_BYTE_VECTOR: + case T_INT_VECTOR: + if (opt_int_vector_set(sc, -1, opc, car(target), cdr(target), (is_null(cddr(target))) ? NULL : cddr(target), cddr(car_x))) + { + opc->v[O_WRAP].fi = opc->v[0].fi; + opc->v[0].fp = i_to_p; + return_true(sc, car_x); + } + return_false(sc, car_x); + + case T_C_OBJECT: + if ((is_null(cddr(target))) && + (is_c_function(c_object_setf(sc, obj)))) + { + /* d_7pid_ok assumes cadr is the target, not car etc */ + s7_d_7pid_t func = s7_d_7pid_function(c_object_setf(sc, obj)); + if (func) + { + s7_pointer slot = opt_integer_symbol(sc, cadr(target)); + opc->v[4].d_7pid_f = func; + opc->v[10].o1 = sc->opts[sc->pc]; + if (slot) + { + if (float_optimize(sc, cddr(car_x))) + { + opc->v[O_WRAP].fd = opt_d_7pid_ssf; + opc->v[0].fp = d_to_p; /* cell_optimize, so need to return s7_pointer */ + opc->v[2].p = slot; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + return_true(sc, car_x); + }} + else + if (int_optimize(sc, cdr(target))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(car_x))) + { + opc->v[O_WRAP].fd = opt_d_7pid_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fd = opc->v[8].o1->v[0].fd; + opc->v[0].fp = d_to_p; + return_true(sc, car_x); + }}}} + return_false(sc, car_x); + + case T_PAIR: + if (index_type != sc->is_integer_symbol) return_false(sc, car_x); /* (let ((tf13 '(()))) (define (f) (do ((i 0 (+ i 1))) ((= i 1)) (set! (tf13 letrec*) 0))) (f)) */ + if (is_pair(cddr(target))) return_false(sc, car_x); + opc->v[3].p_pip_f = list_set_p_pip_unchecked; + + { /* an experiment -- is this ever hit in normal code? (for tref.scm) */ + if ((is_pair(value)) && (car(value) == sc->add_symbol) && (is_t_integer(caddr(value))) && (is_null(cdddr(value))) && (is_symbol(cadr(target))) && + (car(target) == (caadr(value))) && (is_pair(cdadr(value))) && (is_null(cddadr(value))) && (cadr(target) == cadadr(value))) + { + s7_pointer slot = opt_simple_symbol(sc, index); + if ((slot) && (is_t_integer(slot_value(slot)))) + { + opc->v[2].p = slot; + opc->v[3].p = caddr(value); + opc->v[0].fp = list_increment_p_pip_unchecked; + return_true(sc, car_x); + }}} + break; + + case T_HASH_TABLE: + if (is_pair(cddr(target))) return_false(sc, car_x); + opc->v[3].p_ppp_f = s7_hash_table_set; + break; + + case T_LET: + /* here we know the let is a covered mutable let -- ?? not true if s7-optimize called explicitly */ + if ((is_pair(cddr(target))) || (is_openlet(obj))) + return_false(sc, car_x); + if ((is_symbol_and_keyword(cadr(target))) || + ((is_quoted_symbol(cadr(target))))) + opc->v[3].p_ppp_f = let_set_1; + else opc->v[3].p_ppp_f = let_set_p_ppp_2; /* (set! (L3 'x) (+ (L3 'x) 1)) */ + break; + + default: + return_false(sc, car_x); + } if (is_symbol(index)) - { - int32_t start = sc->pc; - s7_pointer slot = opt_simple_symbol(sc, index); - if (slot) - { - opc->v[2].p = slot; - if ((is_t_integer(slot_value(slot))) && - (has_loop_end(opc->v[2].p))) - { - if (is_string(obj)) - { - if (loop_end(opc->v[2].p) <= string_length(obj)) - opc->v[3].p_pip_f = string_set_p_pip_direct; - } - else - if (is_byte_vector(obj)) - { - if (loop_end(opc->v[2].p) <= byte_vector_length(obj)) - opc->v[3].p_pip_f = byte_vector_set_p_pip_direct; - } - else - if (is_any_vector(obj)) /* true for all 3 vectors */ - { - if ((is_any_vector(obj)) && - (loop_end(opc->v[2].p) <= vector_length(obj))) - { - if (is_typed_t_vector(obj)) - opc->v[3].p_pip_f = typed_t_vector_set_p_pip_direct; - else opc->v[3].p_pip_f = t_vector_set_p_pip_direct; - }}} - if (is_symbol(value)) - { - s7_pointer val_slot = opt_simple_symbol(sc, value); - if (val_slot) - { - s7_p_ppp_t func1; - if ((is_string(obj)) || - (is_any_vector(obj)) || - (is_pair(obj))) - { - opc->v[4].p_pip_f = opc->v[3].p_pip_f; - opc->v[3].p = val_slot; - opc->v[0].fp = opt_p_pip_sss; - return_true(sc, car_x); - } - if ((is_let(obj)) && (is_keyword(index)) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 :x) i) */ - (use_pps_slot_set(sc, opc, obj, keyword_symbol(index), val_slot))) - return_true(sc, car_x); - func1 = opc->v[3].p_ppp_f; - opc->v[4].p_ppp_f = func1; - opc->v[3].p = val_slot; - opc->v[0].fp = (func1 == multiply_p_ppp) ? opt_p_ppp_sss_mul : - (((is_hash_table(obj)) && (func1 == s7_hash_table_set)) ? opt_p_ppp_sss_hset : opt_p_ppp_sss); - return_true(sc, car_x); - }} - else - if ((!is_pair(value)) || - (is_proper_quote(sc, value))) - { - if (!is_pair(value)) - opc->v[4].p = value; - else opc->v[4].p = cadr(value); - if ((is_string(obj)) || - (is_any_vector(obj)) || - (is_pair(obj))) - { - opc->v[0].fp = opt_p_pip_ssc; - return_true(sc, car_x); - } - if ((is_let(obj)) && (is_keyword(index)) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 :x) 0) */ - (use_ppc_slot_set(sc, opc, obj, keyword_symbol(index), opc->v[4].p))) - return_true(sc, car_x); - opc->v[0].fp = opt_p_ppp_ssc; - return_true(sc, car_x); - } - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[4].o1 = sc->opts[start]; - opc->v[5].fp = sc->opts[start]->v[0].fp; - if ((is_string(obj)) || - (is_any_vector(obj)) || - (is_pair(obj))) - { - if (p_pip_ssf_combinable(sc, opc, start)) - return_true(sc, car_x); - opc->v[0].fp = opt_p_pip_ssf; - return_true(sc, car_x); - } - if ((is_let(obj)) && (is_keyword(index)) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 :x) (+ (L3 'x) 1)) */ - (use_ppf_slot_set(sc, opc, obj, keyword_symbol(index)))) - return_true(sc, car_x); - - opc->v[0].fp = opt_p_ppp_ssf; - return_true(sc, car_x); - }}} + { + int32_t start = sc->pc; + s7_pointer slot = opt_simple_symbol(sc, index); + if (slot) + { + opc->v[2].p = slot; + if ((is_t_integer(slot_value(slot))) && + (has_loop_end(opc->v[2].p))) + { + if (is_string(obj)) + { + if (loop_end(opc->v[2].p) <= string_length(obj)) + opc->v[3].p_pip_f = string_set_p_pip_direct; + } + else + if (is_byte_vector(obj)) + { + if (loop_end(opc->v[2].p) <= byte_vector_length(obj)) + opc->v[3].p_pip_f = byte_vector_set_p_pip_direct; + } + else + if (is_any_vector(obj)) /* true for all 3 vectors */ + { + if ((is_any_vector(obj)) && + (loop_end(opc->v[2].p) <= vector_length(obj))) + { + if (is_typed_t_vector(obj)) + opc->v[3].p_pip_f = typed_t_vector_set_p_pip_direct; + else opc->v[3].p_pip_f = t_vector_set_p_pip_direct; + }}} + if (is_symbol(value)) + { + s7_pointer val_slot = opt_simple_symbol(sc, value); + if (val_slot) + { + s7_p_ppp_t func1; + if ((is_string(obj)) || + (is_any_vector(obj)) || + (is_pair(obj))) + { + opc->v[4].p_pip_f = opc->v[3].p_pip_f; + opc->v[3].p = val_slot; + opc->v[0].fp = opt_p_pip_sss; + return_true(sc, car_x); + } + if ((is_let(obj)) && (is_keyword(index)) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 :x) i) */ + (use_pps_slot_set(sc, opc, obj, keyword_symbol(index), val_slot))) + return_true(sc, car_x); + func1 = opc->v[3].p_ppp_f; + opc->v[4].p_ppp_f = func1; + opc->v[3].p = val_slot; + opc->v[0].fp = (func1 == multiply_p_ppp) ? opt_p_ppp_sss_mul : + (((is_hash_table(obj)) && (func1 == s7_hash_table_set)) ? opt_p_ppp_sss_hset : opt_p_ppp_sss); + return_true(sc, car_x); + }} + else + if ((!is_pair(value)) || + (is_proper_quote(sc, value))) + { + if (!is_pair(value)) + opc->v[4].p = value; + else opc->v[4].p = cadr(value); + if ((is_string(obj)) || + (is_any_vector(obj)) || + (is_pair(obj))) + { + opc->v[0].fp = opt_p_pip_ssc; + return_true(sc, car_x); + } + if ((is_let(obj)) && (is_keyword(index)) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 :x) 0) */ + (use_ppc_slot_set(sc, opc, obj, keyword_symbol(index), opc->v[4].p))) + return_true(sc, car_x); + opc->v[0].fp = opt_p_ppp_ssc; + return_true(sc, car_x); + } + if (cell_optimize(sc, cddr(car_x))) + { + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fp = sc->opts[start]->v[0].fp; + if ((is_string(obj)) || + (is_any_vector(obj)) || + (is_pair(obj))) + { + if (p_pip_ssf_combinable(sc, opc, start)) + return_true(sc, car_x); + opc->v[0].fp = opt_p_pip_ssf; + return_true(sc, car_x); + } + if ((is_let(obj)) && (is_keyword(index)) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 :x) (+ (L3 'x) 1)) */ + (use_ppf_slot_set(sc, opc, obj, keyword_symbol(index)))) + return_true(sc, car_x); + + opc->v[0].fp = opt_p_ppp_ssf; + return_true(sc, car_x); + }}} else /* index not a symbol */ - { - opt_info *o1; - if ((is_string(obj)) || - (is_pair(obj)) || - (is_any_vector(obj))) - { - opc->v[10].o1 = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(target))) - { - opc->v[8].o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_p_pip_sff; - opc->v[11].fi = opc->v[10].o1->v[0].fi; - opc->v[9].fp = opc->v[8].o1->v[0].fp; - return_true(sc, car_x); - }} - return_false(sc, car_x); - } - if (is_quoted_symbol(cadr(target))) - { - if (is_symbol(value)) - { - s7_pointer val_slot = opt_simple_symbol(sc, value); - if (val_slot) - { - opc->v[2].p = cadadr(target); - opc->v[4].p = val_slot; - opc->v[0].fp = opt_p_ppp_scs; - if ((is_let(obj)) && (opc->v[3].p_ppp_f == let_set_1)) - use_pps_slot_set(sc, opc, obj, cadadr(target), val_slot); - return_true(sc, car_x); - }} - if ((!is_pair(value)) && (is_let(obj)) && (opc->v[3].p_ppp_f == let_set_1) && - (use_ppc_slot_set(sc, opc, obj, cadadr(target), value))) - return_true(sc, car_x); - } - o1 = sc->opts[sc->pc]; - if (cell_optimize(sc, cdr(target))) - { - opt_info *o2; - if (is_symbol(value)) - { - s7_pointer val_slot = opt_simple_symbol(sc, value); - if (val_slot) - { - opc->v[2].p = val_slot; - opc->v[0].fp = opt_p_ppp_sfs; - opc->v[4].o1 = o1; - opc->v[5].fp = o1->v[0].fp; - return_true(sc, car_x); - }} - o2 = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[0].fp = opt_p_ppp_sff; - if ((is_let(obj)) && (is_quoted_symbol(cadr(target))) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 'x) (+ (L3 'x) 1)) */ - (use_ppf_slot_set(sc, opc, obj, cadadr(target)))) - { - opc->v[4].o1 = o2; - opc->v[5].fp = opc->v[4].o1->v[0].fp; - return_true(sc, car_x); - } - opc->v[10].o1 = o1; - opc->v[11].fp = o1->v[0].fp; - opc->v[8].o1 = o2; - opc->v[9].fp = o2->v[0].fp; - return_true(sc, car_x); - }}}} + { + opt_info *o1; + if ((is_string(obj)) || + (is_pair(obj)) || + (is_any_vector(obj))) + { + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(target))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) + { + opc->v[0].fp = opt_p_pip_sff; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[9].fp = opc->v[8].o1->v[0].fp; + return_true(sc, car_x); + }} + return_false(sc, car_x); + } + if (is_quoted_symbol(cadr(target))) + { + if (is_symbol(value)) + { + s7_pointer val_slot = opt_simple_symbol(sc, value); + if (val_slot) + { + opc->v[2].p = cadadr(target); + opc->v[4].p = val_slot; + opc->v[0].fp = opt_p_ppp_scs; + if ((is_let(obj)) && (opc->v[3].p_ppp_f == let_set_1)) + use_pps_slot_set(sc, opc, obj, cadadr(target), val_slot); + return_true(sc, car_x); + }} + if ((!is_pair(value)) && (is_let(obj)) && (opc->v[3].p_ppp_f == let_set_1) && + (use_ppc_slot_set(sc, opc, obj, cadadr(target), value))) + return_true(sc, car_x); + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(target))) + { + opt_info *o2; + if (is_symbol(value)) + { + s7_pointer val_slot = opt_simple_symbol(sc, value); + if (val_slot) + { + opc->v[2].p = val_slot; + opc->v[0].fp = opt_p_ppp_sfs; + opc->v[4].o1 = o1; + opc->v[5].fp = o1->v[0].fp; + return_true(sc, car_x); + }} + o2 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) + { + opc->v[0].fp = opt_p_ppp_sff; + if ((is_let(obj)) && (is_quoted_symbol(cadr(target))) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 'x) (+ (L3 'x) 1)) */ + (use_ppf_slot_set(sc, opc, obj, cadadr(target)))) + { + opc->v[4].o1 = o2; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + return_true(sc, car_x); + } + opc->v[10].o1 = o1; + opc->v[11].fp = o1->v[0].fp; + opc->v[8].o1 = o2; + opc->v[9].fp = o2->v[0].fp; + return_true(sc, car_x); + }}}} return_false(sc, car_x); } @@ -65904,17 +65904,17 @@ static void oo_idp_nr_fixup(opt_info *start) { start->v[0].fp = d_to_p_nr; if (start->v[O_WRAP].fd == opt_d_7pid_ssf) - start->v[0].fp = opt_d_7pid_ssf_nr; + start->v[0].fp = opt_d_7pid_ssf_nr; else - if (start->v[O_WRAP].fd == opt_d_7pid_ssfo_fv) - { - start->v[0].fp = opt_d_7pid_ssfo_fv_nr; - if (start->v[6].d_dd_f == add_d_dd) - start->v[0].fp = opt_d_7pid_ssfo_fv_add_nr; - else - if (start->v[6].d_dd_f == subtract_d_dd) - start->v[0].fp = opt_d_7pid_ssfo_fv_sub_nr; - }} + if (start->v[O_WRAP].fd == opt_d_7pid_ssfo_fv) + { + start->v[0].fp = opt_d_7pid_ssfo_fv_nr; + if (start->v[6].d_dd_f == add_d_dd) + start->v[0].fp = opt_d_7pid_ssfo_fv_add_nr; + else + if (start->v[6].d_dd_f == subtract_d_dd) + start->v[0].fp = opt_d_7pid_ssfo_fv_sub_nr; + }} else if (start->v[0].fp == i_to_p) start->v[0].fp = i_to_p_nr; @@ -65932,9 +65932,9 @@ static bool opt_cell_begin(s7_scheme *sc, s7_pointer car_x, int32_t len) { opt_info *start = sc->opts[sc->pc]; if (!cell_optimize(sc, p)) - return_false(sc, car_x); + return_false(sc, car_x); if (is_pair(cdr(p))) - oo_idp_nr_fixup(start); + oo_idp_nr_fixup(start); opc->v[i].o1 = start; } opc->v[1].i = len - 2; @@ -65967,10 +65967,10 @@ static s7_pointer opt_when_p(opt_info *o) s7_int i, len = o->v[1].i - 1; opt_info *o1; for (i = 0; i < len; i++) - { - o1 = o->v[i + 5].o1; - o1->v[0].fp(o1); - } + { + o1 = o->v[i + 5].o1; + o1->v[0].fp(o1); + } o1 = o->v[i + 5].o1; return(o1->v[0].fp(o1)); } @@ -66026,9 +66026,9 @@ static bool opt_cell_when(s7_scheme *sc, s7_pointer car_x, int32_t len) { opt_info *start = sc->opts[sc->pc]; if (!cell_optimize(sc, p)) - return_false(sc, car_x); + return_false(sc, car_x); if (is_pair(cdr(p))) - oo_idp_nr_fixup(start); + oo_idp_nr_fixup(start); opc->v[k].o1 = start; } opc->v[4].fb = opc->v[3].o1->v[0].fb; @@ -66036,16 +66036,16 @@ static bool opt_cell_when(s7_scheme *sc, s7_pointer car_x, int32_t len) if (car(car_x) == sc->when_symbol) { if (len == 3) - opc->v[0].fp = opt_when_p_1; + opc->v[0].fp = opt_when_p_1; else - 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; + 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 = (len == 3) ? opt_unless_p_1 : opt_unless_p; return_true(sc, car_x); @@ -66077,10 +66077,10 @@ static s7_pointer opt_cond(opt_info *top) opt_info *o1 = top->v[clause + COND_O1].o1; opt_info *o2 = o1->v[4].o1; if (o2->v[0].fb(o2)) - { - s7_pointer res = cond_value(o1); - return(res); - }} + { + s7_pointer res = cond_value(o1); + return(res); + }} return(top->sc->unspecified); } @@ -66107,28 +66107,28 @@ static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x) s7_pointer clause = car(p), cp; int32_t blen; if ((branches >= (NUM_VUNIONS - COND_O1)) || - (!is_pair(clause)) || - (!is_pair(cdr(clause))) || /* leave the test->result case for later */ - (cadr(clause) == sc->feed_to_symbol)) - return_false(sc, clause); + (!is_pair(clause)) || + (!is_pair(cdr(clause))) || /* leave the test->result case for later */ + (cadr(clause) == sc->feed_to_symbol)) + return_false(sc, clause); last_clause = clause; top->v[branches + COND_O1].o1 = sc->opts[sc->pc]; opc = alloc_opt_info(sc); opc->v[4].o1 = sc->opts[sc->pc]; if (!bool_optimize(sc, clause)) - return_false(sc, clause); + return_false(sc, clause); for (blen = 0, cp = cdr(clause); is_pair(cp); blen++, cp = cdr(cp)) - { - if (blen >= NUM_VUNIONS - COND_CLAUSE_O1) - return_false(sc, cp); - opc->v[blen + COND_CLAUSE_O1].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cp)) - return_false(sc, cp); - } + { + if (blen >= NUM_VUNIONS - COND_CLAUSE_O1) + return_false(sc, cp); + opc->v[blen + COND_CLAUSE_O1].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cp)) + return_false(sc, cp); + } if (!is_null(cp)) - return_false(sc, cp); + return_false(sc, cp); opc->v[1].i = blen; if (max_blen < blen) max_blen = blen; opc->v[0].fp = opt_cond; /* a placeholder */ @@ -66145,18 +66145,18 @@ static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x) if (branches == 2) { if ((max_blen == 1) && - ((car(last_clause) == sc->else_symbol) || (car(last_clause) == sc->T))) - { - opt_info *o1; - top->v[6].o1 = top->v[COND_O1].o1->v[COND_CLAUSE_O1].o1; - top->v[7].o1 = top->v[COND_O1 + 1].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_true(sc, car_x); - }} + ((car(last_clause) == sc->else_symbol) || (car(last_clause) == sc->T))) + { + opt_info *o1; + top->v[6].o1 = top->v[COND_O1].o1->v[COND_CLAUSE_O1].o1; + top->v[7].o1 = top->v[COND_O1 + 1].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_true(sc, car_x); + }} top->v[2].i = branches; top->v[0].fp = opt_cond; return_true(sc, car_x); @@ -66173,7 +66173,7 @@ static s7_pointer opt_and_any_p(opt_info *o) opt_info *o1 = o->v[i + 3].o1; val = o1->v[0].fp(o1); if (val == o->sc->F) - return(o->sc->F); + return(o->sc->F); } return(val); } @@ -66191,7 +66191,7 @@ static s7_pointer opt_or_any_p(opt_info *o) opt_info *o1 = o->v[i + 3].o1; s7_pointer val = o1->v[0].fp(o1); if (val != o->sc->F) - return(val); + return(val); } return(o->sc->F); } @@ -66204,11 +66204,11 @@ static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len) opc->v[0].fp = ((car(car_x) == sc->or_symbol) ? opt_or_pp : opt_and_pp); opc->v[10].o1 = sc->opts[sc->pc]; if (!cell_optimize(sc, cdr(car_x))) - return_false(sc, car_x); + return_false(sc, car_x); opc->v[11].fp = opc->v[10].o1->v[0].fp; opc->v[8].o1 = sc->opts[sc->pc]; if (!cell_optimize(sc, cddr(car_x))) - return_false(sc, car_x); + return_false(sc, car_x); opc->v[9].fp = opc->v[8].o1->v[0].fp; return_true(sc, car_x); } @@ -66218,11 +66218,11 @@ static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len) opc->v[1].i = (len - 1); opc->v[0].fp = ((car(car_x) == sc->or_symbol) ? opt_or_any_p : opt_and_any_p); for (int32_t i = 3; is_pair(p); i++, p = cdr(p)) - { - opc->v[i].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - return_false(sc, car_x); - } + { + opc->v[i].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, car_x); + } return_true(sc, car_x); } return_false(sc, car_x); @@ -66294,130 +66294,130 @@ static bool opt_cell_if(s7_scheme *sc, s7_pointer car_x, int32_t len) if (len == 3) { if ((is_proper_list_2(sc, cadr(car_x))) && /* (not arg) */ - (caadr(car_x) == sc->not_symbol)) - { - if (bool_optimize(sc, cdadr(car_x))) - { - opt_info *top = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[10].o1 = top; - opc->v[11].fp = top->v[0].fp; - if (bop->v[0].fb == opt_b_p_s) - { - opc->v[2].b_p_f = bop->v[2].b_p_f; - opc->v[3].p = bop->v[1].p; - opc->v[0].fp = opt_if_nbp_s; - return_true(sc, car_x); - } - if ((bop->v[0].fb == opt_b_pi_fs) || (bop->v[0].fb == opt_b_pi_fs_num_eq)) - { - opc->v[2].b_pi_f = bop->v[2].b_pi_f; - opc->v[3].p = bop->v[1].p; - opc->v[4].o1 = bop->v[10].o1; - opc->v[5].fp = bop->v[11].fp; - opc->v[0].fp = opt_if_nbp_fs; - return_true(sc, car_x); - } - if ((bop->v[0].fb == opt_b_pp_sf) || - (bop->v[0].fb == opt_b_7pp_sf)) - { - opc->v[4].o1 = bop->v[10].o1; - opc->v[5].fp = bop->v[11].fp; - if (bop->v[0].fb == opt_b_pp_sf) - { - opc->v[2].b_pp_f = bop->v[3].b_pp_f; - opc->v[0].fp = opt_if_nbp_sf; - } - else - { - opc->v[2].b_7pp_f = bop->v[3].b_7pp_f; - opc->v[0].fp = opt_if_nbp_7sf; - } - opc->v[3].p = bop->v[1].p; - return_true(sc, car_x); - } - if ((bop->v[0].fb == opt_b_pp_sc) || - (bop->v[0].fb == opt_b_7pp_sc)) - { - if (bop->v[0].fb == opt_b_pp_sc) - { - opc->v[3].b_pp_f = bop->v[3].b_pp_f; - opc->v[0].fp = opt_if_nbp_sc; - } - else - { - opc->v[3].b_7pp_f = bop->v[3].b_7pp_f; - opc->v[0].fp = opt_if_nbp_7sc; - } - opc->v[2].p = bop->v[1].p; - opc->v[4].p = bop->v[2].p; - return_true(sc, car_x); - } - if ((bop->v[0].fb == opt_b_ii_ss) || (bop->v[0].fb == opt_b_ii_ss_eq) || - (bop->v[0].fb == opt_b_ii_ss_lt) || (bop->v[0].fb == opt_b_ii_ss_gt) || - (bop->v[0].fb == opt_b_ii_ss_leq) || (bop->v[0].fb == opt_b_ii_ss_geq)) - { - opc->v[3].b_ii_f = bop->v[3].b_ii_f; - opc->v[2].p = bop->v[1].p; - opc->v[4].p = bop->v[2].p; - opc->v[0].fp = (opc->v[3].b_ii_f == num_eq_b_ii) ? opt_if_num_eq_ii_ss : opt_if_nbp_ss; - return_true(sc, car_x); - } - opc->v[4].o1 = bop; - opc->v[5].fb = bop->v[0].fb; - opc->v[0].fp = opt_if_nbp; - return_true(sc, car_x); - }}} + (caadr(car_x) == sc->not_symbol)) + { + if (bool_optimize(sc, cdadr(car_x))) + { + opt_info *top = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) + { + opc->v[10].o1 = top; + opc->v[11].fp = top->v[0].fp; + if (bop->v[0].fb == opt_b_p_s) + { + opc->v[2].b_p_f = bop->v[2].b_p_f; + opc->v[3].p = bop->v[1].p; + opc->v[0].fp = opt_if_nbp_s; + return_true(sc, car_x); + } + if ((bop->v[0].fb == opt_b_pi_fs) || (bop->v[0].fb == opt_b_pi_fs_num_eq)) + { + opc->v[2].b_pi_f = bop->v[2].b_pi_f; + opc->v[3].p = bop->v[1].p; + opc->v[4].o1 = bop->v[10].o1; + opc->v[5].fp = bop->v[11].fp; + opc->v[0].fp = opt_if_nbp_fs; + return_true(sc, car_x); + } + if ((bop->v[0].fb == opt_b_pp_sf) || + (bop->v[0].fb == opt_b_7pp_sf)) + { + opc->v[4].o1 = bop->v[10].o1; + opc->v[5].fp = bop->v[11].fp; + if (bop->v[0].fb == opt_b_pp_sf) + { + opc->v[2].b_pp_f = bop->v[3].b_pp_f; + opc->v[0].fp = opt_if_nbp_sf; + } + else + { + opc->v[2].b_7pp_f = bop->v[3].b_7pp_f; + opc->v[0].fp = opt_if_nbp_7sf; + } + opc->v[3].p = bop->v[1].p; + return_true(sc, car_x); + } + if ((bop->v[0].fb == opt_b_pp_sc) || + (bop->v[0].fb == opt_b_7pp_sc)) + { + if (bop->v[0].fb == opt_b_pp_sc) + { + opc->v[3].b_pp_f = bop->v[3].b_pp_f; + opc->v[0].fp = opt_if_nbp_sc; + } + else + { + opc->v[3].b_7pp_f = bop->v[3].b_7pp_f; + opc->v[0].fp = opt_if_nbp_7sc; + } + opc->v[2].p = bop->v[1].p; + opc->v[4].p = bop->v[2].p; + return_true(sc, car_x); + } + if ((bop->v[0].fb == opt_b_ii_ss) || (bop->v[0].fb == opt_b_ii_ss_eq) || + (bop->v[0].fb == opt_b_ii_ss_lt) || (bop->v[0].fb == opt_b_ii_ss_gt) || + (bop->v[0].fb == opt_b_ii_ss_leq) || (bop->v[0].fb == opt_b_ii_ss_geq)) + { + opc->v[3].b_ii_f = bop->v[3].b_ii_f; + opc->v[2].p = bop->v[1].p; + opc->v[4].p = bop->v[2].p; + opc->v[0].fp = (opc->v[3].b_ii_f == num_eq_b_ii) ? opt_if_num_eq_ii_ss : opt_if_nbp_ss; + return_true(sc, car_x); + } + opc->v[4].o1 = bop; + opc->v[5].fb = bop->v[0].fb; + opc->v[0].fp = opt_if_nbp; + return_true(sc, car_x); + }}} else - if (bool_optimize(sc, cdr(car_x))) - { - opt_info *top = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opc->v[2].o1 = bop; - opc->v[4].o1 = top; - opc->v[5].fp = top->v[0].fp; - if (bop->v[0].fb == p_to_b) - { - opc->v[0].fp = opt_if_bp_pb; - opc->v[3].fp = bop->v[O_WRAP].fp; - return_true(sc, car_x); - } - if (bop->v[0].fb == opt_b_ii_fc) - { - opc->v[2].i = bop->v[2].i; - opc->v[3].b_ii_f = bop->v[3].b_ii_f; - opc->v[11].fi = bop->v[11].fi; - opc->v[10].o1 = bop->v[10].o1; - opc->v[0].fp = opt_if_bp_ii_fc; - return_true(sc, car_x); - } - opc->v[0].fp = (bop->v[0].fb == opt_b_7p_f) ? opt_if_b7p : ((bop->v[0].fb == opt_and_bb) ? opt_if_bp_and : opt_if_bp); - opc->v[3].fb = bop->v[0].fb; - return_true(sc, car_x); - }} + if (bool_optimize(sc, cdr(car_x))) + { + opt_info *top = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) + { + opc->v[2].o1 = bop; + opc->v[4].o1 = top; + opc->v[5].fp = top->v[0].fp; + if (bop->v[0].fb == p_to_b) + { + opc->v[0].fp = opt_if_bp_pb; + opc->v[3].fp = bop->v[O_WRAP].fp; + return_true(sc, car_x); + } + if (bop->v[0].fb == opt_b_ii_fc) + { + opc->v[2].i = bop->v[2].i; + opc->v[3].b_ii_f = bop->v[3].b_ii_f; + opc->v[11].fi = bop->v[11].fi; + opc->v[10].o1 = bop->v[10].o1; + opc->v[0].fp = opt_if_bp_ii_fc; + return_true(sc, car_x); + } + opc->v[0].fp = (bop->v[0].fb == opt_b_7p_f) ? opt_if_b7p : ((bop->v[0].fb == opt_and_bb) ? opt_if_bp_and : opt_if_bp); + opc->v[3].fb = bop->v[0].fb; + return_true(sc, car_x); + }} return_false(sc, car_x); } if (len == 4) { if (bool_optimize(sc, cdr(car_x))) - { - opt_info *top = sc->opts[sc->pc]; - if (cell_optimize(sc, cddr(car_x))) - { - opt_info *o3 = sc->opts[sc->pc]; - opc->v[0].fp = (bop->v[0].fb == opt_b_7ii_sc_bit) ? opt_if_bpp_bit : opt_if_bpp; - if (cell_optimize(sc, cdddr(car_x))) - { - opc->v[4].o1 = bop; - opc->v[5].fb = bop->v[0].fb; - opc->v[8].o1 = top; - opc->v[9].fp = top->v[0].fp; - opc->v[10].o1 = o3; - opc->v[11].fp = o3->v[0].fp; - return_true(sc, car_x); - }}}} + { + opt_info *top = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(car_x))) + { + opt_info *o3 = sc->opts[sc->pc]; + opc->v[0].fp = (bop->v[0].fb == opt_b_7ii_sc_bit) ? opt_if_bpp_bit : opt_if_bpp; + if (cell_optimize(sc, cdddr(car_x))) + { + opc->v[4].o1 = bop; + opc->v[5].fb = bop->v[0].fb; + opc->v[8].o1 = top; + opc->v[9].fp = top->v[0].fp; + opc->v[10].o1 = o3; + opc->v[11].fp = o3->v[0].fp; + return_true(sc, car_x); + }}}} return_false(sc, car_x); } @@ -66450,25 +66450,25 @@ static s7_pointer opt_case(opt_info *o) if (is_simple(selector)) { for (int32_t ctr = CASE_O1; ctr < lim; ctr++) - { - s7_pointer z; - o1 = o->v[ctr].o1; - for (z = o1->v[CASE_CLAUSE_KEYS].p; is_pair(z); z = cdr(z)) - if (selector == car(z)) - return(case_value(o1)); - if (z == sc->else_symbol) - return(case_value(o1)); - }} + { + s7_pointer z; + o1 = o->v[ctr].o1; + for (z = o1->v[CASE_CLAUSE_KEYS].p; is_pair(z); z = cdr(z)) + if (selector == car(z)) + return(case_value(o1)); + if (z == sc->else_symbol) + return(case_value(o1)); + }} else for (int32_t ctr = CASE_O1; ctr < lim; ctr++) { - s7_pointer z; - o1 = o->v[ctr].o1; - for (z = o1->v[CASE_CLAUSE_KEYS].p; is_pair(z); z = cdr(z)) - if (s7_is_eqv(sc, selector, car(z))) - return(case_value(o1)); - if (z == sc->else_symbol) - return(case_value(o1)); + s7_pointer z; + o1 = o->v[ctr].o1; + for (z = o1->v[CASE_CLAUSE_KEYS].p; is_pair(z); z = cdr(z)) + if (s7_is_eqv(sc, selector, car(z))) + return(case_value(o1)); + if (z == sc->else_symbol) + return(case_value(o1)); } return(sc->unspecified); } @@ -66488,34 +66488,34 @@ static bool opt_cell_case(s7_scheme *sc, s7_pointer car_x) s7_pointer clause = car(p), cp; int32_t blen; if ((!is_pair(clause)) || - ((!is_pair(car(clause))) && (car(clause) != sc->else_symbol)) || - (!is_pair(cdr(clause))) || - (cadr(clause) == sc->feed_to_symbol)) - return_false(sc, clause); + ((!is_pair(car(clause))) && (car(clause) != sc->else_symbol)) || + (!is_pair(cdr(clause))) || + (cadr(clause) == sc->feed_to_symbol)) + return_false(sc, clause); opc = alloc_opt_info(sc); top->v[ctr].o1 = opc; if (car(clause) == sc->else_symbol) - { - if (!is_null(cdr(p))) - return_false(sc, clause); - opc->v[CASE_CLAUSE_KEYS].p = sc->else_symbol; - } + { + if (!is_null(cdr(p))) + return_false(sc, clause); + opc->v[CASE_CLAUSE_KEYS].p = sc->else_symbol; + } else - { - if (!s7_is_proper_list(sc, car(clause))) - return_false(sc, clause); - opc->v[CASE_CLAUSE_KEYS].p = car(clause); - } + { + if (!s7_is_proper_list(sc, car(clause))) + return_false(sc, clause); + opc->v[CASE_CLAUSE_KEYS].p = car(clause); + } for (blen = 0, cp = cdr(clause); (is_pair(cp)) && (blen < (NUM_VUNIONS - CASE_CLAUSE_O1)); blen++, cp = cdr(cp)) - { - opc->v[blen + CASE_CLAUSE_O1].o1 = sc->opts[sc->pc]; - if (!cell_optimize(sc, cp)) - return_false(sc, cp); - } + { + opc->v[blen + CASE_CLAUSE_O1].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cp)) + return_false(sc, cp); + } if (!is_null(cp)) - return_false(sc, cp); + return_false(sc, cp); opc->v[1].i = blen; opc->v[0].fp = opt_case; /* just a placeholder I hope */ } @@ -66575,18 +66575,18 @@ static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t le opt_info *opc = alloc_opt_info(sc); opc->v[1].p = s7_slot(sc, caaadr(car_x)); if (!is_slot(opc->v[1].p)) - return_false(sc, car_x); + return_false(sc, car_x); opc->v[4].o1 = sc->opts[sc->pc]; if (!cell_optimize(sc, cdaadr(car_x))) - return_false(sc, car_x); + return_false(sc, car_x); 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_false(sc, car_x); - } + { + opc->v[i].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, car_x); + } opc->v[2].i = len - 2; opc->v[0].fp = opt_let_temporarily; return_true(sc, car_x); @@ -66652,24 +66652,24 @@ static s7_pointer opt_do_any(opt_info *o) { /* end */ if (ostart->v[0].fb(ostart)) - break; + break; /* body */ if (len == 6) /* here and in opt_do_n we need a better way to unroll these loops */ - {fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]);} + {fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]);} else - if (len == 7) - {fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]); fp[6](os[6]);} - else for (i = 0; i < len; i++) fp[i](os[i]); + if (len == 7) + {fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]); fp[6](os[6]);} + else for (i = 0; i < len; i++) fp[i](os[i]); /* step (let not let*) */ for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); k++, vp = next_slot(vp)) - if (has_stepper(vp)) - { - o1 = steps->v[k].o1; - slot_simply_set_pending_value(vp, o1->v[0].fp(o1)); - } + if (has_stepper(vp)) + { + o1 = steps->v[k].o1; + slot_simply_set_pending_value(vp, o1->v[0].fp(o1)); + } for (vp = let_slots(sc->curlet); tis_slot(vp); vp = next_slot(vp)) - if (has_stepper(vp)) - slot_set_value(vp, slot_pending_value(vp)); + if (has_stepper(vp)) + slot_set_value(vp, slot_pending_value(vp)); } /* result */ result = sc->T; @@ -66782,11 +66782,11 @@ static s7_pointer opt_do_no_vars(opt_info *o) { opt_info *body = do_no_vars_body(o); while (!(fb(ostart))) /* tshoot, tfft */ - for (int32_t i = 0; i < len; i++) - { - opt_info *o1 = body->v[i].o1; - o1->v[0].fp(o1); - }} + for (int32_t i = 0; i < len; i++) + { + opt_info *o1 = body->v[i].o1; + o1->v[0].fp(o1); + }} unstack_gc_protect(sc); set_curlet(sc, old_e); return(sc->T); @@ -66811,26 +66811,26 @@ static s7_pointer opt_do_1(opt_info *o) (is_t_integer(slot_value(vp)))) { if ((ostep->v[0].fp == opt_p_ii_ss_add) || /* tmap */ - (ostep->v[0].fp == i_to_p)) - { - s7_pointer step_val = make_mutable_integer(sc, integer(slot_value(vp))); - slot_set_value(vp, step_val); - if (ostep->v[0].fp == opt_p_ii_ss_add) - while (!ostart->v[0].fb(ostart)) - { - body->v[0].fp(body); - set_integer(step_val, opt_i_ii_ss_add(ostep)); - } - else - while (!ostart->v[0].fb(ostart)) - { - body->v[0].fp(body); - set_integer(step_val, ostep->v[O_WRAP].fi(ostep)); - } - unstack_gc_protect(sc); - set_curlet(sc, old_e); - return(sc->T); - } + (ostep->v[0].fp == i_to_p)) + { + s7_pointer step_val = make_mutable_integer(sc, integer(slot_value(vp))); + slot_set_value(vp, step_val); + if (ostep->v[0].fp == opt_p_ii_ss_add) + while (!ostart->v[0].fb(ostart)) + { + body->v[0].fp(body); + set_integer(step_val, opt_i_ii_ss_add(ostep)); + } + else + while (!ostart->v[0].fb(ostart)) + { + body->v[0].fp(body); + set_integer(step_val, ostep->v[O_WRAP].fi(ostep)); + } + unstack_gc_protect(sc); + set_curlet(sc, old_e); + return(sc->T); + } o->v[8].i = 2; } while (!(ostart->v[0].fb(ostart))) /* s7test tref */ @@ -66863,32 +66863,32 @@ static s7_pointer opt_do_n(opt_info *o) { opt_info *e1 = body->v[0].o1, *e2 = body->v[1].o1; while (!(ostart->v[0].fb(ostart))) - { - e1->v[0].fp(e1); - e2->v[0].fp(e2); - slot_set_value(vp, ostep->v[0].fp(ostep)); - }} + { + e1->v[0].fp(e1); + e2->v[0].fp(e2); + slot_set_value(vp, ostep->v[0].fp(ostep)); + }} else { opt_info *os[NUM_VUNIONS]; opt_info_fp fp[NUM_VUNIONS]; for (int32_t i = 0; i < len; i++) - { - os[i] = body->v[i].o1; - fp[i] = os[i]->v[0].fp; - } + { + os[i] = body->v[i].o1; + fp[i] = os[i]->v[0].fp; + } if (len == 7) - while (!ostart->v[0].fb(ostart)) /* tfft teq */ /* this is probably fft code */ - { - fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]); fp[6](os[6]); - slot_set_value(vp, ostep->v[0].fp(ostep)); - } + while (!ostart->v[0].fb(ostart)) /* tfft teq */ /* this is probably fft code */ + { + fp[0](os[0]); fp[1](os[1]); fp[2](os[2]); fp[3](os[3]); fp[4](os[4]); fp[5](os[5]); fp[6](os[6]); + slot_set_value(vp, ostep->v[0].fp(ostep)); + } else - while (!ostart->v[0].fb(ostart)) /* tfft teq */ - { - for (int32_t i = 0; i < len; i++) fp[i](os[i]); - slot_set_value(vp, ostep->v[0].fp(ostep)); - }} + while (!ostart->v[0].fb(ostart)) /* tfft teq */ + { + for (int32_t i = 0; i < len; i++) fp[i](os[i]); + slot_set_value(vp, ostep->v[0].fp(ostep)); + }} unstack_gc_protect(sc); set_curlet(sc, old_e); return(sc->T); @@ -66911,20 +66911,20 @@ static s7_pointer opt_do_times(opt_info *o) { opt_info *e1 = body->v[0].o1, *e2 = body->v[1].o1; while (integer(vp) < end) - { - e1->v[0].fp(e1); - e2->v[0].fp(e2); - integer(vp)++; - }} + { + e1->v[0].fp(e1); + e2->v[0].fp(e2); + integer(vp)++; + }} else while (integer(vp) < end) /* tbig sg */ { - for (int32_t i = 0; i < len; i++) - { - o1 = body->v[i].o1; - o1->v[0].fp(o1); - } - integer(vp)++; + for (int32_t i = 0; i < len; i++) + { + o1 = body->v[i].o1; + o1->v[0].fp(o1); + } + integer(vp)++; } unstack_gc_protect(sc); set_curlet(sc, old_e); @@ -66946,15 +66946,15 @@ static s7_pointer opt_do_list_simple(opt_info *o) if (fp == opt_if_bp) while (is_pair(slot_value(vp))) { - if (o1->v[3].fb(o1->v[2].o1)) - o1->v[5].fp(o1->v[4].o1); - slot_set_value(vp, cdr(slot_value(vp))); + if (o1->v[3].fb(o1->v[2].o1)) + o1->v[5].fp(o1->v[4].o1); + slot_set_value(vp, cdr(slot_value(vp))); } else while (!is_null(slot_value(vp))) { - fp(o1); - slot_set_value(vp, cdr(slot_value(vp))); + fp(o1); + slot_set_value(vp, cdr(slot_value(vp))); } unstack_gc_protect(sc); set_curlet(sc, old_e); @@ -66980,72 +66980,72 @@ static s7_pointer opt_do_very_simple(opt_info *o) opt_info *o2 = o1; o1 = o2->v[4].o1; if (o2->v[3].p_pip_f == t_vector_set_p_pip_direct) - { - s7_pointer v = slot_value(o2->v[1].p); - while (integer(vp) < end) - { - t_vector_set_p_pip_direct(o2->sc, v, integer(slot_value(o2->v[2].p)), o1->v[0].fp(o1)); - integer(vp)++; - }} + { + s7_pointer v = slot_value(o2->v[1].p); + while (integer(vp) < end) + { + t_vector_set_p_pip_direct(o2->sc, v, integer(slot_value(o2->v[2].p)), o1->v[0].fp(o1)); + integer(vp)++; + }} else - while (integer(vp) < end) - { - o2->v[3].p_pip_f(o2->sc, slot_value(o2->v[1].p), integer(slot_value(o2->v[2].p)), o1->v[0].fp(o1)); - integer(vp)++; - }} + while (integer(vp) < end) + { + o2->v[3].p_pip_f(o2->sc, slot_value(o2->v[1].p), integer(slot_value(o2->v[2].p)), o1->v[0].fp(o1)); + integer(vp)++; + }} else { if (f == opt_p_pip_sso) - { /* vector-set from vector-ref (i.e. copy), but treating vector-* as generic */ - if (((let_dox_slot1(do_curlet_unchecked(o)) == o1->v[2].p) && (o1->v[2].p == o1->v[4].p)) && - (((o1->v[5].p_pip_f == float_vector_set_p_pip_direct) && (o1->v[6].p_pi_f == float_vector_ref_p_pi_direct)) || - ((o1->v[5].p_pip_f == int_vector_set_p_pip_direct) && (o1->v[6].p_pi_f == int_vector_ref_p_pi_direct)) || - ((o1->v[5].p_pip_f == string_set_p_pip_direct) && (o1->v[6].p_pi_f == string_ref_p_pi_direct)) || - ((o1->v[5].p_pip_f == byte_vector_set_p_pip_direct) && (o1->v[6].p_pi_f == byte_vector_ref_p_pi_direct)))) - { - copy_to_same_type(sc, slot_value(o1->v[1].p), slot_value(o1->v[3].p), integer(vp), end, integer(vp)); - unstack_gc_protect(sc); - set_curlet(sc, old_e); - return(sc->T); - } - while (integer(vp) < end) - { - 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)))); - integer(vp)++; - }} + { /* vector-set from vector-ref (i.e. copy), but treating vector-* as generic */ + if (((let_dox_slot1(do_curlet_unchecked(o)) == o1->v[2].p) && (o1->v[2].p == o1->v[4].p)) && + (((o1->v[5].p_pip_f == float_vector_set_p_pip_direct) && (o1->v[6].p_pi_f == float_vector_ref_p_pi_direct)) || + ((o1->v[5].p_pip_f == int_vector_set_p_pip_direct) && (o1->v[6].p_pi_f == int_vector_ref_p_pi_direct)) || + ((o1->v[5].p_pip_f == string_set_p_pip_direct) && (o1->v[6].p_pi_f == string_ref_p_pi_direct)) || + ((o1->v[5].p_pip_f == byte_vector_set_p_pip_direct) && (o1->v[6].p_pi_f == byte_vector_ref_p_pi_direct)))) + { + copy_to_same_type(sc, slot_value(o1->v[1].p), slot_value(o1->v[3].p), integer(vp), end, integer(vp)); + unstack_gc_protect(sc); + set_curlet(sc, old_e); + return(sc->T); + } + while (integer(vp) < end) + { + 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)))); + integer(vp)++; + }} else - 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(do_curlet(o)))) - { - opt_info *o2 = o1->v[5].o1; /* set_p_i_f: x = make_integer(o->sc, o->v[6].fi(o->v[5].o1)); */ - s7_int (*fi)(opt_info *o) = o2->v[0].fi; - s7_pointer ival = make_mutable_integer(sc, integer(slot_value(o1->v[1].p))); - slot_set_value(o1->v[1].p, ival); - while (integer(vp) < end) - { - set_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) && /* tref.scm */ - (o1->v[4].d_7pid_f == float_vector_set_d_7pid_direct)) - { - s7_pointer ind = o1->v[2].p; - opt_info *o2 = do_any_body(o1); - s7_double (*fd)(opt_info *o) = o2->v[0].fd; - s7_pointer fv = slot_value(o1->v[1].p); - while (integer(vp) < end) - { - float_vector_set_d_7pid_direct(sc, fv, integer(slot_value(ind)), fd(o2)); - /* weird! els[integer(slot_value(ind))] = fd(o2) is much slower according to callgrind? */ - integer(vp)++; - }} - else - while (integer(vp) < end) {f(o1); integer(vp)++;}} + 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(do_curlet(o)))) + { + opt_info *o2 = o1->v[5].o1; /* set_p_i_f: x = make_integer(o->sc, o->v[6].fi(o->v[5].o1)); */ + s7_int (*fi)(opt_info *o) = o2->v[0].fi; + s7_pointer ival = make_mutable_integer(sc, integer(slot_value(o1->v[1].p))); + slot_set_value(o1->v[1].p, ival); + while (integer(vp) < end) + { + set_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) && /* tref.scm */ + (o1->v[4].d_7pid_f == float_vector_set_d_7pid_direct)) + { + s7_pointer ind = o1->v[2].p; + opt_info *o2 = do_any_body(o1); + s7_double (*fd)(opt_info *o) = o2->v[0].fd; + s7_pointer fv = slot_value(o1->v[1].p); + while (integer(vp) < end) + { + float_vector_set_d_7pid_direct(sc, fv, integer(slot_value(ind)), fd(o2)); + /* weird! els[integer(slot_value(ind))] = fd(o2) is much slower according to callgrind? */ + integer(vp)++; + }} + else + while (integer(vp) < end) {f(o1); integer(vp)++;}} /* splitting out opt_set_p_d_f_sf_add here (for tgsl.scm) is marginal (time is in opt_d_dd_ff_mul -> opt_d_id_sf -> bessel funcs) */ unstack_gc_protect(sc); set_curlet(sc, old_e); @@ -67100,9 +67100,9 @@ static bool stop_is_safe(s7_scheme *sc, s7_pointer stop, s7_pointer body) /* this could be folded into the cell_optimize traversal */ for (s7_pointer p = body; is_pair(p); p = cdr(p)) if ((is_pair(car(p))) && - (caar(p) == sc->set_symbol) && - (is_pair(cdar(p))) && - (cadar(p) == stop)) + (caar(p) == sc->set_symbol) && + (is_pair(cdar(p))) && + (cadar(p) == stop)) return(!s7_tree_memq(sc, stop, cdr(p))); return(true); } @@ -67130,7 +67130,7 @@ static bool do_passes_safety_check(s7_scheme *sc, s7_pointer body, s7_pointer st { set_safety_checked(body); if (!(do_is_safe(sc, body, stepper, sc->nil, step_vars, has_set))) - set_unsafe_do(body); + set_unsafe_do(body); } return(!is_unsafe_do(body)); } @@ -67143,10 +67143,10 @@ static bool all_integers(s7_scheme *sc, s7_pointer expr) { s7_pointer p; for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!((is_t_integer(car(p))) || - ((is_symbol(car(p))) && (is_t_integer(slot_value(s7_slot(sc, car(p)))))) || - ((is_pair(car(p))) && (all_integers(sc, car(p)))))) - break; + if (!((is_t_integer(car(p))) || + ((is_symbol(car(p))) && (is_t_integer(slot_value(s7_slot(sc, car(p)))))) || + ((is_pair(car(p))) && (all_integers(sc, car(p)))))) + break; return(is_null(p)); } return(false); @@ -67158,10 +67158,10 @@ static bool all_floats(s7_scheme *sc, s7_pointer expr) { s7_pointer p; for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!((is_t_real(car(p))) || - ((is_symbol(car(p))) && (is_t_real(slot_value(s7_slot(sc, car(p)))))) || - ((is_pair(car(p))) && (all_floats(sc, car(p)))))) - break; + if (!((is_t_real(car(p))) || + ((is_symbol(car(p))) && (is_t_real(slot_value(s7_slot(sc, car(p)))))) || + ((is_pair(car(p))) && (all_floats(sc, car(p)))))) + break; return(is_null(p)); } return(false); @@ -67200,17 +67200,17 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) { s7_pointer var = car(p); if ((is_pair(var)) && - (is_symbol(car(var))) && - (is_pair(cdr(var)))) - { - s7_pointer sym = car(var); - if (is_constant_symbol(sc, sym)) - return_false(sc, car_x); - if (symbol_is_in_list(sc, sym)) - syntax_error_nr(sc, "duplicate identifier in do: ~A", 30, var); - add_symbol_to_list(sc, sym); - add_slot(sc, let, sym, sc->undefined); - } + (is_symbol(car(var))) && + (is_pair(cdr(var)))) + { + s7_pointer sym = car(var); + if (is_constant_symbol(sc, sym)) + return_false(sc, car_x); + if (symbol_is_in_list(sc, sym)) + syntax_error_nr(sc, "duplicate identifier in do: ~A", 30, var); + add_symbol_to_list(sc, sym); + add_slot(sc, let, sym, sc->undefined); + } else return_false(sc, car_x); } if (tis_slot(let_slots(let))) @@ -67222,69 +67222,69 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) init_pc = sc->pc; for (k = 0, p = cadr(car_x), slot = let_slots(let); (is_pair(p)) && (k < SIZE_O); k++, p = cdr(p), slot = next_slot(slot)) { - s7_pointer var = car(p); - init_o[k] = sc->opts[sc->pc]; - if (!cell_optimize(sc, cdr(var))) /* opt init in outer let */ - return_false(sc, car_x); - if (is_pair(cddr(var))) - { - set_has_stepper(slot); - if (!is_null(cdddr(var))) - return_false(sc, car_x); - } - else - { - step_len--; - if (!is_null(cddr(var))) - return_false(sc, car_x); - } - /* we can't use slot_set_value(slot, init_o[k]->v[0].fp(init_o[k])) to get the init value here: it might involve side-effects, - * and in some contexts might access variables that aren't set up yet. So, we kludge around... - */ - if (is_symbol(cadr(var))) - slot_set_value(slot, slot_value(s7_slot(sc, cadr(var)))); - else - if (!is_pair(cadr(var))) - slot_set_value(slot, cadr(var)); - else - if (is_proper_quote(sc, cadr(var))) - slot_set_value(slot, cadadr(var)); - else - { - s7_pointer sf = lookup_checked(sc, caadr(var)); - if (is_c_function(sf)) - { - s7_pointer sig = c_function_signature(sf); - if (is_pair(sig)) - { - if ((car(sig) == sc->is_integer_symbol) || - ((is_pair(car(sig))) && - (direct_memq(sc->is_integer_symbol, car(sig)))) || - (all_integers(sc, cadr(var)))) - slot_set_value(slot, int_zero); - else - if ((car(sig) == sc->is_float_symbol) || - ((is_pair(car(sig))) && - (direct_memq(sc->is_float_symbol, car(sig)))) || - (all_floats(sc, cadr(var)))) - slot_set_value(slot, real_zero); - /* need for stepper too -- how does it know (+ x 0.1) is float? try (i 0 (floor (+ i 1))) etc */ - }}}} + s7_pointer var = car(p); + init_o[k] = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdr(var))) /* opt init in outer let */ + return_false(sc, car_x); + if (is_pair(cddr(var))) + { + set_has_stepper(slot); + if (!is_null(cdddr(var))) + return_false(sc, car_x); + } + else + { + step_len--; + if (!is_null(cddr(var))) + return_false(sc, car_x); + } + /* we can't use slot_set_value(slot, init_o[k]->v[0].fp(init_o[k])) to get the init value here: it might involve side-effects, + * and in some contexts might access variables that aren't set up yet. So, we kludge around... + */ + if (is_symbol(cadr(var))) + slot_set_value(slot, slot_value(s7_slot(sc, cadr(var)))); + else + if (!is_pair(cadr(var))) + slot_set_value(slot, cadr(var)); + else + if (is_proper_quote(sc, cadr(var))) + slot_set_value(slot, cadadr(var)); + else + { + s7_pointer sf = lookup_checked(sc, caadr(var)); + if (is_c_function(sf)) + { + s7_pointer sig = c_function_signature(sf); + if (is_pair(sig)) + { + if ((car(sig) == sc->is_integer_symbol) || + ((is_pair(car(sig))) && + (direct_memq(sc->is_integer_symbol, car(sig)))) || + (all_integers(sc, cadr(var)))) + slot_set_value(slot, int_zero); + else + if ((car(sig) == sc->is_float_symbol) || + ((is_pair(car(sig))) && + (direct_memq(sc->is_float_symbol, car(sig)))) || + (all_floats(sc, cadr(var)))) + slot_set_value(slot, real_zero); + /* need for stepper too -- how does it know (+ x 0.1) is float? try (i 0 (floor (+ i 1))) etc */ + }}}} set_curlet(sc, let); for (p = cadr(car_x); is_pair(p); p = cdr(p)) { - s7_pointer var = car(p); - if (is_pair(cddr(var))) - { - s7_pointer init_type = opt_arg_type(sc, cdr(var)); - if (((init_type == sc->is_integer_symbol) || - (init_type == sc->is_float_symbol)) && - (opt_arg_type(sc, cddr(var)) != init_type)) - { - unstack_gc_protect(sc); /* not pop_stack! */ - set_curlet(sc, old_e); - return_false(sc, car_x); - }}}} + s7_pointer var = car(p); + if (is_pair(cddr(var))) + { + s7_pointer init_type = opt_arg_type(sc, cdr(var)); + if (((init_type == sc->is_integer_symbol) || + (init_type == sc->is_float_symbol)) && + (opt_arg_type(sc, cddr(var)) != init_type)) + { + unstack_gc_protect(sc); /* not pop_stack! */ + set_curlet(sc, old_e); + return_false(sc, car_x); + }}}} /* end test */ end_test_pc = sc->pc; @@ -67303,44 +67303,44 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) { s7_pointer stop_slot = (is_symbol(caddr(stop))) ? opt_integer_symbol(sc, caddr(stop)) : sc->nil; if (stop_slot) - { - s7_int lim = (is_slot(stop_slot)) ? integer(slot_value(stop_slot)) : integer(caddr(stop)); - bool set_stop = false; - s7_pointer slot; - - if (car(stop) == sc->gt_symbol) lim++; - for (p = cadr(car_x), slot = let_slots(let); is_pair(p); p = cdr(p), slot = next_slot(slot)) - { - /* this could be put off until it is needed (ref/set), but this code is not called much - * another choice: go from init downto 0: init is lim - */ - if (slot_symbol(slot) == cadr(stop)) - set_stop = true; /* don't overrule this decision below */ - if (has_stepper(slot)) - { - s7_pointer var = car(p), step = caddr(var); - if ((is_t_integer(slot_value(slot))) && - (is_pair(step)) && - (is_pair(cdr(step))) && - (car(var) == cadr(stop)) && - (car(var) == cadr(step)) && - ((car(stop) != sc->num_eq_symbol) || /* else > protects at least the top */ - ((caddr(step) == int_one) && (car(step) == sc->add_symbol)))) - { - set_has_loop_end(slot); - slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); - set_loop_end(slot, lim); - }}} - - if (!set_stop) - { - s7_pointer slot2 = opt_integer_symbol(sc, cadr(stop)); - if ((slot2) && - (stop_is_safe(sc, cadr(stop), cddr(car_x)))) /* b_fft in tfft.scm */ - { - set_has_loop_end(slot2); - set_loop_end(slot2, lim); - }}}} + { + s7_int lim = (is_slot(stop_slot)) ? integer(slot_value(stop_slot)) : integer(caddr(stop)); + bool set_stop = false; + s7_pointer slot; + + if (car(stop) == sc->gt_symbol) lim++; + for (p = cadr(car_x), slot = let_slots(let); is_pair(p); p = cdr(p), slot = next_slot(slot)) + { + /* this could be put off until it is needed (ref/set), but this code is not called much + * another choice: go from init downto 0: init is lim + */ + if (slot_symbol(slot) == cadr(stop)) + set_stop = true; /* don't overrule this decision below */ + if (has_stepper(slot)) + { + s7_pointer var = car(p), step = caddr(var); + if ((is_t_integer(slot_value(slot))) && + (is_pair(step)) && + (is_pair(cdr(step))) && + (car(var) == cadr(stop)) && + (car(var) == cadr(step)) && + ((car(stop) != sc->num_eq_symbol) || /* else > protects at least the top */ + ((caddr(step) == int_one) && (car(step) == sc->add_symbol)))) + { + set_has_loop_end(slot); + slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); + set_loop_end(slot, lim); + }}} + + if (!set_stop) + { + s7_pointer slot2 = opt_integer_symbol(sc, cadr(stop)); + if ((slot2) && + (stop_is_safe(sc, cadr(stop), cddr(car_x)))) /* b_fft in tfft.scm */ + { + set_has_loop_end(slot2); + set_loop_end(slot2, lim); + }}}} /* body */ body_index = sc->pc; @@ -67350,7 +67350,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) body_o[k] = start; if (i < 5) opc->v[i + 7].o1 = start; if (!cell_optimize(sc, p)) - break; + break; oo_idp_nr_fixup(start); } if (!is_null(p)) @@ -67370,8 +67370,8 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) s7_pointer var = car(p); step_o[k] = sc->opts[sc->pc]; if ((is_pair(cddr(var))) && - (!cell_optimize(sc, cddr(var)))) - break; + (!cell_optimize(sc, cddr(var)))) + break; } if (!is_null(p)) { @@ -67391,7 +67391,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) { return_o[rtn_len] = sc->opts[sc->pc]; if (!cell_optimize(sc, p)) - break; + break; } if (!is_null(p)) { @@ -67412,12 +67412,12 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) do_no_vars_test(opc) = sc->opts[end_test_pc]; opc->v[0].fp = opt_do_no_vars; if (body_len > 0) - { - body = alloc_opt_info(sc); - for (k = 0; k < body_len; k++) - body->v[k].o1 = body_o[k]; - do_no_vars_body(opc) = body; - } + { + body = alloc_opt_info(sc); + for (k = 0; k < body_len; k++) + body->v[k].o1 = body_o[k]; + do_no_vars_body(opc) = body; + } return_true(sc, car_x); } opc->v[8].i = 0; @@ -67425,14 +67425,14 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) { s7_pointer expr = cadddr(car_x); if ((is_pair(expr)) && - ((is_c_function(car(expr))) || - (is_safe_setter(car(expr))) || - ((car(expr) == sc->set_symbol) && - (cadr(expr) != caaadr(car_x))) || /* caadr: (stepper init ...) */ - ((car(expr) == sc->vector_set_symbol) && - (is_null(cddddr(expr))) && - (is_code_constant(sc, cadddr(expr)))))) - opc->v[8].i = 1; + ((is_c_function(car(expr))) || + (is_safe_setter(car(expr))) || + ((car(expr) == sc->set_symbol) && + (cadr(expr) != caaadr(car_x))) || /* caadr: (stepper init ...) */ + ((car(expr) == sc->vector_set_symbol) && + (is_null(cddddr(expr))) && + (is_code_constant(sc, cadddr(expr)))))) + opc->v[8].i = 1; } if ((var_len != 1) || (step_len != 1) || (rtn_len != 0)) { @@ -67444,40 +67444,40 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) do_any_test(opc) = sc->opts[end_test_pc]; if ((opc->v[0].fp == opt_do_step_1) && - (opc->v[9].o1->v[0].fp == i_to_p) && - (opc->v[9].o1->v[O_WRAP].fi == opt_i_ii_sc_add) && - (do_any_test(opc)->v[0].fb == opt_b_ii_ss_eq)) - opc->v[0].fp = opt_do_step_i; + (opc->v[9].o1->v[0].fp == i_to_p) && + (opc->v[9].o1->v[O_WRAP].fi == opt_i_ii_sc_add) && + (do_any_test(opc)->v[0].fb == opt_b_ii_ss_eq)) + opc->v[0].fp = opt_do_step_i; inits = alloc_opt_info(sc); for (k = 0; k < var_len; k++) - inits->v[k].o1 = init_o[k]; + inits->v[k].o1 = init_o[k]; do_any_inits(opc) = inits; if (opc->v[0].fp == opt_do_any) - { - opt_info *result, *step; - opt_info *body = alloc_opt_info(sc); - - for (k = 0; k < body_len; k++) - body->v[k].o1 = body_o[k]; - do_any_body(opc) = body; - - result = alloc_opt_info(sc); - for (k = 0; k < rtn_len; k++) - result->v[k].o1 = return_o[k]; - do_any_results(opc) = result; - - step = alloc_opt_info(sc); - for (k = 0; k < var_len; k++) - step->v[k].o1 = step_o[k]; - do_any_steps(opc) = step; - } + { + opt_info *result, *step; + opt_info *body = alloc_opt_info(sc); + + for (k = 0; k < body_len; k++) + body->v[k].o1 = body_o[k]; + do_any_body(opc) = body; + + result = alloc_opt_info(sc); + for (k = 0; k < rtn_len; k++) + result->v[k].o1 = return_o[k]; + do_any_results(opc) = result; + + step = alloc_opt_info(sc); + for (k = 0; k < var_len; k++) + step->v[k].o1 = step_o[k]; + do_any_steps(opc) = step; + } else - { - do_any_body(opc) = sc->opts[body_index]; - do_any_results(opc) = return_o[0]; - } + { + do_any_body(opc) = sc->opts[body_index]; + do_any_results(opc) = return_o[0]; + } return_true(sc, car_x); } @@ -67493,7 +67493,7 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) { opt_info *body = alloc_opt_info(sc); for (k = 0; k < body_len; k++) - body->v[k].o1 = body_o[k]; + body->v[k].o1 = body_o[k]; do_n_body(opc) = body; } do_stepper_init(opc) = sc->opts[init_pc]; @@ -67507,51 +67507,51 @@ static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len) /* we can't use loop_end_possible here yet (not set except for op_dox?) */ if (((car(end) == sc->num_eq_symbol) || (car(end) == sc->geq_symbol)) && - ((is_symbol(caddr(end))) || (is_t_integer(caddr(end)))) && - (is_null(cdddr(end))) && - (car(ind_step) == sc->add_symbol) && - (cadr(ind_step) == ind) && - (caddr(ind_step) == int_one) && - (is_null(cdddr(ind_step))) && - (do_passes_safety_check(sc, cdddr(car_x), ind, cadr(car_x), &has_set))) - { - s7_pointer slot = let_slots(let); - let_set_dox_slot1(let, slot); - let_set_dox_slot2_unchecked(let, (is_symbol(caddr(end))) ? s7_slot(sc, caddr(end)) : sc->undefined); - slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); - opc->v[4].i = body_index; - if (body_len == 1) /* opt_do_1 */ - { - opt_info *o1 = sc->opts[body_index]; - opc->v[0].fp = opt_do_very_simple; - if (is_t_integer(caddr(end))) - opc->v[3].i = integer(caddr(end)); - 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))) */ - { - opc->v[0].fp = opt_do_prepackaged; - opc->v[7].fp = opt_do_dpnr; - } - else - if (o1->v[0].fp == i_to_p_nr) - { - opc->v[0].fp = opt_do_prepackaged; - opc->v[7].fp = opt_do_ipnr; - }} - else - { - opc->v[0].fp = opt_do_times; - if (is_t_integer(caddr(end))) - opc->v[6].i = integer(caddr(end)); - }} + ((is_symbol(caddr(end))) || (is_t_integer(caddr(end)))) && + (is_null(cdddr(end))) && + (car(ind_step) == sc->add_symbol) && + (cadr(ind_step) == ind) && + (caddr(ind_step) == int_one) && + (is_null(cdddr(ind_step))) && + (do_passes_safety_check(sc, cdddr(car_x), ind, cadr(car_x), &has_set))) + { + s7_pointer slot = let_slots(let); + let_set_dox_slot1(let, slot); + let_set_dox_slot2_unchecked(let, (is_symbol(caddr(end))) ? s7_slot(sc, caddr(end)) : sc->undefined); + slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); + opc->v[4].i = body_index; + if (body_len == 1) /* opt_do_1 */ + { + opt_info *o1 = sc->opts[body_index]; + opc->v[0].fp = opt_do_very_simple; + if (is_t_integer(caddr(end))) + opc->v[3].i = integer(caddr(end)); + 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))) */ + { + opc->v[0].fp = opt_do_prepackaged; + opc->v[7].fp = opt_do_dpnr; + } + else + if (o1->v[0].fp == i_to_p_nr) + { + opc->v[0].fp = opt_do_prepackaged; + opc->v[7].fp = opt_do_ipnr; + }} + else + { + opc->v[0].fp = opt_do_times; + if (is_t_integer(caddr(end))) + opc->v[6].i = integer(caddr(end)); + }} else - if ((car(end) == sc->is_null_symbol) && - (is_null(cddr(end))) && - (car(ind_step) == sc->cdr_symbol) && - (cadr(ind_step) == ind) && - (is_null(cddr(ind_step))) && - (body_len == 1) && - (do_passes_safety_check(sc, cdddr(car_x), ind, cadr(car_x), &has_set))) - opc->v[0].fp = opt_do_list_simple; + if ((car(end) == sc->is_null_symbol) && + (is_null(cddr(end))) && + (car(ind_step) == sc->cdr_symbol) && + (cadr(ind_step) == ind) && + (is_null(cddr(ind_step))) && + (body_len == 1) && + (do_passes_safety_check(sc, cdddr(car_x), ind, cadr(car_x), &has_set))) + opc->v[0].fp = opt_do_list_simple; } return_true(sc, car_x); } @@ -67607,8 +67607,8 @@ static bool float_optimize_1(s7_scheme *sc, s7_pointer expr) if (is_symbol(head)) { if ((is_syntactic_symbol(head)) || - (is_syntactic_pair(car_x))) - return(d_syntax_ok(sc, car_x, len)); + (is_syntactic_pair(car_x))) + return(d_syntax_ok(sc, car_x, len)); s_slot = s7_slot(sc, head); if (!is_slot(s_slot)) return_false(sc, car_x); @@ -67623,55 +67623,55 @@ static bool float_optimize_1(s7_scheme *sc, s7_pointer expr) { opt_info *opc = alloc_opt_info(sc); switch (len) - { - case 1: - return(d_ok(sc, opc, s_func)); - - case 2: /* (f v) or (f d): (env e) or (abs x) */ - return((d_d_ok(sc, opc, s_func, car_x)) || - (d_v_ok(sc, opc, s_func, car_x)) || - (d_p_ok(sc, opc, s_func, car_x))); - - case 3: - return((d_dd_ok(sc, opc, s_func, car_x)) || - (d_id_ok(sc, opc, s_func, car_x)) || - (d_vd_ok(sc, opc, s_func, car_x)) || - (d_pd_ok(sc, opc, s_func, car_x)) || - (d_ip_ok(sc, opc, s_func, car_x)) || - (d_7pi_ok(sc, opc, s_func, car_x))); - - case 4: - return((d_ddd_ok(sc, opc, s_func, car_x)) || - (d_7pid_ok(sc, opc, s_func, car_x)) || - (d_vid_ok(sc, opc, s_func, car_x)) || - (d_vdd_ok(sc, opc, s_func, car_x)) || - (d_7pii_ok(sc, opc, s_func, car_x))); - - case 5: - return((d_dddd_ok(sc, opc, s_func, car_x)) || - (d_7piid_ok(sc, opc, s_func, car_x)) || - (d_7piii_ok(sc, opc, s_func, car_x))); - - case 6: - if (d_7piiid_ok(sc, opc, s_func, car_x)) - return_true(sc, car_x); - /* fall through */ - - default: - return(d_add_any_ok(sc, opc, car_x)); - }} + { + case 1: + return(d_ok(sc, opc, s_func)); + + case 2: /* (f v) or (f d): (env e) or (abs x) */ + return((d_d_ok(sc, opc, s_func, car_x)) || + (d_v_ok(sc, opc, s_func, car_x)) || + (d_p_ok(sc, opc, s_func, car_x))); + + case 3: + return((d_dd_ok(sc, opc, s_func, car_x)) || + (d_id_ok(sc, opc, s_func, car_x)) || + (d_vd_ok(sc, opc, s_func, car_x)) || + (d_pd_ok(sc, opc, s_func, car_x)) || + (d_ip_ok(sc, opc, s_func, car_x)) || + (d_7pi_ok(sc, opc, s_func, car_x))); + + case 4: + return((d_ddd_ok(sc, opc, s_func, car_x)) || + (d_7pid_ok(sc, opc, s_func, car_x)) || + (d_vid_ok(sc, opc, s_func, car_x)) || + (d_vdd_ok(sc, opc, s_func, car_x)) || + (d_7pii_ok(sc, opc, s_func, car_x))); + + case 5: + return((d_dddd_ok(sc, opc, s_func, car_x)) || + (d_7piid_ok(sc, opc, s_func, car_x)) || + (d_7piii_ok(sc, opc, s_func, car_x))); + + case 6: + if (d_7piiid_ok(sc, opc, s_func, car_x)) + return_true(sc, car_x); + /* fall through */ + + default: + return(d_add_any_ok(sc, opc, car_x)); + }} else { if ((is_macro(s_func)) && (!no_cell_opt(expr))) - { - s7_pointer body = closure_body(s_func); - if ((is_null(cdr(body))) && (is_pair(car(body))) && - ((caar(body) == sc->list_symbol) || (caar(body) == sc->list_values_symbol) || (caar(body) == initial_value(sc->list_values_symbol)))) - { - s7_pointer result = s7_macroexpand(sc, s_func, cdar(expr)); - if (result == sc->F) return_false(sc, car_x); - return(float_optimize(sc, set_plist_1(sc, result))); - }} + { + s7_pointer body = closure_body(s_func); + if ((is_null(cdr(body))) && (is_pair(car(body))) && + ((caar(body) == sc->list_symbol) || (caar(body) == sc->list_values_symbol) || (caar(body) == initial_value(sc->list_values_symbol)))) + { + s7_pointer result = s7_macroexpand(sc, s_func, cdar(expr)); + if (result == sc->F) return_false(sc, car_x); + return(float_optimize(sc, set_plist_1(sc, result))); + }} if (!s_slot) return_false(sc, car_x); return(d_implicit_ok(sc, s_slot, car_x, len)); } @@ -67695,8 +67695,8 @@ static bool int_optimize_1(s7_scheme *sc, s7_pointer expr) if (is_symbol(head)) { if ((is_syntactic_symbol(head)) || - (is_syntactic_pair(car_x))) - return(i_syntax_ok(sc, car_x, len)); + (is_syntactic_pair(car_x))) + return(i_syntax_ok(sc, car_x, len)); s_slot = s7_slot(sc, head); if (!is_slot(s_slot)) return_false(sc, car_x); s_func = slot_value(s_slot); @@ -67710,44 +67710,44 @@ static bool int_optimize_1(s7_scheme *sc, s7_pointer expr) { opt_info *opc = alloc_opt_info(sc); switch (len) - { - case 2: - return(i_idp_ok(sc, opc, s_func, car_x)); - - case 3: - return((i_ii_ok(sc, opc, s_func, car_x)) || - (i_7pi_ok(sc, opc, s_func, car_x))); - - case 4: - return((i_iii_ok(sc, opc, s_func, car_x)) || - (i_7pii_ok(sc, opc, s_func, car_x))); - - case 5: - { - int32_t pstart = sc->pc; - if (i_7piii_ok(sc, opc, s_func, car_x)) - return_true(sc, car_x); - sc->pc = pstart; - } - /* fall through */ - - default: - return(((head == sc->add_symbol) || - (head == sc->multiply_symbol)) && - (i_add_any_ok(sc, opc, car_x))); - }} + { + case 2: + return(i_idp_ok(sc, opc, s_func, car_x)); + + case 3: + return((i_ii_ok(sc, opc, s_func, car_x)) || + (i_7pi_ok(sc, opc, s_func, car_x))); + + case 4: + return((i_iii_ok(sc, opc, s_func, car_x)) || + (i_7pii_ok(sc, opc, s_func, car_x))); + + case 5: + { + int32_t pstart = sc->pc; + if (i_7piii_ok(sc, opc, s_func, car_x)) + return_true(sc, car_x); + sc->pc = pstart; + } + /* fall through */ + + default: + return(((head == sc->add_symbol) || + (head == sc->multiply_symbol)) && + (i_add_any_ok(sc, opc, car_x))); + }} else { if ((is_macro(s_func)) && (!no_cell_opt(expr))) - { - s7_pointer body = closure_body(s_func); - if ((is_null(cdr(body))) && (is_pair(car(body))) && - ((caar(body) == sc->list_symbol) || (caar(body) == sc->list_values_symbol) || (caar(body) == initial_value(sc->list_values_symbol)))) - { - s7_pointer result = s7_macroexpand(sc, s_func, cdar(expr)); - if (result == sc->F) return_false(sc, car_x); - return(int_optimize(sc, set_plist_1(sc, result))); - }} + { + s7_pointer body = closure_body(s_func); + if ((is_null(cdr(body))) && (is_pair(car(body))) && + ((caar(body) == sc->list_symbol) || (caar(body) == sc->list_values_symbol) || (caar(body) == initial_value(sc->list_values_symbol)))) + { + s7_pointer result = s7_macroexpand(sc, s_func, cdar(expr)); + if (result == sc->F) return_false(sc, car_x); + return(int_optimize(sc, set_plist_1(sc, result))); + }} if (!s_slot) return_false(sc, car_x); return(i_implicit_ok(sc, s_slot, car_x, len)); } @@ -67763,42 +67763,42 @@ static bool p_2x_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (is_symbol(cadr(car_x))) { if ((is_pair(sig)) && (is_pair(cdr(sig))) && (is_pair(cddr(sig))) && (caddr(sig) == sc->is_integer_symbol)) - { - if (p_pi_ok(sc, opc, s_func, sig, car_x)) - return_true(sc, car_x); - - if ((car(sig) == sc->is_float_symbol) || - (car(sig) == sc->is_real_symbol)) - { - s7_d_7pi_t f = s7_d_7pi_function(s_func); - if (f) - { - sc->pc = pstart - 1; - if (float_optimize(sc, expr)) - { - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return_true(sc, car_x); - }}} - sc->pc = pstart; - }} + { + if (p_pi_ok(sc, opc, s_func, sig, car_x)) + return_true(sc, car_x); + + if ((car(sig) == sc->is_float_symbol) || + (car(sig) == sc->is_real_symbol)) + { + s7_d_7pi_t f = s7_d_7pi_function(s_func); + if (f) + { + sc->pc = pstart - 1; + if (float_optimize(sc, expr)) + { + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; + return_true(sc, car_x); + }}} + sc->pc = pstart; + }} { s7_i_ii_t ifunc = s7_i_ii_function(s_func); sc->pc = pstart - 1; if ((ifunc) && - (int_optimize(sc, expr))) + (int_optimize(sc, expr))) { - opc->v[O_WRAP].fi = opc->v[0].fi; - opc->v[0].fp = i_to_p; - if (opc->v[O_WRAP].fi == opt_i_ii_ss_add) - opc->v[0].fp = opt_p_ii_ss_add; - return_true(sc, car_x); + opc->v[O_WRAP].fi = opc->v[0].fi; + opc->v[0].fp = i_to_p; + if (opc->v[O_WRAP].fi == opt_i_ii_ss_add) + opc->v[0].fp = opt_p_ii_ss_add; + return_true(sc, car_x); }} sc->pc = pstart; return((p_ii_ok(sc, opc, s_func, car_x, pstart)) || - (p_dd_ok(sc, opc, s_func, car_x, pstart)) || - (p_pp_ok(sc, opc, s_func, car_x, pstart)) || - (p_call_pp_ok(sc, opc, s_func, car_x, pstart))); + (p_dd_ok(sc, opc, s_func, car_x, pstart)) || + (p_pp_ok(sc, opc, s_func, car_x, pstart)) || + (p_call_pp_ok(sc, opc, s_func, car_x, pstart))); } static bool p_3x_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart, s7_pointer expr) @@ -67807,38 +67807,38 @@ static bool p_3x_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (is_symbol(cadr(car_x))) { if ((is_pair(sig)) && (is_pair(cdr(sig))) && (is_pair(cddr(sig))) && - (caddr(sig) == sc->is_integer_symbol)) - { - if (p_pii_ok(sc, opc, s_func, car_x)) - return_true(sc, car_x); - if (p_pip_ok(sc, opc, s_func, car_x)) - return_true(sc, car_x); - - if (((car(sig) == sc->is_float_symbol) || - (car(sig) == sc->is_real_symbol)) && - (s7_d_7pid_function(s_func)) && - (d_7pid_ok(sc, opc, s_func, car_x))) - { - /* if d_7pid is ok, we need d_to_p for cell_optimize */ - opc->v[O_WRAP].fd = opc->v[0].fd; - opc->v[0].fp = d_to_p; - return_true(sc, car_x); - } - - sc->pc = pstart - 1; - if ((car(sig) == sc->is_integer_symbol) && - (s7_i_7pii_function(s_func)) && - (i_7pii_ok(sc, alloc_opt_info(sc), s_func, car_x))) - { - opc->v[O_WRAP].fi = opc->v[0].fi; - opc->v[0].fp = i_to_p; - return_true(sc, car_x); - } - sc->pc = pstart; - }} + (caddr(sig) == sc->is_integer_symbol)) + { + if (p_pii_ok(sc, opc, s_func, car_x)) + return_true(sc, car_x); + if (p_pip_ok(sc, opc, s_func, car_x)) + return_true(sc, car_x); + + if (((car(sig) == sc->is_float_symbol) || + (car(sig) == sc->is_real_symbol)) && + (s7_d_7pid_function(s_func)) && + (d_7pid_ok(sc, opc, s_func, car_x))) + { + /* if d_7pid is ok, we need d_to_p for cell_optimize */ + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; + return_true(sc, car_x); + } + + sc->pc = pstart - 1; + if ((car(sig) == sc->is_integer_symbol) && + (s7_i_7pii_function(s_func)) && + (i_7pii_ok(sc, alloc_opt_info(sc), s_func, car_x))) + { + opc->v[O_WRAP].fi = opc->v[0].fi; + opc->v[0].fp = i_to_p; + return_true(sc, car_x); + } + sc->pc = pstart; + }} return((p_ppi_ok(sc, opc, s_func, car_x)) || - (p_ppp_ok(sc, opc, s_func, car_x)) || - (p_call_ppp_ok(sc, opc, s_func, car_x))); + (p_ppp_ok(sc, opc, s_func, car_x)) || + (p_call_ppp_ok(sc, opc, s_func, car_x))); } static bool p_4x_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart, s7_pointer expr) @@ -67877,7 +67877,7 @@ static bool p_4x_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer if (!is_symbol(cadr(car_x))) return_false(sc, car_x); obj = lookup_unexamined(sc, cadr(car_x)); /* was lookup_from (to avoid the unbound variable check) */ if ((!obj) || (!is_any_vector(obj)) || (vector_rank(obj) != 3)) - return_false(sc, car_x); + return_false(sc, car_x); } return(p_call_any_ok(sc, opc, s_func, car_x, len)); } @@ -67909,8 +67909,8 @@ static bool cell_optimize_1(s7_scheme *sc, s7_pointer expr) if (is_symbol(head)) { if ((is_syntactic_symbol(head)) || - (is_syntactic_pair(car_x))) /* this can be wrong! */ - return(p_syntax(sc, car_x, len)); + (is_syntactic_pair(car_x))) /* this can be wrong! */ + return(p_syntax(sc, car_x, len)); s_slot = s7_slot(sc, head); if (!is_slot(s_slot)) return_false(sc, car_x); @@ -67921,76 +67921,76 @@ static bool cell_optimize_1(s7_scheme *sc, s7_pointer expr) s_func = head; else { /* ((let-ref L 'mult) 1 2) or 'a etc */ - /* fprintf(stderr, "%d: car_x: %s, head: %s\n", __LINE__, display(car_x), display(head)); */ - if ((head == sc->quote_function) && - ((is_pair(cdr(car_x))) && (is_null(cddr(car_x))))) - return(opt_cell_quote(sc, car_x)); - - /* if head is ([let-ref] L 'multiply), it should be accessible now, so we could do the lookup, set up s_func and go on */ - if (is_pair(head)) - { - s7_pointer let, slot, sym; - if ((car(head) == sc->let_ref_symbol) && (s7_list_length(sc, head) == 3)) - { - let = cadr(head); - sym = caddr(head); - } - else - if (s7_list_length(sc, head) == 2) - { - let = car(head); - sym = cadr(head); - } - else return_false(sc, car_x); - if ((is_symbol(let)) && ((is_symbol_and_keyword(sym)) || (is_quoted_symbol(sym)))) - { - slot = s7_slot(sc, let); - if (!is_slot(slot)) return_false(sc, car_x); - let = slot_value(slot); - if ((!is_let(let)) || (has_let_ref_fallback(let))) return_false(sc, car_x); - sym = (is_pair(sym)) ? cadr(sym) : keyword_symbol(sym); - s_func = let_ref_p_pp(sc, let, sym); - } - else return_false(sc, car_x); - } - else return_false(sc, car_x); + /* fprintf(stderr, "%d: car_x: %s, head: %s\n", __LINE__, display(car_x), display(head)); */ + if ((head == sc->quote_function) && + ((is_pair(cdr(car_x))) && (is_null(cddr(car_x))))) + return(opt_cell_quote(sc, car_x)); + + /* if head is ([let-ref] L 'multiply), it should be accessible now, so we could do the lookup, set up s_func and go on */ + if (is_pair(head)) + { + s7_pointer let, slot, sym; + if ((car(head) == sc->let_ref_symbol) && (s7_list_length(sc, head) == 3)) + { + let = cadr(head); + sym = caddr(head); + } + else + if (s7_list_length(sc, head) == 2) + { + let = car(head); + sym = cadr(head); + } + else return_false(sc, car_x); + if ((is_symbol(let)) && ((is_symbol_and_keyword(sym)) || (is_quoted_symbol(sym)))) + { + slot = s7_slot(sc, let); + if (!is_slot(slot)) return_false(sc, car_x); + let = slot_value(slot); + if ((!is_let(let)) || (has_let_ref_fallback(let))) return_false(sc, car_x); + sym = (is_pair(sym)) ? cadr(sym) : keyword_symbol(sym); + s_func = let_ref_p_pp(sc, let, sym); + } + else return_false(sc, car_x); + } + else return_false(sc, car_x); } if (is_c_function(s_func)) { opt_info *opc = alloc_opt_info(sc); switch (len) - { - case 1: return(p_ok(sc, opc, s_func, car_x)); + { + case 1: return(p_ok(sc, opc, s_func, car_x)); - case 2: return((p_i_ok(sc, opc, s_func, car_x, sc->pc)) || - (p_d_ok(sc, opc, s_func, car_x, sc->pc)) || - (p_p_ok(sc, opc, s_func, car_x))); + case 2: return((p_i_ok(sc, opc, s_func, car_x, sc->pc)) || + (p_d_ok(sc, opc, s_func, car_x, sc->pc)) || + (p_p_ok(sc, opc, s_func, car_x))); - case 3: return(p_2x_ok(sc, opc, s_func, car_x, sc->pc, expr)); - case 4: return(p_3x_ok(sc, opc, s_func, car_x, sc->pc, expr)); - case 5: return(p_4x_ok(sc, opc, s_func, car_x, sc->pc, expr)); + case 3: return(p_2x_ok(sc, opc, s_func, car_x, sc->pc, expr)); + case 4: return(p_3x_ok(sc, opc, s_func, car_x, sc->pc, expr)); + case 5: return(p_4x_ok(sc, opc, s_func, car_x, sc->pc, expr)); - case 6: if (p_5x_ok(sc, opc, s_func, car_x, sc->pc, expr)) return_true(sc, car_x); - /* fall through */ + case 6: if (p_5x_ok(sc, opc, s_func, car_x, sc->pc, expr)) return_true(sc, car_x); + /* fall through */ - default: return(p_call_any_ok(sc, opc, s_func, car_x, len)); /* >3D vector-set etc */ - }} + default: return(p_call_any_ok(sc, opc, s_func, car_x, len)); /* >3D vector-set etc */ + }} else { if (is_closure(s_func)) - { - opt_info *opc = alloc_opt_info(sc); - if (p_fx_any_ok(sc, opc, expr)) - return_true(sc, car_x); - } + { + opt_info *opc = alloc_opt_info(sc); + if (p_fx_any_ok(sc, opc, expr)) + return_true(sc, car_x); + } if (is_macro(s_func)) - return_false(sc, car_x); /* macroexpand+cell_optimize here restarts the optimize process */ + return_false(sc, car_x); /* macroexpand+cell_optimize here restarts the optimize process */ if (!s_slot) return_false(sc, car_x); #if OPT_PRINT { - bool res = p_implicit_ok(sc, s_slot, car_x, len); - if (!res) fprintf(stderr, " %sno p_implicit for %s%s\n", bold_text red_text, display(car_x), unbold_text uncolor_text); - return(res); + bool res = p_implicit_ok(sc, s_slot, car_x, len); + if (!res) fprintf(stderr, " %sno p_implicit for %s%s\n", bold_text red_text, display(car_x), unbold_text uncolor_text); + return(res); } #else return(p_implicit_ok(sc, s_slot, car_x, len)); @@ -68013,14 +68013,14 @@ static bool bool_optimize_nw_1(s7_scheme *sc, s7_pointer expr) if (is_symbol(head)) { if ((is_syntactic_symbol(head)) || - (is_syntactic_pair(car_x))) - { - if (head == sc->and_symbol) - return(opt_b_and(sc, car_x, len)); - if (head == sc->or_symbol) - return(opt_b_or(sc, car_x, len)); - return_false(sc, car_x); - } + (is_syntactic_pair(car_x))) + { + if (head == sc->and_symbol) + return(opt_b_and(sc, car_x, len)); + if (head == sc->or_symbol) + return(opt_b_or(sc, car_x, len)); + return_false(sc, car_x); + } s_func = lookup_unexamined(sc, head); } else @@ -68032,52 +68032,52 @@ static bool bool_optimize_nw_1(s7_scheme *sc, s7_pointer expr) if (is_c_function(s_func)) { if ((is_symbol(head)) && (symbol_id(head) != 0)) /* (float-vector? (block)) -- both safe c_funcs, but this is a method invocation */ - return_false(sc, car_x); + return_false(sc, car_x); switch (len) - { - case 2: - return(b_idp_ok(sc, s_func, car_x, opt_arg_type(sc, cdr(car_x)))); - - case 3: - { - s7_pointer arg1 = cadr(car_x), arg2 = caddr(car_x); - s7_pointer sig1 = opt_arg_type(sc, cdr(car_x)); - s7_pointer sig2 = opt_arg_type(sc, cddr(car_x)); - opt_info *opc = alloc_opt_info(sc); - int32_t cur_index = sc->pc; - s7_b_7pp_t bpf7 = NULL; - s7_b_pp_t bpf; - - if ((sig2 == sc->is_integer_symbol) || (sig2 == sc->is_byte_symbol)) - { - if (((sig1 == sc->is_integer_symbol) || (sig1 == sc->is_byte_symbol)) && - (b_ii_ok(sc, opc, s_func, car_x, arg1, arg2))) - return_true(sc, car_x); - sc->pc = cur_index; - if (b_pi_ok(sc, opc, s_func, car_x, arg2)) - return_true(sc, car_x); - sc->pc = cur_index; - } - - if ((sig1 == sc->is_float_symbol) && - (sig2 == sc->is_float_symbol) && - (b_dd_ok(sc, opc, s_func, car_x, arg1, arg2))) - return_true(sc, car_x); - sc->pc = cur_index; - - bpf = s7_b_pp_function(s_func); - if (!bpf) bpf7 = s7_b_7pp_function(s_func); - if ((bpf) || (bpf7)) - { - if (bpf) - opc->v[3].b_pp_f = bpf; - else opc->v[3].b_7pp_f = bpf7; - return(b_pp_ok(sc, opc, s_func, car_x, arg1, arg2, bpf)); - }} - break; - - default: break; - }} + { + case 2: + return(b_idp_ok(sc, s_func, car_x, opt_arg_type(sc, cdr(car_x)))); + + case 3: + { + s7_pointer arg1 = cadr(car_x), arg2 = caddr(car_x); + s7_pointer sig1 = opt_arg_type(sc, cdr(car_x)); + s7_pointer sig2 = opt_arg_type(sc, cddr(car_x)); + opt_info *opc = alloc_opt_info(sc); + int32_t cur_index = sc->pc; + s7_b_7pp_t bpf7 = NULL; + s7_b_pp_t bpf; + + if ((sig2 == sc->is_integer_symbol) || (sig2 == sc->is_byte_symbol)) + { + if (((sig1 == sc->is_integer_symbol) || (sig1 == sc->is_byte_symbol)) && + (b_ii_ok(sc, opc, s_func, car_x, arg1, arg2))) + return_true(sc, car_x); + sc->pc = cur_index; + if (b_pi_ok(sc, opc, s_func, car_x, arg2)) + return_true(sc, car_x); + sc->pc = cur_index; + } + + if ((sig1 == sc->is_float_symbol) && + (sig2 == sc->is_float_symbol) && + (b_dd_ok(sc, opc, s_func, car_x, arg1, arg2))) + return_true(sc, car_x); + sc->pc = cur_index; + + bpf = s7_b_pp_function(s_func); + if (!bpf) bpf7 = s7_b_7pp_function(s_func); + if ((bpf) || (bpf7)) + { + if (bpf) + opc->v[3].b_pp_f = bpf; + else opc->v[3].b_7pp_f = bpf7; + return(b_pp_ok(sc, opc, s_func, car_x, arg1, arg2, bpf)); + }} + break; + + default: break; + }} return_false(sc, car_x); } @@ -68129,21 +68129,21 @@ static s7_pfunc s7_optimize_1(s7_scheme *sc, s7_pointer expr, bool nv) if (!no_int_opt(expr)) { if (int_optimize(sc, expr)) - return_success(sc, (nv) ? opt_int_any_nv : opt_make_int, expr); + return_success(sc, (nv) ? opt_int_any_nv : opt_make_int, expr); sc->pc = 0; set_no_int_opt(expr); } if (!no_float_opt(expr)) { if (float_optimize(sc, expr)) - return_success(sc, (nv) ? opt_float_any_nv : opt_make_float, expr); + return_success(sc, (nv) ? opt_float_any_nv : opt_make_float, expr); sc->pc = 0; set_no_float_opt(expr); } if (!no_bool_opt(expr)) { if (bool_optimize_nw(sc, expr)) - return_success(sc, (nv) ? opt_bool_any_nv : opt_wrap_bool, expr); + return_success(sc, (nv) ? opt_bool_any_nv : opt_wrap_bool, expr); sc->pc = 0; set_no_bool_opt(expr); } @@ -68186,10 +68186,10 @@ static void fx_curlet_tree(s7_scheme *sc, s7_pointer code) more_vars = (tis_slot(slot3)) && (tis_slot(next_slot(slot3))); fx_tree(sc, code, - slot_symbol(slot1), - (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, - (tis_slot(slot3)) ? slot_symbol(slot3) : NULL, - more_vars); + slot_symbol(slot1), + (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, + (tis_slot(slot3)) ? slot_symbol(slot3) : NULL, + more_vars); outer_e = let_outlet(sc->curlet); if ((!more_vars) && @@ -68202,10 +68202,10 @@ static void fx_curlet_tree(s7_scheme *sc, s7_pointer code) slot2 = next_slot(slot1); slot3 = (tis_slot(slot2)) ? next_slot(slot2) : NULL; fx_tree_outer(sc, code, - slot_symbol(slot1), - (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, - (tis_slot(slot3)) ? slot_symbol(slot3) : NULL, - (tis_slot(slot3)) && (tis_slot(next_slot(slot3)))); + slot_symbol(slot1), + (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, + (tis_slot(slot3)) ? slot_symbol(slot3) : NULL, + (tis_slot(slot3)) && (tis_slot(next_slot(slot3)))); } } @@ -68215,10 +68215,10 @@ static void fx_curlet_tree_in(s7_scheme *sc, s7_pointer code) s7_pointer slot2 = next_slot(slot1); if (tis_slot(slot2)) slot3 = next_slot(slot2); fx_tree_in(sc, code, - slot_symbol(slot1), - (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, - (tis_slot(slot3)) ? slot_symbol(slot3) : NULL, - (tis_slot(slot3)) && (tis_slot(next_slot(slot3)))); + slot_symbol(slot1), + (tis_slot(slot2)) ? slot_symbol(slot2) : NULL, + (tis_slot(slot3)) ? slot_symbol(slot3) : NULL, + (tis_slot(slot3)) && (tis_slot(next_slot(slot3)))); } typedef bool (*s7_bfunc)(s7_scheme *sc, s7_pointer expr); /* used in eval */ @@ -68361,11 +68361,11 @@ static s7_pointer make_iterators(s7_scheme *sc, s7_pointer caller, s7_pointer ar { s7_pointer iter = car(p); if (!is_iterator(iter)) - { - if (!is_mappable(iter)) - wrong_type_error_nr(sc, caller, i, iter, a_sequence_string); - iter = s7_make_iterator(sc, iter); - } + { + if (!is_mappable(iter)) + wrong_type_error_nr(sc, caller, i, iter, a_sequence_string); + iter = s7_make_iterator(sc, iter); + } sc->z = cons(sc, iter, sc->z); } sc->temp3 = sc->unused; @@ -68402,165 +68402,165 @@ static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq slot = let_slots(sc->curlet); if (sc->map_call_ctr == 0) - { - if (is_null(cdr(body))) - func = s7_optimize_nv(sc, body); - else - if (is_null(cddr(body))) /* 3 sometimes works */ - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); /* was list_1 via cons 8-Apr-21, true=nr */ - }} + { + if (is_null(cdr(body))) + func = s7_optimize_nv(sc, body); + else + if (is_null(cddr(body))) /* 3 sometimes works */ + { + set_ulist_1(sc, sc->begin_symbol, body); + func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); /* was list_1 via cons 8-Apr-21, true=nr */ + }} if (func) - { - push_stack_no_let(sc, OP_MAP_UNWIND, f, seq); - sc->map_call_ctr++; - if (is_pair(seq)) - { - for (s7_pointer x = seq, y = x; is_pair(x); ) - { - slot_set_value(slot, car(x)); - func(sc); - x = cdr(x); - if (is_pair(x)) - { - slot_set_value(slot, car(x)); - func(sc); - x = cdr(x); - y = cdr(y); - if (x == y) break; - }} - res = sc->unspecified; - } - else - if (is_float_vector(seq)) - { - s7_double *vals = float_vector_floats(seq); - s7_int i, len = vector_length(seq); - if ((len > MUTLIM) && - (!tree_has_setters(sc, body))) - { - s7_pointer sv = wrapped_real(sc); /* make_mutable_real(sc, 0.0) 16-Nov-23 */ - slot_set_value(slot, sv); - if (func == opt_float_any_nv) - { - opt_info *o = sc->opts[0]; - s7_double (*fd)(opt_info *o) = o->v[0].fd; - for (i = 0; i < len; i++) {set_real(sv, vals[i]); fd(o);}} - else - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if (fp == opt_unless_p_1) - for (i = 0; i < len; i++) {set_real(sv, vals[i]); if (!(o->v[4].fb(o->v[3].o1))) o->v[5].o1->v[0].fp(o->v[5].o1);} - else for (i = 0; i < len; i++) {set_real(sv, vals[i]); fp(o);} - } - else for (i = 0; i < len; i++) {set_real(sv, vals[i]); func(sc);} - } - else for (i = 0; i < len; i++) {slot_set_value(slot, make_real(sc, vals[i])); func(sc);} - res = sc->unspecified; - } - else - if (is_int_vector(seq)) - { - s7_int *vals = int_vector_ints(seq); - s7_int i, len = vector_length(seq); - if ((len > MUTLIM) && - (!tree_has_setters(sc, body))) - { - s7_pointer sv = wrapped_integer(sc); /* make_mutable_integer(sc, 0) */ - slot_set_value(slot, sv); - /* since there are no setters, the inner step is also mutable if there is one. - * func=opt_cell_any_nv, sc->opts[0]->v[0].fp(sc->opts[0]) fp=opt_do_1 -> mutable version - */ - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - for (i = 0; i < len; i++) {set_integer(sv, vals[i]); fi(o);} - } - else for (i = 0; i < len; i++) {set_integer(sv, vals[i]); func(sc);} - } - else for (i = 0; i < len; i++) {slot_set_value(slot, make_integer(sc, vals[i])); func(sc);} - res = sc->unspecified; - } - else - if (is_t_vector(seq)) - { - s7_pointer *vals = vector_elements(seq); - s7_int i, len = vector_length(seq); - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - for (i = 0; i < len; i++) {slot_set_value(slot, vals[i]); fp(o);}} - else for (i = 0; i < len; i++) {slot_set_value(slot, vals[i]); func(sc);} - res = sc->unspecified; - } - else - if (is_string(seq)) - { - const char *str = string_value(seq); - s7_int len = string_length(seq); - for (s7_int i = 0; i < len; i++) {slot_set_value(slot, chars[(uint8_t)(str[i])]); func(sc);} - res = sc->unspecified; - } - else - if (is_byte_vector(seq)) - { - const uint8_t *vals = (const uint8_t *)byte_vector_bytes(seq); - s7_int i, len = vector_length(seq); - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - for (i = 0; i < len; i++) {slot_set_value(slot, small_int(vals[i])); fi(o);}} - else for (i = 0; i < len; i++) {slot_set_value(slot, small_int(vals[i])); func(sc);} - res = sc->unspecified; - } - if (res) - return(clear_for_each(sc)); - if (!is_iterator(seq)) - { - if (!is_mappable(seq)) - wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string); - seq = s7_make_iterator(sc, seq); - set_stack_protected2_with(sc, seq, OP_MAP_UNWIND); /* GC protect new iterator */ - } - /* push_stack_no_let(sc, OP_GC_PROTECT, seq, f); */ - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - while (true) - { - slot_set_value(slot, s7_iterate(sc, seq)); - if (iterator_is_at_end(seq)) return(clear_for_each(sc)); - fp(o); - }} - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - while (true) - { - slot_set_value(slot, s7_iterate(sc, seq)); - if (iterator_is_at_end(seq)) return(clear_for_each(sc)); - fi(o); - }} - while (true) - { - slot_set_value(slot, s7_iterate(sc, seq)); - if (iterator_is_at_end(seq)) return(clear_for_each(sc)); - func(sc); - }} /* we never get here -- the while loops above exit via return #<unspecified> */ + { + push_stack_no_let(sc, OP_MAP_UNWIND, f, seq); + sc->map_call_ctr++; + if (is_pair(seq)) + { + for (s7_pointer x = seq, y = x; is_pair(x); ) + { + slot_set_value(slot, car(x)); + func(sc); + x = cdr(x); + if (is_pair(x)) + { + slot_set_value(slot, car(x)); + func(sc); + x = cdr(x); + y = cdr(y); + if (x == y) break; + }} + res = sc->unspecified; + } + else + if (is_float_vector(seq)) + { + s7_double *vals = float_vector_floats(seq); + s7_int i, len = vector_length(seq); + if ((len > MUTLIM) && + (!tree_has_setters(sc, body))) + { + s7_pointer sv = wrapped_real(sc); /* make_mutable_real(sc, 0.0) 16-Nov-23 */ + slot_set_value(slot, sv); + if (func == opt_float_any_nv) + { + opt_info *o = sc->opts[0]; + s7_double (*fd)(opt_info *o) = o->v[0].fd; + for (i = 0; i < len; i++) {set_real(sv, vals[i]); fd(o);}} + else + if (func == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = o->v[0].fp; + if (fp == opt_unless_p_1) + for (i = 0; i < len; i++) {set_real(sv, vals[i]); if (!(o->v[4].fb(o->v[3].o1))) o->v[5].o1->v[0].fp(o->v[5].o1);} + else for (i = 0; i < len; i++) {set_real(sv, vals[i]); fp(o);} + } + else for (i = 0; i < len; i++) {set_real(sv, vals[i]); func(sc);} + } + else for (i = 0; i < len; i++) {slot_set_value(slot, make_real(sc, vals[i])); func(sc);} + res = sc->unspecified; + } + else + if (is_int_vector(seq)) + { + s7_int *vals = int_vector_ints(seq); + s7_int i, len = vector_length(seq); + if ((len > MUTLIM) && + (!tree_has_setters(sc, body))) + { + s7_pointer sv = wrapped_integer(sc); /* make_mutable_integer(sc, 0) */ + slot_set_value(slot, sv); + /* since there are no setters, the inner step is also mutable if there is one. + * func=opt_cell_any_nv, sc->opts[0]->v[0].fp(sc->opts[0]) fp=opt_do_1 -> mutable version + */ + if (func == opt_int_any_nv) + { + opt_info *o = sc->opts[0]; + s7_int (*fi)(opt_info *o) = o->v[0].fi; + for (i = 0; i < len; i++) {set_integer(sv, vals[i]); fi(o);} + } + else for (i = 0; i < len; i++) {set_integer(sv, vals[i]); func(sc);} + } + else for (i = 0; i < len; i++) {slot_set_value(slot, make_integer(sc, vals[i])); func(sc);} + res = sc->unspecified; + } + else + if (is_t_vector(seq)) + { + s7_pointer *vals = vector_elements(seq); + s7_int i, len = vector_length(seq); + if (func == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = o->v[0].fp; + for (i = 0; i < len; i++) {slot_set_value(slot, vals[i]); fp(o);}} + else for (i = 0; i < len; i++) {slot_set_value(slot, vals[i]); func(sc);} + res = sc->unspecified; + } + else + if (is_string(seq)) + { + const char *str = string_value(seq); + s7_int len = string_length(seq); + for (s7_int i = 0; i < len; i++) {slot_set_value(slot, chars[(uint8_t)(str[i])]); func(sc);} + res = sc->unspecified; + } + else + if (is_byte_vector(seq)) + { + const uint8_t *vals = (const uint8_t *)byte_vector_bytes(seq); + s7_int i, len = vector_length(seq); + if (func == opt_int_any_nv) + { + opt_info *o = sc->opts[0]; + s7_int (*fi)(opt_info *o) = o->v[0].fi; + for (i = 0; i < len; i++) {slot_set_value(slot, small_int(vals[i])); fi(o);}} + else for (i = 0; i < len; i++) {slot_set_value(slot, small_int(vals[i])); func(sc);} + res = sc->unspecified; + } + if (res) + return(clear_for_each(sc)); + if (!is_iterator(seq)) + { + if (!is_mappable(seq)) + wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string); + seq = s7_make_iterator(sc, seq); + set_stack_protected2_with(sc, seq, OP_MAP_UNWIND); /* GC protect new iterator */ + } + /* push_stack_no_let(sc, OP_GC_PROTECT, seq, f); */ + if (func == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = o->v[0].fp; + while (true) + { + slot_set_value(slot, s7_iterate(sc, seq)); + if (iterator_is_at_end(seq)) return(clear_for_each(sc)); + fp(o); + }} + if (func == opt_int_any_nv) + { + opt_info *o = sc->opts[0]; + s7_int (*fi)(opt_info *o) = o->v[0].fi; + while (true) + { + slot_set_value(slot, s7_iterate(sc, seq)); + if (iterator_is_at_end(seq)) return(clear_for_each(sc)); + fi(o); + }} + while (true) + { + slot_set_value(slot, s7_iterate(sc, seq)); + if (iterator_is_at_end(seq)) return(clear_for_each(sc)); + func(sc); + }} /* we never get here -- the while loops above exit via return #<unspecified> */ else /* not func -- unneeded "else" but otherwise confusing code */ - { - set_no_cell_opt(body); - set_curlet(sc, old_e); - }} + { + set_no_cell_opt(body); + set_curlet(sc, old_e); + }} if ((!is_closure_star(f)) && /* for simplicity in op_for_each_2 (otherwise we need to check for default arg) */ (is_null(cdr(body))) && (is_pair(seq))) @@ -68574,7 +68574,7 @@ static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq if (!is_iterator(seq)) { if (!is_mappable(seq)) - wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string); + wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string); sc->z = s7_make_iterator(sc, seq); } else sc->z = seq; @@ -68591,29 +68591,29 @@ static void map_or_for_each_closure_pair_2(s7_scheme *sc, s7_pfunc func, s7_poin slot_set_value(slot1, car(fast1)); slot_set_value(slot2, car(fast2)); if (for_each_case) - func(sc); + func(sc); else - { - s7_pointer val = func(sc); - if (val != sc->no_value) - set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); /* see map_closure_2 below -- stack_protected3 is our temp */ - } + { + s7_pointer val = func(sc); + if (val != sc->no_value) + set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); /* see map_closure_2 below -- stack_protected3 is our temp */ + } if ((is_pair(cdr(fast1))) && (is_pair(cdr(fast2)))) - { - fast1 = cdr(fast1); - if (fast1 == slow1) break; - fast2 = cdr(fast2); - if (fast2 == slow2) break; - slot_set_value(slot1, car(fast1)); - slot_set_value(slot2, car(fast2)); - if (for_each_case) - func(sc); - else - { - s7_pointer val = func(sc); - if (val != sc->no_value) - set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); - }}} + { + fast1 = cdr(fast1); + if (fast1 == slow1) break; + fast2 = cdr(fast2); + if (fast2 == slow2) break; + slot_set_value(slot1, car(fast1)); + slot_set_value(slot2, car(fast2)); + if (for_each_case) + func(sc); + else + { + s7_pointer val = func(sc); + if (val != sc->no_value) + set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); + }}} } static void map_or_for_each_closure_vector_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case) @@ -68625,13 +68625,13 @@ static void map_or_for_each_closure_vector_2(s7_scheme *sc, s7_pfunc func, s7_po slot_set_value(slot1, vector_getter(seq1)(sc, seq1, i)); slot_set_value(slot2, vector_getter(seq2)(sc, seq2, i)); if (for_each_case) - func(sc); + func(sc); else - { - s7_pointer val = func(sc); - if (val != sc->no_value) - set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); - }} + { + s7_pointer val = func(sc); + if (val != sc->no_value) + set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); + }} } static void map_or_for_each_closure_string_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case) @@ -68644,13 +68644,13 @@ static void map_or_for_each_closure_string_2(s7_scheme *sc, s7_pfunc func, s7_po slot_set_value(slot1, chars[(uint8_t)(s1[i])]); slot_set_value(slot2, chars[(uint8_t)(s2[i])]); if (for_each_case) - func(sc); + func(sc); else - { - s7_pointer val = func(sc); - if (val != sc->no_value) - set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); - }} + { + s7_pointer val = func(sc); + if (val != sc->no_value) + set_stack_protected3_with(sc, cons(sc, val, stack_protected3(sc)), OP_MAP_UNWIND); + }} } static s7_pointer g_for_each_closure_2(s7_scheme *sc, s7_pointer f, s7_pointer seq1, s7_pointer seq2) @@ -68663,67 +68663,67 @@ static s7_pointer g_for_each_closure_2(s7_scheme *sc, s7_pointer f, s7_pointer s s7_pointer val1 = seq_init(sc, seq1); s7_pointer val2 = seq_init(sc, seq2); set_curlet(sc, make_let_with_two_slots(sc, closure_let(f), - (is_pair(car(pars))) ? caar(pars) : car(pars), val1, - (is_pair(cadr(pars))) ? cadar(pars) : cadr(pars), val2)); + (is_pair(car(pars))) ? caar(pars) : car(pars), val1, + (is_pair(cadr(pars))) ? cadar(pars) : cadr(pars), val2)); slot1 = let_slots(sc->curlet); slot2 = next_slot(slot1); if (sc->map_call_ctr == 0) - { - if (is_null(cdr(body))) - func = s7_optimize_nv(sc, body); - else - if (is_null(cddr(body))) - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); - }} + { + if (is_null(cdr(body))) + func = s7_optimize_nv(sc, body); + else + if (is_null(cddr(body))) + { + set_ulist_1(sc, sc->begin_symbol, body); + func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), true); + }} if (func) - { - s7_pointer res = NULL; - push_stack_no_let(sc, OP_MAP_UNWIND, f, seq1); - sc->map_call_ctr++; - if ((is_pair(seq1)) && (is_pair(seq2))) - { - map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, true); - res = sc->unspecified; - } - else - if ((is_any_vector(seq1)) && (is_any_vector(seq2))) - { - map_or_for_each_closure_vector_2(sc, func, seq1, seq2, slot1, slot2, true); - res = sc->unspecified; - } - else - if ((is_string(seq1)) && (is_string(seq2))) - { - map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, true); - res = sc->unspecified; - } - sc->map_call_ctr--; - unstack_with(sc, OP_MAP_UNWIND); - set_curlet(sc, olde); - if (res) return(res); - set_no_cell_opt(body); - } + { + s7_pointer res = NULL; + push_stack_no_let(sc, OP_MAP_UNWIND, f, seq1); + sc->map_call_ctr++; + if ((is_pair(seq1)) && (is_pair(seq2))) + { + map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, true); + res = sc->unspecified; + } + else + if ((is_any_vector(seq1)) && (is_any_vector(seq2))) + { + map_or_for_each_closure_vector_2(sc, func, seq1, seq2, slot1, slot2, true); + res = sc->unspecified; + } + else + if ((is_string(seq1)) && (is_string(seq2))) + { + map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, true); + res = sc->unspecified; + } + sc->map_call_ctr--; + unstack_with(sc, OP_MAP_UNWIND); + set_curlet(sc, olde); + if (res) return(res); + set_no_cell_opt(body); + } else /* not func */ - { - set_no_cell_opt(body); - set_curlet(sc, olde); - }} + { + set_no_cell_opt(body); + set_curlet(sc, olde); + }} if (!is_iterator(seq1)) { if (!is_mappable(seq1)) - wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq1, a_sequence_string); + wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq1, a_sequence_string); sc->z = s7_make_iterator(sc, seq1); } else sc->z = seq1; if (!is_iterator(seq2)) { if (!is_mappable(seq2)) - wrong_type_error_nr(sc, sc->for_each_symbol, 3, seq2, a_sequence_string); + wrong_type_error_nr(sc, sc->for_each_symbol, 3, seq2, a_sequence_string); sc->z = list_2(sc, sc->z, s7_make_iterator(sc, seq2)); } else sc->z = list_2(sc, sc->z, seq2); @@ -68740,11 +68740,11 @@ static inline bool for_each_arg_is_null(s7_scheme *sc, s7_pointer args) { s7_pointer obj = car(p); if (!is_mappable(obj)) - { - if (is_null(obj)) - got_nil = true; - else wrong_type_error_nr(sc, sc->for_each_symbol, i, obj, a_sequence_string); - }} + { + if (is_null(obj)) + got_nil = true; + else wrong_type_error_nr(sc, sc->for_each_symbol, i, obj, a_sequence_string); + }} return(got_nil); } @@ -68763,21 +68763,21 @@ Each object can be a list, string, vector, hash-table, or any other sequence." if (is_closure(f)) /* not lambda* that might get confused about arg names */ { if ((len == 1) && - (is_pair(closure_args(f))) && - (is_null(cdr(closure_args(f))))) - arity_ok = true; + (is_pair(closure_args(f))) && + (is_null(cdr(closure_args(f))))) + arity_ok = true; } else if (is_c_object(f)) /* see note in g_map; s7_is_aritable can clobber sc->args=plist=args */ args = copy_proper_list(sc, args); else if (!is_applicable(f)) - return(method_or_bust(sc, f, sc->for_each_symbol, args, something_applicable_string, 1)); + return(method_or_bust(sc, f, sc->for_each_symbol, args, something_applicable_string, 1)); if ((!arity_ok) && (!s7_is_aritable(sc, f, len))) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "for-each first argument ~A called with ~D argument~P?", 53), f, wrap_integer(sc, len), wrap_integer(sc, len))); + set_elist_4(sc, wrap_string(sc, "for-each first argument ~A called with ~D argument~P?", 53), f, wrap_integer(sc, len), wrap_integer(sc, len))); if (for_each_arg_is_null(sc, cdr(args))) return(sc->unspecified); @@ -68789,100 +68789,100 @@ Each object can be a list, string, vector, hash-table, or any other sequence." s7_p_p_t fp = s7_p_p_function(f); if ((fp) && (len == 1)) - { - if (is_pair(cadr(args))) - { - for (s7_pointer fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) - { - fp(sc, car(fast)); - if (is_pair(cdr(fast))) - { - fast = cdr(fast); - if (fast == slow) break; - fp(sc, car(fast)); - }} - return(sc->unspecified); - } - if (is_any_vector(cadr(args))) - { - s7_pointer v = cadr(args); - s7_int vlen = vector_length(v); - if (is_float_vector(v)) - { - s7_pointer rl = wrapped_real(sc); /* make_mutable_real(sc, 0.0) */ - sc->temp7 = rl; - for (s7_int i = 0; i < vlen; i++) - { - set_real(rl, float_vector(v, i)); - fp(sc, rl); - }} - else - if (is_int_vector(v)) - { - s7_pointer iv = wrapped_integer(sc); /* make_mutable_integer(sc, 0) */ - sc->temp7 = iv; - for (s7_int i = 0; i < vlen; i++) - { - set_integer(iv, int_vector(v, i)); - fp(sc, iv); - }} - else - for (s7_int i = 0; i < vlen; i++) - fp(sc, vector_getter(v)(sc, v, i)); /* LOOP_4 here gains almost nothing */ - return(sc->unspecified); - } - if (is_string(cadr(args))) - { - s7_pointer str = cadr(args); - const char *s = string_value(str); - s7_int slen = string_length(str); - for (s7_int i = 0; i < slen; i++) fp(sc, chars[(uint8_t)(s[i])]); - return(sc->unspecified); - }} + { + if (is_pair(cadr(args))) + { + for (s7_pointer fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) + { + fp(sc, car(fast)); + if (is_pair(cdr(fast))) + { + fast = cdr(fast); + if (fast == slow) break; + fp(sc, car(fast)); + }} + return(sc->unspecified); + } + if (is_any_vector(cadr(args))) + { + s7_pointer v = cadr(args); + s7_int vlen = vector_length(v); + if (is_float_vector(v)) + { + s7_pointer rl = wrapped_real(sc); /* make_mutable_real(sc, 0.0) */ + sc->temp7 = rl; + for (s7_int i = 0; i < vlen; i++) + { + set_real(rl, float_vector(v, i)); + fp(sc, rl); + }} + else + if (is_int_vector(v)) + { + s7_pointer iv = wrapped_integer(sc); /* make_mutable_integer(sc, 0) */ + sc->temp7 = iv; + for (s7_int i = 0; i < vlen; i++) + { + set_integer(iv, int_vector(v, i)); + fp(sc, iv); + }} + else + for (s7_int i = 0; i < vlen; i++) + fp(sc, vector_getter(v)(sc, v, i)); /* LOOP_4 here gains almost nothing */ + return(sc->unspecified); + } + if (is_string(cadr(args))) + { + s7_pointer str = cadr(args); + const char *s = string_value(str); + s7_int slen = string_length(str); + for (s7_int i = 0; i < slen; i++) fp(sc, chars[(uint8_t)(s[i])]); + return(sc->unspecified); + }} func = c_function_call(f); /* presumably this is either display/write, or method call? */ sc->z = make_iterators(sc, sc->for_each_symbol, args); sc->z = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); push_stack_no_let(sc, OP_GC_PROTECT, sc->args, sc->z); /* temporary GC protection */ if (len == 1) - { - s7_pointer x = caar(sc->z), y = cdr(sc->z); - sc->z = sc->unused; - while (true) - { - set_car(y, s7_iterate(sc, x)); - if (iterator_is_at_end(x)) - { - /* not pop_stack here since that can clobber sc->code et al, and if this for-each call is - * being treated as safe, fn_proc(for-each) assumes everywhere that sc->code is left alone. - */ - unstack_gc_protect(sc); /* free_cell(sc, x); */ /* 16-Jan-19 */ - return(sc->unspecified); - } - func(sc, y); - }} + { + s7_pointer x = caar(sc->z), y = cdr(sc->z); + sc->z = sc->unused; + while (true) + { + set_car(y, s7_iterate(sc, x)); + if (iterator_is_at_end(x)) + { + /* not pop_stack here since that can clobber sc->code et al, and if this for-each call is + * being treated as safe, fn_proc(for-each) assumes everywhere that sc->code is left alone. + */ + unstack_gc_protect(sc); /* free_cell(sc, x); */ /* 16-Jan-19 */ + return(sc->unspecified); + } + func(sc, y); + }} iters = sc->z; sc->z = sc->unused; while (true) - { - for (s7_pointer x = car(iters), y = cdr(iters); is_pair(x); x = cdr(x), y = cdr(y)) - { - set_car(y, s7_iterate(sc, car(x))); - if (iterator_is_at_end(car(x))) - { - unstack_gc_protect(sc); - return(sc->unspecified); - }} - func(sc, cdr(iters)); - }} + { + for (s7_pointer x = car(iters), y = cdr(iters); is_pair(x); x = cdr(x), y = cdr(y)) + { + set_car(y, s7_iterate(sc, car(x))); + if (iterator_is_at_end(car(x))) + { + unstack_gc_protect(sc); + return(sc->unspecified); + }} + func(sc, cdr(iters)); + }} /* if closure call is straightforward, use OP_FOR_EACH_1 */ if ((len == 1) && (((is_closure(f)) && - (closure_arity_to_int(sc, f) == 1) && - (!is_constant_symbol(sc, car(closure_args(f))))) || + (closure_arity_to_int(sc, f) == 1) && + (!is_constant_symbol(sc, car(closure_args(f))))) || ((is_closure_star(f)) && - (closure_star_arity_to_int(sc, f) == 1) && - (!is_constant_symbol(sc, (is_pair(car(closure_args(f)))) ? caar(closure_args(f)) : car(closure_args(f))))))) + (closure_star_arity_to_int(sc, f) == 1) && + (!is_constant_symbol(sc, (is_pair(car(closure_args(f)))) ? caar(closure_args(f)) : car(closure_args(f))))))) return(g_for_each_closure(sc, f, cadr(args))); push_stack(sc, OP_FOR_EACH, cons_unchecked(sc, make_iterators(sc, sc->for_each_symbol, args), make_list(sc, len, sc->nil)), f); @@ -68898,11 +68898,11 @@ static bool op_for_each(s7_scheme *sc) { set_car(x, s7_iterate(sc, car(y))); if (iterator_is_at_end(car(y))) - { - sc->value = sc->unspecified; - free_cell(sc, sc->args); - return(true); - }} + { + sc->value = sc->unspecified; + free_cell(sc, sc->args); + return(true); + }} push_stack_direct(sc, OP_FOR_EACH); sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, saved_args) : saved_args; return(false); @@ -68963,11 +68963,11 @@ static Inline bool inline_op_for_each_2(s7_scheme *sc) /* called once in eval, l { counter_set_result(c, cdr(counter_result(c))); if (counter_result(c) == counter_list(c)) - { - sc->value = sc->unspecified; - free_cell(sc, c); /* not sc->args = sc->nil; */ - return(true); - } + { + sc->value = sc->unspecified; + free_cell(sc, c); /* not sc->args = sc->nil; */ + return(true); + } push_stack_direct(sc, OP_FOR_EACH_2); } else push_stack_direct(sc, OP_FOR_EACH_3); @@ -69004,99 +69004,99 @@ static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) /* slot = let_slots(sc->curlet); if (sc->map_call_ctr == 0) - { - if (is_null(cdr(body))) - func = s7_cell_optimize(sc, body, false); - else - if (is_null(cddr(body))) - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); /* list_1 8-Apr-21 */ - }} + { + if (is_null(cdr(body))) + func = s7_cell_optimize(sc, body, false); + else + if (is_null(cddr(body))) + { + set_ulist_1(sc, sc->begin_symbol, body); + func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); /* list_1 8-Apr-21 */ + }} if (func) - { - s7_pointer z, res = NULL; - push_stack_no_let(sc, OP_MAP_UNWIND, f, seq); - sc->map_call_ctr++; - if (is_pair(seq)) - { - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_pointer fast = seq, slow = seq; is_pair(fast); fast = cdr(fast), slow = cdr(slow)) - { - slot_set_value(slot, car(fast)); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - if (is_pair(cdr(fast))) - { - fast = cdr(fast); - if (fast == slow) break; - slot_set_value(slot, car(fast)); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - }} - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if (is_float_vector(seq)) - { - s7_double *vals = float_vector_floats(seq); - s7_int len = vector_length(seq); - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot, make_real(sc, vals[i])); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - } - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if (is_int_vector(seq)) - { - s7_int *vals = int_vector_ints(seq); - s7_int len = vector_length(seq); - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot, make_integer(sc, vals[i])); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - } - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if (is_t_vector(seq)) - { - s7_pointer *vals = vector_elements(seq); - s7_int len = vector_length(seq); - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot, vals[i]); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - } - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if (is_string(seq)) - { - s7_int len = string_length(seq); - const char *str = string_value(seq); - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - for (s7_int i = 0; i < len; i++) - { - slot_set_value(slot, chars[(uint8_t)(str[i])]); - z = func(sc); - if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); - } - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - sc->map_call_ctr--; - unstack_with(sc, OP_MAP_UNWIND); - if ((S7_DEBUGGING) && (sc->map_call_ctr < 0)) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} - if (res) return(res); - } + { + s7_pointer z, res = NULL; + push_stack_no_let(sc, OP_MAP_UNWIND, f, seq); + sc->map_call_ctr++; + if (is_pair(seq)) + { + set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); + for (s7_pointer fast = seq, slow = seq; is_pair(fast); fast = cdr(fast), slow = cdr(slow)) + { + slot_set_value(slot, car(fast)); + z = func(sc); + if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); + if (is_pair(cdr(fast))) + { + fast = cdr(fast); + if (fast == slow) break; + slot_set_value(slot, car(fast)); + z = func(sc); + if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); + }} + res = proper_list_reverse_in_place(sc, stack_protected3(sc)); + } + else + if (is_float_vector(seq)) + { + s7_double *vals = float_vector_floats(seq); + s7_int len = vector_length(seq); + set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, make_real(sc, vals[i])); + z = func(sc); + if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); + } + res = proper_list_reverse_in_place(sc, stack_protected3(sc)); + } + else + if (is_int_vector(seq)) + { + s7_int *vals = int_vector_ints(seq); + s7_int len = vector_length(seq); + set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, make_integer(sc, vals[i])); + z = func(sc); + if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); + } + res = proper_list_reverse_in_place(sc, stack_protected3(sc)); + } + else + if (is_t_vector(seq)) + { + s7_pointer *vals = vector_elements(seq); + s7_int len = vector_length(seq); + set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, vals[i]); + z = func(sc); + if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); + } + res = proper_list_reverse_in_place(sc, stack_protected3(sc)); + } + else + if (is_string(seq)) + { + s7_int len = string_length(seq); + const char *str = string_value(seq); + set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, chars[(uint8_t)(str[i])]); + z = func(sc); + if (z != sc->no_value) set_stack_protected3_with(sc, cons(sc, z, stack_protected3(sc)), OP_MAP_UNWIND); + } + res = proper_list_reverse_in_place(sc, stack_protected3(sc)); + } + sc->map_call_ctr--; + unstack_with(sc, OP_MAP_UNWIND); + if ((S7_DEBUGGING) && (sc->map_call_ctr < 0)) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} + if (res) return(res); + } set_no_cell_opt(body); set_curlet(sc, old_e); } @@ -69117,7 +69117,7 @@ static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) /* if (!is_iterator(seq)) { if (!is_mappable(seq)) - wrong_type_error_nr(sc, sc->map_symbol, 2, seq, a_sequence_string); + wrong_type_error_nr(sc, sc->map_symbol, 2, seq, a_sequence_string); sc->z = s7_make_iterator(sc, seq); } else sc->z = seq; @@ -69136,69 +69136,69 @@ static s7_pointer g_map_closure_2(s7_scheme *sc, s7_pointer f, s7_pointer seq1, s7_pointer val1 = seq_init(sc, seq1); s7_pointer val2 = seq_init(sc, seq2); set_curlet(sc, make_let_with_two_slots(sc, closure_let(f), - (is_pair(car(pars))) ? caar(pars) : car(pars), val1, - (is_pair(cadr(pars))) ? cadar(pars) : cadr(pars), val2)); + (is_pair(car(pars))) ? caar(pars) : car(pars), val1, + (is_pair(cadr(pars))) ? cadar(pars) : cadr(pars), val2)); slot1 = let_slots(sc->curlet); slot2 = next_slot(slot1); if (sc->map_call_ctr == 0) - { - if (is_null(cdr(body))) - func = s7_cell_optimize(sc, body, false); - else - if (is_null(cddr(body))) - { - set_ulist_1(sc, sc->begin_symbol, body); - func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); - }} + { + if (is_null(cdr(body))) + func = s7_cell_optimize(sc, body, false); + else + if (is_null(cddr(body))) + { + set_ulist_1(sc, sc->begin_symbol, body); + func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); + }} if (func) - { - s7_pointer res = NULL; - push_stack_no_let(sc, OP_MAP_UNWIND, f, seq1); - sc->map_call_ctr++; - if ((is_pair(seq1)) && (is_pair(seq2))) - { - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, false); /* builds result on stack_protected3 */ - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if ((is_any_vector(seq1)) && (is_any_vector(seq2))) - { - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - map_or_for_each_closure_vector_2(sc, func, seq1, seq2, slot1, slot2, false); - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - else - if ((is_string(seq1)) && (is_string(seq2))) - { - set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); - map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, false); - res = proper_list_reverse_in_place(sc, stack_protected3(sc)); - } - sc->map_call_ctr--; - unstack_with(sc, OP_MAP_UNWIND); - set_curlet(sc, old_e); - if (res) return(res); - set_no_cell_opt(body); - } + { + s7_pointer res = NULL; + push_stack_no_let(sc, OP_MAP_UNWIND, f, seq1); + sc->map_call_ctr++; + if ((is_pair(seq1)) && (is_pair(seq2))) + { + set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); + map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, false); /* builds result on stack_protected3 */ + res = proper_list_reverse_in_place(sc, stack_protected3(sc)); + } + else + if ((is_any_vector(seq1)) && (is_any_vector(seq2))) + { + set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); + map_or_for_each_closure_vector_2(sc, func, seq1, seq2, slot1, slot2, false); + res = proper_list_reverse_in_place(sc, stack_protected3(sc)); + } + else + if ((is_string(seq1)) && (is_string(seq2))) + { + set_stack_protected3_with(sc, sc->nil, OP_MAP_UNWIND); + map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, false); + res = proper_list_reverse_in_place(sc, stack_protected3(sc)); + } + sc->map_call_ctr--; + unstack_with(sc, OP_MAP_UNWIND); + set_curlet(sc, old_e); + if (res) return(res); + set_no_cell_opt(body); + } else /* not func */ - { - set_no_cell_opt(body); - set_curlet(sc, old_e); - }} + { + set_no_cell_opt(body); + set_curlet(sc, old_e); + }} if (!is_iterator(seq1)) { if (!is_mappable(seq1)) - wrong_type_error_nr(sc, sc->map_symbol, 2, seq1, a_sequence_string); + wrong_type_error_nr(sc, sc->map_symbol, 2, seq1, a_sequence_string); sc->z = s7_make_iterator(sc, seq1); } else sc->z = seq1; if (!is_iterator(seq2)) { if (!is_mappable(seq2)) - wrong_type_error_nr(sc, sc->map_symbol, 3, seq2, a_sequence_string); + wrong_type_error_nr(sc, sc->map_symbol, 3, seq2, a_sequence_string); sc->z = list_2(sc, sc->z, s7_make_iterator(sc, seq2)); } else sc->z = list_2(sc, sc->z, seq2); @@ -69224,166 +69224,166 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table for (len = 0, p = cdr(args); is_not_null(p); p = cdr(p), len++) if (!is_mappable(car(p))) { - if (is_null(car(p))) - got_nil = true; - else wrong_type_error_nr(sc, sc->map_symbol, len + 2, car(p), a_sequence_string); + if (is_null(car(p))) + got_nil = true; + else wrong_type_error_nr(sc, sc->map_symbol, len + 2, car(p), a_sequence_string); } switch (type(f)) { case T_C_FUNCTION: if (!(c_function_is_aritable(f, len))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "map ~A: ~D argument~P?", 22), f, wrap_integer(sc, len), wrap_integer(sc, len))); + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "map ~A: ~D argument~P?", 22), f, wrap_integer(sc, len), wrap_integer(sc, len))); case T_C_RST_NO_REQ_FUNCTION: /* if function is safe c func, do the map locally */ if (got_nil) return(sc->nil); if (is_safe_procedure(f)) - { - s7_pointer val, val1, old_args, iter_list; - s7_function func = c_function_call(f); - if (is_pair(cadr(args))) - { - if (len == 1) - { - s7_p_p_t fp = s7_p_p_function(f); - if (fp) - { - val = list_1_unchecked(sc, sc->nil); - gc_protect_via_stack(sc, val); - for (s7_pointer fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) - { - s7_pointer z = fp(sc, car(fast)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - if (is_pair(cdr(fast))) - { - fast = cdr(fast); - if (fast == slow) break; - z = fp(sc, car(fast)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - }} - unstack_gc_protect(sc); - return(proper_list_reverse_in_place(sc, car(val))); - }} - if ((len == 2) && (is_pair(caddr(args)))) - { - s7_p_pp_t fp = s7_p_pp_function(f); - if (fp) - { - val = list_1_unchecked(sc, sc->nil); - gc_protect_via_stack(sc, val); - for (s7_pointer fast1 = cadr(args), slow1 = cadr(args), fast2 = caddr(args), slow2 = caddr(args); - (is_pair(fast1)) && (is_pair(fast2)); - fast1 = cdr(fast1), slow1 = cdr(slow1), fast2 = cdr(fast2), slow2 = cdr(slow2)) - { - s7_pointer z = fp(sc, car(fast1), car(fast2)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - if ((is_pair(cdr(fast1))) && (is_pair(cdr(fast2)))) - { - fast1 = cdr(fast1); - if (fast1 == slow1) break; - fast2 = cdr(fast2); - if (fast2 == slow2) break; - z = fp(sc, car(fast1), car(fast2)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - }} - unstack_gc_protect(sc); - return(proper_list_reverse_in_place(sc, car(val))); - }}} - if ((is_string(cadr(args))) && (len == 1)) - { - s7_p_p_t fp = s7_p_p_function(f); - if (fp) - { - s7_pointer str = cadr(args); - const char *s = string_value(str); - val = list_1_unchecked(sc, sc->nil); - gc_protect_via_stack(sc, val); - len = string_length(str); - for (s7_int i = 0; i < len; i++) - { - s7_pointer z = fp(sc, chars[(uint8_t)(s[i])]); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - } - unstack_gc_protect(sc); - return(proper_list_reverse_in_place(sc, car(val))); - }} - if ((is_any_vector(cadr(args))) && (len == 1)) - { - s7_p_p_t fp = s7_p_p_function(f); - if (fp) - { - s7_pointer vec = cadr(args); - val = list_1_unchecked(sc, sc->nil); - gc_protect_via_stack(sc, val); - len = vector_length(vec); - for (s7_int i = 0; i < len; i++) - { - s7_pointer z = fp(sc, vector_getter(vec)(sc, vec, i)); - if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); - } - unstack_gc_protect(sc); - return(proper_list_reverse_in_place(sc, car(val))); - }} - - sc->z = make_iterators(sc, sc->map_symbol, args); - val1 = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); - iter_list = sc->z; - old_args = sc->args; - push_stack_no_let(sc, OP_GC_PROTECT, val1, val = cons(sc, sc->nil, sc->code)); /* temporary GC protection: need to protect val1, iter_list, val */ - sc->z = sc->unused; - while (true) - { - s7_pointer z; - for (s7_pointer x = iter_list, y = cdr(val1); is_pair(x); x = cdr(x), y = cdr(y)) - { - set_car(y, s7_iterate(sc, car(x))); - if (iterator_is_at_end(car(x))) - { - unstack_gc_protect(sc); /* free_cell(sc, car(x)); */ /* 16-Jan-19 iterator in circular list -- see s7test */ - sc->args = T_Pos(old_args); /* can be #<unused> or #<counter> */ - return(proper_list_reverse_in_place(sc, car(val))); - }} - z = func(sc, cdr(val1)); /* multiple-values? values is unsafe, but s7_values used externally and claims to be safe? */ /* func = c_function_call(f) */ - if (z != sc->no_value) - set_car(val, cons(sc, z, car(val))); - }} + { + s7_pointer val, val1, old_args, iter_list; + s7_function func = c_function_call(f); + if (is_pair(cadr(args))) + { + if (len == 1) + { + s7_p_p_t fp = s7_p_p_function(f); + if (fp) + { + val = list_1_unchecked(sc, sc->nil); + gc_protect_via_stack(sc, val); + for (s7_pointer fast = cadr(args), slow = cadr(args); is_pair(fast); fast = cdr(fast), slow = cdr(slow)) + { + s7_pointer z = fp(sc, car(fast)); + if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); + if (is_pair(cdr(fast))) + { + fast = cdr(fast); + if (fast == slow) break; + z = fp(sc, car(fast)); + if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); + }} + unstack_gc_protect(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }} + if ((len == 2) && (is_pair(caddr(args)))) + { + s7_p_pp_t fp = s7_p_pp_function(f); + if (fp) + { + val = list_1_unchecked(sc, sc->nil); + gc_protect_via_stack(sc, val); + for (s7_pointer fast1 = cadr(args), slow1 = cadr(args), fast2 = caddr(args), slow2 = caddr(args); + (is_pair(fast1)) && (is_pair(fast2)); + fast1 = cdr(fast1), slow1 = cdr(slow1), fast2 = cdr(fast2), slow2 = cdr(slow2)) + { + s7_pointer z = fp(sc, car(fast1), car(fast2)); + if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); + if ((is_pair(cdr(fast1))) && (is_pair(cdr(fast2)))) + { + fast1 = cdr(fast1); + if (fast1 == slow1) break; + fast2 = cdr(fast2); + if (fast2 == slow2) break; + z = fp(sc, car(fast1), car(fast2)); + if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); + }} + unstack_gc_protect(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }}} + if ((is_string(cadr(args))) && (len == 1)) + { + s7_p_p_t fp = s7_p_p_function(f); + if (fp) + { + s7_pointer str = cadr(args); + const char *s = string_value(str); + val = list_1_unchecked(sc, sc->nil); + gc_protect_via_stack(sc, val); + len = string_length(str); + for (s7_int i = 0; i < len; i++) + { + s7_pointer z = fp(sc, chars[(uint8_t)(s[i])]); + if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); + } + unstack_gc_protect(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }} + if ((is_any_vector(cadr(args))) && (len == 1)) + { + s7_p_p_t fp = s7_p_p_function(f); + if (fp) + { + s7_pointer vec = cadr(args); + val = list_1_unchecked(sc, sc->nil); + gc_protect_via_stack(sc, val); + len = vector_length(vec); + for (s7_int i = 0; i < len; i++) + { + s7_pointer z = fp(sc, vector_getter(vec)(sc, vec, i)); + if (z != sc->no_value) set_car(val, cons(sc, z, car(val))); + } + unstack_gc_protect(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }} + + sc->z = make_iterators(sc, sc->map_symbol, args); + val1 = cons_unchecked(sc, sc->z, make_list(sc, len, sc->nil)); + iter_list = sc->z; + old_args = sc->args; + push_stack_no_let(sc, OP_GC_PROTECT, val1, val = cons(sc, sc->nil, sc->code)); /* temporary GC protection: need to protect val1, iter_list, val */ + sc->z = sc->unused; + while (true) + { + s7_pointer z; + for (s7_pointer x = iter_list, y = cdr(val1); is_pair(x); x = cdr(x), y = cdr(y)) + { + set_car(y, s7_iterate(sc, car(x))); + if (iterator_is_at_end(car(x))) + { + unstack_gc_protect(sc); /* free_cell(sc, car(x)); */ /* 16-Jan-19 iterator in circular list -- see s7test */ + sc->args = T_Pos(old_args); /* can be #<unused> or #<counter> */ + return(proper_list_reverse_in_place(sc, car(val))); + }} + z = func(sc, cdr(val1)); /* multiple-values? values is unsafe, but s7_values used externally and claims to be safe? */ /* func = c_function_call(f) */ + if (z != sc->no_value) + set_car(val, cons(sc, z, car(val))); + }} else /* not safe procedure */ - if ((f == global_value(sc->values_symbol)) && - (len == 1) && - (!has_methods(cadr(args)))) /* iterator should be ok here -- object_to_list can handle it */ - { - p = object_to_list(sc, cadr(args)); - if (p != cadr(args)) - return(p); - } + if ((f == global_value(sc->values_symbol)) && + (len == 1) && + (!has_methods(cadr(args)))) /* iterator should be ok here -- object_to_list can handle it */ + { + p = object_to_list(sc, cadr(args)); + if (p != cadr(args)) + return(p); + } break; case T_CLOSURE: case T_CLOSURE_STAR: { - int32_t fargs = (is_closure(f)) ? closure_arity_to_int(sc, f) : closure_star_arity_to_int(sc, f); - if ((len == 1) && - (fargs == 1) && - (!is_constant_symbol(sc, (is_pair(car(closure_args(f)))) ? caar(closure_args(f)) : car(closure_args(f))))) - { - if (got_nil) return(sc->nil); - if (is_closure_star(f)) - return(g_map_closure(sc, f, cadr(args))); - - /* don't go to OP_MAP_2 here! It assumes no recursion */ - sc->z = (!is_iterator(cadr(args))) ? s7_make_iterator(sc, cadr(args)) : cadr(args); - push_stack(sc, OP_MAP_1, inline_make_counter(sc, sc->z), f); - sc->z = sc->unused; - symbol_increment_ctr(car(closure_args(f))); - return(sc->nil); - } - if (((fargs >= 0) && (fargs < len)) || - ((is_closure(f)) && (abs(fargs) > len))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "map ~A: ~D argument~P?", 22), f, wrap_integer(sc, len), wrap_integer(sc, len))); - if (got_nil) return(sc->nil); + int32_t fargs = (is_closure(f)) ? closure_arity_to_int(sc, f) : closure_star_arity_to_int(sc, f); + if ((len == 1) && + (fargs == 1) && + (!is_constant_symbol(sc, (is_pair(car(closure_args(f)))) ? caar(closure_args(f)) : car(closure_args(f))))) + { + if (got_nil) return(sc->nil); + if (is_closure_star(f)) + return(g_map_closure(sc, f, cadr(args))); + + /* don't go to OP_MAP_2 here! It assumes no recursion */ + sc->z = (!is_iterator(cadr(args))) ? s7_make_iterator(sc, cadr(args)) : cadr(args); + push_stack(sc, OP_MAP_1, inline_make_counter(sc, sc->z), f); + sc->z = sc->unused; + symbol_increment_ctr(car(closure_args(f))); + return(sc->nil); + } + if (((fargs >= 0) && (fargs < len)) || + ((is_closure(f)) && (abs(fargs) > len))) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "map ~A: ~D argument~P?", 22), f, wrap_integer(sc, len), wrap_integer(sc, len))); + if (got_nil) return(sc->nil); } break; @@ -69394,11 +69394,11 @@ a list of the results. Its arguments can be lists, vectors, strings, hash-table default: if (!is_applicable(f)) - return(method_or_bust(sc, f, sc->map_symbol, args, something_applicable_string, 1)); + return(method_or_bust(sc, f, sc->map_symbol, args, something_applicable_string, 1)); if ((!is_pair(f)) && - (!s7_is_aritable(sc, f, len))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "map: ~D argument~P for ~A?", 26), wrap_integer(sc, len), wrap_integer(sc, len), f)); + (!s7_is_aritable(sc, f, len))) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "map: ~D argument~P for ~A?", 26), wrap_integer(sc, len), wrap_integer(sc, len), f)); if (got_nil) return(sc->nil); break; } @@ -69417,11 +69417,11 @@ static bool op_map(s7_scheme *sc) { s7_pointer x = s7_iterate(sc, car(y)); if (iterator_is_at_end(car(y))) - { - sc->value = proper_list_reverse_in_place(sc, counter_result(sc->args)); - free_cell(sc, sc->args); /* unsafe? */ /* not sc->args = sc->nil; */ - return(true); - } + { + sc->value = proper_list_reverse_in_place(sc, counter_result(sc->args)); + free_cell(sc, sc->args); /* unsafe? */ /* not sc->args = sc->nil; */ + return(true); + } sc->x = cons(sc, x, sc->x); } sc->x = proper_list_reverse_in_place(sc, sc->x); @@ -69488,11 +69488,11 @@ static bool op_map_2(s7_scheme *sc) /* possibly inline lg */ closure_set_map_list(code, cdr(closure_map_list(code))); /* this depends on code (the function) being non-recursive, else closure_setter gets stepped on */ if (closure_map_list(code) == counter_list(c)) - { - sc->value = proper_list_reverse_in_place(sc, counter_result(c)); - free_cell(sc, c); /* possibly unsafe */ /* not sc->args = sc->nil; */ - return(true); - } + { + sc->value = proper_list_reverse_in_place(sc, counter_result(c)); + free_cell(sc, c); /* possibly unsafe */ /* not sc->args = sc->nil; */ + return(true); + } push_stack_direct(sc, OP_MAP_GATHER_2); } else push_stack_direct(sc, OP_MAP_GATHER_3); @@ -69521,10 +69521,10 @@ static s7_pointer revappend(s7_scheme *sc, s7_pointer a, s7_pointer b) { a = copy_proper_list(sc, a); do { - s7_pointer q = cdr(a); - set_cdr(a, p); - p = a; - a = q; + s7_pointer q = cdr(a); + set_cdr(a, p); + p = a; + a = q; } while (is_pair(a)); } return(p); @@ -69535,7 +69535,7 @@ static Inline void inline_op_map_gather(s7_scheme *sc) /* called thrice in eval, if (sc->value != sc->no_value) { if (is_multiple_value(sc->value)) - counter_set_result(sc->args, revappend(sc, multiple_value(sc->value), counter_result(sc->args))); + counter_set_result(sc->args, revappend(sc, multiple_value(sc->value), counter_result(sc->args))); else counter_set_result(sc->args, cons(sc, sc->value, counter_result(sc->args))); } } @@ -69564,12 +69564,12 @@ static s7_pointer op_safe_c_p_mv(s7_scheme *sc, s7_pointer args) sc->args = set_plist_3(sc, car(sc->value), cadr(sc->value), car(p)); else { - s7_pointer lst; - s7_int len = proper_list_length(p) + 2; - sc->args = safe_list_if_possible(sc, len); - use_safe = (!in_heap(sc->args)); - lst = sc->args; - for (s7_pointer p = sc->value; is_pair(p); p = cdr(p), lst = cdr(lst)) set_car(lst, car(p)); + s7_pointer lst; + s7_int len = proper_list_length(p) + 2; + sc->args = safe_list_if_possible(sc, len); + use_safe = (!in_heap(sc->args)); + lst = sc->args; + for (s7_pointer p = sc->value; is_pair(p); p = cdr(p), lst = cdr(lst)) set_car(lst, car(p)); } sc->code = c_function_base(opt1_cfunc(sc->code)); if (type(sc->code) == T_C_FUNCTION) @@ -69593,17 +69593,17 @@ static s7_pointer op_safe_c_pc_mv(s7_scheme *sc, s7_pointer args) else { if (is_null(cdr(p))) - sc->args = set_plist_4(sc, car(sc->value), cadr(sc->value), car(p), sc->args); + sc->args = set_plist_4(sc, car(sc->value), cadr(sc->value), car(p), sc->args); else /* sc->args = pair_append(sc, sc->value, list_1(sc, sc->args)); */ /* not plist! sc->value is not reusable */ - { - s7_pointer lst, val = sc->args; - s7_int len = proper_list_length(p); - sc->args = safe_list_if_possible(sc, len + 3); - use_safe = (!in_heap(sc->args)); - lst = sc->args; - for (s7_pointer p = sc->value; is_pair(p); p = cdr(p), lst = cdr(lst)) set_car(lst, car(p)); - set_car(lst, val); - }} + { + s7_pointer lst, val = sc->args; + s7_int len = proper_list_length(p); + sc->args = safe_list_if_possible(sc, len + 3); + use_safe = (!in_heap(sc->args)); + lst = sc->args; + for (s7_pointer p = sc->value; is_pair(p); p = cdr(p), lst = cdr(lst)) set_car(lst, car(p)); + set_car(lst, val); + }} sc->code = c_function_base(opt1_cfunc(sc->code)); if (type(sc->code) == T_C_FUNCTION) sc->value = apply_c_function_unopt(sc, sc->code, sc->args); @@ -69626,17 +69626,17 @@ static s7_pointer op_safe_c_ps_mv(s7_scheme *sc, s7_pointer args) /* (define (h else { if (is_null(cdr(p))) - sc->args = set_plist_4(sc, car(sc->value), cadr(sc->value), car(p), val); + sc->args = set_plist_4(sc, car(sc->value), cadr(sc->value), car(p), val); else /* sc->args = pair_append(sc, sc->value, list_1(sc, val)); */ - { - s7_pointer lst; - s7_int len = proper_list_length(p); - sc->args = safe_list_if_possible(sc, len + 3); /* sc->args is not clobbered by fx_call (below) */ - use_safe = (!in_heap(sc->args)); - lst = sc->args; - for (s7_pointer p = sc->value; is_pair(p); p = cdr(p), lst = cdr(lst)) set_car(lst, car(p)); - set_car(lst, val); - }} + { + s7_pointer lst; + s7_int len = proper_list_length(p); + sc->args = safe_list_if_possible(sc, len + 3); /* sc->args is not clobbered by fx_call (below) */ + use_safe = (!in_heap(sc->args)); + lst = sc->args; + for (s7_pointer p = sc->value; is_pair(p); p = cdr(p), lst = cdr(lst)) set_car(lst, car(p)); + set_car(lst, val); + }} sc->code = c_function_base(opt1_cfunc(sc->code)); if (type(sc->code) == T_C_FUNCTION) sc->value = apply_c_function_unopt(sc, sc->code, sc->args); @@ -69661,21 +69661,21 @@ static s7_pointer op_safe_c_pa_mv(s7_scheme *sc, s7_pointer args) else { if (is_null(cdr(p))) - { - s7_pointer val1 = car(sc->value), val2 = cadr(sc->value), val3 = car(p); - s7_pointer val4 = fx_call(sc, cddr(sc->code)); - sc->args = set_plist_4(sc, val1, val2, val3, val4); - } + { + s7_pointer val1 = car(sc->value), val2 = cadr(sc->value), val3 = car(p); + s7_pointer val4 = fx_call(sc, cddr(sc->code)); + sc->args = set_plist_4(sc, val1, val2, val3, val4); + } else - { - s7_pointer lst; - s7_int len = proper_list_length(p); - sc->args = safe_list_if_possible(sc, len + 3); /* sc->args is not clobbered by fx_call (below) */ - use_safe = (!in_heap(sc->args)); - lst = sc->args; - for (s7_pointer p = sc->value; is_pair(p); p = cdr(p), lst = cdr(lst)) set_car(lst, car(p)); - set_car(lst, fx_call(sc, cddr(sc->code))); - }} + { + s7_pointer lst; + s7_int len = proper_list_length(p); + sc->args = safe_list_if_possible(sc, len + 3); /* sc->args is not clobbered by fx_call (below) */ + use_safe = (!in_heap(sc->args)); + lst = sc->args; + for (s7_pointer p = sc->value; is_pair(p); p = cdr(p), lst = cdr(lst)) set_car(lst, car(p)); + set_car(lst, fx_call(sc, cddr(sc->code))); + }} sc->code = c_function_base(opt1_cfunc(sc->code)); if (type(sc->code) == T_C_FUNCTION) sc->value = apply_c_function_unopt(sc, sc->code, sc->args); @@ -69775,7 +69775,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) s7_pointer x; if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, " %s[%d]: splice %s %s\n", __func__, __LINE__, - (sc->stack_end > sc->stack_start) ? op_names[stack_top_op(sc)] : "no stack!", display_truncated(args))); + (sc->stack_end > sc->stack_start) ? op_names[stack_top_op(sc)] : "no stack!", display_truncated(args))); if ((S7_DEBUGGING) && ((is_null(args)) || (is_null(cdr(args))))) fprintf(stderr, "%s: %s\n", __func__, display(args)); switch (unchecked_stack_top_op(sc)) /* unchecked for C s7_values call at top-level -- see ffitest.c */ @@ -69791,7 +69791,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) */ sc->w = args; for (x = args; is_not_null(cdr(x)); x = cdr(x)) - set_stack_top_args(sc, cons(sc, car(x), stack_top_args(sc))); + set_stack_top_args(sc, cons(sc, car(x), stack_top_args(sc))); sc->w = sc->unused; return(car(x)); @@ -69799,12 +69799,12 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) /* (let ((g-1 (lambda (x a b c) (x (+ a 1) (- b 1) 2 (values c 2))))) (g-1 (macro (x y z w) (list-values '+ x y z w)) 2 3 5)) */ /* code = previous arg saved, args = ante-previous args reversed, we'll take value->code->args and reverse in args5 */ if (is_null(args)) - return(sc->unspecified); + return(sc->unspecified); if (is_null(cdr(args))) - return(car(args)); + return(car(args)); set_stack_top_args(sc, cons(sc, stack_top_code(sc), stack_top_args(sc))); for (x = args; is_not_null(cddr(x)); x = cdr(x)) - set_stack_top_args(sc, cons(sc, car(x), stack_top_args(sc))); + set_stack_top_args(sc, cons(sc, car(x), stack_top_args(sc))); set_stack_top_code(sc, car(x)); return(cadr(x)); @@ -69823,7 +69823,7 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) case OP_ANY_CLOSURE_NP_1: case OP_ANY_CLOSURE_NP_2: sc->code = pop_op_stack(sc); error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, too_many_arguments_string, closure_name(sc, sc->code), set_ulist_1(sc, sc->value_symbol, args))); + set_elist_3(sc, too_many_arguments_string, closure_name(sc, sc->code), set_ulist_1(sc, sc->value_symbol, args))); case OP_ANY_C_NP_2: set_stack_top_op(sc, OP_ANY_C_NP_MV); @@ -69834,11 +69834,11 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) case OP_ANY_C_NP_MV: FP_MV: if ((is_immutable(args)) || /* (let () (define (func) (with-output-to-string (lambda () (apply-values (write '(1 2)))))) (func) (func)) */ - (needs_copied_args(args))) - { - clear_needs_copied_args(args); - args = copy_proper_list(sc, args); - } + (needs_copied_args(args))) + { + clear_needs_copied_args(args); + args = copy_proper_list(sc, args); + } set_multiple_value(args); return(args); @@ -69881,8 +69881,8 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) case OP_SET_FROM_LET_TEMP: /* (let-temporarily ((var (values 1 2 3))) var) */ case OP_SET_FROM_SETTER: /* stack_top_code(sc) is slot if (set! x (set! (setter 'x) g)) s7test.scm */ syntax_error_with_caller_nr(sc, "set!: can't set ~A to ~S", 24, - (is_slot(stack_top_code(sc))) ? slot_symbol(stack_top_code(sc)) : stack_top_code(sc), - set_ulist_1(sc, sc->values_symbol, args)); + (is_slot(stack_top_code(sc))) ? slot_symbol(stack_top_code(sc)) : stack_top_code(sc), + set_ulist_1(sc, sc->values_symbol, args)); case OP_SET_opSAq_P_1: case OP_SET_opSAAq_P_1: /* we can assume here that we're dealing with the section after the target, (set! (target...) arg) where arg can't be (values...) @@ -69900,49 +69900,49 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) case OP_LET1: /* (let ((var (values 1 2 3))) ...) */ { - /* (let () (define (hi) (let ((x (values 1 2))) (if x (list x)))) (define (ho) (hi)) (catch #t (lambda () (ho)) (lambda args #f)) (ho)) */ - s7_pointer let_code, vars, sym, p = stack_top_args(sc); - for (let_code = p; is_pair(cdr(let_code)); let_code = cdr(let_code)); - for (vars = caar(let_code); is_pair(cdr(p)); p = cdr(p), vars = cdr(vars)); - sym = caar(vars); - syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, sym, set_ulist_1(sc, sc->values_symbol, args)); - /* stack_args: ((((x (values 1 2))) x)) in (let ((x (values 1 2))) x) - * (1 (((x 1) (y (values 1 2))) x)) in (let ((x 1) (y (values 1 2))) x) - */ + /* (let () (define (hi) (let ((x (values 1 2))) (if x (list x)))) (define (ho) (hi)) (catch #t (lambda () (ho)) (lambda args #f)) (ho)) */ + s7_pointer let_code, vars, sym, p = stack_top_args(sc); + for (let_code = p; is_pair(cdr(let_code)); let_code = cdr(let_code)); + for (vars = caar(let_code); is_pair(cdr(p)); p = cdr(p), vars = cdr(vars)); + sym = caar(vars); + syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, sym, set_ulist_1(sc, sc->values_symbol, args)); + /* stack_args: ((((x (values 1 2))) x)) in (let ((x (values 1 2))) x) + * (1 (((x 1) (y (values 1 2))) x)) in (let ((x 1) (y (values 1 2))) x) + */ } case OP_LET_ONE_NEW_1: case OP_LET_ONE_P_NEW_1: /* (let () (define (hi) (let ((x (values 1 2))) (display x) (if x (list x)))) (define (ho) (hi)) (catch #t (lambda () (ho)) (lambda args #f)) (ho)) */ syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, - opt2_sym(stack_top_code(sc)), set_ulist_1(sc, sc->values_symbol, args)); + opt2_sym(stack_top_code(sc)), set_ulist_1(sc, sc->values_symbol, args)); case OP_LET_ONE_OLD_1: case OP_LET_ONE_P_OLD_1: syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_symbol, - slot_symbol(let_slots(opt3_let(stack_top_code(sc)))), set_ulist_1(sc, sc->values_symbol, args)); + slot_symbol(let_slots(opt3_let(stack_top_code(sc)))), set_ulist_1(sc, sc->values_symbol, args)); case OP_LET_STAR1: /* here caar(sc->code) is bound to sc->value */ syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->let_star_symbol, - caar(stack_top_code(sc)), set_ulist_1(sc, sc->values_symbol, args)); + caar(stack_top_code(sc)), set_ulist_1(sc, sc->values_symbol, args)); case OP_LETREC1: /* here sc->args is the slot about to receive a value */ syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->letrec_symbol, - slot_symbol(stack_top_args(sc)), set_ulist_1(sc, sc->values_symbol, args)); + slot_symbol(stack_top_args(sc)), set_ulist_1(sc, sc->values_symbol, args)); case OP_LETREC_STAR1: syntax_error_with_caller2_nr(sc, "~A: can't bind ~A to ~S", 23, sc->letrec_star_symbol, - slot_symbol(stack_top_args(sc)), set_ulist_1(sc, sc->values_symbol, args)); + slot_symbol(stack_top_args(sc)), set_ulist_1(sc, sc->values_symbol, args)); case OP_AND_P1: case OP_AND_SAFE_P_REST: /* from OP_AND_SAFE_P1 or P2 */ for (x = args; is_not_null(cdr(x)); x = cdr(x)) - if (car(x) == sc->F) - return(sc->F); + if (car(x) == sc->F) + return(sc->F); return(car(x)); case OP_OR_P1: for (x = args; is_not_null(cdr(x)); x = cdr(x)) - if (car(x) != sc->F) - return(car(x)); + if (car(x) != sc->F) + return(car(x)); return(car(x)); case OP_IF1: /* (if (values ...) ...) -- see s7.html at the end of the values writeup for explanation (we're following CL here) */ @@ -69959,15 +69959,15 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) case OP_DYNAMIC_UNWIND: case OP_DYNAMIC_UNWIND_PROFILE: { - s7_pointer old_value = sc->value; - bool mv = is_multiple_value(args); - if (mv) clear_multiple_value(args); - sc->value = cons(sc, sc->values_symbol, args); - dynamic_unwind(sc, stack_top_code(sc), stack_top_args(sc)); /* position (curlet), this applies code to sc->value */ - sc->value = old_value; - if (mv) set_multiple_value(args); - sc->stack_end -= 4; /* either op is possible I think */ - return(splice_in_values(sc, args)); + s7_pointer old_value = sc->value; + bool mv = is_multiple_value(args); + if (mv) clear_multiple_value(args); + sc->value = cons(sc, sc->values_symbol, args); + dynamic_unwind(sc, stack_top_code(sc), stack_top_args(sc)); /* position (curlet), this applies code to sc->value */ + sc->value = old_value; + if (mv) set_multiple_value(args); + sc->stack_end -= 4; /* either op is possible I think */ + return(splice_in_values(sc, args)); } case OP_DEACTIVATE_GOTO: /* (+ (call-with-exit (lambda (ret) (values 1 2 3)))) */ @@ -69994,35 +69994,35 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) case OP_EVAL_MACRO_MV: /* perhaps reader-cond expansion at eval-time (not at run-time) via ((let () reader-cond) ...)? */ { - opcode_t s_op = stack_top4_op(sc); - if ((S7_DEBUGGING) && (SHOW_EVAL_OPS)) - fprintf(stderr, " eval_macro_mv splice %s with %s, code: %s, args: %s, value: %s\n", - display_truncated(args), op_names[s_op], display_truncated(sc->code), display_truncated(sc->args), display_truncated(sc->value)); - if ((s_op == OP_DO_STEP) || (s_op == OP_DEACTIVATE_GOTO) || (s_op == OP_LET1)) - return(args); /* tricky reader-cond as macro in do body returning values... or call-with-exit */ - - /* if eval_args2 here, how to maintain the current evaluation? - * (+ (reader-cond (#t 1 (values 2 3) 4))) -> 10 + opcode_t s_op = stack_top4_op(sc); + if ((S7_DEBUGGING) && (SHOW_EVAL_OPS)) + fprintf(stderr, " eval_macro_mv splice %s with %s, code: %s, args: %s, value: %s\n", + display_truncated(args), op_names[s_op], display_truncated(sc->code), display_truncated(sc->args), display_truncated(sc->value)); + if ((s_op == OP_DO_STEP) || (s_op == OP_DEACTIVATE_GOTO) || (s_op == OP_LET1)) + return(args); /* tricky reader-cond as macro in do body returning values... or call-with-exit */ + + /* if eval_args2 here, how to maintain the current evaluation? + * (+ (reader-cond (#t 1 (values 2 3) 4))) -> 10 * (+ (((vector reader-cond) 0) (#t 1 (values 2 3) 4))) -> 5 [10 if this block of code is included, s7test is ok with this code] - */ - if (s_op == OP_EVAL_ARGS2) - { - sc->w = args; - for (x = args; is_not_null(cdr(x)); x = cdr(x)) - stack_top4_args(sc) = cons(sc, car(x), stack_top4_args(sc)); - sc->w = sc->unused; - if (SHOW_EVAL_OPS) - fprintf(stderr, " eval_macro splice %s with %s, code: %s, args: %s, value: %s -> %s %s\n", - display_truncated(args), op_names[s_op], display_truncated(sc->code), display_truncated(sc->args), - display_truncated(sc->value), display_truncated(stack_top4_args(sc)), display_truncated(car(x))); - return(car(x)); - } - /* else fall through */ - /* safe_c_p_1 also happens and currently drops trailing arg: ((let () reader-cond) (#t (values 1 2) (iv))) - * op_eval_macro (not op_expansion) is called and can be included below (except it segfaults in s7test...), but trailing arg - * is still dropped because optimizer sees (reader-cond ...) -- one arg! - * (define iv (int-vector 1 2)) (define (func) (eof-object? ((let () reader-cond) (#t (values 1 2) (iv))))) (func) - */ + */ + if (s_op == OP_EVAL_ARGS2) + { + sc->w = args; + for (x = args; is_not_null(cdr(x)); x = cdr(x)) + stack_top4_args(sc) = cons(sc, car(x), stack_top4_args(sc)); + sc->w = sc->unused; + if (SHOW_EVAL_OPS) + fprintf(stderr, " eval_macro splice %s with %s, code: %s, args: %s, value: %s -> %s %s\n", + display_truncated(args), op_names[s_op], display_truncated(sc->code), display_truncated(sc->args), + display_truncated(sc->value), display_truncated(stack_top4_args(sc)), display_truncated(car(x))); + return(car(x)); + } + /* else fall through */ + /* safe_c_p_1 also happens and currently drops trailing arg: ((let () reader-cond) (#t (values 1 2) (iv))) + * op_eval_macro (not op_expansion) is called and can be included below (except it segfaults in s7test...), but trailing arg + * is still dropped because optimizer sees (reader-cond ...) -- one arg! + * (define iv (int-vector 1 2)) (define (func) (eof-object? ((let () reader-cond) (#t (values 1 2) (iv))))) (func) + */ } case OP_EXPANSION: @@ -70032,24 +70032,24 @@ static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) * (+ (reader-cond (#t 1 (values 2 3) 4))) */ if (SHOW_EVAL_OPS) - fprintf(stderr, " %s[%d]: %s stack top: %" ld64 ", op: %s, args: %s\n", __func__, __LINE__, - op_names[stack_top_op(sc)], (s7_int)(intptr_t)stack_top(sc), op_names[stack_top4_op(sc)], display_truncated(args)); + fprintf(stderr, " %s[%d]: %s stack top: %" ld64 ", op: %s, args: %s\n", __func__, __LINE__, + op_names[stack_top_op(sc)], (s7_int)(intptr_t)stack_top(sc), op_names[stack_top4_op(sc)], display_truncated(args)); if (stack_top4_op(sc) == OP_LOAD_RETURN_IF_EOF) - { - /* expansion at top-level returned values, eval args in order */ - sc->code = args; - push_stack_no_args_direct(sc, sc->begin_op); - return(sc->code); - } + { + /* expansion at top-level returned values, eval args in order */ + sc->code = args; + push_stack_no_args_direct(sc, sc->begin_op); + return(sc->code); + } for (x = args; is_not_null(cdr(x)); x = cdr(x)) - stack_top4_args(sc) = cons(sc, car(x), stack_top4_args(sc)); + stack_top4_args(sc) = cons(sc, car(x), stack_top4_args(sc)); pop_stack_no_op(sc); /* need GC protection in loop above, so do this afterwards */ return(car(x)); /* sc->value from OP_READ_LIST point of view */ case OP_EVAL_DONE: /* ((lambda (w) 1) (char-ready? (open-input-function (lambda (x) (values 1 2 3 4 5 6 7))))) */ if (stack_top4_op(sc) == OP_NO_VALUES) - error_nr(sc, sc->error_symbol, - set_elist_1(sc, wrap_string(sc, "function-port should not return multiple-values", 47))); + error_nr(sc, sc->error_symbol, + set_elist_1(sc, wrap_string(sc, "function-port should not return multiple-values", 47))); set_stack_top_op(sc, OP_SPLICE_VALUES); /* tricky -- continue from eval_done with the current splice */ set_stack_top_args(sc, args); push_stack_op(sc, OP_EVAL_DONE); @@ -70117,8 +70117,8 @@ static s7_pointer splice_out_values(s7_scheme *sc, s7_pointer args) for (s7_pointer p = cdr(args), np = tp; is_pair(p); p = cdr(p)) if (car(p) != sc->no_value) { - set_cdr(np, list_1(sc, car(p))); - np = cdr(np); + set_cdr(np, list_1(sc, car(p))); + np = cdr(np); } sc->temp8 = sc->unused; return(tp); @@ -70137,30 +70137,30 @@ static s7_pointer g_list_values(s7_scheme *sc, s7_pointer args) for (x = args; is_pair(x); x = cdr(x)) if (is_pair(car(x))) { - if (is_checked(car(x))) - checked = true; + if (is_checked(car(x))) + checked = true; } else if (car(x) == sc->no_value) /* unchecked_car|cdr unrolled here is not faster */ - break; + break; if (is_null(x)) { if (!checked) /* (!tree_has_definers(sc, args)) seems to work, reduces copy_tree calls slightly, but costs more than it saves in tgen */ - { - for (s7_pointer p = args; is_pair(p); p = cdr(p)) /* embedded list can be immutable, so we need to copy (sigh) */ - if (is_immutable_pair(p)) - return(copy_proper_list(sc, args)); - return(args); - } + { + for (s7_pointer p = args; is_pair(p); p = cdr(p)) /* embedded list can be immutable, so we need to copy (sigh) */ + if (is_immutable_pair(p)) + return(copy_proper_list(sc, args)); + return(args); + } sc->temp5 = args; check_free_heap_size(sc, 8192); if (sc->safety > NO_SAFETY) - { - if (!tree_is_cyclic(sc, args)) /* we're copying to clear optimizations I think, and a cyclic list here can't be optimized */ - args = cons_unchecked(sc, /* since list-values is a safe function, args can be immutable, which should not be passed through the copy */ - (is_unquoted_pair(car(args))) ? copy_tree_with_type(sc, car(args)) : car(args), - (is_unquoted_pair(cdr(args))) ? copy_tree_with_type(sc, cdr(args)) : cdr(args)); - } + { + if (!tree_is_cyclic(sc, args)) /* we're copying to clear optimizations I think, and a cyclic list here can't be optimized */ + args = cons_unchecked(sc, /* since list-values is a safe function, args can be immutable, which should not be passed through the copy */ + (is_unquoted_pair(car(args))) ? copy_tree_with_type(sc, car(args)) : car(args), + (is_unquoted_pair(cdr(args))) ? copy_tree_with_type(sc, cdr(args)) : cdr(args)); + } else args = copy_tree(sc, args); /* not copy_any_list here -- see comment below */ sc->temp5 = sc->unused; return(args); @@ -70229,24 +70229,24 @@ static bool is_simple_code(s7_scheme *sc, s7_pointer form) for (tmp = form, slow = form; is_pair(tmp); tmp = cdr(tmp), slow = cdr(slow)) { if (is_pair(car(tmp))) - { - if (!is_simple_code(sc, car(tmp))) - return(false); - } + { + if (!is_simple_code(sc, car(tmp))) + return(false); + } else - if (car(tmp) == sc->unquote_symbol) - return(false); + if (car(tmp) == sc->unquote_symbol) + return(false); tmp = cdr(tmp); if (!is_pair(tmp)) return(is_null(tmp)); if (tmp == slow) return(false); if (is_pair(car(tmp))) - { - if (!is_simple_code(sc, car(tmp))) - return(false); - } + { + if (!is_simple_code(sc, car(tmp))) + return(false); + } else - if (car(tmp) == sc->unquote_symbol) - return(false); + if (car(tmp) == sc->unquote_symbol) + return(false); } return(is_null(tmp)); } @@ -70273,13 +70273,13 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) - if (car(form) == sc->unquote_symbol) { if (!is_pair(cdr(form))) /* (unquote) or (unquote . 1) */ - { - if (is_null(cdr(form))) - syntax_error_nr(sc, "unquote: no argument, ~S", 24, form); - syntax_error_nr(sc, "unquote: stray dot, ~S", 22, form); - } + { + if (is_null(cdr(form))) + syntax_error_nr(sc, "unquote: no argument, ~S", 24, form); + syntax_error_nr(sc, "unquote: stray dot, ~S", 22, form); + } if (is_not_null(cddr(form))) - syntax_error_nr(sc, "unquote: too many arguments, ~S", 31, form); + syntax_error_nr(sc, "unquote: too many arguments, ~S", 31, form); return(cadr(form)); } @@ -70298,8 +70298,8 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) - s7_int len = s7_list_length(sc, form); if (len < 0) { - len = -len; - dotted = true; + len = -len; + dotted = true; } gc_protect_via_stack(sc, sc->w); @@ -70311,31 +70311,31 @@ and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) - set_car(sc->w, initial_value(sc->list_values_symbol)); if (!dotted) { - for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq)) - if ((is_pair(cdr(orig))) && /* this was is_pair(orig) which seems to be always the case */ - (cadr(orig) == sc->unquote_symbol)) /* `(1 . ,(+ 1 1)) -> '(1 unquote (+ 1 1)) -> '(1 . 2) etc */ - { - if (!is_pair(cddr(orig))) - { - sc->w = old_scw; - unstack_gc_protect(sc); - syntax_error_nr(sc, "unquote: no argument, ~S", 24, form); - } - set_car(bq, g_quasiquote_1(sc, car(orig), false)); - set_cdr(bq, sc->nil); - sc->w = list_3(sc, initial_value(sc->qq_append_symbol), sc->w, caddr(orig)); /* `(f . ,(string-append "h" "i")) */ - break; - } - else set_car(bq, g_quasiquote_1(sc, car(orig), false)); + for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq)) + if ((is_pair(cdr(orig))) && /* this was is_pair(orig) which seems to be always the case */ + (cadr(orig) == sc->unquote_symbol)) /* `(1 . ,(+ 1 1)) -> '(1 unquote (+ 1 1)) -> '(1 . 2) etc */ + { + if (!is_pair(cddr(orig))) + { + sc->w = old_scw; + unstack_gc_protect(sc); + syntax_error_nr(sc, "unquote: no argument, ~S", 24, form); + } + set_car(bq, g_quasiquote_1(sc, car(orig), false)); + set_cdr(bq, sc->nil); + sc->w = list_3(sc, initial_value(sc->qq_append_symbol), sc->w, caddr(orig)); /* `(f . ,(string-append "h" "i")) */ + break; + } + else set_car(bq, g_quasiquote_1(sc, car(orig), false)); } else /* `(1 2 . 3) */ { - len--; - for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq)) - set_car(bq, g_quasiquote_1(sc, car(orig), false)); - set_car(bq, g_quasiquote_1(sc, car(orig), false)); - sc->w = list_3(sc, initial_value(sc->qq_append_symbol), sc->w, g_quasiquote_1(sc, cdr(orig), false)); - /* quasiquote might quote a symbol in cdr(orig), so it's not completely pointless */ + len--; + for (orig = form, bq = cdr(sc->w), i = 0; i < len; i++, orig = cdr(orig), bq = cdr(bq)) + set_car(bq, g_quasiquote_1(sc, car(orig), false)); + set_car(bq, g_quasiquote_1(sc, car(orig), false)); + sc->w = list_3(sc, initial_value(sc->qq_append_symbol), sc->w, g_quasiquote_1(sc, cdr(orig), false)); + /* quasiquote might quote a symbol in cdr(orig), so it's not completely pointless */ } bq = sc->w; sc->w = old_scw; @@ -70370,7 +70370,7 @@ static s7_pointer g_qq_append(s7_scheme *sc, s7_pointer args) /* -------------------------------- choosers -------------------------------- */ static s7_pointer make_function_with_class(s7_scheme *sc, s7_pointer cls, const char *name, s7_function f, - int32_t required_args, int32_t optional_args, bool rest_arg) + int32_t required_args, int32_t optional_args, bool rest_arg) { s7_pointer uf = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, NULL); s7_function_set_class(sc, uf, cls); @@ -70379,7 +70379,7 @@ static s7_pointer make_function_with_class(s7_scheme *sc, s7_pointer cls, const } static s7_pointer make_unsafe_function_with_class(s7_scheme *sc, s7_pointer cls, const char *name, s7_function f, - int32_t required_args, int32_t optional_args, bool rest_arg) + int32_t required_args, int32_t optional_args, bool rest_arg) { s7_pointer uf = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, NULL); /* was s7_make_safe_function! 14-Dec-20 */ s7_function_set_class(sc, uf, cls); @@ -70734,7 +70734,7 @@ static void pair_set_current_input_location(s7_scheme *sc, s7_pointer p) if (current_input_port(sc) != sc->standard_input) /* (port_file_number(current_input_port(sc)) > 1) -- maybe 0 is legit? */ { pair_set_location(p, port_location(current_input_port(sc))); - set_has_location(p); /* current_input_port(sc) above can't be nil(?) -- it falls back on stdin now */ + set_has_location(p); /* current_input_port(sc) above can't be nil(?) -- it falls back on stdin now */ } } @@ -70801,94 +70801,94 @@ static s7_pointer check_autoload_and_error_hook(s7_scheme *sc, s7_pointer sym) sc->temp7 = cons_unchecked(sc, current_let, cons_unchecked(sc, code, /* perhaps elist_7 except we use elist_3 above? */ cons_unchecked(sc, args, list_4(sc, value, cur_code, x, z)))); /* not s7_list (debugger checks) */ if (!is_pair(cur_code)) - { - /* isolated typo perhaps -- no pair to hold the position info, so make one. current_code(sc) is GC-protected, so this should be safe */ - cur_code = list_1(sc, sym); /* the error will say "(sym)" which is not too misleading */ - pair_set_current_input_location(sc, cur_code); - } + { + /* isolated typo perhaps -- no pair to hold the position info, so make one. current_code(sc) is GC-protected, so this should be safe */ + cur_code = list_1(sc, sym); /* the error will say "(sym)" which is not too misleading */ + pair_set_current_input_location(sc, cur_code); + } #if (!DISABLE_AUTOLOAD) if ((sc->is_autoloading) && - (sc->autoload_names)) /* created by s7_autoload_set_names which requires alphabetization by the caller (e.g. snd-xref.c) */ - { - bool loaded = false; - const char *file = find_autoload_name(sc, sym, &loaded, true); - if ((file) && (!loaded)) - { - /* if we've already loaded this file, we can get the library (e) from a table [(file lib) ...] - * here it was possible to get caught in a loop: - * change file, reload, unbound var seen, check autoload, it says "load file"... (where file does not get added to *libraries*) - * so the "loaded" arg tries to catch such cases - */ - s7_pointer e = loaded_library(sc, file); - if ((!e) || (!is_let(e))) - { - if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, s7_make_string(sc, file))); - e = s7_load(sc, file); /* s7_load can return NULL */ - } - result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ - if ((result == sc->undefined) && (e) && (is_let(e))) - { - /* the current_let refs here are trying to handle local autoloads, but that is problematic -- we'd need to - * save the autoload curlet when autoload is called, and hope the current reference can still access that let? - * but if the same symbol is autloaded in several lets, we are in trouble, and how to handle a function that - * has an autoload? I think I'll just assume rootlet, even though that is not very elegant. Actually in the - * libgsl case, we're trying to export a name from *libgsl* -- should that be done with define rather than autoload? - */ - result = let_ref_p_pp(sc, e, sym); /* add '(sym . result) to current_let (was sc->nil, s7_load can set sc->curlet to sc->nil) */ - if (result != sc->undefined) - s7_define(sc, sc->nil /* current_let */, sym, result); - }}} + (sc->autoload_names)) /* created by s7_autoload_set_names which requires alphabetization by the caller (e.g. snd-xref.c) */ + { + bool loaded = false; + const char *file = find_autoload_name(sc, sym, &loaded, true); + if ((file) && (!loaded)) + { + /* if we've already loaded this file, we can get the library (e) from a table [(file lib) ...] + * here it was possible to get caught in a loop: + * change file, reload, unbound var seen, check autoload, it says "load file"... (where file does not get added to *libraries*) + * so the "loaded" arg tries to catch such cases + */ + s7_pointer e = loaded_library(sc, file); + if ((!e) || (!is_let(e))) + { + if (hook_has_functions(sc->autoload_hook)) + s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, s7_make_string(sc, file))); + e = s7_load(sc, file); /* s7_load can return NULL */ + } + result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ + if ((result == sc->undefined) && (e) && (is_let(e))) + { + /* the current_let refs here are trying to handle local autoloads, but that is problematic -- we'd need to + * save the autoload curlet when autoload is called, and hope the current reference can still access that let? + * but if the same symbol is autloaded in several lets, we are in trouble, and how to handle a function that + * has an autoload? I think I'll just assume rootlet, even though that is not very elegant. Actually in the + * libgsl case, we're trying to export a name from *libgsl* -- should that be done with define rather than autoload? + */ + result = let_ref_p_pp(sc, e, sym); /* add '(sym . result) to current_let (was sc->nil, s7_load can set sc->curlet to sc->nil) */ + if (result != sc->undefined) + s7_define(sc, sc->nil /* current_let */, sym, result); + }}} #endif if (result == sc->undefined) - { + { #if (!DISABLE_AUTOLOAD) - /* check the *autoload* hash table */ - if ((sc->is_autoloading) && - (is_hash_table(sc->autoload_table))) - { - /* it was possible to get in a loop here: missing paren in x.scm, checks last symbol, sees - * autoload sym -> x.scm, loads x.scm, missing paren... - */ - s7_pointer val = s7_hash_table_ref(sc, sc->autoload_table, sym); - s7_pointer e = NULL; - if (is_string(val)) /* val should be a filename. *load-path* is searched if necessary */ - { - if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, val)); - e = s7_load(sc, string_value(val)); - } - else - if (is_closure(val)) /* val should be a function of one argument, the current (calling) environment */ - { - if (hook_has_functions(sc->autoload_hook)) - s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, val)); - e = s7_call(sc, val, set_ulist_1(sc, sc->curlet, sc->nil)); - } - result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ - if ((result == sc->undefined) && (e) && (is_let(e))) /* added 31-Mar-23 to match sc->autoload_names case above */ - { - result = let_ref_p_pp(sc, e, sym); - if (result != sc->undefined) - s7_define(sc, sc->nil /* current_let */, sym, result); /* as above, was sc->nil -- s7_load above can set sc->curlet to sc->nil */ - }} -#endif - /* check *unbound-variable-hook* */ - if ((result == sc->undefined) && - (is_procedure(sc->unbound_variable_hook)) && - (hook_has_functions(sc->unbound_variable_hook))) - { - /* (let () (set! (hook-functions *unbound-variable-hook*) (list (lambda (v) _asdf_))) _asdf_) */ - s7_pointer old_hook = sc->unbound_variable_hook; - bool old_history_enabled = s7_set_history_enabled(sc, false); - gc_protect_via_stack(sc, old_hook); - sc->unbound_variable_hook = sc->nil; - result = s7_call(sc, old_hook, set_plist_1(sc, sym)); /* not s7_apply_function */ - if (result == sc->unspecified) result = sc->undefined; - sc->unbound_variable_hook = old_hook; - s7_set_history_enabled(sc, old_history_enabled); - unstack_gc_protect(sc); - }} + /* check the *autoload* hash table */ + if ((sc->is_autoloading) && + (is_hash_table(sc->autoload_table))) + { + /* it was possible to get in a loop here: missing paren in x.scm, checks last symbol, sees + * autoload sym -> x.scm, loads x.scm, missing paren... + */ + s7_pointer val = s7_hash_table_ref(sc, sc->autoload_table, sym); + s7_pointer e = NULL; + if (is_string(val)) /* val should be a filename. *load-path* is searched if necessary */ + { + if (hook_has_functions(sc->autoload_hook)) + s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, val)); + e = s7_load(sc, string_value(val)); + } + else + if (is_closure(val)) /* val should be a function of one argument, the current (calling) environment */ + { + if (hook_has_functions(sc->autoload_hook)) + s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, val)); + e = s7_call(sc, val, set_ulist_1(sc, sc->curlet, sc->nil)); + } + result = s7_symbol_value(sc, sym); /* calls lookup, does not trigger unbound_variable search */ + if ((result == sc->undefined) && (e) && (is_let(e))) /* added 31-Mar-23 to match sc->autoload_names case above */ + { + result = let_ref_p_pp(sc, e, sym); + if (result != sc->undefined) + s7_define(sc, sc->nil /* current_let */, sym, result); /* as above, was sc->nil -- s7_load above can set sc->curlet to sc->nil */ + }} +#endif + /* check *unbound-variable-hook* */ + if ((result == sc->undefined) && + (is_procedure(sc->unbound_variable_hook)) && + (hook_has_functions(sc->unbound_variable_hook))) + { + /* (let () (set! (hook-functions *unbound-variable-hook*) (list (lambda (v) _asdf_))) _asdf_) */ + s7_pointer old_hook = sc->unbound_variable_hook; + bool old_history_enabled = s7_set_history_enabled(sc, false); + gc_protect_via_stack(sc, old_hook); + sc->unbound_variable_hook = sc->nil; + result = s7_call(sc, old_hook, set_plist_1(sc, sym)); /* not s7_apply_function */ + if (result == sc->unspecified) result = sc->undefined; + sc->unbound_variable_hook = old_hook; + s7_set_history_enabled(sc, old_history_enabled); + unstack_gc_protect(sc); + }} sc->value = T_Ext(value); sc->args = T_Pos(args); /* can be #<unused> or #<counter>! */ sc->code = code; @@ -70939,7 +70939,7 @@ static void fx_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 (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, e: %s\n", - __func__, __LINE__, display_truncated(expr), display(func), hop, display_truncated(e)); + __func__, __LINE__, display_truncated(expr), display(func), hop, display_truncated(e)); if ((hop != 1) && (is_constant_symbol(sc, car(expr)))) hop = 1; if ((is_closure(func)) || (is_closure_star(func))) @@ -70950,56 +70950,56 @@ static opt_t optimize_thunk(s7_scheme *sc, s7_pointer expr, s7_pointer func, int if (is_immutable(func)) hop = 1; if (is_null(closure_args(func))) /* no rest arg funny business */ - { - set_optimized(expr); - if ((one_form) && (safe_case) && (is_fxable(sc, car(body)))) /* fx stuff is not set yet */ - { - fx_annotate_arg(sc, body, e); - set_optimize_op(expr, hop + OP_SAFE_THUNK_A); - set_closure_one_form_fx_arg(func); - set_opt1_lambda_add(expr, func); - return(OPT_T); - } - /* thunks with fully fxable bodies are rare apparently, and the time spent here overwhelms run time gains */ - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_THUNK : ((one_form) ? OP_THUNK_O : OP_THUNK))); - set_opt1_lambda_add(expr, func); - return((safe_case) ? OPT_T : OPT_F); - } + { + set_optimized(expr); + if ((one_form) && (safe_case) && (is_fxable(sc, car(body)))) /* fx stuff is not set yet */ + { + fx_annotate_arg(sc, body, e); + set_optimize_op(expr, hop + OP_SAFE_THUNK_A); + set_closure_one_form_fx_arg(func); + set_opt1_lambda_add(expr, func); + return(OPT_T); + } + /* thunks with fully fxable bodies are rare apparently, and the time spent here overwhelms run time gains */ + set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_THUNK : ((one_form) ? OP_THUNK_O : OP_THUNK))); + set_opt1_lambda_add(expr, func); + return((safe_case) ? OPT_T : OPT_F); + } if (is_symbol(closure_args(func))) /* (define* (f1 . a) ...) called (f1) -- called a closure (not closure*) in define_unchecked */ - { - set_opt1_lambda_add(expr, func); - if (safe_case) - { - if (!has_fx(body)) - { - fx_annotate_args(sc, body, e); - fx_tree(sc, body, closure_args(func), NULL, NULL, false); - } - set_safe_optimize_op(expr, hop + OP_SAFE_THUNK_ANY); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + OP_THUNK_ANY); /* "thunk" because here it is called with no args, I guess */ - return(OPT_F); - } + { + set_opt1_lambda_add(expr, func); + if (safe_case) + { + if (!has_fx(body)) + { + fx_annotate_args(sc, body, e); + fx_tree(sc, body, closure_args(func), NULL, NULL, false); + } + set_safe_optimize_op(expr, hop + OP_SAFE_THUNK_ANY); + return(OPT_T); + } + set_unsafe_optimize_op(expr, hop + OP_THUNK_ANY); /* "thunk" because here it is called with no args, I guess */ + return(OPT_F); + } if (is_closure_star(func)) - { - set_opt1_lambda_add(expr, func); - set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_0 : OP_CLOSURE_STAR_NA)); - } + { + set_opt1_lambda_add(expr, func); + set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_0 : OP_CLOSURE_STAR_NA)); + } return(OPT_F); } if (is_c_function(func)) { if (c_function_min_args(func) != 0) - return(OPT_F); + return(OPT_F); if ((hop == 0) && (symbol_id(car(expr)) == 0)) hop = 1; if (is_safe_procedure(func)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); - choose_c_function(sc, expr, func, 0); - return(OPT_T); - } + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); + choose_c_function(sc, expr, func, 0); + return(OPT_T); + } set_unsafe_optimize_op(expr, hop + OP_C); choose_c_function(sc, expr, func, 0); return(OPT_F); @@ -71019,116 +71019,116 @@ static int32_t combine_ops(s7_scheme *sc, s7_pointer expr, combine_op_t cop, s7_ { case E_C_P: switch (op_no_hop(e1)) - { - case OP_SAFE_C_S: return(OP_SAFE_C_opSq); - case OP_SAFE_C_NC: return(OP_SAFE_C_opNCq); - case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq); - case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq); - 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); - case OP_SAFE_C_SS: - set_opt3_sym(expr, cadr(e1)); - set_opt1_sym(cdr(expr), caddr(e1)); - return(OP_SAFE_C_opSSq); - case OP_SAFE_C_opSq: - set_opt3_pair(expr, cadr(e1)); - set_opt3_sym(cdr(expr), cadadr(e1)); - return(OP_SAFE_C_op_opSqq); - case OP_SAFE_C_S_opSq: - set_opt3_pair(expr, caddr(e1)); - return(OP_SAFE_C_op_S_opSqq); - case OP_SAFE_C_opSq_S: - set_opt3_pair(expr, cadr(e1)); - return(OP_SAFE_C_op_opSq_Sq); - } + { + case OP_SAFE_C_S: return(OP_SAFE_C_opSq); + case OP_SAFE_C_NC: return(OP_SAFE_C_opNCq); + case OP_SAFE_C_SC: return(OP_SAFE_C_opSCq); + case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq); + 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); + case OP_SAFE_C_SS: + set_opt3_sym(expr, cadr(e1)); + set_opt1_sym(cdr(expr), caddr(e1)); + return(OP_SAFE_C_opSSq); + case OP_SAFE_C_opSq: + set_opt3_pair(expr, cadr(e1)); + set_opt3_sym(cdr(expr), cadadr(e1)); + return(OP_SAFE_C_op_opSqq); + case OP_SAFE_C_S_opSq: + set_opt3_pair(expr, caddr(e1)); + return(OP_SAFE_C_op_S_opSqq); + case OP_SAFE_C_opSq_S: + set_opt3_pair(expr, cadr(e1)); + return(OP_SAFE_C_op_opSq_Sq); + } return(OP_SAFE_C_P); /* this splits out to A in optimize_func one_arg */ case E_C_SP: switch (op_no_hop(e2)) - { - case OP_SAFE_C_S: return(OP_SAFE_C_S_opSq); - case OP_SAFE_C_AA: return(OP_SAFE_C_S_opAAq); - case OP_SAFE_C_SC: - set_opt2_con(cdr(expr), caddr(e2)); - return(OP_SAFE_C_S_opSCq); - case OP_SAFE_C_CS: /* expr is (* a (- 1 b)), e2 is (- 1 b) */ - set_opt2_sym(cdr(expr), caddr(e2)); - return(OP_SAFE_C_S_opCSq); - case OP_SAFE_C_SS: /* (* a (- b c)) */ - set_opt2_sym(cdr(expr), caddr(e2)); - return(OP_SAFE_C_S_opSSq); - case OP_SAFE_C_A: - set_opt3_pair(expr, cdaddr(expr)); - return(OP_SAFE_C_S_opAq); - } + { + case OP_SAFE_C_S: return(OP_SAFE_C_S_opSq); + case OP_SAFE_C_AA: return(OP_SAFE_C_S_opAAq); + case OP_SAFE_C_SC: + set_opt2_con(cdr(expr), caddr(e2)); + return(OP_SAFE_C_S_opSCq); + case OP_SAFE_C_CS: /* expr is (* a (- 1 b)), e2 is (- 1 b) */ + set_opt2_sym(cdr(expr), caddr(e2)); + return(OP_SAFE_C_S_opCSq); + case OP_SAFE_C_SS: /* (* a (- b c)) */ + set_opt2_sym(cdr(expr), caddr(e2)); + return(OP_SAFE_C_S_opSSq); + case OP_SAFE_C_A: + set_opt3_pair(expr, cdaddr(expr)); + return(OP_SAFE_C_S_opAq); + } return(OP_SAFE_C_SP); /* if fxable -> AA later */ case E_C_PS: switch (op_no_hop(e1)) - { - case OP_SAFE_C_S: - set_opt1_sym(cdr(expr), cadr(e1)); - set_opt3_sym(expr, e2); - return(OP_SAFE_C_opSq_S); - case OP_SAFE_C_SS: return(OP_SAFE_C_opSSq_S); - case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq_S); - case OP_SAFE_C_A: return(OP_SAFE_C_opAq_S); - case OP_SAFE_C_opSSq: - set_opt1_pair(cdr(expr), cadadr(expr)); - set_opt3_pair(expr, cadr(e1)); - return(OP_SAFE_C_op_opSSqq_S); - } + { + case OP_SAFE_C_S: + set_opt1_sym(cdr(expr), cadr(e1)); + set_opt3_sym(expr, e2); + return(OP_SAFE_C_opSq_S); + case OP_SAFE_C_SS: return(OP_SAFE_C_opSSq_S); + case OP_SAFE_C_CS: return(OP_SAFE_C_opCSq_S); + case OP_SAFE_C_A: return(OP_SAFE_C_opAq_S); + case OP_SAFE_C_opSSq: + set_opt1_pair(cdr(expr), cadadr(expr)); + set_opt3_pair(expr, cadr(e1)); + return(OP_SAFE_C_op_opSSqq_S); + } return(OP_SAFE_C_PS); case E_C_PC: switch (op_no_hop(e1)) - { - case OP_SAFE_C_S: - set_opt1_sym(cdr(expr), cadr(e1)); - set_opt2_con(cdr(expr), e2); - 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_SS: - set_opt3_con(cdr(expr), caddr(expr)); - return(OP_SAFE_C_opSSq_C); - } + { + case OP_SAFE_C_S: + set_opt1_sym(cdr(expr), cadr(e1)); + set_opt2_con(cdr(expr), e2); + 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_SS: + set_opt3_con(cdr(expr), caddr(expr)); + return(OP_SAFE_C_opSSq_C); + } set_opt3_con(cdr(expr), caddr(expr)); return(OP_SAFE_C_PC); case E_C_CP: switch (op_no_hop(e2)) - { - case OP_SAFE_C_S: - set_opt3_pair(expr, e2); - return(OP_SAFE_C_C_opSq); - case OP_SAFE_C_SC: - set_opt1_sym(cdr(expr), cadr(e2)); - set_opt2_con(cdr(expr), caddr(e2)); - return(OP_SAFE_C_C_opSCq); - case OP_SAFE_C_SS: - set_opt1_sym(cdr(expr), cadr(e2)); - return(OP_SAFE_C_C_opSSq); - } + { + case OP_SAFE_C_S: + set_opt3_pair(expr, e2); + return(OP_SAFE_C_C_opSq); + case OP_SAFE_C_SC: + set_opt1_sym(cdr(expr), cadr(e2)); + set_opt2_con(cdr(expr), caddr(e2)); + return(OP_SAFE_C_C_opSCq); + case OP_SAFE_C_SS: + set_opt1_sym(cdr(expr), cadr(e2)); + return(OP_SAFE_C_C_opSSq); + } return(OP_SAFE_C_CP); case E_C_PP: switch (op_no_hop(e2)) - { - case OP_SAFE_C_S: - if (is_safe_c_s(e1)) - return(OP_SAFE_C_opSq_opSq); - if (optimize_op_match(e1, OP_SAFE_C_SS)) - return(OP_SAFE_C_opSSq_opSq); - break; - case OP_SAFE_C_SS: - if (optimize_op_match(e1, OP_SAFE_C_SS)) - return(OP_SAFE_C_opSSq_opSSq); - if (is_safe_c_s(e1)) - return(OP_SAFE_C_opSq_opSSq); - break; - } + { + case OP_SAFE_C_S: + if (is_safe_c_s(e1)) + return(OP_SAFE_C_opSq_opSq); + if (optimize_op_match(e1, OP_SAFE_C_SS)) + return(OP_SAFE_C_opSSq_opSq); + break; + case OP_SAFE_C_SS: + if (optimize_op_match(e1, OP_SAFE_C_SS)) + return(OP_SAFE_C_opSSq_opSSq); + if (is_safe_c_s(e1)) + return(OP_SAFE_C_opSq_opSSq); + break; + } return(OP_SAFE_C_PP); default: break; @@ -71140,7 +71140,7 @@ static bool arg_findable(s7_scheme *sc, s7_pointer arg1, s7_pointer e) { if (pair_symbol_is_safe(sc, arg1, e)) return(true); /* includes global_slot check */ return((!sc->in_with_let) && - (is_slot(s7_slot(sc, arg1)))); + (is_slot(s7_slot(sc, arg1)))); } static bool safe_c_aa_to_ag_ga(s7_scheme *sc, s7_pointer arg, int32_t hop) @@ -71172,14 +71172,14 @@ static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int3 if (is_c_function(func)) { set_safe_optimize_op(expr, hop + ((is_safe_procedure(func)) ? - ((n_args == 1) ? OP_SAFE_C_A : OP_SAFE_C_AA) : - ((n_args == 1) ? ((is_semisafe(func)) ? OP_CL_A : OP_C_A) : - ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)))); + ((n_args == 1) ? OP_SAFE_C_A : OP_SAFE_C_AA) : + ((n_args == 1) ? ((is_semisafe(func)) ? OP_CL_A : OP_C_A) : + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)))); if (op_no_hop(expr) == OP_SAFE_C_AA) - { - set_opt3_pair(expr, cddr(expr)); - if (optimize_op(expr) == HOP_SAFE_C_AA) return(check_c_aa(sc, expr, func, hop, e)); - } + { + set_opt3_pair(expr, cddr(expr)); + if (optimize_op(expr) == HOP_SAFE_C_AA) return(check_c_aa(sc, expr, func, hop, e)); + } set_c_function(expr, func); return(OPT_T); } @@ -71191,13 +71191,13 @@ static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int3 set_unsafely_optimized(expr); set_opt1_lambda_add(expr, func); if (one_form) - set_optimize_op(expr, hop + ((safe_case) ? - ((n_args == 1) ? OP_SAFE_CLOSURE_A_O : OP_SAFE_CLOSURE_AA_O) : - ((n_args == 1) ? OP_CLOSURE_A_O : OP_CLOSURE_AA_O))); + set_optimize_op(expr, hop + ((safe_case) ? + ((n_args == 1) ? OP_SAFE_CLOSURE_A_O : OP_SAFE_CLOSURE_AA_O) : + ((n_args == 1) ? OP_CLOSURE_A_O : OP_CLOSURE_AA_O))); else - set_optimize_op(expr, hop + ((safe_case) ? - ((n_args == 1) ? OP_SAFE_CLOSURE_A : OP_SAFE_CLOSURE_AA) : - ((n_args == 1) ? OP_CLOSURE_A : OP_CLOSURE_AA))); + set_optimize_op(expr, hop + ((safe_case) ? + ((n_args == 1) ? OP_SAFE_CLOSURE_A : OP_SAFE_CLOSURE_AA) : + ((n_args == 1) ? OP_CLOSURE_A : OP_CLOSURE_AA))); return(OPT_F); } if ((is_closure_star(func)) && @@ -71207,12 +71207,12 @@ static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int3 { set_unsafely_optimized(expr); if (n_args == 1) - set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); + set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); else - if (closure_star_arity_to_int(sc, func) == 2) - set_optimize_op(expr, ((is_safe_closure(func)) ? ((is_null(cdr(closure_body(func)))) ? OP_SAFE_CLOSURE_STAR_AA_O : - OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_NA)); - else set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA)); + if (closure_star_arity_to_int(sc, func) == 2) + set_optimize_op(expr, ((is_safe_closure(func)) ? ((is_null(cdr(closure_body(func)))) ? OP_SAFE_CLOSURE_STAR_AA_O : + OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_NA)); + else set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA)); set_opt1_lambda_add(expr, func); } return(OPT_F); @@ -71246,10 +71246,10 @@ static inline s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer sym for (; x; x = let_outlet(x)) { if (let_id(x) == id) - return(local_slot(symbol)); + return(local_slot(symbol)); for (s7_pointer y = let_slots(x); tis_slot(y); y = next_slot(y)) - if (slot_symbol(y) == symbol) - return(y); + if (slot_symbol(y) == symbol) + return(y); } return(global_slot(symbol)); /* it's no longer global perhaps (local definition now inaccessible) */ } @@ -71257,10 +71257,10 @@ static inline s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer sym static bool is_ok_lambda(s7_scheme *sc, s7_pointer arg2) { return((is_pair(arg2)) && - (is_lambda(sc, car(arg2))) && /* must start (lambda ...) */ - (is_pair(cdr(arg2))) && /* must have arg(s) */ - (is_pair(cddr(arg2))) && /* must have body */ - (s7_is_proper_list(sc, cdddr(arg2)))); + (is_lambda(sc, car(arg2))) && /* must start (lambda ...) */ + (is_pair(cdr(arg2))) && /* must have arg(s) */ + (is_pair(cddr(arg2))) && /* must have body */ + (s7_is_proper_list(sc, cdddr(arg2)))); } static bool hop_if_constant(s7_scheme *sc, s7_pointer sym) @@ -71269,7 +71269,7 @@ static bool hop_if_constant(s7_scheme *sc, s7_pointer sym) } static opt_t optimize_c_function_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer func, - int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) + int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) { s7_pointer arg1 = cadr(expr); bool func_is_safe = is_safe_procedure(func); @@ -71278,25 +71278,25 @@ static opt_t optimize_c_function_one_arg(s7_scheme *sc, s7_pointer expr, s7_poin if (pairs == 0) { if (func_is_safe) /* safe c function */ - { - set_safe_optimize_op(expr, hop + ((symbols == 0) ? OP_SAFE_C_NC : OP_SAFE_C_S)); - choose_c_function(sc, expr, func, 1); - return(OPT_T); - } + { + set_safe_optimize_op(expr, hop + ((symbols == 0) ? OP_SAFE_C_NC : OP_SAFE_C_S)); + choose_c_function(sc, expr, func, 1); + return(OPT_T); + } /* c function is not safe */ if (symbols == 0) - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); /* OP_C_C never happens */ - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - } + { + set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); /* OP_C_C never happens */ + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), 1); + } else - { - set_unsafely_optimized(expr); - if (c_function_call(func) == g_read) - set_optimize_op(expr, hop + OP_READ_S); - else set_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_S : OP_C_S)); - } + { + set_unsafely_optimized(expr); + if (c_function_call(func) == g_read) + set_optimize_op(expr, hop + OP_READ_S); + else set_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_S : OP_C_S)); + } choose_c_function(sc, expr, func, 1); return(OPT_F); } @@ -71304,83 +71304,83 @@ static opt_t optimize_c_function_one_arg(s7_scheme *sc, s7_pointer expr, s7_poin if (bad_pairs == 0) { if (func_is_safe) - { - int32_t op = combine_ops(sc, expr, E_C_P, arg1, NULL); - /* if ((hop == 1) && (!op_has_hop(arg1))) hop = 0; *//* probably not the right way to fix this (s7test tc_or_a_and_a_a_la) */ - set_safe_optimize_op(expr, hop + op); - - if ((op == OP_SAFE_C_P) && - (is_fxable(sc, arg1))) - { - set_optimize_op(expr, hop + OP_SAFE_C_A); - fx_annotate_arg(sc, cdr(expr), e); - } - choose_c_function(sc, expr, func, 1); - return(OPT_T); - } + { + int32_t op = combine_ops(sc, expr, E_C_P, arg1, NULL); + /* if ((hop == 1) && (!op_has_hop(arg1))) hop = 0; *//* probably not the right way to fix this (s7test tc_or_a_and_a_a_la) */ + set_safe_optimize_op(expr, hop + op); + + if ((op == OP_SAFE_C_P) && + (is_fxable(sc, arg1))) + { + set_optimize_op(expr, hop + OP_SAFE_C_A); + fx_annotate_arg(sc, cdr(expr), e); + } + choose_c_function(sc, expr, func, 1); + return(OPT_T); + } if (is_fxable(sc, arg1)) - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - choose_c_function(sc, expr, func, 1); - return(OPT_F); - }} + { + set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), 1); + choose_c_function(sc, expr, func, 1); + return(OPT_F); + }} else /* bad_pairs == 1 */ { if (quotes == 1) - { - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - if (func_is_safe) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_A); - choose_c_function(sc, expr, func, 1); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); - choose_c_function(sc, expr, func, 1); - return(OPT_F); - } + { + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), 1); + if (func_is_safe) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_A); + choose_c_function(sc, expr, func, 1); + return(OPT_T); + } + set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); + choose_c_function(sc, expr, func, 1); + return(OPT_F); + } /* quotes == 0 */ if (!func_is_safe) - { - s7_pointer lambda_expr = arg1; - if ((is_ok_lambda(sc, lambda_expr)) && - (!direct_memq(car(lambda_expr), e))) /* (let ((lambda #f)) (call-with-exit (lambda ...))) */ - { - if (((c_function_call(func) == g_call_with_exit) || - (c_function_call(func) == g_call_cc) || - (c_function_call(func) == g_call_with_output_string)) && - (is_proper_list_1(sc, cadr(lambda_expr))) && - (is_symbol(caadr(lambda_expr))) && - (!is_probably_constant(caadr(lambda_expr)))) /* (call-with-exit (lambda (pi) ...) */ - { - if (c_function_call(func) == g_call_cc) - set_unsafe_optimize_op(expr, OP_CALL_CC); - else - if (c_function_call(func) == g_call_with_exit) - set_unsafe_optimize_op(expr, (is_null(cdddr(lambda_expr))) ? OP_CALL_WITH_EXIT_O : OP_CALL_WITH_EXIT); - else - { - set_unsafe_optimize_op(expr, OP_CALL_WITH_OUTPUT_STRING); - set_opt2_pair(expr, cddr(lambda_expr)); - set_opt3_sym(expr, caadr(lambda_expr)); - set_local(caadr(lambda_expr)); - return(OPT_F); - } - choose_c_function(sc, expr, func, 1); - set_opt2_pair(expr, cdr(lambda_expr)); - set_local(caadr(lambda_expr)); /* check_lambda_args normally handles this, but if hop==1, we'll skip that step */ - return(OPT_F); - } - if ((c_function_call(func) == g_with_output_to_string) && - (is_null(cadr(lambda_expr)))) - { - set_unsafe_optimize_op(expr, OP_WITH_OUTPUT_TO_STRING); - set_opt2_pair(expr, cddr(lambda_expr)); - return(OPT_F); - }}}} + { + s7_pointer lambda_expr = arg1; + if ((is_ok_lambda(sc, lambda_expr)) && + (!direct_memq(car(lambda_expr), e))) /* (let ((lambda #f)) (call-with-exit (lambda ...))) */ + { + if (((c_function_call(func) == g_call_with_exit) || + (c_function_call(func) == g_call_cc) || + (c_function_call(func) == g_call_with_output_string)) && + (is_proper_list_1(sc, cadr(lambda_expr))) && + (is_symbol(caadr(lambda_expr))) && + (!is_probably_constant(caadr(lambda_expr)))) /* (call-with-exit (lambda (pi) ...) */ + { + if (c_function_call(func) == g_call_cc) + set_unsafe_optimize_op(expr, OP_CALL_CC); + else + if (c_function_call(func) == g_call_with_exit) + set_unsafe_optimize_op(expr, (is_null(cdddr(lambda_expr))) ? OP_CALL_WITH_EXIT_O : OP_CALL_WITH_EXIT); + else + { + set_unsafe_optimize_op(expr, OP_CALL_WITH_OUTPUT_STRING); + set_opt2_pair(expr, cddr(lambda_expr)); + set_opt3_sym(expr, caadr(lambda_expr)); + set_local(caadr(lambda_expr)); + return(OPT_F); + } + choose_c_function(sc, expr, func, 1); + set_opt2_pair(expr, cdr(lambda_expr)); + set_local(caadr(lambda_expr)); /* check_lambda_args normally handles this, but if hop==1, we'll skip that step */ + return(OPT_F); + } + if ((c_function_call(func) == g_with_output_to_string) && + (is_null(cadr(lambda_expr)))) + { + set_unsafe_optimize_op(expr, OP_WITH_OUTPUT_TO_STRING); + set_opt2_pair(expr, cddr(lambda_expr)); + return(OPT_F); + }}}} set_unsafe_optimize_op(expr, hop + ((func_is_safe) ? OP_SAFE_C_P : OP_C_P)); choose_c_function(sc, expr, func, 1); return(OPT_F); @@ -71392,15 +71392,15 @@ static bool walk_fxable(s7_scheme *sc, s7_pointer tree) { s7_pointer q = car(p); if ((is_pair(q)) && - (is_optimized(q))) - { - opcode_t op = optimize_op(q); - if (is_safe_c_op(op)) return(true); - if ((op >= OP_TC_AND_A_OR_A_LA) || - ((op >= OP_THUNK) && (op < OP_BEGIN)) || - (!walk_fxable(sc, q))) - return(false); - }} + (is_optimized(q))) + { + opcode_t op = optimize_op(q); + if (is_safe_c_op(op)) return(true); + if ((op >= OP_TC_AND_A_OR_A_LA) || + ((op >= OP_THUNK) && (op < OP_BEGIN)) || + (!walk_fxable(sc, q))) + return(false); + }} return(true); } @@ -71410,8 +71410,8 @@ static bool is_safe_fxable(s7_scheme *sc, s7_pointer p) if (is_optimized(p)) { if ((fx_function[optimize_op(p)]) && - (walk_fxable(sc, (p)))) - return(true); + (walk_fxable(sc, (p)))) + return(true); } if (is_proper_quote(sc, p)) return(true); if ((S7_DEBUGGING) && (is_optimized(p)) && (fx_function[optimize_op(p)])) fprintf(stderr, "omit %s: %s\n", op_names[optimize_op(p)], display(p)); @@ -71427,23 +71427,23 @@ static opt_t fxify_closure_s(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7 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); + 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 = caddar(body); - set_opt3_con(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_SC); - if ((caar(body) == sc->vector_ref_symbol) && (is_global(sc->vector_ref_symbol))) - set_fx_direct(cdr(expr), fx_safe_closure_s_to_vref); - else - { - set_fx_direct(cdr(expr), fx_safe_closure_s_to_sc); - if ((is_t_integer(body_arg2)) && (integer(body_arg2) == 1)) - { - if (caar(body) == sc->subtract_symbol) set_fx_direct(cdr(expr), fx_safe_closure_s_to_sub1); - if (caar(body) == sc->add_symbol) set_fx_direct(cdr(expr), fx_safe_closure_s_to_add1); - }}}} + if (optimize_op(car(body)) == HOP_SAFE_C_SC) + { + s7_pointer body_arg2 = caddar(body); + set_opt3_con(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_SC); + if ((caar(body) == sc->vector_ref_symbol) && (is_global(sc->vector_ref_symbol))) + set_fx_direct(cdr(expr), fx_safe_closure_s_to_vref); + else + { + set_fx_direct(cdr(expr), fx_safe_closure_s_to_sc); + if ((is_t_integer(body_arg2)) && (integer(body_arg2) == 1)) + { + if (caar(body) == sc->subtract_symbol) set_fx_direct(cdr(expr), fx_safe_closure_s_to_sub1); + if (caar(body) == sc->add_symbol) set_fx_direct(cdr(expr), fx_safe_closure_s_to_add1); + }}}} set_closure_one_form_fx_arg(func); fx_tree(sc, body, car(closure_args(func)), NULL, NULL, false); return(OPT_T); @@ -71458,29 +71458,29 @@ static bool fxify_closure_a(s7_scheme *sc, s7_pointer func, bool one_form, bool set_optimize_op(expr, hop + OP_CLOSURE_A_O); else { - s7_pointer body = closure_body(func); - if (!is_fxable(sc, car(body))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_O); - else - { - fx_annotate_arg(sc, body, e); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_A); - if ((is_pair(car(body))) && - (optimize_op(car(body)) == HOP_SAFE_C_SC) && - (car(closure_args(func)) == cadar(body))) - { - s7_pointer body_arg2 = caddar(body); - set_opt3_con(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_TO_SC); - /* why is this setting expr whereas _s case above sets cdr(expr)? */ - if ((caar(body) == sc->vector_ref_symbol) && (is_global(sc->vector_ref_symbol))) - set_fx_direct(expr, fx_safe_closure_a_to_vref); - else set_fx_direct(expr, fx_safe_closure_a_to_sc); - } - set_closure_one_form_fx_arg(func); - fx_tree(sc, body, car(closure_args(func)), NULL, NULL, false); - return(true); - }} + s7_pointer body = closure_body(func); + if (!is_fxable(sc, car(body))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_O); + else + { + fx_annotate_arg(sc, body, e); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_A); + if ((is_pair(car(body))) && + (optimize_op(car(body)) == HOP_SAFE_C_SC) && + (car(closure_args(func)) == cadar(body))) + { + s7_pointer body_arg2 = caddar(body); + set_opt3_con(cdr(expr), (is_pair(body_arg2)) ? cadr(body_arg2) : body_arg2); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_A_TO_SC); + /* why is this setting expr whereas _s case above sets cdr(expr)? */ + if ((caar(body) == sc->vector_ref_symbol) && (is_global(sc->vector_ref_symbol))) + set_fx_direct(expr, fx_safe_closure_a_to_vref); + else set_fx_direct(expr, fx_safe_closure_a_to_sc); + } + set_closure_one_form_fx_arg(func); + fx_tree(sc, body, car(closure_args(func)), NULL, NULL, false); + return(true); + }} return(false); } @@ -71495,10 +71495,10 @@ static opt_t optimize_closure_sym(s7_scheme *sc, s7_pointer expr, s7_pointer fun { s7_pointer body = closure_body(func); if (!has_fx(body)) /* does this have any effect? */ - { - fx_annotate_args(sc, body, e); - fx_tree(sc, body, closure_args(func), NULL, NULL, false); - } + { + fx_annotate_args(sc, body, e); + fx_tree(sc, body, closure_args(func), NULL, NULL, false); + } set_safe_optimize_op(expr, hop + OP_ANY_CLOSURE_SYM); return(OPT_T); } @@ -71516,10 +71516,10 @@ static opt_t optimize_closure_a_sym(s7_scheme *sc, s7_pointer expr, s7_pointer f { s7_pointer body = closure_body(func); if (!has_fx(body)) /* does this have any effect? */ - { - fx_annotate_args(sc, body, e); - fx_tree(sc, body, car(closure_args(func)), cdr(closure_args(func)), NULL, false); - } + { + fx_annotate_args(sc, body, e); + fx_tree(sc, body, car(closure_args(func)), cdr(closure_args(func)), NULL, false); + } set_safe_optimize_op(expr, hop + OP_ANY_CLOSURE_A_SYM); return(OPT_T); } @@ -71535,9 +71535,9 @@ static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer if (arit != 1) { if (is_symbol(closure_args(func))) /* (arit == -1) is ambiguous: (define (f . a)...) and (define (f a . b)...) both are -1 here */ - return(optimize_closure_sym(sc, expr, func, hop, 1, e)); + return(optimize_closure_sym(sc, expr, func, hop, 1, e)); if ((arit == -1) && (is_symbol(cdr(closure_args(func))))) - return(optimize_closure_a_sym(sc, expr, func, hop, 1, e)); + return(optimize_closure_a_sym(sc, expr, func, hop, 1, e)); return(OPT_F); } safe_case = is_safe_closure(func); @@ -71550,15 +71550,15 @@ static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer set_opt2_sym(expr, arg1); set_opt1_lambda_add(expr, func); if (one_form) - { - if (safe_case) - { - if (is_fxable(sc, car(body))) - return(fxify_closure_s(sc, func, expr, e, hop)); - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_O); /* tleft 7638 if _O here, 7692 if not (and claims 80 in the begin setup) */ - } - else set_optimize_op(expr, hop + OP_CLOSURE_S_O); - } + { + if (safe_case) + { + if (is_fxable(sc, car(body))) + return(fxify_closure_s(sc, func, expr, e, hop)); + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_O); /* tleft 7638 if _O here, 7692 if not (and claims 80 in the begin setup) */ + } + else set_optimize_op(expr, hop + OP_CLOSURE_S_O); + } else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_S : OP_CLOSURE_S)); set_unsafely_optimized(expr); return(OPT_F); @@ -71586,20 +71586,20 @@ static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer } static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer func, - int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) + int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) { s7_pointer arg1; if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad_pairs: %d, e: %s\n", - __func__, __LINE__, display_truncated(expr), display(func), hop, pairs, symbols, quotes, bad_pairs, display_truncated(e)); + __func__, __LINE__, display_truncated(expr), display(func), hop, pairs, symbols, quotes, bad_pairs, display_truncated(e)); /* very often, expr is already optimized, quoted stuff is counted under "bad_pairs"! as well as quotes */ if (quotes > 0) { if (direct_memq(sc->quote_symbol, e)) - return(OPT_OOPS); + return(OPT_OOPS); if ((bad_pairs == quotes) && - (is_symbol(car(expr))) && - (is_constant_symbol(sc, car(expr)))) - hop = 1; + (is_symbol(car(expr))) && + (is_constant_symbol(sc, car(expr)))) + hop = 1; } arg1 = cadr(expr); /* need in_with_let -> search only rootlet not lookup */ @@ -71608,10 +71608,10 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu { /* wrap the bad arg in a check symbol lookup */ if (s7_is_aritable(sc, func, 1)) - { - set_fx_direct(cdr(expr), fx_unsafe_s); - return(wrap_bad_args(sc, func, expr, 1, hop, e)); - } + { + set_fx_direct(cdr(expr), fx_unsafe_s); + return(wrap_bad_args(sc, func, expr, 1, hop, e)); + } return(OPT_F); } @@ -71627,80 +71627,80 @@ static opt_t optimize_func_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer fu case T_CLOSURE_STAR: if (is_null(closure_args(func))) - return(OPT_F); + return(OPT_F); if (fx_count(sc, expr) == 1) - { - bool safe_case = is_safe_closure(func); - if (is_immutable(func)) hop = 1; - fx_annotate_arg(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 1); - set_unsafely_optimized(expr); - - if ((safe_case) && (is_null(cdr(closure_args(func))))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_A1); - else - 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_NA_1 : OP_CLOSURE_STAR_NA)); - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); - } - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); - } + { + bool safe_case = is_safe_closure(func); + if (is_immutable(func)) hop = 1; + fx_annotate_arg(sc, cdr(expr), e); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), 1); + set_unsafely_optimized(expr); + + if ((safe_case) && (is_null(cdr(closure_args(func))))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_A1); + else + 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_NA_1 : OP_CLOSURE_STAR_NA)); + else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); + } + else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); + } return(OPT_F); case T_C_FUNCTION_STAR: - if ((fx_count(sc, expr) == 1) && - (c_function_max_args(func) >= 1) && - (!is_symbol_and_keyword(arg1))) /* the only arg should not be a keyword (needs error checks later) */ - { - if ((hop == 0) && ((is_immutable(func)) || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) hop = 1; - set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_A); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - set_c_function(expr, func); - return(OPT_T); - } - break; + if ((fx_count(sc, expr) == 1) && + (c_function_max_args(func) >= 1) && + (!is_symbol_and_keyword(arg1))) /* the only arg should not be a keyword (needs error checks later) */ + { + if ((hop == 0) && ((is_immutable(func)) || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) hop = 1; + set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_A); + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), 1); + set_c_function(expr, func); + return(OPT_T); + } + break; case T_PAIR: case T_VECTOR: case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: if (is_fxable(sc, arg1)) - { - set_unsafe_optimize_op(expr, (is_pair(func) ? OP_IMPLICIT_PAIR_REF_A : OP_IMPLICIT_VECTOR_REF_A)); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - return(OPT_T); - } + { + set_unsafe_optimize_op(expr, (is_pair(func) ? OP_IMPLICIT_PAIR_REF_A : OP_IMPLICIT_VECTOR_REF_A)); + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), 1); + return(OPT_T); + } break; case T_LET: if (((quotes == 1) && (is_symbol(cadr(arg1)))) || /* (e 'a) or (e ':a) */ - (is_symbol_and_keyword(arg1))) /* (e :a) */ - { - s7_pointer sym = (quotes == 1) ? cadr(arg1) : arg1; - if (is_keyword(sym)) sym = keyword_symbol(sym); - if (func == sc->s7_starlet) /* (*s7* ...), sc->s7_starlet is a let */ - { - set_safe_optimize_op(expr, OP_IMPLICIT_S7_STARLET_REF_S); - set_opt3_int(expr, s7_starlet_symbol(sym)); - return(OPT_T); - } - set_opt3_con(expr, sym); - set_unsafe_optimize_op(expr, OP_IMPLICIT_LET_REF_C); - return(OPT_T); - } + (is_symbol_and_keyword(arg1))) /* (e :a) */ + { + s7_pointer sym = (quotes == 1) ? cadr(arg1) : arg1; + if (is_keyword(sym)) sym = keyword_symbol(sym); + if (func == sc->s7_starlet) /* (*s7* ...), sc->s7_starlet is a let */ + { + set_safe_optimize_op(expr, OP_IMPLICIT_S7_STARLET_REF_S); + set_opt3_int(expr, s7_starlet_symbol(sym)); + return(OPT_T); + } + set_opt3_con(expr, sym); + set_unsafe_optimize_op(expr, OP_IMPLICIT_LET_REF_C); + return(OPT_T); + } /* fall through */ case T_HASH_TABLE: case T_C_OBJECT: if (is_fxable(sc, arg1)) - { - set_unsafe_optimize_op(expr, (type(func) == T_LET) ? OP_IMPLICIT_LET_REF_A : - ((type(func) == T_HASH_TABLE) ? OP_IMPLICIT_HASH_TABLE_REF_A : OP_IMPLICIT_C_OBJECT_REF_A)); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 1); - return(OPT_T); - } + { + set_unsafe_optimize_op(expr, (type(func) == T_LET) ? OP_IMPLICIT_LET_REF_A : + ((type(func) == T_HASH_TABLE) ? OP_IMPLICIT_HASH_TABLE_REF_A : OP_IMPLICIT_C_OBJECT_REF_A)); + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), 1); + return(OPT_T); + } break; default: @@ -71736,9 +71736,9 @@ static bool two_args_ok(s7_scheme *sc, s7_pointer expr, s7_pointer e) static void opt_sp_1(s7_scheme *sc, s7_function g, s7_pointer expr) { set_opt1_any(cdr(expr), - (s7_pointer)((intptr_t)((g == g_cons) ? OP_SAFE_CONS_SP_1 : - (((g == g_multiply) || (g == g_multiply_2)) ? OP_SAFE_MULTIPLY_SP_1 : - (((g == g_add) || (g == g_add_2)) ? OP_SAFE_ADD_SP_1 : OP_SAFE_C_SP_1))))); + (s7_pointer)((intptr_t)((g == g_cons) ? OP_SAFE_CONS_SP_1 : + (((g == g_multiply) || (g == g_multiply_2)) ? OP_SAFE_MULTIPLY_SP_1 : + (((g == g_add) || (g == g_add_2)) ? OP_SAFE_ADD_SP_1 : OP_SAFE_C_SP_1))))); } static opt_t set_any_c_np(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t num_args, opcode_t op) @@ -71780,26 +71780,26 @@ static void fixup_closure_star_aa(s7_scheme *sc, s7_pointer f, s7_pointer code, else if ((lambda_has_simple_defaults(f)) && (arity == 2)) set_optimize_op(code, hop + ((is_safe_closure(f)) ? ((is_null(cdr(closure_body(f)))) ? OP_SAFE_CLOSURE_STAR_AA_O : - OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_NA)); + OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_NA)); else set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA_2 : OP_CLOSURE_STAR_NA)); } static int32_t check_lambda(s7_scheme *sc, s7_pointer form, bool optl); static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, - int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) + int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) { s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad_pairs: %d, e: %s\n", - __func__, __LINE__, display_truncated(expr), display(func), hop, pairs, symbols, quotes, bad_pairs, display_truncated(e)); + __func__, __LINE__, display_truncated(expr), display(func), hop, pairs, symbols, quotes, bad_pairs, display_truncated(e)); if (quotes > 0) { if (direct_memq(sc->quote_symbol, e)) - return(OPT_OOPS); + return(OPT_OOPS); if ((bad_pairs == quotes) && - (is_symbol(car(expr))) && - (is_constant_symbol(sc, car(expr)))) - hop = 1; + (is_symbol(car(expr))) && + (is_constant_symbol(sc, car(expr)))) + hop = 1; } if (((is_symbol(arg1)) && (!arg_findable(sc, arg1, e))) || @@ -71808,12 +71808,12 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f { /* wrap bad args */ if ((is_fxable(sc, arg1)) && - (is_fxable(sc, arg2)) && - (s7_is_aritable(sc, func, 2))) /* arg_findable key -> #t(?) so clo* ok */ - { - fx_annotate_args(sc, cdr(expr), e); - return(wrap_bad_args(sc, func, expr, 2, hop, e)); - } + (is_fxable(sc, arg2)) && + (s7_is_aritable(sc, func, 2))) /* arg_findable key -> #t(?) so clo* ok */ + { + fx_annotate_args(sc, cdr(expr), e); + return(wrap_bad_args(sc, func, expr, 2, hop, e)); + } return(OPT_F); } /* end of bad symbol wrappers */ @@ -71825,435 +71825,435 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f if (hop == 0) hop = hop_if_constant(sc, car(expr)); if (pairs == 0) - { - if ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) - { - /* another case here: set-car! and set-cdr! are safe if symbols==1 and arg1 is the symbol (i.e. arg2 is a constant) */ - if (symbols == 0) - set_optimize_op(expr, hop + OP_SAFE_C_NC); - else - if (symbols == 2) /* these two symbols are almost never the same, (sqrt (+ (* x x) (* y y))) */ - { - set_optimize_op(expr, hop + OP_SAFE_C_SS); - set_opt2_sym(cdr(expr), arg2); - } - else - if (is_normal_symbol(arg1)) - { - set_opt2_con(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_SC); - } - else - { - set_opt1_con(cdr(expr), arg1); - set_opt2_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_CS); - } - set_optimized(expr); - choose_c_function(sc, expr, func, 2); - return(OPT_T); - } - - set_unsafely_optimized(expr); - if (symbols == 2) - { - if (c_function_call(func) == g_apply) - { - set_optimize_op(expr, OP_APPLY_SS); - set_opt1_cfunc(expr, func); /* not quite set_c_function */ - set_opt2_sym(expr, arg2); - } - else - { - if (is_semisafe(func)) - { - set_opt2_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_CL_SS); - } - else set_optimize_op(expr, hop + OP_C_SS); - choose_c_function(sc, expr, func, 2); - }} - else - { - set_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : - (((symbols == 0) && (pairs == 0) && (car(expr) == sc->values_symbol)) ? OP_C_NC : OP_C_AA))); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - choose_c_function(sc, expr, func, 2); - if (is_safe_procedure(opt1_cfunc(expr))) - { - clear_unsafe(expr); - /* symbols can be 0..2 here, no pairs */ - set_optimized(expr); - if (symbols == 1) - { - if (is_normal_symbol(arg1)) - { - set_optimize_op(expr, hop + OP_SAFE_C_SC); - set_opt2_con(cdr(expr), arg2); - } - else - { - set_opt1_con(cdr(expr), arg1); - set_opt2_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_CS); - }} - return(OPT_T); - }} - return(OPT_F); - } + { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) + { + /* another case here: set-car! and set-cdr! are safe if symbols==1 and arg1 is the symbol (i.e. arg2 is a constant) */ + if (symbols == 0) + set_optimize_op(expr, hop + OP_SAFE_C_NC); + else + if (symbols == 2) /* these two symbols are almost never the same, (sqrt (+ (* x x) (* y y))) */ + { + set_optimize_op(expr, hop + OP_SAFE_C_SS); + set_opt2_sym(cdr(expr), arg2); + } + else + if (is_normal_symbol(arg1)) + { + set_opt2_con(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_SAFE_C_SC); + } + else + { + set_opt1_con(cdr(expr), arg1); + set_opt2_sym(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_SAFE_C_CS); + } + set_optimized(expr); + choose_c_function(sc, expr, func, 2); + return(OPT_T); + } + + set_unsafely_optimized(expr); + if (symbols == 2) + { + if (c_function_call(func) == g_apply) + { + set_optimize_op(expr, OP_APPLY_SS); + set_opt1_cfunc(expr, func); /* not quite set_c_function */ + set_opt2_sym(expr, arg2); + } + else + { + if (is_semisafe(func)) + { + set_opt2_sym(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_CL_SS); + } + else set_optimize_op(expr, hop + OP_C_SS); + choose_c_function(sc, expr, func, 2); + }} + else + { + set_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : + (((symbols == 0) && (pairs == 0) && (car(expr) == sc->values_symbol)) ? OP_C_NC : OP_C_AA))); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), 2); + choose_c_function(sc, expr, func, 2); + if (is_safe_procedure(opt1_cfunc(expr))) + { + clear_unsafe(expr); + /* symbols can be 0..2 here, no pairs */ + set_optimized(expr); + if (symbols == 1) + { + if (is_normal_symbol(arg1)) + { + set_optimize_op(expr, hop + OP_SAFE_C_SC); + set_opt2_con(cdr(expr), arg2); + } + else + { + set_opt1_con(cdr(expr), arg1); + set_opt2_sym(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_SAFE_C_CS); + }} + return(OPT_T); + }} + return(OPT_F); + } /* pairs != 0 */ if ((bad_pairs == 0) && - (pairs == 2)) - { - if ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) - { - int32_t op = combine_ops(sc, expr, E_C_PP, arg1, arg2); - set_safe_optimize_op(expr, hop + op); - if (op == OP_SAFE_C_PP) - { - if (((op_no_hop(cadr(expr))) == OP_SAFE_CLOSURE_S_TO_SC) && - ((op_no_hop(caddr(expr))) == OP_SAFE_CLOSURE_S_TO_SC) && - (is_global(caadr(expr))) && (is_global(caaddr(expr)))) - { - /* ideally this would be OP not HOP, but safe_closure_s_to_sc is too picky */ - /* set_opt3_pair(expr, caddr(expr)); */ /* set_opt3_arglen(cdr(expr), 2); */ - set_safe_optimize_op(expr, HOP_SAFE_C_FF); - } - - 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 (is_fxable(sc, arg1)) - { - if (is_fxable(sc, arg2)) - return(check_c_aa(sc, expr, func, hop, e)); /* AA case */ - set_optimize_op(expr, hop + OP_SAFE_C_AP); - fx_annotate_arg(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - } - else - if (is_fxable(sc, arg2)) - { - set_optimize_op(expr, hop + OP_SAFE_C_PA); - fx_annotate_arg(sc, cddr(expr), e); - set_opt3_arglen(cdr(expr), 2); - }} - choose_c_function(sc, expr, func, 2); /* this might change the op to safe_c_c, so it has to be last */ - return(OPT_T); - }} + (pairs == 2)) + { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) + { + int32_t op = combine_ops(sc, expr, E_C_PP, arg1, arg2); + set_safe_optimize_op(expr, hop + op); + if (op == OP_SAFE_C_PP) + { + if (((op_no_hop(cadr(expr))) == OP_SAFE_CLOSURE_S_TO_SC) && + ((op_no_hop(caddr(expr))) == OP_SAFE_CLOSURE_S_TO_SC) && + (is_global(caadr(expr))) && (is_global(caaddr(expr)))) + { + /* ideally this would be OP not HOP, but safe_closure_s_to_sc is too picky */ + /* set_opt3_pair(expr, caddr(expr)); */ /* set_opt3_arglen(cdr(expr), 2); */ + set_safe_optimize_op(expr, HOP_SAFE_C_FF); + } + + 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 (is_fxable(sc, arg1)) + { + if (is_fxable(sc, arg2)) + return(check_c_aa(sc, expr, func, hop, e)); /* AA case */ + set_optimize_op(expr, hop + OP_SAFE_C_AP); + fx_annotate_arg(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), 2); + } + else + if (is_fxable(sc, arg2)) + { + set_optimize_op(expr, hop + OP_SAFE_C_PA); + fx_annotate_arg(sc, cddr(expr), e); + set_opt3_arglen(cdr(expr), 2); + }} + choose_c_function(sc, expr, func, 2); /* this might change the op to safe_c_c, so it has to be last */ + return(OPT_T); + }} if ((bad_pairs == 0) && - (pairs == 1)) - { - if ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) - { - combine_op_t orig_op; - int32_t op; - - if (is_pair(arg1)) - { - orig_op = (is_normal_symbol(arg2)) ? E_C_PS : E_C_PC; - op = combine_ops(sc, expr, orig_op, arg1, arg2); - } - else - { - orig_op = (is_normal_symbol(arg1)) ? E_C_SP : E_C_CP; - op = combine_ops(sc, expr, orig_op, arg1, arg2); - } - 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)) && - (is_fxable(sc, arg1)))) - { - fx_annotate_args(sc, cdr(expr), e); - if (!safe_c_aa_to_ag_ga(sc, expr, hop)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_AA); - set_opt3_pair(expr, cddr(expr)); - }} - else - { - set_safe_optimize_op(expr, hop + op); - if ((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) - { - opt_sp_1(sc, c_function_call(func), expr); - set_opt3_any(cdr(expr), arg1); - } - else - if (op == OP_SAFE_C_PC) - set_opt3_con(cdr(expr), arg2); - } - choose_c_function(sc, expr, func, 2); - return(OPT_T); - }} + (pairs == 1)) + { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) + { + combine_op_t orig_op; + int32_t op; + + if (is_pair(arg1)) + { + orig_op = (is_normal_symbol(arg2)) ? E_C_PS : E_C_PC; + op = combine_ops(sc, expr, orig_op, arg1, arg2); + } + else + { + orig_op = (is_normal_symbol(arg1)) ? E_C_SP : E_C_CP; + op = combine_ops(sc, expr, orig_op, arg1, arg2); + } + 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)) && + (is_fxable(sc, arg1)))) + { + fx_annotate_args(sc, cdr(expr), e); + if (!safe_c_aa_to_ag_ga(sc, expr, hop)) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_AA); + set_opt3_pair(expr, cddr(expr)); + }} + else + { + set_safe_optimize_op(expr, hop + op); + if ((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) + { + opt_sp_1(sc, c_function_call(func), expr); + set_opt3_any(cdr(expr), arg1); + } + else + if (op == OP_SAFE_C_PC) + set_opt3_con(cdr(expr), arg2); + } + choose_c_function(sc, expr, func, 2); + return(OPT_T); + }} if ((bad_pairs == 1) && (quotes == 1)) - { - if ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) - { - if (symbols == 1) - { - set_optimized(expr); - if (is_normal_symbol(arg1)) - { - set_opt2_con(cdr(expr), cadr(arg2)); - set_optimize_op(expr, hop + OP_SAFE_C_SC); - } - else - { - set_opt1_con(cdr(expr), cadr(arg1)); - set_opt2_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_CS); - } - choose_c_function(sc, expr, func, 2); - return(OPT_T); - } - if ((pairs == 1) && (is_pair(arg2))) /* QC never happens */ - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_CQ); - set_opt2_con(cdr(expr), cadr(arg2)); - choose_c_function(sc, expr, func, 2); - return(OPT_T); - } - if (!is_safe_c_s(arg1)) - { - if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) - return(check_c_aa(sc, expr, func, hop, e)); - }} - else - if (pairs == 1) - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - choose_c_function(sc, expr, func, 2); - return(OPT_F); - }} + { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) + { + if (symbols == 1) + { + set_optimized(expr); + if (is_normal_symbol(arg1)) + { + set_opt2_con(cdr(expr), cadr(arg2)); + set_optimize_op(expr, hop + OP_SAFE_C_SC); + } + else + { + set_opt1_con(cdr(expr), cadr(arg1)); + set_opt2_sym(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_SAFE_C_CS); + } + choose_c_function(sc, expr, func, 2); + return(OPT_T); + } + if ((pairs == 1) && (is_pair(arg2))) /* QC never happens */ + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_CQ); + set_opt2_con(cdr(expr), cadr(arg2)); + choose_c_function(sc, expr, func, 2); + return(OPT_T); + } + if (!is_safe_c_s(arg1)) + { + if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) + return(check_c_aa(sc, expr, func, hop, e)); + }} + else + if (pairs == 1) + { + set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), 2); + choose_c_function(sc, expr, func, 2); + return(OPT_F); + }} if (quotes == 2) - { - if (func_is_safe) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_AA); /* op_safe_c_nc -> fx_c_nc appears to leave quoted pairs quoted? */ - set_opt3_pair(expr, cddr(expr)); - } - else - { - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); - set_opt3_arglen(cdr(expr), 2); - } - fx_annotate_args(sc, cdr(expr), e); - choose_c_function(sc, expr, func, 2); - return((func_is_safe) ? OPT_T : OPT_F); - } + { + if (func_is_safe) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_AA); /* op_safe_c_nc -> fx_c_nc appears to leave quoted pairs quoted? */ + set_opt3_pair(expr, cddr(expr)); + } + else + { + set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); + set_opt3_arglen(cdr(expr), 2); + } + fx_annotate_args(sc, cdr(expr), e); + choose_c_function(sc, expr, func, 2); + return((func_is_safe) ? OPT_T : OPT_F); + } if ((pairs == 1) && - (quotes == 0) && - ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e))))) - { - if (symbols == 1) - { - set_optimized(expr); - if (is_normal_symbol(arg1)) /* this is what optimize_expression uses to count symbols */ - { - set_optimize_op(expr, hop + OP_SAFE_C_SP); - opt_sp_1(sc, c_function_call(func), expr); - } - else set_optimize_op(expr, hop + OP_SAFE_C_PS); - choose_c_function(sc, expr, func, 2); - if (bad_pairs == 0) - return(OPT_T); - set_unsafe(expr); - return(OPT_F); - } - if (symbols == 0) - { - set_optimized(expr); - if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) - return(check_c_aa(sc, expr, func, hop, e)); - if (is_pair(arg1)) - { - set_optimize_op(expr, hop + OP_SAFE_C_PC); - set_opt3_con(cdr(expr), arg2); - } - else - { - set_optimize_op(expr, hop + OP_SAFE_C_CP); - opt_sp_1(sc, c_function_call(func), expr); - set_opt3_any(cdr(expr), arg1); - } - choose_c_function(sc, expr, func, 2); - if (bad_pairs == 0) - return(OPT_T); - set_unsafe(expr); - return(OPT_F); - }} + (quotes == 0) && + ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e))))) + { + if (symbols == 1) + { + set_optimized(expr); + if (is_normal_symbol(arg1)) /* this is what optimize_expression uses to count symbols */ + { + set_optimize_op(expr, hop + OP_SAFE_C_SP); + opt_sp_1(sc, c_function_call(func), expr); + } + else set_optimize_op(expr, hop + OP_SAFE_C_PS); + choose_c_function(sc, expr, func, 2); + if (bad_pairs == 0) + return(OPT_T); + set_unsafe(expr); + return(OPT_F); + } + if (symbols == 0) + { + set_optimized(expr); + if ((is_fxable(sc, arg1)) && (is_fxable(sc, arg2))) + return(check_c_aa(sc, expr, func, hop, e)); + if (is_pair(arg1)) + { + set_optimize_op(expr, hop + OP_SAFE_C_PC); + set_opt3_con(cdr(expr), arg2); + } + else + { + set_optimize_op(expr, hop + OP_SAFE_C_CP); + opt_sp_1(sc, c_function_call(func), expr); + set_opt3_any(cdr(expr), arg1); + } + choose_c_function(sc, expr, func, 2); + if (bad_pairs == 0) + return(OPT_T); + set_unsafe(expr); + return(OPT_F); + }} if ((pairs == 2) && - ((func_is_safe) || - ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e))))) - { - if ((bad_pairs == 1) && - (is_safe_c_s(arg1))) - { - /* unsafe func here won't work unless we check that later and make the new arg list (for list-values etc) - * (and it has to be the last pair else the unknown_g stuff can mess up) - */ - if (is_safe_quote(car(arg2))) - { - if (!is_proper_list_1(sc, cdr(arg2))) - return(OPT_OOPS); - set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_C); - set_opt1_sym(cdr(expr), cadr(arg1)); - set_opt2_con(cdr(expr), cadr(arg2)); - choose_c_function(sc, expr, func, 2); - return(OPT_T); - }} - if (quotes == 0) - { - set_unsafely_optimized(expr); - if (is_fxable(sc, arg1)) - { - if (is_fxable(sc, arg2)) - return(check_c_aa(sc, expr, func, hop, e)); - set_optimize_op(expr, hop + OP_SAFE_C_AP); - opt_sp_1(sc, c_function_call(func), expr); - fx_annotate_arg(sc, cdr(expr), e); - } - else - if (is_fxable(sc, arg2)) - { - set_optimize_op(expr, hop + OP_SAFE_C_PA); - fx_annotate_arg(sc, cddr(expr), e); - } - else - { - set_optimize_op(expr, hop + OP_SAFE_C_PP); - opt_sp_1(sc, c_function_call(func), expr); - } - choose_c_function(sc, expr, func, 2); - return(OPT_F); - } - if (quotes == 1) - { - if (is_safe_quote(car(arg1))) - { - if (!is_proper_list_1(sc, cdr(arg1))) - return(OPT_OOPS); - set_optimize_op(expr, hop + OP_SAFE_C_CP); - opt_sp_1(sc, c_function_call(func), expr); - set_opt3_any(cdr(expr), cadr(arg1)); - } - else - { - set_optimize_op(expr, hop + OP_SAFE_C_PC); - set_opt3_con(cdr(expr), cadr(arg2)); - } - set_unsafely_optimized(expr); - choose_c_function(sc, expr, func, 2); - return(OPT_F); - }} + ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e))))) + { + if ((bad_pairs == 1) && + (is_safe_c_s(arg1))) + { + /* unsafe func here won't work unless we check that later and make the new arg list (for list-values etc) + * (and it has to be the last pair else the unknown_g stuff can mess up) + */ + if (is_safe_quote(car(arg2))) + { + if (!is_proper_list_1(sc, cdr(arg2))) + return(OPT_OOPS); + set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_C); + set_opt1_sym(cdr(expr), cadr(arg1)); + set_opt2_con(cdr(expr), cadr(arg2)); + choose_c_function(sc, expr, func, 2); + return(OPT_T); + }} + if (quotes == 0) + { + set_unsafely_optimized(expr); + if (is_fxable(sc, arg1)) + { + if (is_fxable(sc, arg2)) + return(check_c_aa(sc, expr, func, hop, e)); + set_optimize_op(expr, hop + OP_SAFE_C_AP); + opt_sp_1(sc, c_function_call(func), expr); + fx_annotate_arg(sc, cdr(expr), e); + } + else + if (is_fxable(sc, arg2)) + { + set_optimize_op(expr, hop + OP_SAFE_C_PA); + fx_annotate_arg(sc, cddr(expr), e); + } + else + { + set_optimize_op(expr, hop + OP_SAFE_C_PP); + opt_sp_1(sc, c_function_call(func), expr); + } + choose_c_function(sc, expr, func, 2); + return(OPT_F); + } + if (quotes == 1) + { + if (is_safe_quote(car(arg1))) + { + if (!is_proper_list_1(sc, cdr(arg1))) + return(OPT_OOPS); + set_optimize_op(expr, hop + OP_SAFE_C_CP); + opt_sp_1(sc, c_function_call(func), expr); + set_opt3_any(cdr(expr), cadr(arg1)); + } + else + { + set_optimize_op(expr, hop + OP_SAFE_C_PC); + set_opt3_con(cdr(expr), cadr(arg2)); + } + set_unsafely_optimized(expr); + choose_c_function(sc, expr, func, 2); + return(OPT_F); + }} if (func_is_safe) - { - if (fx_count(sc, expr) == 2) - return(check_c_aa(sc, expr, func, hop, e)); - } + { + if (fx_count(sc, expr) == 2) + return(check_c_aa(sc, expr, func, hop, e)); + } else - { - if (is_fxable(sc, arg1)) - { - if (is_fxable(sc, arg2)) - { - if ((c_function_call(func) == g_apply) && - (is_normal_symbol(arg1))) - { - set_optimize_op(expr, OP_APPLY_SA); - if ((is_pair(arg2)) && - (is_normal_symbol(car(arg2)))) /* arg2 might be ((if expr op1 op2) ...) */ - { - s7_pointer lister = lookup(sc, car(arg2)); - if ((is_c_function(lister)) && - (is_pair(c_function_signature(lister))) && - (car(c_function_signature(lister)) == sc->is_proper_list_symbol)) - set_optimize_op(expr, OP_APPLY_SL); - } - set_opt1_cfunc(expr, func); /* not quite set_c_function */ - } - else set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 2); - } - else - { - if (((c_function_call(func) == g_with_input_from_string) || - (c_function_call(func) == g_with_input_from_file) || - (c_function_call(func) == g_with_output_to_file)) && - (is_ok_lambda(sc, arg2)) && - (is_null(cadr(arg2))) && - (!direct_memq(car(arg2), e))) /* lambda is redefined?? */ - { - set_unsafe_optimize_op(expr, (is_string(arg1)) ? OP_WITH_IO_C : OP_WITH_IO); - set_opt2_pair(expr, cddr(arg2)); - set_opt1_any(expr, (s7_pointer)io_function(c_function_call(func))); - return(OPT_F); - } - if (((c_function_call(func) == g_call_with_input_string) || - (c_function_call(func) == g_call_with_input_file) || - (c_function_call(func) == g_call_with_output_file)) && - (is_ok_lambda(sc, arg2)) && - (is_proper_list_1(sc, cadr(arg2))) && - (is_symbol(caadr(arg2))) && - (!is_probably_constant(caadr(arg2))) && - (!direct_memq(sc->lambda_symbol, e))) /* lambda is redefined?? */ - { - set_unsafe_optimize_op(expr, (is_string(arg1)) ? OP_WITH_IO_C : OP_WITH_IO); - set_opt2_pair(expr, cddr(arg2)); - set_opt3_sym(expr, caadr(arg2)); - set_opt1_any(expr, (s7_pointer)io_function(c_function_call(func))); - return(OPT_F); - } - set_unsafe_optimize_op(expr, hop + OP_C_AP); - fx_annotate_arg(sc, cdr(expr), e); - } - choose_c_function(sc, expr, func, 2); - return(OPT_F); - } - - if ((is_semisafe(func)) && - (is_symbol(car(expr))) && - (car(expr) != sc->values_symbol) && - (is_fxable(sc, arg2)) && - (is_pair(arg1)) && - (car(arg1) == sc->lambda_symbol)) - { - fx_annotate_arg(sc, cddr(expr), e); - set_unsafe_optimize_op(expr, hop + OP_CL_FA); - check_lambda(sc, arg1, true); /* this changes symbol_list */ - - clear_symbol_list(sc); /* so restore it */ - for (s7_pointer p = e; is_pair(p); p = cdr(p)) - if (is_normal_symbol(car(p))) - add_symbol_to_list(sc, car(p)); - - /* two seq args can't happen here (func_2_args = map + lambda + seq, arg1 is the lambda form, arg2 is fxable (see above) */ - choose_c_function(sc, expr, func, 2); - if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && - ((is_proper_list_1(sc, cadr(arg1))) && /* one parameter */ - (!is_possibly_constant(caadr(arg1))))) /* parameter name not trouble */ - { - /* built-in permanent closure here was not much faster */ - set_fn(expr, (fn_proc(expr) == g_for_each) ? g_for_each_closure : NULL); - set_opt3_pair(expr, cdr(arg1)); - set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FA); - } - return(OPT_F); - }} + { + if (is_fxable(sc, arg1)) + { + if (is_fxable(sc, arg2)) + { + if ((c_function_call(func) == g_apply) && + (is_normal_symbol(arg1))) + { + set_optimize_op(expr, OP_APPLY_SA); + if ((is_pair(arg2)) && + (is_normal_symbol(car(arg2)))) /* arg2 might be ((if expr op1 op2) ...) */ + { + s7_pointer lister = lookup(sc, car(arg2)); + if ((is_c_function(lister)) && + (is_pair(c_function_signature(lister))) && + (car(c_function_signature(lister)) == sc->is_proper_list_symbol)) + set_optimize_op(expr, OP_APPLY_SL); + } + set_opt1_cfunc(expr, func); /* not quite set_c_function */ + } + else set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), 2); + } + else + { + if (((c_function_call(func) == g_with_input_from_string) || + (c_function_call(func) == g_with_input_from_file) || + (c_function_call(func) == g_with_output_to_file)) && + (is_ok_lambda(sc, arg2)) && + (is_null(cadr(arg2))) && + (!direct_memq(car(arg2), e))) /* lambda is redefined?? */ + { + set_unsafe_optimize_op(expr, (is_string(arg1)) ? OP_WITH_IO_C : OP_WITH_IO); + set_opt2_pair(expr, cddr(arg2)); + set_opt1_any(expr, (s7_pointer)io_function(c_function_call(func))); + return(OPT_F); + } + if (((c_function_call(func) == g_call_with_input_string) || + (c_function_call(func) == g_call_with_input_file) || + (c_function_call(func) == g_call_with_output_file)) && + (is_ok_lambda(sc, arg2)) && + (is_proper_list_1(sc, cadr(arg2))) && + (is_symbol(caadr(arg2))) && + (!is_probably_constant(caadr(arg2))) && + (!direct_memq(sc->lambda_symbol, e))) /* lambda is redefined?? */ + { + set_unsafe_optimize_op(expr, (is_string(arg1)) ? OP_WITH_IO_C : OP_WITH_IO); + set_opt2_pair(expr, cddr(arg2)); + set_opt3_sym(expr, caadr(arg2)); + set_opt1_any(expr, (s7_pointer)io_function(c_function_call(func))); + return(OPT_F); + } + set_unsafe_optimize_op(expr, hop + OP_C_AP); + fx_annotate_arg(sc, cdr(expr), e); + } + choose_c_function(sc, expr, func, 2); + return(OPT_F); + } + + if ((is_semisafe(func)) && + (is_symbol(car(expr))) && + (car(expr) != sc->values_symbol) && + (is_fxable(sc, arg2)) && + (is_pair(arg1)) && + (car(arg1) == sc->lambda_symbol)) + { + fx_annotate_arg(sc, cddr(expr), e); + set_unsafe_optimize_op(expr, hop + OP_CL_FA); + check_lambda(sc, arg1, true); /* this changes symbol_list */ + + clear_symbol_list(sc); /* so restore it */ + for (s7_pointer p = e; is_pair(p); p = cdr(p)) + if (is_normal_symbol(car(p))) + add_symbol_to_list(sc, car(p)); + + /* two seq args can't happen here (func_2_args = map + lambda + seq, arg1 is the lambda form, arg2 is fxable (see above) */ + choose_c_function(sc, expr, func, 2); + if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && + ((is_proper_list_1(sc, cadr(arg1))) && /* one parameter */ + (!is_possibly_constant(caadr(arg1))))) /* parameter name not trouble */ + { + /* built-in permanent closure here was not much faster */ + set_fn(expr, (fn_proc(expr) == g_for_each) ? g_for_each_closure : NULL); + set_opt3_pair(expr, cdr(arg1)); + set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FA); + } + return(OPT_F); + }} return(set_any_c_np(sc, func, expr, e, 2, hop + OP_ANY_C_NP)); /* OP_C_PP doesn't exist, presumably OP_SAFE_C_PP was caught above? */ } @@ -72264,13 +72264,13 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f int32_t arit = closure_arity_to_int(sc, func); if (arit != 2) - { - if (is_symbol(closure_args(func))) - return(optimize_closure_sym(sc, expr, func, hop, 2, e)); - if ((arit == -1) && (is_symbol(cdr(closure_args(func))))) /* (define (f a . b) ...) */ - return(optimize_closure_a_sym(sc, expr, func, hop, 2, e)); - return(OPT_F); - } + { + if (is_symbol(closure_args(func))) + return(optimize_closure_sym(sc, expr, func, hop, 2, e)); + if ((arit == -1) && (is_symbol(cdr(closure_args(func))))) /* (define (f a . b) ...) */ + return(optimize_closure_a_sym(sc, expr, func, hop, 2, e)); + return(OPT_F); + } if (is_immutable(func)) hop = 1; body = closure_body(func); @@ -72278,112 +72278,112 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f safe_case = is_safe_closure(func); if ((pairs == 0) && - (symbols >= 1)) - { - set_unsafely_optimized(expr); - set_opt1_lambda_add(expr, func); - if (symbols == 2) - { - set_opt2_sym(expr, arg2); - if (!one_form) - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SS : OP_CLOSURE_SS)); - else - if (!safe_case) - set_optimize_op(expr, hop + OP_CLOSURE_SS_O); - else - if (!is_fxable(sc, car(body))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_O); - else - { - fx_annotate_arg(sc, body, e); - fx_tree(sc, body, car(closure_args(func)), cadr(closure_args(func)), NULL, false); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_A); - /* fx_annotate_args(sc, cdr(expr), e); */ - set_closure_one_form_fx_arg(func); - return(OPT_T); - } - return(OPT_F); - } - if (is_normal_symbol(arg1)) - { - if (one_form) - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC_O : OP_CLOSURE_SC_O)); /* _A case is very rare */ - else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC : OP_CLOSURE_SC)); - set_opt2_con(expr, arg2); - return(OPT_F); - }} + (symbols >= 1)) + { + set_unsafely_optimized(expr); + set_opt1_lambda_add(expr, func); + if (symbols == 2) + { + set_opt2_sym(expr, arg2); + if (!one_form) + set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SS : OP_CLOSURE_SS)); + else + if (!safe_case) + set_optimize_op(expr, hop + OP_CLOSURE_SS_O); + else + if (!is_fxable(sc, car(body))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_O); + else + { + fx_annotate_arg(sc, body, e); + fx_tree(sc, body, car(closure_args(func)), cadr(closure_args(func)), NULL, false); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_A); + /* fx_annotate_args(sc, cdr(expr), e); */ + set_closure_one_form_fx_arg(func); + return(OPT_T); + } + return(OPT_F); + } + if (is_normal_symbol(arg1)) + { + if (one_form) + set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC_O : OP_CLOSURE_SC_O)); /* _A case is very rare */ + else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC : OP_CLOSURE_SC)); + set_opt2_con(expr, arg2); + return(OPT_F); + }} if ((!arglist_has_rest(sc, closure_args(func))) && - (fx_count(sc, expr) == 2)) - { - if (!one_form) - set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AA : OP_CLOSURE_AA)); - else - if (!safe_case) - set_optimize_op(expr, hop + OP_CLOSURE_AA_O); - else - if (!is_fxable(sc, car(body))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_O); - else - { - fx_annotate_arg(sc, body, e); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_A); /* safe_closure_as|sa_a? */ - set_closure_one_form_fx_arg(func); - fx_annotate_args(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); - return(OPT_T); - } - fx_annotate_args(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); - return(OPT_F); - } + (fx_count(sc, expr) == 2)) + { + if (!one_form) + set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AA : OP_CLOSURE_AA)); + else + if (!safe_case) + set_optimize_op(expr, hop + OP_CLOSURE_AA_O); + else + if (!is_fxable(sc, car(body))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_O); + else + { + fx_annotate_arg(sc, body, e); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_AA_A); /* safe_closure_as|sa_a? */ + set_closure_one_form_fx_arg(func); + fx_annotate_args(sc, cdr(expr), e); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), 2); + return(OPT_T); + } + fx_annotate_args(sc, cdr(expr), e); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), 2); + return(OPT_F); + } if (is_fxable(sc, arg1)) - { - set_unsafely_optimized(expr); - fx_annotate_arg(sc, cdr(expr), e); - set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP)); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); /* for op_unknown_np */ - return(OPT_F); - } + { + set_unsafely_optimized(expr); + fx_annotate_arg(sc, cdr(expr), e); + set_safe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP)); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), 2); /* for op_unknown_np */ + return(OPT_F); + } if ((is_pair(arg1)) && - (car(arg1) == sc->lambda_symbol) && - (is_pair(cdr(arg1))) && /* not (lambda) */ - (is_fxable(sc, arg2)) && - (is_null(cdr(closure_body(func))))) - { - fx_annotate_arg(sc, cddr(expr), e); - set_opt2_pair(expr, cdr(arg1)); - set_unsafe_optimize_op(expr, hop + OP_CLOSURE_FA); - check_lambda(sc, arg1, false); - - clear_symbol_list(sc); /* clobbered in check_lambda so restore it? */ - for (s7_pointer p = e; is_pair(p); p = cdr(p)) - if (is_normal_symbol(car(p))) - add_symbol_to_list(sc, car(p)); - - /* check_lambda calls optimize_lambda if define in progress, else just optimize on the body */ - clear_safe_closure_body(cddr(arg1)); /* otherwise we need to fixup the local let for the optimizer -- see s7test intersection case 91492 */ - set_opt1_lambda_add(expr, func); - return(OPT_F); - } + (car(arg1) == sc->lambda_symbol) && + (is_pair(cdr(arg1))) && /* not (lambda) */ + (is_fxable(sc, arg2)) && + (is_null(cdr(closure_body(func))))) + { + fx_annotate_arg(sc, cddr(expr), e); + set_opt2_pair(expr, cdr(arg1)); + set_unsafe_optimize_op(expr, hop + OP_CLOSURE_FA); + check_lambda(sc, arg1, false); + + clear_symbol_list(sc); /* clobbered in check_lambda so restore it? */ + for (s7_pointer p = e; is_pair(p); p = cdr(p)) + if (is_normal_symbol(car(p))) + add_symbol_to_list(sc, car(p)); + + /* check_lambda calls optimize_lambda if define in progress, else just optimize on the body */ + clear_safe_closure_body(cddr(arg1)); /* otherwise we need to fixup the local let for the optimizer -- see s7test intersection case 91492 */ + set_opt1_lambda_add(expr, func); + return(OPT_F); + } if (is_fxable(sc, arg2)) - { - set_unsafely_optimized(expr); - fx_annotate_arg(sc, cddr(expr), e); - set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 2); /* for op_unknown_np */ - return(OPT_F); - } + { + set_unsafely_optimized(expr); + fx_annotate_arg(sc, cddr(expr), e); + set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), 2); /* for op_unknown_np */ + return(OPT_F); + } if (is_safe_closure(func)) /* clo* too */ - return(set_any_closure_np(sc, func, expr, e, 2, hop + OP_SAFE_CLOSURE_PP)); + return(set_any_closure_np(sc, func, expr, e, 2, hop + OP_SAFE_CLOSURE_PP)); set_unsafely_optimized(expr); set_optimize_op(expr, hop + OP_CLOSURE_PP); @@ -72395,15 +72395,15 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f if (is_closure_star(func)) { if (!closure_star_is_aritable(sc, func, closure_args(func), 1)) /* not 2, cadr(expr) might be keyword or pair->keyword etc */ - return(OPT_OOPS); /* (let* cons () (lambda* (a . b) (cons a b))) so closure_args=(), arity=0 ?? */ + return(OPT_OOPS); /* (let* cons () (lambda* (a . b) (cons a b))) so closure_args=(), arity=0 ?? */ if (is_immutable(func)) hop = 1; if (fx_count(sc, expr) == 2) - { - fixup_closure_star_aa(sc, func, expr, hop); - fx_annotate_args(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - return(OPT_F); - }} + { + fixup_closure_star_aa(sc, func, expr, hop); + fx_annotate_args(sc, cdr(expr), e); + set_opt1_lambda_add(expr, func); + return(OPT_F); + }} if ((is_c_function_star(func)) && (fx_count(sc, expr) == 2) && @@ -72431,66 +72431,66 @@ static opt_t optimize_func_two_args(s7_scheme *sc, s7_pointer expr, s7_pointer f } static opt_t optimize_safe_c_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, - int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, s7_pointer e) + int32_t hop, int32_t pairs, int32_t symbols, int32_t quotes, s7_pointer e) { s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); if (pairs == 0) { set_optimized(expr); if (symbols == 0) - set_optimize_op(expr, hop + OP_SAFE_C_NC); + set_optimize_op(expr, hop + OP_SAFE_C_NC); else - { - clear_has_fx(cdr(expr)); - if (symbols == 3) - { - set_optimize_op(expr, hop + OP_SAFE_C_SSS); - set_opt1_sym(cdr(expr), arg2); - set_opt2_sym(cdr(expr), arg3); - } - else - if (symbols == 2) - if (!is_normal_symbol(arg1)) - { - set_optimize_op(expr, hop + OP_SAFE_C_CSS); - set_opt1_sym(cdr(expr), arg2); - set_opt2_sym(cdr(expr), arg3); - } - else - if (!is_normal_symbol(arg3)) - { - set_opt2_con(cdr(expr), arg3); - set_opt1_sym(cdr(expr), arg2); - set_optimize_op(expr, hop + OP_SAFE_C_SSC); - } - else - { - set_opt1_con(cdr(expr), arg2); - set_opt2_sym(cdr(expr), arg3); - set_optimize_op(expr, hop + OP_SAFE_C_SCS); - } - else - if (is_normal_symbol(arg1)) - { - set_opt1_con(cdr(expr), arg2); - set_opt2_con(cdr(expr), arg3); - set_optimize_op(expr, hop + OP_SAFE_C_SCC); - } - else - if (is_normal_symbol(arg2)) - { - set_opt1_sym(cdr(expr), arg2); - set_opt2_con(cdr(expr), arg3); - set_opt3_con(cdr(expr), arg1); - set_optimize_op(expr, hop + OP_SAFE_C_CSC); - } - else - { - set_opt1_sym(cdr(expr), arg3); - set_opt2_con(cdr(expr), arg2); - set_opt3_con(cdr(expr), arg1); - set_optimize_op(expr, hop + OP_SAFE_C_CCS); - }} + { + clear_has_fx(cdr(expr)); + if (symbols == 3) + { + set_optimize_op(expr, hop + OP_SAFE_C_SSS); + set_opt1_sym(cdr(expr), arg2); + set_opt2_sym(cdr(expr), arg3); + } + else + if (symbols == 2) + if (!is_normal_symbol(arg1)) + { + set_optimize_op(expr, hop + OP_SAFE_C_CSS); + set_opt1_sym(cdr(expr), arg2); + set_opt2_sym(cdr(expr), arg3); + } + else + if (!is_normal_symbol(arg3)) + { + set_opt2_con(cdr(expr), arg3); + set_opt1_sym(cdr(expr), arg2); + set_optimize_op(expr, hop + OP_SAFE_C_SSC); + } + else + { + set_opt1_con(cdr(expr), arg2); + set_opt2_sym(cdr(expr), arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCS); + } + else + if (is_normal_symbol(arg1)) + { + set_opt1_con(cdr(expr), arg2); + set_opt2_con(cdr(expr), arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCC); + } + else + if (is_normal_symbol(arg2)) + { + set_opt1_sym(cdr(expr), arg2); + set_opt2_con(cdr(expr), arg3); + set_opt3_con(cdr(expr), arg1); + set_optimize_op(expr, hop + OP_SAFE_C_CSC); + } + else + { + set_opt1_sym(cdr(expr), arg3); + set_opt2_con(cdr(expr), arg2); + set_opt3_con(cdr(expr), arg1); + set_optimize_op(expr, hop + OP_SAFE_C_CCS); + }} choose_c_function(sc, expr, func, 3); return(OPT_T); } @@ -72500,42 +72500,42 @@ static opt_t optimize_safe_c_func_three_args(s7_scheme *sc, s7_pointer expr, s7_ { set_optimized(expr); if (quotes == 1) - { - if ((symbols == 2) && - (is_normal_symbol(arg1)) && - (is_normal_symbol(arg3))) - { - set_opt1_con(cdr(expr), cadr(arg2)); /* fx_c_scs uses opt1_con */ - clear_has_fx(cdr(expr)); /* (s7test safe_c_func_three_args) this is used above -- maybe just clear it at the top? */ - set_opt2_sym(cdr(expr), arg3); - set_optimize_op(expr, hop + OP_SAFE_C_SCS); /* used to be SQS */ - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - if (symbols == 1) - { - if ((is_normal_symbol(arg3)) && - (is_proper_quote(sc, arg2)) && - (is_safe_c_s(arg1))) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_CS); /* lg */ - set_opt1_con(cdr(expr), cadr(arg2)); /* opt1_con is T_Exs (unchecked) */ - set_opt2_sym(cdr(expr), arg3); - set_opt3_sym(cdr(expr), cadr(arg1)); - choose_c_function(sc, expr, func, 3); - return(OPT_T); - } - if ((is_normal_symbol(arg2)) && - (is_proper_quote(sc, arg1)) && - (!is_pair(arg3))) - { - set_optimize_op(expr, hop + OP_SAFE_C_CSC); - set_opt1_sym(cdr(expr), arg2); - set_opt2_con(cdr(expr), arg3); - set_opt3_con(cdr(expr), cadr(arg1)); - choose_c_function(sc, expr, func, 3); - return(OPT_T); - }}} + { + if ((symbols == 2) && + (is_normal_symbol(arg1)) && + (is_normal_symbol(arg3))) + { + set_opt1_con(cdr(expr), cadr(arg2)); /* fx_c_scs uses opt1_con */ + clear_has_fx(cdr(expr)); /* (s7test safe_c_func_three_args) this is used above -- maybe just clear it at the top? */ + set_opt2_sym(cdr(expr), arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCS); /* used to be SQS */ + choose_c_function(sc, expr, func, 3); + return(OPT_T); + } + if (symbols == 1) + { + if ((is_normal_symbol(arg3)) && + (is_proper_quote(sc, arg2)) && + (is_safe_c_s(arg1))) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_opSq_CS); /* lg */ + set_opt1_con(cdr(expr), cadr(arg2)); /* opt1_con is T_Exs (unchecked) */ + set_opt2_sym(cdr(expr), arg3); + set_opt3_sym(cdr(expr), cadr(arg1)); + choose_c_function(sc, expr, func, 3); + return(OPT_T); + } + if ((is_normal_symbol(arg2)) && + (is_proper_quote(sc, arg1)) && + (!is_pair(arg3))) + { + set_optimize_op(expr, hop + OP_SAFE_C_CSC); + set_opt1_sym(cdr(expr), arg2); + set_opt2_con(cdr(expr), arg3); + set_opt3_con(cdr(expr), cadr(arg1)); + choose_c_function(sc, expr, func, 3); + return(OPT_T); + }}} fx_annotate_args(sc, cdr(expr), e); set_opt3_arglen(cdr(expr), 3); @@ -72543,35 +72543,35 @@ static opt_t optimize_safe_c_func_three_args(s7_scheme *sc, s7_pointer expr, s7_ set_optimize_op(expr, hop + OP_SAFE_C_AAA); if (pairs == 1) - { - if (is_pair(arg1)) set_optimize_op(expr, hop + OP_SAFE_C_AGG); - - if ((symbols == 0) && (is_pair(arg2))) - set_optimize_op(expr, hop + OP_SAFE_C_CAC); - else - { - if ((symbols == 1) && (is_pair(arg3))) - set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_SAFE_C_CSA : OP_SAFE_C_SCA)); - else - { - if (symbols == 2) - { - if (is_normal_symbol(arg1)) - { - if (is_normal_symbol(arg2)) - { - set_optimize_op(expr, hop + OP_SAFE_C_SSA); - clear_has_fx(cdr(expr)); /* has_fx might have been on (see s7test) */ - } - else set_optimize_op(expr, hop + OP_SAFE_C_SAS); - } - else - if (is_pair(arg1)) - set_optimize_op(expr, hop + OP_SAFE_C_ASS); - }}}} + { + if (is_pair(arg1)) set_optimize_op(expr, hop + OP_SAFE_C_AGG); + + if ((symbols == 0) && (is_pair(arg2))) + set_optimize_op(expr, hop + OP_SAFE_C_CAC); + else + { + if ((symbols == 1) && (is_pair(arg3))) + set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_SAFE_C_CSA : OP_SAFE_C_SCA)); + else + { + if (symbols == 2) + { + if (is_normal_symbol(arg1)) + { + if (is_normal_symbol(arg2)) + { + set_optimize_op(expr, hop + OP_SAFE_C_SSA); + clear_has_fx(cdr(expr)); /* has_fx might have been on (see s7test) */ + } + else set_optimize_op(expr, hop + OP_SAFE_C_SAS); + } + else + if (is_pair(arg1)) + set_optimize_op(expr, hop + OP_SAFE_C_ASS); + }}}} else - if ((is_normal_symbol(arg1)) && (pairs == 2)) - set_optimize_op(expr, hop + OP_SAFE_C_SAA); + if ((is_normal_symbol(arg1)) && (pairs == 2)) + set_optimize_op(expr, hop + OP_SAFE_C_SAA); choose_c_function(sc, expr, func, 3); return(OPT_T); @@ -72580,7 +72580,7 @@ static opt_t optimize_safe_c_func_three_args(s7_scheme *sc, s7_pointer expr, s7_ } static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, - int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) + int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) { s7_pointer arg1, arg2, arg3; if ((quotes > 0) && @@ -72599,44 +72599,44 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer { /* wrap bad args */ if ((is_fxable(sc, arg1)) && - (is_fxable(sc, arg2)) && - (is_fxable(sc, arg3)) && - (s7_is_aritable(sc, func, 3))) - { - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 3); - if (is_c_function(func)) - { - if (is_safe_procedure(func)) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_AAA); - set_opt3_pair(cdr(expr), cdddr(expr)); - set_opt3_pair(expr, cddr(expr)); - } - else set_safe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_NA : OP_C_NA)); - set_c_function(expr, func); - return(OPT_T); - } - if ((is_closure(func)) && - (closure_arity_to_int(sc, func) == 3) && - (!arglist_has_rest(sc, closure_args(func)))) - { - set_unsafely_optimized(expr); - set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_3A : OP_CLOSURE_3A)); - set_opt1_lambda_add(expr, func); - return(OPT_F); - } - if ((is_closure_star(func)) && - (lambda_has_simple_defaults(func)) && - (closure_star_arity_to_int(sc, func) != 0) && - (closure_star_arity_to_int(sc, func) != 1)) - { - set_unsafely_optimized(expr); - if ((is_safe_closure(func)) && (closure_star_arity_to_int(sc, func) == 3)) - set_optimize_op(expr, OP_SAFE_CLOSURE_STAR_3A); - else set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA)); - set_opt1_lambda_add(expr, func); - }} + (is_fxable(sc, arg2)) && + (is_fxable(sc, arg3)) && + (s7_is_aritable(sc, func, 3))) + { + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), 3); + if (is_c_function(func)) + { + if (is_safe_procedure(func)) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_AAA); + set_opt3_pair(cdr(expr), cdddr(expr)); + set_opt3_pair(expr, cddr(expr)); + } + else set_safe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_NA : OP_C_NA)); + set_c_function(expr, func); + return(OPT_T); + } + if ((is_closure(func)) && + (closure_arity_to_int(sc, func) == 3) && + (!arglist_has_rest(sc, closure_args(func)))) + { + set_unsafely_optimized(expr); + set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_3A : OP_CLOSURE_3A)); + set_opt1_lambda_add(expr, func); + return(OPT_F); + } + if ((is_closure_star(func)) && + (lambda_has_simple_defaults(func)) && + (closure_star_arity_to_int(sc, func) != 0) && + (closure_star_arity_to_int(sc, func) != 1)) + { + set_unsafely_optimized(expr); + if ((is_safe_closure(func)) && (closure_star_arity_to_int(sc, func) == 3)) + set_optimize_op(expr, OP_SAFE_CLOSURE_STAR_3A); + else set_optimize_op(expr, ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA)); + set_opt1_lambda_add(expr, func); + }} return(OPT_F); } /* end of bad symbol wrappers */ @@ -72649,131 +72649,131 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer { if (hop == 0) hop = hop_if_constant(sc, car(expr)); if ((is_safe_procedure(func)) || - ((is_maybe_safe(func)) && (unsafe_is_safe(sc, arg3, e)))) - { - if (optimize_safe_c_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, e) == OPT_T) - return(OPT_T); - if ((is_normal_symbol(arg1)) && (is_normal_symbol(arg2))) - { - set_opt3_pair(expr, arg3); - set_unsafe_optimize_op(expr, hop + OP_SAFE_C_SSP); /* vector-set! in tbig apparently */ - choose_c_function(sc, expr, func, 3); - return(OPT_F); - } - return(set_any_c_np(sc, func, expr, e, 3, hop + OP_SAFE_C_3P)); - } + ((is_maybe_safe(func)) && (unsafe_is_safe(sc, arg3, e)))) + { + if (optimize_safe_c_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, e) == OPT_T) + return(OPT_T); + if ((is_normal_symbol(arg1)) && (is_normal_symbol(arg2))) + { + set_opt3_pair(expr, arg3); + set_unsafe_optimize_op(expr, hop + OP_SAFE_C_SSP); /* vector-set! in tbig apparently */ + choose_c_function(sc, expr, func, 3); + return(OPT_F); + } + return(set_any_c_np(sc, func, expr, e, 3, hop + OP_SAFE_C_3P)); + } /* func is not safe */ if (fx_count(sc, expr) == 3) - { - set_optimized(expr); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), 3); - if (is_semisafe(func)) - set_optimize_op(expr, hop + (((is_normal_symbol(arg1)) && (is_normal_symbol(arg3))) ? OP_CL_SAS : OP_CL_NA)); - else - if ((fx_proc(cdr(expr)) == fx_c) && (fx_proc(cddr(expr)) == fx_c) && (fx_proc(cdddr(expr)) == fx_c)) - set_optimize_op(expr, hop + OP_C_NC); - else set_optimize_op(expr, hop + OP_C_NA); - choose_c_function(sc, expr, func, 3); - set_unsafe(expr); - return(OPT_F); - } + { + set_optimized(expr); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), 3); + if (is_semisafe(func)) + set_optimize_op(expr, hop + (((is_normal_symbol(arg1)) && (is_normal_symbol(arg3))) ? OP_CL_SAS : OP_CL_NA)); + else + if ((fx_proc(cdr(expr)) == fx_c) && (fx_proc(cddr(expr)) == fx_c) && (fx_proc(cdddr(expr)) == fx_c)) + set_optimize_op(expr, hop + OP_C_NC); + else set_optimize_op(expr, hop + OP_C_NA); + choose_c_function(sc, expr, func, 3); + set_unsafe(expr); + return(OPT_F); + } /* (define (hi) (catch #t (lambda () 1) (lambda args 2))) * first arg list must be (), second a symbol */ if (c_function_call(func) == g_catch) - { - if (((bad_pairs == 2) && (!is_pair(arg1))) || - ((bad_pairs == 3) && (is_quote(car(arg1))))) - { - s7_pointer body_lambda = arg2, error_lambda = arg3; - if ((is_ok_lambda(sc, body_lambda)) && - (is_ok_lambda(sc, error_lambda)) && - (is_null(cadr(body_lambda))) && - (((is_symbol(cadr(error_lambda))) && /* (lambda args ... */ - (!is_probably_constant(cadr(error_lambda)))) || - ((is_pair(cadr(error_lambda))) && /* (lambda (type info) ... */ - (is_pair(cdadr(error_lambda))) && - (is_null(cddadr(error_lambda))) && - (!is_probably_constant(caadr(error_lambda))) && /* (lambda (pi ...) ...) */ - (!is_probably_constant(cadadr(error_lambda)))))) - { - s7_pointer error_result = caddr(error_lambda); - set_unsafely_optimized(expr); - if ((arg1 == sc->T) && /* tag is #t */ - (is_null(cdddr(error_lambda))) && /* error lambda body is one expr */ - ((!is_symbol(error_result)) || /* (lambda args #f) */ - ((is_pair(cadr(error_lambda))) && - (error_result == caadr(error_lambda)))) && /* (lambda (type info) type) */ - ((!is_pair(error_result)) || - (is_quote(car(error_result))) || /* (lambda args 'a) */ - ((car(error_result) == sc->car_symbol) && - (is_pair(cdr(error_result))) && /* (lambda (type info) (car)) */ - (cadr(error_result) == cadr(error_lambda))))) /* (lambda args (car args) -> error-type */ - { - set_optimize_op(expr, OP_C_CATCH_ALL); /* catch_all* = #t tag, error handling can skip to the simple lambda body */ - set_c_function(expr, func); - - if (is_pair(error_result)) - error_result = (is_quote(car(error_result))) ? cadr(error_result) : sc->unused; - else - if (is_symbol(error_result)) - error_result = sc->unused; - set_opt2_con(expr, error_result); /* for op_c_catch_all|_a -> stack */ - - set_opt1_pair(cdr(expr), cddr(body_lambda)); - if (is_null(cdddr(body_lambda))) - { - if (is_fxable(sc, caddr(body_lambda))) - { - set_optimize_op(expr, OP_C_CATCH_ALL_A); - set_fx_direct(cddr(body_lambda), fx_choose(sc, cddr(body_lambda), sc->curlet, let_symbol_is_safe)); - } - else - { - set_opt1_pair(cdr(expr), caddr(body_lambda)); - set_optimize_op(expr, OP_C_CATCH_ALL_O); - /* fn got no hits */ - }}} - else - { - set_optimize_op(expr, OP_C_CATCH); /* mainly c_catch_p, but this is not a common case */ - choose_c_function(sc, expr, func, 3); - } - return(OPT_F); - }}} + { + if (((bad_pairs == 2) && (!is_pair(arg1))) || + ((bad_pairs == 3) && (is_quote(car(arg1))))) + { + s7_pointer body_lambda = arg2, error_lambda = arg3; + if ((is_ok_lambda(sc, body_lambda)) && + (is_ok_lambda(sc, error_lambda)) && + (is_null(cadr(body_lambda))) && + (((is_symbol(cadr(error_lambda))) && /* (lambda args ... */ + (!is_probably_constant(cadr(error_lambda)))) || + ((is_pair(cadr(error_lambda))) && /* (lambda (type info) ... */ + (is_pair(cdadr(error_lambda))) && + (is_null(cddadr(error_lambda))) && + (!is_probably_constant(caadr(error_lambda))) && /* (lambda (pi ...) ...) */ + (!is_probably_constant(cadadr(error_lambda)))))) + { + s7_pointer error_result = caddr(error_lambda); + set_unsafely_optimized(expr); + if ((arg1 == sc->T) && /* tag is #t */ + (is_null(cdddr(error_lambda))) && /* error lambda body is one expr */ + ((!is_symbol(error_result)) || /* (lambda args #f) */ + ((is_pair(cadr(error_lambda))) && + (error_result == caadr(error_lambda)))) && /* (lambda (type info) type) */ + ((!is_pair(error_result)) || + (is_quote(car(error_result))) || /* (lambda args 'a) */ + ((car(error_result) == sc->car_symbol) && + (is_pair(cdr(error_result))) && /* (lambda (type info) (car)) */ + (cadr(error_result) == cadr(error_lambda))))) /* (lambda args (car args) -> error-type */ + { + set_optimize_op(expr, OP_C_CATCH_ALL); /* catch_all* = #t tag, error handling can skip to the simple lambda body */ + set_c_function(expr, func); + + if (is_pair(error_result)) + error_result = (is_quote(car(error_result))) ? cadr(error_result) : sc->unused; + else + if (is_symbol(error_result)) + error_result = sc->unused; + set_opt2_con(expr, error_result); /* for op_c_catch_all|_a -> stack */ + + set_opt1_pair(cdr(expr), cddr(body_lambda)); + if (is_null(cdddr(body_lambda))) + { + if (is_fxable(sc, caddr(body_lambda))) + { + set_optimize_op(expr, OP_C_CATCH_ALL_A); + set_fx_direct(cddr(body_lambda), fx_choose(sc, cddr(body_lambda), sc->curlet, let_symbol_is_safe)); + } + else + { + set_opt1_pair(cdr(expr), caddr(body_lambda)); + set_optimize_op(expr, OP_C_CATCH_ALL_O); + /* fn got no hits */ + }}} + else + { + set_optimize_op(expr, OP_C_CATCH); /* mainly c_catch_p, but this is not a common case */ + choose_c_function(sc, expr, func, 3); + } + return(OPT_F); + }}} if ((is_semisafe(func)) && - (is_symbol(car(expr))) && (car(expr) != sc->values_symbol) && - (is_fxable(sc, arg2)) && (is_fxable(sc, arg3)) && - (is_pair(arg1)) && (car(arg1) == sc->lambda_symbol)) - { - choose_c_function(sc, expr, func, 3); - if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && - (is_proper_list_2(sc, cadr(arg1))) && /* two parameters */ - (is_symbol(caadr(arg1))) && (!is_possibly_constant(caadr(arg1))) && /* parameter name not trouble */ - (is_symbol(cadadr(arg1))) && (!is_possibly_constant(cadadr(arg1)))) - { - fx_annotate_args(sc, cddr(expr), e); - check_lambda(sc, arg1, true); /* this changes symbol_list */ - - clear_symbol_list(sc); /* so restore it */ - for (s7_pointer p = e; is_pair(p); p = cdr(p)) - if (is_normal_symbol(car(p))) - add_symbol_to_list(sc, car(p)); - - set_fn(expr, (fn_proc(expr) == g_for_each) ? g_for_each_closure_2 : NULL); - set_opt3_pair(expr, cdr(arg1)); - set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FAA); - return(OPT_F); - }} + (is_symbol(car(expr))) && (car(expr) != sc->values_symbol) && + (is_fxable(sc, arg2)) && (is_fxable(sc, arg3)) && + (is_pair(arg1)) && (car(arg1) == sc->lambda_symbol)) + { + choose_c_function(sc, expr, func, 3); + if (((fn_proc(expr) == g_for_each) || (fn_proc(expr) == g_map)) && + (is_proper_list_2(sc, cadr(arg1))) && /* two parameters */ + (is_symbol(caadr(arg1))) && (!is_possibly_constant(caadr(arg1))) && /* parameter name not trouble */ + (is_symbol(cadadr(arg1))) && (!is_possibly_constant(cadadr(arg1)))) + { + fx_annotate_args(sc, cddr(expr), e); + check_lambda(sc, arg1, true); /* this changes symbol_list */ + + clear_symbol_list(sc); /* so restore it */ + for (s7_pointer p = e; is_pair(p); p = cdr(p)) + if (is_normal_symbol(car(p))) + add_symbol_to_list(sc, car(p)); + + set_fn(expr, (fn_proc(expr) == g_for_each) ? g_for_each_closure_2 : NULL); + set_opt3_pair(expr, cdr(arg1)); + set_unsafe_optimize_op(expr, OP_MAP_FOR_EACH_FAA); + return(OPT_F); + }} if ((is_safe_procedure(func)) || - ((is_semisafe(func)) && - (((car(expr) != sc->assoc_symbol) && (car(expr) != sc->member_symbol)) || - (unsafe_is_safe(sc, arg3, e))))) - return(set_any_c_np(sc, func, expr, e, 3, hop + OP_SAFE_C_3P)); + ((is_semisafe(func)) && + (((car(expr) != sc->assoc_symbol) && (car(expr) != sc->member_symbol)) || + (unsafe_is_safe(sc, arg3, e))))) + return(set_any_c_np(sc, func, expr, e, 3, hop + OP_SAFE_C_3P)); return(set_any_c_np(sc, func, expr, e, 3, hop + OP_ANY_C_NP)); } @@ -72782,90 +72782,90 @@ static opt_t optimize_func_three_args(s7_scheme *sc, s7_pointer expr, s7_pointer { int32_t arit = closure_arity_to_int(sc, func); if (arit != 3) - { - if (is_symbol(closure_args(func))) - return(optimize_closure_sym(sc, expr, func, hop, 3, e)); - return(OPT_F); - } + { + if (is_symbol(closure_args(func))) + return(optimize_closure_sym(sc, expr, func, hop, 3, e)); + return(OPT_F); + } if (is_immutable(func)) hop = 1; if (symbols == 3) - { - s7_pointer body = closure_body(func); - bool one_form = is_null(cdr(body)); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 3); - - if (is_safe_closure(func)) - { - if ((one_form) && - (is_fxable(sc, car(body)))) - { - set_opt2_sym(expr, arg2); - set_opt3_sym(expr, arg3); - fx_annotate_arg(sc, body, e); - fx_tree(sc, body, car(closure_args(func)), cadr(closure_args(func)), caddr(closure_args(func)), false); - set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S_A); - set_closure_one_form_fx_arg(func); - } - else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S); - return(OPT_T); - } - set_unsafe_optimize_op(expr, hop + ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)); - return(OPT_F); - } + { + s7_pointer body = closure_body(func); + bool one_form = is_null(cdr(body)); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), 3); + + if (is_safe_closure(func)) + { + if ((one_form) && + (is_fxable(sc, car(body)))) + { + set_opt2_sym(expr, arg2); + set_opt3_sym(expr, arg3); + fx_annotate_arg(sc, body, e); + fx_tree(sc, body, car(closure_args(func)), cadr(closure_args(func)), caddr(closure_args(func)), false); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S_A); + set_closure_one_form_fx_arg(func); + } + else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3S); + return(OPT_T); + } + set_unsafe_optimize_op(expr, hop + ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)); + return(OPT_F); + } if (fx_count(sc, expr) == 3) - { - if (is_safe_closure(func)) - { - if ((!is_pair(arg2)) && (!is_pair(arg3))) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AGG); - else - if (is_normal_symbol(arg1)) - set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_SAFE_CLOSURE_SSA : OP_SAFE_CLOSURE_SAA)); - else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3A); - } - else - if ((is_normal_symbol(arg2)) && (is_normal_symbol(arg3))) - set_optimize_op(expr, hop + OP_CLOSURE_ASS); - else - if (is_normal_symbol(arg1)) - set_optimize_op(expr, hop + ((is_normal_symbol(arg3)) ? OP_CLOSURE_SAS : OP_CLOSURE_SAA)); - else - if (is_normal_symbol(arg3)) - set_optimize_op(expr, hop + OP_CLOSURE_AAS); - else set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_CLOSURE_ASA : OP_CLOSURE_3A)); - set_unsafely_optimized(expr); - fx_annotate_args(sc, cdr(expr), e); - - if (is_fx_treeable(cdr(expr))) - fx_tree(sc, closure_body(func), car(closure_args(func)), cadr(closure_args(func)), caddr(closure_args(func)), false); - - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 3); - return(OPT_F); - } + { + if (is_safe_closure(func)) + { + if ((!is_pair(arg2)) && (!is_pair(arg3))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_AGG); + else + if (is_normal_symbol(arg1)) + set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_SAFE_CLOSURE_SSA : OP_SAFE_CLOSURE_SAA)); + else set_optimize_op(expr, hop + OP_SAFE_CLOSURE_3A); + } + else + if ((is_normal_symbol(arg2)) && (is_normal_symbol(arg3))) + set_optimize_op(expr, hop + OP_CLOSURE_ASS); + else + if (is_normal_symbol(arg1)) + set_optimize_op(expr, hop + ((is_normal_symbol(arg3)) ? OP_CLOSURE_SAS : OP_CLOSURE_SAA)); + else + if (is_normal_symbol(arg3)) + set_optimize_op(expr, hop + OP_CLOSURE_AAS); + else set_optimize_op(expr, hop + ((is_normal_symbol(arg2)) ? OP_CLOSURE_ASA : OP_CLOSURE_3A)); + set_unsafely_optimized(expr); + fx_annotate_args(sc, cdr(expr), e); + + if (is_fx_treeable(cdr(expr))) + fx_tree(sc, closure_body(func), car(closure_args(func)), cadr(closure_args(func)), caddr(closure_args(func)), false); + + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), 3); + return(OPT_F); + } return(set_any_closure_np(sc, func, expr, e, 3, hop + OP_ANY_CLOSURE_3P)); } if (is_closure_star(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); + (closure_star_arity_to_int(sc, func) == 0) || + (closure_star_arity_to_int(sc, func) == 1)) + return(OPT_F); if (fx_count(sc, expr) == 3) - { - if (is_immutable(func)) hop = 1; - if ((is_safe_closure(func)) && (closure_star_arity_to_int(sc, func) == 3)) - set_optimize_op(expr, OP_SAFE_CLOSURE_STAR_3A); - else set_unsafe_optimize_op(expr, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA))); - fx_annotate_args(sc, cdr(expr), e); - set_opt1_lambda_add(expr, func); - set_opt3_arglen(cdr(expr), 3); - return(OPT_F); - }} + { + if (is_immutable(func)) hop = 1; + if ((is_safe_closure(func)) && (closure_star_arity_to_int(sc, func) == 3)) + set_optimize_op(expr, OP_SAFE_CLOSURE_STAR_3A); + else set_unsafe_optimize_op(expr, hop + ((is_safe_closure(func) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA))); + fx_annotate_args(sc, cdr(expr), e); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(cdr(expr), 3); + return(OPT_F); + }} if ((is_c_function_star(func)) && (fx_count(sc, expr) == 3) && @@ -72889,90 +72889,90 @@ static bool symbols_are_safe(s7_scheme *sc, s7_pointer args, s7_pointer e) { s7_pointer arg = car(p); if ((is_normal_symbol(arg)) && - (!arg_findable(sc, arg, e))) - return(false); + (!arg_findable(sc, arg, e))) + return(false); } return(true); } 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) + int32_t pairs, int32_t symbols, int32_t quotes, int32_t bad_pairs, s7_pointer e) { bool func_is_closure; if (quotes > 0) { if (direct_memq(sc->quote_symbol, e)) - return(OPT_OOPS); + return(OPT_OOPS); if ((bad_pairs == quotes) && - (is_symbol(car(expr))) && - (is_constant_symbol(sc, car(expr)))) - hop = 1; + (is_symbol(car(expr))) && + (is_constant_symbol(sc, car(expr)))) + hop = 1; } if ((is_c_function(func)) && (c_function_is_aritable(func, args))) { if (hop == 0) hop = hop_if_constant(sc, car(expr)); if (is_safe_procedure(func)) - { - if (pairs == 0) - { - if (symbols == 0) - { - set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); - choose_c_function(sc, expr, func, args); - return(OPT_T); - } - if (symbols == args) - { - if (symbols_are_safe(sc, cdr(expr), e)) - set_safe_optimize_op(expr, hop + OP_SAFE_C_NS); - else - { - set_safe_optimize_op(expr, hop + ((args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA)); - fx_annotate_args(sc, cdr(expr), e); - } - set_opt3_arglen(cdr(expr), args); - choose_c_function(sc, expr, func, args); - return(OPT_T); - }} - - if (fx_count(sc, expr) == args) - { - s7_pointer p; - set_optimized(expr); - set_optimize_op(expr, hop + ((args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA)); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - choose_c_function(sc, expr, func, args); - - for (p = cdr(expr); (is_pair(p)) && (is_pair(cdr(p))); p = cddr(p)) - { - if (is_normal_symbol(car(p))) - break; - if ((is_pair(car(p))) && - ((!is_pair(cdar(p))) || (!is_quote(caar(p))))) - break; - } - if (is_null(p)) - { - set_optimize_op(expr, hop + OP_SAFE_C_ALL_CA); - for (p = cdr(expr); is_pair(p); p = cddr(p)) - { - clear_has_fx(p); - set_opt2_con(p, (is_pair(car(p))) ? cadar(p) : car(p)); - }} - return(OPT_T); - } - return(set_any_c_np(sc, func, expr, e, args, hop + OP_ANY_C_NP)); - } + { + if (pairs == 0) + { + if (symbols == 0) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); + choose_c_function(sc, expr, func, args); + return(OPT_T); + } + if (symbols == args) + { + if (symbols_are_safe(sc, cdr(expr), e)) + set_safe_optimize_op(expr, hop + OP_SAFE_C_NS); + else + { + set_safe_optimize_op(expr, hop + ((args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA)); + fx_annotate_args(sc, cdr(expr), e); + } + set_opt3_arglen(cdr(expr), args); + choose_c_function(sc, expr, func, args); + return(OPT_T); + }} + + if (fx_count(sc, expr) == args) + { + s7_pointer p; + set_optimized(expr); + set_optimize_op(expr, hop + ((args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA)); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), args); + choose_c_function(sc, expr, func, args); + + for (p = cdr(expr); (is_pair(p)) && (is_pair(cdr(p))); p = cddr(p)) + { + if (is_normal_symbol(car(p))) + break; + if ((is_pair(car(p))) && + ((!is_pair(cdar(p))) || (!is_quote(caar(p))))) + break; + } + if (is_null(p)) + { + set_optimize_op(expr, hop + OP_SAFE_C_ALL_CA); + for (p = cdr(expr); is_pair(p); p = cddr(p)) + { + clear_has_fx(p); + set_opt2_con(p, (is_pair(car(p))) ? cadar(p) : car(p)); + }} + return(OPT_T); + } + return(set_any_c_np(sc, func, expr, e, args, hop + OP_ANY_C_NP)); + } /* c_func is not safe */ if (fx_count(sc, expr) == args) /* trigger_size doesn't matter for unsafe funcs */ - { - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_NA : OP_C_NA)); - choose_c_function(sc, expr, func, args); - return(OPT_F); - } + { + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), args); + set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_NA : OP_C_NA)); + choose_c_function(sc, expr, func, args); + return(OPT_F); + } return(set_any_c_np(sc, func, expr, e, args, hop + OP_ANY_C_NP)); /* was num_args=3! 2-Sep-20 */ } @@ -72981,34 +72981,34 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer { int32_t arit = closure_arity_to_int(sc, func); if (arit != args) - { - if (is_symbol(closure_args(func))) - return(optimize_closure_sym(sc, expr, func, hop, args, e)); - return(OPT_F); - } + { + if (is_symbol(closure_args(func))) + return(optimize_closure_sym(sc, expr, func, hop, args, e)); + return(OPT_F); + } if (is_immutable(func)) hop = 1; if (fx_count(sc, expr) == args) - { - bool safe_case = is_safe_closure(func); - set_unsafely_optimized(expr); - set_unsafe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_NA : ((args == 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA))); - fx_annotate_args(sc, cdr(expr), e); - set_opt3_arglen(cdr(expr), args); - set_opt1_lambda_add(expr, func); - - if ((symbols == args) && - (symbols_are_safe(sc, cdr(expr), e))) - { - if (safe_case) - set_optimize_op(expr, hop + OP_SAFE_CLOSURE_NS); - else set_optimize_op(expr, hop + ((args == 4) ? ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S) : - ((args == 5) ? OP_CLOSURE_5S : OP_CLOSURE_NS))); - } - return(OPT_F); - } + { + bool safe_case = is_safe_closure(func); + set_unsafely_optimized(expr); + set_unsafe_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_NA : ((args == 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA))); + fx_annotate_args(sc, cdr(expr), e); + set_opt3_arglen(cdr(expr), args); + set_opt1_lambda_add(expr, func); + + if ((symbols == args) && + (symbols_are_safe(sc, cdr(expr), e))) + { + if (safe_case) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_NS); + else set_optimize_op(expr, hop + ((args == 4) ? ((is_null(cdr(closure_body(func)))) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S) : + ((args == 5) ? OP_CLOSURE_5S : OP_CLOSURE_NS))); + } + return(OPT_F); + } if (args == 4) - return(set_any_closure_np(sc, func, expr, e, 4, hop + OP_ANY_CLOSURE_4P)); + return(set_any_closure_np(sc, func, expr, e, 4, hop + OP_ANY_CLOSURE_4P)); return(set_any_closure_np(sc, func, expr, e, args, hop + OP_ANY_CLOSURE_NP)); } @@ -73035,7 +73035,7 @@ static opt_t optimize_func_many_args(s7_scheme *sc, s7_pointer expr, s7_pointer { set_unsafely_optimized(expr); if (func_is_closure) - set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_NA : ((args == 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA))); + set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_NA : ((args == 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA))); else set_optimize_op(expr, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA)); fx_annotate_args(sc, cdr(expr), e); set_opt3_arglen(cdr(expr), args); @@ -73051,10 +73051,10 @@ static bool vars_syntax_ok(s7_pointer vars) { s7_pointer var = car(p); if ((!is_pair(var)) || - (!is_symbol(car(var))) || - (!is_pair(cdr(var))) || - (is_pair(cddr(var)))) - return(false); + (!is_symbol(car(var))) || + (!is_pair(cdr(var))) || + (is_pair(cddr(var)))) + return(false); } return(true); } @@ -73070,15 +73070,15 @@ static bool vars_opt_ok(s7_scheme *sc, s7_pointer vars, int32_t hop, s7_pointer s7_pointer init = cadr(var); /* if ((is_slot(global_slot(car(var)))) && (is_c_function(global_value(car(var))))) return(false); */ /* too draconian (see snd-test) */ if ((is_normal_symbol(car(var))) && (is_global(car(var)))) /* (define (f) (let ((+ -)) (with-let (curlet) (#_integer? (+))))) (f) */ - { - s7_int old_pl = sc->print_length; - sc->print_length = 80; - /* fprintf(stderr, "set %s local in %s\n", display(car(var)), display_truncated(vars)); */ - /* locals in tall: initial_dur, bump, fft_window ?? none of these look problematic! */ - sc->print_length = old_pl; - set_local(car(var)); - return(false); - } + { + s7_int old_pl = sc->print_length; + sc->print_length = 80; + /* fprintf(stderr, "set %s local in %s\n", display(car(var)), display_truncated(vars)); */ + /* locals in tall: initial_dur, bump, fft_window ?? none of these look problematic! */ + sc->print_length = old_pl; + set_local(car(var)); + return(false); + } /* also too draconian (tall for example) but +/- above is broken now (returns #t) * perhaps set_local could be undone upon leaving the let if there's no capture possible */ @@ -73086,9 +73086,9 @@ static bool vars_opt_ok(s7_scheme *sc, s7_pointer vars, int32_t hop, s7_pointer s7_pointer init = cadar(p); #endif if ((is_pair(init)) && - (!is_checked(init)) && - (optimize_expression(sc, init, hop, e, false) == OPT_OOPS)) - return(false); + (!is_checked(init)) && + (optimize_expression(sc, init, hop, e, false) == OPT_OOPS)) + return(false); } return(true); } @@ -73110,57 +73110,57 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in case OP_LET: case OP_LETREC: case OP_LET_STAR: case OP_LETREC_STAR: if (is_symbol(cadr(expr))) - { - if (!is_pair(cddr(expr))) /* (let name . x) */ - return(OPT_F); - vars = caddr(expr); - if (!is_list(vars)) return(OPT_OOPS); - body = cdddr(expr); - } + { + if (!is_pair(cddr(expr))) /* (let name . x) */ + return(OPT_F); + vars = caddr(expr); + if (!is_list(vars)) return(OPT_OOPS); + body = cdddr(expr); + } else - { - vars = cadr(expr); - body = cddr(expr); - if (is_null(vars)) - e = cons(sc, sc->nil, e); /* () in e = empty let */ - else - if (!is_pair(vars)) - return(OPT_OOPS); - } + { + vars = cadr(expr); + body = cddr(expr); + if (is_null(vars)) + e = cons(sc, sc->nil, e); /* () in e = empty let */ + else + if (!is_pair(vars)) + return(OPT_OOPS); + } if (!is_pair(body)) return(OPT_OOPS); if (!vars_syntax_ok(vars)) - return(OPT_OOPS); + return(OPT_OOPS); if ((op == OP_LETREC) || (op == OP_LETREC_STAR)) - { - e = collect_variables(sc, vars, e); - if (!vars_opt_ok(sc, vars, hop, e)) - return(OPT_OOPS); - } + { + e = collect_variables(sc, vars, e); + if (!vars_opt_ok(sc, vars, hop, e)) + return(OPT_OOPS); + } else - if (op == OP_LET) - { - if (!vars_opt_ok(sc, vars, hop, e)) - return(OPT_OOPS); - e = collect_variables(sc, vars, e); - } - else - for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((is_pair(cadr(var))) && - (!is_checked(cadr(var))) && - (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - e = cons(sc, add_symbol_to_list(sc, car(var)), e); - sc->w = e; - } + if (op == OP_LET) + { + if (!vars_opt_ok(sc, vars, hop, e)) + return(OPT_OOPS); + e = collect_variables(sc, vars, e); + } + else + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + s7_pointer var = car(p); + if ((is_pair(cadr(var))) && + (!is_checked(cadr(var))) && + (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) + return(OPT_OOPS); + e = cons(sc, add_symbol_to_list(sc, car(var)), e); + sc->w = e; + } if (is_symbol(cadr(expr))) - { - e = cons(sc, add_symbol_to_list(sc, cadr(expr)), e); - sc->w = e; - } + { + e = cons(sc, add_symbol_to_list(sc, cadr(expr)), e); + sc->w = e; + } break; case OP_LET_TEMPORARILY: @@ -73168,15 +73168,15 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in if (!is_list(vars)) return(OPT_OOPS); body = cddr(expr); for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(vars); - if ((is_pair(var)) && - (is_pair(cdr(var))) && - (is_pair(cadr(var))) && - (!is_checked(cadr(var))) && - (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - } + { + s7_pointer var = car(vars); + if ((is_pair(var)) && + (is_pair(cdr(var))) && + (is_pair(cadr(var))) && + (!is_checked(cadr(var))) && + (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) + return(OPT_OOPS); + } /* e = cons(sc, sc->nil, e); */ /* !? currently let-temporarily does not make a new let, so it is like begin? */ body_export_ok = export_ok; /* (list x (let-temporarily () (define x 0))) just as in begin */ break; @@ -73184,34 +73184,34 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in case OP_DO: vars = cadr(expr); if (is_null(vars)) - e = cons(sc, sc->nil, e); + e = cons(sc, sc->nil, e); else - if (!is_pair(vars)) - return(OPT_OOPS); + if (!is_pair(vars)) + return(OPT_OOPS); body = cddr(expr); for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if ((!is_pair(var)) || - (!is_symbol(car(var))) || - (!is_pair(cdr(var)))) - return(OPT_OOPS); - if ((is_pair(cadr(var))) && - (!is_checked(cadr(var))) && - (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) /* the init field -- locals are not defined yet */ - return(OPT_OOPS); - } + { + s7_pointer var = car(p); + if ((!is_pair(var)) || + (!is_symbol(car(var))) || + (!is_pair(cdr(var)))) + return(OPT_OOPS); + if ((is_pair(cadr(var))) && + (!is_checked(cadr(var))) && + (optimize_expression(sc, cadr(var), hop, e, false) == OPT_OOPS)) /* the init field -- locals are not defined yet */ + return(OPT_OOPS); + } e = collect_variables(sc, vars, e); for (s7_pointer p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = cddar(p); - if ((is_pair(var)) && - (is_pair(car(var))) && - (!is_checked(car(var))) && - (optimize_expression(sc, car(var), hop, e, false) == OPT_OOPS)) /* the step field -- locals are defined */ - return(OPT_OOPS); - } + { + s7_pointer var = cddar(p); + if ((is_pair(var)) && + (is_pair(car(var))) && + (!is_checked(car(var))) && + (optimize_expression(sc, car(var), hop, e, false) == OPT_OOPS)) /* the step field -- locals are defined */ + return(OPT_OOPS); + } break; case OP_BEGIN: @@ -73241,95 +73241,95 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in vars = cadr(expr); body = cddr(expr); if (is_pair(vars)) - { - if ((export_ok) && - (is_symbol(car(vars)))) - { - add_symbol_to_list(sc, car(vars)); - if (is_pair(e)) - { - if (car(e) != sc->if_keyword) - set_cdr(e, cons(sc, car(vars), cdr(e))); /* export it */ - else add_symbol_to_list(sc, symbol_to_keyword(sc, car(vars))); - } - else e = cons(sc, car(vars), e); - } - e = collect_parameters(sc, cdr(vars), e); - body_export_ok = export_ok; - } + { + if ((export_ok) && + (is_symbol(car(vars)))) + { + add_symbol_to_list(sc, car(vars)); + if (is_pair(e)) + { + if (car(e) != sc->if_keyword) + set_cdr(e, cons(sc, car(vars), cdr(e))); /* export it */ + else add_symbol_to_list(sc, symbol_to_keyword(sc, car(vars))); + } + else e = cons(sc, car(vars), e); + } + e = collect_parameters(sc, cdr(vars), e); + body_export_ok = export_ok; + } else - { - if ((export_ok) && - (is_symbol(vars))) - { - /* actually if this is defining a function, the name should probably be included in the local let - * but that's next-to-impossible to guarantee unless it's (define x (lambda...)) of course. - */ - sc->temp9 = e; - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (!is_checked(car(p))) && /* ((full_type(p) & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */ - (optimize_expression(sc, car(p), hop, e, false) == OPT_OOPS)) /* "body" here is not body in terms of export_ok */ - { - sc->temp9 = sc->unused; - return(OPT_OOPS); - } - sc->temp9 = sc->unused; - - add_symbol_to_list(sc, vars); - if (is_pair(e)) - { - if (car(e) != sc->if_keyword) - set_cdr(e, cons(sc, vars, cdr(e))); /* export it */ - else add_symbol_to_list(sc, symbol_to_keyword(sc, vars)); - } - /* else e = cons(sc, vars, e); */ /* ?? should this be set-cdr etc? */ - return(OPT_F); - } - body_export_ok = false; - } + { + if ((export_ok) && + (is_symbol(vars))) + { + /* actually if this is defining a function, the name should probably be included in the local let + * but that's next-to-impossible to guarantee unless it's (define x (lambda...)) of course. + */ + sc->temp9 = e; + for (s7_pointer p = body; is_pair(p); p = cdr(p)) + if ((is_pair(car(p))) && + (!is_checked(car(p))) && /* ((full_type(p) & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */ + (optimize_expression(sc, car(p), hop, e, false) == OPT_OOPS)) /* "body" here is not body in terms of export_ok */ + { + sc->temp9 = sc->unused; + return(OPT_OOPS); + } + sc->temp9 = sc->unused; + + add_symbol_to_list(sc, vars); + if (is_pair(e)) + { + if (car(e) != sc->if_keyword) + set_cdr(e, cons(sc, vars, cdr(e))); /* export it */ + else add_symbol_to_list(sc, symbol_to_keyword(sc, vars)); + } + /* else e = cons(sc, vars, e); */ /* ?? should this be set-cdr etc? */ + return(OPT_F); + } + body_export_ok = false; + } break; case OP_LAMBDA: case OP_LAMBDA_STAR: case OP_MACRO: case OP_MACRO_STAR: vars = cadr(expr); if (is_null(vars)) - e = cons(sc, sc->nil, e); + e = cons(sc, sc->nil, e); else - if ((!is_pair(vars)) && (!is_symbol(vars))) - return(OPT_OOPS); + if ((!is_pair(vars)) && (!is_symbol(vars))) + return(OPT_OOPS); e = collect_parameters(sc, vars, e); body = cddr(expr); break; case OP_SET: if ((is_pair(cadr(expr))) && (caadr(expr) == sc->outlet_symbol)) - return(OPT_OOPS); + return(OPT_OOPS); if (!is_pair(cddr(expr))) - return(OPT_OOPS); + return(OPT_OOPS); if ((is_pair(cadr(expr))) && - (!is_checked(cadr(expr)))) - { - bool old_in_with_let = sc->in_with_let; - set_checked(cadr(expr)); - if (caadr(expr) == sc->with_let_symbol) sc->in_with_let = true; - for (s7_pointer lp = cdadr(expr); is_pair(lp); lp = cdr(lp)) - if ((is_pair(car(lp))) && - (!is_checked(car(lp))) && - (optimize_expression(sc, car(lp), hop, e, body_export_ok) == OPT_OOPS)) - { - sc->in_with_let = old_in_with_let; - return(OPT_OOPS); - } - sc->in_with_let = old_in_with_let; - } + (!is_checked(cadr(expr)))) + { + bool old_in_with_let = sc->in_with_let; + set_checked(cadr(expr)); + if (caadr(expr) == sc->with_let_symbol) sc->in_with_let = true; + for (s7_pointer lp = cdadr(expr); is_pair(lp); lp = cdr(lp)) + if ((is_pair(car(lp))) && + (!is_checked(car(lp))) && + (optimize_expression(sc, car(lp), hop, e, body_export_ok) == OPT_OOPS)) + { + sc->in_with_let = old_in_with_let; + return(OPT_OOPS); + } + sc->in_with_let = old_in_with_let; + } if ((is_pair(caddr(expr))) && - (!is_checked(caddr(expr))) && - (optimize_expression(sc, caddr(expr), hop, e, body_export_ok) == OPT_OOPS)) - return(OPT_OOPS); + (!is_checked(caddr(expr))) && + (optimize_expression(sc, caddr(expr), hop, e, body_export_ok) == OPT_OOPS)) + return(OPT_OOPS); if ((is_pair(cadr(expr))) && (caadr(expr) == sc->s7_starlet_symbol)) - return(OPT_T); + return(OPT_T); return(OPT_F); case OP_WITH_LET: @@ -73338,81 +73338,81 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in * returns 1 if hop is 1, but -2 otherwise. (with-let (unlet)...) is safe however. */ { - bool old_with_let = sc->in_with_let; - sc->in_with_let = (old_with_let) || (!is_pair(body)) || (!is_pair(car(body))) || - ((caar(body) != sc->unlet_symbol) && /* (caar(body) != sc->rootlet_symbol) && */ (caar(body) != sc->curlet_symbol)); - /* not rootlet here: (let ((i 0)) (_rd3_ (with-let (rootlet) ((null? i) i)))) */ - for (s7_pointer p = body; is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (!is_checked(car(p))) && - (optimize_expression(sc, car(p), 0, sc->nil, body_export_ok) == OPT_OOPS)) - { - sc->in_with_let = old_with_let; - return(OPT_OOPS); - } - sc->in_with_let = old_with_let; - return(OPT_F); + bool old_with_let = sc->in_with_let; + sc->in_with_let = (old_with_let) || (!is_pair(body)) || (!is_pair(car(body))) || + ((caar(body) != sc->unlet_symbol) && /* (caar(body) != sc->rootlet_symbol) && */ (caar(body) != sc->curlet_symbol)); + /* not rootlet here: (let ((i 0)) (_rd3_ (with-let (rootlet) ((null? i) i)))) */ + for (s7_pointer p = body; is_pair(p); p = cdr(p)) + if ((is_pair(car(p))) && + (!is_checked(car(p))) && + (optimize_expression(sc, car(p), 0, sc->nil, body_export_ok) == OPT_OOPS)) + { + sc->in_with_let = old_with_let; + return(OPT_OOPS); + } + sc->in_with_let = old_with_let; + return(OPT_F); } case OP_CASE: if ((is_pair(cadr(expr))) && - (!is_checked(cadr(expr))) && - (optimize_expression(sc, cadr(expr), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); + (!is_checked(cadr(expr))) && + (optimize_expression(sc, cadr(expr), hop, e, false) == OPT_OOPS)) + return(OPT_OOPS); for (s7_pointer p = cddr(expr); is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && - (is_pair(cdar(p)))) - for (s7_pointer rst = cdar(p); is_pair(rst); rst = cdr(rst)) - if ((is_pair(car(rst))) && - (!is_checked(car(rst))) && - (optimize_expression(sc, car(rst), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); + if ((is_pair(car(p))) && + (is_pair(cdar(p)))) + for (s7_pointer rst = cdar(p); is_pair(rst); rst = cdr(rst)) + if ((is_pair(car(rst))) && + (!is_checked(car(rst))) && + (optimize_expression(sc, car(rst), hop, e, false) == OPT_OOPS)) + return(OPT_OOPS); return(OPT_F); case OP_COND: /* split opt is necessary: (cond (lambda (x) ...)) */ for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - if (is_pair(car(p))) - { - s7_pointer test = caar(p); - e = cons(sc, sc->if_keyword, e); /* I think this is a marker in case define is encountered? (see above) */ - if ((is_pair(test)) && - (!is_checked(test)) && - (optimize_expression(sc, test, hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - for (s7_pointer rst = cdar(p); is_pair(rst); rst = cdr(rst)) - if ((is_pair(car(rst))) && - (!is_checked(car(rst))) && - (optimize_expression(sc, car(rst), hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - } + if (is_pair(car(p))) + { + s7_pointer test = caar(p); + e = cons(sc, sc->if_keyword, e); /* I think this is a marker in case define is encountered? (see above) */ + if ((is_pair(test)) && + (!is_checked(test)) && + (optimize_expression(sc, test, hop, e, false) == OPT_OOPS)) + return(OPT_OOPS); + for (s7_pointer rst = cdar(p); is_pair(rst); rst = cdr(rst)) + if ((is_pair(car(rst))) && + (!is_checked(car(rst))) && + (optimize_expression(sc, car(rst), hop, e, false) == OPT_OOPS)) + return(OPT_OOPS); + } { - s7_pointer p; - for (p = cdr(expr); is_pair(p); p = cdr(p)) - { - s7_pointer q; - if ((!is_pair(car(p))) || (!is_fxable(sc, caar(p)))) - break; - if (!is_pair(cdar(p))) - break; - for (q = cdar(p); is_pair(q); q = cdr(q)) - if ((car(q) == sc->feed_to_symbol) || (!is_fxable(sc, car(q)))) - break; - if (!is_null(q)) break; - } - if (!is_null(p)) return(OPT_F); - set_safe_optimize_op(expr, OP_COND_NA_NA); + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cdr(p)) + { + s7_pointer q; + if ((!is_pair(car(p))) || (!is_fxable(sc, caar(p)))) + break; + if (!is_pair(cdar(p))) + break; + for (q = cdar(p); is_pair(q); q = cdr(q)) + if ((car(q) == sc->feed_to_symbol) || (!is_fxable(sc, car(q)))) + break; + if (!is_null(q)) break; + } + if (!is_null(p)) return(OPT_F); + set_safe_optimize_op(expr, OP_COND_NA_NA); } for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) - { - set_fx_direct(car(p), fx_choose(sc, car(p), e, pair_symbol_is_safe)); - for (s7_pointer q = cdar(p); is_pair(q); q = cdr(q)) - set_fx_direct(q, fx_choose(sc, q, e, pair_symbol_is_safe)); - } + { + set_fx_direct(car(p), fx_choose(sc, car(p), e, pair_symbol_is_safe)); + for (s7_pointer q = cdar(p); is_pair(q); q = cdr(q)) + set_fx_direct(q, fx_choose(sc, q, e, pair_symbol_is_safe)); + } return(OPT_T); case OP_IF: case OP_WHEN: case OP_UNLESS: if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) - return(OPT_OOPS); + return(OPT_OOPS); case OP_OR: case OP_AND: e = cons(sc, sc->if_keyword, e); break; @@ -73423,11 +73423,11 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in sc->temp9 = e; for (s7_pointer p = body; is_pair(p); p = cdr(p)) if ((is_pair(car(p))) && - (!is_checked(car(p))) && /* ((full_type(p) & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */ - (optimize_expression(sc, car(p), hop, e, body_export_ok) == OPT_OOPS)) + (!is_checked(car(p))) && /* ((full_type(p) & (TYPE_MASK | T_CHECKED)) == T_PAIR) is not faster */ + (optimize_expression(sc, car(p), hop, e, body_export_ok) == OPT_OOPS)) { - sc->temp9 = sc->unused; - return(OPT_OOPS); + sc->temp9 = sc->unused; + return(OPT_OOPS); } sc->temp9 = sc->unused; @@ -73436,148 +73436,148 @@ static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, in (symbol_id(car(expr)) == 0))) { if (op == OP_IF) - { - s7_pointer test = cdr(expr), b1, b2, p; - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - return(OPT_F); - if (!is_null(p)) return(OPT_OOPS); - if ((is_pair(cdr(test))) && (is_pair(cddr(test))) && (!is_null(cdddr(test)))) - return(OPT_OOPS); - - for (p = cdr(expr); is_pair(p); p = cdr(p)) - set_fx_direct(p, fx_choose(sc, p, e, pair_symbol_is_safe)); - - b1 = cdr(test); - b2 = cdr(b1); - if ((fx_proc(b1) == fx_q) && - (is_pair(b2))) - { - set_opt3_con(test, cadar(b1)); - if (fx_proc(b2) == fx_q) - { - set_safe_optimize_op(expr, OP_IF_A_C_C); - set_opt1_con(expr, cadar(b1)); - set_opt2_con(expr, cadar(b2)); - return(OPT_T); - } - set_opt1_pair(expr, b1); - set_opt2_pair(expr, b2); - set_safe_optimize_op(expr, OP_IF_A_A_A); - } - else - { - if ((is_pair(car(test))) && - (caar(test) == sc->not_symbol) && - (is_fxable(sc, cadar(test)))) - { - set_fx_direct(cdar(test), fx_choose(sc, cdar(test), e, pair_symbol_is_safe)); - set_opt1_pair(expr, cdar(test)); - set_opt2_pair(expr, b1); - if (is_pair(b2)) set_opt3_pair(expr, b2); - set_safe_optimize_op(expr, (is_null(b2)) ? OP_IF_NOT_A_A : OP_IF_NOT_A_A_A); - } - else - { - if ((is_pair(b2)) && (fx_proc(b1) == fx_c) && (fx_proc(b2) == fx_c)) - { - set_safe_optimize_op(expr, OP_IF_A_C_C); - set_opt1_con(expr, car(b1)); - set_opt2_con(expr, car(b2)); - return(OPT_T); - } - if ((fx_proc(test) == fx_and_2a) && (fx_proc(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_S_A); - 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 : ((fx_proc(test) == fx_s) ? OP_IF_S_A_A : OP_IF_A_A_A)); - }} - return(OPT_T); - } + { + s7_pointer test = cdr(expr), b1, b2, p; + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + return(OPT_F); + if (!is_null(p)) return(OPT_OOPS); + if ((is_pair(cdr(test))) && (is_pair(cddr(test))) && (!is_null(cdddr(test)))) + return(OPT_OOPS); + + for (p = cdr(expr); is_pair(p); p = cdr(p)) + set_fx_direct(p, fx_choose(sc, p, e, pair_symbol_is_safe)); + + b1 = cdr(test); + b2 = cdr(b1); + if ((fx_proc(b1) == fx_q) && + (is_pair(b2))) + { + set_opt3_con(test, cadar(b1)); + if (fx_proc(b2) == fx_q) + { + set_safe_optimize_op(expr, OP_IF_A_C_C); + set_opt1_con(expr, cadar(b1)); + set_opt2_con(expr, cadar(b2)); + return(OPT_T); + } + set_opt1_pair(expr, b1); + set_opt2_pair(expr, b2); + set_safe_optimize_op(expr, OP_IF_A_A_A); + } + else + { + if ((is_pair(car(test))) && + (caar(test) == sc->not_symbol) && + (is_fxable(sc, cadar(test)))) + { + set_fx_direct(cdar(test), fx_choose(sc, cdar(test), e, pair_symbol_is_safe)); + set_opt1_pair(expr, cdar(test)); + set_opt2_pair(expr, b1); + if (is_pair(b2)) set_opt3_pair(expr, b2); + set_safe_optimize_op(expr, (is_null(b2)) ? OP_IF_NOT_A_A : OP_IF_NOT_A_A_A); + } + else + { + if ((is_pair(b2)) && (fx_proc(b1) == fx_c) && (fx_proc(b2) == fx_c)) + { + set_safe_optimize_op(expr, OP_IF_A_C_C); + set_opt1_con(expr, car(b1)); + set_opt2_con(expr, car(b2)); + return(OPT_T); + } + if ((fx_proc(test) == fx_and_2a) && (fx_proc(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_S_A); + 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 : ((fx_proc(test) == fx_s) ? OP_IF_S_A_A : OP_IF_A_A_A)); + }} + return(OPT_T); + } else - { - if ((op == OP_OR) || (op == OP_AND)) - { - int32_t args, pairs = 0; - s7_pointer p, sym = NULL; - bool c_s_is_ok = true; - - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - return(OPT_F); - if (!is_null(p)) return(OPT_OOPS); - for (args = 0, p = cdr(expr); is_pair(p); p = cdr(p), args++) /* this only applies to or/and */ - if (is_pair(car(p))) - { - pairs++; - if ((c_s_is_ok) && - ((!is_h_safe_c_s(car(p))) || - ((sym) && (sym != cadar(p))))) - c_s_is_ok = false; - else sym = (is_pair(cdar(p))) ? cadar(p) : sc->unspecified; - } - - if ((c_s_is_ok) && (args == 2) && (pairs == 2)) - { - if (op == OP_OR) - { - set_opt3_sym(cdr(expr), cadadr(expr)); - if ((is_symbol(caadr(expr))) && (symbol_type(caadr(expr)) > 0) && (is_global(caadr(expr))) && - ((is_symbol(caaddr(expr))) && (symbol_type(caaddr(expr)) > 0) && (is_global(caaddr(expr))))) - { - set_opt3_int(expr, symbol_type(caadr(expr))); - set_opt2_int(cdr(expr), symbol_type(caaddr(expr))); - set_safe_optimize_op(expr, OP_OR_S_TYPE_2); - } - else set_safe_optimize_op(expr, OP_OR_S_2); - } - else - { - set_opt3_sym(cdr(expr), cadadr(expr)); - set_safe_optimize_op(expr, OP_AND_S_2); - } - return(OPT_T); - } - - for (p = cdr(expr); is_pair(p); p = cdr(p)) - set_fx_direct(p, fx_choose(sc, p, e, pair_symbol_is_safe)); - if (op == OP_OR) - { - if (args == 2) - set_safe_optimize_op(expr, OP_OR_2A); - else - { - if (args == 3) - set_safe_optimize_op(expr, OP_OR_3A); - else set_safe_optimize_op(expr, OP_OR_N); - } - return(OPT_T); - } - if (args == 2) - set_safe_optimize_op(expr, OP_AND_2A); - else set_safe_optimize_op(expr, (args == 3) ? OP_AND_3A : OP_AND_N); - return(OPT_T); - } - else - if (op == OP_BEGIN) - { - s7_pointer p; - if (!is_pair(cdr(expr))) return(OPT_F); - for (p = cdr(expr); is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - return(OPT_F); - if (!is_null(p)) return(OPT_OOPS); - for (p = cdr(expr); is_pair(p); p = cdr(p)) - set_fx_direct(p, fx_choose(sc, p, e, pair_symbol_is_safe)); - set_safe_optimize_op(expr, ((is_pair(cddr(expr))) && (is_null(cdddr(expr)))) ? OP_BEGIN_AA : OP_BEGIN_NA); - return(OPT_T); - }}} /* fully fxable lets don't happen much: even let-2a-a is scarcely used */ + { + if ((op == OP_OR) || (op == OP_AND)) + { + int32_t args, pairs = 0; + s7_pointer p, sym = NULL; + bool c_s_is_ok = true; + + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + return(OPT_F); + if (!is_null(p)) return(OPT_OOPS); + for (args = 0, p = cdr(expr); is_pair(p); p = cdr(p), args++) /* this only applies to or/and */ + if (is_pair(car(p))) + { + pairs++; + if ((c_s_is_ok) && + ((!is_h_safe_c_s(car(p))) || + ((sym) && (sym != cadar(p))))) + c_s_is_ok = false; + else sym = (is_pair(cdar(p))) ? cadar(p) : sc->unspecified; + } + + if ((c_s_is_ok) && (args == 2) && (pairs == 2)) + { + if (op == OP_OR) + { + set_opt3_sym(cdr(expr), cadadr(expr)); + if ((is_symbol(caadr(expr))) && (symbol_type(caadr(expr)) > 0) && (is_global(caadr(expr))) && + ((is_symbol(caaddr(expr))) && (symbol_type(caaddr(expr)) > 0) && (is_global(caaddr(expr))))) + { + set_opt3_int(expr, symbol_type(caadr(expr))); + set_opt2_int(cdr(expr), symbol_type(caaddr(expr))); + set_safe_optimize_op(expr, OP_OR_S_TYPE_2); + } + else set_safe_optimize_op(expr, OP_OR_S_2); + } + else + { + set_opt3_sym(cdr(expr), cadadr(expr)); + set_safe_optimize_op(expr, OP_AND_S_2); + } + return(OPT_T); + } + + for (p = cdr(expr); is_pair(p); p = cdr(p)) + set_fx_direct(p, fx_choose(sc, p, e, pair_symbol_is_safe)); + if (op == OP_OR) + { + if (args == 2) + set_safe_optimize_op(expr, OP_OR_2A); + else + { + if (args == 3) + set_safe_optimize_op(expr, OP_OR_3A); + else set_safe_optimize_op(expr, OP_OR_N); + } + return(OPT_T); + } + if (args == 2) + set_safe_optimize_op(expr, OP_AND_2A); + else set_safe_optimize_op(expr, (args == 3) ? OP_AND_3A : OP_AND_N); + return(OPT_T); + } + else + if (op == OP_BEGIN) + { + s7_pointer p; + if (!is_pair(cdr(expr))) return(OPT_F); + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + return(OPT_F); + if (!is_null(p)) return(OPT_OOPS); + for (p = cdr(expr); is_pair(p); p = cdr(p)) + set_fx_direct(p, fx_choose(sc, p, e, pair_symbol_is_safe)); + set_safe_optimize_op(expr, ((is_pair(cddr(expr))) && (is_null(cdddr(expr)))) ? OP_BEGIN_AA : OP_BEGIN_NA); + return(OPT_T); + }}} /* fully fxable lets don't happen much: even let-2a-a is scarcely used */ return(OPT_F); } @@ -73590,45 +73590,45 @@ static opt_t optimize_funcs(s7_scheme *sc, s7_pointer expr, s7_pointer func, int { s7_pointer car_p = car(p); if (is_normal_symbol(car_p)) /* for opt func */ - symbols++; + symbols++; else - if (is_pair(car_p)) - { - pairs++; - if (!is_checked(car_p)) - { - opt_t res; - if ((is_pair(car(car_p))) && (caar(car_p) == sc->let_symbol)) - res = OPT_F; - else res = optimize_expression(sc, car_p, orig_hop, e, false); - if (res == OPT_F) - { - bad_pairs++; - if (is_proper_quote(sc, car_p)) - quotes++; - } - else - if (res == OPT_OOPS) - return(OPT_OOPS); - } - else - if ((!is_optimized(car_p)) || - (is_unsafe(car_p))) - { - bad_pairs++; - if (is_proper_quote(sc, car_p)) - quotes++; - }}} + if (is_pair(car_p)) + { + pairs++; + if (!is_checked(car_p)) + { + opt_t res; + if ((is_pair(car(car_p))) && (caar(car_p) == sc->let_symbol)) + res = OPT_F; + else res = optimize_expression(sc, car_p, orig_hop, e, false); + if (res == OPT_F) + { + bad_pairs++; + if (is_proper_quote(sc, car_p)) + quotes++; + } + else + if (res == OPT_OOPS) + return(OPT_OOPS); + } + else + if ((!is_optimized(car_p)) || + (is_unsafe(car_p))) + { + bad_pairs++; + if (is_proper_quote(sc, car_p)) + quotes++; + }}} if (is_null(p)) /* if not null, dotted list of args, (cons 1 . 2) etc -- error perhaps? */ { switch (args) - { - case 0: return(optimize_thunk(sc, expr, func, hop, e)); - case 1: return(optimize_func_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - case 2: return(optimize_func_two_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - case 3: return(optimize_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); - default: return(optimize_func_many_args(sc, expr, func, hop, args, pairs, symbols, quotes, bad_pairs, e)); - }} + { + case 0: return(optimize_thunk(sc, expr, func, hop, e)); + case 1: return(optimize_func_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); + case 2: return(optimize_func_two_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); + case 3: return(optimize_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e)); + default: return(optimize_func_many_args(sc, expr, func, hop, args, pairs, symbols, quotes, bad_pairs, e)); + }} return(OPT_OOPS); /* was OPT_F, but this is always an error */ } @@ -73642,165 +73642,165 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 { s7_pointer slot; if (is_syntactic_symbol(car_expr)) - { - if (!is_pair(cdr(expr))) - return(OPT_OOPS); - return(optimize_syntax(sc, expr, T_Syn(global_value(car_expr)), hop, e, export_ok)); - } + { + if (!is_pair(cdr(expr))) + return(OPT_OOPS); + return(optimize_syntax(sc, expr, T_Syn(global_value(car_expr)), hop, e, export_ok)); + } slot = find_uncomplicated_symbol(sc, car_expr, e); /* local vars (recursive calls too??) are considered complicated */ if (is_slot(slot)) - { - s7_pointer func = slot_value(slot); - if (is_syntax(func)) /* not is_syntactic -- here we have the value */ - return((is_pair(cdr(expr))) ? optimize_syntax(sc, expr, func, hop, e, export_ok) : OPT_OOPS); /* e can be extended via set-cdr! here */ - - if (is_any_macro(func)) - return(OPT_F); - - /* we miss implicit indexing here because at this time, the data are not set */ - if ((is_t_procedure(func)) || /* t_procedure_p: c_funcs, closures, etc */ - ((is_applicable(func)) && - (is_safe_procedure(func)))) /* built-in applicable objects like vectors */ - { - if ((hop != 0) && - ((is_any_closure(func)) || /* see use-redef in s7test -- I'm not sure about this */ - ((!is_global(car_expr)) && - ((!is_slot(global_slot(car_expr))) || - (global_value(car_expr) != func)))) && - (!is_immutable(car_expr)) && /* list|apply-values -- can't depend on opt1 here because it might not be global, or might be redefined locally */ - (!is_immutable_slot(slot))) /* (define-constant...) */ - { - /* (let () (define (f2 a) (+ a 1)) (define (f1 a) (f2 a)) (define (f2 a) (- a)) (f1 12)) - * (let () (define (f2 a) (+ a 1)) (define (f1 a) (f2 a)) (define (f2 a) (- a 1)) (f1 12)) - * and similar define* cases - */ - hop = 0; - /* this is very tricky! See s7test for some cases. Basically, we need to protect a recursive call - * of the current function being optimized from being confused with some previous definition - * of the same name. But method lists have global names so the global bit is off even though the - * thing is actually a safe global. But no closure can be considered safe in the hop sense -- - * even a global function might be redefined at any time, and previous uses of it in other functions - * need to reflect its new value. - * So, closures are always checked, but built-in functions are used as if never redefined until that redefinition. - * Syntax handling is already impure in s7, so the special handling of built-in functions doesn't - * offend me much. Consider each a sort of reader macro until someone redefines it -- previous - * uses might not be affected because they might have been optimized away -- the result depends on the - * current optimizer. - * Another case (from K Matheussen): - * (define (call-func func arg1 arg2) (define (call) (func arg1 arg2)) (call)) (call-func + 1 2.5) (call-func - 5 2) - * when we get here originally "func" is +, hop=1, but just checking for !is_global(car_expr) is - * not good enough -- if we load mockery.scm, nothing is global! - * Yet another case (define (test-abs) (define (abs x) (+ x 1)) (format *stderr* "abs ~A~%" (abs -1))) - * when optimize_syntax sees the (define abs ...), it inserts abs into e so that the caller's e is extended (set-cdr!) - * so that find_uncomplicated_symbol above will be unhappy when we reach (abs -1) as the format arg. - * This can be confused if lambda is redefined at some point, but... - */ - } - return(optimize_funcs(sc, expr, func, hop, orig_hop, e)); - }} + { + s7_pointer func = slot_value(slot); + if (is_syntax(func)) /* not is_syntactic -- here we have the value */ + return((is_pair(cdr(expr))) ? optimize_syntax(sc, expr, func, hop, e, export_ok) : OPT_OOPS); /* e can be extended via set-cdr! here */ + + if (is_any_macro(func)) + return(OPT_F); + + /* we miss implicit indexing here because at this time, the data are not set */ + if ((is_t_procedure(func)) || /* t_procedure_p: c_funcs, closures, etc */ + ((is_applicable(func)) && + (is_safe_procedure(func)))) /* built-in applicable objects like vectors */ + { + if ((hop != 0) && + ((is_any_closure(func)) || /* see use-redef in s7test -- I'm not sure about this */ + ((!is_global(car_expr)) && + ((!is_slot(global_slot(car_expr))) || + (global_value(car_expr) != func)))) && + (!is_immutable(car_expr)) && /* list|apply-values -- can't depend on opt1 here because it might not be global, or might be redefined locally */ + (!is_immutable_slot(slot))) /* (define-constant...) */ + { + /* (let () (define (f2 a) (+ a 1)) (define (f1 a) (f2 a)) (define (f2 a) (- a)) (f1 12)) + * (let () (define (f2 a) (+ a 1)) (define (f1 a) (f2 a)) (define (f2 a) (- a 1)) (f1 12)) + * and similar define* cases + */ + hop = 0; + /* this is very tricky! See s7test for some cases. Basically, we need to protect a recursive call + * of the current function being optimized from being confused with some previous definition + * of the same name. But method lists have global names so the global bit is off even though the + * thing is actually a safe global. But no closure can be considered safe in the hop sense -- + * even a global function might be redefined at any time, and previous uses of it in other functions + * need to reflect its new value. + * So, closures are always checked, but built-in functions are used as if never redefined until that redefinition. + * Syntax handling is already impure in s7, so the special handling of built-in functions doesn't + * offend me much. Consider each a sort of reader macro until someone redefines it -- previous + * uses might not be affected because they might have been optimized away -- the result depends on the + * current optimizer. + * Another case (from K Matheussen): + * (define (call-func func arg1 arg2) (define (call) (func arg1 arg2)) (call)) (call-func + 1 2.5) (call-func - 5 2) + * when we get here originally "func" is +, hop=1, but just checking for !is_global(car_expr) is + * not good enough -- if we load mockery.scm, nothing is global! + * Yet another case (define (test-abs) (define (abs x) (+ x 1)) (format *stderr* "abs ~A~%" (abs -1))) + * when optimize_syntax sees the (define abs ...), it inserts abs into e so that the caller's e is extended (set-cdr!) + * so that find_uncomplicated_symbol above will be unhappy when we reach (abs -1) as the format arg. + * This can be confused if lambda is redefined at some point, but... + */ + } + return(optimize_funcs(sc, expr, func, hop, orig_hop, e)); + }} else - if ((sc->undefined_identifier_warnings) && - (slot == sc->undefined) && /* car_expr is not in e or global */ - (symbol_tag(car_expr) == 0)) /* and we haven't looked it up earlier */ - { - s7_pointer p = current_input_port(sc); - if ((is_input_port(p)) && - (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)); - symbol_set_tag(car_expr, 1); /* one warning is enough */ - } + if ((sc->undefined_identifier_warnings) && + (slot == sc->undefined) && /* car_expr is not in e or global */ + (symbol_tag(car_expr) == 0)) /* and we haven't looked it up earlier */ + { + s7_pointer p = current_input_port(sc); + if ((is_input_port(p)) && + (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)); + symbol_set_tag(car_expr, 1); /* one warning is enough */ + } /* car_expr is a symbol but it's not a built-in procedure or a safe case = vector etc */ { - /* else maybe it's something like a let variable binding: (sqrtfreq (sqrt frequency)) */ - s7_pointer p; - int32_t len = 0, pairs = 0, symbols = 0; - - for (p = cdr(expr); is_pair(p); p = cdr(p), len++) - { - s7_pointer car_p = car(p); - if (is_pair(car_p)) - { - pairs++; - if ((!is_checked(car_p)) && - (optimize_expression(sc, car_p, hop, e, false) == OPT_OOPS)) - return(OPT_OOPS); - } - else - if (is_symbol(car_p)) - symbols++; - } - if ((is_null(p)) && /* (+ 1 . 2) */ - (!is_optimized(expr))) - { - /* len=0 case is almost entirely arglists */ - set_opt1_con(expr, sc->unused); - - if (pairs == 0) - { - if (len == 0) - { - /* hoping to catch object application here, as in readers in Snd */ - set_unsafe_optimize_op(expr, OP_UNKNOWN); - return(OPT_F); - } - if (len == 1) - { - if (!is_quote(car_expr)) /* !! quote can be redefined locally, unsetting the T_SYNTACTIC flag -- can this happen elsewhere? */ - set_unsafe_optimize_op(expr, (is_normal_symbol(cadr(expr))) ? OP_UNKNOWN_S : OP_UNKNOWN_A); - fx_annotate_arg(sc, cdr(expr), e); /* g->a later if closure */ - return(OPT_F); - } - if (len == 2) - { - set_unsafely_optimized(expr); - set_optimize_op(expr, OP_UNKNOWN_GG); - return(OPT_F); - } - if (len >= 3) - { - if (len == symbols) - { - set_unsafe_optimize_op(expr, OP_UNKNOWN_NS); - set_opt3_arglen(cdr(expr), len); - return(OPT_F); - } - if (fx_count(sc, expr) == len) - { - set_unsafe_optimize_op(expr, OP_UNKNOWN_NA); - set_opt3_arglen(cdr(expr), len); - return(OPT_F); - }}} - else /* pairs != 0 */ - { - s7_pointer arg1 = cadr(expr); - if ((pairs == 1) && (len == 1)) - { - if ((is_quote(car_expr)) && - (direct_memq(sc->quote_symbol, e))) - return(OPT_OOPS); - - if (is_fxable(sc, arg1)) - { - set_opt3_arglen(cdr(expr), 1); - fx_annotate_arg(sc, cdr(expr), e); - set_unsafe_optimize_op(expr, OP_UNKNOWN_A); - return(OPT_F); - }} - if (fx_count(sc, expr) == len) - { - set_unsafe_optimize_op(expr, (len == 1) ? OP_UNKNOWN_A : ((len == 2) ? OP_UNKNOWN_AA : OP_UNKNOWN_NA)); - set_opt3_arglen(cdr(expr), len); - if (len <= 2) fx_annotate_args(sc, cdr(expr), e); - return(OPT_F); - } - set_unsafe_optimize_op(expr, OP_UNKNOWN_NP); - set_opt3_arglen(cdr(expr), len); - return(OPT_F); - }}}} + /* else maybe it's something like a let variable binding: (sqrtfreq (sqrt frequency)) */ + s7_pointer p; + int32_t len = 0, pairs = 0, symbols = 0; + + for (p = cdr(expr); is_pair(p); p = cdr(p), len++) + { + s7_pointer car_p = car(p); + if (is_pair(car_p)) + { + pairs++; + if ((!is_checked(car_p)) && + (optimize_expression(sc, car_p, hop, e, false) == OPT_OOPS)) + return(OPT_OOPS); + } + else + if (is_symbol(car_p)) + symbols++; + } + if ((is_null(p)) && /* (+ 1 . 2) */ + (!is_optimized(expr))) + { + /* len=0 case is almost entirely arglists */ + set_opt1_con(expr, sc->unused); + + if (pairs == 0) + { + if (len == 0) + { + /* hoping to catch object application here, as in readers in Snd */ + set_unsafe_optimize_op(expr, OP_UNKNOWN); + return(OPT_F); + } + if (len == 1) + { + if (!is_quote(car_expr)) /* !! quote can be redefined locally, unsetting the T_SYNTACTIC flag -- can this happen elsewhere? */ + set_unsafe_optimize_op(expr, (is_normal_symbol(cadr(expr))) ? OP_UNKNOWN_S : OP_UNKNOWN_A); + fx_annotate_arg(sc, cdr(expr), e); /* g->a later if closure */ + return(OPT_F); + } + if (len == 2) + { + set_unsafely_optimized(expr); + set_optimize_op(expr, OP_UNKNOWN_GG); + return(OPT_F); + } + if (len >= 3) + { + if (len == symbols) + { + set_unsafe_optimize_op(expr, OP_UNKNOWN_NS); + set_opt3_arglen(cdr(expr), len); + return(OPT_F); + } + if (fx_count(sc, expr) == len) + { + set_unsafe_optimize_op(expr, OP_UNKNOWN_NA); + set_opt3_arglen(cdr(expr), len); + return(OPT_F); + }}} + else /* pairs != 0 */ + { + s7_pointer arg1 = cadr(expr); + if ((pairs == 1) && (len == 1)) + { + if ((is_quote(car_expr)) && + (direct_memq(sc->quote_symbol, e))) + return(OPT_OOPS); + + if (is_fxable(sc, arg1)) + { + set_opt3_arglen(cdr(expr), 1); + fx_annotate_arg(sc, cdr(expr), e); + set_unsafe_optimize_op(expr, OP_UNKNOWN_A); + return(OPT_F); + }} + if (fx_count(sc, expr) == len) + { + set_unsafe_optimize_op(expr, (len == 1) ? OP_UNKNOWN_A : ((len == 2) ? OP_UNKNOWN_AA : OP_UNKNOWN_NA)); + set_opt3_arglen(cdr(expr), len); + if (len <= 2) fx_annotate_args(sc, cdr(expr), e); + return(OPT_F); + } + set_unsafe_optimize_op(expr, OP_UNKNOWN_NP); + set_opt3_arglen(cdr(expr), len); + return(OPT_F); + }}}} else { /* car(expr) is not a symbol, but there might be interesting stuff here */ @@ -73808,26 +73808,26 @@ static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7 s7_pointer p; if ((car_expr == sc->quote_function) && (is_pair(cdr(expr)))) /* very common */ - return(optimize_syntax(sc, expr, sc->quote_function, hop, e, export_ok)); + return(optimize_syntax(sc, expr, sc->quote_function, hop, e, export_ok)); if (is_c_function(car_expr)) /* (#_abs x) etc */ - return(optimize_funcs(sc, expr, car_expr, 1, orig_hop, e)); + return(optimize_funcs(sc, expr, car_expr, 1, orig_hop, e)); if (is_syntax(car_expr)) /* (#_cond...) etc */ - { - if (!is_pair(cdr(expr))) - return(OPT_OOPS); - return(optimize_syntax(sc, expr, car_expr, orig_hop, e, export_ok)); - } + { + if (!is_pair(cdr(expr))) + return(OPT_OOPS); + return(optimize_syntax(sc, expr, car_expr, orig_hop, e, export_ok)); + } if (is_any_macro(car_expr)) - return(OPT_F); + return(OPT_F); /* if car is a pair, we can't easily tell whether its value is (say) + or cond, so we need to catch this case and fixup fx settings */ for (p = expr; is_pair(p); p = cdr(p)) - if (((is_symbol(car(p))) && (is_syntactic_symbol(car(p)))) || - ((is_pair(car(p))) && (!is_checked(car(p))) && - (optimize_expression(sc, car(p), hop, e, false) == OPT_OOPS))) - return(OPT_OOPS); + if (((is_symbol(car(p))) && (is_syntactic_symbol(car(p)))) || + ((is_pair(car(p))) && (!is_checked(car(p))) && + (optimize_expression(sc, car(p), hop, e, false) == OPT_OOPS))) + return(OPT_OOPS); /* here we get for example: * ((if (not (let? p)) write write-to-vector) obj p) ; not uncomplicated/c-function [((if 3d fourth third) p) in index] * ((if (symbol? (cadr f)) cadr (if (pair? (cadr f)) caadr not)) f) ; fx not symbol -- opif_a_aaq_a @@ -73845,20 +73845,20 @@ static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e) s7_pointer obj = car(x); set_checked(x); if (is_pair(obj)) - { - if ((!is_checked(obj)) && - (optimize_expression(sc, obj, hop, e, true) == OPT_OOPS)) - { - s7_pointer p; - for (p = cdr(x); is_pair(p); p = cdr(p)); - if (!is_null(p)) - syntax_error_nr(sc, "stray dot in function body: ~S", 30, code); - return(OPT_OOPS); - }} + { + if ((!is_checked(obj)) && + (optimize_expression(sc, obj, hop, e, true) == OPT_OOPS)) + { + s7_pointer p; + for (p = cdr(x); is_pair(p); p = cdr(p)); + if (!is_null(p)) + syntax_error_nr(sc, "stray dot in function body: ~S", 30, code); + return(OPT_OOPS); + }} else /* new 22-Sep-19, but I don't think this saves anything over falling into trailers */ - if (is_symbol(obj)) - set_optimize_op(obj, (is_keyword(obj)) ? OP_CONSTANT : OP_SYMBOL); - else set_optimize_op(obj, OP_CONSTANT); + if (is_symbol(obj)) + set_optimize_op(obj, (is_keyword(obj)) ? OP_CONSTANT : OP_SYMBOL); + else set_optimize_op(obj, OP_CONSTANT); } if (!is_list(x)) syntax_error_nr(sc, "stray dot in function body: ~S", 30, code); @@ -73871,7 +73871,7 @@ static bool symbol_is_in_arg_list(const s7_pointer sym, s7_pointer lst) s7_pointer x; for (x = lst; is_pair(x); x = cdr(x)) if ((sym == car(x)) || - ((is_pair(car(x))) && (sym == caar(x)))) + ((is_pair(car(x))) && (sym == caar(x)))) return(true); return(sym == x); } @@ -73884,8 +73884,8 @@ static void check_lambda_args(s7_scheme *sc, s7_pointer args, int32_t *arity, s7 if (!is_list(args)) { if (is_constant(sc, args)) /* (lambda :a ...) or (define (f :a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "lambda parameter is a constant: (~S ~S ...)", 43), car(form), cadr(form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "lambda parameter is a constant: (~S ~S ...)", 43), car(form), cadr(form))); /* we currently accept (lambda i i . i) (lambda quote i) (lambda : : . #()) (lambda : 1 . "") * at this level, but when the lambda form is evaluated, it will trigger an error. */ @@ -73897,33 +73897,33 @@ static void check_lambda_args(s7_scheme *sc, s7_pointer args, int32_t *arity, s7 { s7_pointer car_x = car(x); if (is_constant(sc, car_x)) /* (lambda (pi) pi), constant here means not a symbol */ - { - if (is_pair(car_x)) /* (lambda ((:hi . "hi") . "hi") 1) */ - error_nr(sc, sc->syntax_error_symbol, /* don't use ~A here or below, (lambda #\null do) for example */ - set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a pair (perhaps use lambda*?): (~S ~S ...)", 65), - car_x, car(form), cadr(form))); - if ((car_x == sc->rest_keyword) && - ((car(form) == sc->define_symbol) || (car(form) == sc->lambda_symbol))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_5(sc, wrap_string(sc, "lambda parameter is ~S? (~S ~S ...), perhaps use ~S", 51), - car_x, car(form), cadr(form), - (car(form) == sc->define_symbol) ? sc->define_star_symbol : sc->lambda_star_symbol)); - error_nr(sc, sc->syntax_error_symbol, /* (lambda (a :b c) 1) */ - set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a constant: (~S ~S ...)", 46), - car_x, car(form), cadr(form))); - } + { + if (is_pair(car_x)) /* (lambda ((:hi . "hi") . "hi") 1) */ + error_nr(sc, sc->syntax_error_symbol, /* don't use ~A here or below, (lambda #\null do) for example */ + set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a pair (perhaps use lambda*?): (~S ~S ...)", 65), + car_x, car(form), cadr(form))); + if ((car_x == sc->rest_keyword) && + ((car(form) == sc->define_symbol) || (car(form) == sc->lambda_symbol))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "lambda parameter is ~S? (~S ~S ...), perhaps use ~S", 51), + car_x, car(form), cadr(form), + (car(form) == sc->define_symbol) ? sc->define_star_symbol : sc->lambda_star_symbol)); + error_nr(sc, sc->syntax_error_symbol, /* (lambda (a :b c) 1) */ + set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a constant: (~S ~S ...)", 46), + car_x, car(form), cadr(form))); + } if (symbol_is_in_arg_list(car_x, cdr(x))) /* (lambda (a a) ...) or (lambda (a . a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is used twice in the parameter list, (~S ~S ...)", 68), - car_x, car(form), cadr(form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is used twice in the parameter list, (~S ~S ...)", 68), + car_x, car(form), cadr(form))); set_local(car_x); } if (is_not_null(x)) { if (is_constant(sc, x)) /* (lambda (a . 0.0) a) or (lambda (a . :b) a) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda :rest parameter ~S is a constant in (~S ~S ...)", 54), - x, car(form), cadr(form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "lambda :rest parameter ~S is a constant in (~S ~S ...)", 54), + x, car(form), cadr(form))); i = -i - 1; } if (arity) (*arity) = i; @@ -73937,8 +73937,8 @@ static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, s7_poin if (!is_list(args)) { if (is_constant(sc, args)) /* (lambda* :a ...) or (define* (f . :a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "lambda* parameter is a constant: (~S ~S ...)", 44), car(form), cadr(form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "lambda* parameter is a constant: (~S ~S ...)", 44), car(form), cadr(form))); if (is_symbol(args)) set_local(args); return(args); } @@ -73949,96 +73949,96 @@ static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, s7_poin { s7_pointer car_w = car(w); if (is_pair(car_w)) - { - has_defaults = true; - if (is_constant(sc, car(car_w))) /* (lambda* ((:a 1)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is a constant: (~S ~S ...)", 47), - car(car_w), car(form), cadr(form))); - if (symbol_is_in_arg_list(caar(w), cdr(w))) /* (lambda* ((a 1) a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S occurs twice in the argument list: (~S ~S ...)", 67), - car(car_w), car(form), cadr(form))); - if (!is_pair(cdr(car_w))) - { - if (is_null(cdr(car_w))) /* (lambda* ((a)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S default value missing in (~S ~S ...)", 57), - car_w, car(form), cadr(form))); - error_nr(sc, sc->syntax_error_symbol, /* (lambda* ((a . 0.0)) a) */ - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is a dotted pair in (~S ~S ...)", 52), - car_w, car(form), cadr(form))); - } - if ((is_pair(cadr(car_w))) && /* (lambda* ((a (quote . -1))) ...) */ - (s7_list_length(sc, cadr(car_w)) < 0)) - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S default value is not a proper list in (~S ~S ...)", 70), - car_w, car(form), cadr(form))); - if (is_not_null(cddr(car_w))) /* (lambda* ((a 0.0 'hi)) a) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S has multiple default values in (~S ~S ...)", 63), - car_w, car(form), cadr(form))); - - set_local(car(car_w)); - } + { + has_defaults = true; + if (is_constant(sc, car(car_w))) /* (lambda* ((:a 1)) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is a constant: (~S ~S ...)", 47), + car(car_w), car(form), cadr(form))); + if (symbol_is_in_arg_list(caar(w), cdr(w))) /* (lambda* ((a 1) a) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S occurs twice in the argument list: (~S ~S ...)", 67), + car(car_w), car(form), cadr(form))); + if (!is_pair(cdr(car_w))) + { + if (is_null(cdr(car_w))) /* (lambda* ((a)) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S default value missing in (~S ~S ...)", 57), + car_w, car(form), cadr(form))); + error_nr(sc, sc->syntax_error_symbol, /* (lambda* ((a . 0.0)) a) */ + set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is a dotted pair in (~S ~S ...)", 52), + car_w, car(form), cadr(form))); + } + if ((is_pair(cadr(car_w))) && /* (lambda* ((a (quote . -1))) ...) */ + (s7_list_length(sc, cadr(car_w)) < 0)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S default value is not a proper list in (~S ~S ...)", 70), + car_w, car(form), cadr(form))); + if (is_not_null(cddr(car_w))) /* (lambda* ((a 0.0 'hi)) a) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S has multiple default values in (~S ~S ...)", 63), + car_w, car(form), cadr(form))); + + set_local(car(car_w)); + } else - if (car_w != sc->rest_keyword) - { - if (is_constant(sc, car_w)) - { - if (car_w != sc->allow_other_keys_keyword) - error_nr(sc, sc->syntax_error_symbol, /* (lambda* (pi) ...) */ - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is a constant: (~S ~S ...)", 47), - car_w, car(form), cadr(form))); - if (is_not_null(cdr(w))) /* (lambda* (:allow-other-keys x) x) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, ":allow-other-keys should be the last parameter: (~S ~S ...)", 59), - car(form), cadr(form))); - if (w == top) /* (lambda* (:allow-other-keys) 1) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, ":allow-other-keys can't be the only parameter: (~S ~S ...)", 58), - car(form), cadr(form))); - set_allow_other_keys(top); - set_cdr(v, sc->nil); - } - if (symbol_is_in_arg_list(car_w, cdr(w))) /* (lambda* (a a) ...) or (lambda* (a . a) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is used twice in the parameter list: (~S ~S ...)", 69), - car_w, car(form), cadr(form))); - - if (!is_keyword(car_w)) set_local(car_w); - } - else - { - has_defaults = true; - if (!is_pair(cdr(w))) /* (lambda* (:rest) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "lambda* :rest parameter missing in (~S ~S ...)", 46), - car(form), cadr(form))); - if (!is_symbol(cadr(w))) /* (lambda* (:rest (a 1)) ...) */ - { - if (!is_pair(cadr(w))) /* (lambda* (:rest 1) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* :rest parameter is not a symbol: ~S in (~S ~S ...)", 58), - w, car(form), cadr(form))); - error_nr(sc, sc->syntax_error_symbol, /* (lambda* (:rest '(1 2)) 1) */ - set_elist_4(sc, wrap_string(sc, "lambda* :rest parameter can't have a default value: ~S in (~S ~S ...)", 69), - w, car(form), cadr(form))); - } - if (is_constant(sc, cadr(w))) /* (lambda* (a :rest x) ...) where x is locally a constant */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "lambda*: ~S is immutable, so it can't be the :rest parameter name: (~S ~S ...)", 78), - cadr(w), car(form), cadr(form))); - set_local(cadr(w)); - }} + if (car_w != sc->rest_keyword) + { + if (is_constant(sc, car_w)) + { + if (car_w != sc->allow_other_keys_keyword) + error_nr(sc, sc->syntax_error_symbol, /* (lambda* (pi) ...) */ + set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is a constant: (~S ~S ...)", 47), + car_w, car(form), cadr(form))); + if (is_not_null(cdr(w))) /* (lambda* (:allow-other-keys x) x) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, ":allow-other-keys should be the last parameter: (~S ~S ...)", 59), + car(form), cadr(form))); + if (w == top) /* (lambda* (:allow-other-keys) 1) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, ":allow-other-keys can't be the only parameter: (~S ~S ...)", 58), + car(form), cadr(form))); + set_allow_other_keys(top); + set_cdr(v, sc->nil); + } + if (symbol_is_in_arg_list(car_w, cdr(w))) /* (lambda* (a a) ...) or (lambda* (a . a) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "lambda* parameter ~S is used twice in the parameter list: (~S ~S ...)", 69), + car_w, car(form), cadr(form))); + + if (!is_keyword(car_w)) set_local(car_w); + } + else + { + has_defaults = true; + if (!is_pair(cdr(w))) /* (lambda* (:rest) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "lambda* :rest parameter missing in (~S ~S ...)", 46), + car(form), cadr(form))); + if (!is_symbol(cadr(w))) /* (lambda* (:rest (a 1)) ...) */ + { + if (!is_pair(cadr(w))) /* (lambda* (:rest 1) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "lambda* :rest parameter is not a symbol: ~S in (~S ~S ...)", 58), + w, car(form), cadr(form))); + error_nr(sc, sc->syntax_error_symbol, /* (lambda* (:rest '(1 2)) 1) */ + set_elist_4(sc, wrap_string(sc, "lambda* :rest parameter can't have a default value: ~S in (~S ~S ...)", 69), + w, car(form), cadr(form))); + } + if (is_constant(sc, cadr(w))) /* (lambda* (a :rest x) ...) where x is locally a constant */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "lambda*: ~S is immutable, so it can't be the :rest parameter name: (~S ~S ...)", 78), + cadr(w), car(form), cadr(form))); + set_local(cadr(w)); + }} if (is_not_null(w)) { if (is_constant(sc, w)) /* (lambda* (a . 0.0) a) or (lambda* (a . :b) a) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "lambda* :rest parameter ~S is a constant, (~S ~S ...)", 53), - w, car(form), cadr(form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "lambda* :rest parameter ~S is a constant, (~S ~S ...)", 53), + w, car(form), cadr(form))); if (is_symbol(w)) - set_local(w); + set_local(w); } else if ((body) && (!has_defaults) && (is_pair(args))) @@ -74068,348 +74068,348 @@ static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at { if (!is_pair(cdr(x))) return(UNSAFE_BODY); switch (symbol_syntax_op_checked(x)) - /* symbol_syntax_op(expr) here gets tangled in fx_annotation order problems! -- fix this?!? - * it appears that safe bodies are marked unsafe because the opts are out-of-order? - */ - { - case OP_OR: case OP_AND: case OP_BEGIN: case OP_WITH_BAFFLE: - return(body_is_safe(sc, func, cdr(x), at_end)); - - case OP_MACROEXPAND: - return(UNSAFE_BODY); - - case OP_QUOTE: case OP_QUOTE_UNCHECKED: - return(((!is_pair(cdr(x))) || (!is_null(cddr(x)))) ? UNSAFE_BODY : VERY_SAFE_BODY); /* (quote . 1) or (quote 1 2) etc */ - - case OP_IF: - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (is_pair(cadr(x))) - { - result = form_is_safe(sc, func, cadr(x), false); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (is_pair(caddr(x))) - { - result = min_body(result, form_is_safe(sc, func, caddr(x), at_end)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if ((is_pair(cdddr(x))) && - (is_pair(cadddr(x)))) - return(min_body(result, form_is_safe(sc, func, cadddr(x), at_end))); - return(result); - - case OP_WHEN: case OP_UNLESS: - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (is_pair(cadr(x))) - { - result = form_is_safe(sc, func, cadr(x), false); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - return(min_body(result, body_is_safe(sc, func, cddr(x), at_end))); - - case OP_COND: - { - bool follow = false; - s7_pointer p = cdr(x); - for (s7_pointer sp = x; is_pair(p); p = cdr(p)) - { - s7_pointer ex = car(p); - if (!is_pair(ex)) return(UNSAFE_BODY); - if (is_pair(car(ex))) - { - result = min_body(result, form_is_safe(sc, func, car(ex), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (is_pair(cdr(ex))) - { - result = min_body(result, body_is_safe(sc, func, cdr(ex), at_end)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - } - return((is_null(p)) ? result : UNSAFE_BODY); - } - - case OP_CASE: - { - bool follow = false; - s7_pointer sp, p; - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (is_pair(cadr(x))) - { - result = form_is_safe(sc, func, cadr(x), false); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - sp = cdr(x); - for (p = cdr(sp); is_pair(p); p = cdr(p)) - { - if (!is_pair(car(p))) return(UNSAFE_BODY); - if (is_pair(cdar(p))) - { - result = min_body(result, body_is_safe(sc, func, cdar(p), at_end)); /* null cdar(p) ok here */ - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - } - return(result); - } - - case OP_SET: - /* if we set func, we have to abandon the tail call scan: (let () (define (hi a) (let ((v (vector 1 2 3))) (set! hi v) (hi a))) (hi 1)) */ - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (cadr(x) == func) return(UNSAFE_BODY); - - /* car(x) is set!, cadr(x) is settee or obj, caddr(x) is val */ - if (is_pair(caddr(x))) - { - result = form_is_safe(sc, func, caddr(x), false); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - return((is_pair(cadr(x))) ? min_body(result, form_is_safe(sc, func, cadr(x), false)) : result); - /* not OP_DEFINE even in simple cases (safe_closure assumes constant funclet) */ - - case OP_WITH_LET: - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - return((is_pair(cadr(x))) ? UNSAFE_BODY : min_body(body_is_safe(sc, sc->F, cddr(x), at_end), SAFE_BODY)); - /* shadowing can happen in with-let -- symbols are global so local_slots are shadowable */ - - case OP_LET_TEMPORARILY: - if (!is_pair(cadr(x))) return(UNSAFE_BODY); - for (s7_pointer p = cadr(x); is_pair(p); p = cdr(p)) - { - if ((!is_pair(car(p))) || - (!is_pair(cdar(p)))) - return(UNSAFE_BODY); - if (is_pair(cadar(p))) - { - result = min_body(result, form_is_safe(sc, sc->F, cadar(p), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - }} - return(min_body(result, body_is_safe(sc, sc->F, cddr(x), at_end))); - - /* in the name binders, we first have to check that "func" actually is the same thing as the caller's func */ - case OP_LET: case OP_LET_STAR: case OP_LETREC: case OP_LETREC_STAR: - { - bool follow = false; - s7_pointer let_name, sp, vars = cadr(x), body = cddr(x); - if (is_symbol(vars)) - { - if (!is_pair(body)) return(UNSAFE_BODY); /* (let name . res) */ - if (vars == func) return(UNSAFE_BODY); /* named let shadows caller */ - let_name = vars; - vars = caddr(x); - body = cdddr(x); - if (is_symbol(func)) - add_symbol_to_list(sc, func); - } - else let_name = func; - - for (sp = NULL; is_pair(vars); vars = cdr(vars)) - { - s7_pointer let_var = car(vars), var_name; - - if ((!is_pair(let_var)) || - (!is_pair(cdr(let_var)))) - return(UNSAFE_BODY); - var_name = car(let_var); - if ((!is_symbol(var_name)) || - (var_name == let_name) || /* let var shadows caller */ - (var_name == func)) - return(UNSAFE_BODY); - add_symbol_to_list(sc, var_name); - - if (is_pair(cadr(let_var))) - { - result = min_body(result, form_is_safe(sc, let_name, cadr(let_var), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - follow = (!follow); - if (follow) - { - if (!sp) - sp = vars; - else - { - sp = cdr(sp); - if (vars == sp) return(UNSAFE_BODY); - }}} - return(min_body(result, body_is_safe(sc, let_name, body, (let_name != func) || at_end))); - } - - case OP_DO: /* (do (...) (...) ...) */ - if (!is_pair(cddr(x))) return(UNSAFE_BODY); - if (is_pair(cadr(x))) - { - s7_pointer vars = cadr(x); - s7_pointer sp = vars; - for (bool follow = false; is_pair(vars); vars = cdr(vars)) - { - s7_pointer do_var = car(vars); - if ((!is_pair(do_var)) || - (!is_pair(cdr(do_var))) || /* (do ((a . 1) (b . 2)) ...) */ - (car(do_var) == func) || - (!is_symbol(car(do_var)))) - return(UNSAFE_BODY); - - add_symbol_to_list(sc, car(do_var)); - - if (is_pair(cadr(do_var))) - result = min_body(result, form_is_safe(sc, func, cadr(do_var), false)); - if ((is_pair(cddr(do_var))) && (is_pair(caddr(do_var)))) - result = min_body(result, form_is_safe(sc, func, caddr(do_var), false)); - if (result == UNSAFE_BODY) - return(UNSAFE_BODY); - if (sp != vars) - { - if (follow) {sp = cdr(sp); if (vars == sp) return(UNSAFE_BODY);} - follow = (!follow); - }}} - if (is_pair(caddr(x))) - result = min_body(result, body_is_safe(sc, func, caddr(x), at_end)); - return(min_body(result, body_is_safe(sc, func, cdddr(x), false))); - - /* define and friends are not safe: (define (a) (define b 3)...) tries to put b in the current let, - * but in a safe func, that's a constant. See s7test L 1865 for an example. - */ - default: - /* OP_LAMBDA is major case here */ - /* try to catch weird cases like: - * (let () (define (hi1 a) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1)) - * (let () (define (hi1 a) (define (ho1 b) b) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1)) - */ - return(UNSAFE_BODY); - }} + /* symbol_syntax_op(expr) here gets tangled in fx_annotation order problems! -- fix this?!? + * it appears that safe bodies are marked unsafe because the opts are out-of-order? + */ + { + case OP_OR: case OP_AND: case OP_BEGIN: case OP_WITH_BAFFLE: + return(body_is_safe(sc, func, cdr(x), at_end)); + + case OP_MACROEXPAND: + return(UNSAFE_BODY); + + case OP_QUOTE: case OP_QUOTE_UNCHECKED: + return(((!is_pair(cdr(x))) || (!is_null(cddr(x)))) ? UNSAFE_BODY : VERY_SAFE_BODY); /* (quote . 1) or (quote 1 2) etc */ + + case OP_IF: + if (!is_pair(cddr(x))) return(UNSAFE_BODY); + if (is_pair(cadr(x))) + { + result = form_is_safe(sc, func, cadr(x), false); + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + } + if (is_pair(caddr(x))) + { + result = min_body(result, form_is_safe(sc, func, caddr(x), at_end)); + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + } + if ((is_pair(cdddr(x))) && + (is_pair(cadddr(x)))) + return(min_body(result, form_is_safe(sc, func, cadddr(x), at_end))); + return(result); + + case OP_WHEN: case OP_UNLESS: + if (!is_pair(cddr(x))) return(UNSAFE_BODY); + if (is_pair(cadr(x))) + { + result = form_is_safe(sc, func, cadr(x), false); + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + } + return(min_body(result, body_is_safe(sc, func, cddr(x), at_end))); + + case OP_COND: + { + bool follow = false; + s7_pointer p = cdr(x); + for (s7_pointer sp = x; is_pair(p); p = cdr(p)) + { + s7_pointer ex = car(p); + if (!is_pair(ex)) return(UNSAFE_BODY); + if (is_pair(car(ex))) + { + result = min_body(result, form_is_safe(sc, func, car(ex), false)); + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + } + if (is_pair(cdr(ex))) + { + result = min_body(result, body_is_safe(sc, func, cdr(ex), at_end)); + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + } + if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} + follow = (!follow); + } + return((is_null(p)) ? result : UNSAFE_BODY); + } + + case OP_CASE: + { + bool follow = false; + s7_pointer sp, p; + if (!is_pair(cddr(x))) return(UNSAFE_BODY); + if (is_pair(cadr(x))) + { + result = form_is_safe(sc, func, cadr(x), false); + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + } + sp = cdr(x); + for (p = cdr(sp); is_pair(p); p = cdr(p)) + { + if (!is_pair(car(p))) return(UNSAFE_BODY); + if (is_pair(cdar(p))) + { + result = min_body(result, body_is_safe(sc, func, cdar(p), at_end)); /* null cdar(p) ok here */ + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + } + if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} + follow = (!follow); + } + return(result); + } + + case OP_SET: + /* if we set func, we have to abandon the tail call scan: (let () (define (hi a) (let ((v (vector 1 2 3))) (set! hi v) (hi a))) (hi 1)) */ + if (!is_pair(cddr(x))) return(UNSAFE_BODY); + if (cadr(x) == func) return(UNSAFE_BODY); + + /* car(x) is set!, cadr(x) is settee or obj, caddr(x) is val */ + if (is_pair(caddr(x))) + { + result = form_is_safe(sc, func, caddr(x), false); + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + } + return((is_pair(cadr(x))) ? min_body(result, form_is_safe(sc, func, cadr(x), false)) : result); + /* not OP_DEFINE even in simple cases (safe_closure assumes constant funclet) */ + + case OP_WITH_LET: + if (!is_pair(cddr(x))) return(UNSAFE_BODY); + return((is_pair(cadr(x))) ? UNSAFE_BODY : min_body(body_is_safe(sc, sc->F, cddr(x), at_end), SAFE_BODY)); + /* shadowing can happen in with-let -- symbols are global so local_slots are shadowable */ + + case OP_LET_TEMPORARILY: + if (!is_pair(cadr(x))) return(UNSAFE_BODY); + for (s7_pointer p = cadr(x); is_pair(p); p = cdr(p)) + { + if ((!is_pair(car(p))) || + (!is_pair(cdar(p)))) + return(UNSAFE_BODY); + if (is_pair(cadar(p))) + { + result = min_body(result, form_is_safe(sc, sc->F, cadar(p), false)); + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + }} + return(min_body(result, body_is_safe(sc, sc->F, cddr(x), at_end))); + + /* in the name binders, we first have to check that "func" actually is the same thing as the caller's func */ + case OP_LET: case OP_LET_STAR: case OP_LETREC: case OP_LETREC_STAR: + { + bool follow = false; + s7_pointer let_name, sp, vars = cadr(x), body = cddr(x); + if (is_symbol(vars)) + { + if (!is_pair(body)) return(UNSAFE_BODY); /* (let name . res) */ + if (vars == func) return(UNSAFE_BODY); /* named let shadows caller */ + let_name = vars; + vars = caddr(x); + body = cdddr(x); + if (is_symbol(func)) + add_symbol_to_list(sc, func); + } + else let_name = func; + + for (sp = NULL; is_pair(vars); vars = cdr(vars)) + { + s7_pointer let_var = car(vars), var_name; + + if ((!is_pair(let_var)) || + (!is_pair(cdr(let_var)))) + return(UNSAFE_BODY); + var_name = car(let_var); + if ((!is_symbol(var_name)) || + (var_name == let_name) || /* let var shadows caller */ + (var_name == func)) + return(UNSAFE_BODY); + add_symbol_to_list(sc, var_name); + + if (is_pair(cadr(let_var))) + { + result = min_body(result, form_is_safe(sc, let_name, cadr(let_var), false)); + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + } + follow = (!follow); + if (follow) + { + if (!sp) + sp = vars; + else + { + sp = cdr(sp); + if (vars == sp) return(UNSAFE_BODY); + }}} + return(min_body(result, body_is_safe(sc, let_name, body, (let_name != func) || at_end))); + } + + case OP_DO: /* (do (...) (...) ...) */ + if (!is_pair(cddr(x))) return(UNSAFE_BODY); + if (is_pair(cadr(x))) + { + s7_pointer vars = cadr(x); + s7_pointer sp = vars; + for (bool follow = false; is_pair(vars); vars = cdr(vars)) + { + s7_pointer do_var = car(vars); + if ((!is_pair(do_var)) || + (!is_pair(cdr(do_var))) || /* (do ((a . 1) (b . 2)) ...) */ + (car(do_var) == func) || + (!is_symbol(car(do_var)))) + return(UNSAFE_BODY); + + add_symbol_to_list(sc, car(do_var)); + + if (is_pair(cadr(do_var))) + result = min_body(result, form_is_safe(sc, func, cadr(do_var), false)); + if ((is_pair(cddr(do_var))) && (is_pair(caddr(do_var)))) + result = min_body(result, form_is_safe(sc, func, caddr(do_var), false)); + if (result == UNSAFE_BODY) + return(UNSAFE_BODY); + if (sp != vars) + { + if (follow) {sp = cdr(sp); if (vars == sp) return(UNSAFE_BODY);} + follow = (!follow); + }}} + if (is_pair(caddr(x))) + result = min_body(result, body_is_safe(sc, func, caddr(x), at_end)); + return(min_body(result, body_is_safe(sc, func, cdddr(x), false))); + + /* define and friends are not safe: (define (a) (define b 3)...) tries to put b in the current let, + * but in a safe func, that's a constant. See s7test L 1865 for an example. + */ + default: + /* OP_LAMBDA is major case here */ + /* try to catch weird cases like: + * (let () (define (hi1 a) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1)) + * (let () (define (hi1 a) (define (ho1 b) b) (define (hi1 b) (+ b 1)) (hi1 a)) (hi1 1)) + */ + return(UNSAFE_BODY); + }} else /* car(x) is not syntactic */ { if (expr == func) /* try to catch tail call, expr is car(x) */ - { - bool follow = false; - s7_pointer sp = x, p; - sc->got_rec = true; /* (walk (car tree)) lint and almost all others in s7test */ - set_rec_tc_args(sc, proper_list_length(cdr(x))); - if (!at_end) {result = RECUR_BODY; sc->not_tc = true;} - for (p = cdr(x); is_pair(p); p = cdr(p)) - { - if (is_pair(car(p))) - { - if (caar(p) == func) /* func called as arg, so not tail call */ - { - sc->not_tc = true; - result = RECUR_BODY; - } - result = min_body(result, form_is_safe(sc, func, car(p), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - else - if (car(p) == func) /* func itself as arg */ - return(UNSAFE_BODY); - - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - } - if ((at_end) && (!sc->not_tc) && (is_null(p))) /* tail call, so safe */ - { - sc->got_tc = true; - set_rec_tc_args(sc, proper_list_length(cdr(x))); - return(result); - } - if (result != UNSAFE_BODY) result = RECUR_BODY; - return(result); - } + { + bool follow = false; + s7_pointer sp = x, p; + sc->got_rec = true; /* (walk (car tree)) lint and almost all others in s7test */ + set_rec_tc_args(sc, proper_list_length(cdr(x))); + if (!at_end) {result = RECUR_BODY; sc->not_tc = true;} + for (p = cdr(x); is_pair(p); p = cdr(p)) + { + if (is_pair(car(p))) + { + if (caar(p) == func) /* func called as arg, so not tail call */ + { + sc->not_tc = true; + result = RECUR_BODY; + } + result = min_body(result, form_is_safe(sc, func, car(p), false)); + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + } + else + if (car(p) == func) /* func itself as arg */ + return(UNSAFE_BODY); + + if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} + follow = (!follow); + } + if ((at_end) && (!sc->not_tc) && (is_null(p))) /* tail call, so safe */ + { + sc->got_tc = true; + set_rec_tc_args(sc, proper_list_length(cdr(x))); + return(result); + } + if (result != UNSAFE_BODY) result = RECUR_BODY; + return(result); + } if (is_symbol(expr)) /* expr=car(x) */ - { - s7_pointer f, f_slot; - bool c_safe; - - if (symbol_is_in_list(sc, expr)) return(UNSAFE_BODY); - if ((is_slot(global_slot(expr))) && (is_syntax(global_value(expr)))) - return(UNSAFE_BODY); /* syntax hidden behind some other name */ - - f_slot = s7_slot(sc, expr); - if (!is_slot(f_slot)) return(UNSAFE_BODY); - - f = slot_value(f_slot); - if (is_c_function(f)) - { - if ((expr == sc->apply_symbol) && (is_pair(cdr(x))) && (is_symbol(cadr(x)))) /* (apply <safe_c_function> ...) */ - { - s7_pointer cadr_f = lookup_unexamined(sc, cadr(x)); /* "unexamined" to skip unbound_variable */ - c_safe = ((cadr_f) && /* (cadr_f != sc->undefined) && */ - ((is_safe_c_function(cadr_f)) || - ((is_closure(cadr_f)) && (is_very_safe_closure(cadr_f))))); - } - else c_safe = (is_safe_or_scope_safe_procedure(f)); - } - else c_safe = false; - - result = ((is_simple_sequence(f)) || /* was is_sequence? */ - ((is_closure(f)) && (is_very_safe_closure(f))) || - ((c_safe) && ((is_immutable_slot(f_slot)) || (is_global(expr))))) ? VERY_SAFE_BODY : SAFE_BODY; - - if ((c_safe) || - ((is_any_closure(f)) && (is_safe_closure(f))) || - (is_simple_sequence(f))) /* was is_sequence? */ - { - bool follow = false; - s7_pointer sp = x, p = cdr(x); - - for (; is_pair(p); p = cdr(p)) - { - if (is_unquoted_pair(car(p))) - { - if (caar(p) == func) - { - sc->got_rec = true; /* (+ 1 (recur (- x 1))) t123 (and others) */ - set_rec_tc_args(sc, proper_list_length(cdar(p))); - return(RECUR_BODY); - } - if ((is_c_function(f)) && (is_scope_safe(f)) && - (caar(p) == sc->lambda_symbol)) - { - s7_pointer largs, lbody, q; - body_t lresult; - - if (!is_pair(cdar(p))) /* (lambda . /) */ - return(UNSAFE_BODY); - largs = cadar(p); - lbody = cddar(p); - for (q = largs; is_pair(q); q = cdr(q)) - { - if (!is_symbol(car(q))) - return(UNSAFE_BODY); - add_symbol_to_list(sc, car(q)); - } - lresult = body_is_safe(sc, func, lbody, false); - result = min_body(result, lresult); - } - else result = min_body(result, form_is_safe(sc, func, car(p), false)); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } - else - if (car(p) == func) /* the current function passed as an argument to something */ - return(UNSAFE_BODY); - - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - } - return((is_null(p)) ? result : UNSAFE_BODY); - } - if ((is_safe_quote(expr)) && - (is_proper_list_1(sc, cdr(x)))) - return(result); - - if (expr == sc->values_symbol) /* (values) is safe, as is (values x) if x is: (values (define...)) */ - { - if (is_null(cdr(x))) return(result); - if ((is_pair(cdr(x))) && (is_null(cddr(x)))) - return((is_pair(cadr(x))) ? min_body(result, form_is_safe(sc, func, cadr(x), false)) : result); - }} + { + s7_pointer f, f_slot; + bool c_safe; + + if (symbol_is_in_list(sc, expr)) return(UNSAFE_BODY); + if ((is_slot(global_slot(expr))) && (is_syntax(global_value(expr)))) + return(UNSAFE_BODY); /* syntax hidden behind some other name */ + + f_slot = s7_slot(sc, expr); + if (!is_slot(f_slot)) return(UNSAFE_BODY); + + f = slot_value(f_slot); + if (is_c_function(f)) + { + if ((expr == sc->apply_symbol) && (is_pair(cdr(x))) && (is_symbol(cadr(x)))) /* (apply <safe_c_function> ...) */ + { + s7_pointer cadr_f = lookup_unexamined(sc, cadr(x)); /* "unexamined" to skip unbound_variable */ + c_safe = ((cadr_f) && /* (cadr_f != sc->undefined) && */ + ((is_safe_c_function(cadr_f)) || + ((is_closure(cadr_f)) && (is_very_safe_closure(cadr_f))))); + } + else c_safe = (is_safe_or_scope_safe_procedure(f)); + } + else c_safe = false; + + result = ((is_simple_sequence(f)) || /* was is_sequence? */ + ((is_closure(f)) && (is_very_safe_closure(f))) || + ((c_safe) && ((is_immutable_slot(f_slot)) || (is_global(expr))))) ? VERY_SAFE_BODY : SAFE_BODY; + + if ((c_safe) || + ((is_any_closure(f)) && (is_safe_closure(f))) || + (is_simple_sequence(f))) /* was is_sequence? */ + { + bool follow = false; + s7_pointer sp = x, p = cdr(x); + + for (; is_pair(p); p = cdr(p)) + { + if (is_unquoted_pair(car(p))) + { + if (caar(p) == func) + { + sc->got_rec = true; /* (+ 1 (recur (- x 1))) t123 (and others) */ + set_rec_tc_args(sc, proper_list_length(cdar(p))); + return(RECUR_BODY); + } + if ((is_c_function(f)) && (is_scope_safe(f)) && + (caar(p) == sc->lambda_symbol)) + { + s7_pointer largs, lbody, q; + body_t lresult; + + if (!is_pair(cdar(p))) /* (lambda . /) */ + return(UNSAFE_BODY); + largs = cadar(p); + lbody = cddar(p); + for (q = largs; is_pair(q); q = cdr(q)) + { + if (!is_symbol(car(q))) + return(UNSAFE_BODY); + add_symbol_to_list(sc, car(q)); + } + lresult = body_is_safe(sc, func, lbody, false); + result = min_body(result, lresult); + } + else result = min_body(result, form_is_safe(sc, func, car(p), false)); + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + } + else + if (car(p) == func) /* the current function passed as an argument to something */ + return(UNSAFE_BODY); + + if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} + follow = (!follow); + } + return((is_null(p)) ? result : UNSAFE_BODY); + } + if ((is_safe_quote(expr)) && + (is_proper_list_1(sc, cdr(x)))) + return(result); + + if (expr == sc->values_symbol) /* (values) is safe, as is (values x) if x is: (values (define...)) */ + { + if (is_null(cdr(x))) return(result); + if ((is_pair(cdr(x))) && (is_null(cddr(x)))) + return((is_pair(cadr(x))) ? min_body(result, form_is_safe(sc, func, cadr(x), false)) : result); + }} else - if (expr == sc->quote_function) - return(((!is_pair(cdr(x))) || (!is_null(cddr(x)))) ? UNSAFE_BODY : VERY_SAFE_BODY); /* (#_quote . 1) or (#_quote 1 2) etc */ + if (expr == sc->quote_function) + return(((!is_pair(cdr(x))) || (!is_null(cddr(x)))) ? UNSAFE_BODY : VERY_SAFE_BODY); /* (#_quote . 1) or (#_quote 1 2) etc */ return(UNSAFE_BODY); /* not recur_body here if at_end -- possible defines in body etc */ } @@ -74424,15 +74424,15 @@ static body_t body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool for (s7_pointer sp = body; is_pair(p); p = cdr(p)) { if (is_pair(car(p))) - { - result = min_body(result, form_is_safe(sc, func, car(p), (at_end) && (is_null(cdr(p))))); - if (result == UNSAFE_BODY) return(UNSAFE_BODY); - } + { + result = min_body(result, form_is_safe(sc, func, car(p), (at_end) && (is_null(cdr(p))))); + if (result == UNSAFE_BODY) return(UNSAFE_BODY); + } if (p != body) - { - if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} - follow = (!follow); - }} + { + if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);} + follow = (!follow); + }} return((is_null(p)) ? result : UNSAFE_BODY); } @@ -74442,7 +74442,7 @@ static bool tree_has_definers_or_binders(s7_scheme *sc, s7_pointer tree) if (tree_has_definers_or_binders(sc, car(p))) return(true); return((is_symbol(tree)) && - (is_definer_or_binder(tree))); + (is_definer_or_binder(tree))); } static bool check_recur_if(s7_scheme *sc, const s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body) @@ -74455,228 +74455,228 @@ static bool check_recur_if(s7_scheme *sc, const s7_pointer name, int32_t vars, s s7_pointer false_p = cadr(obody); /* if_a_a_(if...) */ if ((vars <= 2) && - (is_fxable(sc, true_p)) && - (is_proper_list_4(sc, false_p))) - { - if (car(false_p) == sc->if_symbol) - { - s7_pointer test2 = cadr(false_p); - s7_pointer true2 = caddr(false_p); - s7_pointer false2 = cadddr(false_p); - if ((is_fxable(sc, test2)) && - (is_proper_list_3(sc, false2)) && /* opa_laaq or oplaa_laaq */ - (is_h_optimized(false2))) /* the c-op */ - { - s7_pointer la1 = cadr(false2); - s7_pointer la2 = caddr(false2); - if ((is_fxable(sc, true2)) && - (((vars == 1) && (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2))) || - (((vars == 2) && (is_proper_list_3(sc, la1)) && (is_proper_list_3(sc, la2))))) && - (car(la1) == name) && (car(la2) == name) && - (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && - ((vars == 1) || ((is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2)))))) - { - set_safe_optimize_op(body, (vars == 1) ? OP_RECUR_IF_A_A_IF_A_A_opLA_LAq : OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, obody, args); - fx_annotate_args(sc, cdr(false_p), args); - fx_annotate_args(sc, cdr(la1), args); - fx_annotate_args(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), (vars == 2) ? cadr(args) : NULL, NULL, false); - set_opt1_pair(body, cdr(false_p)); - set_opt3_pair(body, false2); - set_opt3_pair(false2, cdr(la2)); - return(true); - } - if ((vars == 2) && (is_proper_list_3(sc, true2)) && - (car(true2) == name) && - (is_fxable(sc, cadr(true2))) && (is_fxable(sc, caddr(true2))) && - (is_fxable(sc, cadr(false2))) && - (is_proper_list_3(sc, la2)) && - (car(la2) == name) && /* actually, not needed because func is TC (not RECUR) if not == name */ - (is_fxable(sc, cadr(la2))) && - (is_fxable(sc, caddr(la2)))) - { - set_safe_optimize_op(body, OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq); - fx_annotate_arg(sc, cdr(body), args); /* if_(A)... */ - fx_annotate_arg(sc, obody, args); /* if_a_(A)... */ - fx_annotate_arg(sc, cdr(false_p), args); /* if_a_a_if_(A)... */ - fx_annotate_args(sc, cdr(true2), args); /* if_a_a_if_a_l(AA)... */ - fx_annotate_arg(sc, cdr(false2), args); /* if_a_a_if_a_laa_op(A).. */ - fx_annotate_args(sc, cdr(la2), args); /* if_a_a_if_a_laa_opa_l(AA)q */ - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, false2); - set_opt3_pair(false2, la2); - return(true); - }}} - - if (car(false_p) == sc->and_symbol) - { - s7_pointer a1 = cadr(false_p); - s7_pointer a2 = caddr(false_p); - s7_pointer a3 = cadddr(false_p); - if ((is_fxable(sc, a1)) && - (is_proper_list_3(sc, a2)) && (is_proper_list_3(sc, a3)) && - (car(a2) == name) && (car(a3) == name) && - (is_fxable(sc, cadr(a2))) && (is_fxable(sc, cadr(a3))) && - (is_fxable(sc, caddr(a2))) && (is_fxable(sc, caddr(a3)))) - { - set_safe_optimize_op(body, OP_RECUR_IF_A_A_AND_A_LAA_LAA); - fx_annotate_arg(sc, cdr(body), args); /* if_(A)... */ - fx_annotate_arg(sc, cddr(body), args); /* if_a_(A)... */ - fx_annotate_arg(sc, cdr(false_p), args); /* if_a_a_and_(A)... */ - fx_annotate_args(sc, cdr(a2), args); /* if_a_a_and_a_l(AA)... */ - fx_annotate_args(sc, cdr(a3), args); /* if_a_a_and_a_laa_l(AA) */ - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, false_p); - return(true); - }}} + (is_fxable(sc, true_p)) && + (is_proper_list_4(sc, false_p))) + { + if (car(false_p) == sc->if_symbol) + { + s7_pointer test2 = cadr(false_p); + s7_pointer true2 = caddr(false_p); + s7_pointer false2 = cadddr(false_p); + if ((is_fxable(sc, test2)) && + (is_proper_list_3(sc, false2)) && /* opa_laaq or oplaa_laaq */ + (is_h_optimized(false2))) /* the c-op */ + { + s7_pointer la1 = cadr(false2); + s7_pointer la2 = caddr(false2); + if ((is_fxable(sc, true2)) && + (((vars == 1) && (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2))) || + (((vars == 2) && (is_proper_list_3(sc, la1)) && (is_proper_list_3(sc, la2))))) && + (car(la1) == name) && (car(la2) == name) && + (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && + ((vars == 1) || ((is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2)))))) + { + set_safe_optimize_op(body, (vars == 1) ? OP_RECUR_IF_A_A_IF_A_A_opLA_LAq : OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, obody, args); + fx_annotate_args(sc, cdr(false_p), args); + fx_annotate_args(sc, cdr(la1), args); + fx_annotate_args(sc, cdr(la2), args); + fx_tree(sc, cdr(body), car(args), (vars == 2) ? cadr(args) : NULL, NULL, false); + set_opt1_pair(body, cdr(false_p)); + set_opt3_pair(body, false2); + set_opt3_pair(false2, cdr(la2)); + return(true); + } + if ((vars == 2) && (is_proper_list_3(sc, true2)) && + (car(true2) == name) && + (is_fxable(sc, cadr(true2))) && (is_fxable(sc, caddr(true2))) && + (is_fxable(sc, cadr(false2))) && + (is_proper_list_3(sc, la2)) && + (car(la2) == name) && /* actually, not needed because func is TC (not RECUR) if not == name */ + (is_fxable(sc, cadr(la2))) && + (is_fxable(sc, caddr(la2)))) + { + set_safe_optimize_op(body, OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq); + fx_annotate_arg(sc, cdr(body), args); /* if_(A)... */ + fx_annotate_arg(sc, obody, args); /* if_a_(A)... */ + fx_annotate_arg(sc, cdr(false_p), args); /* if_a_a_if_(A)... */ + fx_annotate_args(sc, cdr(true2), args); /* if_a_a_if_a_l(AA)... */ + fx_annotate_arg(sc, cdr(false2), args); /* if_a_a_if_a_laa_op(A).. */ + fx_annotate_args(sc, cdr(la2), args); /* if_a_a_if_a_laa_opa_l(AA)q */ + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + set_opt3_pair(body, false2); + set_opt3_pair(false2, la2); + return(true); + }}} + + if (car(false_p) == sc->and_symbol) + { + s7_pointer a1 = cadr(false_p); + s7_pointer a2 = caddr(false_p); + s7_pointer a3 = cadddr(false_p); + if ((is_fxable(sc, a1)) && + (is_proper_list_3(sc, a2)) && (is_proper_list_3(sc, a3)) && + (car(a2) == name) && (car(a3) == name) && + (is_fxable(sc, cadr(a2))) && (is_fxable(sc, cadr(a3))) && + (is_fxable(sc, caddr(a2))) && (is_fxable(sc, caddr(a3)))) + { + set_safe_optimize_op(body, OP_RECUR_IF_A_A_AND_A_LAA_LAA); + fx_annotate_arg(sc, cdr(body), args); /* if_(A)... */ + fx_annotate_arg(sc, cddr(body), args); /* if_a_(A)... */ + fx_annotate_arg(sc, cdr(false_p), args); /* if_a_a_and_(A)... */ + fx_annotate_args(sc, cdr(a2), args); /* if_a_a_and_a_l(AA)... */ + fx_annotate_args(sc, cdr(a3), args); /* if_a_a_and_a_laa_l(AA) */ + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + set_opt3_pair(body, false_p); + return(true); + }}} if ((is_fxable(sc, true_p)) && - (is_pair(false_p)) && - (is_h_optimized(false_p)) && - (is_pair(cdr(false_p))) && - (is_pair(cddr(false_p)))) - orig = false_p; + (is_pair(false_p)) && + (is_h_optimized(false_p)) && + (is_pair(cdr(false_p))) && + (is_pair(cddr(false_p)))) + orig = false_p; else - if ((is_fxable(sc, false_p)) && - (is_pair(true_p)) && - (is_h_optimized(true_p)) && - (is_pair(cdr(true_p))) && - (is_pair(cddr(true_p)))) - { - orig = true_p; - /* true_p = false_p; */ - false_p = orig; - obody = cdr(obody); - } + if ((is_fxable(sc, false_p)) && + (is_pair(true_p)) && + (is_h_optimized(true_p)) && + (is_pair(cdr(true_p))) && + (is_pair(cddr(true_p)))) + { + orig = true_p; + /* true_p = false_p; */ + false_p = orig; + obody = cdr(obody); + } if (orig) - { - if (is_null(cdddr(false_p))) /* 2 args to outer (c) func */ - { - if ((is_fxable(sc, cadr(false_p))) || (is_fxable(sc, caddr(false_p)))) - { - s7_pointer la = (is_fxable(sc, cadr(false_p))) ? caddr(false_p) : cadr(false_p); - if ((is_pair(la)) && - (car(la) == name) && - (is_pair(cdr(la))) && - (is_fxable(sc, cadr(la)))) - { - if ((vars == 1) && (is_null(cddr(la)))) - set_safe_optimize_op(body, (orig == cadddr(body)) ? - ((la == cadr(false_p)) ? OP_RECUR_IF_A_A_opLA_Aq : OP_RECUR_IF_A_A_opA_LAq) : - ((la == cadr(false_p)) ? OP_RECUR_IF_A_opLA_Aq_A : OP_RECUR_IF_A_opA_LAq_A)); - else - if ((vars == 2) && - (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 - { - 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); - } - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, obody, args); - fx_annotate_arg(sc, (la == cadr(false_p)) ? cddr(false_p) : cdr(false_p), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, false); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la); - return(true); - }} - else - { - s7_pointer la1 = cadr(false_p); - s7_pointer la2 = caddr(false_p); - 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, (orig == cadddr(body)) ? OP_RECUR_IF_A_A_opLA_LAq : OP_RECUR_IF_A_opLA_LAq_A); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, obody, args); - fx_annotate_arg(sc, cdr(la1), args); - fx_annotate_arg(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la2); - return(true); - }}} - else /* 3 args to c func */ - { - if ((vars == 1) && - (is_pair(cdddr(false_p))) && - (is_null(cddddr(false_p)))) - { - s7_pointer la1 = cadr(false_p); - s7_pointer la2 = caddr(false_p); - s7_pointer la3 = cadddr(false_p); - if ((is_proper_list_2(sc, la2)) && (is_proper_list_2(sc, la3)) && - (car(la2) == name) && (car(la3) == name) && - (is_fxable(sc, cadr(la2))) && (is_fxable(sc, cadr(la3)))) - { - if ((is_proper_list_2(sc, la1)) && (car(la1) == name) && (is_fxable(sc, cadr(la1)))) - { - if (orig != cadddr(body)) - return(false); - set_safe_optimize_op(body, OP_RECUR_IF_A_A_opLA_LA_LAq); - fx_annotate_arg(sc, cdr(la1), args); - } - else - if (is_fxable(sc, la1)) - { - set_safe_optimize_op(body, (orig == cadddr(body)) ? OP_RECUR_IF_A_A_opA_LA_LAq : OP_RECUR_IF_A_opA_LA_LAq_A); - fx_annotate_arg(sc, cdr(false_p), args); - } - else return(false); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, obody, args); - fx_annotate_arg(sc, cdr(la2), args); - fx_annotate_arg(sc, cdr(la3), args); - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la3); - return(true); - }}}}} + { + if (is_null(cdddr(false_p))) /* 2 args to outer (c) func */ + { + if ((is_fxable(sc, cadr(false_p))) || (is_fxable(sc, caddr(false_p)))) + { + s7_pointer la = (is_fxable(sc, cadr(false_p))) ? caddr(false_p) : cadr(false_p); + if ((is_pair(la)) && + (car(la) == name) && + (is_pair(cdr(la))) && + (is_fxable(sc, cadr(la)))) + { + if ((vars == 1) && (is_null(cddr(la)))) + set_safe_optimize_op(body, (orig == cadddr(body)) ? + ((la == cadr(false_p)) ? OP_RECUR_IF_A_A_opLA_Aq : OP_RECUR_IF_A_A_opA_LAq) : + ((la == cadr(false_p)) ? OP_RECUR_IF_A_opLA_Aq_A : OP_RECUR_IF_A_opA_LAq_A)); + else + if ((vars == 2) && + (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 + { + 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); + } + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, obody, args); + fx_annotate_arg(sc, (la == cadr(false_p)) ? cddr(false_p) : cdr(false_p), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, false); + set_opt3_pair(body, false_p); + set_opt3_pair(false_p, la); + return(true); + }} + else + { + s7_pointer la1 = cadr(false_p); + s7_pointer la2 = caddr(false_p); + 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, (orig == cadddr(body)) ? OP_RECUR_IF_A_A_opLA_LAq : OP_RECUR_IF_A_opLA_LAq_A); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, obody, args); + fx_annotate_arg(sc, cdr(la1), args); + fx_annotate_arg(sc, cdr(la2), args); + fx_tree(sc, cdr(body), car(args), NULL, NULL, false); + set_opt3_pair(body, false_p); + set_opt3_pair(false_p, la2); + return(true); + }}} + else /* 3 args to c func */ + { + if ((vars == 1) && + (is_pair(cdddr(false_p))) && + (is_null(cddddr(false_p)))) + { + s7_pointer la1 = cadr(false_p); + s7_pointer la2 = caddr(false_p); + s7_pointer la3 = cadddr(false_p); + if ((is_proper_list_2(sc, la2)) && (is_proper_list_2(sc, la3)) && + (car(la2) == name) && (car(la3) == name) && + (is_fxable(sc, cadr(la2))) && (is_fxable(sc, cadr(la3)))) + { + if ((is_proper_list_2(sc, la1)) && (car(la1) == name) && (is_fxable(sc, cadr(la1)))) + { + if (orig != cadddr(body)) + return(false); + set_safe_optimize_op(body, OP_RECUR_IF_A_A_opLA_LA_LAq); + fx_annotate_arg(sc, cdr(la1), args); + } + else + if (is_fxable(sc, la1)) + { + set_safe_optimize_op(body, (orig == cadddr(body)) ? OP_RECUR_IF_A_A_opA_LA_LAq : OP_RECUR_IF_A_opA_LA_LAq_A); + fx_annotate_arg(sc, cdr(false_p), args); + } + else return(false); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, obody, args); + fx_annotate_arg(sc, cdr(la2), args); + fx_annotate_arg(sc, cdr(la3), args); + fx_tree(sc, cdr(body), car(args), NULL, NULL, false); + set_opt3_pair(body, false_p); + set_opt3_pair(false_p, la3); + return(true); + }}}}} if ((vars == 3) && - (is_fxable(sc, test))) - { - s7_pointer true_p = caddr(body); - s7_pointer false_p = cadddr(body); - if ((is_fxable(sc, true_p)) && - (is_proper_list_4(sc, false_p)) && - (car(false_p) == name)) - { - s7_pointer l3a = cdr(false_p); - s7_pointer la1 = car(l3a); - s7_pointer la2 = cadr(l3a); - s7_pointer 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); - fx_annotate_args(sc, cdr(la1), args); - fx_annotate_args(sc, cdr(la2), args); - fx_annotate_args(sc, cdr(la3), args); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); - set_opt3_pair(body, false_p); - set_opt3_pair(false_p, la3); - return(true); - }}} + (is_fxable(sc, test))) + { + s7_pointer true_p = caddr(body); + s7_pointer false_p = cadddr(body); + if ((is_fxable(sc, true_p)) && + (is_proper_list_4(sc, false_p)) && + (car(false_p) == name)) + { + s7_pointer l3a = cdr(false_p); + s7_pointer la1 = car(l3a); + s7_pointer la2 = cadr(l3a); + s7_pointer 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); + fx_annotate_args(sc, cdr(la1), args); + fx_annotate_args(sc, cdr(la2), args); + fx_annotate_args(sc, cdr(la3), args); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); + set_opt3_pair(body, false_p); + set_opt3_pair(false_p, la3); + return(true); + }}} return(false); } @@ -74697,164 +74697,164 @@ static bool check_recur(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer s7_pointer la1 = caddr(or_p); s7_pointer la2 = cadddr(or_p); if ((is_fxable(sc, cadr(or_p))) && - (proper_list_length(la1) == 3) && - (proper_list_length(la2) == 3) && - (car(la1) == name) && - (car(la2) == name) && - (is_fxable(sc, cadr(la1))) && - (is_fxable(sc, caddr(la1))) && - (is_fxable(sc, cadr(la2))) && - (is_fxable(sc, caddr(la2)))) - { - set_safe_optimize_op(body, OP_RECUR_AND_A_OR_A_LAA_LAA); - fx_annotate_args(sc, cdr(la1), args); - fx_annotate_args(sc, cdr(la2), args); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cdr(or_p), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, or_p); - return(true); - }} + (proper_list_length(la1) == 3) && + (proper_list_length(la2) == 3) && + (car(la1) == name) && + (car(la2) == name) && + (is_fxable(sc, cadr(la1))) && + (is_fxable(sc, caddr(la1))) && + (is_fxable(sc, cadr(la2))) && + (is_fxable(sc, caddr(la2)))) + { + set_safe_optimize_op(body, OP_RECUR_AND_A_OR_A_LAA_LAA); + fx_annotate_args(sc, cdr(la1), args); + fx_annotate_args(sc, cdr(la2), args); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cdr(or_p), args); + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + set_opt3_pair(body, or_p); + return(true); + }} if (car(body) == sc->cond_symbol) { s7_pointer clause = cadr(body), clause2 = NULL; if ((is_proper_list_1(sc, (cdr(clause)))) && - (is_fxable(sc, car(clause))) && - (is_fxable(sc, cadr(clause)))) - { - s7_pointer la_clause = caddr(body); - s7_int len = proper_list_length(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 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))) - { - 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)))) - { - s7_pointer 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 - { - s7_pointer 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); - fx_annotate_arg(sc, clause2, args); - fx_annotate_args(sc, cdr(laa), args); - } - else return(false); - } - fx_annotate_args(sc, clause, args); - fx_annotate_arg(sc, cdr(la_clause), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - set_opt3_pair(body, la_clause); - set_opt3_pair(la_clause, la); - return(true); - }} - else - { - if ((len == 4) && - (is_fxable(sc, cadr(clause2)))) - { - s7_pointer la1 = cadr(la_clause); - s7_pointer la2 = caddr(la_clause); - bool happy = false; - - 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); - fx_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 (is_fxable(sc, la1)) - { - set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opA_LAAq); - fx_annotate_arg(sc, cdr(la_clause), 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); - fx_annotate_args(sc, cdr(la1), args); - happy = true; - }} - if (happy) - { - set_opt3_pair(la_clause, cdr(la2)); - fx_annotate_args(sc, clause, args); - fx_annotate_args(sc, clause2, args); - fx_annotate_args(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - set_opt3_pair(body, la_clause); - return(true); - }}}} - else - { - if (clause2) - { - s7_pointer 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 = cadr(la_clause); - s7_pointer 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); - fx_annotate_args(sc, clause, args); - fx_annotate_arg(sc, clause2, args); - fx_annotate_args(sc, cdr(laa), args); - fx_annotate_arg(sc, cdr(la_clause), args); - fx_annotate_args(sc, cdr(la2), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, la_clause); - set_opt3_pair(la_clause, cdr(la2)); - return(true); - }}}}}}}} + (is_fxable(sc, car(clause))) && + (is_fxable(sc, cadr(clause)))) + { + s7_pointer la_clause = caddr(body); + s7_int len = proper_list_length(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 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))) + { + 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)))) + { + s7_pointer 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 + { + s7_pointer 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); + fx_annotate_arg(sc, clause2, args); + fx_annotate_args(sc, cdr(laa), args); + } + else return(false); + } + fx_annotate_args(sc, clause, args); + fx_annotate_arg(sc, cdr(la_clause), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); + set_opt3_pair(body, la_clause); + set_opt3_pair(la_clause, la); + return(true); + }} + else + { + if ((len == 4) && + (is_fxable(sc, cadr(clause2)))) + { + s7_pointer la1 = cadr(la_clause); + s7_pointer la2 = caddr(la_clause); + bool happy = false; + + 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); + fx_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 (is_fxable(sc, la1)) + { + set_safe_optimize_op(body, OP_RECUR_COND_A_A_A_A_opA_LAAq); + fx_annotate_arg(sc, cdr(la_clause), 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); + fx_annotate_args(sc, cdr(la1), args); + happy = true; + }} + if (happy) + { + set_opt3_pair(la_clause, cdr(la2)); + fx_annotate_args(sc, clause, args); + fx_annotate_args(sc, clause2, args); + fx_annotate_args(sc, cdr(la2), args); + fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); + set_opt3_pair(body, la_clause); + return(true); + }}}} + else + { + if (clause2) + { + s7_pointer 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 = cadr(la_clause); + s7_pointer 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); + fx_annotate_args(sc, clause, args); + fx_annotate_arg(sc, clause2, args); + fx_annotate_args(sc, cdr(laa), args); + fx_annotate_arg(sc, cdr(la_clause), args); + fx_annotate_args(sc, cdr(la2), args); + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + set_opt3_pair(body, la_clause); + set_opt3_pair(la_clause, cdr(la2)); + return(true); + }}}}}}}} return(false); } @@ -74865,41 +74865,41 @@ static bool check_tc_when(s7_scheme *sc, const s7_pointer name, int32_t vars, s7 { s7_pointer p; for (p = cddr(body); is_pair(cdr(p)); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; + if (!is_fxable(sc, car(p))) + break; if ((is_proper_list_1(sc, p)) && /* i.e. p is the last form in the when body */ - (is_pair(car(p))) && - (caar(p) == name)) - { - s7_pointer laa = car(p); - set_opt3_pair(body, p); - if ((is_pair(cdr(laa))) && (is_fxable(sc, cadr(laa)))) - { - if (is_null(cddr(laa))) - { - if (vars != 1) return(false); - set_safe_optimize_op(body, OP_TC_WHEN_LA); - } - else - if (is_fxable(sc, caddr(laa))) - { - if (is_null(cdddr(laa))) - { - if (vars != 2) return(false); - set_safe_optimize_op(body, OP_TC_WHEN_LAA); - } - else - if ((vars == 3) && (is_fxable(sc, cadddr(laa))) && (is_null(cddddr(laa)))) - set_safe_optimize_op(body, OP_TC_WHEN_L3A); - else return(false); - } - fx_annotate_arg(sc, cdr(body), args); - for (p = cddr(body); is_pair(cdr(p)); p = cdr(p)) - fx_annotate_arg(sc, p, args); - fx_annotate_args(sc, cdr(laa), args); - fx_tree(sc, cdr(body), car(args), (is_pair(cdr(args))) ? cadr(args) : NULL, ((is_pair(cdr(args))) && (is_pair(cddr(args)))) ? caddr(args) : NULL, false); - return(true); - }}} + (is_pair(car(p))) && + (caar(p) == name)) + { + s7_pointer laa = car(p); + set_opt3_pair(body, p); + if ((is_pair(cdr(laa))) && (is_fxable(sc, cadr(laa)))) + { + if (is_null(cddr(laa))) + { + if (vars != 1) return(false); + set_safe_optimize_op(body, OP_TC_WHEN_LA); + } + else + if (is_fxable(sc, caddr(laa))) + { + if (is_null(cdddr(laa))) + { + if (vars != 2) return(false); + set_safe_optimize_op(body, OP_TC_WHEN_LAA); + } + else + if ((vars == 3) && (is_fxable(sc, cadddr(laa))) && (is_null(cddddr(laa)))) + set_safe_optimize_op(body, OP_TC_WHEN_L3A); + else return(false); + } + fx_annotate_arg(sc, cdr(body), args); + for (p = cddr(body); is_pair(cdr(p)); p = cdr(p)) + fx_annotate_arg(sc, p, args); + fx_annotate_args(sc, cdr(laa), args); + fx_tree(sc, cdr(body), car(args), (is_pair(cdr(args))) ? cadr(args) : NULL, ((is_pair(cdr(args))) && (is_pair(cddr(args)))) ? caddr(args) : NULL, false); + return(true); + }}} return(false); } @@ -74913,49 +74913,49 @@ static bool check_tc_case(s7_scheme *sc, s7_pointer name, s7_pointer args, s7_po { s7_pointer clause = car(clauses), result; if (is_proper_list_1(sc, car(clause))) - { - if (!is_simple(caar(clause))) - return(false); /* even if key is a small int, selector might be a mutable alias of that, so = will fail */ - set_opt1_any(clauses, caar(clause)); - } + { + if (!is_simple(caar(clause))) + return(false); /* even if key is a small int, selector might be a mutable alias of that, so = will fail */ + set_opt1_any(clauses, caar(clause)); + } else - { - if ((car(clause) != sc->else_symbol) || - (!is_null(cdr(clauses)))) - return(false); - got_else = true; - } + { + if ((car(clause) != sc->else_symbol) || + (!is_null(cdr(clauses)))) + return(false); + got_else = true; + } set_opt2_any(clauses, NULL); result = cdr(clause); if (is_null(result)) - return(false); + return(false); if (is_proper_list_1(sc, result)) - { - if (is_fxable(sc, car(result))) - { - fx_annotate_arg(sc, result, args); - set_opt2_any(clauses, result); - } - else - if ((is_proper_list_2(sc, car(result))) && - (caar(result) == name) && - (is_fxable(sc, cadar(result)))) - { - set_has_tc(car(result)); - set_opt2_any(clauses, car(result)); - fx_annotate_arg(sc, cdar(result), args); - } - else results_fxable = false; - } + { + if (is_fxable(sc, car(result))) + { + fx_annotate_arg(sc, result, args); + set_opt2_any(clauses, result); + } + else + if ((is_proper_list_2(sc, car(result))) && + (caar(result) == name) && + (is_fxable(sc, cadar(result)))) + { + set_has_tc(car(result)); + set_opt2_any(clauses, car(result)); + fx_annotate_arg(sc, cdar(result), args); + } + else results_fxable = false; + } else results_fxable = false; if (!opt2_any(clauses)) - { - if (car(result) == sc->feed_to_symbol) - return(false); - if (tree_count(sc, name, result, 0) != 0) - return(false); - set_opt2_any(clauses, result); - }} + { + if (car(result) == sc->feed_to_symbol) + return(false); + if (tree_count(sc, name, result, 0) != 0) + return(false); + set_opt2_any(clauses, result); + }} if ((!got_else) || (!is_null(clauses))) return(false); set_optimize_op(body, OP_TC_CASE_LA); @@ -74973,145 +74973,145 @@ static bool check_tc_cond(s7_scheme *sc, s7_pointer name, int32_t vars, s7_point { p = cdr(p); if ((is_pair(p)) && (is_null(cdr(p))) && ((caar(p) == sc->else_symbol) || (caar(p) == sc->T))) - { - s7_pointer else_clause; - if (((vars != 1) && (vars != 2)) || (tree_count(sc, name, body, 0) != 1)) return(false); - else_clause = cdar(p); - if (is_proper_list_1(sc, else_clause)) - { - s7_pointer la = car(else_clause); - fx_annotate_arg(sc, clause1, args); - if ((is_pair(la)) && (car(la) == name) && (is_pair(cdr(la)))) - { - if ((is_fxable(sc, cadr(la))) && - ((((vars == 1) && (is_null(cddr(la)))) || - ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la))))))) - { - bool zs_fxable = is_fxable(sc, cadr(clause1)); - set_optimize_op(body, (vars == 1) ? OP_TC_COND_A_Z_LA : OP_TC_COND_A_Z_LAA); - if (zs_fxable) fx_annotate_arg(sc, cdr(clause1), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - if (zs_fxable) set_optimized(body); - set_opt1_pair(cdr(body), cdadr(body)); - set_opt3_pair(cdr(body), cdadr(caddr(body))); - return(zs_fxable); - }} - else - { - la = cadr(clause1); - if ((is_pair(la)) && (car(la) == name) && (is_pair(cdr(la)))) - { - if ((is_fxable(sc, cadr(la))) && - (((vars == 1) && (is_null(cddr(la)))) || - ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la)))))) - { - bool zs_fxable = is_fxable(sc, car(else_clause)); - set_optimize_op(body, (vars == 1) ? OP_TC_COND_A_LA_Z : OP_TC_COND_A_LAA_Z); - if (zs_fxable) fx_annotate_arg(sc, else_clause, args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - if (zs_fxable) set_optimized(body); - set_opt1_pair(cdr(body), cdaddr(body)); - set_opt3_pair(cdr(body), cdadr(cadr(body))); - return(zs_fxable); - }}}} - return(false); - } + { + s7_pointer else_clause; + if (((vars != 1) && (vars != 2)) || (tree_count(sc, name, body, 0) != 1)) return(false); + else_clause = cdar(p); + if (is_proper_list_1(sc, else_clause)) + { + s7_pointer la = car(else_clause); + fx_annotate_arg(sc, clause1, args); + if ((is_pair(la)) && (car(la) == name) && (is_pair(cdr(la)))) + { + if ((is_fxable(sc, cadr(la))) && + ((((vars == 1) && (is_null(cddr(la)))) || + ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la))))))) + { + bool zs_fxable = is_fxable(sc, cadr(clause1)); + set_optimize_op(body, (vars == 1) ? OP_TC_COND_A_Z_LA : OP_TC_COND_A_Z_LAA); + if (zs_fxable) fx_annotate_arg(sc, cdr(clause1), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); + if (zs_fxable) set_optimized(body); + set_opt1_pair(cdr(body), cdadr(body)); + set_opt3_pair(cdr(body), cdadr(caddr(body))); + return(zs_fxable); + }} + else + { + la = cadr(clause1); + if ((is_pair(la)) && (car(la) == name) && (is_pair(cdr(la)))) + { + if ((is_fxable(sc, cadr(la))) && + (((vars == 1) && (is_null(cddr(la)))) || + ((vars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la)))))) + { + bool zs_fxable = is_fxable(sc, car(else_clause)); + set_optimize_op(body, (vars == 1) ? OP_TC_COND_A_LA_Z : OP_TC_COND_A_LAA_Z); + if (zs_fxable) fx_annotate_arg(sc, else_clause, args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); + if (zs_fxable) set_optimized(body); + set_opt1_pair(cdr(body), cdaddr(body)); + set_opt3_pair(cdr(body), cdadr(cadr(body))); + return(zs_fxable); + }}}} + return(false); + } if (is_proper_list_2(sc, p)) - { - s7_pointer clause2 = car(p); - if ((is_proper_list_2(sc, clause2)) && - (is_fxable(sc, car(clause2)))) - { - s7_pointer else_p = cdr(p); - s7_pointer else_clause = car(else_p); - - if ((is_proper_list_2(sc, else_clause)) && - ((car(else_clause) == sc->else_symbol) || (car(else_clause) == sc->T))) - { - bool zs_fxable = true; - if ((vars == 2) && /* ...laa_laa case */ - (is_proper_list_3(sc, cadr(clause2))) && (caadr(clause2) == name) && - (is_fxable(sc, cadadr(clause2))) && (is_safe_fxable(sc, caddadr(clause2))) && - (is_proper_list_3(sc, cadr(else_clause))) && (caadr(else_clause) == name) && - (is_fxable(sc, cadadr(else_clause))) && (is_safe_fxable(sc, caddadr(else_clause)))) - { - set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_LAA); - if (is_fxable(sc, cadr(clause1))) - fx_annotate_args(sc, clause1, args); - else - { - fx_annotate_arg(sc, clause1, args); - zs_fxable = false; - } - fx_annotate_arg(sc, clause2, args); - fx_annotate_args(sc, cdadr(clause2), args); - fx_annotate_args(sc, cdadr(else_clause), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_opt3_pair(body, cadr(else_clause)); - if (zs_fxable) set_optimized(body); - return(zs_fxable); - } - - if ((tree_count(sc, name, body, 0) == 1) && /* needed to filter out cond_a_a_a_laa_opa_laa */ - - (((is_pair(cadr(else_clause))) && (caadr(else_clause) == name) && - (is_pair(cdadr(else_clause))) && (is_fxable(sc, cadadr(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)))))) || - - ((is_pair(cadr(clause2))) && (caadr(clause2) == name) && - (is_pair(cdadr(clause2))) && (is_fxable(sc, cadadr(clause2))) && - (((vars == 1) && (is_null(cddadr(clause2)))) || - ((vars == 2) && (is_pair(cddadr(clause2))) && (is_fxable(sc, caddadr(clause2))) && (is_null(cdddr(cadr(clause2))))))))) - { - s7_pointer test2 = clause2; - s7_pointer la_test = else_clause; - if (vars == 1) - { - if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) - set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LA); - else - { - set_optimize_op(body, OP_TC_COND_A_Z_A_LA_Z); - test2 = else_clause; - la_test = clause2; - fx_annotate_arg(sc, clause2, args); - }} - else - if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) - { - set_opt3_pair(body, cdadr(else_clause)); - set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LAA); - } - else - { - set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_Z); - test2 = else_clause; - la_test = clause2; - set_opt3_pair(body, cdadr(la_test)); - fx_annotate_arg(sc, clause2, args); - } - if (is_fxable(sc, cadr(clause1))) - fx_annotate_args(sc, clause1, args); - else - { - fx_annotate_arg(sc, clause1, args); - zs_fxable = false; - } - if (is_fxable(sc, cadr(test2))) - fx_annotate_args(sc, test2, args); - else - { - fx_annotate_arg(sc, test2, args); - zs_fxable = false; - } - fx_annotate_args(sc, cdadr(la_test), args); - fx_tree(sc, cdr(body), car(args), (vars == 2) ? cadr(args) : NULL, NULL, false); - if (zs_fxable) set_optimized(body); - return(zs_fxable); - }}}}} + { + s7_pointer clause2 = car(p); + if ((is_proper_list_2(sc, clause2)) && + (is_fxable(sc, car(clause2)))) + { + s7_pointer else_p = cdr(p); + s7_pointer else_clause = car(else_p); + + if ((is_proper_list_2(sc, else_clause)) && + ((car(else_clause) == sc->else_symbol) || (car(else_clause) == sc->T))) + { + bool zs_fxable = true; + if ((vars == 2) && /* ...laa_laa case */ + (is_proper_list_3(sc, cadr(clause2))) && (caadr(clause2) == name) && + (is_fxable(sc, cadadr(clause2))) && (is_safe_fxable(sc, caddadr(clause2))) && + (is_proper_list_3(sc, cadr(else_clause))) && (caadr(else_clause) == name) && + (is_fxable(sc, cadadr(else_clause))) && (is_safe_fxable(sc, caddadr(else_clause)))) + { + set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_LAA); + if (is_fxable(sc, cadr(clause1))) + fx_annotate_args(sc, clause1, args); + else + { + fx_annotate_arg(sc, clause1, args); + zs_fxable = false; + } + fx_annotate_arg(sc, clause2, args); + fx_annotate_args(sc, cdadr(clause2), args); + fx_annotate_args(sc, cdadr(else_clause), args); + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + set_opt3_pair(body, cadr(else_clause)); + if (zs_fxable) set_optimized(body); + return(zs_fxable); + } + + if ((tree_count(sc, name, body, 0) == 1) && /* needed to filter out cond_a_a_a_laa_opa_laa */ + + (((is_pair(cadr(else_clause))) && (caadr(else_clause) == name) && + (is_pair(cdadr(else_clause))) && (is_fxable(sc, cadadr(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)))))) || + + ((is_pair(cadr(clause2))) && (caadr(clause2) == name) && + (is_pair(cdadr(clause2))) && (is_fxable(sc, cadadr(clause2))) && + (((vars == 1) && (is_null(cddadr(clause2)))) || + ((vars == 2) && (is_pair(cddadr(clause2))) && (is_fxable(sc, caddadr(clause2))) && (is_null(cdddr(cadr(clause2))))))))) + { + s7_pointer test2 = clause2; + s7_pointer la_test = else_clause; + if (vars == 1) + { + if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) + set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LA); + else + { + set_optimize_op(body, OP_TC_COND_A_Z_A_LA_Z); + test2 = else_clause; + la_test = clause2; + fx_annotate_arg(sc, clause2, args); + }} + else + if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) + { + set_opt3_pair(body, cdadr(else_clause)); + set_optimize_op(body, OP_TC_COND_A_Z_A_Z_LAA); + } + else + { + set_optimize_op(body, OP_TC_COND_A_Z_A_LAA_Z); + test2 = else_clause; + la_test = clause2; + set_opt3_pair(body, cdadr(la_test)); + fx_annotate_arg(sc, clause2, args); + } + if (is_fxable(sc, cadr(clause1))) + fx_annotate_args(sc, clause1, args); + else + { + fx_annotate_arg(sc, clause1, args); + zs_fxable = false; + } + if (is_fxable(sc, cadr(test2))) + fx_annotate_args(sc, test2, args); + else + { + fx_annotate_arg(sc, test2, args); + zs_fxable = false; + } + fx_annotate_args(sc, cdadr(la_test), args); + fx_tree(sc, cdr(body), car(args), (vars == 2) ? cadr(args) : NULL, NULL, false); + if (zs_fxable) set_optimized(body); + return(zs_fxable); + }}}}} return(false); } @@ -75123,113 +75123,113 @@ static bool check_tc_let(s7_scheme *sc, const s7_pointer name, int32_t vars, s7_ { s7_pointer test_expr = cadr(let_body); if (is_fxable(sc, test_expr)) - { - if ((car(let_body) == sc->if_symbol) && (is_pair(cdddr(let_body)))) - { - s7_pointer laa = cadddr(let_body); - if ((is_pair(laa)) && /* else caddr is laa and cadddr is z */ - (car(laa) == name) && - (((vars == 1) && (is_proper_list_2(sc, laa))) || - ((vars == 2) && (is_proper_list_3(sc, laa)) && (is_safe_fxable(sc, caddr(laa))))) && - (is_fxable(sc, cadr(laa)))) - { - bool z_fxable; - set_optimize_op(body, (vars == 1) ? OP_TC_LET_IF_A_Z_LA : OP_TC_LET_IF_A_Z_LAA); - fx_annotate_arg(sc, cdaadr(body), args); /* let var binding, caadr: (x (- y 1)) etc */ - fx_tree(sc, cdaadr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); /* these are references to laa args, applied to the let var binding */ - fx_annotate_arg(sc, cdr(let_body), args); /* test_expr */ - fx_annotate_args(sc, cdr(laa), args); - z_fxable = is_fxable(sc, caddr(let_body)); - if (z_fxable) fx_annotate_arg(sc, cddr(let_body), args); - fx_tree(sc, cdr(let_body), car(caadr(body)), NULL, NULL, false); - fx_tree_outer(sc, cdr(let_body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); - if (z_fxable) set_optimized(body); - return(z_fxable); - }} - else - { - s7_pointer p; - for (p = cddr(let_body); is_pair(cdr(p)); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; - if ((is_proper_list_1(sc, p)) && - (is_proper_list_3(sc, car(p))) && - (caar(p) == name)) - { - s7_pointer laa = car(p); - if ((is_fxable(sc, cadr(laa))) && - (is_safe_fxable(sc, caddr(laa)))) - { - set_optimize_op(body, (car(let_body) == sc->when_symbol) ? OP_TC_LET_WHEN_LAA : OP_TC_LET_UNLESS_LAA); - fx_annotate_arg(sc, cdaadr(body), args); /* outer var */ - fx_annotate_arg(sc, cdr(let_body), args); /* test */ - for (p = cddr(let_body); is_pair(cdr(p)); p = cdr(p)) - fx_annotate_arg(sc, p, args); - fx_annotate_args(sc, cdr(laa), args); - fx_tree(sc, cdaadr(body), car(args), cadr(args), NULL, false); /* these are references to the outer let */ - fx_tree(sc, cdr(let_body), car(caadr(body)), NULL, NULL, false); - fx_tree_outer(sc, cdr(let_body), car(args), cadr(args), NULL, false); - set_optimized(body); - return(true); - }}}}} + { + if ((car(let_body) == sc->if_symbol) && (is_pair(cdddr(let_body)))) + { + s7_pointer laa = cadddr(let_body); + if ((is_pair(laa)) && /* else caddr is laa and cadddr is z */ + (car(laa) == name) && + (((vars == 1) && (is_proper_list_2(sc, laa))) || + ((vars == 2) && (is_proper_list_3(sc, laa)) && (is_safe_fxable(sc, caddr(laa))))) && + (is_fxable(sc, cadr(laa)))) + { + bool z_fxable; + set_optimize_op(body, (vars == 1) ? OP_TC_LET_IF_A_Z_LA : OP_TC_LET_IF_A_Z_LAA); + fx_annotate_arg(sc, cdaadr(body), args); /* let var binding, caadr: (x (- y 1)) etc */ + fx_tree(sc, cdaadr(body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); /* these are references to laa args, applied to the let var binding */ + fx_annotate_arg(sc, cdr(let_body), args); /* test_expr */ + fx_annotate_args(sc, cdr(laa), args); + z_fxable = is_fxable(sc, caddr(let_body)); + if (z_fxable) fx_annotate_arg(sc, cddr(let_body), args); + fx_tree(sc, cdr(let_body), car(caadr(body)), NULL, NULL, false); + fx_tree_outer(sc, cdr(let_body), car(args), (vars == 1) ? NULL : cadr(args), NULL, false); + if (z_fxable) set_optimized(body); + return(z_fxable); + }} + else + { + s7_pointer p; + for (p = cddr(let_body); is_pair(cdr(p)); p = cdr(p)) + if (!is_fxable(sc, car(p))) + break; + if ((is_proper_list_1(sc, p)) && + (is_proper_list_3(sc, car(p))) && + (caar(p) == name)) + { + s7_pointer laa = car(p); + if ((is_fxable(sc, cadr(laa))) && + (is_safe_fxable(sc, caddr(laa)))) + { + set_optimize_op(body, (car(let_body) == sc->when_symbol) ? OP_TC_LET_WHEN_LAA : OP_TC_LET_UNLESS_LAA); + fx_annotate_arg(sc, cdaadr(body), args); /* outer var */ + fx_annotate_arg(sc, cdr(let_body), args); /* test */ + for (p = cddr(let_body); is_pair(cdr(p)); p = cdr(p)) + fx_annotate_arg(sc, p, args); + fx_annotate_args(sc, cdr(laa), args); + fx_tree(sc, cdaadr(body), car(args), cadr(args), NULL, false); /* these are references to the outer let */ + fx_tree(sc, cdr(let_body), car(caadr(body)), NULL, NULL, false); + fx_tree_outer(sc, cdr(let_body), car(args), cadr(args), NULL, false); + set_optimized(body); + return(true); + }}}}} else { if (car(let_body) == sc->cond_symbol) /* vars=#loop pars, args=names thereof (arglist) */ - { - s7_pointer var_name; - bool all_fxable = true; - for (s7_pointer p = cdr(let_body); is_pair(p); p = cdr(p)) - { - s7_pointer clause = car(p); - if ((is_proper_list_2(sc, clause)) && - (is_fxable(sc, car(clause)))) /* test is ok */ - { - s7_pointer result; - - if ((!is_pair(cdr(p))) && - (car(clause) != sc->else_symbol) && (car(clause) != sc->T)) - return(false); - result = cadr(clause); - if ((is_pair(result)) && - (car(result) == name)) /* result is recursive call */ - { - s7_int i = 0; - for (s7_pointer arg = cdr(result); is_pair(arg); i++, arg = cdr(arg)) - if (!is_fxable(sc, car(arg))) - return(false); - if (i != vars) - return(false); - }} - else return(false); - } - /* cond form looks ok */ - set_optimize_op(body, OP_TC_LET_COND); - set_opt3_arglen(cdr(body), vars); - fx_annotate_arg(sc, cdaadr(body), args); /* let var */ - if (vars > 0) - fx_tree(sc, cdaadr(body), car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, vars > 3); - var_name = caaadr(body); - for (s7_pointer p = cdr(let_body); is_pair(p); p = cdr(p)) - { - s7_pointer clause = car(p); - s7_pointer result = cadr(clause); - fx_annotate_arg(sc, clause, args); - if ((is_pair(result)) && (car(result) == name)) - { - set_has_tc(cdr(clause)); - fx_annotate_args(sc, cdr(result), args); - } - else - if (is_fxable(sc, result)) - fx_annotate_arg(sc, cdr(clause), args); - else all_fxable = false; - fx_tree(sc, clause, var_name, NULL, NULL, false); /* just 1 let var */ - if (vars > 0) - fx_tree_outer(sc, clause, car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, vars > 3); - } - if (all_fxable) set_optimized(body); - return(all_fxable); - }} + { + s7_pointer var_name; + bool all_fxable = true; + for (s7_pointer p = cdr(let_body); is_pair(p); p = cdr(p)) + { + s7_pointer clause = car(p); + if ((is_proper_list_2(sc, clause)) && + (is_fxable(sc, car(clause)))) /* test is ok */ + { + s7_pointer result; + + if ((!is_pair(cdr(p))) && + (car(clause) != sc->else_symbol) && (car(clause) != sc->T)) + return(false); + result = cadr(clause); + if ((is_pair(result)) && + (car(result) == name)) /* result is recursive call */ + { + s7_int i = 0; + for (s7_pointer arg = cdr(result); is_pair(arg); i++, arg = cdr(arg)) + if (!is_fxable(sc, car(arg))) + return(false); + if (i != vars) + return(false); + }} + else return(false); + } + /* cond form looks ok */ + set_optimize_op(body, OP_TC_LET_COND); + set_opt3_arglen(cdr(body), vars); + fx_annotate_arg(sc, cdaadr(body), args); /* let var */ + if (vars > 0) + fx_tree(sc, cdaadr(body), car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, vars > 3); + var_name = caaadr(body); + for (s7_pointer p = cdr(let_body); is_pair(p); p = cdr(p)) + { + s7_pointer clause = car(p); + s7_pointer result = cadr(clause); + fx_annotate_arg(sc, clause, args); + if ((is_pair(result)) && (car(result) == name)) + { + set_has_tc(cdr(clause)); + fx_annotate_args(sc, cdr(result), args); + } + else + if (is_fxable(sc, result)) + fx_annotate_arg(sc, cdr(clause), args); + else all_fxable = false; + fx_tree(sc, clause, var_name, NULL, NULL, false); /* just 1 let var */ + if (vars > 0) + fx_tree_outer(sc, clause, car(args), (vars > 1) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, vars > 3); + } + if (all_fxable) set_optimized(body); + return(all_fxable); + }} return(false); } @@ -75247,88 +75247,88 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar { s7_pointer orx = caddr(body); if (((car(orx) == sc->or_symbol) || (car(orx) == sc->and_symbol)) && - (car(body) != car(orx)) && - (is_fxable(sc, cadr(orx)))) - { - s7_int len = proper_list_length(orx); - if ((len == 3) || - ((vars == 1) && (len == 4) && (tree_count(sc, name, orx, 0) == 1) && (is_fxable(sc, caddr(orx))))) /* the ...or|and_a_a_la case below? */ - { - s7_pointer 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_safe_fxable(sc, caddr(tc)))) || - ((vars == 3) && (is_pair(cddr(tc))) && (is_pair(cdddr(tc))) && (is_null(cddddr(tc))) && - (is_safe_fxable(sc, caddr(tc))) && (is_safe_fxable(sc, cadddr(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) : - ((len == 3) ? OP_TC_OR_A_AND_A_LA : OP_TC_OR_A_AND_A_A_LA)); - else - if (vars == 2) - set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_LAA : OP_TC_OR_A_AND_A_LAA); - else set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_L3A : OP_TC_OR_A_AND_A_L3A); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cdr(orx), args); - if (len == 4) fx_annotate_arg(sc, cddr(orx), args); - fx_annotate_args(sc, cdr(tc), args); - /* if ((fx_proc(cdr(tc)) == fx_c_sca) && (fn_proc(cadr(tc)) == g_substring)) -> g_substring_uncopied); */ - /* for that to be safe we need to be sure nothing in the body looks for null-termination (e.g.. string->number) */ - fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), (vars == 3) ? caddr(args) : NULL, false); - return(true); - }}} + (car(body) != car(orx)) && + (is_fxable(sc, cadr(orx)))) + { + s7_int len = proper_list_length(orx); + if ((len == 3) || + ((vars == 1) && (len == 4) && (tree_count(sc, name, orx, 0) == 1) && (is_fxable(sc, caddr(orx))))) /* the ...or|and_a_a_la case below? */ + { + s7_pointer 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_safe_fxable(sc, caddr(tc)))) || + ((vars == 3) && (is_pair(cddr(tc))) && (is_pair(cdddr(tc))) && (is_null(cddddr(tc))) && + (is_safe_fxable(sc, caddr(tc))) && (is_safe_fxable(sc, cadddr(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) : + ((len == 3) ? OP_TC_OR_A_AND_A_LA : OP_TC_OR_A_AND_A_A_LA)); + else + if (vars == 2) + set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_LAA : OP_TC_OR_A_AND_A_LAA); + else set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_L3A : OP_TC_OR_A_AND_A_L3A); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cdr(orx), args); + if (len == 4) fx_annotate_arg(sc, cddr(orx), args); + fx_annotate_args(sc, cdr(tc), args); + /* if ((fx_proc(cdr(tc)) == fx_c_sca) && (fn_proc(cadr(tc)) == g_substring)) -> g_substring_uncopied); */ + /* for that to be safe we need to be sure nothing in the body looks for null-termination (e.g.. string->number) */ + fx_tree(sc, cdr(body), car(args), (vars == 1) ? NULL : cadr(args), (vars == 3) ? caddr(args) : NULL, false); + return(true); + }}} else - { - if ((vars == 1) && - (car(body) == sc->or_symbol) && - (is_fxable(sc, orx)) && - (is_pair(cdddr(body))) && - (is_pair(cadddr(body)))) - { - s7_pointer and_p = cadddr(body); - if ((is_proper_list_4(sc, and_p)) && - (car(and_p) == sc->and_symbol) && - (is_fxable(sc, cadr(and_p))) && - (is_fxable(sc, caddr(and_p)))) - { - s7_pointer la = cadddr(and_p); - if ((is_proper_list_2(sc, la)) && - (car(la) == name) && - (is_fxable(sc, cadr(la)))) - { - set_safe_optimize_op(body, OP_TC_OR_A_A_AND_A_A_LA); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cddr(body), args); - fx_annotate_arg(sc, cdr(and_p), args); - fx_annotate_arg(sc, cddr(and_p), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - return(true); - }}} - else - { - if ((vars == 1) && (car(body) == sc->and_symbol) && (car(orx) == sc->if_symbol) && - (is_proper_list_4(sc, orx)) && (is_fxable(sc, cadr(orx))) && (tree_count(sc, name, orx, 0) == 1)) - { - bool z_first = ((is_pair(cadddr(orx))) && (car(cadddr(orx)) == name)); - s7_pointer la = (z_first) ? cadddr(orx) : caddr(orx); - if ((car(la) == name) && (is_proper_list_2(sc, la)) && (is_fxable(sc, cadr(la)))) - { - bool z_fxable = true; - s7_pointer z = (z_first) ? cddr(orx) : cdddr(orx); - set_optimize_op(body, (z_first) ? OP_TC_AND_A_IF_A_Z_LA : OP_TC_AND_A_IF_A_LA_Z); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cdr(orx), args); - fx_annotate_arg(sc, cdr(la), args); - if (is_fxable(sc, car(z))) fx_annotate_arg(sc, z, args); else z_fxable = false; - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - if (z_fxable) set_optimized(body); - return(z_fxable); - }}}}} + { + if ((vars == 1) && + (car(body) == sc->or_symbol) && + (is_fxable(sc, orx)) && + (is_pair(cdddr(body))) && + (is_pair(cadddr(body)))) + { + s7_pointer and_p = cadddr(body); + if ((is_proper_list_4(sc, and_p)) && + (car(and_p) == sc->and_symbol) && + (is_fxable(sc, cadr(and_p))) && + (is_fxable(sc, caddr(and_p)))) + { + s7_pointer la = cadddr(and_p); + if ((is_proper_list_2(sc, la)) && + (car(la) == name) && + (is_fxable(sc, cadr(la)))) + { + set_safe_optimize_op(body, OP_TC_OR_A_A_AND_A_A_LA); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cddr(body), args); + fx_annotate_arg(sc, cdr(and_p), args); + fx_annotate_arg(sc, cddr(and_p), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), NULL, NULL, false); + return(true); + }}} + else + { + if ((vars == 1) && (car(body) == sc->and_symbol) && (car(orx) == sc->if_symbol) && + (is_proper_list_4(sc, orx)) && (is_fxable(sc, cadr(orx))) && (tree_count(sc, name, orx, 0) == 1)) + { + bool z_first = ((is_pair(cadddr(orx))) && (car(cadddr(orx)) == name)); + s7_pointer la = (z_first) ? cadddr(orx) : caddr(orx); + if ((car(la) == name) && (is_proper_list_2(sc, la)) && (is_fxable(sc, cadr(la)))) + { + bool z_fxable = true; + s7_pointer z = (z_first) ? cddr(orx) : cdddr(orx); + set_optimize_op(body, (z_first) ? OP_TC_AND_A_IF_A_Z_LA : OP_TC_AND_A_IF_A_LA_Z); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cdr(orx), args); + fx_annotate_arg(sc, cdr(la), args); + if (is_fxable(sc, car(z))) fx_annotate_arg(sc, z, args); else z_fxable = false; + fx_tree(sc, cdr(body), car(args), NULL, NULL, false); + if (z_fxable) set_optimized(body); + return(z_fxable); + }}}}} if ((vars == 3) && (((car(body) == sc->or_symbol) && (is_proper_list_2(sc, cdr(body)))) || @@ -75337,26 +75337,26 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar { s7_pointer and_p = (car(body) == sc->or_symbol) ? caddr(body) : cadddr(body); if ((is_proper_list_4(sc, and_p)) && - (car(and_p) == sc->and_symbol) && - (is_fxable(sc, cadr(and_p))) && - (is_fxable(sc, caddr(and_p)))) - { - s7_pointer la = cadddr(and_p); - if ((is_proper_list_4(sc, la)) && - (car(la) == name) && - (is_fxable(sc, cadr(la))) && - (is_safe_fxable(sc, caddr(la))) && - (is_safe_fxable(sc, cadddr(la)))) - { - set_safe_optimize_op(body, OP_TC_OR_A_AND_A_A_L3A); - set_opt3_pair(cdr(body), (car(body) == sc->or_symbol) ? cdaddr(body) : cdr(cadddr(body))); - fx_annotate_arg(sc, cdr(body), args); - fx_annotate_arg(sc, cdr(and_p), args); - fx_annotate_arg(sc, cddr(and_p), args); - fx_annotate_args(sc, cdr(la), args); - fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); - return(true); - }}} + (car(and_p) == sc->and_symbol) && + (is_fxable(sc, cadr(and_p))) && + (is_fxable(sc, caddr(and_p)))) + { + s7_pointer la = cadddr(and_p); + if ((is_proper_list_4(sc, la)) && + (car(la) == name) && + (is_fxable(sc, cadr(la))) && + (is_safe_fxable(sc, caddr(la))) && + (is_safe_fxable(sc, cadddr(la)))) + { + set_safe_optimize_op(body, OP_TC_OR_A_AND_A_A_L3A); + set_opt3_pair(cdr(body), (car(body) == sc->or_symbol) ? cdaddr(body) : cdr(cadddr(body))); + fx_annotate_arg(sc, cdr(body), args); + fx_annotate_arg(sc, cdr(and_p), args); + fx_annotate_arg(sc, cddr(and_p), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); + return(true); + }}} if (((vars >= 1) && (vars <= 3)) && (car(body) == sc->if_symbol) && @@ -75364,205 +75364,205 @@ static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer ar { s7_pointer test = cadr(body); if (is_fxable(sc, test)) - { - s7_pointer true_p = caddr(body); - s7_pointer false_p = cadddr(body); - s7_int true_len = proper_list_length(true_p); - s7_int false_len = proper_list_length(false_p); - - fx_annotate_arg(sc, cdr(body), args); - - if (vars == 1) - { - if ((false_len == 2) && - (car(false_p) == name) && - (is_fxable(sc, cadr(false_p)))) - { - set_optimize_op(body, OP_TC_IF_A_Z_LA); - fx_annotate_arg(sc, cdr(false_p), args); /* arg */ - set_opt1_pair(cdr(body), cddr(body)); - set_opt3_pair(cdr(body), cdar(cdddr(body))); - if (!is_fxable(sc, true_p)) return(false); - fx_annotate_arg(sc, cddr(body), args); /* result */ - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - set_optimized(body); /* split here and elsewhere from set_optimize_op is deliberate */ - return(true); - } - if ((true_len == 2) && - (car(true_p) == name) && - (is_fxable(sc, cadr(true_p)))) - { - set_optimize_op(body, OP_TC_IF_A_LA_Z); - fx_annotate_arg(sc, cdr(true_p), args); /* arg */ - set_opt1_pair(cdr(body), cdddr(body)); - set_opt3_pair(cdr(body), cdar(cddr(body))); - if (!is_fxable(sc, false_p)) return(false); - fx_annotate_arg(sc, cdddr(body), args); /* result */ - fx_tree(sc, cdr(body), car(args), NULL, NULL, false); - set_optimized(body); - return(true); - }} - - if (vars == 2) - { - if ((false_len == 3) && - (car(false_p) == name) && - (is_fxable(sc, cadr(false_p))) && - (is_safe_fxable(sc, caddr(false_p)))) - { - set_optimize_op(body, OP_TC_IF_A_Z_LAA); - fx_annotate_args(sc, cdr(false_p), args); - set_opt1_pair(cdr(body), cddr(body)); /* body == code in op, if_z */ - set_opt3_pair(cdr(body), cdar(cdddr(body))); /* la */ - if (!is_fxable(sc, true_p)) return(false); - fx_annotate_arg(sc, cddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_optimized(body); - return(true); - } - if ((true_len == 3) && - (car(true_p) == name) && - (is_fxable(sc, cadr(true_p))) && - (is_safe_fxable(sc, caddr(true_p)))) - { - set_optimize_op(body, OP_TC_IF_A_LAA_Z); - fx_annotate_args(sc, cdr(true_p), args); - set_opt1_pair(cdr(body), cdddr(body)); - set_opt3_pair(cdr(body), cdar(cddr(body))); - if (!is_fxable(sc, false_p)) return(false); - fx_annotate_arg(sc, cdddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); - set_optimized(body); - return(true); - }} - - if (vars == 3) - { - if ((false_len == 4) && - (car(false_p) == name) && - (is_fxable(sc, cadr(false_p))) && (is_safe_fxable(sc, caddr(false_p))) && (is_safe_fxable(sc, cadddr(false_p)))) - { - set_optimize_op(body, OP_TC_IF_A_Z_L3A); - fx_annotate_args(sc, cdr(false_p), args); - set_opt1_pair(cdr(body), cddr(body)); - set_opt3_pair(cdr(body), cdar(cdddr(body))); - if (!is_fxable(sc, true_p)) return(false); - fx_annotate_arg(sc, cddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); - set_optimized(body); - return(true); - } - if ((true_len == 4) && - (car(true_p) == name) && - (is_fxable(sc, cadr(true_p))) && (is_safe_fxable(sc, caddr(true_p))) && (is_safe_fxable(sc, cadddr(true_p)))) - { - set_optimize_op(body, OP_TC_IF_A_L3A_Z); - fx_annotate_args(sc, cdr(true_p), args); - set_opt1_pair(cdr(body), cdddr(body)); - set_opt3_pair(cdr(body), cdar(cddr(body))); - if (!is_fxable(sc, false_p)) return(false); - fx_annotate_arg(sc, cdddr(body), args); - fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); - set_optimized(body); - return(true); - }} - - if ((false_len == 4) && - (car(false_p) == sc->if_symbol)) - { - s7_pointer in_test = cadr(false_p); - s7_pointer in_true = caddr(false_p); - s7_pointer 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)))) - { - la = in_false; - z = cddr(false_p); - } - else - if ((is_pair(in_true)) && - (car(in_true) == name) && - (is_pair(cdr(in_true))) && - (is_fxable(sc, cadr(in_true)))) - { - la = in_true; - z = cdddr(false_p); - } - 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_safe_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_safe_fxable(sc, caddr(la))) && (is_safe_fxable(sc, cadddr(la))) && - (is_fxable(sc, cadr(in_true))) && (is_safe_fxable(sc, caddr(in_true))) && (is_safe_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 - 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 */ - fx_annotate_arg(sc, cddr(body), args); - else zs_fxable = false; - fx_annotate_arg(sc, cdr(false_p), args); /* inner test */ - fx_annotate_args(sc, cdr(la), args); /* la arg(s) */ - if (vars == 3) - fx_annotate_args(sc, cdr(in_true), args); - else - if (is_fxable(sc, car(z))) - fx_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) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, false); - if (zs_fxable) set_optimized(body); - return(zs_fxable); - }}}} - - if ((vars == 2) && - (false_len == 3) && - (car(false_p) == sc->let_star_symbol)) - { - s7_pointer letv = cadr(false_p), letb, v; - - if (!is_pair(letv)) return(false); - letb = caddr(false_p); - for (v = letv; is_pair(v); v = cdr(v)) - if (!is_fxable(sc, cadar(v))) - return(false); - if ((is_proper_list_4(sc, letb)) && - (car(letb) == sc->if_symbol) && - (is_fxable(sc, cadr(letb)))) - { - s7_pointer laa = cadddr(letb); - if ((car(laa) == name) && - (is_proper_list_3(sc, laa)) && - (is_fxable(sc, cadr(laa))) && - (is_safe_fxable(sc, caddr(laa)))) - { - bool zs_fxable; - set_safe_optimize_op(body, OP_TC_IF_A_Z_LET_IF_A_Z_LAA); - fx_annotate_args(sc, cdr(laa), args); - zs_fxable = is_fxable(sc, caddr(letb)); - fx_annotate_args(sc, cdr(letb), args); - for (v = letv; is_pair(v); v = cdr(v)) - fx_annotate_arg(sc, cdar(v), args); - fx_tree(sc, cdar(letv), car(args), cadr(args), NULL, true); /* first var of let*, second var of let* can't be fx_treed */ - fx_tree(sc, cdr(body), car(args), cadr(args), NULL, true); /* these are references to the outer let */ - fx_tree(sc, cdr(laa), caar(letv), (is_pair(cdr(letv))) ? caadr(letv) : NULL, NULL, true); - fx_tree(sc, cdr(letb), caar(letv), (is_pair(cdr(letv))) ? caadr(letv) : NULL, NULL, true); - fx_tree_outer(sc, cddr(letb), car(args), cadr(args), NULL, true); - if (!is_fxable(sc, caddr(body))) - return(false); - fx_annotate_arg(sc, cddr(body), args); - return(zs_fxable); - }}}}} + { + s7_pointer true_p = caddr(body); + s7_pointer false_p = cadddr(body); + s7_int true_len = proper_list_length(true_p); + s7_int false_len = proper_list_length(false_p); + + fx_annotate_arg(sc, cdr(body), args); + + if (vars == 1) + { + if ((false_len == 2) && + (car(false_p) == name) && + (is_fxable(sc, cadr(false_p)))) + { + set_optimize_op(body, OP_TC_IF_A_Z_LA); + fx_annotate_arg(sc, cdr(false_p), args); /* arg */ + set_opt1_pair(cdr(body), cddr(body)); + set_opt3_pair(cdr(body), cdar(cdddr(body))); + if (!is_fxable(sc, true_p)) return(false); + fx_annotate_arg(sc, cddr(body), args); /* result */ + fx_tree(sc, cdr(body), car(args), NULL, NULL, false); + set_optimized(body); /* split here and elsewhere from set_optimize_op is deliberate */ + return(true); + } + if ((true_len == 2) && + (car(true_p) == name) && + (is_fxable(sc, cadr(true_p)))) + { + set_optimize_op(body, OP_TC_IF_A_LA_Z); + fx_annotate_arg(sc, cdr(true_p), args); /* arg */ + set_opt1_pair(cdr(body), cdddr(body)); + set_opt3_pair(cdr(body), cdar(cddr(body))); + if (!is_fxable(sc, false_p)) return(false); + fx_annotate_arg(sc, cdddr(body), args); /* result */ + fx_tree(sc, cdr(body), car(args), NULL, NULL, false); + set_optimized(body); + return(true); + }} + + if (vars == 2) + { + if ((false_len == 3) && + (car(false_p) == name) && + (is_fxable(sc, cadr(false_p))) && + (is_safe_fxable(sc, caddr(false_p)))) + { + set_optimize_op(body, OP_TC_IF_A_Z_LAA); + fx_annotate_args(sc, cdr(false_p), args); + set_opt1_pair(cdr(body), cddr(body)); /* body == code in op, if_z */ + set_opt3_pair(cdr(body), cdar(cdddr(body))); /* la */ + if (!is_fxable(sc, true_p)) return(false); + fx_annotate_arg(sc, cddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + set_optimized(body); + return(true); + } + if ((true_len == 3) && + (car(true_p) == name) && + (is_fxable(sc, cadr(true_p))) && + (is_safe_fxable(sc, caddr(true_p)))) + { + set_optimize_op(body, OP_TC_IF_A_LAA_Z); + fx_annotate_args(sc, cdr(true_p), args); + set_opt1_pair(cdr(body), cdddr(body)); + set_opt3_pair(cdr(body), cdar(cddr(body))); + if (!is_fxable(sc, false_p)) return(false); + fx_annotate_arg(sc, cdddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + set_optimized(body); + return(true); + }} + + if (vars == 3) + { + if ((false_len == 4) && + (car(false_p) == name) && + (is_fxable(sc, cadr(false_p))) && (is_safe_fxable(sc, caddr(false_p))) && (is_safe_fxable(sc, cadddr(false_p)))) + { + set_optimize_op(body, OP_TC_IF_A_Z_L3A); + fx_annotate_args(sc, cdr(false_p), args); + set_opt1_pair(cdr(body), cddr(body)); + set_opt3_pair(cdr(body), cdar(cdddr(body))); + if (!is_fxable(sc, true_p)) return(false); + fx_annotate_arg(sc, cddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); + set_optimized(body); + return(true); + } + if ((true_len == 4) && + (car(true_p) == name) && + (is_fxable(sc, cadr(true_p))) && (is_safe_fxable(sc, caddr(true_p))) && (is_safe_fxable(sc, cadddr(true_p)))) + { + set_optimize_op(body, OP_TC_IF_A_L3A_Z); + fx_annotate_args(sc, cdr(true_p), args); + set_opt1_pair(cdr(body), cdddr(body)); + set_opt3_pair(cdr(body), cdar(cddr(body))); + if (!is_fxable(sc, false_p)) return(false); + fx_annotate_arg(sc, cdddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args), caddr(args), false); + set_optimized(body); + return(true); + }} + + if ((false_len == 4) && + (car(false_p) == sc->if_symbol)) + { + s7_pointer in_test = cadr(false_p); + s7_pointer in_true = caddr(false_p); + s7_pointer 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)))) + { + la = in_false; + z = cddr(false_p); + } + else + if ((is_pair(in_true)) && + (car(in_true) == name) && + (is_pair(cdr(in_true))) && + (is_fxable(sc, cadr(in_true)))) + { + la = in_true; + z = cdddr(false_p); + } + 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_safe_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_safe_fxable(sc, caddr(la))) && (is_safe_fxable(sc, cadddr(la))) && + (is_fxable(sc, cadr(in_true))) && (is_safe_fxable(sc, caddr(in_true))) && (is_safe_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 + 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 */ + fx_annotate_arg(sc, cddr(body), args); + else zs_fxable = false; + fx_annotate_arg(sc, cdr(false_p), args); /* inner test */ + fx_annotate_args(sc, cdr(la), args); /* la arg(s) */ + if (vars == 3) + fx_annotate_args(sc, cdr(in_true), args); + else + if (is_fxable(sc, car(z))) + fx_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) ? cadr(args) : NULL, (vars > 2) ? caddr(args) : NULL, false); + if (zs_fxable) set_optimized(body); + return(zs_fxable); + }}}} + + if ((vars == 2) && + (false_len == 3) && + (car(false_p) == sc->let_star_symbol)) + { + s7_pointer letv = cadr(false_p), letb, v; + + if (!is_pair(letv)) return(false); + letb = caddr(false_p); + for (v = letv; is_pair(v); v = cdr(v)) + if (!is_fxable(sc, cadar(v))) + return(false); + if ((is_proper_list_4(sc, letb)) && + (car(letb) == sc->if_symbol) && + (is_fxable(sc, cadr(letb)))) + { + s7_pointer laa = cadddr(letb); + if ((car(laa) == name) && + (is_proper_list_3(sc, laa)) && + (is_fxable(sc, cadr(laa))) && + (is_safe_fxable(sc, caddr(laa)))) + { + bool zs_fxable; + set_safe_optimize_op(body, OP_TC_IF_A_Z_LET_IF_A_Z_LAA); + fx_annotate_args(sc, cdr(laa), args); + zs_fxable = is_fxable(sc, caddr(letb)); + fx_annotate_args(sc, cdr(letb), args); + for (v = letv; is_pair(v); v = cdr(v)) + fx_annotate_arg(sc, cdar(v), args); + fx_tree(sc, cdar(letv), car(args), cadr(args), NULL, true); /* first var of let*, second var of let* can't be fx_treed */ + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, true); /* these are references to the outer let */ + fx_tree(sc, cdr(laa), caar(letv), (is_pair(cdr(letv))) ? caadr(letv) : NULL, NULL, true); + fx_tree(sc, cdr(letb), caar(letv), (is_pair(cdr(letv))) ? caadr(letv) : NULL, NULL, true); + fx_tree_outer(sc, cddr(letb), car(args), cadr(args), NULL, true); + if (!is_fxable(sc, caddr(body))) + return(false); + fx_annotate_arg(sc, cddr(body), args); + return(zs_fxable); + }}}}} /* let */ if ((is_proper_list_3(sc, body)) && @@ -75597,10 +75597,10 @@ static void mark_fx_treeable(s7_scheme *sc, s7_pointer body) if (is_pair(body)) /* slightly faster than the other way of writing this */ { if (is_pair(car(body))) - { - set_is_fx_treeable(body); - mark_fx_treeable(sc, car(body)); - } + { + set_is_fx_treeable(body); + mark_fx_treeable(sc, car(body)); + } mark_fx_treeable(sc, cdr(body)); } } @@ -75611,9 +75611,9 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_truncated(body)); if (len < 0) /* (define (hi) 1 . 2) */ error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "~A: function body messed up, ~A", 31), - (unstarred_lambda) ? sc->lambda_symbol : sc->lambda_star_symbol, - sc->code)); + set_elist_3(sc, wrap_string(sc, "~A: function body messed up, ~A", 31), + (unstarred_lambda) ? sc->lambda_symbol : sc->lambda_star_symbol, + sc->code)); if (len > 0) /* i.e. not circular */ { body_t result; @@ -75621,9 +75621,9 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun clear_symbol_list(sc); for (p = args; is_pair(p); p = cdr(p)) - add_symbol_to_list(sc, (is_symbol(car(p))) ? car(p) : caar(p)); + add_symbol_to_list(sc, (is_symbol(car(p))) ? car(p) : caar(p)); if (!is_null(p)) - add_symbol_to_list(sc, p); + add_symbol_to_list(sc, p); sc->got_tc = false; sc->not_tc = false; sc->got_rec = false; @@ -75633,77 +75633,77 @@ static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer fun /* if the body is safe, we can optimize the calling sequence */ if (!unstarred_lambda) - { - bool happy = true; - /* check default vals -- if none is an expression or symbol, set simple args */ - for (p = args; is_pair(p); p = cdr(p)) - { - s7_pointer arg = car(p); - if ((is_pair(arg)) && /* has default value */ - (is_pair(cdr(arg))) && /* is not a ridiculous improper list */ - ((is_symbol(cadr(arg))) || /* if default value might involve eval in any way, it isn't simple */ - (is_unquoted_pair(cadr(arg))))) /* pair as default only ok if it is (quote ...) */ - { - happy = false; - if ((result > UNSAFE_BODY) && - (tree_has_definers_or_binders(sc, cadr(arg)))) /* if the default has a definer, body is not safe (funclet is not stable) */ - result = UNSAFE_BODY; - break; - }} - if (happy) - lambda_set_simple_defaults(body); - } + { + bool happy = true; + /* check default vals -- if none is an expression or symbol, set simple args */ + for (p = args; is_pair(p); p = cdr(p)) + { + s7_pointer arg = car(p); + if ((is_pair(arg)) && /* has default value */ + (is_pair(cdr(arg))) && /* is not a ridiculous improper list */ + ((is_symbol(cadr(arg))) || /* if default value might involve eval in any way, it isn't simple */ + (is_unquoted_pair(cadr(arg))))) /* pair as default only ok if it is (quote ...) */ + { + happy = false; + if ((result > UNSAFE_BODY) && + (tree_has_definers_or_binders(sc, cadr(arg)))) /* if the default has a definer, body is not safe (funclet is not stable) */ + result = UNSAFE_BODY; + break; + }} + if (happy) + lambda_set_simple_defaults(body); + } if (result >= SAFE_BODY) /* not RECUR_BODY here (need new let for cons-r in s7test) */ - { - set_safe_closure_body(body); - if (result == VERY_SAFE_BODY) - set_very_safe_closure_body(body); - } + { + set_safe_closure_body(body); + if (result == VERY_SAFE_BODY) + set_very_safe_closure_body(body); + } if (is_symbol(func)) - { - lst = list_1(sc, add_symbol_to_list(sc, func)); - sc->temp1 = lst; - } + { + lst = list_1(sc, add_symbol_to_list(sc, func)); + sc->temp1 = lst; + } else lst = sc->nil; if (optimize(sc, body, 1, cleared_args = collect_parameters(sc, args, lst)) == OPT_OOPS) - clear_all_optimizations(sc, body); + clear_all_optimizations(sc, body); else - if (result >= RECUR_BODY) - { - int32_t nvars; - mark_fx_treeable(sc, body); - - for (nvars = 0, p = args; (is_pair(p)) && (!is_symbol_and_keyword(car(p))); nvars++, p = cdr(p)); - if ((is_null(p)) && - (nvars > 0)) - { - fx_annotate_args(sc, body, cleared_args); /* almost useless -- we need a recursive traversal here but that collides with check_if et al */ - fx_tree(sc, body, /* this usually costs more than it saves! */ - (is_pair(car(args))) ? caar(args) : car(args), - (nvars > 1) ? ((is_pair(cadr(args))) ? caadr(args) : cadr(args)) : NULL, - (nvars > 2) ? ((is_pair(caddr(args))) ? caaddr(args) : caddr(args)) : NULL, - nvars > 3); - } - if (((unstarred_lambda) || ((is_null(p)) && (nvars == sc->rec_tc_args))) && - (is_null(cdr(body)))) - { /* (if <a> #t|#f...) happens only rarely */ - if (sc->got_tc) - { - if (check_tc(sc, func, nvars, args, car(body))) - set_safe_closure_body(body); /* (very_)safe_closure set above if > RECUR_BODY */ - /* if not check_tc, car(body) is either not a tc op or it is not optimized so that is_fxable will return false */ - } - if ((sc->got_rec) && - (!is_tc_op(optimize_op(car(body)))) && - (check_recur(sc, func, nvars, args, car(body)))) - set_safe_closure_body(body); - }} + if (result >= RECUR_BODY) + { + int32_t nvars; + mark_fx_treeable(sc, body); + + for (nvars = 0, p = args; (is_pair(p)) && (!is_symbol_and_keyword(car(p))); nvars++, p = cdr(p)); + if ((is_null(p)) && + (nvars > 0)) + { + fx_annotate_args(sc, body, cleared_args); /* almost useless -- we need a recursive traversal here but that collides with check_if et al */ + fx_tree(sc, body, /* this usually costs more than it saves! */ + (is_pair(car(args))) ? caar(args) : car(args), + (nvars > 1) ? ((is_pair(cadr(args))) ? caadr(args) : cadr(args)) : NULL, + (nvars > 2) ? ((is_pair(caddr(args))) ? caaddr(args) : caddr(args)) : NULL, + nvars > 3); + } + if (((unstarred_lambda) || ((is_null(p)) && (nvars == sc->rec_tc_args))) && + (is_null(cdr(body)))) + { /* (if <a> #t|#f...) happens only rarely */ + if (sc->got_tc) + { + if (check_tc(sc, func, nvars, args, car(body))) + set_safe_closure_body(body); /* (very_)safe_closure set above if > RECUR_BODY */ + /* if not check_tc, car(body) is either not a tc op or it is not optimized so that is_fxable will return false */ + } + if ((sc->got_rec) && + (!is_tc_op(optimize_op(car(body)))) && + (check_recur(sc, func, nvars, args, car(body)))) + set_safe_closure_body(body); + }} if (is_symbol(func)) - { - sc->temp1 = sc->unused; - free_cell(sc, lst); - } + { + sc->temp1 = sc->unused; + free_cell(sc, lst); + } sc->got_tc = false; sc->not_tc = false; sc->got_rec = false; @@ -75749,9 +75749,9 @@ static int32_t check_lambda(s7_scheme *sc, s7_pointer form, bool opt) optimize_lambda(sc, true, sc->unused, car(code), body); else if (optimize(sc, body, 0, - /* ((sc->op_stack_now > sc->op_stack) && (is_c_function((*(sc->op_stack_now - 1)))) && (is_scope_safe((*(sc->op_stack_now - 1))))) ? 1 : 0, */ - /* this works except when someone resets outlet(curlet) after defining a local function! */ - collect_parameters(sc, car(code), sc->nil)) == OPT_OOPS) + /* ((sc->op_stack_now > sc->op_stack) && (is_c_function((*(sc->op_stack_now - 1)))) && (is_scope_safe((*(sc->op_stack_now - 1))))) ? 1 : 0, */ + /* this works except when someone resets outlet(curlet) after defining a local function! */ + collect_parameters(sc, car(code), sc->nil)) == OPT_OOPS) clear_all_optimizations(sc, body); pair_set_syntax_op(form, OP_LAMBDA_UNCHECKED); if (arity < -1) arity++; /* confusing! at least 0 = (), but (lambda arg...) has same "arity" here as (lambda (a . b)...)? */ @@ -75789,7 +75789,7 @@ static void check_lambda_star(s7_scheme *sc) (stack_top_op(sc) != OP_DEFINE1)) { if (optimize(sc, cdr(code), 0, collect_parameters(sc, car(code), sc->nil)) == OPT_OOPS) - clear_all_optimizations(sc, cdr(code)); + clear_all_optimizations(sc, cdr(code)); } else optimize_lambda(sc, false, sc->unused, car(code), cdr(code)); @@ -75802,7 +75802,7 @@ static void check_lambda_star(s7_scheme *sc) static inline bool is_undefined_feed_to(s7_scheme *sc, const s7_pointer sym) { return((sym == sc->feed_to_symbol) && - ((symbol_ctr(sc->feed_to_symbol) == 0) || (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))); + ((symbol_ctr(sc->feed_to_symbol) == 0) || (s7_symbol_value(sc, sc->feed_to_symbol) == sc->undefined))); } static bool is_all_fxable(s7_scheme *sc, s7_pointer x) @@ -75832,85 +75832,85 @@ static s7_pointer check_case(s7_scheme *sc) { s7_pointer y, car_x; if (!is_pair(car(x))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case clause ~S messed up in ~A", sc->print_length), - x, object_to_string_truncated(sc, form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case clause ~S messed up in ~A", sc->print_length), + x, object_to_string_truncated(sc, form))); car_x = car(x); if (!is_list(cdr(car_x))) /* (case 1 ((1))) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case clause result ~S is messed up in ~A", sc->print_length), - car_x, object_to_string_truncated(sc, form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case clause result ~S is messed up in ~A", sc->print_length), + car_x, object_to_string_truncated(sc, form))); if ((bodies_simple) && - ((is_null(cdr(car_x))) || (!is_null(cddr(car_x))))) - bodies_simple = false; + ((is_null(cdr(car_x))) || (!is_null(cddr(car_x))))) + bodies_simple = false; use_fx = ((use_fx) && (is_pair(cdr(car_x))) && (is_all_fxable(sc, cdr(car_x)))); y = car(car_x); if (!is_pair(y)) - { - if ((y != sc->else_symbol) && /* (case 1 (2 1)) */ - ((!is_symbol(y)) || - (s7_symbol_value(sc, y) != sc->else_symbol))) /* "proper list" below because: (case 1 (() 2) ... */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "case clause key-list ~S in ~S is not a proper list or 'else', in ~A", 67), - y, car_x, object_to_string_truncated(sc, form))); - has_else = true; - if (is_not_null(cdr(x))) /* (case 1 (else 1) ((2) 1)) */ - syntax_error_nr(sc, "case 'else' clause is not the last clause: ~S", 45, x); - if (!is_null(cdr(car_x))) /* else (else) so return selector */ - { - if (is_pair(cddr(car_x))) - { - set_opt3_any(code, cdr(car_x)); - bodies_simple = false; - } - else - { - set_opt3_any(code, ((bodies_simple) && (keys_single)) ? cadr(car_x) : cdr(car_x)); - set_opt1_clause(x, cadr(car_x)); - }}} + { + if ((y != sc->else_symbol) && /* (case 1 (2 1)) */ + ((!is_symbol(y)) || + (s7_symbol_value(sc, y) != sc->else_symbol))) /* "proper list" below because: (case 1 (() 2) ... */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "case clause key-list ~S in ~S is not a proper list or 'else', in ~A", 67), + y, car_x, object_to_string_truncated(sc, form))); + has_else = true; + if (is_not_null(cdr(x))) /* (case 1 (else 1) ((2) 1)) */ + syntax_error_nr(sc, "case 'else' clause is not the last clause: ~S", 45, x); + if (!is_null(cdr(car_x))) /* else (else) so return selector */ + { + if (is_pair(cddr(car_x))) + { + set_opt3_any(code, cdr(car_x)); + bodies_simple = false; + } + else + { + set_opt3_any(code, ((bodies_simple) && (keys_single)) ? cadr(car_x) : cdr(car_x)); + set_opt1_clause(x, cadr(car_x)); + }}} else - { - if (!is_simple(car(y))) keys_simple = false; - if (!is_null(cdr(y))) keys_single = false; - if (key_type == T_FREE) - key_type = type(car(y)); - else - if (key_type != type(car(y))) - key_type = NUM_TYPES; - if (key_type == T_SYMBOL) set_case_key(car(y)); - - for (y = cdr(y); is_pair(y); y = cdr(y)) - { - if (!is_simple(car(y))) - keys_simple = false; - if (key_type != type(car(y))) - key_type = NUM_TYPES; - if (key_type == T_SYMBOL) set_case_key(car(y)); - } - if (!is_null(y)) /* (case () ((1 . 2) . hi) . hi) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case key list ~S is improper, in ~A", 35), - car_x, object_to_string_truncated(sc, form))); - } + { + if (!is_simple(car(y))) keys_simple = false; + if (!is_null(cdr(y))) keys_single = false; + if (key_type == T_FREE) + key_type = type(car(y)); + else + if (key_type != type(car(y))) + key_type = NUM_TYPES; + if (key_type == T_SYMBOL) set_case_key(car(y)); + + for (y = cdr(y); is_pair(y); y = cdr(y)) + { + if (!is_simple(car(y))) + keys_simple = false; + if (key_type != type(car(y))) + key_type = NUM_TYPES; + if (key_type == T_SYMBOL) set_case_key(car(y)); + } + if (!is_null(y)) /* (case () ((1 . 2) . hi) . hi) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case key list ~S is improper, in ~A", 35), + car_x, object_to_string_truncated(sc, form))); + } y = car_x; if (!s7_is_proper_list(sc, cdr(y))) /* (case 2 ((1 2) 1 . 2)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case: stray dot? ~S in ~A", 25), - y, object_to_string_truncated(sc, form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case: stray dot? ~S in ~A", 25), + y, object_to_string_truncated(sc, form))); if ((is_pair(cdr(y))) && (is_undefined_feed_to(sc, cadr(y)))) - { - has_feed_to = true; - if (!is_pair(cddr(y))) /* (case 1 (else =>)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case: '=>' target missing: ~S in ~A", 35), - y, object_to_string_truncated(sc, form))); - if (is_pair(cdddr(y))) /* (case 1 (else => + - *)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "case: '=>' has too many targets: ~S in ~A", 41), - y, object_to_string_truncated(sc, form))); - }} + { + has_feed_to = true; + if (!is_pair(cddr(y))) /* (case 1 (else =>)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case: '=>' target missing: ~S in ~A", 35), + y, object_to_string_truncated(sc, form))); + if (is_pair(cdddr(y))) /* (case 1 (else => + - *)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case: '=>' has too many targets: ~S in ~A", 41), + y, object_to_string_truncated(sc, form))); + }} if (is_not_null(x)) /* (case x ((1 2)) . 1) */ syntax_error_nr(sc, "case: stray dot? ~S", 19, form); @@ -75918,21 +75918,21 @@ static s7_pointer check_case(s7_scheme *sc) (bodies_simple)) { for (x = cdr(code); is_not_null(x); x = cdr(x)) - { - set_opt2_any(x, caar(x)); - if (is_pair(opt2_any(x))) - { - set_opt2_any(x, car(opt2_any(x))); - if (is_pair(cdar(x))) - set_opt1_clause(x, cadar(x)); - }}} + { + set_opt2_any(x, caar(x)); + if (is_pair(opt2_any(x))) + { + set_opt2_any(x, car(opt2_any(x))); + if (is_pair(cdar(x))) + set_opt1_clause(x, cadar(x)); + }}} else for (x = cdr(code); is_not_null(x); x = cdr(x)) { - set_opt2_any(x, caar(x)); - if ((is_pair(opt2_any(x))) && - (is_pair(cdar(x)))) - set_opt1_clause(x, cadar(x)); + set_opt2_any(x, caar(x)); + if ((is_pair(opt2_any(x))) && + (is_pair(cdar(x)))) + set_opt1_clause(x, cadar(x)); } if (key_type == T_INTEGER) set_has_integer_keys(form); @@ -75944,62 +75944,62 @@ static s7_pointer check_case(s7_scheme *sc) (!keys_single)) { if (!keys_simple) /* x_g_g */ - { - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, OP_CASE_A_G_G); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); - } - else pair_set_syntax_op(form, OP_CASE_P_G_G); - } + { + if (is_fxable(sc, car(code))) + { + pair_set_syntax_op(form, OP_CASE_A_G_G); + set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); + if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); + } + else pair_set_syntax_op(form, OP_CASE_P_G_G); + } else /* x_e_g */ - { - if (!has_else) set_opt3_any(code, sc->unused); /* affects all that goto CASE_E_G */ - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, (key_type == T_SYMBOL) ? OP_CASE_A_S_G : OP_CASE_A_E_G); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); - } - else pair_set_syntax_op(form, OP_CASE_P_E_G); - }} + { + if (!has_else) set_opt3_any(code, sc->unused); /* affects all that goto CASE_E_G */ + if (is_fxable(sc, car(code))) + { + pair_set_syntax_op(form, (key_type == T_SYMBOL) ? OP_CASE_A_S_G : OP_CASE_A_E_G); + set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); + if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); + } + else pair_set_syntax_op(form, OP_CASE_P_E_G); + }} else /* x_x_s */ if (!keys_simple) /* x_g|i_s */ { - if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, ((!WITH_GMP) && (key_type == T_INTEGER)) ? OP_CASE_A_I_S : OP_CASE_A_G_S); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); - } - else pair_set_syntax_op(form, ((!WITH_GMP) && (key_type == T_INTEGER)) ? OP_CASE_P_I_S : OP_CASE_P_G_S); + if (is_fxable(sc, car(code))) + { + pair_set_syntax_op(form, ((!WITH_GMP) && (key_type == T_INTEGER)) ? OP_CASE_A_I_S : OP_CASE_A_G_S); + set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); + if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); + } + else pair_set_syntax_op(form, ((!WITH_GMP) && (key_type == T_INTEGER)) ? OP_CASE_P_I_S : OP_CASE_P_G_S); } else /* x_e_s */ if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, OP_CASE_A_E_S); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); - } + { + pair_set_syntax_op(form, OP_CASE_A_E_S); + set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); + if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree_in(sc, code); + } else pair_set_syntax_op(form, OP_CASE_P_E_S); if ((use_fx) && (has_else) && (!has_feed_to)) { opcode_t op = optimize_op(form); if ((op == OP_CASE_A_E_S) || (op == OP_CASE_A_G_S) || (op == OP_CASE_A_S_G) || ((!WITH_GMP) && (op == OP_CASE_A_I_S))) - { - pair_set_syntax_op(form, - (op == OP_CASE_A_I_S) ? OP_CASE_A_I_S_A : - ((op == OP_CASE_A_E_S) ? OP_CASE_A_E_S_A : - ((op == OP_CASE_A_S_G) ? OP_CASE_A_S_G_A : OP_CASE_A_G_S_A))); - for (x = cdr(code); is_pair(x); x = cdr(x)) - { - s7_pointer clause = cdar(x); - fx_annotate_args(sc, clause, sc->curlet); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, clause); - if (is_null(cdr(x))) set_opt3_any(code, clause); - }}} + { + pair_set_syntax_op(form, + (op == OP_CASE_A_I_S) ? OP_CASE_A_I_S_A : + ((op == OP_CASE_A_E_S) ? OP_CASE_A_E_S_A : + ((op == OP_CASE_A_S_G) ? OP_CASE_A_S_G_A : OP_CASE_A_G_S_A))); + for (x = cdr(code); is_pair(x); x = cdr(x)) + { + s7_pointer clause = cdar(x); + fx_annotate_args(sc, clause, sc->curlet); + if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, clause); + if (is_null(cdr(x))) set_opt3_any(code, clause); + }}} carc = cadr(form); if (!is_pair(carc)) { @@ -76019,14 +76019,14 @@ static bool op_case_i_s(s7_scheme *sc) if (else_clause != sc->unspecified) { if (is_t_integer(selector)) - { - s7_int val = integer(selector); - for (s7_pointer x = cddr(sc->code); is_pair(cdr(x)); x = cdr(x)) - if (integer(opt2_any(x)) == val) - { - sc->code = opt1_clause(x); - return(false); - }} + { + s7_int val = integer(selector); + for (s7_pointer x = cddr(sc->code); is_pair(cdr(x)); x = cdr(x)) + if (integer(opt2_any(x)) == val) + { + sc->code = opt1_clause(x); + return(false); + }} sc->code = else_clause; return(false); } @@ -76034,11 +76034,11 @@ static bool op_case_i_s(s7_scheme *sc) { s7_int val = integer(selector); for (s7_pointer x = cddr(sc->code); is_pair(x); x = cdr(x)) - if (integer(opt2_any(x)) == val) - { - sc->code = opt1_clause(x); - return(false); - }} + if (integer(opt2_any(x)) == val) + { + sc->code = opt1_clause(x); + return(false); + }} sc->value = sc->unspecified; return(true); } @@ -76050,8 +76050,8 @@ static inline s7_pointer fx_case_a_i_s_a(s7_scheme *sc, s7_pointer code) /* inli { s7_int val = integer(selector); for (s7_pointer x = cddr(sc->code); is_pair(cdr(x)); x = cdr(x)) - if (integer(opt2_any(x)) == val) - return(fx_call(sc, cdar(x))); + if (integer(opt2_any(x)) == val) + return(fx_call(sc, cdar(x))); } return(fx_call(sc, opt3_any(cdr(code)))); } @@ -76063,16 +76063,16 @@ static bool op_case_e_g_1(s7_scheme *sc, const s7_pointer selector, bool ok) if (ok) { for (x = cddr(sc->code); is_pair(x); x = cdr(x)) - { - s7_pointer y = opt2_any(x); - if (!is_pair(y)) /* i.e. else? */ - goto ELSE_CASE_1; - do { - if (car(y) == selector) - goto ELSE_CASE_1; - y = cdr(y); - } while (is_pair(y)); - } + { + s7_pointer y = opt2_any(x); + if (!is_pair(y)) /* i.e. else? */ + goto ELSE_CASE_1; + do { + if (car(y) == selector) + goto ELSE_CASE_1; + y = cdr(y); + } while (is_pair(y)); + } sc->value = sc->unspecified; pop_stack(sc); return(true); @@ -76127,14 +76127,14 @@ static s7_pointer fx_case_a_s_g_a(s7_scheme *sc, s7_pointer code) if (is_case_key(selector)) for (s7_pointer x = cddr(sc->code); is_pair(x); x = cdr(x)) { - s7_pointer y = opt2_any(x); - if (!is_pair(y)) /* i.e. else? */ - return(fx_call_all(sc, cdar(x))); /* else clause */ - do { - if (car(y) == selector) - return(fx_call_all(sc, cdar(x))); - y = cdr(y); - } while (is_pair(y)); + s7_pointer y = opt2_any(x); + if (!is_pair(y)) /* i.e. else? */ + return(fx_call_all(sc, cdar(x))); /* else clause */ + do { + if (car(y) == selector) + return(fx_call_all(sc, cdar(x))); + y = cdr(y); + } while (is_pair(y)); } return(fx_call_all(sc, opt3_any(cdr(code)))); /* selector is not a case-key */ } @@ -76151,31 +76151,31 @@ static bool op_case_g_g(s7_scheme *sc) s7_int selector; sc->code = cddr(sc->code); if (is_t_integer(sc->value)) - selector = integer(sc->value); + selector = integer(sc->value); else - { + { #if WITH_GMP - if ((is_t_big_integer(sc->value)) && (mpz_fits_slong_p(big_integer(sc->value)))) - selector = mpz_get_si(big_integer(sc->value)); - else -#endif - { - for (x = sc->code; is_pair(x); x = cdr(x)) - if (!is_pair(caar(x))) - goto ELSE_CASE; - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - }} + if ((is_t_big_integer(sc->value)) && (mpz_fits_slong_p(big_integer(sc->value)))) + selector = mpz_get_si(big_integer(sc->value)); + else +#endif + { + for (x = sc->code; is_pair(x); x = cdr(x)) + if (!is_pair(caar(x))) + goto ELSE_CASE; + sc->value = sc->unspecified; + pop_stack(sc); + return(true); + }} for (x = sc->code; is_pair(x); x = cdr(x)) - { - s7_pointer y = caar(x); - if (!is_pair(y)) - goto ELSE_CASE; - for (; is_pair(y); y = cdr(y)) - if (integer(car(y)) == selector) - goto ELSE_CASE; - } + { + s7_pointer y = caar(x); + if (!is_pair(y)) + goto ELSE_CASE; + for (; is_pair(y); y = cdr(y)) + if (integer(car(y)) == selector) + goto ELSE_CASE; + } sc->value = sc->unspecified; pop_stack(sc); return(true); @@ -76184,16 +76184,16 @@ static bool op_case_g_g(s7_scheme *sc) if (is_simple(sc->value)) { for (x = sc->code; is_pair(x); x = cdr(x)) - { - s7_pointer y = caar(x); - if (!is_pair(y)) - goto ELSE_CASE; - do { - if (car(y) == sc->value) - goto ELSE_CASE; - y = cdr(y); - } while (is_pair(y)); - } + { + s7_pointer y = caar(x); + if (!is_pair(y)) + goto ELSE_CASE; + do { + if (car(y) == sc->value) + goto ELSE_CASE; + y = cdr(y); + } while (is_pair(y)); + } sc->value = sc->unspecified; pop_stack(sc); return(true); @@ -76202,10 +76202,10 @@ static bool op_case_g_g(s7_scheme *sc) { s7_pointer y = caar(x); if (!is_pair(y)) - goto ELSE_CASE; + goto ELSE_CASE; for (; is_pair(y); y = cdr(y)) - if (s7_is_eqv(sc, car(y), sc->value)) - goto ELSE_CASE; + if (s7_is_eqv(sc, car(y), sc->value)) + goto ELSE_CASE; } sc->value = sc->unspecified; /* this was sc->nil but the spec says case value is unspecified if no clauses match */ pop_stack(sc); @@ -76238,10 +76238,10 @@ static void op_case_e_s(s7_scheme *sc) if (is_simple(selector)) for (s7_pointer x = cddr(sc->code); is_pair(x); x = cdr(x)) if (opt2_any(x) == selector) - { - sc->code = opt1_clause(x); - return; - } + { + sc->code = opt1_clause(x); + return; + } sc->code = opt3_any(cdr(sc->code)); } @@ -76251,7 +76251,7 @@ static s7_pointer fx_case_a_e_s_a(s7_scheme *sc, s7_pointer code) if (is_simple(selector)) for (s7_pointer x = cddr(code); is_pair(x); x = cdr(x)) if (opt2_any(x) == selector) - return(fx_call(sc, cdar(x))); + return(fx_call(sc, cdar(x))); return(fx_call(sc, opt3_any(cdr(code)))); } @@ -76261,8 +76261,8 @@ static void op_case_g_s(s7_scheme *sc) for (s7_pointer x = cddr(sc->code); is_pair(x); x = cdr(x)) if (s7_is_eqv(sc, opt2_any(x), selector)) { - sc->code = opt1_clause(x); - return; + sc->code = opt1_clause(x); + return; } sc->code = opt3_any(cdr(sc->code)); } @@ -76290,8 +76290,8 @@ static void check_let_a_body(s7_scheme *sc, s7_pointer form) else if (is_pair(cadr(code))) { - pair_set_syntax_op(form, OP_LET_A_P_OLD); - if (is_fx_treeable(cdaar(code))) fx_tree(sc, cdr(code), caaar(code), NULL, NULL, false); + pair_set_syntax_op(form, OP_LET_A_P_OLD); + if (is_fx_treeable(cdaar(code))) fx_tree(sc, cdr(code), caaar(code), NULL, NULL, false); } } @@ -76305,50 +76305,50 @@ static void check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer start) set_opt2_sym(cdr(code), car(binding)); /* these don't collide -- cdr(code) and code */ set_opt2_pair(code, cadr(binding)); if (is_optimized(cadr(binding))) - { - if ((optimize_op(cadr(binding)) == HOP_SAFE_C_SS) && - (fn_proc(cadr(binding)) == g_assq)) - { - set_opt2_sym(code, cadadr(binding)); - pair_set_syntax_op(form, OP_LET_opaSSq_OLD); - set_opt3_sym(cdr(code), caddadr(binding)); - set_opt1_sym(code, car(binding)); - } - else - if (is_fxable(sc, cadr(binding))) - { - set_opt2_pair(code, binding); - pair_set_syntax_op(form, OP_LET_A_OLD); - fx_annotate_arg(sc, cdr(binding), sc->curlet); - if (is_null(cddr(code))) - check_let_a_body(sc, form); - else - { - s7_pointer p; - for (p = cdr(code); is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; - if (is_null(p)) - { - pair_set_syntax_op(form, OP_LET_A_NA_OLD); - fx_annotate_args(sc, cdr(code), set_plist_1(sc, car(binding))); - fx_tree(sc, cdr(code), car(binding), NULL, NULL, false); - return; - } - if (is_fx_treeable(cdr(code))) fx_tree(sc, cdr(code), car(binding), NULL, NULL, false); - }}}} + { + if ((optimize_op(cadr(binding)) == HOP_SAFE_C_SS) && + (fn_proc(cadr(binding)) == g_assq)) + { + set_opt2_sym(code, cadadr(binding)); + pair_set_syntax_op(form, OP_LET_opaSSq_OLD); + set_opt3_sym(cdr(code), caddadr(binding)); + set_opt1_sym(code, car(binding)); + } + else + if (is_fxable(sc, cadr(binding))) + { + set_opt2_pair(code, binding); + pair_set_syntax_op(form, OP_LET_A_OLD); + fx_annotate_arg(sc, cdr(binding), sc->curlet); + if (is_null(cddr(code))) + check_let_a_body(sc, form); + else + { + s7_pointer p; + for (p = cdr(code); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + break; + if (is_null(p)) + { + pair_set_syntax_op(form, OP_LET_A_NA_OLD); + fx_annotate_args(sc, cdr(code), set_plist_1(sc, car(binding))); + fx_tree(sc, cdr(code), car(binding), NULL, NULL, false); + return; + } + if (is_fx_treeable(cdr(code))) fx_tree(sc, cdr(code), car(binding), NULL, NULL, false); + }}}} else { set_opt2_pair(code, binding); pair_set_syntax_op(form, OP_LET_A_OLD); fx_annotate_arg(sc, cdr(binding), sc->curlet); if (is_null(cddr(code))) - check_let_a_body(sc, form); + check_let_a_body(sc, form); else - { - fx_annotate_args(sc, cdr(code), set_plist_1(sc, caaar(code))); /* no effect if not syntactic -- how to fix? */ - if (is_fx_treeable(cdr(code))) fx_tree(sc, cdr(code), car(binding), NULL, NULL, false); - }} + { + fx_annotate_args(sc, cdr(code), set_plist_1(sc, caaar(code))); /* no effect if not syntactic -- how to fix? */ + if (is_fx_treeable(cdr(code))) fx_tree(sc, cdr(code), car(binding), NULL, NULL, false); + }} if ((optimize_op(form) == OP_LET_A_OLD) && (is_pair(cddr(code))) && (is_null(cdddr(code)))) pair_set_syntax_op(form, OP_LET_A_OLD_2); @@ -76372,18 +76372,18 @@ static s7_pointer check_named_let(s7_scheme *sc, int32_t vars) sc->args = T_Pair(safe_list_if_possible(sc, vars)); for (s7_pointer ex = cadr(code), exp = sc->args; is_pair(ex); ex = cdr(ex), exp = cdr(exp)) - { - s7_pointer val = cdar(ex); - s7_function fx = fx_choose(sc, val, sc->curlet, let_symbol_is_safe); - if (fx) set_fx_direct(val, fx); else fx_ok = false; - set_car(exp, caar(ex)); - } + { + s7_pointer val = cdar(ex); + s7_function fx = fx_choose(sc, val, sc->curlet, let_symbol_is_safe); + if (fx) set_fx_direct(val, fx); else fx_ok = false; + set_car(exp, caar(ex)); + } if (fx_ok) - { - set_opt1_pair(code, caadr(code)); - if (vars == 2) set_opt3_pair(code, cadadr(code)); - pair_set_syntax_op(sc->code, (vars == 1) ? OP_NAMED_LET_A : ((vars == 2) ? OP_NAMED_LET_AA : OP_NAMED_LET_NA)); - } + { + set_opt1_pair(code, caadr(code)); + if (vars == 2) set_opt3_pair(code, cadadr(code)); + pair_set_syntax_op(sc->code, (vars == 1) ? OP_NAMED_LET_A : ((vars == 2) ? OP_NAMED_LET_AA : OP_NAMED_LET_NA)); + } optimize_lambda(sc, true, car(code), sc->args, cddr(code)); /* car(code) is the name */ if (!in_heap(sc->args)) clear_list_in_use(sc->args); sc->args = sc->nil; @@ -76400,7 +76400,7 @@ static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ if (!is_pair(code)) /* (let . 1) */ { if (is_null(code)) /* (let) */ - syntax_error_nr(sc, "let has no variables or body: ~A", 32, form); + syntax_error_nr(sc, "let has no variables or body: ~A", 32, form); syntax_error_nr(sc, "let form is an improper list? ~A", 32, form); } @@ -76415,15 +76415,15 @@ static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ if (named_let) { if (!is_list(cadr(code))) /* (let hi #t) */ - syntax_error_nr(sc, "let variable list is messed up: ~A", 34, form); + syntax_error_nr(sc, "let variable list is messed up: ~A", 34, form); if (!is_pair(cddr(code))) /* (let hi () . =>) or (let hi () ) */ - { - if (is_null(cddr(code))) - syntax_error_nr(sc, "named let has no body: ~A", 25 , form); - syntax_error_nr(sc, "named let stray dot? ~A", 23, form); - } + { + if (is_null(cddr(code))) + syntax_error_nr(sc, "named let has no body: ~A", 25 , form); + syntax_error_nr(sc, "named let stray dot? ~A", 23, form); + } if (is_constant_symbol(sc, car(code))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_symbol, form)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_symbol, form)); set_local(car(code)); start = cadr(code); } @@ -76435,41 +76435,41 @@ static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ s7_pointer y, carx = car(x); if ((!is_pair(carx)) || (is_null(cdr(carx)))) /* (let ((x)) ...) or (let ((x 1) . (y 2)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let variable declaration, but no value?: ~A in ~A", 49), - x, object_to_string_truncated(sc, form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let variable declaration, but no value?: ~A in ~A", 49), + x, object_to_string_truncated(sc, form))); if (!(is_pair(cdr(carx)))) /* (let ((x . 1))...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let variable declaration, ~A, is not a proper list in ~A", 56), - x, object_to_string_truncated(sc, form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let variable declaration, ~A, is not a proper list in ~A", 56), + x, object_to_string_truncated(sc, form))); if (is_not_null(cddr(carx))) /* (let ((x 1 2 3)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let variable declaration, ~A, has more than one value in ~A", 59), - x, object_to_string_truncated(sc, form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let variable declaration, ~A, has more than one value in ~A", 59), + x, object_to_string_truncated(sc, form))); y = car(carx); if (!(is_symbol(y))) - { - if (is_c_function(y)) /* (let ((#_abs 3)) ...) */ - { - s7_pointer sym = c_function_name_to_symbol(sc, y); - if (is_slot(initial_slot(sym))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_2(sc, wrap_string(sc, "variable name #_~S in let is a function, not a symbol", 53), y)); - } - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "bad variable name ~W in let (it is ~A, not a symbol) in ~A", 58), - y, object_type_name(sc, y), - object_to_string_truncated(sc, form))); - } + { + if (is_c_function(y)) /* (let ((#_abs 3)) ...) */ + { + s7_pointer sym = c_function_name_to_symbol(sc, y); + if (is_slot(initial_slot(sym))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_2(sc, wrap_string(sc, "variable name #_~S in let is a function, not a symbol", 53), y)); + } + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "bad variable name ~W in let (it is ~A, not a symbol) in ~A", 58), + y, object_type_name(sc, y), + object_to_string_truncated(sc, form))); + } if (is_constant_symbol(sc, y)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_symbol, x)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_symbol, x)); /* check for name collisions -- not sure this is required by Scheme */ if (symbol_is_in_list(sc, y)) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "duplicate identifier in let: ~S in ~S", 37), y, form)); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "duplicate identifier in let: ~S in ~S", 37), y, form)); add_symbol_to_list(sc, y); set_local(y); } @@ -76490,39 +76490,39 @@ static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ { pair_set_syntax_op(form, OP_LET_UNCHECKED); if (vars == 1) - check_let_one_var(sc, form, start); + check_let_one_var(sc, form, start); else - { - /* this used to check that vars < gc_trigger_size, but I can't see why */ - opcode_t opt = OP_UNOPT; - for (s7_pointer p = start; is_pair(p); p = cdr(p)) - { - x = car(p); - if (is_fxable(sc, cadr(x))) - { - set_fx_direct(cdr(x), fx_choose(sc, cdr(x), sc->curlet, let_symbol_is_safe)); - if (opt == OP_UNOPT) - opt = OP_LET_NA_OLD; - } - else opt = OP_LET_UNCHECKED; - } - pair_set_syntax_op(form, opt); - if ((opt == OP_LET_NA_OLD) && - (is_null(cddr(code)))) /* 1 form in body */ - { - if (vars == 2) - { - pair_set_syntax_op(form, OP_LET_2A_OLD); - set_opt1_pair(code, caar(code)); - set_opt2_pair(code, cadar(code)); - } - else - if (vars == 3) - { - pair_set_syntax_op(form, OP_LET_3A_OLD); - set_opt1_pair(code, cadar(code)); - set_opt2_pair(code, caddar(code)); - }}}} + { + /* this used to check that vars < gc_trigger_size, but I can't see why */ + opcode_t opt = OP_UNOPT; + for (s7_pointer p = start; is_pair(p); p = cdr(p)) + { + x = car(p); + if (is_fxable(sc, cadr(x))) + { + set_fx_direct(cdr(x), fx_choose(sc, cdr(x), sc->curlet, let_symbol_is_safe)); + if (opt == OP_UNOPT) + opt = OP_LET_NA_OLD; + } + else opt = OP_LET_UNCHECKED; + } + pair_set_syntax_op(form, opt); + if ((opt == OP_LET_NA_OLD) && + (is_null(cddr(code)))) /* 1 form in body */ + { + if (vars == 2) + { + pair_set_syntax_op(form, OP_LET_2A_OLD); + set_opt1_pair(code, caar(code)); + set_opt2_pair(code, cadar(code)); + } + else + if (vars == 3) + { + pair_set_syntax_op(form, OP_LET_3A_OLD); + set_opt1_pair(code, cadar(code)); + set_opt2_pair(code, caddar(code)); + }}}} /* if safe_c or safe_closure as car(body), null cdr(body), see if only vars as args * symbol_list is intact?? @@ -76530,13 +76530,13 @@ static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ if (optimize_op(form) >= OP_LET_NA_OLD) { if ((!in_heap(form)) && - (body_is_safe(sc, sc->unused, cdr(code), true) >= SAFE_BODY)) /* recur_body is apparently never hit */ - set_opt3_let(code, make_semipermanent_let(sc, car(code))); + (body_is_safe(sc, sc->unused, cdr(code), true) >= SAFE_BODY)) /* recur_body is apparently never hit */ + set_opt3_let(code, make_semipermanent_let(sc, car(code))); else - { - set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ - set_opt3_let(code, sc->rootlet); - }} + { + set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ + set_opt3_let(code, sc->rootlet); + }} /* fx_tree inits */ if ((is_pair(code)) && @@ -76547,21 +76547,21 @@ static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ s7_pointer s1 = let_slots(sc->curlet), s2 = next_slot(s1), s3 = NULL; bool more_vars = false; if (tis_slot(s2)) - { - if (tis_slot(next_slot(s2))) - { - s3 = next_slot(s2); - more_vars = tis_slot(next_slot(s3)); - s3 = slot_symbol(s3); - } - s2 = slot_symbol(s2); - } + { + if (tis_slot(next_slot(s2))) + { + s3 = next_slot(s2); + more_vars = tis_slot(next_slot(s3)); + s3 = slot_symbol(s3); + } + s2 = slot_symbol(s2); + } s1 = slot_symbol(s1); for (s7_pointer p = car(code); is_pair(p); p = cdr(p)) /* var list */ - { - s7_pointer init = cdar(p); - fx_tree(sc, init, s1, s2, s3, more_vars); - }} + { + s7_pointer init = cdar(p); + fx_tree(sc, init, s1, s2, s3, more_vars); + }} return(code); } @@ -76614,31 +76614,31 @@ static bool op_let1(s7_scheme *sc) { sc->args = cons(sc, sc->value, sc->args); if (is_pair(sc->code)) - { - x = cdar(sc->code); - if (has_fx(x)) - { + { + x = cdar(sc->code); + if (has_fx(x)) + { #if S7_DEBUGGING - s7_pointer old_args = sc->args; + s7_pointer old_args = sc->args; #endif - sc->value = fx_call(sc, x); + sc->value = fx_call(sc, x); #if S7_DEBUGGING - if (sc->args != old_args) - { - fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(old_args), display(sc->args)); - gdb_break(); - } -#endif - } - else - { - check_stack_size(sc); - push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); - sc->code = car(x); - return(false); - } - sc->code = cdr(sc->code); - } + if (sc->args != old_args) + { + fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(old_args), display(sc->args)); + gdb_break(); + } +#endif + } + else + { + check_stack_size(sc); + push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); + sc->code = car(x); + return(false); + } + sc->code = cdr(sc->code); + } else break; } x = proper_list_reverse_in_place(sc, sc->args); @@ -76664,15 +76664,15 @@ static bool op_let1(s7_scheme *sc) y = args; for (x = cdr(x); is_not_null(y); x = cdr(x)) - { - sym = caar(x); - args = cdr(args); - reuse_as_slot(y, sym, unchecked_car(y)); - symbol_set_local_slot(sym, id, y); - slot_set_next(sp, y); - sp = y; - y = args; - } + { + sym = caar(x); + args = cdr(args); + reuse_as_slot(y, sym, unchecked_car(y)); + symbol_set_local_slot(sym, id, y); + slot_set_next(sp, y); + sp = y; + y = args; + } slot_set_next(sp, slot_end); } sc->code = T_Pair(cdr(sc->code)); @@ -76695,19 +76695,19 @@ static bool op_let(s7_scheme *sc) sc->code = sc->value; set_curlet(sc, make_let(sc, sc->curlet)); if (named_let) /* see also below -- there are 3 cases */ - { - s7_pointer body = cddr(sc->code); - set_opt2_int(cdr(sc->code), 0); - sc->x = make_closure_unchecked(sc, sc->nil, body, T_CLOSURE, 0); - /* args = () in new closure, see NAMED_LET_NO_VARS above */ - /* if this is a safe closure, we can build its let in advance and name it (a thunk in this case) */ - set_funclet(closure_let(sc->x)); - funclet_set_function(closure_let(sc->x), car(sc->code)); - add_slot_checked(sc, sc->curlet, car(sc->code), sc->x); - set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */ - sc->code = T_Pair(body); - sc->x = sc->unused; - } + { + s7_pointer body = cddr(sc->code); + set_opt2_int(cdr(sc->code), 0); + sc->x = make_closure_unchecked(sc, sc->nil, body, T_CLOSURE, 0); + /* args = () in new closure, see NAMED_LET_NO_VARS above */ + /* if this is a safe closure, we can build its let in advance and name it (a thunk in this case) */ + set_funclet(closure_let(sc->x)); + funclet_set_function(closure_let(sc->x), car(sc->code)); + add_slot_checked(sc, sc->curlet, car(sc->code), sc->x); + set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */ + sc->code = T_Pair(body); + sc->x = sc->unused; + } else sc->code = T_Pair(cdr(sc->code)); return(true); } @@ -76951,10 +76951,10 @@ static Inline void inline_op_let_na_new(s7_scheme *sc) /* called once in eval, c s7_pointer arg = cdar(p); sc->value = fx_call(sc, arg); if (!sp) - { - add_slot(sc, let, caar(p), sc->value); - sp = let_slots(let); - } + { + add_slot(sc, let, caar(p), sc->value); + sp = let_slots(let); + } else sp = inline_add_slot_at_end(sc, let_id(let), sp, caar(p), sc->value); } sc->let_number++; @@ -77038,15 +77038,15 @@ static bool check_let_star(s7_scheme *sc) if (named_let) { if (!is_list(cadr(code))) /* (let* hi #t) */ - syntax_error_nr(sc, "let* variable list is messed up: ~A", 35, form); + syntax_error_nr(sc, "let* variable list is messed up: ~A", 35, form); if (!is_pair(cddr(code))) /* (let* hi () . =>) or (let* hi () ) */ - { - if (is_null(cddr(code))) - syntax_error_nr(sc, "named let* has no body: ~A", 26, form); - syntax_error_nr(sc, "named let* stray dot? ~A", 24, form); - } + { + if (is_null(cddr(code))) + syntax_error_nr(sc, "named let* has no body: ~A", 26, form); + syntax_error_nr(sc, "named let* stray dot? ~A", 24, form); + } if (is_constant_symbol(sc, car(code))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_star_symbol, form)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_star_symbol, form)); set_local(car(code)); } else @@ -77058,39 +77058,39 @@ static bool check_let_star(s7_scheme *sc) { s7_pointer var, var_and_val = car(vars); if (!is_pair(var_and_val)) /* (let* (3) ... */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable list, ~A, is messed up in ~A", 42), - var_and_val, object_to_string_truncated(sc, form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let* variable list, ~A, is messed up in ~A", 42), + var_and_val, object_to_string_truncated(sc, form))); if (!(is_pair(cdr(var_and_val)))) /* (let* ((x . 1))...) */ - { - if (is_null(cdr(var_and_val))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable declaration, but no value?: ~A in ~A", 50), - var_and_val, object_to_string_truncated(sc, form))); - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable declaration is not a proper list: ~A in ~A", 56), - var_and_val, object_to_string_truncated(sc, form))); - } + { + if (is_null(cdr(var_and_val))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let* variable declaration, but no value?: ~A in ~A", 50), + var_and_val, object_to_string_truncated(sc, form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let* variable declaration is not a proper list: ~A in ~A", 56), + var_and_val, object_to_string_truncated(sc, form))); + } if (!is_null(cddr(var_and_val))) /* (let* ((c 1 2)) ...) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable declaration has more than one value?: ~A in ~A", 60), - var_and_val, object_to_string_truncated(sc, form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let* variable declaration has more than one value?: ~A in ~A", 60), + var_and_val, object_to_string_truncated(sc, form))); var = car(var_and_val); if (!(is_symbol(var))) /* (let* ((3 1)) 1) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "bad variable name ~W in let* (it is ~A, not a symbol) in ~A", 59), - var, object_type_name(sc, var), - object_to_string_truncated(sc, form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "bad variable name ~W in let* (it is ~A, not a symbol) in ~A", 59), + var, object_type_name(sc, var), + object_to_string_truncated(sc, form))); if (is_constant_symbol(sc, var)) /* (let* ((pi 3)) ...) */ - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_star_symbol, var_and_val)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_star_symbol, var_and_val)); if ((named_let) && (symbol_is_in_arg_list(var, cdr(vars)))) /* (let* loop ((a 1) (a 2)) ...) -- added 2-Dec-19 */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "named let* parameter, ~A, is used twice in the parameter list in ~A", 67), - var, object_to_string_truncated(sc, form))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "named let* parameter, ~A, is used twice in the parameter list in ~A", 67), + var, object_to_string_truncated(sc, form))); /* currently (let* ((a 1) (a (+ a 1))) a) is 2, not an error */ if (symbol_is_in_list(sc, var)) shadowing = true; @@ -77099,8 +77099,8 @@ static bool check_let_star(s7_scheme *sc) } if (!is_null(vars)) error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "let* variable list is not a proper list: ~A in ~A", 49), - vars, object_to_string_truncated(sc, form))); + set_elist_3(sc, wrap_string(sc, "let* variable list is not a proper list: ~A in ~A", 49), + vars, object_to_string_truncated(sc, form))); if (!s7_is_proper_list(sc, cdr(code))) syntax_error_nr(sc, "stray dot in let* body: ~S", 26, cdr(code)); @@ -77110,31 +77110,31 @@ static bool check_let_star(s7_scheme *sc) else for (vars = (named_let) ? cadr(code) : car(code); is_pair(vars); vars = cdr(vars)) if (is_fxable(sc, cadar(vars))) - set_fx_direct(cdar(vars), fx_choose(sc, cdar(vars), sc->curlet, let_star_symbol_is_safe)); + set_fx_direct(cdar(vars), fx_choose(sc, cdar(vars), sc->curlet, let_star_symbol_is_safe)); else fxable = false; if (named_let) { if (is_null(cadr(code))) - { - pair_set_syntax_op(form, OP_NAMED_LET_NO_VARS); - set_opt1_pair(form, cdddr(form)); - } + { + pair_set_syntax_op(form, OP_NAMED_LET_NO_VARS); + set_opt1_pair(form, cdddr(form)); + } else - { - pair_set_syntax_op(form, OP_NAMED_LET_STAR); - set_opt2_con(code, cadr(caadr(code))); - } + { + pair_set_syntax_op(form, OP_NAMED_LET_STAR); + set_opt2_con(code, cadr(caadr(code))); + } sc->value = cdr(code); if (is_null(car(sc->value))) /* (let* name () ... */ - { - s7_pointer let_sym = car(code); - set_curlet(sc, make_let(sc, sc->curlet)); - sc->code = T_Pair(cdr(sc->value)); - add_slot_checked(sc, sc->curlet, let_sym, make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE_STAR, 0)); - set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */ - return(false); - } + { + s7_pointer let_sym = car(code); + set_curlet(sc, make_let(sc, sc->curlet)); + sc->code = T_Pair(cdr(sc->value)); + add_slot_checked(sc, sc->curlet, let_sym, make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE_STAR, 0)); + set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */ + return(false); + } set_curlet(sc, make_let(sc, sc->curlet)); push_stack(sc, OP_LET_STAR1, code, cadr(code)); sc->code = cadr(caadr(code)); /* first var val */ @@ -77150,30 +77150,30 @@ static bool check_let_star(s7_scheme *sc) else if (is_null(cdar(code))) { - check_let_one_var(sc, form, car(code)); /* (let* ((var...))...) -> (let ((var...))...) */ - if (optimize_op(form) >= OP_LET_NA_OLD) - { - if ((!in_heap(form)) && - (body_is_safe(sc, sc->unused, cdr(code), true) >= SAFE_BODY)) - set_opt3_let(code, make_semipermanent_let(sc, car(code))); - else - { - set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ - set_opt3_let(code, sc->rootlet); - }}} + check_let_one_var(sc, form, car(code)); /* (let* ((var...))...) -> (let ((var...))...) */ + if (optimize_op(form) >= OP_LET_NA_OLD) + { + if ((!in_heap(form)) && + (body_is_safe(sc, sc->unused, cdr(code), true) >= SAFE_BODY)) + set_opt3_let(code, make_semipermanent_let(sc, car(code))); + else + { + set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */ + set_opt3_let(code, sc->rootlet); + }}} else /* multiple variables */ { - if (fxable) - { - pair_set_syntax_op(form, OP_LET_STAR_NA); - if ((is_null(cddr(code))) && - (is_fxable(sc, cadr(code)))) - { - fx_annotate_arg(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_LET_STAR_NA_A); - }} - else pair_set_syntax_op(form, OP_LET_STAR2); - set_opt2_con(code, cadaar(code)); + if (fxable) + { + pair_set_syntax_op(form, OP_LET_STAR_NA); + if ((is_null(cddr(code))) && + (is_fxable(sc, cadr(code)))) + { + fx_annotate_arg(sc, cdr(code), sc->curlet); + pair_set_syntax_op(form, OP_LET_STAR_NA_A); + }} + else pair_set_syntax_op(form, OP_LET_STAR2); + set_opt2_con(code, cadaar(code)); } push_stack(sc, ((intptr_t)((shadowing) ? OP_LET_STAR_SHADOWED : OP_LET_STAR1)), code, car(code)); /* args is the let body, saved for later, code is the list of vars+initial-values */ @@ -77189,16 +77189,16 @@ static bool op_let_star_shadowed(s7_scheme *sc) set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caar(sc->code), sc->value)); sc->code = cdr(sc->code); if (is_pair(sc->code)) - { - s7_pointer x = cdar(sc->code); - if (has_fx(x)) - sc->value = fx_call(sc, x); - else - { - push_stack_direct(sc, OP_LET_STAR_SHADOWED); - sc->code = car(x); - return(true); - }} + { + s7_pointer x = cdar(sc->code); + if (has_fx(x)) + sc->value = fx_call(sc, x); + else + { + push_stack_direct(sc, OP_LET_STAR_SHADOWED); + sc->code = car(x); + return(true); + }} else break; } sc->code = cdr(sc->args); /* original sc->code set in push_stack above */ @@ -77212,32 +77212,32 @@ static inline bool op_let_star1(s7_scheme *sc) while (true) { if (let_counter == sc->capture_let_counter) - { - if (sp == NULL) - { - add_slot_checked(sc, sc->curlet, caar(sc->code), sc->value); - sp = let_slots(sc->curlet); - } - else sp = inline_add_slot_at_end(sc, let_id(sc->curlet), sp, caar(sc->code), sc->value); - } + { + if (sp == NULL) + { + add_slot_checked(sc, sc->curlet, caar(sc->code), sc->value); + sp = let_slots(sc->curlet); + } + else sp = inline_add_slot_at_end(sc, let_id(sc->curlet), sp, caar(sc->code), sc->value); + } else - { - set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caar(sc->code), sc->value)); - sp = let_slots(sc->curlet); - let_counter = sc->capture_let_counter; - } + { + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caar(sc->code), sc->value)); + sp = let_slots(sc->curlet); + let_counter = sc->capture_let_counter; + } sc->code = cdr(sc->code); if (is_pair(sc->code)) - { - s7_pointer x = cdar(sc->code); - if (has_fx(x)) - sc->value = fx_call(sc, x); - else - { - push_stack_direct(sc, OP_LET_STAR1); - sc->code = car(x); - return(true); - }} + { + s7_pointer x = cdar(sc->code); + if (has_fx(x)) + sc->value = fx_call(sc, x); + else + { + push_stack_direct(sc, OP_LET_STAR1); + sc->code = car(x); + return(true); + }} else break; } sc->code = sc->args; /* original sc->code set in push_stack above */ @@ -77247,17 +77247,17 @@ static inline bool op_let_star1(s7_scheme *sc) /* now we need to declare the new function (in the outer let) -- must delay this because init might reference same-name outer func */ /* but the let name might be shadowed by a variable: (let* x ((x 1))...) so the name's symbol_id can be incorrect */ if (symbol_id(name) > let_id(let_outlet(sc->curlet))) - { - s7_int cur_id = symbol_id(name); - s7_pointer cur_slot = local_slot(name); - symbol_set_id_unchecked(name, let_id(let_outlet(sc->curlet))); - add_slot_checked(sc, let_outlet(sc->curlet), name, - make_closure_unchecked(sc, args, body, T_CLOSURE_STAR, (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET)); - symbol_set_id_unchecked(name, cur_id); - set_local_slot(name, cur_slot); - } + { + s7_int cur_id = symbol_id(name); + s7_pointer cur_slot = local_slot(name); + symbol_set_id_unchecked(name, let_id(let_outlet(sc->curlet))); + add_slot_checked(sc, let_outlet(sc->curlet), name, + make_closure_unchecked(sc, args, body, T_CLOSURE_STAR, (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET)); + symbol_set_id_unchecked(name, cur_id); + set_local_slot(name, cur_slot); + } else add_slot_checked(sc, let_outlet(sc->curlet), name, - make_closure_unchecked(sc, args, body, T_CLOSURE_STAR, (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET)); + make_closure_unchecked(sc, args, body, T_CLOSURE_STAR, (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET)); sc->code = body; } @@ -77275,20 +77275,20 @@ static void op_let_star_na(s7_scheme *sc) { s7_pointer val = fx_call(sc, cdar(p)); /* eval in outer let */ if (let_counter == sc->capture_let_counter) - { - if (!sp) - { - add_slot_checked(sc, sc->curlet, caar(p), val); - sp = let_slots(sc->curlet); - } - else sp = inline_add_slot_at_end(sc, let_id(sc->curlet), sp, caar(p), val); - } + { + if (!sp) + { + add_slot_checked(sc, sc->curlet, caar(p), val); + sp = let_slots(sc->curlet); + } + else sp = inline_add_slot_at_end(sc, let_id(sc->curlet), sp, caar(p), val); + } else - { - set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caar(p), val)); - sp = let_slots(sc->curlet); - let_counter = sc->capture_let_counter; - }} + { + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caar(p), val)); + sp = let_slots(sc->curlet); + let_counter = sc->capture_let_counter; + }} sc->code = T_Pair(cdr(sc->code)); } @@ -77301,20 +77301,20 @@ static void op_let_star_na_a(s7_scheme *sc) { s7_pointer val = fx_call(sc, cdar(p)); if (let_counter == sc->capture_let_counter) - { - if (!sp) - { - add_slot_checked(sc, sc->curlet, caar(p), val); - sp = let_slots(sc->curlet); - } - else sp = inline_add_slot_at_end(sc, let_id(sc->curlet), sp, caar(p), val); - } + { + if (!sp) + { + add_slot_checked(sc, sc->curlet, caar(p), val); + sp = let_slots(sc->curlet); + } + else sp = inline_add_slot_at_end(sc, let_id(sc->curlet), sp, caar(p), val); + } else - { - set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caar(p), val)); - sp = let_slots(sc->curlet); - let_counter = sc->capture_let_counter; - }} + { + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caar(p), val)); + sp = let_slots(sc->curlet); + let_counter = sc->capture_let_counter; + }} sc->value = fx_call(sc, cdr(sc->code)); } @@ -77352,33 +77352,33 @@ static void check_letrec(s7_scheme *sc, bool letrec) { s7_pointer y, carx; if (!is_pair(x)) /* (letrec ((a 1) . 2) ...) */ - syntax_error_with_caller_nr(sc, "~A: improper list of variables? ~A", 34, caller, sc->code); + syntax_error_with_caller_nr(sc, "~A: improper list of variables? ~A", 34, caller, sc->code); carx = car(x); if (!is_pair(carx)) /* (letrec (1 2) #t) */ - syntax_error_with_caller_nr(sc, "~A: bad variable ~S (should be a pair (name value))", 51, caller, carx); + syntax_error_with_caller_nr(sc, "~A: bad variable ~S (should be a pair (name value))", 51, caller, carx); y = car(carx); if (!(is_symbol(y))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_5(sc, wrap_string(sc, "bad variable name ~W in ~A (it is ~A, not a symbol) in ~A", 57), - y, caller, object_type_name(sc, y), - object_to_string_truncated(sc, sc->code))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "bad variable name ~W in ~A (it is ~A, not a symbol) in ~A", 57), + y, caller, object_type_name(sc, y), + object_to_string_truncated(sc, sc->code))); if (is_constant_symbol(sc, y)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, caller, x)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, caller, x)); if (!is_pair(cdr(carx))) /* (letrec ((x . 1))...) */ - { - if (is_null(cdr(carx))) /* (letrec ((x)) x) -- perhaps this is legal? */ - syntax_error_with_caller_nr(sc, "~A: variable declaration has no value?: ~A", 42, caller, carx); - syntax_error_with_caller_nr(sc, "~A: variable declaration is not a proper list?: ~A", 50, caller, carx); - } + { + if (is_null(cdr(carx))) /* (letrec ((x)) x) -- perhaps this is legal? */ + syntax_error_with_caller_nr(sc, "~A: variable declaration has no value?: ~A", 42, caller, carx); + syntax_error_with_caller_nr(sc, "~A: variable declaration is not a proper list?: ~A", 50, caller, carx); + } if (is_not_null(cddr(carx))) /* (letrec ((x 1 2 3)) ...) */ - syntax_error_with_caller_nr(sc, "~A: variable declaration has more than one value?: ~A", 53, caller, carx); + syntax_error_with_caller_nr(sc, "~A: variable declaration has more than one value?: ~A", 53, caller, carx); /* check for name collisions -- this is needed in letrec* else which of the two legit values does our "rec" refer to, so to speak */ if (symbol_is_in_list(sc, y)) - syntax_error_with_caller_nr(sc, "~A: duplicate identifier: ~A", 28, caller, y); + syntax_error_with_caller_nr(sc, "~A: duplicate identifier: ~A", 28, caller, y); add_symbol_to_list(sc, y); set_local(y); } @@ -77400,17 +77400,17 @@ static void letrec_setup_closures(s7_scheme *sc) for (s7_pointer slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) if (is_closure(slot_value(slot))) { - s7_pointer func = slot_value(slot); - if ((!is_safe_closure(func)) || - (!is_optimized(car(closure_body(func))))) - optimize_lambda(sc, true, slot_symbol(slot), closure_args(func), closure_body(func)); - if (is_safe_closure_body(closure_body(func))) - { - set_safe_closure(func); - if (is_very_safe_closure_body(closure_body(func))) - set_very_safe_closure(func); - } - make_funclet(sc, func, slot_symbol(slot), closure_let(func)); + s7_pointer func = slot_value(slot); + if ((!is_safe_closure(func)) || + (!is_optimized(car(closure_body(func))))) + optimize_lambda(sc, true, slot_symbol(slot), closure_args(func), closure_body(func)); + if (is_safe_closure_body(closure_body(func))) + { + set_safe_closure(func); + if (is_very_safe_closure_body(closure_body(func))) + set_very_safe_closure(func); + } + make_funclet(sc, func, slot_symbol(slot), closure_let(func)); } } @@ -77442,20 +77442,20 @@ static bool op_letrec_unchecked(s7_scheme *sc) { s7_pointer slot; for (s7_pointer x = car(code); is_not_null(x); x = cdr(x)) - { - slot = add_slot_checked(sc, sc->curlet, caar(x), sc->undefined); - slot_set_pending_value(slot, sc->undefined); - slot_set_expression(slot, cdar(x)); - set_checked_slot(slot); - } + { + slot = add_slot_checked(sc, sc->curlet, caar(x), sc->undefined); + slot_set_pending_value(slot, sc->undefined); + slot_set_expression(slot, cdar(x)); + set_checked_slot(slot); + } for (slot = let_slots(sc->curlet); tis_slot(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) - slot_set_pending_value(slot, fx_call(sc, slot_expression(slot))); + slot_set_pending_value(slot, fx_call(sc, slot_expression(slot))); if (tis_slot(slot)) - { - push_stack(sc, OP_LETREC1, slot, code); - sc->code = car(slot_expression(slot)); - return(true); - } + { + push_stack(sc, OP_LETREC1, slot, code); + sc->code = car(slot_expression(slot)); + return(true); + } op_letrec2(sc); } sc->code = T_Pair(cdr(code)); @@ -77492,20 +77492,20 @@ static bool op_letrec_star_unchecked(s7_scheme *sc) { s7_pointer slot; for (s7_pointer x = car(code); is_not_null(x); x = cdr(x)) - { - slot = add_slot_checked(sc, sc->curlet, caar(x), sc->undefined); - slot_set_expression(slot, cdar(x)); - } + { + slot = add_slot_checked(sc, sc->curlet, caar(x), sc->undefined); + slot_set_expression(slot, cdar(x)); + } let_set_slots(sc->curlet, reverse_slots(let_slots(sc->curlet))); for (slot = let_slots(sc->curlet); tis_slot(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); + slot_set_value(slot, fx_call(sc, slot_expression(slot))); if (tis_slot(slot)) - { - push_stack(sc, OP_LETREC_STAR1, slot, code); - sc->code = car(slot_expression(slot)); - return(true); - }} + { + push_stack(sc, OP_LETREC_STAR1, slot, code); + sc->code = car(slot_expression(slot)); + return(true); + }} sc->code = T_Pair(cdr(code)); return(false); } @@ -77547,36 +77547,36 @@ static void check_let_temporarily(s7_scheme *sc) { s7_pointer carx, caarx; if (!is_pair(x)) /* (let-temporarily ((a 1) . 2) ...) */ - syntax_error_nr(sc, "let-temporarily: improper list of variables? ~A", 47, form); + syntax_error_nr(sc, "let-temporarily: improper list of variables? ~A", 47, form); carx = car(x); if (!is_pair(carx)) /* (let-temporarily (1 2) #t) */ - syntax_error_nr(sc, "let-temporarily: bad variable ~S (it should be a pair (name value))", 67, carx); + syntax_error_nr(sc, "let-temporarily: bad variable ~S (it should be a pair (name value))", 67, carx); caarx = car(carx); if (is_symbol(caarx)) - { - if (is_constant_symbol(sc, caarx)) /* (let-temporarily ((pi 3)) ...) */ - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_temporarily_symbol, x)); - } + { + if (is_constant_symbol(sc, caarx)) /* (let-temporarily ((pi 3)) ...) */ + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_temporarily_symbol, x)); + } else - if (!is_pair(caarx)) /* (let-temporarily ((1 2)) ...) */ - syntax_error_nr(sc, "let-temporarily: bad variable ~S (it should be a symbol or a pair)", 66, caarx); + if (!is_pair(caarx)) /* (let-temporarily ((1 2)) ...) */ + syntax_error_nr(sc, "let-temporarily: bad variable ~S (it should be a symbol or a pair)", 66, caarx); if (!is_pair(cdr(carx))) /* (let-temporarily ((x . 1))...) */ - syntax_error_nr(sc, "let-temporarily: variable declaration value is messed up: ~S", 60, carx); + syntax_error_nr(sc, "let-temporarily: variable declaration value is messed up: ~S", 60, carx); if (is_not_null(cddr(carx))) /* (let-temporarily ((x 1 2 3)) ...) */ - syntax_error_nr(sc, "let-temporarily: variable declaration has more than one value?: ~A", 66, carx); + syntax_error_nr(sc, "let-temporarily: variable declaration has more than one value?: ~A", 66, carx); if ((all_fx) && - ((!is_symbol(caarx)) || (!is_fxable(sc, cadr(carx))))) /* if all_fx, each var is (symbol fxable-expr) */ - all_fx = false; + ((!is_symbol(caarx)) || (!is_fxable(sc, cadr(carx))))) /* if all_fx, each var is (symbol fxable-expr) */ + all_fx = false; if ((all_s7) && - ((!is_pair(caarx)) || (car(caarx) != sc->s7_starlet_symbol) || - (!is_quoted_symbol(cadr(caarx))) || (is_keyword(cadr(cadr(caarx)))) || - (!is_fxable(sc, cadr(carx))))) - all_s7 = false; + ((!is_pair(caarx)) || (car(caarx) != sc->s7_starlet_symbol) || + (!is_quoted_symbol(cadr(caarx))) || (is_keyword(cadr(cadr(caarx)))) || + (!is_fxable(sc, cadr(carx))))) + all_s7 = false; } if (!s7_is_proper_list(sc, cdr(code))) syntax_error_nr(sc, "stray dot in let-temporarily body: ~S", 37, cdr(code)); @@ -77585,26 +77585,26 @@ static void check_let_temporarily(s7_scheme *sc) { pair_set_syntax_op(form, (all_fx) ? ((is_null(cdar(code))) ? OP_LET_TEMP_A : OP_LET_TEMP_NA) : OP_LET_TEMP_S7); for (x = car(code); is_pair(x); x = cdr(x)) - fx_annotate_arg(sc, cdar(x), sc->curlet); + fx_annotate_arg(sc, cdar(x), sc->curlet); if ((optimize_op(form) == OP_LET_TEMP_A) && (is_pair(cdr(code))) && (is_null(cddr(code))) && (is_fxable(sc, cadr(code)))) - { - fx_annotate_arg(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_LET_TEMP_A_A); - } + { + fx_annotate_arg(sc, cdr(code), sc->curlet); + pair_set_syntax_op(form, OP_LET_TEMP_A_A); + } else - if (all_s7) /* not OP_LET_TEMP_NA */ - { - s7_pointer var = caar(code); - if ((is_fxable(sc, cadr(var))) && /* code: ((((*s7* 'openlets) fxable-expr)) ...) */ - (is_null(cdar(code)))) - { - if ((is_quoted_symbol(cadar(var))) && - (s7_starlet_symbol(cadr(cadar(var))) == SL_OPENLETS)) /* (cadr(cadar(var)) == make_symbol_with_strlen(sc, "openlets"))) */ - { - pair_set_syntax_op(form, OP_LET_TEMP_S7_DIRECT); - set_opt1_pair(form, cdr(var)); - }}} + if (all_s7) /* not OP_LET_TEMP_NA */ + { + s7_pointer var = caar(code); + if ((is_fxable(sc, cadr(var))) && /* code: ((((*s7* 'openlets) fxable-expr)) ...) */ + (is_null(cdar(code)))) + { + if ((is_quoted_symbol(cadar(var))) && + (s7_starlet_symbol(cadr(cadar(var))) == SL_OPENLETS)) /* (cadr(cadar(var)) == make_symbol_with_strlen(sc, "openlets"))) */ + { + pair_set_syntax_op(form, OP_LET_TEMP_S7_DIRECT); + set_opt1_pair(form, cdr(var)); + }}} if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) {fx_curlet_tree(sc, code); fx_curlet_tree_in(sc, code);} } @@ -77612,20 +77612,20 @@ static void check_let_temporarily(s7_scheme *sc) { pair_set_syntax_op(form, OP_LET_TEMP_UNCHECKED); if ((is_pair(car(code))) && (is_null(cdar(code))) && (is_pair(caar(code)))) - { - s7_pointer var = caar(code); - s7_pointer val = cadr(var); - var = car(var); - if ((is_pair(var)) && (car(var) == sc->setter_symbol) && (is_pair(cdr(var))) && (is_pair(cddr(var))) && (val == sc->F)) - { - /* (let-temporarily (((setter (slot-symbol cp) (slot-env cp)) #f)) ...) reactive.scm */ - optimize_expression(sc, cadr(var), 0, sc->curlet, false); - optimize_expression(sc, caddr(var), 0, sc->curlet, false); - if ((is_fxable(sc, cadr(var))) && (is_fxable(sc, caddr(var)))) - { - fx_annotate_args(sc, cdr(var), sc->curlet); - pair_set_syntax_op(form, OP_LET_TEMP_SETTER); - }}}} + { + s7_pointer var = caar(code); + s7_pointer val = cadr(var); + var = car(var); + if ((is_pair(var)) && (car(var) == sc->setter_symbol) && (is_pair(cdr(var))) && (is_pair(cddr(var))) && (val == sc->F)) + { + /* (let-temporarily (((setter (slot-symbol cp) (slot-env cp)) #f)) ...) reactive.scm */ + optimize_expression(sc, cadr(var), 0, sc->curlet, false); + optimize_expression(sc, caddr(var), 0, sc->curlet, false); + if ((is_fxable(sc, cadr(var))) && (is_fxable(sc, caddr(var)))) + { + fx_annotate_args(sc, cdr(var), sc->curlet); + pair_set_syntax_op(form, OP_LET_TEMP_SETTER); + }}}} } static void op_let_temp_unchecked(s7_scheme *sc) @@ -77642,7 +77642,7 @@ static void op_let_temp_init1_1(s7_scheme *sc) { clear_symbol_from_symbol(sc->value); if (is_immutable_symbol(sc->value)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_temporarily_symbol, sc->value)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_temporarily_symbol, sc->value)); sc->value = s7_symbol_value(sc, sc->value); } set_caddr(sc->args, cons(sc, sc->value, caddr(sc->args))); @@ -77661,25 +77661,25 @@ static bool op_let_temp_init1(s7_scheme *sc) set_car(binding, cons_unchecked(sc, new_value, car(binding))); set_car(sc->args, cdar(sc->args)); if (is_symbol(settee)) /* get initial values */ - set_caddr(sc->args, cons_unchecked(sc, lookup_checked(sc, settee), caddr(sc->args))); + set_caddr(sc->args, cons_unchecked(sc, lookup_checked(sc, settee), caddr(sc->args))); else - { - if (is_pair(settee)) - { - push_stack_direct(sc, OP_LET_TEMP_INIT1); - sc->code = settee; - return(true); - } - set_caddr(sc->args, cons_unchecked(sc, new_value, caddr(sc->args))); - }} + { + if (is_pair(settee)) + { + push_stack_direct(sc, OP_LET_TEMP_INIT1); + sc->code = settee; + return(true); + } + set_caddr(sc->args, cons_unchecked(sc, new_value, caddr(sc->args))); + }} set_car(sc->args, cadr(sc->args)); return(false); } typedef enum {goto_start, goto_begin, fall_through, goto_do_end_clauses, goto_safe_do_end_clauses, - goto_eval, goto_apply_lambda, goto_do_end, goto_top_no_pop, goto_apply, - goto_eval_args, goto_eval_args_top, goto_do_unchecked, goto_pop_read_list, - goto_read_tok, goto_feed_to, goto_set_unchecked, goto_unopt} goto_t; + goto_eval, goto_apply_lambda, goto_do_end, goto_top_no_pop, goto_apply, + goto_eval_args, goto_eval_args_top, goto_do_unchecked, goto_pop_read_list, + goto_read_tok, goto_feed_to, goto_set_unchecked, goto_unopt} goto_t; static goto_t op_let_temp_init2(s7_scheme *sc) { @@ -77691,25 +77691,25 @@ static goto_t op_let_temp_init2(s7_scheme *sc) set_car(p, cdar(p)); set_car(sc->args, cdar(sc->args)); if ((!is_symbol(settee)) || (is_pair(new_value))) - { - if (is_symbol(settee)) - { - push_stack_direct(sc, OP_LET_TEMP_INIT2); /* (let-temporarily (((*s7* 'print-length) 32)) ...) */ - push_stack_no_args(sc, OP_SET_FROM_LET_TEMP, settee); - sc->code = new_value; - return(goto_eval); - } - sc->code = set_plist_3(sc, sc->set_symbol, settee, new_value); - push_stack_direct(sc, OP_LET_TEMP_INIT2); - return(goto_set_unchecked); - } + { + if (is_symbol(settee)) + { + push_stack_direct(sc, OP_LET_TEMP_INIT2); /* (let-temporarily (((*s7* 'print-length) 32)) ...) */ + push_stack_no_args(sc, OP_SET_FROM_LET_TEMP, settee); + sc->code = new_value; + return(goto_eval); + } + sc->code = set_plist_3(sc, sc->set_symbol, settee, new_value); + push_stack_direct(sc, OP_LET_TEMP_INIT2); + return(goto_set_unchecked); + } slot = s7_slot(sc, settee); if (!is_slot(slot)) - unbound_variable_error_nr(sc, settee); + unbound_variable_error_nr(sc, settee); if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); if (is_symbol(new_value)) - new_value = lookup_checked(sc, new_value); + new_value = lookup_checked(sc, new_value); slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, new_value) : new_value); } set_car(sc->args, cadr(sc->args)); @@ -77735,31 +77735,31 @@ static bool op_let_temp_done1(s7_scheme *sc) set_car(sc->args, cdar(sc->args)); if ((is_pair(settee)) && (car(settee) == sc->s7_starlet_symbol) && /* (let-temporarily (((*s7* (symbol "print-length")) 43))...) */ - ((is_symbol_and_keyword(cadr(settee))) || - (is_quoted_symbol(cadr(settee))))) - { - s7_pointer sym = cadr(settee); - if (is_pair(sym)) sym = cadr(sym); - s7_starlet_set_1(sc, T_Sym(sym), sc->value); - } + ((is_symbol_and_keyword(cadr(settee))) || + (is_quoted_symbol(cadr(settee))))) + { + s7_pointer sym = cadr(settee); + if (is_pair(sym)) sym = cadr(sym); + s7_starlet_set_1(sc, T_Sym(sym), sc->value); + } else - { - s7_pointer slot; - if (!is_symbol(settee)) - { - push_stack_direct(sc, OP_LET_TEMP_DONE1); /* save args and (pending) body value==sc->code */ - if ((is_pair(sc->value)) || (is_symbol(sc->value))) - sc->code = set_plist_3(sc, sc->set_symbol, settee, set_plist_2(sc, sc->quote_function, sc->value)); - else sc->code = set_plist_3(sc, sc->set_symbol, settee, sc->value); - return(false); /* goto set_unchecked */ - } - slot = s7_slot(sc, settee); - if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); - if (slot_has_setter(slot)) /* maybe setter changed in let-temp body? else setter has already checked the init value */ - slot_set_value(slot, call_setter(sc, slot, sc->value)); - else slot_set_value(slot, sc->value); - }} + { + s7_pointer slot; + if (!is_symbol(settee)) + { + push_stack_direct(sc, OP_LET_TEMP_DONE1); /* save args and (pending) body value==sc->code */ + if ((is_pair(sc->value)) || (is_symbol(sc->value))) + sc->code = set_plist_3(sc, sc->set_symbol, settee, set_plist_2(sc, sc->quote_function, sc->value)); + else sc->code = set_plist_3(sc, sc->set_symbol, settee, sc->value); + return(false); /* goto set_unchecked */ + } + slot = s7_slot(sc, settee); + if (is_immutable_slot(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); + if (slot_has_setter(slot)) /* maybe setter changed in let-temp body? else setter has already checked the init value */ + slot_set_value(slot, call_setter(sc, slot, sc->value)); + else slot_set_value(slot, sc->value); + }} pop_stack(sc); /* not unstack */ sc->value = sc->code; if (is_multiple_value(sc->value)) @@ -77777,7 +77777,7 @@ static bool op_let_temp_s7(s7_scheme *sc) /* all entries are of the form ((*s7* { s7_pointer old_value, field = cadadr(caar(p)); /* p: (((*s7* 'expansions?) #f)) -- no keywords here (see check_let_temporarily) */ if (s7_starlet_immutable_field[s7_starlet_symbol(field)]) - immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "let-temporarily: can't set! (*s7* '~S)", 38), field)); + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "let-temporarily: can't set! (*s7* '~S)", 38), field)); old_value = s7_starlet(sc, s7_starlet_symbol(field)); push_stack(sc, OP_LET_TEMP_S7_UNWIND, old_value, field); } @@ -77851,9 +77851,9 @@ static bool op_let_temp_na(s7_scheme *sc) /* all entries are of the form (symbol s7_pointer settee = car(var); slot = s7_slot(sc, settee); if (!is_slot(slot)) - unbound_variable_error_nr(sc, settee); + unbound_variable_error_nr(sc, settee); if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot); } for (p = car(sc->code); is_pair(p); p = cdr(p), end += 4) @@ -77862,7 +77862,7 @@ static bool op_let_temp_na(s7_scheme *sc) /* all entries are of the form (symbol s7_pointer new_val = fx_call(sc, cdr(var)); slot = end[0]; if (slot_has_setter(slot)) - slot_set_value(slot, call_setter(sc, slot, new_val)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); */ + slot_set_value(slot, call_setter(sc, slot, new_val)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, settee, new_val))); */ else slot_set_value(slot, new_val); } sc->code = cdr(sc->code); @@ -77928,7 +77928,7 @@ static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code) if (!is_pair(cdr(code))) /* (quote . -1) */ { if (is_null(cdr(code))) - syntax_error_nr(sc, "quote: not enough arguments: ~A", 31, code); + syntax_error_nr(sc, "quote: not enough arguments: ~A", 31, code); syntax_error_nr(sc, "quote: stray dot?: ~A", 21, code); } if (is_not_null(cddr(code))) /* (quote . (1 2)) or (quote 1 1) */ @@ -77963,27 +77963,27 @@ static bool check_and(s7_scheme *sc, s7_pointer expr) (is_proper_list_1(sc, cdr(code)))) { if ((fx_proc(code) == fx_is_pair_s) || (fx_proc(code) == fx_is_pair_t)) - { - pair_set_syntax_op(expr, OP_AND_PAIR_P); - set_opt3_sym(expr, cadar(code)); - set_opt2_con(expr, cadr(code)); - } + { + pair_set_syntax_op(expr, OP_AND_PAIR_P); + set_opt3_sym(expr, cadar(code)); + set_opt2_con(expr, cadr(code)); + } else pair_set_syntax_op(expr, (any_nils > 0) ? OP_AND_AP : OP_AND_2A); } else { pair_set_syntax_op(expr, (any_nils > 0) ? OP_AND_P : OP_AND_N); if ((any_nils == 1) && (len > 2)) - { - if (!has_fx(code)) - pair_set_syntax_op(expr, OP_AND_SAFE_P1); - else - if (!has_fx(cdr(code))) - pair_set_syntax_op(expr, OP_AND_SAFE_P2); - else - if ((!has_fx(cddr(code))) && (len == 3)) - pair_set_syntax_op(expr, OP_AND_SAFE_P3); - }} + { + if (!has_fx(code)) + pair_set_syntax_op(expr, OP_AND_SAFE_P1); + else + if (!has_fx(cdr(code))) + pair_set_syntax_op(expr, OP_AND_SAFE_P2); + else + if ((!has_fx(cddr(code))) && (len == 3)) + pair_set_syntax_op(expr, OP_AND_SAFE_P3); + }} if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); set_current_code(sc, sc->code); return(false); @@ -78087,12 +78087,12 @@ static void fb_if_annotate(s7_scheme *sc, s7_pointer code, s7_pointer form) if (optimize_op(form) == OP_IF_A_P) { if (is_fxable(sc, cadr(code))) - { - pair_set_syntax_op(form, OP_IF_A_A); - fx_annotate_arg(sc, cdr(code), sc->curlet); - set_opt1_pair(form, cdr(code)); - fb_annotate(sc, form, code, OP_IF_B_A); - } + { + pair_set_syntax_op(form, OP_IF_A_A); + fx_annotate_arg(sc, cdr(code), sc->curlet); + set_opt1_pair(form, cdr(code)); + fb_annotate(sc, form, code, OP_IF_B_A); + } else fb_annotate(sc, form, code, OP_IF_B_P); } if (optimize_op(form) == OP_IF_A_R) @@ -78102,29 +78102,29 @@ static void fb_if_annotate(s7_scheme *sc, s7_pointer code, s7_pointer form) if (optimize_op(form) == OP_IF_A_P_P) { if (is_fxable(sc, cadr(code))) - { - set_opt1_pair(form, cdr(code)); - if (is_fxable(sc, caddr(code))) - { - pair_set_syntax_op(form, OP_IF_A_A_A); /* b_a_a never happens? */ - set_opt2_pair(form, cddr(code)); - } - else - { - pair_set_syntax_op(form, OP_IF_A_A_P); - fb_annotate(sc, form, code, OP_IF_B_A_P); - } - fx_annotate_args(sc, cdr(code), sc->curlet); - } + { + set_opt1_pair(form, cdr(code)); + if (is_fxable(sc, caddr(code))) + { + pair_set_syntax_op(form, OP_IF_A_A_A); /* b_a_a never happens? */ + set_opt2_pair(form, cddr(code)); + } + else + { + pair_set_syntax_op(form, OP_IF_A_A_P); + fb_annotate(sc, form, code, OP_IF_B_A_P); + } + fx_annotate_args(sc, cdr(code), sc->curlet); + } else - if (is_fxable(sc, caddr(code))) - { - pair_set_syntax_op(form, OP_IF_A_P_A); - fx_annotate_args(sc, cdr(code), sc->curlet); - set_opt2_pair(form, cddr(code)); - fb_annotate(sc, form, code, OP_IF_B_P_A); - } - else fb_annotate(sc, form, code, OP_IF_B_P_P); + if (is_fxable(sc, caddr(code))) + { + pair_set_syntax_op(form, OP_IF_A_P_A); + fx_annotate_args(sc, cdr(code), sc->curlet); + set_opt2_pair(form, cddr(code)); + fb_annotate(sc, form, code, OP_IF_B_P_A); + } + else fb_annotate(sc, form, code, OP_IF_B_P_P); } } @@ -78154,169 +78154,169 @@ static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool re if (is_pair(test)) { if (is_optimized(test)) - { - if (is_h_safe_c_nc(test)) /* replace these with fx_and* */ - { - pair_set_syntax_op(form, choose_if_optc(IF_A, one_branch, reversed, not_case)); - if (not_case) - { - set_fx(cdar(code), fx_choose(sc, cdar(code), sc->curlet, let_symbol_is_safe)); - if (!reversed) set_opt3_pair(form, cdadr(form)); - } - else set_fx(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - fb_if_annotate(sc, code, form); - return; - } - if ((is_h_safe_c_s(test)) && - (is_symbol(car(test)))) - { - uint8_t typ = symbol_type(car(test)); - if (typ > 0) - { - pair_set_syntax_op(form, choose_if_optc(IF_IS_TYPE_S, one_branch, reversed, not_case)); - set_opt3_byte(code, typ); - if (optimize_op(form) == OP_IF_IS_TYPE_S_P_P) - { - if (is_fxable(sc, caddr(code))) - { - set_opt2_pair(form, cddr(code)); - if (is_fxable(sc, cadr(code))) - { - set_opt1_pair(form, cdr(code)); - fx_annotate_args(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_IF_IS_TYPE_S_A_A); - } - else - { - set_opt1_any(form, cadr(code)); - pair_set_syntax_op(form, OP_IF_IS_TYPE_S_P_A); - fx_annotate_arg(sc, cddr(code), sc->curlet); - } - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - } - else - if (is_fxable(sc, cadr(code))) - { - set_opt2_any(form, caddr(code)); - set_opt1_pair(form, cdr(code)); - fx_annotate_arg(sc, cdr(code), sc->curlet); - pair_set_syntax_op(form, OP_IF_IS_TYPE_S_A_P); - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - }}} - else - { - pair_set_syntax_op(form, choose_if_optc(IF_opSq, one_branch, reversed, not_case)); - if (not_case) set_opt1_pair(code, cadar(code)); /* code is cdr(if...): ((not (f sym)) ...) */ - } - clear_has_fx(code); - set_opt2_sym(code, cadr(test)); - return; - } - if (is_fxable(sc, test)) - { - if ((optimize_op(test) == OP_OR_2A) || (optimize_op(test) == OP_AND_2A)) - { - if (optimize_op(test) == OP_OR_2A) - pair_set_syntax_op(form, choose_if_optc(IF_OR2, one_branch, reversed, not_case)); - else pair_set_syntax_op(form, choose_if_optc(IF_AND2, one_branch, reversed, not_case)); - clear_has_fx(code); - set_opt2_pair(code, cdr(test)); - set_opt3_pair(code, cddr(test)); - return; - } - if (optimize_op(test) == OP_AND_3A) - { - pair_set_syntax_op(form, choose_if_optc(IF_AND3, one_branch, reversed, not_case)); - clear_has_fx(code); - set_opt2_pair(code, cdr(test)); - set_opt3_pair(code, cddr(test)); - set_opt1_pair(code, cdddr(test)); - return; - } - - pair_set_syntax_op(form, choose_if_optc(IF_A, one_branch, reversed, not_case)); - if (not_case) - { - set_fx_direct(cdar(code), fx_choose(sc, cdar(code), sc->curlet, let_symbol_is_safe)); - if (!reversed) set_opt3_pair(form, cdadr(form)); - } - else set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - fb_if_annotate(sc, code, form); - } - else - { - pair_set_syntax_op(form, choose_if_optc(IF_P, one_branch, reversed, not_case)); - set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); - set_opt3_any(code, (not_case) ? cadar(code) : car(code)); - } - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) - fx_curlet_tree(sc, code); - } + { + if (is_h_safe_c_nc(test)) /* replace these with fx_and* */ + { + pair_set_syntax_op(form, choose_if_optc(IF_A, one_branch, reversed, not_case)); + if (not_case) + { + set_fx(cdar(code), fx_choose(sc, cdar(code), sc->curlet, let_symbol_is_safe)); + if (!reversed) set_opt3_pair(form, cdadr(form)); + } + else set_fx(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); + if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); + fb_if_annotate(sc, code, form); + return; + } + if ((is_h_safe_c_s(test)) && + (is_symbol(car(test)))) + { + uint8_t typ = symbol_type(car(test)); + if (typ > 0) + { + pair_set_syntax_op(form, choose_if_optc(IF_IS_TYPE_S, one_branch, reversed, not_case)); + set_opt3_byte(code, typ); + if (optimize_op(form) == OP_IF_IS_TYPE_S_P_P) + { + if (is_fxable(sc, caddr(code))) + { + set_opt2_pair(form, cddr(code)); + if (is_fxable(sc, cadr(code))) + { + set_opt1_pair(form, cdr(code)); + fx_annotate_args(sc, cdr(code), sc->curlet); + pair_set_syntax_op(form, OP_IF_IS_TYPE_S_A_A); + } + else + { + set_opt1_any(form, cadr(code)); + pair_set_syntax_op(form, OP_IF_IS_TYPE_S_P_A); + fx_annotate_arg(sc, cddr(code), sc->curlet); + } + if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); + } + else + if (is_fxable(sc, cadr(code))) + { + set_opt2_any(form, caddr(code)); + set_opt1_pair(form, cdr(code)); + fx_annotate_arg(sc, cdr(code), sc->curlet); + pair_set_syntax_op(form, OP_IF_IS_TYPE_S_A_P); + if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); + }}} + else + { + pair_set_syntax_op(form, choose_if_optc(IF_opSq, one_branch, reversed, not_case)); + if (not_case) set_opt1_pair(code, cadar(code)); /* code is cdr(if...): ((not (f sym)) ...) */ + } + clear_has_fx(code); + set_opt2_sym(code, cadr(test)); + return; + } + if (is_fxable(sc, test)) + { + if ((optimize_op(test) == OP_OR_2A) || (optimize_op(test) == OP_AND_2A)) + { + if (optimize_op(test) == OP_OR_2A) + pair_set_syntax_op(form, choose_if_optc(IF_OR2, one_branch, reversed, not_case)); + else pair_set_syntax_op(form, choose_if_optc(IF_AND2, one_branch, reversed, not_case)); + clear_has_fx(code); + set_opt2_pair(code, cdr(test)); + set_opt3_pair(code, cddr(test)); + return; + } + if (optimize_op(test) == OP_AND_3A) + { + pair_set_syntax_op(form, choose_if_optc(IF_AND3, one_branch, reversed, not_case)); + clear_has_fx(code); + set_opt2_pair(code, cdr(test)); + set_opt3_pair(code, cddr(test)); + set_opt1_pair(code, cdddr(test)); + return; + } + + pair_set_syntax_op(form, choose_if_optc(IF_A, one_branch, reversed, not_case)); + if (not_case) + { + set_fx_direct(cdar(code), fx_choose(sc, cdar(code), sc->curlet, let_symbol_is_safe)); + if (!reversed) set_opt3_pair(form, cdadr(form)); + } + else set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); + fb_if_annotate(sc, code, form); + } + else + { + pair_set_syntax_op(form, choose_if_optc(IF_P, one_branch, reversed, not_case)); + set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); + set_opt3_any(code, (not_case) ? cadar(code) : car(code)); + } + if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) + fx_curlet_tree(sc, code); + } else - { - pair_set_syntax_op(form, choose_if_optc(IF_P, one_branch, reversed, not_case)); - clear_has_fx(code); - set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); - set_opt3_any(code, (not_case) ? cadar(code) : car(code)); - if (is_symbol_and_syntactic(car(test))) - { - pair_set_syntax_op(test, symbol_syntax_op_checked(test)); - if ((symbol_syntax_op(car(test)) == OP_AND) || - (symbol_syntax_op(car(test)) == OP_OR)) - { - opcode_t new_op; - if (symbol_syntax_op(car(test)) == OP_AND) - check_and(sc, test); - else check_or(sc, test); - new_op = symbol_syntax_op_checked(test); - if ((new_op == OP_AND_P) || (new_op == OP_AND_AP) || (new_op == OP_AND_PAIR_P) || - (new_op == OP_AND_N) || (new_op == OP_AND_SAFE_P1) || (new_op == OP_AND_SAFE_P2) || (new_op == OP_AND_SAFE_P3)) - { - pair_set_syntax_op(form, choose_if_optc(IF_ANDP, one_branch, reversed, not_case)); - set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); - set_opt3_pair(code, (not_case) ? cdadar(code) : cdar(code)); - } - else - if ((new_op == OP_OR_P) || (new_op == OP_OR_AP)) - { - pair_set_syntax_op(form, choose_if_optc(IF_ORP, one_branch, reversed, not_case)); - set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); - set_opt3_pair(code, (not_case) ? cdadar(code) : cdar(code)); - }}}}} + { + pair_set_syntax_op(form, choose_if_optc(IF_P, one_branch, reversed, not_case)); + clear_has_fx(code); + set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); + set_opt3_any(code, (not_case) ? cadar(code) : car(code)); + if (is_symbol_and_syntactic(car(test))) + { + pair_set_syntax_op(test, symbol_syntax_op_checked(test)); + if ((symbol_syntax_op(car(test)) == OP_AND) || + (symbol_syntax_op(car(test)) == OP_OR)) + { + opcode_t new_op; + if (symbol_syntax_op(car(test)) == OP_AND) + check_and(sc, test); + else check_or(sc, test); + new_op = symbol_syntax_op_checked(test); + if ((new_op == OP_AND_P) || (new_op == OP_AND_AP) || (new_op == OP_AND_PAIR_P) || + (new_op == OP_AND_N) || (new_op == OP_AND_SAFE_P1) || (new_op == OP_AND_SAFE_P2) || (new_op == OP_AND_SAFE_P3)) + { + pair_set_syntax_op(form, choose_if_optc(IF_ANDP, one_branch, reversed, not_case)); + set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); + set_opt3_pair(code, (not_case) ? cdadar(code) : cdar(code)); + } + else + if ((new_op == OP_OR_P) || (new_op == OP_OR_AP)) + { + pair_set_syntax_op(form, choose_if_optc(IF_ORP, one_branch, reversed, not_case)); + set_opt2_any(code, (one_branch) ? cadr(code) : cdr(code)); + set_opt3_pair(code, (not_case) ? cdadar(code) : cdar(code)); + }}}}} else /* test is symbol or constant, but constant here is nutty */ if (is_safe_symbol(test)) { - pair_set_syntax_op(form, choose_if_optc(IF_S, one_branch, reversed, not_case)); - if (not_case) set_opt1_sym(code, cadar(code)); /* code is cdr(if...): ((not sym) ...) */ - if (optimize_op(form) == OP_IF_S_P_P) - { - if (is_fxable(sc, caddr(code))) - { - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - set_opt2_pair(form, cddr(code)); /* opt1_any set above to cadr(code) */ - if (is_fxable(sc, cadr(code))) - { - pair_set_syntax_op(form, OP_IF_S_A_A); - fx_annotate_args(sc, cdr(code), sc->curlet); - set_opt1_pair(form, cdr(code)); - } - else - { - pair_set_syntax_op(form, OP_IF_S_P_A); - fx_annotate_arg(sc, cddr(code), sc->curlet); - } - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - } - else - if (is_fxable(sc, cadr(code))) - { - pair_set_syntax_op(form, OP_IF_S_A_P); - fx_annotate_arg(sc, cdr(code), sc->curlet); - if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); - set_opt1_pair(form, cdr(code)); - set_opt2_any(form, caddr(code)); - }}} + pair_set_syntax_op(form, choose_if_optc(IF_S, one_branch, reversed, not_case)); + if (not_case) set_opt1_sym(code, cadar(code)); /* code is cdr(if...): ((not sym) ...) */ + if (optimize_op(form) == OP_IF_S_P_P) + { + if (is_fxable(sc, caddr(code))) + { + if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); + set_opt2_pair(form, cddr(code)); /* opt1_any set above to cadr(code) */ + if (is_fxable(sc, cadr(code))) + { + pair_set_syntax_op(form, OP_IF_S_A_A); + fx_annotate_args(sc, cdr(code), sc->curlet); + set_opt1_pair(form, cdr(code)); + } + else + { + pair_set_syntax_op(form, OP_IF_S_P_A); + fx_annotate_arg(sc, cddr(code), sc->curlet); + } + if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); + } + else + if (is_fxable(sc, cadr(code))) + { + pair_set_syntax_op(form, OP_IF_S_A_P); + fx_annotate_arg(sc, cdr(code), sc->curlet); + if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); + set_opt1_pair(form, cdr(code)); + set_opt2_any(form, caddr(code)); + }}} } /* (cond <> (else <>)) only happens in old-fashioned code, so set_if_opts covers if/when/unless but not cond */ @@ -78331,14 +78331,14 @@ static s7_pointer check_if(s7_scheme *sc, s7_pointer form) if (!is_pair(cdr_code)) /* (if 1) */ { if (is_null(cdr(code))) - syntax_error_nr(sc, "~S: if needs another clause", 27, form); + syntax_error_nr(sc, "~S: if needs another clause", 27, form); syntax_error_nr(sc, "~S: stray dot?", 14, form); /* (if 1 . 2) */ } if (is_pair(cdr(cdr_code))) { if (is_not_null(cddr(cdr_code))) /* (if 1 2 3 4) */ - syntax_error_nr(sc, "too many clauses for if: ~A", 27, form); + syntax_error_nr(sc, "too many clauses for if: ~A", 27, form); } else if (is_not_null(cdr(cdr_code))) /* (if 1 2 . 3) */ @@ -78393,36 +78393,36 @@ static void check_when(s7_scheme *sc) { s7_pointer test = car(code); if (is_safe_symbol(test)) - { - pair_set_syntax_op(form, OP_WHEN_S); - set_opt2_con(form, cadr(code)); - set_opt3_pair(form, cddr(code)); - } + { + pair_set_syntax_op(form, OP_WHEN_S); + set_opt2_con(form, cadr(code)); + set_opt3_pair(form, cddr(code)); + } else - /* fxable body doesn't happen very often -- a dozen or so hits in the standard tests */ - if (is_fxable(sc, test)) - { - pair_set_syntax_op(form, OP_WHEN_A); - if (is_pair(car(code))) set_opt2_pair(form, cdar(code)); - set_opt3_pair(form, cdr(code)); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); /* "A" in when_a */ - - if (fx_proc(code) == fx_and_2a) - pair_set_syntax_op(form, OP_WHEN_AND_2A); - else - if (fx_proc(code) == fx_and_3a) - pair_set_syntax_op(form, OP_WHEN_AND_3A); - } - else - if ((is_pair(test)) && (car(test) == sc->and_symbol)) - { - opcode_t new_op; - pair_set_syntax_op(test, symbol_syntax_op_checked(test)); - check_and(sc, test); - new_op = symbol_syntax_op_checked(test); - if (new_op == OP_AND_AP) - pair_set_syntax_op(form, OP_WHEN_AND_AP); - }} + /* fxable body doesn't happen very often -- a dozen or so hits in the standard tests */ + if (is_fxable(sc, test)) + { + pair_set_syntax_op(form, OP_WHEN_A); + if (is_pair(car(code))) set_opt2_pair(form, cdar(code)); + set_opt3_pair(form, cdr(code)); + set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); /* "A" in when_a */ + + if (fx_proc(code) == fx_and_2a) + pair_set_syntax_op(form, OP_WHEN_AND_2A); + else + if (fx_proc(code) == fx_and_3a) + pair_set_syntax_op(form, OP_WHEN_AND_3A); + } + else + if ((is_pair(test)) && (car(test) == sc->and_symbol)) + { + opcode_t new_op; + pair_set_syntax_op(test, symbol_syntax_op_checked(test)); + check_and(sc, test); + new_op = symbol_syntax_op_checked(test); + if (new_op == OP_AND_AP) + pair_set_syntax_op(form, OP_WHEN_AND_AP); + }} push_stack_no_args(sc, OP_WHEN_PP, cdr(code)); set_current_code(sc, sc->code); sc->code = car(code); @@ -78527,18 +78527,18 @@ static void check_unless(s7_scheme *sc) else if (is_safe_symbol(car(code))) { - pair_set_syntax_op(form, OP_UNLESS_S); - set_opt2_con(form, cadr(code)); - set_opt3_pair(form, cddr(code)); + pair_set_syntax_op(form, OP_UNLESS_S); + set_opt2_con(form, cadr(code)); + set_opt3_pair(form, cddr(code)); } else if (is_fxable(sc, car(code))) - { - pair_set_syntax_op(form, OP_UNLESS_A); - set_opt2_con(form, cadr(code)); - set_opt3_pair(form, cddr(code)); - set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); - } + { + pair_set_syntax_op(form, OP_UNLESS_A); + set_opt2_con(form, cadr(code)); + set_opt3_pair(form, cddr(code)); + set_fx_direct(code, fx_choose(sc, code, sc->curlet, let_symbol_is_safe)); + } push_stack_no_args(sc, OP_UNLESS_PP, cdr(code)); set_current_code(sc, sc->code); sc->code = car(code); @@ -78635,63 +78635,63 @@ static void check_define(s7_scheme *sc) if (!is_pair(cdr(code))) { if (is_null(cdr(code))) - syntax_error_with_caller_nr(sc, "~A: no value? ~A", 16, caller, sc->code); /* (define var) */ + syntax_error_with_caller_nr(sc, "~A: no value? ~A", 16, caller, sc->code); /* (define var) */ syntax_error_with_caller_nr(sc, "~A: stray dot? ~A", 17, caller, sc->code); /* (define var . 1) */ } if (!is_pair(car(code))) { if (is_not_null(cddr(code))) /* (define var 1 . 2) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "~A: more than one value? ~A", 27), caller, print_truncate(sc, sc->code))); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "~A: more than one value? ~A", 27), caller, print_truncate(sc, sc->code))); if (starred) - syntax_error_nr(sc, "define* is restricted to functions: ~S", 38, sc->code); + syntax_error_nr(sc, "define* is restricted to functions: ~S", 38, sc->code); func = car(code); if (!is_symbol(func)) /* (define 3 a) */ - syntax_error_with_caller2_nr(sc, "~A: can't define ~W (~A); it should be a symbol", 47, caller, func, object_type_name(sc, func)); + syntax_error_with_caller2_nr(sc, "~A: can't define ~W (~A); it should be a symbol", 47, caller, func, object_type_name(sc, func)); if (is_keyword(func)) /* (define :hi 1) */ - syntax_error_with_caller_nr(sc, "~A ~A: keywords are constants", 29, caller, func); + syntax_error_with_caller_nr(sc, "~A ~A: keywords are constants", 29, caller, func); if (is_syntactic_symbol(func)) /* (define and a) */ - { - if (sc->safety > NO_SAFETY) - s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_truncated(sc->code)); - set_local(func); - } + { + if (sc->safety > NO_SAFETY) + s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_truncated(sc->code)); + set_local(func); + } if ((is_pair(cadr(code))) && /* look for (define sym (lambda ...)) and treat it like (define (sym ...)...) */ - ((caadr(code) == sc->lambda_symbol) || - (caadr(code) == sc->lambda_star_symbol)) && - (symbol_id(caadr(code)) == 0)) - { - if ((is_global(func)) && (is_slot(global_slot(func))) && (is_immutable(global_slot(func))) && (is_slot(initial_slot(func)))) - immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't ~A ~S: it is immutable", 28), caller, func)); - - /* not is_global here because that bit might not be set for initial symbols (why not? -- redef as method etc) */ - if (!is_pair(cdadr(code))) /* (define x (lambda . 1)) */ - syntax_error_with_caller_nr(sc, "~A: stray dot? ~A", 17, caller, sc->code); - if (!is_pair(cddr(cadr(code)))) /* (define f (lambda (arg))) */ - syntax_error_with_caller_nr(sc, "~A: no body: ~A", 15, caller, sc->code); - if (caadr(code) == sc->lambda_star_symbol) - check_lambda_star_args(sc, cadadr(code), cddr(cadr(code)), cadr(code)); - else check_lambda_args(sc, cadadr(code), NULL, cadr(code)); - optimize_lambda(sc, caadr(code) == sc->lambda_symbol, func, cadadr(code), cddr(cadr(code))); - }} + ((caadr(code) == sc->lambda_symbol) || + (caadr(code) == sc->lambda_star_symbol)) && + (symbol_id(caadr(code)) == 0)) + { + if ((is_global(func)) && (is_slot(global_slot(func))) && (is_immutable(global_slot(func))) && (is_slot(initial_slot(func)))) + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't ~A ~S: it is immutable", 28), caller, func)); + + /* not is_global here because that bit might not be set for initial symbols (why not? -- redef as method etc) */ + if (!is_pair(cdadr(code))) /* (define x (lambda . 1)) */ + syntax_error_with_caller_nr(sc, "~A: stray dot? ~A", 17, caller, sc->code); + if (!is_pair(cddr(cadr(code)))) /* (define f (lambda (arg))) */ + syntax_error_with_caller_nr(sc, "~A: no body: ~A", 15, caller, sc->code); + if (caadr(code) == sc->lambda_star_symbol) + check_lambda_star_args(sc, cadadr(code), cddr(cadr(code)), cadr(code)); + else check_lambda_args(sc, cadadr(code), NULL, cadr(code)); + optimize_lambda(sc, caadr(code) == sc->lambda_symbol, func, cadadr(code), cddr(cadr(code))); + }} else { func = caar(code); if (!is_symbol(func)) /* (define (3 a) a) */ - syntax_error_with_caller2_nr(sc, "~A: can't define ~S, ~A (should be a symbol)", 44, caller, func, object_type_name(sc, func)); + syntax_error_with_caller2_nr(sc, "~A: can't define ~S, ~A (should be a symbol)", 44, caller, func, object_type_name(sc, func)); if (is_syntactic_symbol(func)) /* (define (and a) a) */ - { - if (sc->safety > NO_SAFETY) - s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_truncated(sc->code)); - set_local(func); - } + { + if (sc->safety > NO_SAFETY) + s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(func), display_truncated(sc->code)); + set_local(func); + } if ((is_global(func)) && (is_slot(global_slot(func))) && - (is_immutable(global_slot(func))) && (is_slot(initial_slot(func)))) /* (define (abs x) 1) after (immutable! abs) */ - immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't ~A ~S: it is immutable", 28), caller, func)); + (is_immutable(global_slot(func))) && (is_slot(initial_slot(func)))) /* (define (abs x) 1) after (immutable! abs) */ + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't ~A ~S: it is immutable", 28), caller, func)); if (starred) - set_cdar(code, check_lambda_star_args(sc, cdar(code), cdr(code), sc->code)); + set_cdar(code, check_lambda_star_args(sc, cdar(code), cdr(code), sc->code)); else check_lambda_args(sc, cdar(code), NULL, sc->code); optimize_lambda(sc, !starred, func, cdar(code), cdr(code)); } @@ -78699,8 +78699,8 @@ static void check_define(s7_scheme *sc) if (sc->cur_op == OP_DEFINE) { if ((is_pair(car(code))) && - (!is_possibly_constant(func))) - pair_set_syntax_op(sc->code, OP_DEFINE_FUNCHECKED); + (!is_possibly_constant(func))) + pair_set_syntax_op(sc->code, OP_DEFINE_FUNCHECKED); else pair_set_syntax_op(sc->code, OP_DEFINE_UNCHECKED); } else pair_set_syntax_op(sc->code, (starred) ? OP_DEFINE_STAR_UNCHECKED : OP_DEFINE_CONSTANT_UNCHECKED); @@ -78720,10 +78720,10 @@ static bool op_define_unchecked(s7_scheme *sc) sc->value = make_closure(sc, cdar(code), cdr(code), T_CLOSURE_STAR, CLOSURE_ARITY_NOT_SET); /* closure_body might not be cdr(code) after make_closure (add_trace) */ if ((is_pair(locp)) && (has_location(locp))) - { - pair_set_location(closure_body(sc->value), pair_location(locp)); - set_has_location(closure_body(sc->value)); - } + { + pair_set_location(closure_body(sc->value), pair_location(locp)); + set_has_location(closure_body(sc->value)); + } sc->code = caar(code); return(false); } @@ -78733,11 +78733,11 @@ static bool op_define_unchecked(s7_scheme *sc) s7_pointer x = car(code); sc->code = cadr(code); if (is_pair(sc->code)) - { - push_stack_no_args(sc, OP_DEFINE1, x); - sc->cur_op = optimize_op(sc->code); - return(true); - } + { + push_stack_no_args(sc, OP_DEFINE1, x); + sc->cur_op = optimize_op(sc->code); + return(true); + } sc->value = (is_symbol(sc->code)) ? lookup_global(sc, sc->code) : sc->code; sc->code = x; } @@ -78752,10 +78752,10 @@ static bool op_define_unchecked(s7_scheme *sc) */ s7_pointer x = make_closure(sc, args, cdr(code), T_CLOSURE | ((!s7_is_proper_list(sc, args)) ? T_COPY_ARGS : 0), (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET); if ((is_pair(locp)) && (has_location(locp))) - { - pair_set_location(closure_body(x), pair_location(locp)); - set_has_location(closure_body(x)); - } + { + pair_set_location(closure_body(x), pair_location(locp)); + set_has_location(closure_body(x)); + } sc->value = T_Ext(x); sc->code = caar(code); } @@ -78783,72 +78783,72 @@ static s7_pointer make_funclet(s7_scheme *sc, s7_pointer new_func, s7_pointer fu { s7_pointer last_slot = NULL; if (is_closure(new_func)) - { - if (is_pair(arg)) - { - last_slot = make_slot(sc, car(arg), sc->nil); - slot_set_next(last_slot, slot_end); - let_set_slots(new_let, last_slot); - symbol_set_local_slot(car(arg), let_id(new_let), last_slot); - for (arg = cdr(arg); is_pair(arg); arg = cdr(arg)) - last_slot = inline_add_slot_at_end(sc, let_id(new_let), last_slot, car(arg), sc->nil); - } - if (is_symbol(arg)) - { - if (last_slot) - last_slot = add_slot_at_end(sc, let_id(new_let), last_slot, arg, sc->nil); - else - { - last_slot = make_slot(sc, arg, sc->nil); - slot_set_next(last_slot, slot_end); - let_set_slots(new_let, last_slot); - symbol_set_local_slot(arg, let_id(new_let), last_slot); - } - set_is_rest_slot(last_slot); - }} + { + if (is_pair(arg)) + { + last_slot = make_slot(sc, car(arg), sc->nil); + slot_set_next(last_slot, slot_end); + let_set_slots(new_let, last_slot); + symbol_set_local_slot(car(arg), let_id(new_let), last_slot); + for (arg = cdr(arg); is_pair(arg); arg = cdr(arg)) + last_slot = inline_add_slot_at_end(sc, let_id(new_let), last_slot, car(arg), sc->nil); + } + if (is_symbol(arg)) + { + if (last_slot) + last_slot = add_slot_at_end(sc, let_id(new_let), last_slot, arg, sc->nil); + else + { + last_slot = make_slot(sc, arg, sc->nil); + slot_set_next(last_slot, slot_end); + let_set_slots(new_let, last_slot); + symbol_set_local_slot(arg, let_id(new_let), last_slot); + } + set_is_rest_slot(last_slot); + }} else /* closure_star */ - { - s7_pointer slot, first_default = sc->nil; - let_set_slots(new_let, slot_end); - for (; is_pair(arg); arg = cdr(arg)) - { - s7_pointer par = car(arg); - if (is_pair(par)) - { - s7_pointer val = cadr(par); - slot = add_slot_checked(sc, new_let, car(par), sc->nil); - slot_set_expression(slot, val); - if ((is_symbol(val)) || (is_pair(val))) - { - if (is_null(first_default)) - first_default = slot; - set_slot_defaults(slot); - }} - else - if (is_keyword(par)) - { - if (par == sc->rest_keyword) - { - arg = cdr(arg); - slot = add_slot_checked(sc, new_let, car(arg), sc->nil); - slot_set_expression(slot, sc->nil); - }} - else - { - slot = add_slot_checked(sc, new_let, par, sc->nil); - slot_set_expression(slot, sc->F); - }} - if (is_symbol(arg)) - { - slot = add_slot_checked(sc, new_let, arg, sc->nil); /* set up rest arg */ - set_is_rest_slot(slot); - slot_set_expression(slot, sc->nil); - } - if (tis_slot(let_slots(new_let))) - { - let_set_slots(new_let, reverse_slots(let_slots(new_let))); - slot_set_pending_value(let_slots(new_let), first_default); - }} + { + s7_pointer slot, first_default = sc->nil; + let_set_slots(new_let, slot_end); + for (; is_pair(arg); arg = cdr(arg)) + { + s7_pointer par = car(arg); + if (is_pair(par)) + { + s7_pointer val = cadr(par); + slot = add_slot_checked(sc, new_let, car(par), sc->nil); + slot_set_expression(slot, val); + if ((is_symbol(val)) || (is_pair(val))) + { + if (is_null(first_default)) + first_default = slot; + set_slot_defaults(slot); + }} + else + if (is_keyword(par)) + { + if (par == sc->rest_keyword) + { + arg = cdr(arg); + slot = add_slot_checked(sc, new_let, car(arg), sc->nil); + slot_set_expression(slot, sc->nil); + }} + else + { + slot = add_slot_checked(sc, new_let, par, sc->nil); + slot_set_expression(slot, sc->F); + }} + if (is_symbol(arg)) + { + slot = add_slot_checked(sc, new_let, arg, sc->nil); /* set up rest arg */ + set_is_rest_slot(slot); + slot_set_expression(slot, sc->nil); + } + if (tis_slot(let_slots(new_let))) + { + let_set_slots(new_let, reverse_slots(let_slots(new_let))); + slot_set_pending_value(let_slots(new_let), first_default); + }} set_immutable_let(new_let); } else let_set_slots(new_let, slot_end); /* if unsafe closure, arg-holding-let will be created on each call */ @@ -78864,10 +78864,10 @@ static bool op_define_constant(s7_scheme *sc) if (is_symbol_and_keyword(car(code))) /* (define-constant :rest :allow-other-keys) */ { if (car(code) == cadr(code)) /* (define-constant pi pi) returns pi */ - { - sc->value = car(code); - return(true); - } + { + sc->value = car(code); + return(true); + } syntax_error_with_caller_nr(sc, "~A ~A: keywords are constants", 29, sc->define_constant_symbol, car(code)); } if ((is_symbol(car(code))) && /* (define-constant abs abs): "abs will not be touched" */ @@ -78895,7 +78895,7 @@ static void op_define_constant1(s7_scheme *sc) set_possibly_constant(sc->code); set_immutable_slot(slot); if (is_any_closure(slot_value(slot))) - set_immutable(slot_value(slot)); /* for the optimizer mainly */ + set_immutable(slot_value(slot)); /* for the optimizer mainly */ } } @@ -78916,7 +78916,7 @@ static inline void define_funchecked(s7_scheme *sc) { set_safe_closure(new_func); if (is_very_safe_closure_body(cdr(code))) - set_very_safe_closure(new_func); + set_very_safe_closure(new_func); make_funclet(sc, new_func, sc->value, sc->curlet); } else closure_set_let(new_func, sc->curlet); /* unsafe closures created by other functions do not support *function* */ @@ -78942,7 +78942,7 @@ static s7_pointer check_define_macro(s7_scheme *sc, opcode_t op, s7_pointer form if (is_syntactic_symbol(mac_name)) { if (sc->safety > NO_SAFETY) - s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(mac_name), display_truncated(sc->code)); + s7_warn(sc, 256, "%s: syntactic keywords tend to behave badly if redefined: %s\n", display(mac_name), display_truncated(sc->code)); set_local(mac_name); } if (is_constant_symbol(sc, mac_name)) @@ -78953,20 +78953,20 @@ static s7_pointer check_define_macro(s7_scheme *sc, opcode_t op, s7_pointer form if (s7_list_length(sc, cdr(sc->code)) < 0) /* (define-macro (hi) 1 . 2) */ error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "~A: macro body messed up, ~A", 28), caller, sc->code)); + set_elist_3(sc, wrap_string(sc, "~A: macro body messed up, ~A", 28), caller, sc->code)); args = cdar(sc->code); if ((!is_list(args)) && (!is_symbol(args))) error_nr(sc, sc->syntax_error_symbol, /* (define-macro (mac . 1) ...) */ - set_elist_3(sc, wrap_string(sc, "macro ~A argument list is ~S?", 29), mac_name, args)); + set_elist_3(sc, wrap_string(sc, "macro ~A argument list is ~S?", 29), mac_name, args)); if ((op == OP_DEFINE_MACRO) || (op == OP_DEFINE_BACRO) || (op == OP_DEFINE_EXPANSION)) { for (; is_pair(args); args = cdr(args)) - if (!is_symbol(car(args))) - error_nr(sc, sc->syntax_error_symbol, /* (define-macro (mac 1) ...) */ - set_elist_3(sc, wrap_string(sc, "~A parameter name, ~A, is not a symbol", 38), caller, car(args))); + if (!is_symbol(car(args))) + error_nr(sc, sc->syntax_error_symbol, /* (define-macro (mac 1) ...) */ + set_elist_3(sc, wrap_string(sc, "~A parameter name, ~A, is not a symbol", 38), caller, car(args))); check_lambda_args(sc, cdar(sc->code), NULL, form); } else set_cdar(sc->code, check_lambda_star_args(sc, args, NULL, form)); @@ -78986,20 +78986,20 @@ static s7_pointer check_macro(s7_scheme *sc, opcode_t op, s7_pointer form) if ((!is_list(args)) && (!is_symbol(args))) error_nr(sc, sc->syntax_error_symbol, /* (macro #(0) ...) */ - set_elist_2(sc, wrap_string(sc, "macro parameter list is ~S?", 27), args)); + set_elist_2(sc, wrap_string(sc, "macro parameter list is ~S?", 27), args)); if ((op == OP_MACRO) || (op == OP_BACRO)) { for (; is_pair(args); args = cdr(args)) - if (!is_symbol(car(args))) - error_nr(sc, sc->syntax_error_symbol, /* (macro (1) ...) */ - set_elist_3(sc, wrap_string(sc, "~A parameter name, ~A, is not a symbol", 38), caller, car(args))); + if (!is_symbol(car(args))) + error_nr(sc, sc->syntax_error_symbol, /* (macro (1) ...) */ + set_elist_3(sc, wrap_string(sc, "~A parameter name, ~A, is not a symbol", 38), caller, car(args))); check_lambda_args(sc, car(sc->code), NULL, form); } else set_car(sc->code, check_lambda_star_args(sc, args, NULL, form)); if (s7_list_length(sc, cdr(sc->code)) < 0) /* (macro () 1 . 2) */ error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "~A: macro body messed up, ~A", 28), caller, form)); + set_elist_3(sc, wrap_string(sc, "~A: macro body messed up, ~A", 28), caller, form)); return(sc->code); } @@ -79095,28 +79095,28 @@ static goto_t op_expansion(s7_scheme *sc) if (!is_let(sc->curlet)) set_curlet(sc, sc->rootlet); if ((symbol_id(symbol) == 0) || - (sc->curlet == sc->nil)) - slot = global_slot(symbol); + (sc->curlet == sc->nil)) + slot = global_slot(symbol); else slot = s7_slot(sc, symbol); sc->code = (is_slot(slot)) ? slot_value(slot) : sc->undefined; if ((!is_either_macro(sc->code)) || (!is_expansion(sc->code))) - clear_expansion(symbol); + clear_expansion(symbol); else - { - /* call the reader macro */ - sc->args = cdr(sc->value); - push_stack_no_code(sc, OP_EXPANSION, sc->nil); - set_curlet(sc, make_let(sc, closure_let(sc->code))); - transfer_macro_info(sc, sc->code); - if (!is_macro_star(sc->code)) - return(goto_apply_lambda); - apply_macro_star_1(sc); - return(goto_begin); - /* bacros don't seem to make sense here -- they are tied to the run-time environment, - * procedures would need to evaluate their arguments in rootlet - */ - }} + { + /* call the reader macro */ + sc->args = cdr(sc->value); + push_stack_no_code(sc, OP_EXPANSION, sc->nil); + set_curlet(sc, make_let(sc, closure_let(sc->code))); + transfer_macro_info(sc, sc->code); + if (!is_macro_star(sc->code)) + return(goto_apply_lambda); + apply_macro_star_1(sc); + return(goto_begin); + /* bacros don't seem to make sense here -- they are tied to the run-time environment, + * procedures would need to evaluate their arguments in rootlet + */ + }} return(fall_through); } @@ -79185,7 +79185,7 @@ static goto_t op_macroexpand(s7_scheme *sc) if (!is_symbol(caar(sc->code))) { if (!is_any_macro(caar(sc->code))) - syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, sc->code); + syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, sc->code); sc->code = caar(sc->code); return(macroexpand(sc)); } @@ -79242,12 +79242,12 @@ static void op_finish_expansion(s7_scheme *sc) if (sc->value == sc->no_value) { if (stack_top_op(sc) != OP_LOAD_RETURN_IF_EOF) /* latter op if empty expansion at top-level */ - { - if (stack_top_op(sc) != OP_READ_LIST) /* OP_EVAL_STRING: (eval-string "(reader-cond...)") where reader-cond returns (values) */ - sc->value = sc->F; /* (eval-string "") -> #f, was nil_string for awhile */ - else set_stack_top_op(sc, OP_READ_NEXT); - /* OP_READ_DONE: (eval-string (object->string (with-input-from-string "(reader-cond ((provided? 'surreals) 123))" read))) */ - }} + { + if (stack_top_op(sc) != OP_READ_LIST) /* OP_EVAL_STRING: (eval-string "(reader-cond...)") where reader-cond returns (values) */ + sc->value = sc->F; /* (eval-string "") -> #f, was nil_string for awhile */ + else set_stack_top_op(sc, OP_READ_NEXT); + /* OP_READ_DONE: (eval-string (object->string (with-input-from-string "(reader-cond ((provided? 'surreals) 123))" read))) */ + }} else if (is_pair(sc->value)) sc->value = copy_body(sc, sc->value); @@ -79267,8 +79267,8 @@ static void check_with_let(s7_scheme *sc) syntax_error_nr(sc, "stray dot in with-let body: ~S", 30, sc->code); pair_set_syntax_op(sc->code, ((is_normal_symbol(car(form))) && - (is_normal_symbol(cadr(form))) && /* (with-let lt a) is not the same as (with-let lt :a) */ - (is_null(cddr(form)))) ? OP_WITH_LET_S : OP_WITH_LET_UNCHECKED); + (is_normal_symbol(cadr(form))) && /* (with-let lt a) is not the same as (with-let lt :a) */ + (is_null(cddr(form)))) ? OP_WITH_LET_S : OP_WITH_LET_UNCHECKED); set_current_code(sc, sc->code); } @@ -79279,7 +79279,7 @@ static bool op_with_let_unchecked(s7_scheme *sc) if (!is_pair(sc->value)) { if (is_symbol(sc->value)) - sc->value = lookup_checked(sc, sc->value); + sc->value = lookup_checked(sc, sc->value); sc->code = cdr(sc->code); return(false); } @@ -79298,15 +79298,15 @@ static s7_pointer fx_with_let_s(s7_scheme *sc, s7_pointer arg) { e = find_let(sc, e); if (!is_let(e)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "with-let takes an environment argument: ~A", 42), car(code))); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "with-let takes an environment argument: ~A", 42), car(code))); } val = let_ref(sc, e, sym); /* (with-let e s) -> (let-ref e s), "s" unevalled? */ if (val == sc->undefined) /* but sym can have the value #<undefined>: (with-let (inlet 'x #<undefined>) x) */ { if ((e == sc->s7_starlet) && (is_slot(global_slot(sym)))) /* (let () (define (func) (with-let *s7* letrec*)) (func) (func)), .5 tlet */ - return(global_value(sym)); /* perhaps the e=*s7* check is not needed */ + return(global_value(sym)); /* perhaps the e=*s7* check is not needed */ if (is_slot(lookup_slot_with_let(sc, sym, e))) - return(sc->undefined); + return(sc->undefined); unbound_variable_error_nr(sc, sym); } return(val); @@ -79318,7 +79318,7 @@ static void activate_with_let(s7_scheme *sc, s7_pointer e) { s7_pointer new_e = find_let(sc, e); /* sc->nil here means no let found */ if ((!is_let(new_e)) && (!has_closure_let(e))) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "with-let takes an environment argument: ~A", 42), e)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "with-let takes an environment argument: ~A", 42), e)); e = new_e; } if (e == sc->rootlet) @@ -79345,31 +79345,31 @@ static void check_cond(s7_scheme *sc) for (x = code; is_pair(x); x = cdr(x)) if (!is_pair(car(x))) /* (cond 1) or (cond (#t 1) 3) */ error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "every clause in cond must be a pair: ~S in ~A", 45), - car(x), object_to_string_truncated(sc, form))); + set_elist_3(sc, wrap_string(sc, "every clause in cond must be a pair: ~S in ~A", 45), + car(x), object_to_string_truncated(sc, form))); else { - s7_pointer y = car(x); - if (!s7_is_proper_list(sc, cdr(y))) /* (cond (xxx . 1)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "stray dot? ~S in ~A", 19), - y, object_to_string_truncated(sc, form))); - if (is_pair(cdr(y))) - { - if (is_pair(cddr(y))) result_single = false; - if (is_undefined_feed_to(sc, cadr(y))) - { - has_feed_to = true; - if (!is_pair(cddr(y))) /* (cond (#t =>)) or (cond (#t => . 1)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "cond: '=>' target missing? ~S in ~A", 36), - x, object_to_string_truncated(sc, form))); - if (is_pair(cdddr(y))) /* (cond (1 => + abs)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "cond: '=>' has too many targets: ~S in ~A", 41), - x, object_to_string_truncated(sc, form))); - }} - else result_single = false; + s7_pointer y = car(x); + if (!s7_is_proper_list(sc, cdr(y))) /* (cond (xxx . 1)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "stray dot? ~S in ~A", 19), + y, object_to_string_truncated(sc, form))); + if (is_pair(cdr(y))) + { + if (is_pair(cddr(y))) result_single = false; + if (is_undefined_feed_to(sc, cadr(y))) + { + has_feed_to = true; + if (!is_pair(cddr(y))) /* (cond (#t =>)) or (cond (#t => . 1)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "cond: '=>' target missing? ~S in ~A", 36), + x, object_to_string_truncated(sc, form))); + if (is_pair(cdddr(y))) /* (cond (1 => + abs)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "cond: '=>' has too many targets: ~S in ~A", 41), + x, object_to_string_truncated(sc, form))); + }} + else result_single = false; } if (is_not_null(x)) /* (cond ((1 2)) . 1) */ error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "cond: stray dot? ~S", 19), form)); @@ -79379,33 +79379,33 @@ static void check_cond(s7_scheme *sc) s7_pointer p = car(x); /* clear_has_fx(p); */ /* a kludge -- if has_fx here (and not re-fx'd below), someone messed up earlier -- but was fx_treeable set? */ if (is_fxable(sc, car(p))) - fx_annotate_arg(sc, p, sc->curlet); + fx_annotate_arg(sc, p, sc->curlet); for (p = cdr(p); is_pair(p); p = cdr(p)) - if (!has_fx(p)) - { - s7_function f = fx_choose(sc, p, sc->curlet, let_symbol_is_safe); - if (f) set_fx_direct(p, f); else result_fx = false; - }} + if (!has_fx(p)) + { + s7_function f = fx_choose(sc, p, sc->curlet, let_symbol_is_safe); + if (f) set_fx_direct(p, f); else result_fx = false; + }} if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code); if (has_feed_to) { pair_set_syntax_op(form, OP_COND_UNCHECKED); if (is_null(cdr(code))) - { - s7_pointer expr = car(code), f; - f = caddr(expr); - if ((is_proper_list_3(sc, f)) && - (car(f) == sc->lambda_symbol)) - { - s7_pointer arg = cadr(f); - if ((is_pair(arg)) && - (is_null(cdr(arg))) && - (is_symbol(car(arg)))) /* (define (hi) (cond (#t => (lambda (s) s)))) */ - { - set_opt2_lambda(code, caddar(code)); /* (lambda ...) above */ - pair_set_syntax_op(form, OP_COND_FEED); - }}}} + { + s7_pointer expr = car(code), f; + f = caddr(expr); + if ((is_proper_list_3(sc, f)) && + (car(f) == sc->lambda_symbol)) + { + s7_pointer arg = cadr(f); + if ((is_pair(arg)) && + (is_null(cdr(arg))) && + (is_symbol(car(arg)))) /* (define (hi) (cond (#t => (lambda (s) s)))) */ + { + set_opt2_lambda(code, caddar(code)); /* (lambda ...) above */ + pair_set_syntax_op(form, OP_COND_FEED); + }}}} else { s7_pointer p; @@ -79414,28 +79414,28 @@ static void check_cond(s7_scheme *sc) pair_set_syntax_op(form, OP_COND_SIMPLE); for (i = 0, p = code; xopt && (is_pair(p)); i++, p = cdr(p)) - xopt = ((has_fx(car(p))) && (is_pair(cdar(p)))); + xopt = ((has_fx(car(p))) && (is_pair(cdar(p)))); if (xopt) - { - pair_set_syntax_op(form, (result_fx) ? OP_COND_NA_NA : ((result_single) ? OP_COND_NA_NP_O : OP_COND_NA_NP)); + { + pair_set_syntax_op(form, (result_fx) ? OP_COND_NA_NA : ((result_single) ? OP_COND_NA_NP_O : OP_COND_NA_NP)); if (result_single) - { - if (i == 2) - { - p = caadr(code); - if ((p == sc->else_symbol) || (p == sc->T)) - pair_set_syntax_op(form, OP_COND_NA_2E); - } - else - if (i == 3) - { - p = caaddr(code); - if ((p == sc->else_symbol) || (p == sc->T)) - pair_set_syntax_op(form, OP_COND_NA_3E); - }}} + { + if (i == 2) + { + p = caadr(code); + if ((p == sc->else_symbol) || (p == sc->T)) + pair_set_syntax_op(form, OP_COND_NA_2E); + } + else + if (i == 3) + { + p = caaddr(code); + if ((p == sc->else_symbol) || (p == sc->T)) + pair_set_syntax_op(form, OP_COND_NA_3E); + }}} else - if (result_single) - pair_set_syntax_op(form, OP_COND_SIMPLE_O); + if (result_single) + pair_set_syntax_op(form, OP_COND_SIMPLE_O); } set_opt3_any(code, caar(code)); } @@ -79484,57 +79484,57 @@ static bool op_cond1(s7_scheme *sc) while (true) { if (is_true(sc, sc->value)) /* test is true, so evaluate result */ - { - sc->code = cdar(sc->code); - if (is_pair(sc->code)) - { - if (is_null(cdr(sc->code))) - { - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - pop_stack(sc); - return(true); /* goto top_no_pop */ - } - sc->code = car(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - } - /* check_cond catches stray dots */ - if (is_undefined_feed_to(sc, car(sc->code))) - return(false); - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - sc->code = cdr(sc->code); - if (is_pair(cdr(sc->code))) - push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); - } - else push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); - sc->code = car(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - } - if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "cond1 mv case %s\n", display(sc->value)); - pop_stack(sc); - return(true); - } + { + sc->code = cdar(sc->code); + if (is_pair(sc->code)) + { + if (is_null(cdr(sc->code))) + { + if (has_fx(sc->code)) + { + sc->value = fx_call(sc, sc->code); + pop_stack(sc); + return(true); /* goto top_no_pop */ + } + sc->code = car(sc->code); + sc->cur_op = optimize_op(sc->code); + return(true); + } + /* check_cond catches stray dots */ + if (is_undefined_feed_to(sc, car(sc->code))) + return(false); + if (has_fx(sc->code)) + { + sc->value = fx_call(sc, sc->code); + sc->code = cdr(sc->code); + if (is_pair(cdr(sc->code))) + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + } + else push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); + sc->code = car(sc->code); + sc->cur_op = optimize_op(sc->code); + return(true); + } + if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "cond1 mv case %s\n", display(sc->value)); + pop_stack(sc); + return(true); + } sc->code = cdr(sc->code); /* go to next clause */ if (is_null(sc->code)) - { - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - } + { + sc->value = sc->unspecified; + pop_stack(sc); + return(true); + } if (has_fx(car(sc->code))) - sc->value = fx_call(sc, car(sc->code)); + sc->value = fx_call(sc, car(sc->code)); else - { - push_stack_no_args_direct(sc, OP_COND1); - sc->code = caar(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - }} + { + push_stack_no_args_direct(sc, OP_COND1); + sc->code = caar(sc->code); + sc->cur_op = optimize_op(sc->code); + return(true); + }} return(true); /* make the compiler happy */ } @@ -79543,38 +79543,38 @@ static bool op_cond1_simple(s7_scheme *sc) while (true) { if (is_true(sc, sc->value)) - { - sc->code = T_Lst(cdar(sc->code)); - if (is_null(sc->code)) - { - if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "cond1_simple mv case %s\n", display(sc->value)); - pop_stack(sc); - return(true); - } - if (!has_fx(sc->code)) - return(false); - sc->value = fx_call(sc, sc->code); - sc->code = cdr(sc->code); - if (is_pair(sc->code)) return(false); /* goto begin */ - pop_stack(sc); - return(true); /* goto top_no_pop */ - } + { + sc->code = T_Lst(cdar(sc->code)); + if (is_null(sc->code)) + { + if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "cond1_simple mv case %s\n", display(sc->value)); + pop_stack(sc); + return(true); + } + if (!has_fx(sc->code)) + return(false); + sc->value = fx_call(sc, sc->code); + sc->code = cdr(sc->code); + if (is_pair(sc->code)) return(false); /* goto begin */ + pop_stack(sc); + return(true); /* goto top_no_pop */ + } sc->code = cdr(sc->code); if (is_null(sc->code)) - { - sc->value = sc->unspecified; - pop_stack(sc); - return(true); - } + { + sc->value = sc->unspecified; + pop_stack(sc); + return(true); + } if (has_fx(car(sc->code))) - sc->value = fx_call(sc, car(sc->code)); + sc->value = fx_call(sc, car(sc->code)); else - { - push_stack_no_args_direct(sc, OP_COND1_SIMPLE); - sc->code = caar(sc->code); - sc->cur_op = optimize_op(sc->code); - return(true); - }} + { + push_stack_no_args_direct(sc, OP_COND1_SIMPLE); + sc->code = caar(sc->code); + sc->cur_op = optimize_op(sc->code); + return(true); + }} } static bool op_cond1_simple_o(s7_scheme *sc) @@ -79582,31 +79582,31 @@ static bool op_cond1_simple_o(s7_scheme *sc) while (true) { if (is_true(sc, sc->value)) - { - sc->code = cdar(sc->code); - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - return(true); /* goto start */ - } - sc->code = car(sc->code); - return(false); - } + { + sc->code = cdar(sc->code); + if (has_fx(sc->code)) + { + sc->value = fx_call(sc, sc->code); + return(true); /* goto start */ + } + sc->code = car(sc->code); + return(false); + } sc->code = cdr(sc->code); if (is_null(sc->code)) - { - sc->value = sc->unspecified; - return(true); - } + { + sc->value = sc->unspecified; + return(true); + } if (has_fx(car(sc->code))) - sc->value = fx_call(sc, car(sc->code)); + sc->value = fx_call(sc, car(sc->code)); else - { - check_stack_size(sc); /* 4-May-21 snd-test */ - push_stack_no_args_direct(sc, OP_COND1_SIMPLE_O); - sc->code = caar(sc->code); - return(false); - }} + { + check_stack_size(sc); /* 4-May-21 snd-test */ + push_stack_no_args_direct(sc, OP_COND1_SIMPLE_O); + sc->code = caar(sc->code); + return(false); + }} } static bool op_cond_na_np(s7_scheme *sc) /* all tests are fxable, results may be a mixture, no =>, no missing results */ @@ -79614,17 +79614,17 @@ static bool op_cond_na_np(s7_scheme *sc) /* all tests are fxable, results may b for (s7_pointer p = cdr(sc->code); is_pair(p); p = cdr(p)) if (is_true(sc, fx_call(sc, car(p)))) { - for (p = T_Lst(cdar(p)); is_pair(p); p = cdr(p)) - if (has_fx(T_Pair(p))) - sc->value = fx_call(sc, p); - else - { - if (is_pair(cdr(p))) - push_stack_no_args(sc, OP_COND_NA_NP_1, cdr(p)); - sc->code = car(p); - return(false); - } - return(true); + for (p = T_Lst(cdar(p)); is_pair(p); p = cdr(p)) + if (has_fx(T_Pair(p))) + sc->value = fx_call(sc, p); + else + { + if (is_pair(cdr(p))) + push_stack_no_args(sc, OP_COND_NA_NP_1, cdr(p)); + sc->code = car(p); + return(false); + } + return(true); } sc->value = sc->unspecified; return(true); @@ -79637,10 +79637,10 @@ static bool op_cond_na_np_1(s7_scheme *sc) /* continuing to handle a multi-stat sc->value = fx_call(sc, p); else { - if (is_pair(cdr(p))) - push_stack_no_args(sc, OP_COND_NA_NP_1, cdr(p)); - sc->code = car(p); - return(false); + if (is_pair(cdr(p))) + push_stack_no_args(sc, OP_COND_NA_NP_1, cdr(p)); + sc->code = car(p); + return(false); } return(true); } @@ -79650,14 +79650,14 @@ static Inline bool inline_op_cond_na_np_o(s7_scheme *sc) /* all tests are fxabl for (s7_pointer p = cdr(sc->code); is_pair(p); p = cdr(p)) if (is_true(sc, fx_call(sc, car(p)))) { - p = cdar(p); - if (has_fx(T_Pair(p))) - { - sc->value = fx_call(sc, p); - return(true); - } - sc->code = car(p); - return(false); + p = cdar(p); + if (has_fx(T_Pair(p))) + { + sc->value = fx_call(sc, p); + return(true); + } + sc->code = car(p); + return(false); } sc->value = sc->unspecified; return(true); @@ -79718,18 +79718,18 @@ static bool feed_to(s7_scheme *sc) sc->args = multiple_value(sc->value); clear_multiple_value(sc->args); if (is_symbol(cadr(sc->code))) - { - sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */ - return(true); - }} + { + sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */ + return(true); + }} else { if (is_symbol(cadr(sc->code))) - { - sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */ - sc->args = (needs_copied_args(sc->code)) ? list_1(sc, sc->value) : set_plist_1(sc, sc->value); - return(true); - } + { + sc->code = lookup_global(sc, cadr(sc->code)); /* car is => */ + sc->args = (needs_copied_args(sc->code)) ? list_1(sc, sc->value) : set_plist_1(sc, sc->value); + return(true); + } sc->args = list_1(sc, sc->value); /* not plist here */ } push_stack_direct(sc, OP_FEED_TO_1); @@ -79745,7 +79745,7 @@ static void check_set(s7_scheme *sc) if (!is_pair(code)) { if (is_null(code)) /* (set!) */ - syntax_error_nr(sc, "set!: not enough arguments: ~A", 30, form); + syntax_error_nr(sc, "set!: not enough arguments: ~A", 30, form); syntax_error_nr(sc, "set!: stray dot? ~A", 19, form); /* (set! . 1) */ } settee = car(code); @@ -79753,7 +79753,7 @@ static void check_set(s7_scheme *sc) if (!is_pair(cdr(code))) { if (is_null(cdr(code))) /* (set! var) */ - syntax_error_nr(sc, "set!: not enough arguments: ~A", 30, form); + syntax_error_nr(sc, "set!: not enough arguments: ~A", 30, form); syntax_error_nr(sc, "set!: stray dot? ~A", 19, form); /* (set! var . 1) */ } value = cadr(code); /* the value has not yet been evaluated */ @@ -79768,84 +79768,84 @@ static void check_set(s7_scheme *sc) if (is_pair(settee)) { if ((is_pair(car(settee))) && - (!is_list(cdr(settee)))) /* (set! ('(1 2) . 0) 1) */ - syntax_error_nr(sc, "improper list of arguments to set!: ~A", 38, form); + (!is_list(cdr(settee)))) /* (set! ('(1 2) . 0) 1) */ + syntax_error_nr(sc, "improper list of arguments to set!: ~A", 38, form); if (!s7_is_proper_list(sc, settee)) /* (set! ("hi" . 1) #\a) or (set! (#(1 2) . 1) 0) */ - syntax_error_nr(sc, "set! target is an improper list: (set! ~A ...)", 46, settee); + syntax_error_nr(sc, "set! target is an improper list: (set! ~A ...)", 46, settee); } else if (!is_symbol(settee)) /* (set! 12345 1) */ error_nr(sc, sc->syntax_error_symbol, /* (set! #_abs 32) -> "error: set! can't change abs (a c-function), (set! abs 32)" */ - set_elist_4(sc, wrap_string(sc, "set! can't change ~S (~A), ~S", 29), settee, sc->type_names[type(settee)], form)); + set_elist_4(sc, wrap_string(sc, "set! can't change ~S (~A), ~S", 29), settee, sc->type_names[type(settee)], form)); else if (is_keyword(settee)) /* (set! :hi 3) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "set!: can't change keyword's value: ~S in ~S", 44), settee, form)); + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "set!: can't change keyword's value: ~S in ~S", 44), settee, form)); if (is_pair(settee)) /* here we have (set! (...) ...) */ { pair_set_syntax_op(form, OP_SET_UNCHECKED); /* if not pair car, op_set_normal below */ if (is_symbol(car(settee))) - { - if (is_null(cdr(settee))) /* (set! (symbol) ...) */ - { - if (is_fxable(sc, value)) - { - pair_set_syntax_op(form, OP_SET_opSq_A); /* (set! (symbol) fxable) */ - fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) = value */ - }} - else - if (is_null(cddr(settee))) /* we check cddr(code) above */ /* this leaves (set! (vect i j) 1) unhandled so we go to OP_SET_UNCHECKED */ - { - s7_pointer index = cadr(settee); - if (is_fxable(sc, index)) - { - if ((car(settee) == sc->let_ref_symbol) && (!is_pair(cddr(settee)))) /* perhaps also check for hash-table-ref */ - /* (let () (define (func) (catch #t (lambda () (set! (let-ref (list 1)) 1)) (lambda args 'error))) (func) (func)) */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_2(sc, wrap_string(sc, "set!: not enough arguments for let-ref: ~S", 42), sc->code)); - fx_annotate_arg(sc, cdr(settee), sc->curlet); /* cdr(settee) -> index */ - if (is_fxable(sc, value)) - { - pair_set_syntax_op(form, OP_SET_opSAq_A); /* (set! (symbol fxable) fxable) */ - /* perhaps: if "S" is a known function (etc), split this -- the runtime check for a macro here is very expensive - * fprintf(stderr, "(set! %s %s)\n", display(settee), display(value)); - * S=vector[tnum]/hash-table/c_func/s7/setter[tset]/var-*[lt]/c-obj[tobj]/dilambda[tstar] - * so, if not any_macro OP_SET_opFAq_A else OP_SET_opMAq_A? or just the latter - * also (set! (car a) b) -> (set-car! a b), (set! (cfunc a) b) -> ((setter cfunc) a b) - * set_opsaq_a as "unknown" equivalent -> all the special cases which check just their case, maybe a no-parcel option + { + if (is_null(cdr(settee))) /* (set! (symbol) ...) */ + { + if (is_fxable(sc, value)) + { + pair_set_syntax_op(form, OP_SET_opSq_A); /* (set! (symbol) fxable) */ + fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) = value */ + }} + else + if (is_null(cddr(settee))) /* we check cddr(code) above */ /* this leaves (set! (vect i j) 1) unhandled so we go to OP_SET_UNCHECKED */ + { + s7_pointer index = cadr(settee); + if (is_fxable(sc, index)) + { + if ((car(settee) == sc->let_ref_symbol) && (!is_pair(cddr(settee)))) /* perhaps also check for hash-table-ref */ + /* (let () (define (func) (catch #t (lambda () (set! (let-ref (list 1)) 1)) (lambda args 'error))) (func) (func)) */ + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_2(sc, wrap_string(sc, "set!: not enough arguments for let-ref: ~S", 42), sc->code)); + fx_annotate_arg(sc, cdr(settee), sc->curlet); /* cdr(settee) -> index */ + if (is_fxable(sc, value)) + { + pair_set_syntax_op(form, OP_SET_opSAq_A); /* (set! (symbol fxable) fxable) */ + /* perhaps: if "S" is a known function (etc), split this -- the runtime check for a macro here is very expensive + * fprintf(stderr, "(set! %s %s)\n", display(settee), display(value)); + * S=vector[tnum]/hash-table/c_func/s7/setter[tset]/var-*[lt]/c-obj[tobj]/dilambda[tstar] + * so, if not any_macro OP_SET_opFAq_A else OP_SET_opMAq_A? or just the latter + * also (set! (car a) b) -> (set-car! a b), (set! (cfunc a) b) -> ((setter cfunc) a b) + * set_opsaq_a as "unknown" equivalent -> all the special cases which check just their case, maybe a no-parcel option */ - fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */ + fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */ - if (car(settee) == sc->s7_starlet_symbol) /* (set! (*s7* 'field) value) */ - { - s7_pointer sym = (is_symbol(index)) ? - ((is_keyword(index)) ? keyword_symbol(index) : index) : + if (car(settee) == sc->s7_starlet_symbol) /* (set! (*s7* 'field) value) */ + { + s7_pointer sym = (is_symbol(index)) ? + ((is_keyword(index)) ? keyword_symbol(index) : index) : ((is_quoted_symbol(index)) ? cadr(index) : index); - if ((is_symbol(sym)) && (s7_starlet_symbol(sym) != SL_NO_FIELD)) - { - /* perhaps preset field -> op_print_length_set[misc?]|safety[tstar] etc, most (timing test) cases are just heap-size called once */ - set_safe_optimize_op(form, OP_IMPLICIT_S7_STARLET_SET); - set_opt3_sym(form, sym); - }}} - else pair_set_syntax_op(form, OP_SET_opSAq_P); /* (set! (symbol fxable) any) */ - }} - else - if ((is_null(cdddr(settee))) && - (car(settee) != sc->with_let_symbol)) /* (set! (with-let lt a) 32) needs to be handled by op_set_with_let_1 */ - { - s7_pointer index1 = cadr(settee), index2 = caddr(settee); - if ((is_fxable(sc, index1)) && (is_fxable(sc, index2))) - { - fx_annotate_args(sc, cdr(settee), sc->curlet); /* cdr(settee) -> index1 and 2 */ - if (is_fxable(sc, value)) - { - pair_set_syntax_op(form, OP_SET_opSAAq_A); /* (set! (symbol fxable fxable) fxable) */ - fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */ - } - else pair_set_syntax_op(form, OP_SET_opSAAq_P); /* (set! (symbol fxable fxable) any) */ - }}} + if ((is_symbol(sym)) && (s7_starlet_symbol(sym) != SL_NO_FIELD)) + { + /* perhaps preset field -> op_print_length_set[misc?]|safety[tstar] etc, most (timing test) cases are just heap-size called once */ + set_safe_optimize_op(form, OP_IMPLICIT_S7_STARLET_SET); + set_opt3_sym(form, sym); + }}} + else pair_set_syntax_op(form, OP_SET_opSAq_P); /* (set! (symbol fxable) any) */ + }} + else + if ((is_null(cdddr(settee))) && + (car(settee) != sc->with_let_symbol)) /* (set! (with-let lt a) 32) needs to be handled by op_set_with_let_1 */ + { + s7_pointer index1 = cadr(settee), index2 = caddr(settee); + if ((is_fxable(sc, index1)) && (is_fxable(sc, index2))) + { + fx_annotate_args(sc, cdr(settee), sc->curlet); /* cdr(settee) -> index1 and 2 */ + if (is_fxable(sc, value)) + { + pair_set_syntax_op(form, OP_SET_opSAAq_A); /* (set! (symbol fxable fxable) fxable) */ + fx_annotate_arg(sc, cdr(code), sc->curlet); /* cdr(code) -> value */ + } + else pair_set_syntax_op(form, OP_SET_opSAAq_P); /* (set! (symbol fxable fxable) any) */ + }}} return; } pair_set_syntax_op(form, OP_SET_NORMAL); @@ -79853,102 +79853,102 @@ static void check_set(s7_scheme *sc) { s7_pointer slot = s7_slot(sc, settee); if ((is_slot(slot)) && - (!slot_has_setter(slot)) && - (!is_immutable(slot)) && - (!is_syntactic_symbol(settee))) - { - if (is_normal_symbol(value)) - { - s7_pointer slot1 = s7_slot(sc, value); - if ((is_slot(slot1)) && (!slot_has_setter(slot1))) - { - pair_set_syntax_op(form, OP_SET_S_S); - set_opt2_sym(code, value); - }} - else - if ((!is_pair(value)) || - ((is_quote(car(value))) && (is_pair(cdr(value))))) /* (quote . 1) ? */ - { - pair_set_syntax_op(form, OP_SET_S_C); - set_opt2_con(code, (is_pair(value)) ? cadr(value) : value); - } - else - { - pair_set_syntax_op(form, OP_SET_S_P); - if (is_optimized(value)) - { - if (optimize_op(value) == HOP_SAFE_C_SS) - { - if (settee == cadr(value)) - { - pair_set_syntax_op(form, OP_INCREMENT_SA); - fx_annotate_arg(sc, cddr(value), sc->curlet); /* this sets fx_proc(arg) */ - set_opt2_pair(code, cddr(value)); - } - else - { - pair_set_syntax_op(form, OP_SET_S_A); - fx_annotate_arg(sc, cdr(code), sc->curlet); - }} - else - { - if (is_fxable(sc, value)) - { - pair_set_syntax_op(form, OP_SET_S_A); - fx_annotate_arg(sc, cdr(code), sc->curlet); - } - if ((is_safe_c_op(optimize_op(value))) && - (is_pair(cdr(value))) && - (settee == cadr(value)) && - (!is_null(cddr(value)))) - { - if (is_null(cdddr(value))) - { - if (is_fxable(sc, caddr(value))) - { - pair_set_syntax_op(form, OP_INCREMENT_SA); - fx_annotate_arg(sc, cddr(value), sc->curlet); /* this sets fx_proc(arg) */ - set_opt2_pair(code, cddr(value)); - }} - else - if ((is_null(cddddr(value))) && - (is_fxable(sc, caddr(value))) && - (is_fxable(sc, cadddr(value)))) - { - pair_set_syntax_op(form, OP_INCREMENT_SAA); - fx_annotate_args(sc, cddr(value), sc->curlet); - /* fx_annotate_arg(sc, cdddr(value), sc->curlet); */ - set_opt2_pair(code, cddr(value)); - }}}} - if ((is_h_optimized(value)) && - (is_safe_c_op(optimize_op(value))) && /* else might not be opt1_cfunc? (opt1_lambda probably) */ - (!is_unsafe(value)) && /* is_unsafe(value) can happen! */ - (is_not_null(cdr(value)))) /* (set! x (y)) */ - { - if (is_not_null(cddr(value))) - { - if ((caddr(value) == int_one) && - (cadr(value) == settee)) - { - if (opt1_cfunc(value) == sc->add_x1) - pair_set_syntax_op(form, OP_INCREMENT_BY_1); - else - if (opt1_cfunc(value) == sc->subtract_x1) - pair_set_syntax_op(form, OP_DECREMENT_BY_1); - } - else - if ((cadr(value) == int_one) && - (caddr(value) == settee) && - (opt1_cfunc(value) == sc->add_1x)) - pair_set_syntax_op(form, OP_INCREMENT_BY_1); - else - if ((settee == caddr(value)) && - (is_safe_symbol(cadr(value))) && - (car(value) == sc->cons_symbol)) - { - pair_set_syntax_op(form, OP_SET_CONS); - set_opt2_sym(code, cadr(value)); - }}}}}} + (!slot_has_setter(slot)) && + (!is_immutable(slot)) && + (!is_syntactic_symbol(settee))) + { + if (is_normal_symbol(value)) + { + s7_pointer slot1 = s7_slot(sc, value); + if ((is_slot(slot1)) && (!slot_has_setter(slot1))) + { + pair_set_syntax_op(form, OP_SET_S_S); + set_opt2_sym(code, value); + }} + else + if ((!is_pair(value)) || + ((is_quote(car(value))) && (is_pair(cdr(value))))) /* (quote . 1) ? */ + { + pair_set_syntax_op(form, OP_SET_S_C); + set_opt2_con(code, (is_pair(value)) ? cadr(value) : value); + } + else + { + pair_set_syntax_op(form, OP_SET_S_P); + if (is_optimized(value)) + { + if (optimize_op(value) == HOP_SAFE_C_SS) + { + if (settee == cadr(value)) + { + pair_set_syntax_op(form, OP_INCREMENT_SA); + fx_annotate_arg(sc, cddr(value), sc->curlet); /* this sets fx_proc(arg) */ + set_opt2_pair(code, cddr(value)); + } + else + { + pair_set_syntax_op(form, OP_SET_S_A); + fx_annotate_arg(sc, cdr(code), sc->curlet); + }} + else + { + if (is_fxable(sc, value)) + { + pair_set_syntax_op(form, OP_SET_S_A); + fx_annotate_arg(sc, cdr(code), sc->curlet); + } + if ((is_safe_c_op(optimize_op(value))) && + (is_pair(cdr(value))) && + (settee == cadr(value)) && + (!is_null(cddr(value)))) + { + if (is_null(cdddr(value))) + { + if (is_fxable(sc, caddr(value))) + { + pair_set_syntax_op(form, OP_INCREMENT_SA); + fx_annotate_arg(sc, cddr(value), sc->curlet); /* this sets fx_proc(arg) */ + set_opt2_pair(code, cddr(value)); + }} + else + if ((is_null(cddddr(value))) && + (is_fxable(sc, caddr(value))) && + (is_fxable(sc, cadddr(value)))) + { + pair_set_syntax_op(form, OP_INCREMENT_SAA); + fx_annotate_args(sc, cddr(value), sc->curlet); + /* fx_annotate_arg(sc, cdddr(value), sc->curlet); */ + set_opt2_pair(code, cddr(value)); + }}}} + if ((is_h_optimized(value)) && + (is_safe_c_op(optimize_op(value))) && /* else might not be opt1_cfunc? (opt1_lambda probably) */ + (!is_unsafe(value)) && /* is_unsafe(value) can happen! */ + (is_not_null(cdr(value)))) /* (set! x (y)) */ + { + if (is_not_null(cddr(value))) + { + if ((caddr(value) == int_one) && + (cadr(value) == settee)) + { + if (opt1_cfunc(value) == sc->add_x1) + pair_set_syntax_op(form, OP_INCREMENT_BY_1); + else + if (opt1_cfunc(value) == sc->subtract_x1) + pair_set_syntax_op(form, OP_DECREMENT_BY_1); + } + else + if ((cadr(value) == int_one) && + (caddr(value) == settee) && + (opt1_cfunc(value) == sc->add_1x)) + pair_set_syntax_op(form, OP_INCREMENT_BY_1); + else + if ((settee == caddr(value)) && + (is_safe_symbol(cadr(value))) && + (car(value) == sc->cons_symbol)) + { + pair_set_syntax_op(form, OP_SET_CONS); + set_opt2_sym(code, cadr(value)); + }}}}}} } static void op_set_s_c(s7_scheme *sc) @@ -79988,7 +79988,7 @@ static void op_set_safe(s7_scheme *sc) /* name is misleading -- we need to check if (is_slot(slot)) { if (is_immutable_slot(slot)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, sc->code)); + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, sc->code)); slot_set_value(slot, sc->value); } else @@ -80050,13 +80050,13 @@ static noreturn void no_setter_error_nr(s7_scheme *sc, s7_pointer obj) if (type(caar(sc->code)) >= T_C_FUNCTION_STAR) error_nr(sc, sc->no_setter_symbol, - set_elist_6(sc, wrap_string(sc, "~W (~A) does not have a setter: (set! (~W~{~^ ~S~}) ~S)", 55), - caar(sc->code), sc->type_names[typ], caar(sc->code), cdar(sc->code), cadr(sc->code))); + set_elist_6(sc, wrap_string(sc, "~W (~A) does not have a setter: (set! (~W~{~^ ~S~}) ~S)", 55), + caar(sc->code), sc->type_names[typ], caar(sc->code), cdar(sc->code), cadr(sc->code))); error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "~A (~A) does not have a setter: (set! ~S ~S)", 44), - caar(sc->code), sc->type_names[typ], - (is_pair(car(sc->code))) ? copy_any_list(sc, car(sc->code)) : car(sc->code), - (is_pair(cadr(sc->code))) ? copy_any_list(sc, cadr(sc->code)) : cadr(sc->code))); + set_elist_5(sc, wrap_string(sc, "~A (~A) does not have a setter: (set! ~S ~S)", 44), + caar(sc->code), sc->type_names[typ], + (is_pair(car(sc->code))) ? copy_any_list(sc, car(sc->code)) : car(sc->code), + (is_pair(cadr(sc->code))) ? copy_any_list(sc, cadr(sc->code)) : cadr(sc->code))); /* copy is necessary due to the way quoted lists|symbols are handled in op_set_with_let_1|2 and copy_tree * copy_proper_list can fail: (let ((x #f)) (map set! `((set! x (+ x 1)) (* x 2)) (hash-table 'a 1))) */ @@ -80066,7 +80066,7 @@ static bool pair3_cfunc(s7_scheme *sc, s7_pointer obj, s7_pointer setf, s7_point { if (!c_function_is_aritable(setf, 2)) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_6(sc, wrap_string(sc, "set!: two arguments? (~A ~S ~S), ~A is (setter ~A)", 50), setf, arg, value, setf, obj)); + set_elist_6(sc, wrap_string(sc, "set!: two arguments? (~A ~S ~S), ~A is (setter ~A)", 50), setf, arg, value, setf, obj)); if (!is_safe_procedure(setf)) /* if unsafe, we can't call c_function_call(setf) directly (need drop into eval+apply) */ { sc->code = setf; @@ -80099,24 +80099,24 @@ static bool set_pair3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_pointer sc->value = g_vector_set_3(sc, with_list_t3(obj, arg, value)); #else if (vector_rank(obj) > 1) - sc->value = g_vector_set(sc, with_list_t3(obj, arg, value)); + sc->value = g_vector_set(sc, with_list_t3(obj, arg, value)); else - { - s7_int index; - if (!is_t_integer(arg)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), sc->code)); - index = integer(arg); - if (index < 0) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must not be negative: ~S", 43), sc->code)); - if (index >= vector_length(obj)) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be less than vector length: ~S", 54), sc->code)); - if (is_immutable_vector(obj)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, obj)); - if (is_typed_vector(obj)) - value = typed_vector_setter(sc, obj, index, value); - else vector_element(obj, index) = value; - sc->value = T_Ext(value); - } + { + s7_int index; + if (!is_t_integer(arg)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), sc->code)); + index = integer(arg); + if (index < 0) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must not be negative: ~S", 43), sc->code)); + if (index >= vector_length(obj)) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be less than vector length: ~S", 54), sc->code)); + if (is_immutable_vector(obj)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, obj)); + if (is_typed_vector(obj)) + value = typed_vector_setter(sc, obj, index, value); + else vector_element(obj, index) = value; + sc->value = T_Ext(value); + } #endif break; @@ -80125,20 +80125,20 @@ static bool set_pair3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_pointer sc->value = g_string_set(sc, with_list_t3(obj, arg, value)); #else { - s7_int index; - if (!is_t_integer(arg)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "index must be an integer: ~S", 28), sc->code)); - index = integer(arg); - if (index < 0) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "index must not be negative: ~S", 30), sc->code)); - if (index >= string_length(obj)) - error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "index must be less than sequence length: ~S", 43), sc->code)); - if (is_immutable_string(obj)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->string_set_symbol, obj)); - if (!is_character(value)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "string-set!: value must be a character: ~S", 42), sc->code)); - string_value(obj)[index] = (char)s7_character(value); - sc->value = value; + s7_int index; + if (!is_t_integer(arg)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "index must be an integer: ~S", 28), sc->code)); + index = integer(arg); + if (index < 0) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "index must not be negative: ~S", 30), sc->code)); + if (index >= string_length(obj)) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "index must be less than sequence length: ~S", 43), sc->code)); + if (is_immutable_string(obj)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->string_set_symbol, obj)); + if (!is_character(value)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "string-set!: value must be a character: ~S", 42), sc->code)); + string_value(obj)[index] = (char)s7_character(value); + sc->value = value; } #endif break; @@ -80149,7 +80149,7 @@ static bool set_pair3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_pointer case T_HASH_TABLE: if (is_immutable_hash_table(obj)) /* not checked in s7_hash_table_set */ - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->hash_table_set_symbol, obj)); + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->hash_table_set_symbol, obj)); sc->value = s7_hash_table_set(sc, obj, arg, value); break; @@ -80160,14 +80160,14 @@ static bool set_pair3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_pointer case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION: case T_C_FUNCTION_STAR: /* obj here is a c_function, but its setter could be a closure and vice versa below */ if (is_c_function(c_function_setter(obj))) - return(pair3_cfunc(sc, obj, c_function_setter(obj), arg, value)); + return(pair3_cfunc(sc, obj, c_function_setter(obj), arg, value)); sc->code = c_function_setter(obj); /* closure/macro */ sc->args = (needs_copied_args(sc->code)) ? list_2(sc, arg, value) : set_plist_2(sc, arg, value); return(true); /* goto APPLY; not redundant -- setter type might not match getter type */ case T_C_MACRO: /* (set! (setter quasiquote) (lambda args args)) (define (f) (set! (quasiquote 1) (setter 'i))) (f) (f) */ if (is_c_function(c_macro_setter(obj))) - return(pair3_cfunc(sc, obj, c_macro_setter(obj), arg, value)); + return(pair3_cfunc(sc, obj, c_macro_setter(obj), arg, value)); sc->code = c_macro_setter(obj); sc->args = (needs_copied_args(sc->code)) ? list_2(sc, arg, value) : set_plist_2(sc, arg, value); return(true); /* goto APPLY; */ @@ -80176,7 +80176,7 @@ static bool set_pair3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_pointer case T_BACRO: case T_BACRO_STAR: case T_CLOSURE: case T_CLOSURE_STAR: if (is_c_function(closure_setter(obj))) - return(pair3_cfunc(sc, obj, closure_setter(obj), arg, value)); + return(pair3_cfunc(sc, obj, closure_setter(obj), arg, value)); sc->code = closure_setter(obj); sc->args = (needs_copied_args(sc->code)) ? list_2(sc, arg, value) : set_plist_2(sc, arg, value); return(true); /* goto APPLY; */ @@ -80194,7 +80194,7 @@ static bool op_set_opsq_a(s7_scheme *sc) /* (set! (symbol) fxable) */ if ((is_sequence(obj)) && (!is_c_object(obj))) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "set!: not enough arguments for ~S: ~S", 37), caar(code), sc->code)); + set_elist_3(sc, wrap_string(sc, "set!: not enough arguments for ~S: ~S", 37), caar(code), sc->code)); setf = setter_p_pp(sc, obj, sc->curlet); if (is_any_macro(setf)) @@ -80207,8 +80207,8 @@ static bool op_set_opsq_a(s7_scheme *sc) /* (set! (symbol) fxable) */ if (is_c_function(setf)) { if (c_function_min_args(setf) > 1) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "set!: not enough arguments: (~A ~S)", 35), setf, value)); + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "set!: not enough arguments: (~A ~S)", 35), setf, value)); sc->value = c_function_call(setf)(sc, with_list_t1(value)); return(false); } @@ -80226,11 +80226,11 @@ static bool op_set_opsaq_a(s7_scheme *sc) /* (set! (symbol fxable) fxable { s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = pair_append(sc, cdar(code), cdr(code)); - return(true); - }} + { + sc->code = setf; + sc->args = pair_append(sc, cdar(code), cdr(code)); + return(true); + }} value = fx_call(sc, cdr(code)); gc_protect_via_stack(sc, value); if (dont_eval_args(obj)) /* this check is expensive, 8 in tstar, similar lg, but it's faster than is_any_macro */ @@ -80256,11 +80256,11 @@ static inline bool op_set_opsaq_p(s7_scheme *sc) { s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = pair_append(sc, cdar(code), cdr(code)); - return(true); - }} + { + sc->code = setf; + sc->args = pair_append(sc, cdar(code), cdr(code)); + return(true); + }} push_stack(sc, OP_SET_opSAq_P_1, obj, code); sc->code = cadr(code); return(false); @@ -80280,7 +80280,7 @@ static bool pair4_cfunc(s7_scheme *sc, s7_pointer obj, s7_pointer setf, s7_point { if (!c_function_is_aritable(setf, 3)) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_7(sc, wrap_string(sc, "set!: three arguments? (~A ~S ~S ~S), ~A is (setter ~A)", 55), setf, index1, index2, value, setf, obj)); + set_elist_7(sc, wrap_string(sc, "set!: three arguments? (~A ~S ~S ~S), ~A is (setter ~A)", 55), setf, index1, index2, value, setf, obj)); if (!is_safe_procedure(setf)) { sc->code = setf; @@ -80310,12 +80310,12 @@ static bool set_pair4(s7_scheme *sc, s7_pointer obj, s7_pointer index1, s7_point break; case T_VECTOR: if (vector_rank(obj) == 2) - sc->value = g_vector_set_4(sc, set_plist_4(sc, obj, index1, index2, value)); + sc->value = g_vector_set_4(sc, set_plist_4(sc, obj, index1, index2, value)); else - { - sc->value = g_vector_ref(sc, with_list_t2(obj, index1)); - return(set_pair3(sc, sc->value, index2, value)); - } + { + sc->value = g_vector_ref(sc, with_list_t2(obj, index1)); + return(set_pair3(sc, sc->value, index2, value)); + } break; case T_PAIR: @@ -80333,14 +80333,14 @@ static bool set_pair4(s7_scheme *sc, s7_pointer obj, s7_pointer index1, s7_point case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION: case T_C_FUNCTION_STAR: /* obj here is any_c_function, but its setter could be a closure and vice versa below */ if (is_c_function(c_function_setter(obj))) - return(pair4_cfunc(sc, obj, c_function_setter(obj), index1, index2, value)); + return(pair4_cfunc(sc, obj, c_function_setter(obj), index1, index2, value)); sc->code = c_function_setter(obj); /* closure|macro */ sc->args = (needs_copied_args(sc->code)) ? list_3(sc, index1, index2, value) : set_plist_3(sc, index1, index2, value); return(true); /* goto APPLY; not redundant -- setter type might not match getter type */ case T_C_MACRO: /* (set! (setter quasiquote) (lambda (a . b) a)) (let () (define (func) (set! (quasiquote 'a 0) 3)) (func) (func)) */ if (is_c_function(c_macro_setter(obj))) - return(pair4_cfunc(sc, obj, c_macro_setter(obj), index1, index2, value)); + return(pair4_cfunc(sc, obj, c_macro_setter(obj), index1, index2, value)); sc->code = c_macro_setter(obj); sc->args = (needs_copied_args(sc->code)) ? list_3(sc, index1, index2, value) : set_plist_3(sc, index1, index2, value); return(true); /* goto APPLY; */ @@ -80349,7 +80349,7 @@ static bool set_pair4(s7_scheme *sc, s7_pointer obj, s7_pointer index1, s7_point case T_BACRO: case T_BACRO_STAR: case T_CLOSURE: case T_CLOSURE_STAR: if (is_c_function(closure_setter(obj))) - return(pair4_cfunc(sc, obj, closure_setter(obj), index1, index2, value)); + return(pair4_cfunc(sc, obj, closure_setter(obj), index1, index2, value)); sc->code = closure_setter(obj); sc->args = (needs_copied_args(sc->code)) ? list_3(sc, index1, index2, value) : set_plist_3(sc, index1, index2, value); return(true); /* goto APPLY; */ @@ -80369,11 +80369,11 @@ static bool op_set_opsaaq_a(s7_scheme *sc) /* (set! (symbol fxable fxable { s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = pair_append(sc, cdar(code), cdr(code)); - return(true); - }} + { + sc->code = setf; + sc->args = pair_append(sc, cdar(code), cdr(code)); + return(true); + }} value = fx_call(sc, cdr(code)); gc_protect_via_stack(sc, value); index1 = fx_call(sc, cdar(code)); @@ -80391,11 +80391,11 @@ static bool op_set_opsaaq_p(s7_scheme *sc) { s7_pointer setf = setter_p_pp(sc, obj, sc->curlet); if (is_any_macro(setf)) - { - sc->code = setf; - sc->args = pair_append(sc, cdar(code), cdr(code)); - return(true); - }} + { + sc->code = setf; + sc->args = pair_append(sc, cdar(code), cdr(code)); + return(true); + }} push_stack(sc, OP_SET_opSAAq_P_1, obj, code); sc->code = cadr(code); return(false); @@ -80419,28 +80419,28 @@ static bool op_set1(s7_scheme *sc) if (is_slot(lx)) { if (is_immutable_slot(lx)) - { - if (s7_is_eqv(sc, slot_value(lx), sc->value)) return(true); /* (set! pi pi) -- this can be confusing! */ - /* eqv? needed here because 0 != 0 if one is int_zero and the other a mutable_integer from a loop, etc */ - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, sym)); - } + { + if (s7_is_eqv(sc, slot_value(lx), sc->value)) return(true); /* (set! pi pi) -- this can be confusing! */ + /* eqv? needed here because 0 != 0 if one is int_zero and the other a mutable_integer from a loop, etc */ + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->set_symbol, sym)); + } if (slot_has_setter(lx)) - { - s7_pointer func = slot_setter(lx); - if (is_c_function(func)) - sc->value = call_c_function_setter(sc, func, sym, sc->value); /* perhaps better: apply_c_function -- has argnum error checks */ - else - if (is_any_procedure(func)) - { - /* don't push OP_EVAL_DONE here and call eval(sc, OP_APPLY) below -- setter might hit an error */ - /* 41297 (set! (v) val) where v=vector gets the setter, but calls vector-set! with no args */ - push_stack_no_args(sc, OP_SET_FROM_SETTER, lx); - if (has_let_arg(func)) - sc->args = list_3(sc, sym, sc->value, sc->curlet); - else sc->args = list_2(sc, sym, sc->value); /* these lists are reused as the closure_let slots in apply_lambda via apply_closure */ - sc->code = func; - return(false); /* goto APPLY */ - }} + { + s7_pointer func = slot_setter(lx); + if (is_c_function(func)) + sc->value = call_c_function_setter(sc, func, sym, sc->value); /* perhaps better: apply_c_function -- has argnum error checks */ + else + if (is_any_procedure(func)) + { + /* don't push OP_EVAL_DONE here and call eval(sc, OP_APPLY) below -- setter might hit an error */ + /* 41297 (set! (v) val) where v=vector gets the setter, but calls vector-set! with no args */ + push_stack_no_args(sc, OP_SET_FROM_SETTER, lx); + if (has_let_arg(func)) + sc->args = list_3(sc, sym, sc->value, sc->curlet); + else sc->args = list_2(sc, sym, sc->value); /* these lists are reused as the closure_let slots in apply_lambda via apply_closure */ + sc->code = func; + return(false); /* goto APPLY */ + }} slot_set_value(lx, sc->value); symbol_increment_ctr(sym); /* see define setfib example in s7test.scm -- I'm having second thoughts about this... */ return(true); /* continue */ @@ -80463,25 +80463,25 @@ static bool op_set_with_let_1(s7_scheme *sc) syntax_error_nr(sc, "with-let needs a let and a symbol: (set! (with-let) ~$)", 55, sc->value); if (!is_pair(cdr(sc->args))) /* (set! (with-let e) ...) */ error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "with-let in (set! (with-let ~S) ~$) has no symbol to set?", 57), car(sc->args), sc->value)); + set_elist_3(sc, wrap_string(sc, "with-let in (set! (with-let ~S) ~$) has no symbol to set?", 57), car(sc->args), sc->value)); e = car(sc->args); b = cadr(sc->args); if (is_multiple_value(x)) /* (set! (with-let lt) (values 1 2)) */ error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "can't (set! (with-let ~S ~S) (values ~{~S~^ ~})): too many values", 65), e, b, x)); + set_elist_4(sc, wrap_string(sc, "can't (set! (with-let ~S ~S) (values ~{~S~^ ~})): too many values", 65), e, b, x)); if (is_symbol(e)) { if (is_symbol(b)) - { - e = lookup_checked(sc, e); /* the let */ - if (!is_let(e)) - wrong_type_error_nr(sc, sc->let_set_symbol, 1, e, a_let_string); - sc->value = let_set_1(sc, e, b, x); - pop_stack(sc); - return(true); - } + { + e = lookup_checked(sc, e); /* the let */ + if (!is_let(e)) + wrong_type_error_nr(sc, sc->let_set_symbol, 1, e, a_let_string); + sc->value = let_set_1(sc, e, b, x); + pop_stack(sc); + return(true); + } sc->value = lookup_checked(sc, e); sc->code = set_plist_3(sc, sc->set_symbol, b, ((is_symbol(x)) || (is_pair(x))) ? set_plist_2(sc, sc->quote_function, x) : x); /* (let* ((x (vector 1 2)) (lt (curlet))) (set! (with-let lt (x 0)) 32) x) here: (set! (x 0) 32) */ @@ -80503,7 +80503,7 @@ static bool op_set_with_let_2(s7_scheme *sc) b = car(sc->args); if ((!is_symbol(b)) && (!is_pair(b))) error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "can't set ~S in ~$", 18), b, set_ulist_1(sc, global_value(sc->set_symbol), sc->args))); + set_elist_3(sc, wrap_string(sc, "can't set ~S in ~$", 18), b, set_ulist_1(sc, global_value(sc->set_symbol), sc->args))); x = cadr(sc->args); if (is_symbol(b)) /* b is a symbol -- everything else is ready so call let-set! */ { @@ -80512,7 +80512,7 @@ static bool op_set_with_let_2(s7_scheme *sc) } if ((is_symbol(x)) || (is_pair(x))) /* (set! (with-let (inlet :v (vector 1 2)) (v 0)) 'a) */ sc->code = list_3(sc, sc->set_symbol, b, - ((is_symbol(x)) || (is_pair(x))) ? list_2(sc, sc->quote_function, x) : x); + ((is_symbol(x)) || (is_pair(x))) ? list_2(sc, sc->quote_function, x) : x); else sc->code = cons(sc, sc->set_symbol, sc->args); /* (set! (with-let (curlet) (*s7* 'print-length)) 16), x=16 b=(*s7* 'print-length) */ return(false); /* fall into SET_WITH_LET */ } @@ -80543,21 +80543,21 @@ static Inline void inline_op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ct switch (type(val)) { case T_RATIO: - new_cell(sc, sc->value, T_RATIO); - set_numerator(sc->value, numerator(val) + denominator(val)); - set_denominator(sc->value, denominator(val)); - break; + new_cell(sc, sc->value, T_RATIO); + set_numerator(sc->value, numerator(val) + denominator(val)); + set_denominator(sc->value, denominator(val)); + break; case T_REAL: - sc->value = make_real(sc, real(val) + 1.0); - break; + sc->value = make_real(sc, real(val) + 1.0); + break; case T_COMPLEX: - new_cell(sc, sc->value, T_COMPLEX); - set_real_part(sc->value, real_part(val) + 1.0); - set_imag_part(sc->value, imag_part(val)); - break; + new_cell(sc, sc->value, T_COMPLEX); + set_real_part(sc->value, real_part(val) + 1.0); + set_imag_part(sc->value, imag_part(val)); + break; default: - sc->value = add_p_pp(sc, val, int_one); - break; + sc->value = add_p_pp(sc, val, int_one); + break; } slot_set_value(y, sc->value); } @@ -80572,21 +80572,21 @@ static void op_decrement_by_1(s7_scheme *sc) /* ([set!] ctr (- ctr 1)) */ switch (type(val)) { case T_RATIO: - new_cell(sc, sc->value, T_RATIO); - set_numerator(sc->value, numerator(val) - denominator(val)); - set_denominator(sc->value, denominator(val)); - break; + new_cell(sc, sc->value, T_RATIO); + set_numerator(sc->value, numerator(val) - denominator(val)); + set_denominator(sc->value, denominator(val)); + break; case T_REAL: - sc->value = make_real(sc, real(val) - 1.0); - break; + sc->value = make_real(sc, real(val) - 1.0); + break; case T_COMPLEX: - new_cell(sc, sc->value, T_COMPLEX); - set_real_part(sc->value, real_part(val) - 1.0); - set_imag_part(sc->value, imag_part(val)); - break; + new_cell(sc, sc->value, T_COMPLEX); + set_real_part(sc->value, real_part(val) - 1.0); + set_imag_part(sc->value, imag_part(val)); + break; default: - sc->value = g_subtract(sc, set_plist_2(sc, val, int_one)); - break; + sc->value = g_subtract(sc, set_plist_2(sc, val, int_one)); + break; } slot_set_value(y, sc->value); } @@ -80603,10 +80603,10 @@ static Inline bool inline_op_implicit_vector_ref_a(s7_scheme *sc) /* called once { s7_int index = s7_integer_clamped_if_gmp(sc, x); if ((index < vector_length(v)) && (index >= 0)) - { - sc->value = (is_float_vector(v)) ? make_real(sc, float_vector(v, index)) : vector_getter(v)(sc, v, index); - return(true); - }} + { + sc->value = (is_float_vector(v)) ? make_real(sc, float_vector(v, index)) : vector_getter(v)(sc, v, index); + return(true); + }} sc->value = vector_ref_1(sc, v, set_plist_1(sc, x)); return(true); } @@ -80622,7 +80622,7 @@ static s7_pointer fx_implicit_vector_ref_a(s7_scheme *sc, s7_pointer arg) { s7_int index = s7_integer_clamped_if_gmp(sc, x); if ((index < vector_length(v)) && (index >= 0)) - return(vector_getter(v)(sc, v, index)); + return(vector_getter(v)(sc, v, index)); } return(vector_ref_1(sc, v, set_plist_1(sc, x))); } @@ -80647,13 +80647,13 @@ static bool op_implicit_vector_ref_aa(s7_scheme *sc) /* if Inline 70 in concorda s7_int ix = s7_integer_clamped_if_gmp(sc, x); s7_int iy = s7_integer_clamped_if_gmp(sc, y); if ((ix >= 0) && (iy >= 0) && - (ix < vector_dimension(v, 0)) && (iy < vector_dimension(v, 1))) - { - s7_int index = (ix * vector_offset(v, 0)) + iy; - sc->value = vector_getter(v)(sc, v, index); /* check for normal vector saves in some cases, costs in others */ - unstack_gc_protect(sc); - return(true); - }} + (ix < vector_dimension(v, 0)) && (iy < vector_dimension(v, 1))) + { + s7_int index = (ix * vector_offset(v, 0)) + iy; + sc->value = vector_getter(v)(sc, v, index); /* check for normal vector saves in some cases, costs in others */ + unstack_gc_protect(sc); + return(true); + }} sc->value = vector_ref_1(sc, v, set_plist_2(sc, x, y)); unstack_gc_protect(sc); return(true); @@ -80721,21 +80721,21 @@ static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer vect, s7_pointer ind * sc->code here: ((v 0 'a) 32) */ if (vector_rank(vect) == 1) - { - s7_pointer ind = car(inds); - if (is_symbol(ind)) ind = lookup_checked(sc, ind); - if (is_t_integer(ind)) - { - s7_pointer obj; - s7_int index1 = integer(ind); - if ((index1 < 0) || (index1 >= vector_length(vect))) - out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, car(inds), (index1 < 0) ? it_is_negative_string : it_is_too_large_string); - obj = vector_element(vect, index1); - if (!is_applicable(obj)) - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~S) is ~S which can't take arguments", 47), form, vect, car(inds), obj)); - return(call_set_implicit(sc, obj, cdr(inds), val, form)); - }} + { + s7_pointer ind = car(inds); + if (is_symbol(ind)) ind = lookup_checked(sc, ind); + if (is_t_integer(ind)) + { + s7_pointer obj; + s7_int index1 = integer(ind); + if ((index1 < 0) || (index1 >= vector_length(vect))) + out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, car(inds), (index1 < 0) ? it_is_negative_string : it_is_too_large_string); + obj = vector_element(vect, index1); + if (!is_applicable(obj)) + error_nr(sc, sc->no_setter_symbol, + set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~S) is ~S which can't take arguments", 47), form, vect, car(inds), obj)); + return(call_set_implicit(sc, obj, cdr(inds), val, form)); + }} push_stack(sc, OP_SET2, cdr(inds), val); sc->code = list_2(sc, vect, car(inds)); return(goto_unopt); @@ -80744,48 +80744,48 @@ static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer vect, s7_pointer ind if ((argnum > 1) || (vector_rank(vect) > 1)) { if ((argnum == 2) && - (cdr(form) == sc->code) && /* form == cdr(sc->code) only on the outer call, thereafter form is the old form for better error messages */ - (is_fxable(sc, car(inds))) && - (is_fxable(sc, cadr(inds))) && - (is_fxable(sc, car(val)))) /* (set! (v fx fx) fx) */ - { - fx_annotate_args(sc, inds, sc->curlet); - fx_annotate_arg(sc, val, sc->curlet); - set_opt3_pair(form, cdr(inds)); - pair_set_syntax_op(form, OP_IMPLICIT_VECTOR_SET_4); - } + (cdr(form) == sc->code) && /* form == cdr(sc->code) only on the outer call, thereafter form is the old form for better error messages */ + (is_fxable(sc, car(inds))) && + (is_fxable(sc, cadr(inds))) && + (is_fxable(sc, car(val)))) /* (set! (v fx fx) fx) */ + { + fx_annotate_args(sc, inds, sc->curlet); + fx_annotate_arg(sc, val, sc->curlet); + set_opt3_pair(form, cdr(inds)); + pair_set_syntax_op(form, OP_IMPLICIT_VECTOR_SET_4); + } if ((argnum == vector_rank(vect)) && - (!is_pair(car(val)))) - { - s7_pointer p; - for (p = inds; is_pair(p); p = cdr(p)) - if (is_pair(car(p))) break; - if (is_null(p)) - { - s7_pointer pa; - s7_pointer args = safe_list_if_possible(sc, argnum + 2); - if (in_heap(args)) gc_protect_via_stack(sc, args); - set_car(args, vect); - for (p = inds, pa = cdr(args); is_pair(p); p = cdr(p), pa = cdr(pa)) - { - index = car(p); - if (is_symbol(index)) - index = lookup_checked(sc, index); - if (!s7_is_integer(index)) - { - if (in_heap(args)) unstack_gc_protect(sc); - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), form)); - } - set_car(pa, index); - } - set_car(pa, car(val)); - if (is_symbol(car(pa))) - set_car(pa, lookup_checked(sc, car(pa))); - sc->value = g_vector_set(sc, args); - if (in_heap(args)) unstack_gc_protect(sc); - else clear_list_in_use(args); - return(goto_start); - }} + (!is_pair(car(val)))) + { + s7_pointer p; + for (p = inds; is_pair(p); p = cdr(p)) + if (is_pair(car(p))) break; + if (is_null(p)) + { + s7_pointer pa; + s7_pointer args = safe_list_if_possible(sc, argnum + 2); + if (in_heap(args)) gc_protect_via_stack(sc, args); + set_car(args, vect); + for (p = inds, pa = cdr(args); is_pair(p); p = cdr(p), pa = cdr(pa)) + { + index = car(p); + if (is_symbol(index)) + index = lookup_checked(sc, index); + if (!s7_is_integer(index)) + { + if (in_heap(args)) unstack_gc_protect(sc); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), form)); + } + set_car(pa, index); + } + set_car(pa, car(val)); + if (is_symbol(car(pa))) + set_car(pa, lookup_checked(sc, car(pa))); + sc->value = g_vector_set(sc, args); + if (in_heap(args)) unstack_gc_protect(sc); + else clear_list_in_use(args); + return(goto_start); + }} push_op_stack(sc, sc->vector_set_function); /* vector_setter(vect) has wrong args */ sc->code = (is_null(cdr(inds))) ? val : ((is_null(cddr(inds))) ? cons(sc, cadr(inds), val) : pair_append(sc, cdr(inds), T_Lst(val))); /* i.e. rest(args) + val */ push_stack(sc, OP_EVAL_ARGS4, list_1(sc, vect), sc->code); @@ -80811,23 +80811,23 @@ static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer vect, s7_pointer ind s7_pointer value; if (is_symbol(index)) - index = lookup_checked(sc, index); + index = lookup_checked(sc, index); if (!s7_is_integer(index)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), sc->code)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "vector-set!: index must be an integer: ~S", 41), sc->code)); ind = s7_integer_clamped_if_gmp(sc, index); if ((ind < 0) || (ind >= vector_length(vect))) - out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); value = car(val); if (!is_pair(value)) - { - if (is_symbol(value)) - value = lookup_checked(sc, value); - if (is_typed_t_vector(vect)) - typed_vector_setter(sc, vect, ind, value); - else vector_setter(vect)(sc, vect, ind, value); - sc->value = T_Ext(value); - return(goto_start); - } + { + if (is_symbol(value)) + value = lookup_checked(sc, value); + if (is_typed_t_vector(vect)) + typed_vector_setter(sc, vect, ind, value); + else vector_setter(vect)(sc, vect, ind, value); + sc->value = T_Ext(value); + return(goto_start); + } push_op_stack(sc, sc->vector_set_function); sc->args = list_2(sc, index, vect); sc->code = val; @@ -80850,16 +80850,16 @@ static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer c_obj, s7_pointer { push_op_stack(sc, sc->c_object_set_function); if (is_null(inds)) - { - push_stack(sc, OP_EVAL_ARGS1, list_1(sc, c_obj), sc->nil); - sc->code = car(val); - } + { + push_stack(sc, OP_EVAL_ARGS1, list_1(sc, c_obj), sc->nil); + sc->code = car(val); + } else - { - sc->code = (is_null(cdr(inds))) ? cons(sc, car(inds), val) : pair_append(sc, cdr(inds), T_Lst(val)); - push_stack(sc, OP_EVAL_ARGS4, list_1(sc, c_obj), sc->code); - sc->code = car(inds); - } + { + sc->code = (is_null(cdr(inds))) ? cons(sc, car(inds), val) : pair_append(sc, cdr(inds), T_Lst(val)); + push_stack(sc, OP_EVAL_ARGS4, list_1(sc, c_obj), sc->code); + sc->code = car(inds); + } sc->cur_op = optimize_op(sc->code); return(goto_top_no_pop); } @@ -80868,14 +80868,14 @@ static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer c_obj, s7_pointer { s7_pointer value = car(val); if (is_symbol(index)) - index = lookup_checked(sc, index); + index = lookup_checked(sc, index); if (!is_pair(value)) - { - if (is_symbol(value)) - value = lookup_checked(sc, value); - sc->value = (*(c_object_set(sc, c_obj)))(sc, with_list_t3(c_obj, index, value)); - return(goto_start); - } + { + if (is_symbol(value)) + value = lookup_checked(sc, value); + sc->value = (*(c_object_set(sc, c_obj)))(sc, with_list_t3(c_obj, index, value)); + return(goto_start); + } push_op_stack(sc, sc->c_object_set_function); sc->args = list_2(sc, index, c_obj); sc->code = val; @@ -80928,28 +80928,28 @@ static goto_t set_implicit_string(s7_scheme *sc, s7_pointer str, s7_pointer inds { s7_int ind; if (is_symbol(index)) - index = lookup_checked(sc, index); + index = lookup_checked(sc, index); if (!s7_is_integer(index)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "index must be an integer: ~S", 28), form)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "index must be an integer: ~S", 28), form)); ind = s7_integer_clamped_if_gmp(sc, index); if ((ind < 0) || (ind >= string_length(str))) - out_of_range_error_nr(sc, sc->string_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + out_of_range_error_nr(sc, sc->string_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); if (is_immutable_string(str)) - immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->string_set_symbol, str)); + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->string_set_symbol, str)); val = car(val); if (!is_pair(val)) - { - if (is_symbol(val)) - val = lookup_checked(sc, val); - if (is_character(val)) - { - string_value(str)[ind] = character(val); - sc->value = val; - return(goto_start); - } - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "value must be a character: ~S", 29), form)); - } + { + if (is_symbol(val)) + val = lookup_checked(sc, val); + if (is_character(val)) + { + string_value(str)[ind] = character(val); + sc->value = val; + return(goto_start); + } + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "value must be a character: ~S", 29), form)); + } /* maybe op_implicit_string_set_a as in vector someday, but this code isn't (currently) called much */ push_op_stack(sc, sc->string_set_function); sc->args = list_2(sc, index, str); @@ -80978,13 +80978,13 @@ static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer lst, s7_pointer inds, { /* split (set! (a b c...) v) into (set! ((a b) c ...) v), eval (a b), return (let ((L (list (list 1 2)))) (set! (L 0 0) 3) L) */ if (index_val) - { - s7_pointer obj = list_ref_1(sc, lst, index_val); - if (!is_applicable(obj)) - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, lst, index_val, obj)); - return(call_set_implicit(sc, obj, cdr(inds), val, form)); - } + { + s7_pointer obj = list_ref_1(sc, lst, index_val); + if (!is_applicable(obj)) + error_nr(sc, sc->no_setter_symbol, + set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, lst, index_val, obj)); + return(call_set_implicit(sc, obj, cdr(inds), val, form)); + } push_stack(sc, OP_SET2, cdr(inds), val); /* (let ((L (list (list 1 2 3)))) (set! (L (- (length L) 1) 2) 0) L) */ sc->code = list_2(sc, caadr(form), car(inds)); return(goto_unopt); @@ -80992,12 +80992,12 @@ static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer lst, s7_pointer inds, if (index_val) { if (!is_pair(value)) - { - set_car(sc->t2_1, index_val); - set_car(sc->t2_2, (is_symbol(value)) ? lookup_checked(sc, value) : value); - sc->value = g_list_set_1(sc, lst, sc->t2_1, 2); - return(goto_start); - } + { + set_car(sc->t2_1, index_val); + set_car(sc->t2_2, (is_symbol(value)) ? lookup_checked(sc, value) : value); + sc->value = g_list_set_1(sc, lst, sc->t2_1, 2); + return(goto_start); + } push_op_stack(sc, sc->list_set_function); /* because cdr(inds) is nil, we're definitely calling list_set */ sc->args = list_2(sc, index_val, lst); /* plist unsafe here */ sc->code = val; @@ -81023,28 +81023,28 @@ static goto_t set_implicit_hash_table(s7_scheme *sc, s7_pointer table, s7_pointe if (is_pair(key)) { if (is_quote(car(key))) - keyval = cadr(key); + keyval = cadr(key); } else keyval = (is_normal_symbol(key)) ? lookup_checked(sc, key) : key; if (!is_null(cdr(inds))) { if (keyval) - { - s7_pointer obj = s7_hash_table_ref(sc, table, keyval); - if (obj == sc->F) /* (let ((h (hash-table 'b 1))) (set! (h 'a 'asdf) 32)) */ - error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "in ~S, ~$ does not exist in ~S", 30), form, keyval, table)); - else - if (!is_applicable(obj)) /* (let ((h (hash-table 'b 1))) (set! (h 'b 'asdf) 32)) */ - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, table, keyval, obj)); - /* (let ((v (hash-table 'a (hash-table 'b 1)))) (set! (v 'a 'b 'b) 32) v) -> - * error: in (set! (v 'a 'b 'b) 32), ((hash-table 'b 1) 'b) is 1 which can't take arguments - * (let ((v (hash-table 'a (list 1 2)))) (set! (v 'a 1) 5)) -> code: (set! ((1 2) 1) 5) -> 5 (v: (hash-table 'a (1 5))) - */ - return(call_set_implicit(sc, obj, cdr(inds), val, form)); - } + { + s7_pointer obj = s7_hash_table_ref(sc, table, keyval); + if (obj == sc->F) /* (let ((h (hash-table 'b 1))) (set! (h 'a 'asdf) 32)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "in ~S, ~$ does not exist in ~S", 30), form, keyval, table)); + else + if (!is_applicable(obj)) /* (let ((h (hash-table 'b 1))) (set! (h 'b 'asdf) 32)) */ + error_nr(sc, sc->no_setter_symbol, + set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, table, keyval, obj)); + /* (let ((v (hash-table 'a (hash-table 'b 1)))) (set! (v 'a 'b 'b) 32) v) -> + * error: in (set! (v 'a 'b 'b) 32), ((hash-table 'b 1) 'b) is 1 which can't take arguments + * (let ((v (hash-table 'a (list 1 2)))) (set! (v 'a 1) 5)) -> code: (set! ((1 2) 1) 5) -> 5 (v: (hash-table 'a (1 5))) + */ + return(call_set_implicit(sc, obj, cdr(inds), val, form)); + } push_stack(sc, OP_SET2, cdr(inds), val); /* (let ((L (hash-table 'b (hash-table 'a 1)))) (set! (L (symbol "b") (symbol "a")) 0) L) */ sc->code = list_2(sc, caadr(form), key); /* plist unsafe */ return(goto_unopt); @@ -81053,17 +81053,17 @@ static goto_t set_implicit_hash_table(s7_scheme *sc, s7_pointer table, s7_pointe { s7_pointer value = car(val); if (is_pair(value)) - { - if (is_quote(car(value))) - { - sc->value = s7_hash_table_set(sc, table, keyval, cadr(value)); - return(goto_start); - }} + { + if (is_quote(car(value))) + { + sc->value = s7_hash_table_set(sc, table, keyval, cadr(value)); + return(goto_start); + }} else - { - sc->value = s7_hash_table_set(sc, table, keyval, (is_normal_symbol(value)) ? lookup_checked(sc, value) : value); - return(goto_start); - } + { + sc->value = s7_hash_table_set(sc, table, keyval, (is_normal_symbol(value)) ? lookup_checked(sc, value) : value); + return(goto_start); + } push_op_stack(sc, sc->hash_table_set_function); /* because cdr(inds) is nil, we're definitely calling hash_table_set */ sc->args = list_2(sc, keyval, table); /* plist unsafe here */ sc->code = val; @@ -81087,20 +81087,20 @@ static goto_t set_implicit_let(s7_scheme *sc, s7_pointer let, s7_pointer inds, s if (is_pair(sym)) { if (is_quote(car(sym))) - symval = cadr(sym); + symval = cadr(sym); } else symval = (is_normal_symbol(sym)) ? lookup_checked(sc, sym) : sym; if (!is_null(cdr(inds))) { if (symval) - { - s7_pointer obj = let_ref(sc, let, symval); - if (!is_applicable(obj)) /* (let ((h (hash-table 'b 1))) (set! (h 'b 'asdf) 32)) */ - error_nr(sc, sc->no_setter_symbol, - set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, let, symval, obj)); - return(call_set_implicit(sc, obj, cdr(inds), val, form)); - } + { + s7_pointer obj = let_ref(sc, let, symval); + if (!is_applicable(obj)) /* (let ((h (hash-table 'b 1))) (set! (h 'b 'asdf) 32)) */ + error_nr(sc, sc->no_setter_symbol, + set_elist_5(sc, wrap_string(sc, "in ~S, (~S ~$) is ~S which can't take arguments", 47), form, let, symval, obj)); + return(call_set_implicit(sc, obj, cdr(inds), val, form)); + } push_stack(sc, OP_SET2, cdr(inds), val); sc->code = list_2(sc, let, car(inds)); return(goto_unopt); @@ -81109,12 +81109,12 @@ static goto_t set_implicit_let(s7_scheme *sc, s7_pointer let, s7_pointer inds, s { s7_pointer value = car(val); if (!is_pair(value)) - { - if (is_symbol(value)) - value = lookup_checked(sc, value); - sc->value = let_set_2(sc, let, symval, value); - return(goto_start); - } + { + if (is_symbol(value)) + value = lookup_checked(sc, value); + sc->value = let_set_2(sc, let, symval, value); + return(goto_start); + } push_op_stack(sc, sc->let_set_function); sc->args = list_2(sc, symval, let); sc->code = val; @@ -81132,7 +81132,7 @@ static goto_t set_implicit_c_function(s7_scheme *sc, s7_pointer fnc) /* (let (( if (!is_t_procedure(c_function_setter(fnc))) { if (!is_any_macro(c_function_setter(fnc))) - no_setter_error_nr(sc, fnc); + no_setter_error_nr(sc, fnc); sc->args = (is_null(cdar(sc->code))) ? cdr(sc->code) : ((is_null(cddar(sc->code))) ? cons(sc, cadar(sc->code), cdr(sc->code)) : pair_append(sc, cdar(sc->code), cdr(sc->code))); sc->code = c_function_setter(fnc); @@ -81148,13 +81148,13 @@ static goto_t set_implicit_c_function(s7_scheme *sc, s7_pointer fnc) /* (let (( else { if (is_null(cddar(sc->code))) /* (set! (fnc ind) val) */ - push_stack(sc, OP_EVAL_SET2, cadr(sc->code), c_function_setter(fnc)); + push_stack(sc, OP_EVAL_SET2, cadr(sc->code), c_function_setter(fnc)); else - { - push_op_stack(sc, c_function_setter(fnc)); - sc->value = pair_append(sc, cddar(sc->code), cdr(sc->code)); - push_stack(sc, OP_EVAL_SET3, sc->nil, sc->value); /* args=evalled, code=unevalled */ - } + { + push_op_stack(sc, c_function_setter(fnc)); + sc->value = pair_append(sc, cddar(sc->code), cdr(sc->code)); + push_stack(sc, OP_EVAL_SET3, sc->nil, sc->value); /* args=evalled, code=unevalled */ + } sc->code = cadar(sc->code); } sc->cur_op = optimize_op(sc->code); @@ -81169,7 +81169,7 @@ static goto_t set_implicit_closure(s7_scheme *sc, s7_pointer fnc) if (!is_t_procedure(setter)) { if (!is_any_macro(setter)) - no_setter_error_nr(sc, fnc); + no_setter_error_nr(sc, fnc); sc->args = (is_null(cdar(sc->code))) ? cdr(sc->code) : ((is_null(cddar(sc->code))) ? cons(sc, cadar(sc->code), cdr(sc->code)) : pair_append(sc, cdar(sc->code), cdr(sc->code))); sc->code = setter; @@ -81183,13 +81183,13 @@ static goto_t set_implicit_closure(s7_scheme *sc, s7_pointer fnc) else { if (is_null(cddar(sc->code))) /* (set! (fnc ind) val) */ - push_stack(sc, OP_EVAL_SET2, cadr(sc->code), setter); + push_stack(sc, OP_EVAL_SET2, cadr(sc->code), setter); else /* (set! (fnc inds ...) val) */ - { - push_op_stack(sc, setter); - sc->value = pair_append(sc, cddar(sc->code), cdr(sc->code)); - push_stack(sc, OP_EVAL_SET3, sc->nil, sc->value); /* args=evalled, code=unevalled */ - } + { + push_op_stack(sc, setter); + sc->value = pair_append(sc, cddar(sc->code), cdr(sc->code)); + push_stack(sc, OP_EVAL_SET3, sc->nil, sc->value); /* args=evalled, code=unevalled */ + } sc->code = cadar(sc->code); /* "ind" above */ } sc->cur_op = optimize_op(sc->code); @@ -81206,7 +81206,7 @@ static goto_t set_implicit_iterator(s7_scheme *sc, s7_pointer iter) if (!is_null(cdar(sc->code))) /* (set! (iter ...) val) but iter is a thunk */ error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "~S (an iterator): too many arguments: ~S", 40), iter, sc->code)); + set_elist_3(sc, wrap_string(sc, "~S (an iterator): too many arguments: ~S", 40), iter, sc->code)); if (is_procedure(setter)) { @@ -81263,12 +81263,12 @@ static goto_t call_set_implicit(s7_scheme *sc, s7_pointer obj, s7_pointer inds, default: /* (set! (1 2) 3) */ if (is_applicable(obj)) - no_setter_error_nr(sc, obj); /* this is reachable if obj is a goto or continuation: (set! (go 1) 2) in s7test.scm */ + no_setter_error_nr(sc, obj); /* this is reachable if obj is a goto or continuation: (set! (go 1) 2) in s7test.scm */ error_nr(sc, sc->no_setter_symbol, - list_3(sc, wrap_string(sc, "in ~S, ~S has no setter", 23), - cons_unchecked(sc, sc->set_symbol, /* copy_tree(sc, form) also works but copies too much: we want to copy the ulists */ - cons(sc, copy_proper_list(sc, cadr(form)), cddr(form))), - obj)); + list_3(sc, wrap_string(sc, "in ~S, ~S has no setter", 23), + cons_unchecked(sc, sc->set_symbol, /* copy_tree(sc, form) also works but copies too much: we want to copy the ulists */ + cons(sc, copy_proper_list(sc, cadr(form)), cddr(form))), + obj)); } return(goto_top_no_pop); } @@ -81288,10 +81288,10 @@ static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) .. obj = caar_code; else { - push_stack(sc, OP_SET2, cdar(sc->code), T_Pair(cdr(sc->code))); - sc->code = caar_code; - sc->cur_op = optimize_op(sc->code); - return(goto_top_no_pop); + push_stack(sc, OP_SET2, cdar(sc->code), T_Pair(cdr(sc->code))); + sc->code = caar_code; + sc->cur_op = optimize_op(sc->code); + return(goto_top_no_pop); } /* code here is the setter and the value without the "set!": ((window-width) 800), (set! (hi 0) (* 2 3)) -> ((hi 0) (* 2 3)) */ /* for gmp case, indices need to be decoded via s7_integer, not just integer */ @@ -81302,10 +81302,10 @@ static noreturn void set_with_let_error_nr(s7_scheme *sc) { s7_pointer target = cadr(sc->code), value = caddr(sc->code); error_nr(sc, sc->no_setter_symbol, - set_elist_3(sc, wrap_string(sc, "can't set ~A in ~S", 18), target, - list_3(sc, sc->set_symbol, - (is_pair(target)) ? copy_proper_list(sc, target) : target, - (is_pair(value)) ? copy_proper_list(sc, value) : value))); + set_elist_3(sc, wrap_string(sc, "can't set ~A in ~S", 18), target, + list_3(sc, sc->set_symbol, + (is_pair(target)) ? copy_proper_list(sc, target) : target, + (is_pair(value)) ? copy_proper_list(sc, value) : value))); } static goto_t op_set2(s7_scheme *sc) @@ -81323,20 +81323,20 @@ static goto_t op_set2(s7_scheme *sc) * (let ((L '((1 2 3))) (index 1)) (set! ((L 0) index) 32) L) */ if (!s7_is_proper_list(sc, sc->args)) /* (set! ('(1 2) 1 . 2) 1) */ - syntax_error_nr(sc, "set! target arguments are an improper list: ~A", 46, sc->args); + syntax_error_nr(sc, "set! target arguments are an improper list: ~A", 46, sc->args); if (is_multiple_value(sc->value)) /* (set! ((values fnc 0)) 32) etc */ - { - if (is_null(sc->args)) - { /* can't assume we're in list-set! here -- first value is target */ - sc->code = list_3(sc, sc->set_symbol, multiple_value(sc->value), car(sc->code)); - return(goto_eval); - } - else /* this has to be at least 2 args, sc->args and sc->code make 2 more, so... */ - syntax_error_nr(sc, "set!: too many arguments: ~S", 28, - set_ulist_1(sc, sc->set_symbol, pair_append(sc, multiple_value(sc->value), pair_append(sc, sc->args, T_Lst(sc->code))))); - } + { + if (is_null(sc->args)) + { /* can't assume we're in list-set! here -- first value is target */ + sc->code = list_3(sc, sc->set_symbol, multiple_value(sc->value), car(sc->code)); + return(goto_eval); + } + else /* this has to be at least 2 args, sc->args and sc->code make 2 more, so... */ + syntax_error_nr(sc, "set!: too many arguments: ~S", 28, + set_ulist_1(sc, sc->set_symbol, pair_append(sc, multiple_value(sc->value), pair_append(sc, sc->args, T_Lst(sc->code))))); + } if (is_null(sc->args)) - syntax_error_nr(sc, "list set!: not enough arguments: ~S", 35, sc->code); + syntax_error_nr(sc, "list set!: not enough arguments: ~S", 35, sc->code); push_op_stack(sc, sc->list_set_function); if (!is_null(cdr(sc->args))) sc->code = pair_append(sc, cdr(sc->args), T_Lst(sc->code)); push_stack(sc, OP_EVAL_ARGS4, list_1(sc, sc->value), T_Pair(sc->code)); @@ -81350,7 +81350,7 @@ static goto_t op_set2(s7_scheme *sc) * bad case when args is nil: (let ((L #(#(1 2 3) #(4 5 6)))) (set! ((L 1)) 32) L) */ if (sc->args == sc->nil) - syntax_error_nr(sc, "vector set!: not enough arguments: ~S", 37, sc->code); + syntax_error_nr(sc, "vector set!: not enough arguments: ~S", 37, sc->code); push_op_stack(sc, sc->vector_set_function); if (!is_null(cdr(sc->args))) sc->code = pair_append(sc, cdr(sc->args), T_Lst(sc->code)); push_stack(sc, OP_EVAL_ARGS4, list_1(sc, sc->value), T_Pair(sc->code)); @@ -81374,9 +81374,9 @@ static bool safe_stepper_expr(s7_pointer expr, const s7_pointer var) if (is_pair(p)) { if ((is_optimized(p)) && - (op_has_hop(p)) && - (is_safe_c_op(optimize_op(p)))) - return(true); + (op_has_hop(p)) && + (is_safe_c_op(optimize_op(p)))) + return(true); if (car(p) == var) return(false); } else @@ -81389,7 +81389,7 @@ static bool tree_match(s7_pointer tree) if (is_symbol(tree)) return(is_matched_symbol(tree)); return((is_pair(tree)) && - ((tree_match(car(tree))) || (tree_match(cdr(tree))))); + ((tree_match(car(tree))) || (tree_match(cdr(tree))))); } static bool all_ints_here(s7_scheme *sc, s7_pointer settee, s7_pointer expr, s7_pointer step_vars) /* see also all_integers above */ @@ -81403,14 +81403,14 @@ static bool all_ints_here(s7_scheme *sc, s7_pointer settee, s7_pointer expr, s7_ s7_pointer val; if (expr == settee) return(true); for (s7_pointer step = step_vars; is_pair(step); step = cdr(step)) - if (caar(step) == expr) - { - if (!all_ints_here(sc, caar(step), cadar(step), step_vars)) /* TODO: can we lookup step_vars here? or only in do_is_safe? */ - return(false); - if (is_pair(cddar(step))) - return(all_ints_here(sc, caar(step), caddar(step), step_vars)); - return(true); - } + if (caar(step) == expr) + { + if (!all_ints_here(sc, caar(step), cadar(step), step_vars)) /* TODO: can we lookup step_vars here? or only in do_is_safe? */ + return(false); + if (is_pair(cddar(step))) + return(all_ints_here(sc, caar(step), caddar(step), step_vars)); + return(true); + } val = lookup_unexamined(sc, expr); return((val) && (is_t_integer(val))); } @@ -81429,7 +81429,7 @@ static bool all_ints_here(s7_scheme *sc, s7_pointer settee, s7_pointer expr, s7_ if ((is_pair(sig)) && ((car(sig) == sc->is_integer_symbol) || (car(sig) == sc->is_byte_symbol) || ((is_pair(car(sig))) && - ((direct_memq(sc->is_integer_symbol, car(sig))) || (direct_memq(sc->is_byte_symbol, car(sig))))))) + ((direct_memq(sc->is_integer_symbol, car(sig))) || (direct_memq(sc->is_byte_symbol, car(sig))))))) return(true); /* like int-vector or length */ if (!is_all_integer(car(expr))) return(false); for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) @@ -81449,225 +81449,225 @@ static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_po { s7_pointer expr = car(p); if (is_pair(expr)) - { - s7_pointer x = car(expr); - - if ((!is_symbol(x)) && (!is_safe_c_function(x)) && (x != sc->quote_function)) - 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 - */ - - if (is_symbol_and_syntactic(x)) - { - s7_pointer func = global_value(x), vars, cp; - opcode_t op = syntax_opcode(func); - switch (op) - { - case OP_MACROEXPAND: - return(false); - - case OP_QUOTE: - if ((!is_pair(cdr(expr))) || (!is_null(cddr(expr)))) /* (quote . 1) or (quote 1 2) etc */ - return(false); - break; - - case OP_LET: case OP_LET_STAR: - case OP_LETREC: case OP_LETREC_STAR: - if ((!is_pair(cdr(expr))) || - (!is_list(cadr(expr))) || - (!is_pair(cddr(expr)))) - return(false); - cp = var_list; - for (vars = cadr(expr); is_pair(vars); vars = cdr(vars)) - { - s7_pointer var; - if (!is_pair(car(vars))) return(false); - var = caar(vars); - if (direct_memq(var, ((op == OP_LET) || (op == OP_LETREC)) ? cp : var_list)) return(false); - if ((!is_symbol(var)) || (is_keyword(var))) return(false); - cp = cons(sc, var, cp); - sc->x = cp; - } - sc->x = sc->unused; - if (!do_is_safe(sc, cddr(expr), stepper, cp, step_vars, has_set)) return(false); - break; - - case OP_DO: - { - s7_pointer combined_vars; - if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (do) or (do (...)) */ - return(false); - cp = var_list; - sc->w = (is_pair(cadr(expr))) ? pair_append(sc, cadr(expr), step_vars) : step_vars; - combined_vars = sc->w; - for (vars = cadr(expr); is_pair(vars); vars = cdr(vars)) - { - s7_pointer var; - if (!is_pair(car(vars))) return(false); - var = caar(vars); - if ((direct_memq(var, cp)) || (var == stepper)) return(false); - cp = cons(sc, var, cp); - sc->x = cp; - if ((is_pair(cdar(vars))) && - (!do_is_safe(sc, cdar(vars), stepper, cp, combined_vars, has_set))) - { - sc->x = sc->unused; - return(false); - }} - sc->x = sc->unused; - if (!do_is_safe(sc, caddr(expr), stepper, cp, combined_vars, has_set)) return(false); - if ((is_pair(cdddr(expr))) && - (!do_is_safe(sc, cadddr(expr), stepper, cp, combined_vars, has_set))) - return(false); - } - break; - - case OP_SET: - { - s7_pointer settee; - if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (set!) or (set! x) */ - return(false); - settee = cadr(expr); - if (!is_symbol(settee)) /* (set! (...) ...) which is tricky due to setter functions/macros */ - { - s7_pointer setv; - if ((!is_pair(settee)) || (!is_symbol(car(settee)))) - return(false); - setv = lookup_unexamined(sc, car(settee)); - if (!((setv) && - ((is_sequence(setv)) || - ((is_c_function(setv)) && - (is_safe_procedure(c_function_setter(setv))))))) - return(false); - - /* if ((has_set) && (!is_sequence(setv))) (*has_set) = true; */ - /* ^ trouble in tmock.scm (opt2_fn not set) -- apparently op_simple_do assumes has_fn which set! lacks */ - if (has_set) (*has_set) = true; - } - else - { - s7_pointer end_and_result = caddr(sc->code); - if ((is_pair(end_and_result)) && /* sc->code = do-form (formerly (cdr(do-form)) causing a bug here) */ - (is_pair(car(end_and_result))) && - (!is_syntax(caar(end_and_result)))) /* 10-Jan-24 */ - { - bool res; - set_match_symbol(settee); - res = tree_match(car(end_and_result)); /* (set! end ...) in some fashion */ - clear_match_symbol(settee); - if (res) return(false); - } - if (!direct_memq(settee, var_list)) /* is some local variable being set? */ - { - s7_pointer val = lookup_unexamined(sc, settee); - if (has_set) (*has_set) = true; - if ((val) && (is_t_integer(val)) && (!all_ints_here(sc, settee, caddr(expr), step_vars))) - return(false); - }} - if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) - return(false); - if (!safe_stepper_expr(expr, stepper)) /* is step var's value used as the stored value by set!? */ - return(false); - } - break; - - case OP_LET_TEMPORARILY: - if ((!is_pair(cdr(expr))) || - (!is_pair(cadr(expr))) || - (!is_pair(cddr(expr)))) - return(false); - for (cp = cadr(expr); is_pair(cp); cp = cdr(cp)) - if ((!is_pair(car(cp))) || - (!is_pair(cdar(cp))) || - (!do_is_safe(sc, cdar(cp), stepper, var_list, step_vars, has_set))) - return(false); - if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) return(false); - break; - - case OP_COND: - for (cp = cdr(expr); is_pair(cp); cp = cdr(cp)) - if (!do_is_safe(sc, car(cp), stepper, var_list, step_vars, has_set)) - return(false); - break; - - case OP_CASE: - if ((!is_pair(cdr(expr))) || - (!do_is_safe(sc, cadr(expr), stepper, var_list, step_vars, has_set))) - return(false); - for (cp = cddr(expr); is_pair(cp); cp = cdr(cp)) - if ((!is_pair(car(cp))) || /* (case x #(123)...) */ - (!do_is_safe(sc, cdar(cp), stepper, var_list, step_vars, has_set))) - return(false); - break; - - case OP_IF: case OP_WHEN: case OP_UNLESS: - case OP_AND: case OP_OR: case OP_BEGIN: - case OP_WITH_BAFFLE: - if (!do_is_safe(sc, cdr(expr), stepper, var_list, step_vars, has_set)) - return(false); - break; - - case OP_WITH_LET: - return(false); /* 11-Jan-24, this was true!? */ - - default: - return(false); - }} /* is_syntax(x=car(expr)) */ - else - if (x == sc->quote_function) - { - if ((!is_pair(cdr(expr))) || (!is_null(cddr(expr)))) /* (#_quote . 1) or (#_quote 1 2) etc */ - return(false); - } - else - { - /* if a macro, we'll eventually expand it (if *_optimize), but that requires a symbol lookup here and macroexpand */ - if ((!is_optimized(expr)) || - (optimize_op(expr) == OP_UNKNOWN_NP) || - (!do_is_safe(sc, cdr(expr), stepper, var_list, step_vars, has_set))) - return(false); - - /* is this still needed? fx_c_optcq bug -- tests seem ok without it -- 3.5 in tmat */ - if ((is_symbol(x)) && (is_slot(global_slot(x))) && (is_syntax(global_value(x)))) /* maybe (x == sc->immutable_symbol)? */ - return(false); /* syntax hidden behind some other name */ - - if ((is_symbol(x)) && (is_setter(x))) /* "setter" includes stuff like cons and vector -- x is a symbol */ - { - /* (hash-table-set! ht i 0) -- caddr is being saved, so this is not safe - * similarly (vector-set! v 0 i) etc - */ - if (is_null(cdr(expr))) - { - if (is_null(cdr(p))) /* (vector) for example */ - return((x == sc->vector_symbol) || (x == sc->list_symbol) || (x == sc->string_symbol)); - } - else - { - if ((has_set) && - (!direct_memq(cadr(expr), var_list)) && /* non-local is being changed */ - ((cadr(expr) == stepper) || /* stepper is being set? */ - (!is_pair(cddr(expr))) || - (!is_pair(cdddr(expr))) || - (is_pair(cddddr(expr))) || - ((x == sc->hash_table_set_symbol) && (caddr(expr) == stepper)) || - (cadddr(expr) == stepper) || /* used to check is_symbol here and above but that's unnecessary */ - ((is_pair(cadddr(expr))) && (s7_tree_memq(sc, stepper, cadddr(expr)))))) - (*has_set) = true; - - if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) - return(false); - if (!safe_stepper_expr(expr, stepper)) - return(false); - }}}}} + { + s7_pointer x = car(expr); + + if ((!is_symbol(x)) && (!is_safe_c_function(x)) && (x != sc->quote_function)) + 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 + */ + + if (is_symbol_and_syntactic(x)) + { + s7_pointer func = global_value(x), vars, cp; + opcode_t op = syntax_opcode(func); + switch (op) + { + case OP_MACROEXPAND: + return(false); + + case OP_QUOTE: + if ((!is_pair(cdr(expr))) || (!is_null(cddr(expr)))) /* (quote . 1) or (quote 1 2) etc */ + return(false); + break; + + case OP_LET: case OP_LET_STAR: + case OP_LETREC: case OP_LETREC_STAR: + if ((!is_pair(cdr(expr))) || + (!is_list(cadr(expr))) || + (!is_pair(cddr(expr)))) + return(false); + cp = var_list; + for (vars = cadr(expr); is_pair(vars); vars = cdr(vars)) + { + s7_pointer var; + if (!is_pair(car(vars))) return(false); + var = caar(vars); + if (direct_memq(var, ((op == OP_LET) || (op == OP_LETREC)) ? cp : var_list)) return(false); + if ((!is_symbol(var)) || (is_keyword(var))) return(false); + cp = cons(sc, var, cp); + sc->x = cp; + } + sc->x = sc->unused; + if (!do_is_safe(sc, cddr(expr), stepper, cp, step_vars, has_set)) return(false); + break; + + case OP_DO: + { + s7_pointer combined_vars; + if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (do) or (do (...)) */ + return(false); + cp = var_list; + sc->w = (is_pair(cadr(expr))) ? pair_append(sc, cadr(expr), step_vars) : step_vars; + combined_vars = sc->w; + for (vars = cadr(expr); is_pair(vars); vars = cdr(vars)) + { + s7_pointer var; + if (!is_pair(car(vars))) return(false); + var = caar(vars); + if ((direct_memq(var, cp)) || (var == stepper)) return(false); + cp = cons(sc, var, cp); + sc->x = cp; + if ((is_pair(cdar(vars))) && + (!do_is_safe(sc, cdar(vars), stepper, cp, combined_vars, has_set))) + { + sc->x = sc->unused; + return(false); + }} + sc->x = sc->unused; + if (!do_is_safe(sc, caddr(expr), stepper, cp, combined_vars, has_set)) return(false); + if ((is_pair(cdddr(expr))) && + (!do_is_safe(sc, cadddr(expr), stepper, cp, combined_vars, has_set))) + return(false); + } + break; + + case OP_SET: + { + s7_pointer settee; + if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (set!) or (set! x) */ + return(false); + settee = cadr(expr); + if (!is_symbol(settee)) /* (set! (...) ...) which is tricky due to setter functions/macros */ + { + s7_pointer setv; + if ((!is_pair(settee)) || (!is_symbol(car(settee)))) + return(false); + setv = lookup_unexamined(sc, car(settee)); + if (!((setv) && + ((is_sequence(setv)) || + ((is_c_function(setv)) && + (is_safe_procedure(c_function_setter(setv))))))) + return(false); + + /* if ((has_set) && (!is_sequence(setv))) (*has_set) = true; */ + /* ^ trouble in tmock.scm (opt2_fn not set) -- apparently op_simple_do assumes has_fn which set! lacks */ + if (has_set) (*has_set) = true; + } + else + { + s7_pointer end_and_result = caddr(sc->code); + if ((is_pair(end_and_result)) && /* sc->code = do-form (formerly (cdr(do-form)) causing a bug here) */ + (is_pair(car(end_and_result))) && + (!is_syntax(caar(end_and_result)))) /* 10-Jan-24 */ + { + bool res; + set_match_symbol(settee); + res = tree_match(car(end_and_result)); /* (set! end ...) in some fashion */ + clear_match_symbol(settee); + if (res) return(false); + } + if (!direct_memq(settee, var_list)) /* is some local variable being set? */ + { + s7_pointer val = lookup_unexamined(sc, settee); + if (has_set) (*has_set) = true; + if ((val) && (is_t_integer(val)) && (!all_ints_here(sc, settee, caddr(expr), step_vars))) + return(false); + }} + if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) + return(false); + if (!safe_stepper_expr(expr, stepper)) /* is step var's value used as the stored value by set!? */ + return(false); + } + break; + + case OP_LET_TEMPORARILY: + if ((!is_pair(cdr(expr))) || + (!is_pair(cadr(expr))) || + (!is_pair(cddr(expr)))) + return(false); + for (cp = cadr(expr); is_pair(cp); cp = cdr(cp)) + if ((!is_pair(car(cp))) || + (!is_pair(cdar(cp))) || + (!do_is_safe(sc, cdar(cp), stepper, var_list, step_vars, has_set))) + return(false); + if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) return(false); + break; + + case OP_COND: + for (cp = cdr(expr); is_pair(cp); cp = cdr(cp)) + if (!do_is_safe(sc, car(cp), stepper, var_list, step_vars, has_set)) + return(false); + break; + + case OP_CASE: + if ((!is_pair(cdr(expr))) || + (!do_is_safe(sc, cadr(expr), stepper, var_list, step_vars, has_set))) + return(false); + for (cp = cddr(expr); is_pair(cp); cp = cdr(cp)) + if ((!is_pair(car(cp))) || /* (case x #(123)...) */ + (!do_is_safe(sc, cdar(cp), stepper, var_list, step_vars, has_set))) + return(false); + break; + + case OP_IF: case OP_WHEN: case OP_UNLESS: + case OP_AND: case OP_OR: case OP_BEGIN: + case OP_WITH_BAFFLE: + if (!do_is_safe(sc, cdr(expr), stepper, var_list, step_vars, has_set)) + return(false); + break; + + case OP_WITH_LET: + return(false); /* 11-Jan-24, this was true!? */ + + default: + return(false); + }} /* is_syntax(x=car(expr)) */ + else + if (x == sc->quote_function) + { + if ((!is_pair(cdr(expr))) || (!is_null(cddr(expr)))) /* (#_quote . 1) or (#_quote 1 2) etc */ + return(false); + } + else + { + /* if a macro, we'll eventually expand it (if *_optimize), but that requires a symbol lookup here and macroexpand */ + if ((!is_optimized(expr)) || + (optimize_op(expr) == OP_UNKNOWN_NP) || + (!do_is_safe(sc, cdr(expr), stepper, var_list, step_vars, has_set))) + return(false); + + /* is this still needed? fx_c_optcq bug -- tests seem ok without it -- 3.5 in tmat */ + if ((is_symbol(x)) && (is_slot(global_slot(x))) && (is_syntax(global_value(x)))) /* maybe (x == sc->immutable_symbol)? */ + return(false); /* syntax hidden behind some other name */ + + if ((is_symbol(x)) && (is_setter(x))) /* "setter" includes stuff like cons and vector -- x is a symbol */ + { + /* (hash-table-set! ht i 0) -- caddr is being saved, so this is not safe + * similarly (vector-set! v 0 i) etc + */ + if (is_null(cdr(expr))) + { + if (is_null(cdr(p))) /* (vector) for example */ + return((x == sc->vector_symbol) || (x == sc->list_symbol) || (x == sc->string_symbol)); + } + else + { + if ((has_set) && + (!direct_memq(cadr(expr), var_list)) && /* non-local is being changed */ + ((cadr(expr) == stepper) || /* stepper is being set? */ + (!is_pair(cddr(expr))) || + (!is_pair(cdddr(expr))) || + (is_pair(cddddr(expr))) || + ((x == sc->hash_table_set_symbol) && (caddr(expr) == stepper)) || + (cadddr(expr) == stepper) || /* used to check is_symbol here and above but that's unnecessary */ + ((is_pair(cadddr(expr))) && (s7_tree_memq(sc, stepper, cadddr(expr)))))) + (*has_set) = true; + + if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) + return(false); + if (!safe_stepper_expr(expr, stepper)) + return(false); + }}}}} return(true); } static bool preserves_type(s7_scheme *sc, uint32_t x) { return((x == sc->add_class) || - (x == sc->subtract_class) || - (x == sc->multiply_class)); + (x == sc->subtract_class) || + (x == sc->multiply_class)); } static s7_pointer simple_stepper(s7_scheme *sc, s7_pointer v) @@ -81677,13 +81677,13 @@ static s7_pointer simple_stepper(s7_scheme *sc, s7_pointer v) { s7_pointer step_expr = caddr(v); if ((is_optimized(step_expr)) && - (((optimize_op(step_expr) == HOP_SAFE_C_SC) && (car(v) == cadr(step_expr))) || - ((is_h_safe_c_nc(step_expr)) && /* replace with is_fxable? */ - (is_pair(cdr(step_expr))) && /* ((v 0 (+))) */ - (car(v) == cadr(step_expr)) && - ((opt1_cfunc(step_expr) == sc->add_x1) || (opt1_cfunc(step_expr) == sc->subtract_x1))) || - ((optimize_op(step_expr) == HOP_SAFE_C_CS) && (car(v) == caddr(step_expr))))) - return(step_expr); + (((optimize_op(step_expr) == HOP_SAFE_C_SC) && (car(v) == cadr(step_expr))) || + ((is_h_safe_c_nc(step_expr)) && /* replace with is_fxable? */ + (is_pair(cdr(step_expr))) && /* ((v 0 (+))) */ + (car(v) == cadr(step_expr)) && + ((opt1_cfunc(step_expr) == sc->add_x1) || (opt1_cfunc(step_expr) == sc->subtract_x1))) || + ((optimize_op(step_expr) == HOP_SAFE_C_CS) && (car(v) == caddr(step_expr))))) + return(step_expr); } return(NULL); } @@ -81691,11 +81691,11 @@ static s7_pointer simple_stepper(s7_scheme *sc, s7_pointer v) static bool is_simple_end(s7_scheme *sc, s7_pointer end) { return((is_optimized(end)) && - (is_safe_c_op(optimize_op(end))) && - (is_pair(cddr(end))) && /* end: (zero? n) */ - (cadr(end) != caddr(end)) && - ((opt1_cfunc(end) == sc->num_eq_xi) || - (optimize_op(end) == HOP_SAFE_C_SS) || (optimize_op(end) == HOP_SAFE_C_SC))); + (is_safe_c_op(optimize_op(end))) && + (is_pair(cddr(end))) && /* end: (zero? n) */ + (cadr(end) != caddr(end)) && + ((opt1_cfunc(end) == sc->num_eq_xi) || + (optimize_op(end) == HOP_SAFE_C_SS) || (optimize_op(end) == HOP_SAFE_C_SC))); } static s7_pointer fxify_step_exprs(s7_scheme *sc, s7_pointer code) @@ -81708,26 +81708,26 @@ static s7_pointer fxify_step_exprs(s7_scheme *sc, s7_pointer code) s7_function callee = NULL; s7_pointer expr = cdar(p); /* init */ if (is_pair(expr)) - { - callee = fx_choose(sc, expr, sc->nil, do_symbol_is_safe); /* not vars -- they aren't defined yet */ - if (callee) set_fx(expr, callee); - } + { + callee = fx_choose(sc, expr, sc->nil, do_symbol_is_safe); /* not vars -- they aren't defined yet */ + if (callee) set_fx(expr, callee); + } expr = cddar(p); /* step */ if (is_pair(expr)) - { - if ((is_pair(car(expr))) && - (!is_checked(car(expr)))) - optimize_expression(sc, car(expr), 0, e, false); - callee = fx_choose(sc, expr, vars, do_symbol_is_safe); /* fx_proc can be nil! */ - if (callee) set_fx(expr, callee); - }} + { + if ((is_pair(car(expr))) && + (!is_checked(car(expr)))) + optimize_expression(sc, car(expr), 0, e, false); + callee = fx_choose(sc, expr, vars, do_symbol_is_safe); /* fx_proc can be nil! */ + if (callee) set_fx(expr, callee); + }} if ((is_pair(cdr(code))) && (is_pair(cadr(code)))) { s7_pointer result = cdadr(code); if ((is_pair(result)) && - (is_fxable(sc, car(result)))) - set_fx_direct(result, fx_choose(sc, result, vars, do_symbol_is_safe)); + (is_fxable(sc, car(result)))) + set_fx_direct(result, fx_choose(sc, result, vars, do_symbol_is_safe)); } return(code); } @@ -81738,8 +81738,8 @@ static bool do_vector_has_definers(s7_pointer v) s7_pointer *els = vector_elements(v); for (s7_int i = 0; i < len; i++) if ((is_pair(els[i])) && - (is_symbol(car(els[i]))) && - (is_definer(car(els[i])))) /* this is a desperate kludge */ + (is_symbol(car(els[i]))) && + (is_definer(car(els[i])))) /* this is a desperate kludge */ return(true); return(false); } @@ -81755,36 +81755,36 @@ static /* inline */ bool do_tree_has_definers(s7_scheme *sc, s7_pointer tree) { s7_pointer pp = car(p); if (is_symbol(pp)) - { - if (is_definer(pp)) - { - if (pp == sc->varlet_symbol) /* tlet case (varlet e1 ...) */ - { - if ((is_pair(cdr(p))) && (is_symbol(cadr(p))) && (!symbol_is_in_list(sc, cadr(p)))) - return(true); - } - else - if (pp == sc->apply_symbol) - { - s7_pointer val; - if ((!is_pair(cdr(p))) || (!is_symbol(cadr(p)))) return(true); - val = lookup_unexamined(sc, cadr(p)); - if ((!val) || (!is_c_function(val))) return(true); - } - else return(true); - }} + { + if (is_definer(pp)) + { + if (pp == sc->varlet_symbol) /* tlet case (varlet e1 ...) */ + { + if ((is_pair(cdr(p))) && (is_symbol(cadr(p))) && (!symbol_is_in_list(sc, cadr(p)))) + return(true); + } + else + if (pp == sc->apply_symbol) + { + s7_pointer val; + if ((!is_pair(cdr(p))) || (!is_symbol(cadr(p)))) return(true); + val = lookup_unexamined(sc, cadr(p)); + if ((!val) || (!is_c_function(val))) return(true); + } + else return(true); + }} else - if (is_pair(pp)) - { - if (do_tree_has_definers(sc, pp)) - return(true); - } - else - if ((is_applicable(pp)) && - (((is_t_vector(pp)) && (do_vector_has_definers(pp))) || - ((is_c_function(pp)) && (is_func_definer(pp))) || - ((is_syntax(pp)) && (is_syntax_definer(pp))))) - return(true); + if (is_pair(pp)) + { + if (do_tree_has_definers(sc, pp)) + return(true); + } + else + if ((is_applicable(pp)) && + (((is_t_vector(pp)) && (do_vector_has_definers(pp))) || + ((is_c_function(pp)) && (is_func_definer(pp))) || + ((is_syntax(pp)) && (is_syntax_definer(pp))))) + return(true); } return(false); } @@ -81809,41 +81809,41 @@ static void check_do_for_obvious_errors(s7_scheme *sc, s7_pointer form) { clear_symbol_list(sc); for (x = car(code); is_pair(x); x = cdr(x)) - { - s7_pointer y = car(x); - if (!(is_pair(y))) /* (do (4) (= 3)) */ - syntax_error_nr(sc, "do: variable name missing? ~A", 29, form); - - if (!is_symbol(car(y))) /* (do ((3 2)) ()) */ - syntax_error_nr(sc, "do step variable: ~S is not a symbol?", 37, y); - - if (is_constant_symbol(sc, car(y))) /* (do ((pi 3 (+ pi 1))) ((= pi 4)) pi) */ - syntax_error_nr(sc, "do step variable: ~S is immutable", 33, y); - - if (!is_pair(cdr(y))) - syntax_error_nr(sc, "do: step variable has no initial value: ~A", 42, x); - if (!is_pair(cddr(y))) - { - if (is_not_null(cddr(y))) /* (do ((i 0 . 1)) ...) */ - syntax_error_nr(sc, "do: step variable info is an improper list?: ~A", 47, x); - } - else - if (is_not_null(cdddr(y))) /* (do ((i 0 1 (+ i 1))) ...) */ - syntax_error_nr(sc, "do: step variable info has extra stuff after the increment: ~A", 62, x); - set_local(car(y)); - - if (symbol_is_in_list(sc, car(y))) /* (do ((i 0 (+ i 1)) (i 2))...) */ - syntax_error_nr(sc, "duplicate identifier in do: ~A", 30, x); - add_symbol_to_list(sc, car(y)); - } + { + s7_pointer y = car(x); + if (!(is_pair(y))) /* (do (4) (= 3)) */ + syntax_error_nr(sc, "do: variable name missing? ~A", 29, form); + + if (!is_symbol(car(y))) /* (do ((3 2)) ()) */ + syntax_error_nr(sc, "do step variable: ~S is not a symbol?", 37, y); + + if (is_constant_symbol(sc, car(y))) /* (do ((pi 3 (+ pi 1))) ((= pi 4)) pi) */ + syntax_error_nr(sc, "do step variable: ~S is immutable", 33, y); + + if (!is_pair(cdr(y))) + syntax_error_nr(sc, "do: step variable has no initial value: ~A", 42, x); + if (!is_pair(cddr(y))) + { + if (is_not_null(cddr(y))) /* (do ((i 0 . 1)) ...) */ + syntax_error_nr(sc, "do: step variable info is an improper list?: ~A", 47, x); + } + else + if (is_not_null(cdddr(y))) /* (do ((i 0 1 (+ i 1))) ...) */ + syntax_error_nr(sc, "do: step variable info has extra stuff after the increment: ~A", 62, x); + set_local(car(y)); + + if (symbol_is_in_list(sc, car(y))) /* (do ((i 0 (+ i 1)) (i 2))...) */ + syntax_error_nr(sc, "duplicate identifier in do: ~A", 30, x); + add_symbol_to_list(sc, car(y)); + } if (is_not_null(x)) /* (do ((i 0 i) . 1) ((= i 1))) */ - syntax_error_nr(sc, "do: list of variables is improper: ~A", 37, form); + syntax_error_nr(sc, "do: list of variables is improper: ~A", 37, form); } if (is_pair(cadr(code))) { for (x = cadr(code); is_pair(x); x = cdr(x)); if (is_not_null(x)) /* (do ((i 0 (+ i 1))) ((= i 2) . 3) */ - syntax_error_nr(sc, "stray dot in do end section? ~A", 31, form); + syntax_error_nr(sc, "stray dot in do end section? ~A", 31, form); } for (x = cddr(code); is_pair(x); x = cdr(x)); if (is_not_null(x)) @@ -81858,49 +81858,49 @@ static s7_pointer do_end_bad(s7_scheme *sc, s7_pointer form) s7_pointer p; /* no body, end not fxable (if eval car(end) might be unopt) */ for (p = car(code); is_pair(p); p = cdr(p)) /* gather var names */ - { - s7_pointer var = car(p); - if (is_pair(cddr(var))) /* if no step expr it's safe in other step exprs 16-Apr-19 */ - set_match_symbol(car(var)); - } + { + s7_pointer var = car(p); + 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 = car(p); - s7_pointer val = cddr(var); - if (is_pair(val)) - { - clear_match_symbol(car(var)); /* ignore current var */ - if (tree_match(car(val))) - { - for (s7_pointer q = car(code); is_pair(q); q = cdr(q)) - clear_match_symbol(caar(q)); - return(code); - }} - set_match_symbol(car(var)); - } + { + s7_pointer var = car(p); + s7_pointer val = cddr(var); + if (is_pair(val)) + { + clear_match_symbol(car(var)); /* ignore current var */ + if (tree_match(car(val))) + { + for (s7_pointer 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)); + clear_match_symbol(caar(p)); if (is_null(p)) - { - if ((is_null(cadr(code))) && /* (do () ()) or (do (fxable vars) ()) */ - (is_null(cddr(code)))) - { - if (sc->safety > NO_SAFETY) - s7_warn(sc, 256, "%s: infinite do loop: %s\n", __func__, display(form)); - return(code); - } - fxify_step_exprs(sc, code); - for (p = car(code); is_pair(p); p = cdr(p)) - { - s7_pointer 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_NA_VARS); - return(sc->nil); - }} + { + if ((is_null(cadr(code))) && /* (do () ()) or (do (fxable vars) ()) */ + (is_null(cddr(code)))) + { + if (sc->safety > NO_SAFETY) + s7_warn(sc, 256, "%s: infinite do loop: %s\n", __func__, display(form)); + return(code); + } + fxify_step_exprs(sc, code); + for (p = car(code); is_pair(p); p = cdr(p)) + { + s7_pointer 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_NA_VARS); + return(sc->nil); + }} return(fxify_step_exprs(sc, code)); } @@ -81928,30 +81928,30 @@ static s7_pointer check_do(s7_scheme *sc) { pair_set_syntax_op(form, OP_DO_NO_VARS); if (is_fx_treeable(end)) - { - if ((is_pair(car(end))) && /* this code is repeated below */ - (has_fx(end)) && - (!(is_syntax(caar(end)))) && - (!((is_symbol(caar(end))) && (is_definer_or_binder(caar(end)))))) - { - s7_pointer v1 = NULL, v2 = NULL, v3 = NULL; - bool more_vs = false; - if (tis_slot(let_slots(sc->curlet))) /* outer vars */ - { - p = let_slots(sc->curlet); - v1 = slot_symbol(p); - p = next_slot(p); - if (tis_slot(p)) - { - v2 = slot_symbol(p); - p = next_slot(p); - if (tis_slot(p)) - { - v3 = slot_symbol(p); - more_vs = tis_slot(next_slot(p)); - }}} - if (v1) fx_tree_outer(sc, end, v1, v2, v3, more_vs); - }} + { + if ((is_pair(car(end))) && /* this code is repeated below */ + (has_fx(end)) && + (!(is_syntax(caar(end)))) && + (!((is_symbol(caar(end))) && (is_definer_or_binder(caar(end)))))) + { + s7_pointer v1 = NULL, v2 = NULL, v3 = NULL; + bool more_vs = false; + if (tis_slot(let_slots(sc->curlet))) /* outer vars */ + { + p = let_slots(sc->curlet); + v1 = slot_symbol(p); + p = next_slot(p); + if (tis_slot(p)) + { + v2 = slot_symbol(p); + p = next_slot(p); + if (tis_slot(p)) + { + v3 = slot_symbol(p); + more_vs = tis_slot(next_slot(p)); + }}} + if (v1) fx_tree_outer(sc, end, v1, v2, v3, more_vs); + }} return(sc->nil); } @@ -81969,79 +81969,79 @@ static s7_pointer check_do(s7_scheme *sc) fx_tree(sc, end, car(v), NULL, NULL, false); if (is_fx_treeable(body)) /* this is thwarted by gotos */ - fx_tree(sc, body, car(v), NULL, NULL, false); + fx_tree(sc, body, car(v), NULL, NULL, false); step_expr = simple_stepper(sc, v); if (step_expr) - { - s7_pointer orig_end = end; - set_fx(cdr(v), fx_choose(sc, cdr(v), vars, do_symbol_is_safe)); /* v is (i 0 (+ i 1)) or the like */ - - /* step var is (var const|symbol (op var const)|(op const var)) */ - end = car(end); - if ((is_simple_end(sc, end)) && - (car(v) == cadr(end))) - { - /* end var is (op var const|symbol) using same var as step so at least we can use SIMPLE_DO */ - bool has_set = false; - bool one_line = ((is_null(cdr(body))) && (is_pair(car(body)))); - if ((car(end) == sc->num_eq_symbol) && (is_symbol(cadr(end))) && (is_t_integer(caddr(end)))) - { - set_c_function(end, sc->num_eq_2); - set_opt2_con(cdr(end), caddr(end)); - set_fx_direct(orig_end, (integer(caddr(end)) == 0) ? fx_num_eq_s0 : fx_num_eq_si); - } - set_opt1_any(code, caddr(end)); /* symbol or int(?) */ - set_opt2_pair(code, step_expr); /* caddr(caar(code)) */ - pair_set_syntax_op(form, OP_SIMPLE_DO); /* simple_do: 1 var easy step/end */ - - if ((c_function_class(opt1_cfunc(step_expr)) == sc->add_class) && /* we check above that (car(v) == cadr(step_expr)) and (car(v) == cadr(end)) */ - ((c_function_class(opt1_cfunc(end)) == sc->num_eq_class) || - (opt1_cfunc(end) == sc->geq_2))) - { - if ((one_line) && - ((!is_optimized(car(body))) || (op_no_hop(car(body)) != OP_SAFE_C_NC)) && /* this does happen: (if (= i 3) (vector-set! j 0 i)) */ - (is_symbol_and_syntactic(caar(body))) && - (s7_is_integer(caddr(step_expr))) && /* this currently blocks s7_optimize of float steppers */ - (s7_integer_clamped_if_gmp(sc, caddr(step_expr)) == 1)) - { - pair_set_syntax_op(car(body), symbol_syntax_op_checked(car(body))); - pair_set_syntax_op(form, OP_DOTIMES_P); /* dotimes_p: simple + syntax body + 1 expr */ - } - - if (((caddr(step_expr) == int_one) || (cadr(step_expr) == int_one)) && - (do_is_safe(sc, body, car(v), sc->nil, vars, &has_set))) - { - pair_set_syntax_op(form, OP_SAFE_DO); /* safe_do: body is safe, step by 1 */ - /* no semipermanent let here because apparently do_is_safe accepts recursive calls? */ - if ((!has_set) && - (c_function_class(opt1_cfunc(end)) == sc->num_eq_class)) - { - pair_set_syntax_op(form, OP_SAFE_DOTIMES); /* safe_dotimes: end is = */ - if (is_fxable(sc, car(body))) - fx_annotate_arg(sc, body, collect_variables(sc, vars, sc->nil)); - } - fx_tree(sc, body, car(v), NULL, NULL, false); - if (stack_top_op(sc) == OP_SAFE_DO_STEP) - fx_tree_outer(sc, body, caaar(stack_top_code(sc)), NULL, NULL, true); - }} - return(sc->nil); - }}} + { + s7_pointer orig_end = end; + set_fx(cdr(v), fx_choose(sc, cdr(v), vars, do_symbol_is_safe)); /* v is (i 0 (+ i 1)) or the like */ + + /* step var is (var const|symbol (op var const)|(op const var)) */ + end = car(end); + if ((is_simple_end(sc, end)) && + (car(v) == cadr(end))) + { + /* end var is (op var const|symbol) using same var as step so at least we can use SIMPLE_DO */ + bool has_set = false; + bool one_line = ((is_null(cdr(body))) && (is_pair(car(body)))); + if ((car(end) == sc->num_eq_symbol) && (is_symbol(cadr(end))) && (is_t_integer(caddr(end)))) + { + set_c_function(end, sc->num_eq_2); + set_opt2_con(cdr(end), caddr(end)); + set_fx_direct(orig_end, (integer(caddr(end)) == 0) ? fx_num_eq_s0 : fx_num_eq_si); + } + set_opt1_any(code, caddr(end)); /* symbol or int(?) */ + set_opt2_pair(code, step_expr); /* caddr(caar(code)) */ + pair_set_syntax_op(form, OP_SIMPLE_DO); /* simple_do: 1 var easy step/end */ + + if ((c_function_class(opt1_cfunc(step_expr)) == sc->add_class) && /* we check above that (car(v) == cadr(step_expr)) and (car(v) == cadr(end)) */ + ((c_function_class(opt1_cfunc(end)) == sc->num_eq_class) || + (opt1_cfunc(end) == sc->geq_2))) + { + if ((one_line) && + ((!is_optimized(car(body))) || (op_no_hop(car(body)) != OP_SAFE_C_NC)) && /* this does happen: (if (= i 3) (vector-set! j 0 i)) */ + (is_symbol_and_syntactic(caar(body))) && + (s7_is_integer(caddr(step_expr))) && /* this currently blocks s7_optimize of float steppers */ + (s7_integer_clamped_if_gmp(sc, caddr(step_expr)) == 1)) + { + pair_set_syntax_op(car(body), symbol_syntax_op_checked(car(body))); + pair_set_syntax_op(form, OP_DOTIMES_P); /* dotimes_p: simple + syntax body + 1 expr */ + } + + if (((caddr(step_expr) == int_one) || (cadr(step_expr) == int_one)) && + (do_is_safe(sc, body, car(v), sc->nil, vars, &has_set))) + { + pair_set_syntax_op(form, OP_SAFE_DO); /* safe_do: body is safe, step by 1 */ + /* no semipermanent let here because apparently do_is_safe accepts recursive calls? */ + if ((!has_set) && + (c_function_class(opt1_cfunc(end)) == sc->num_eq_class)) + { + pair_set_syntax_op(form, OP_SAFE_DOTIMES); /* safe_dotimes: end is = */ + if (is_fxable(sc, car(body))) + fx_annotate_arg(sc, body, collect_variables(sc, vars, sc->nil)); + } + fx_tree(sc, body, car(v), NULL, NULL, false); + if (stack_top_op(sc) == OP_SAFE_DO_STEP) + fx_tree_outer(sc, body, caaar(stack_top_code(sc)), NULL, NULL, true); + }} + return(sc->nil); + }}} /* we get here if there is more than one local var or anything "non-simple" about the rest */ for (p = vars; is_pair(p); p = cdr(p)) { s7_pointer var = car(p); if ((!is_fxable(sc, cadr(var))) || - ((is_pair(cddr(var))) && (!is_fxable(sc, caddr(var)))) || - ((is_symbol(cadr(var))) && (is_definer_or_binder(cadr(var))))) - { - for (s7_pointer q = vars; q != p; q = cdr(q)) - clear_match_symbol(caar(q)); - return(fxify_step_exprs(sc, code)); - } + ((is_pair(cddr(var))) && (!is_fxable(sc, caddr(var)))) || + ((is_symbol(cadr(var))) && (is_definer_or_binder(cadr(var))))) + { + for (s7_pointer q = vars; q != p; q = cdr(q)) + clear_match_symbol(caar(q)); + return(fxify_step_exprs(sc, code)); + } if (is_pair(cddr(var))) /* if no step expr it's safe in other step exprs 16-Apr-19 */ - set_match_symbol(car(var)); + set_match_symbol(car(var)); } { @@ -82050,170 +82050,170 @@ static s7_pointer check_do(s7_scheme *sc) for (p = vars; is_pair(p); p = cdr(p)) { - s7_pointer var = car(p); - s7_pointer val = cddr(var); - stepper3 = stepper2; - stepper2 = stepper1; - stepper1 = stepper0; - stepper0 = car(var); - if (is_pair(val)) - { - var = car(var); - clear_match_symbol(var); /* ignore current var */ - if (tree_match(car(val))) - { - for (s7_pointer q = vars; is_pair(q); q = cdr(q)) - clear_match_symbol(caar(q)); - if (is_null(body)) - got_pending = true; - else return(fxify_step_exprs(sc, code)); - } - set_match_symbol(var); - }} + s7_pointer var = car(p); + s7_pointer val = cddr(var); + stepper3 = stepper2; + stepper2 = stepper1; + stepper1 = stepper0; + stepper0 = car(var); + if (is_pair(val)) + { + var = car(var); + clear_match_symbol(var); /* ignore current var */ + if (tree_match(car(val))) + { + for (s7_pointer q = vars; is_pair(q); q = cdr(q)) + clear_match_symbol(caar(q)); + if (is_null(body)) + got_pending = true; + else return(fxify_step_exprs(sc, code)); + } + set_match_symbol(var); + }} for (p = vars; is_pair(p); p = cdr(p)) set_match_symbol(caar(p)); for (p = let_slots(sc->curlet); tis_slot(p); p = next_slot(p)) if (is_matched_symbol(slot_symbol(p))) - { - outer_shadowed = true; - break; - } + { + outer_shadowed = true; + break; + } for (p = vars; is_pair(p); p = cdr(p)) clear_match_symbol(caar(p)); /* end and steps look ok! */ for (p = vars; is_pair(p); p = cdr(p)) { - s7_pointer var = car(p); - set_fx_direct(cdr(var), fx_choose(sc, cdr(var), sc->curlet, let_symbol_is_safe)); /* init val */ - if (is_pair(cddr(var))) - { - s7_pointer step_expr = caddr(var); - set_fx_direct(cddr(var), fx_choose(sc, cddr(var), vars, do_symbol_is_safe)); /* sets opt2(cddr(var)), not opt1 */ - if (!is_pair(step_expr)) /* (i 0 0) */ - { - if (cadr(var) == caddr(var)) /* not types match: (i x y) etc */ - set_safe_stepper_expr(cddr(var)); - } - else - { - s7_pointer endp = car(end); - s7_pointer var1 = car(var); - if ((!is_quote(car(step_expr))) && /* opt1_cfunc(==opt1) might not be set in this case (sigh) */ - (is_safe_c_op(optimize_op(step_expr))) && - ((preserves_type(sc, c_function_class(opt1_cfunc(step_expr)))) || /* add etc */ - (car(step_expr) == sc->cdr_symbol) || - (car(step_expr) == sc->cddr_symbol) || - ((is_pair(cadr(var))) && - (is_pair(c_function_signature(c_function_base(opt1_cfunc(step_expr))))) && - (car(c_function_signature(c_function_base(opt1_cfunc(step_expr)))) != sc->T) && - (caadr(var) == car(step_expr))))) /* i.e. accept char-position as init/step, but not iterate */ - set_safe_stepper_expr(cddr(var)); - - if ((is_proper_list_3(sc, endp)) && (is_proper_list_3(sc, step_expr)) && - ((car(endp) == sc->num_eq_symbol) || (car(endp) == sc->geq_symbol)) && - (is_symbol(cadr(endp))) && - ((is_t_integer(caddr(endp))) || (is_symbol(caddr(endp)))) && - (car(step_expr) == sc->add_symbol) && - (var1 == cadr(endp)) && (var1 == cadr(step_expr)) && - ((car(endp) != sc->num_eq_symbol) || ((caddr(step_expr) == int_one)))) - set_loop_end_possible(end); - }}} + s7_pointer var = car(p); + set_fx_direct(cdr(var), fx_choose(sc, cdr(var), sc->curlet, let_symbol_is_safe)); /* init val */ + if (is_pair(cddr(var))) + { + s7_pointer step_expr = caddr(var); + set_fx_direct(cddr(var), fx_choose(sc, cddr(var), vars, do_symbol_is_safe)); /* sets opt2(cddr(var)), not opt1 */ + if (!is_pair(step_expr)) /* (i 0 0) */ + { + if (cadr(var) == caddr(var)) /* not types match: (i x y) etc */ + set_safe_stepper_expr(cddr(var)); + } + else + { + s7_pointer endp = car(end); + s7_pointer var1 = car(var); + if ((!is_quote(car(step_expr))) && /* opt1_cfunc(==opt1) might not be set in this case (sigh) */ + (is_safe_c_op(optimize_op(step_expr))) && + ((preserves_type(sc, c_function_class(opt1_cfunc(step_expr)))) || /* add etc */ + (car(step_expr) == sc->cdr_symbol) || + (car(step_expr) == sc->cddr_symbol) || + ((is_pair(cadr(var))) && + (is_pair(c_function_signature(c_function_base(opt1_cfunc(step_expr))))) && + (car(c_function_signature(c_function_base(opt1_cfunc(step_expr)))) != sc->T) && + (caadr(var) == car(step_expr))))) /* i.e. accept char-position as init/step, but not iterate */ + set_safe_stepper_expr(cddr(var)); + + if ((is_proper_list_3(sc, endp)) && (is_proper_list_3(sc, step_expr)) && + ((car(endp) == sc->num_eq_symbol) || (car(endp) == sc->geq_symbol)) && + (is_symbol(cadr(endp))) && + ((is_t_integer(caddr(endp))) || (is_symbol(caddr(endp)))) && + (car(step_expr) == sc->add_symbol) && + (var1 == cadr(endp)) && (var1 == cadr(step_expr)) && + ((car(endp) != sc->num_eq_symbol) || ((caddr(step_expr) == int_one)))) + set_loop_end_possible(end); + }}} pair_set_syntax_op(form, (got_pending) ? OP_DOX_PENDING_NO_BODY : OP_DOX); /* there are only a couple of cases in snd-test where a multi-statement do body is completely fx-able */ if ((is_null(body)) && - (is_null(cdr(vars))) && - (is_pair(cdr(end))) && - (is_null(cddr(end))) && - (has_fx(cdr(end))) && - (is_pair(cdar(vars))) && - (is_pair(cddar(vars)))) + (is_null(cdr(vars))) && + (is_pair(cdr(end))) && + (is_null(cddr(end))) && + (has_fx(cdr(end))) && + (is_pair(cdar(vars))) && + (is_pair(cddar(vars)))) { - s7_pointer var = caar(vars); - s7_pointer step = cddar(vars); - set_opt3_any(code, (in_heap(code)) ? sc->F : make_semipermanent_let(sc, vars)); - if (!got_pending) - pair_set_syntax_op(form, OP_DOX_NO_BODY); - if (is_safe_stepper_expr(step)) - { - step = car(step); - if ((is_pair(step)) && (is_proper_list_3(sc, step))) - { - if ((car(step) == sc->add_symbol) && - (((cadr(step) == var) && (caddr(step) == int_one)) || - (caddr(step) == var)) && (cadr(step) == int_one)) - set_opt2_con(code, int_one); - else - if ((car(step) == sc->subtract_symbol) && - (cadr(step) == var) && - (caddr(step) == int_one)) - set_opt2_con(code, minus_one); - else set_opt2_con(code, int_zero); - } - else set_opt2_con(code, int_zero); - } - else set_opt2_con(code, int_zero); + s7_pointer var = caar(vars); + s7_pointer step = cddar(vars); + set_opt3_any(code, (in_heap(code)) ? sc->F : make_semipermanent_let(sc, vars)); + if (!got_pending) + pair_set_syntax_op(form, OP_DOX_NO_BODY); + if (is_safe_stepper_expr(step)) + { + step = car(step); + if ((is_pair(step)) && (is_proper_list_3(sc, step))) + { + if ((car(step) == sc->add_symbol) && + (((cadr(step) == var) && (caddr(step) == int_one)) || + (caddr(step) == var)) && (cadr(step) == int_one)) + set_opt2_con(code, int_one); + else + if ((car(step) == sc->subtract_symbol) && + (cadr(step) == var) && + (caddr(step) == int_one)) + set_opt2_con(code, minus_one); + else set_opt2_con(code, int_zero); + } + else set_opt2_con(code, int_zero); + } + else set_opt2_con(code, int_zero); } if (do_passes_safety_check(sc, body, sc->nil, vars, NULL)) { - s7_pointer var1 = NULL, var2 = NULL, var3 = NULL; - bool more_vars = false; - if (tis_slot(let_slots(sc->curlet))) /* outer vars */ - { - p = let_slots(sc->curlet); - var1 = slot_symbol(p); - p = next_slot(p); - if (tis_slot(p)) - { - var2 = slot_symbol(p); - p = next_slot(p); - if (tis_slot(p)) - { - var3 = slot_symbol(p); - more_vars = tis_slot(next_slot(p)); - }}} - - for (p = vars; is_pair(p); p = cdr(p)) - { - s7_pointer var = car(p); - if (is_pair(cdr(var))) - { - if (var1) fx_tree_in(sc, cdr(var), var1, var2, var3, more_vars); /* init vals, more_vars refers to outer let, stepper3 == local let more_vars */ - if (is_pair(cddr(var))) - { - if (stepper0) fx_tree(sc, cddr(var), stepper0, stepper1, stepper2, stepper3); - if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, cddr(var), var1, var2, var3, more_vars); - }}} - - if ((is_pair(cdr(end))) && - (is_null(cddr(end))) && - (has_fx(cdr(end)))) - { - if (!fx_tree_in(sc, cdr(end), stepper0, stepper1, stepper2, stepper3)) - fx_tree(sc, cadr(end), stepper0, stepper1, stepper2, stepper3); - if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, cdr(end), var1, var2, var3, more_vars); - } - - if ((is_pair(car(end))) && - (has_fx(end)) && - (!(is_syntax(caar(end)))) && - (!((is_symbol(caar(end))) && (is_definer_or_binder(caar(end)))))) - { - if (!fx_tree_in(sc, end, stepper0, stepper1, stepper2, stepper3)) /* just the end-test, not the results */ - fx_tree(sc, car(end), stepper0, stepper1, stepper2, stepper3); /* car(end) might be (or ...) */ - if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, end, var1, var2, var3, more_vars); - } - - if ((is_pair(body)) && (is_null(cdr(body))) && - (is_fxable(sc, car(body)))) - { - fx_annotate_arg(sc, body, collect_variables(sc, vars, sc->nil)); - if (stepper0) fx_tree(sc, body, stepper0, stepper1, stepper2, stepper3); - if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, body, var1, var2, var3, more_vars); - }}} + s7_pointer var1 = NULL, var2 = NULL, var3 = NULL; + bool more_vars = false; + if (tis_slot(let_slots(sc->curlet))) /* outer vars */ + { + p = let_slots(sc->curlet); + var1 = slot_symbol(p); + p = next_slot(p); + if (tis_slot(p)) + { + var2 = slot_symbol(p); + p = next_slot(p); + if (tis_slot(p)) + { + var3 = slot_symbol(p); + more_vars = tis_slot(next_slot(p)); + }}} + + for (p = vars; is_pair(p); p = cdr(p)) + { + s7_pointer var = car(p); + if (is_pair(cdr(var))) + { + if (var1) fx_tree_in(sc, cdr(var), var1, var2, var3, more_vars); /* init vals, more_vars refers to outer let, stepper3 == local let more_vars */ + if (is_pair(cddr(var))) + { + if (stepper0) fx_tree(sc, cddr(var), stepper0, stepper1, stepper2, stepper3); + if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, cddr(var), var1, var2, var3, more_vars); + }}} + + if ((is_pair(cdr(end))) && + (is_null(cddr(end))) && + (has_fx(cdr(end)))) + { + if (!fx_tree_in(sc, cdr(end), stepper0, stepper1, stepper2, stepper3)) + fx_tree(sc, cadr(end), stepper0, stepper1, stepper2, stepper3); + if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, cdr(end), var1, var2, var3, more_vars); + } + + if ((is_pair(car(end))) && + (has_fx(end)) && + (!(is_syntax(caar(end)))) && + (!((is_symbol(caar(end))) && (is_definer_or_binder(caar(end)))))) + { + if (!fx_tree_in(sc, end, stepper0, stepper1, stepper2, stepper3)) /* just the end-test, not the results */ + fx_tree(sc, car(end), stepper0, stepper1, stepper2, stepper3); /* car(end) might be (or ...) */ + if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, end, var1, var2, var3, more_vars); + } + + if ((is_pair(body)) && (is_null(cdr(body))) && + (is_fxable(sc, car(body)))) + { + fx_annotate_arg(sc, body, collect_variables(sc, vars, sc->nil)); + if (stepper0) fx_tree(sc, body, stepper0, stepper1, stepper2, stepper3); + if ((var1) && (!outer_shadowed) && (!stepper3)) fx_tree_outer(sc, body, var1, var2, var3, more_vars); + }}} return(sc->nil); } @@ -82223,64 +82223,64 @@ static bool has_safe_steppers(s7_scheme *sc, s7_pointer let) { s7_pointer val = slot_value(slot); if (slot_has_expression(slot)) - { - s7_pointer step_expr = T_Pair(slot_expression(slot)); - if (is_safe_stepper_expr(step_expr)) - { - if (is_t_integer(val)) - { - if (is_int_optable(step_expr)) - set_safe_stepper(slot); - else - if (no_int_opt(step_expr)) - clear_safe_stepper(slot); - else - { - sc->pc = 0; - if (int_optimize(sc, step_expr)) - { - set_safe_stepper(slot); - set_is_int_optable(step_expr); - } - else - { - clear_safe_stepper(slot); - set_no_int_opt(step_expr); - }}} - else - if (is_small_real(val)) - { - if (is_float_optable(step_expr)) - set_safe_stepper(slot); - else - if (no_float_opt(step_expr)) - clear_safe_stepper(slot); - else - { - sc->pc = 0; - if (float_optimize(sc, step_expr)) - { - set_safe_stepper(slot); - set_is_float_optable(step_expr); - } - else - { - clear_safe_stepper(slot); - set_no_float_opt(step_expr); - }}} - else set_safe_stepper(slot); /* ?? shouldn't this check types ?? */ - }} + { + s7_pointer step_expr = T_Pair(slot_expression(slot)); + if (is_safe_stepper_expr(step_expr)) + { + if (is_t_integer(val)) + { + if (is_int_optable(step_expr)) + set_safe_stepper(slot); + else + if (no_int_opt(step_expr)) + clear_safe_stepper(slot); + else + { + sc->pc = 0; + if (int_optimize(sc, step_expr)) + { + set_safe_stepper(slot); + set_is_int_optable(step_expr); + } + else + { + clear_safe_stepper(slot); + set_no_int_opt(step_expr); + }}} + else + if (is_small_real(val)) + { + if (is_float_optable(step_expr)) + set_safe_stepper(slot); + else + if (no_float_opt(step_expr)) + clear_safe_stepper(slot); + else + { + sc->pc = 0; + if (float_optimize(sc, step_expr)) + { + set_safe_stepper(slot); + set_is_float_optable(step_expr); + } + else + { + clear_safe_stepper(slot); + set_no_float_opt(step_expr); + }}} + else set_safe_stepper(slot); /* ?? shouldn't this check types ?? */ + }} else - { - if (is_t_real(val)) - slot_set_value(slot, make_mutable_real(sc, real(val))); - else - if (is_t_integer(val)) - slot_set_value(slot, make_mutable_integer(sc, integer(val))); - set_safe_stepper(slot); - } + { + if (is_t_real(val)) + slot_set_value(slot, make_mutable_real(sc, real(val))); + else + if (is_t_integer(val)) + slot_set_value(slot, make_mutable_integer(sc, integer(val))); + set_safe_stepper(slot); + } if (!is_safe_stepper(slot)) - return(false); + return(false); } return(true); } @@ -82291,10 +82291,10 @@ static bool copy_if_end_ok(s7_scheme *sc, s7_pointer dest, s7_pointer source, s7 { s7_pointer end_slot = s7_slot(sc, (cadr(endp) == slot_symbol(stepper)) ? caddr(endp) : cadr(endp)); if ((is_slot(end_slot)) && (is_t_integer(slot_value(end_slot)))) - { - copy_to_same_type(sc, dest, source, i, integer(slot_value(end_slot)), i); - return(true); - }} + { + copy_to_same_type(sc, dest, source, i, integer(slot_value(end_slot)), i); + return(true); + }} return(false); } @@ -82308,7 +82308,7 @@ static bool op_dox_init(s7_scheme *sc) { add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars))); if (is_pair(cddar(vars))) - slot_set_expression(let_slots(let), cddar(vars)); + slot_set_expression(let_slots(let), cddar(vars)); else slot_just_set_expression(let_slots(let), sc->nil); } set_curlet(sc, let); @@ -82338,40 +82338,40 @@ static goto_t op_dox_no_body_1(s7_scheme *sc, s7_pointer slots, s7_pointer end, s7_function f = fx_proc(slot_expression(stepper)); /* e.g. fx_add_s1 */ s7_pointer a = car(slot_expression(stepper)); if ((f == fx_c_nc) || (f == fx_c_0c)) - { - f = fn_proc(a); - a = cdr(a); - } + { + f = fn_proc(a); + a = cdr(a); + } if (((f == fx_cdr_s) || (f == fx_cdr_t)) && - (cadr(a) == slot_symbol(stepper))) - { - do {slot_set_value(stepper, cdr(slot_value(stepper)));} while (endf(sc, endp) == sc->F); - sc->value = sc->T; - } + (cadr(a) == slot_symbol(stepper))) + { + do {slot_set_value(stepper, cdr(slot_value(stepper)));} while (endf(sc, endp) == sc->F); + sc->value = sc->T; + } else /* (- n 1) tpeak dup */ - if (((f == fx_add_t1) || (f == fx_add_u1)) && (is_t_integer(slot_value(stepper)))) - { - s7_pointer p = make_mutable_integer(sc, integer(slot_value(stepper))); - slot_set_value(stepper, p); - if (!no_bool_opt(end)) - { - sc->pc = 0; - if (bool_optimize(sc, end)) /* in dup.scm this costs more than the fb(o) below saves (search is short) */ - { /* but tc is much slower (and bool|int_optimize dominates) */ - opt_info *o = sc->opts[0]; - bool (*fb)(opt_info *o) = o->v[0].fb; - do {integer(p)++;} while (!fb(o)); /* do {integer(p)++;} while ((sc->value = optf(sc, endp)) == sc->F); */ - clear_mutable_integer(p); - sc->value = sc->T; - sc->code = cdr(end); - return(goto_do_end_clauses); - } - set_no_bool_opt(end); - } - do {integer(p)++;} while ((sc->value = endf(sc, endp)) == sc->F); - clear_mutable_integer(p); - } - else do {slot_set_value(stepper, f(sc, a));} while ((sc->value = endf(sc, endp)) == sc->F); + if (((f == fx_add_t1) || (f == fx_add_u1)) && (is_t_integer(slot_value(stepper)))) + { + s7_pointer p = make_mutable_integer(sc, integer(slot_value(stepper))); + slot_set_value(stepper, p); + if (!no_bool_opt(end)) + { + sc->pc = 0; + if (bool_optimize(sc, end)) /* in dup.scm this costs more than the fb(o) below saves (search is short) */ + { /* but tc is much slower (and bool|int_optimize dominates) */ + opt_info *o = sc->opts[0]; + bool (*fb)(opt_info *o) = o->v[0].fb; + do {integer(p)++;} while (!fb(o)); /* do {integer(p)++;} while ((sc->value = optf(sc, endp)) == sc->F); */ + clear_mutable_integer(p); + sc->value = sc->T; + sc->code = cdr(end); + return(goto_do_end_clauses); + } + set_no_bool_opt(end); + } + do {integer(p)++;} while ((sc->value = endf(sc, endp)) == sc->F); + clear_mutable_integer(p); + } + else do {slot_set_value(stepper, f(sc, a));} while ((sc->value = endf(sc, endp)) == sc->F); sc->code = cdr(end); return(goto_do_end_clauses); @@ -82384,35 +82384,35 @@ static goto_t op_dox_no_body_1(s7_scheme *sc, s7_pointer slots, s7_pointer end, s7_pointer step2 = next_slot(step1); s7_pointer expr2 = slot_expression(step2); /* presetting fx_proc/car(expr) is not faster */ if ((fx_proc(expr2) == fx_subtract_u1) && - (is_t_integer(slot_value(step2))) && - (endf == fx_num_eq_ui)) - { - s7_int lim = integer(caddr(endp)); - for (s7_int i = integer(slot_value(step2)) - 1; i >= lim; i--) - slot_set_value(step1, fx_call(sc, expr1)); - } + (is_t_integer(slot_value(step2))) && + (endf == fx_num_eq_ui)) + { + s7_int lim = integer(caddr(endp)); + for (s7_int i = integer(slot_value(step2)) - 1; i >= lim; i--) + slot_set_value(step1, fx_call(sc, expr1)); + } else - do { - slot_set_value(step1, fx_call(sc, expr1)); - slot_set_value(step2, fx_call(sc, expr2)); - } while ((sc->value = endf(sc, endp)) == sc->F); + do { + slot_set_value(step1, fx_call(sc, expr1)); + slot_set_value(step2, fx_call(sc, expr2)); + } while ((sc->value = endf(sc, endp)) == sc->F); sc->code = cdr(end); if (!is_pair(sc->code)) return(goto_start); /* no result: (define (f) (do ((x 0 (+ x 1)) (i 0 (+ i 1))) ((= i 1)))) (f) (f) */ if ((!is_symbol(car(sc->code))) || (is_pair(cdr(sc->code)))) /* more than one result: (define (f) (do ((x 0 (+ x 1)) (i 0 (+ i 1))) ((= i 1) x 3 4))) (f) */ - return(goto_do_end_clauses); + return(goto_do_end_clauses); step1 = s7_slot(sc, car(sc->code)); if (step1 == sc->undefined) /* (let () (define (f) (do ((x 0 (+ x 1)) (i 0 (+ i 1))) ((= i 1) y))) (f)) */ - unbound_variable_error_nr(sc, car(sc->code)); + unbound_variable_error_nr(sc, car(sc->code)); sc->value = slot_value(step1); if (is_t_real(sc->value)) - clear_mutable_number(sc->value); + clear_mutable_number(sc->value); return(goto_start); } do { s7_pointer slt = slots; do { if (slot_has_expression(slt)) - slot_set_value(slt, fx_call(sc, slot_expression(slt))); + slot_set_value(slt, fx_call(sc, slot_expression(slt))); slt = next_slot(slt); } while (tis_slot(slt)); } while ((sc->value = endf(sc, endp)) == sc->F); @@ -82445,11 +82445,11 @@ static goto_t op_dox(s7_scheme *sc) new_cell_no_check(sc, slot, T_SLOT); slot_set_symbol_and_value(slot, caar(vars), val); if (is_pair(stp)) - { - steppers++; - stepper = slot; - slot_set_expression(slot, stp); - } + { + steppers++; + stepper = slot; + slot_set_expression(slot, stp); + } else slot_just_set_expression(slot, sc->nil); slot_set_next(slot, let_slots(let)); let_set_slots(let, slot); @@ -82474,10 +82474,10 @@ static goto_t op_dox(s7_scheme *sc) { s7_pointer stop_slot = (is_symbol(caddr(endp))) ? opt_integer_symbol(sc, caddr(endp)) : sc->nil; if (stop_slot) /* sc->nil -> it's an integer */ - { - set_has_loop_end(stepper); - set_loop_end(stepper, (is_slot(stop_slot)) ? integer(slot_value(stop_slot)) : integer(caddr(endp))); - }} + { + set_has_loop_end(stepper); + set_loop_end(stepper, (is_slot(stop_slot)) ? integer(slot_value(stop_slot)) : integer(caddr(endp))); + }} if (is_true(sc, sc->value = endf(sc, endp))) { @@ -82495,181 +82495,181 @@ static goto_t op_dox(s7_scheme *sc) s7_pfunc bodyf = NULL; if ((!no_cell_opt(code)) && #if WITH_GMP - (!got_bignum) && + (!got_bignum) && #endif - (has_safe_steppers(sc, sc->curlet))) - bodyf = s7_optimize_nv(sc, code); + (has_safe_steppers(sc, sc->curlet))) + bodyf = s7_optimize_nv(sc, code); if ((!bodyf) && - (is_fxable(sc, body)) && /* happens very rarely, #_* as car etc */ - (is_c_function(car(body)))) - bodyf = s7_optimize_nv(sc, set_dlist_1(sc, set_ulist_1(sc, c_function_name_to_symbol(sc, car(body)), cdr(body)))); + (is_fxable(sc, body)) && /* happens very rarely, #_* as car etc */ + (is_c_function(car(body)))) + bodyf = s7_optimize_nv(sc, set_dlist_1(sc, set_ulist_1(sc, c_function_name_to_symbol(sc, car(body)), cdr(body)))); if (bodyf) - { - if (steppers == 1) /* one expr body, 1 stepper */ - { - s7_pointer stepa = car(slot_expression(stepper)); - s7_function stepf = fx_proc(slot_expression(stepper)); - if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && (is_t_integer(slot_value(stepper)))) - { - s7_int i = integer(slot_value(stepper)); - opt_info *o = sc->opts[0]; - if (bodyf == opt_cell_any_nv) - { - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if (!((fp == opt_p_pip_sso) && (o->v[2].p == o->v[4].p) && - (((o->v[5].p_pip_f == string_set_p_pip_unchecked) && (o->v[6].p_pi_f == string_ref_p_pi_unchecked)) || - ((o->v[5].p_pip_f == string_set_p_pip_direct) && (o->v[6].p_pi_f == string_ref_p_pi_direct)) || - ((o->v[5].p_pip_f == vector_set_p_pip_unchecked) && (o->v[6].p_pi_f == t_vector_ref_p_pi_unchecked)) || - ((o->v[5].p_pip_f == t_vector_set_p_pip_direct) && (o->v[6].p_pi_f == t_vector_ref_p_pi_direct)) || - ((o->v[5].p_pip_f == list_set_p_pip_unchecked) && (o->v[6].p_pi_f == list_ref_p_pi_unchecked))) && - (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[3].p), i, endp, stepper)))) - { - if (has_loop_end(stepper)) - { /* (do ((val 0) (i 0 (+ i 1))) ((= i 1) val) (set! val (real-part (v b1 b2)))) */ - s7_int lim = loop_end(stepper); - if ((i >= 0) && (lim < NUM_SMALL_INTS)) - do {fp(o); slot_set_value(stepper, small_int(++i));} while (i < lim); - else do {fp(o); slot_set_value(stepper, make_integer(sc, ++i));} while (i < lim); - sc->value = sc->T; - } - else - do { /* (do ((i start (+ i 1))) ((= end i)) (display i)) */ - fp(o); - slot_set_value(stepper, make_integer(sc, ++i)); - } while ((sc->value = endf(sc, endp)) == sc->F); - }} - else - if (!(((bodyf == opt_float_any_nv) && (o->v[0].fd == opt_d_7pid_ss_ss) && - (o->v[2].p == o->v[6].p) && - ((o->v[4].d_7pid_f == float_vector_set_d_7pid) || (o->v[4].d_7pid_f == float_vector_set_d_7pid_direct)) && - ((o->v[3].d_7pi_f == float_vector_ref_d_7pi) || (o->v[3].d_7pi_f == float_vector_ref_d_7pi_direct)) && - (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[5].p), i, endp, stepper))) || - - ((bodyf == opt_int_any_nv) && ((o->v[0].fi == opt_i_7pii_ssf) || (o->v[0].fi == opt_i_7pii_ssf_vset)) && - (o->v[2].p == o->v[4].o1->v[2].p) && - (((o->v[3].i_7pii_f == int_vector_set_i_7pii) && (o->v[4].o1->v[3].i_7pi_f == int_vector_ref_i_7pi)) || - ((o->v[3].i_7pii_f == int_vector_set_i_7pii_direct) && (o->v[4].o1->v[3].i_7pi_f == int_vector_ref_i_pi_direct))) && - (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[4].o1->v[1].p), i, endp, stepper))))) - /* here the has_loop_end business doesn't happen much */ - do { /* (do ((count 0) (i 7 (+ i 1))) ((= i 10) count) (set! count (quotient i 3))) */ - bodyf(sc); - slot_set_value(stepper, make_integer(sc, ++i)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - do { /* (do ((count 0.0) (i 7.0 (+ i 1.0))) ((>= i 10.0) count) (set! count (modulo i 3.0))) */ - bodyf(sc); - slot_set_value(stepper, stepf(sc, stepa)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - - if ((steppers == 2) && - (!tis_slot(next_slot(next_slot(slots))))) - { - s7_pointer s1 = slots, s2 = next_slot(slots); - s7_function f1 = fx_proc(slot_expression(s1)); - s7_function f2 = fx_proc(slot_expression(s2)); - s7_pointer p1 = car(slot_expression(s1)); - s7_pointer p2 = car(slot_expression(s2)); - /* split out opt_float_any_nv gained nothing (see tmp), same for opt_cell_any_nv, constant end value was never hit */ - if (bodyf == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - s7_pointer s3 = NULL; - /* thash case -- this is dumb */ - if ((f2 == fx_add_u1) && (is_t_integer(slot_value(s2))) && (cadr(endp) == slot_symbol(s2)) && (!s7_tree_memq(sc, cadr(endp), body)) && - (((endf == fx_num_eq_ui) && (is_t_integer(caddr(endp)))) || - ((endf == fx_num_eq_us) && (s3 = opt_integer_symbol(sc, caddr(endp))) && (!s7_tree_memq(sc, caddr(endp), body))))) - { /* (do ((i 0 (+ i 1)) (z (random 100) (random 100))) ((= i 5000000) counts) (hash-table-set! counts z (+ (or (hash-table-ref counts z) 0) 1))) */ - s7_int i = integer(slot_value(s2)); - s7_int endi = (is_t_integer(caddr(endp))) ? integer(caddr(endp)) : integer(slot_value(s3)); - do { - fp(o); - slot_set_value(s1, f1(sc, p1)); - i++; - } while (i < endi); - slot_set_value(s2, make_integer(sc, endi)); - } - else - do { /* (do ((i 0 (+ i 1)) (lst lis (cdr lst))) ((= i (- len 1)) (reverse result)) (set! result (cons (car lst) result))) */ - fp(o); - slot_set_value(s1, f1(sc, p1)); - slot_set_value(s2, f2(sc, p2)); - } while ((sc->value = endf(sc, endp)) == sc->F); - } - else - do { /* (do ((i 0 (+ i 1)) (j 0 (+ j 1))) ((= i 3) x) (set! x (max x (* i j)))) */ - bodyf(sc); - slot_set_value(s1, f1(sc, p1)); - slot_set_value(s2, f2(sc, p2)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } - if (bodyf == opt_cell_any_nv) - { /* (do ((i npats (- i 1)) (ipats ipats (cdr ipats)) (a '())) ((zero? i) a) (set! a (cons (car ipats) a))) */ - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - do { - s7_pointer slot1 = slots; - fp(o); - do { - if (slot_has_expression(slot1)) - slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); - slot1 = next_slot(slot1); - } while (tis_slot(slot1)); - } while ((sc->value = endf(sc, endp)) == sc->F); - } - else - do { /* (do ((i 0 (+ i 1)) (ph 0.0 (+ ph incr)) (kph 0.0 (+ kph kincr))) ((= i 4410)) (float-vector-set! v1 i (+ (cos ph) (cos kph)))) */ - s7_pointer slot1 = slots; - bodyf(sc); - do { - if (slot_has_expression(slot1)) - slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); - slot1 = next_slot(slot1); - } while (tis_slot(slot1)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - } + { + if (steppers == 1) /* one expr body, 1 stepper */ + { + s7_pointer stepa = car(slot_expression(stepper)); + s7_function stepf = fx_proc(slot_expression(stepper)); + if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && (is_t_integer(slot_value(stepper)))) + { + s7_int i = integer(slot_value(stepper)); + opt_info *o = sc->opts[0]; + if (bodyf == opt_cell_any_nv) + { + s7_pointer (*fp)(opt_info *o) = o->v[0].fp; + if (!((fp == opt_p_pip_sso) && (o->v[2].p == o->v[4].p) && + (((o->v[5].p_pip_f == string_set_p_pip_unchecked) && (o->v[6].p_pi_f == string_ref_p_pi_unchecked)) || + ((o->v[5].p_pip_f == string_set_p_pip_direct) && (o->v[6].p_pi_f == string_ref_p_pi_direct)) || + ((o->v[5].p_pip_f == vector_set_p_pip_unchecked) && (o->v[6].p_pi_f == t_vector_ref_p_pi_unchecked)) || + ((o->v[5].p_pip_f == t_vector_set_p_pip_direct) && (o->v[6].p_pi_f == t_vector_ref_p_pi_direct)) || + ((o->v[5].p_pip_f == list_set_p_pip_unchecked) && (o->v[6].p_pi_f == list_ref_p_pi_unchecked))) && + (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[3].p), i, endp, stepper)))) + { + if (has_loop_end(stepper)) + { /* (do ((val 0) (i 0 (+ i 1))) ((= i 1) val) (set! val (real-part (v b1 b2)))) */ + s7_int lim = loop_end(stepper); + if ((i >= 0) && (lim < NUM_SMALL_INTS)) + do {fp(o); slot_set_value(stepper, small_int(++i));} while (i < lim); + else do {fp(o); slot_set_value(stepper, make_integer(sc, ++i));} while (i < lim); + sc->value = sc->T; + } + else + do { /* (do ((i start (+ i 1))) ((= end i)) (display i)) */ + fp(o); + slot_set_value(stepper, make_integer(sc, ++i)); + } while ((sc->value = endf(sc, endp)) == sc->F); + }} + else + if (!(((bodyf == opt_float_any_nv) && (o->v[0].fd == opt_d_7pid_ss_ss) && + (o->v[2].p == o->v[6].p) && + ((o->v[4].d_7pid_f == float_vector_set_d_7pid) || (o->v[4].d_7pid_f == float_vector_set_d_7pid_direct)) && + ((o->v[3].d_7pi_f == float_vector_ref_d_7pi) || (o->v[3].d_7pi_f == float_vector_ref_d_7pi_direct)) && + (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[5].p), i, endp, stepper))) || + + ((bodyf == opt_int_any_nv) && ((o->v[0].fi == opt_i_7pii_ssf) || (o->v[0].fi == opt_i_7pii_ssf_vset)) && + (o->v[2].p == o->v[4].o1->v[2].p) && + (((o->v[3].i_7pii_f == int_vector_set_i_7pii) && (o->v[4].o1->v[3].i_7pi_f == int_vector_ref_i_7pi)) || + ((o->v[3].i_7pii_f == int_vector_set_i_7pii_direct) && (o->v[4].o1->v[3].i_7pi_f == int_vector_ref_i_pi_direct))) && + (copy_if_end_ok(sc, slot_value(o->v[1].p), slot_value(o->v[4].o1->v[1].p), i, endp, stepper))))) + /* here the has_loop_end business doesn't happen much */ + do { /* (do ((count 0) (i 7 (+ i 1))) ((= i 10) count) (set! count (quotient i 3))) */ + bodyf(sc); + slot_set_value(stepper, make_integer(sc, ++i)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return(goto_do_end_clauses); + } + do { /* (do ((count 0.0) (i 7.0 (+ i 1.0))) ((>= i 10.0) count) (set! count (modulo i 3.0))) */ + bodyf(sc); + slot_set_value(stepper, stepf(sc, stepa)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return(goto_do_end_clauses); + } + + if ((steppers == 2) && + (!tis_slot(next_slot(next_slot(slots))))) + { + s7_pointer s1 = slots, s2 = next_slot(slots); + s7_function f1 = fx_proc(slot_expression(s1)); + s7_function f2 = fx_proc(slot_expression(s2)); + s7_pointer p1 = car(slot_expression(s1)); + s7_pointer p2 = car(slot_expression(s2)); + /* split out opt_float_any_nv gained nothing (see tmp), same for opt_cell_any_nv, constant end value was never hit */ + if (bodyf == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = o->v[0].fp; + s7_pointer s3 = NULL; + /* thash case -- this is dumb */ + if ((f2 == fx_add_u1) && (is_t_integer(slot_value(s2))) && (cadr(endp) == slot_symbol(s2)) && (!s7_tree_memq(sc, cadr(endp), body)) && + (((endf == fx_num_eq_ui) && (is_t_integer(caddr(endp)))) || + ((endf == fx_num_eq_us) && (s3 = opt_integer_symbol(sc, caddr(endp))) && (!s7_tree_memq(sc, caddr(endp), body))))) + { /* (do ((i 0 (+ i 1)) (z (random 100) (random 100))) ((= i 5000000) counts) (hash-table-set! counts z (+ (or (hash-table-ref counts z) 0) 1))) */ + s7_int i = integer(slot_value(s2)); + s7_int endi = (is_t_integer(caddr(endp))) ? integer(caddr(endp)) : integer(slot_value(s3)); + do { + fp(o); + slot_set_value(s1, f1(sc, p1)); + i++; + } while (i < endi); + slot_set_value(s2, make_integer(sc, endi)); + } + else + do { /* (do ((i 0 (+ i 1)) (lst lis (cdr lst))) ((= i (- len 1)) (reverse result)) (set! result (cons (car lst) result))) */ + fp(o); + slot_set_value(s1, f1(sc, p1)); + slot_set_value(s2, f2(sc, p2)); + } while ((sc->value = endf(sc, endp)) == sc->F); + } + else + do { /* (do ((i 0 (+ i 1)) (j 0 (+ j 1))) ((= i 3) x) (set! x (max x (* i j)))) */ + bodyf(sc); + slot_set_value(s1, f1(sc, p1)); + slot_set_value(s2, f2(sc, p2)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return(goto_do_end_clauses); + } + if (bodyf == opt_cell_any_nv) + { /* (do ((i npats (- i 1)) (ipats ipats (cdr ipats)) (a '())) ((zero? i) a) (set! a (cons (car ipats) a))) */ + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = o->v[0].fp; + do { + s7_pointer slot1 = slots; + fp(o); + do { + if (slot_has_expression(slot1)) + slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); + slot1 = next_slot(slot1); + } while (tis_slot(slot1)); + } while ((sc->value = endf(sc, endp)) == sc->F); + } + else + do { /* (do ((i 0 (+ i 1)) (ph 0.0 (+ ph incr)) (kph 0.0 (+ kph kincr))) ((= i 4410)) (float-vector-set! v1 i (+ (cos ph) (cos kph)))) */ + s7_pointer slot1 = slots; + bodyf(sc); + do { + if (slot_has_expression(slot1)) + slot_set_value(slot1, fx_call(sc, slot_expression(slot1))); + slot1 = next_slot(slot1); + } while (tis_slot(slot1)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return(goto_do_end_clauses); + } if ((steppers == 1) && - (car(body) == sc->set_symbol) && - (is_pair(cdr(body))) && - (is_symbol(cadr(body))) && - (is_pair(cddr(body))) && - ((has_fx(cddr(body))) || (is_fxable(sc, caddr(body)))) && - (is_null(cdddr(body)))) - { - s7_pointer val = cddr(body), stepa; - s7_function stepf, valf; - s7_pointer slot = s7_slot(sc, cadr(body)); - if (slot == sc->undefined) /* (let ((lim 1)) (define (f) (let ((y 1)) (do ((i 0 (+ i y))) ((= i lim)) (set! xxx 3)))) (f)) */ - unbound_variable_error_nr(sc, cadr(body)); - /* here we could jump to the end of this procedure (unsetting op_dox etc) to avoid (set! a a) as an error if 'a is immutable */ - if (is_immutable_slot(slot)) /* (let ((lim 1)) (define-constant x 1) (define (f) (let ((y 1)) (do ((i 0 (+ i y))) ((= i lim)) (set! x 3)))) (f)) */ - immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S is immutable in ~S", 21), cadr(body), body)); /* "x is immutable in (set! x 3)" */ - - if (!has_fx(val)) - set_fx(val, fx_choose(sc, val, sc->curlet, let_symbol_is_safe)); - valf = fx_proc(val); - val = car(val); - stepf = fx_proc(slot_expression(stepper)); - stepa = car(slot_expression(stepper)); - do { /* (do ((i 1 4)) ((> i 3)) (set! x (+ x i))) */ - slot_set_value(slot, valf(sc, val)); - slot_set_value(stepper, stepf(sc, stepa)); - } while ((sc->value = endf(sc, endp)) == sc->F); - sc->code = cdr(end); - return(goto_do_end_clauses); - }} + (car(body) == sc->set_symbol) && + (is_pair(cdr(body))) && + (is_symbol(cadr(body))) && + (is_pair(cddr(body))) && + ((has_fx(cddr(body))) || (is_fxable(sc, caddr(body)))) && + (is_null(cdddr(body)))) + { + s7_pointer val = cddr(body), stepa; + s7_function stepf, valf; + s7_pointer slot = s7_slot(sc, cadr(body)); + if (slot == sc->undefined) /* (let ((lim 1)) (define (f) (let ((y 1)) (do ((i 0 (+ i y))) ((= i lim)) (set! xxx 3)))) (f)) */ + unbound_variable_error_nr(sc, cadr(body)); + /* here we could jump to the end of this procedure (unsetting op_dox etc) to avoid (set! a a) as an error if 'a is immutable */ + if (is_immutable_slot(slot)) /* (let ((lim 1)) (define-constant x 1) (define (f) (let ((y 1)) (do ((i 0 (+ i y))) ((= i lim)) (set! x 3)))) (f)) */ + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S is immutable in ~S", 21), cadr(body), body)); /* "x is immutable in (set! x 3)" */ + + if (!has_fx(val)) + set_fx(val, fx_choose(sc, val, sc->curlet, let_symbol_is_safe)); + valf = fx_proc(val); + val = car(val); + stepf = fx_proc(slot_expression(stepper)); + stepa = car(slot_expression(stepper)); + do { /* (do ((i 1 4)) ((> i 3)) (set! x (+ x i))) */ + slot_set_value(slot, valf(sc, val)); + slot_set_value(stepper, stepf(sc, stepa)); + } while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return(goto_do_end_clauses); + }} else /* more than one expr */ { s7_pointer p = code; @@ -82680,86 +82680,86 @@ static goto_t op_dox(s7_scheme *sc) if ((!no_cell_opt(code)) && #if WITH_GMP - (!got_bignum) && -#endif - (has_safe_steppers(sc, sc->curlet))) - { - sc->pc = 0; - for (int32_t k = 0; (is_pair(p)) && (k < MAX_OPT_BODY_SIZE); k++, p = cdr(p), body_len++) - { - opt_info *start = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - { - set_no_cell_opt(code); - p = code; - break; - } - oo_idp_nr_fixup(start); - body[k] = start; - } - use_opts = is_null(p); - } + (!got_bignum) && +#endif + (has_safe_steppers(sc, sc->curlet))) + { + sc->pc = 0; + for (int32_t k = 0; (is_pair(p)) && (k < MAX_OPT_BODY_SIZE); k++, p = cdr(p), body_len++) + { + opt_info *start = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + { + set_no_cell_opt(code); + p = code; + break; + } + oo_idp_nr_fixup(start); + body[k] = start; + } + use_opts = is_null(p); + } if (p == code) - for (; is_pair(p); p = cdr(p)) - if (!is_fxable(sc, car(p))) - break; + for (; is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + break; if (is_null(p)) - { - s7_pointer stepa = NULL; - s7_function stepf = NULL; - if (!use_opts) - fx_annotate_args(sc, code, sc->curlet); - if (stepper) - { - stepf = fx_proc(slot_expression(stepper)); - stepa = car(slot_expression(stepper)); - } - while (true) /* (do ((i 0 (+ 1 i))) ((= end i)) (set! end 8) (display i)) */ - { - if (use_opts) - for (int32_t i = 0; i < body_len; i++) - body[i]->v[0].fp(body[i]); - /* opt_set_p_d_f shoot: 144,186,857 => s7.c:opt_set_p_d_f (2,093,278x) (b also, big/fft as part of fft code 7M) */ - else - for (p = code; is_pair(p); p = cdr(p)) - fx_call(sc, p); - - if (steppers == 1) - slot_set_value(stepper, stepf(sc, stepa)); - else - { - s7_pointer slot = slots; - do { - if (slot_has_expression(slot)) - slot_set_value(slot, fx_call(sc, slot_expression(slot))); - slot = next_slot(slot); - } while (tis_slot(slot)); - } - if (is_true(sc, sc->value = endf(sc, endp))) - { - sc->code = cdr(end); - return(goto_do_end_clauses); - }}}} + { + s7_pointer stepa = NULL; + s7_function stepf = NULL; + if (!use_opts) + fx_annotate_args(sc, code, sc->curlet); + if (stepper) + { + stepf = fx_proc(slot_expression(stepper)); + stepa = car(slot_expression(stepper)); + } + while (true) /* (do ((i 0 (+ 1 i))) ((= end i)) (set! end 8) (display i)) */ + { + if (use_opts) + for (int32_t i = 0; i < body_len; i++) + body[i]->v[0].fp(body[i]); + /* opt_set_p_d_f shoot: 144,186,857 => s7.c:opt_set_p_d_f (2,093,278x) (b also, big/fft as part of fft code 7M) */ + else + for (p = code; is_pair(p); p = cdr(p)) + fx_call(sc, p); + + if (steppers == 1) + slot_set_value(stepper, stepf(sc, stepa)); + else + { + s7_pointer slot = slots; + do { + if (slot_has_expression(slot)) + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + slot = next_slot(slot); + } while (tis_slot(slot)); + } + if (is_true(sc, sc->value = endf(sc, endp))) + { + sc->code = cdr(end); + return(goto_do_end_clauses); + }}}} if ((is_null(cdr(code))) && /* one expr */ (is_pair(car(code)))) { code = car(code); if ((is_syntactic_pair(code)) || - (is_symbol_and_syntactic(car(code)))) - { - push_stack_no_args_direct(sc, OP_DOX_STEP_O); - if (is_syntactic_pair(code)) - sc->cur_op = (opcode_t)optimize_op(code); - else - { - sc->cur_op = (opcode_t)symbol_syntax_op_checked(code); - pair_set_syntax_op(code, sc->cur_op); - } - sc->code = code; - return(goto_top_no_pop); - }} + (is_symbol_and_syntactic(car(code)))) + { + push_stack_no_args_direct(sc, OP_DOX_STEP_O); + if (is_syntactic_pair(code)) + sc->cur_op = (opcode_t)optimize_op(code); + else + { + sc->cur_op = (opcode_t)symbol_syntax_op_checked(code); + pair_set_syntax_op(code, sc->cur_op); + } + sc->code = code; + return(goto_top_no_pop); + }} 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_O : OP_DOX_STEP), cdr(form)); @@ -82826,17 +82826,17 @@ static void op_dox_no_body(s7_scheme *sc) */ slot_set_value(slot, istep); if (testf == fx_or_2a) - { - s7_pointer t1 = cadr(test); - s7_pointer t2 = caddr(test); - s7_function f1 = fx_proc(cdr(test)); - s7_function f2 = fx_proc(cddr(test)); - while ((f1(sc, t1) == sc->F) && (f2(sc, t2) == sc->F)) - integer(istep) += incr; - } + { + s7_pointer t1 = cadr(test); + s7_pointer t2 = caddr(test); + s7_function f1 = fx_proc(cdr(test)); + s7_function f2 = fx_proc(cddr(test)); + while ((f1(sc, t1) == sc->F) && (f2(sc, t2) == sc->F)) + integer(istep) += incr; + } else while (testf(sc, test) == sc->F) {integer(istep) += incr;} if (is_small_int(integer(istep))) - slot_set_value(slot, small_int(integer(istep))); + slot_set_value(slot, small_int(integer(istep))); else clear_mutable_integer(istep); /* just clears the T_MUTABLE bit */ sc->value = fx_call(sc, result); } @@ -82845,27 +82845,27 @@ static void op_dox_no_body(s7_scheme *sc) s7_function stepf = fx_proc(cddr(var)); s7_pointer step = caddr(var); if (testf == fx_or_and_2a) - { - s7_pointer f1_arg = cadr(test), p = opt3_pair(test); /* cdadr(p) */ - s7_function f1 = fx_proc(cdr(test)); - s7_pointer f2_arg = car(p); - s7_pointer f3_arg = cadr(p); - s7_function f2 = fx_proc(p); - s7_function f3 = fx_proc(cdr(p)); - if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && (is_t_integer(slot_value(slot)))) - { - s7_pointer ip = make_mutable_integer(sc, integer(slot_value(slot))); - slot_set_value(slot, ip); - while ((f1(sc, f1_arg) == sc->F) && - ((f2(sc, f2_arg) == sc->F) || (f3(sc, f3_arg) == sc->F))) - integer(ip)++; - clear_mutable_integer(ip); - } - else - while ((f1(sc, f1_arg) == sc->F) && - ((f2(sc, f2_arg) == sc->F) || (f3(sc, f3_arg) == sc->F))) - slot_set_value(slot, stepf(sc, step)); - } + { + s7_pointer f1_arg = cadr(test), p = opt3_pair(test); /* cdadr(p) */ + s7_function f1 = fx_proc(cdr(test)); + s7_pointer f2_arg = car(p); + s7_pointer f3_arg = cadr(p); + s7_function f2 = fx_proc(p); + s7_function f3 = fx_proc(cdr(p)); + if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && (is_t_integer(slot_value(slot)))) + { + s7_pointer ip = make_mutable_integer(sc, integer(slot_value(slot))); + slot_set_value(slot, ip); + while ((f1(sc, f1_arg) == sc->F) && + ((f2(sc, f2_arg) == sc->F) || (f3(sc, f3_arg) == sc->F))) + integer(ip)++; + clear_mutable_integer(ip); + } + else + while ((f1(sc, f1_arg) == sc->F) && + ((f2(sc, f2_arg) == sc->F) || (f3(sc, f3_arg) == sc->F))) + slot_set_value(slot, stepf(sc, step)); + } else while (testf(sc, test) == sc->F) {slot_set_value(slot, stepf(sc, step));} sc->value = fx_call(sc, result); } @@ -82882,12 +82882,12 @@ static void op_dox_pending_no_body(s7_scheme *sc) { add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars))); if (is_pair(cddar(vars))) - slot_set_expression(let_slots(let), cddar(vars)); + slot_set_expression(let_slots(let), cddar(vars)); else - { - all_steps = false; - slot_just_set_expression(let_slots(let), sc->nil); - }} + { + all_steps = false; + slot_just_set_expression(let_slots(let), sc->nil); + }} slots = let_slots(let); set_curlet(sc, let); sc->temp1 = sc->unused; @@ -82903,11 +82903,11 @@ static void op_dox_pending_no_body(s7_scheme *sc) s7_pointer slot2 = next_slot(slot1); s7_pointer expr2 = slot_expression(slot2); while (fx_call(sc, test) == sc->F) - { - slot_simply_set_pending_value(slot1, fx_call(sc, expr1)); /* use pending_value for GC protection */ - slot_set_value(slot2, fx_call(sc, expr2)); - slot_set_value(slot1, slot_pending_value(slot1)); - } + { + slot_simply_set_pending_value(slot1, fx_call(sc, expr1)); /* use pending_value for GC protection */ + slot_set_value(slot2, fx_call(sc, expr2)); + slot_set_value(slot1, slot_pending_value(slot1)); + } sc->code = cdr(test); let_clear_has_pending_value(sc, sc->curlet); return; @@ -82916,15 +82916,15 @@ static void op_dox_pending_no_body(s7_scheme *sc) { s7_pointer slt = slots; do { - if (slot_has_expression(slt)) - slot_simply_set_pending_value(slt, fx_call(sc, slot_expression(slt))); - slt = next_slot(slt); + if (slot_has_expression(slt)) + slot_simply_set_pending_value(slt, fx_call(sc, slot_expression(slt))); + slt = next_slot(slt); } while (tis_slot(slt)); slt = slots; do { - if (slot_has_expression(slt)) - slot_set_value(slt, slot_pending_value(slt)); - slt = next_slot(slt); + if (slot_has_expression(slt)) + slot_set_value(slt, slot_pending_value(slt)); + slt = next_slot(slt); } while (tis_slot(slt)); } sc->code = cdr(test); @@ -82943,33 +82943,33 @@ static bool op_do_no_vars(s7_scheme *sc) { body[i] = sc->opts[sc->pc]; if (!cell_optimize(sc, p)) - break; + break; } if (is_null(p)) { s7_pointer end = cadr(sc->code); set_curlet(sc, inline_make_let(sc, sc->curlet)); if (i == 1) - while ((sc->value = fx_call(sc, end)) == sc->F) body[0]->v[0].fp(body[0]); /* presetting body[0] and body[0]->v[0].fp is not faster */ + while ((sc->value = fx_call(sc, end)) == sc->F) body[0]->v[0].fp(body[0]); /* presetting body[0] and body[0]->v[0].fp is not faster */ else - if (i == 2) - { - opt_info *o0 = body[0], *o1 = body[1]; - s7_pointer (*fp0)(opt_info *o) = o0->v[0].fp; - s7_pointer (*fp1)(opt_info *o) = o1->v[0].fp; - while ((sc->value = fx_call(sc, end)) == sc->F) {fp0(o0); fp1(o1);} - } - else - if (i == 0) /* null body! */ - { - s7_function endf = fx_proc(end); - s7_pointer endp = car(end); - while (!is_true(sc, sc->value = endf(sc, endp))); /* the assignment is (normally) in the noise */ - } - else - while ((sc->value = fx_call(sc, end)) == sc->F) - for (int32_t k = 0; k < i; k++) - body[k]->v[0].fp(body[k]); + if (i == 2) + { + opt_info *o0 = body[0], *o1 = body[1]; + s7_pointer (*fp0)(opt_info *o) = o0->v[0].fp; + s7_pointer (*fp1)(opt_info *o) = o1->v[0].fp; + while ((sc->value = fx_call(sc, end)) == sc->F) {fp0(o0); fp1(o1);} + } + else + if (i == 0) /* null body! */ + { + s7_function endf = fx_proc(end); + s7_pointer endp = car(end); + while (!is_true(sc, sc->value = endf(sc, endp))); /* the assignment is (normally) in the noise */ + } + else + while ((sc->value = fx_call(sc, end)) == sc->F) + for (int32_t k = 0; k < i; k++) + body[k]->v[0].fp(body[k]); sc->code = cdr(end); /* inner let still active during result */ return(true); } @@ -83017,11 +83017,11 @@ static void op_do_no_body_na_vars(s7_scheme *sc) /* vars fxable, end-test not */ { add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars))); if (is_pair(cddar(vars))) - { - slot_set_expression(let_slots(let), cddar(vars)); - steppers++; - stepper = let_slots(let); - } + { + slot_set_expression(let_slots(let), cddar(vars)); + steppers++; + stepper = let_slots(let); + } else slot_just_set_expression(let_slots(let), sc->nil); } if (steppers == 1) let_set_dox_slot1(let, stepper); @@ -83065,31 +83065,31 @@ static bool do_step1(s7_scheme *sc) { s7_pointer code; if (is_null(sc->args)) /* after getting the new values, transfer them into the slot_values */ - { - for (s7_pointer x = sc->code; is_pair(x); x = cdr(x)) /* sc->code here is the original sc->args list */ - { - s7_pointer slot = car(x); - if (is_immutable_slot(slot)) /* (let () (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (immutable! 'i)))) (func)) */ - immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S is immutable in ~S", 21), slot_symbol(slot), car(slot_expression(slot)))); - slot_set_value(slot, slot_pending_value(slot)); - slot_clear_has_pending_value(slot); - } - pop_stack_no_op(sc); - return(true); - } + { + for (s7_pointer x = sc->code; is_pair(x); x = cdr(x)) /* sc->code here is the original sc->args list */ + { + s7_pointer slot = car(x); + if (is_immutable_slot(slot)) /* (let () (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (immutable! 'i)))) (func)) */ + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S is immutable in ~S", 21), slot_symbol(slot), car(slot_expression(slot)))); + slot_set_value(slot, slot_pending_value(slot)); + slot_clear_has_pending_value(slot); + } + pop_stack_no_op(sc); + return(true); + } code = T_Pair(slot_expression(car(sc->args))); /* get the next stepper new value */ if (has_fx(code)) - { - sc->value = fx_call(sc, code); - slot_set_pending_value(car(sc->args), sc->value); /* consistently slower if slot_simply_set... here? */ - sc->args = T_Lst(cdr(sc->args)); /* go to next step var */ - } + { + sc->value = fx_call(sc, code); + slot_set_pending_value(car(sc->args), sc->value); /* consistently slower if slot_simply_set... here? */ + sc->args = T_Lst(cdr(sc->args)); /* go to next step var */ + } else - { - push_stack_direct(sc, OP_DO_STEP2); - sc->code = car(code); - return(false); - }} + { + push_stack_direct(sc, OP_DO_STEP2); + sc->code = car(code); + return(false); + }} } static bool op_do_step2(s7_scheme *sc) @@ -83120,7 +83120,7 @@ static goto_t do_end_code(s7_scheme *sc) if (is_pair(cdr(sc->code))) { if (is_undefined_feed_to(sc, car(sc->code))) - return(goto_feed_to); + return(goto_feed_to); /* never has_fx(sc->code) here (first of a body) */ push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); sc->code = car(sc->code); @@ -83156,25 +83156,25 @@ static bool opt_do_copy(s7_scheme *sc, opt_info *o, s7_int start, s7_int stop) s7_pointer dest = slot_value(o->v[1].p); s7_pointer source = slot_value(o->v[3].p); if ((is_t_vector(dest)) && - (((o->v[5].p_pip_f == vector_set_p_pip_unchecked) || (o->v[5].p_pip_f == t_vector_set_p_pip_direct)) && - ((o->v[6].p_pi_f == t_vector_ref_p_pi_unchecked) || (o->v[6].p_pi_f == vector_ref_p_pi_unchecked) || (o->v[6].p_pi_f == t_vector_ref_p_pi_direct)))) - caller = sc->vector_set_symbol; + (((o->v[5].p_pip_f == vector_set_p_pip_unchecked) || (o->v[5].p_pip_f == t_vector_set_p_pip_direct)) && + ((o->v[6].p_pi_f == t_vector_ref_p_pi_unchecked) || (o->v[6].p_pi_f == vector_ref_p_pi_unchecked) || (o->v[6].p_pi_f == t_vector_ref_p_pi_direct)))) + caller = sc->vector_set_symbol; else - if ((is_string(dest)) && - (((o->v[5].p_pip_f == string_set_p_pip_unchecked) || (o->v[5].p_pip_f == string_set_p_pip_direct)) && - ((o->v[6].p_pi_f == string_ref_p_pi_unchecked) || (o->v[6].p_pi_f == string_ref_p_pi_direct)))) - caller = sc->string_set_symbol; - else - if ((is_pair(dest)) && - ((o->v[5].p_pip_f == list_set_p_pip_unchecked) && (o->v[6].p_pi_f == list_ref_p_pi_unchecked))) - caller = sc->list_set_symbol; - else return(false); + if ((is_string(dest)) && + (((o->v[5].p_pip_f == string_set_p_pip_unchecked) || (o->v[5].p_pip_f == string_set_p_pip_direct)) && + ((o->v[6].p_pi_f == string_ref_p_pi_unchecked) || (o->v[6].p_pi_f == string_ref_p_pi_direct)))) + caller = sc->string_set_symbol; + else + if ((is_pair(dest)) && + ((o->v[5].p_pip_f == list_set_p_pip_unchecked) && (o->v[6].p_pi_f == list_ref_p_pi_unchecked))) + caller = sc->list_set_symbol; + else return(false); if (start < 0) - out_of_range_error_nr(sc, caller, wrap_integer(sc, 2), wrap_integer(sc, start), it_is_negative_string); + out_of_range_error_nr(sc, caller, wrap_integer(sc, 2), wrap_integer(sc, start), it_is_negative_string); if ((stop > integer(s7_length(sc, source))) || (stop > integer(s7_length(sc, dest)))) - out_of_range_error_nr(sc, caller, wrap_integer(sc, 2), wrap_integer(sc, stop), it_is_too_large_string); + out_of_range_error_nr(sc, caller, wrap_integer(sc, 2), wrap_integer(sc, stop), it_is_too_large_string); if ((caller) && (copy_to_same_type(sc, dest, source, start, stop, start))) - return(true); + return(true); } return(false); } @@ -83212,51 +83212,51 @@ static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) s7_int stop = integer(slot_value(end_slot)); if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if ((fp == opt_p_ppp_sss) || (fp == opt_p_ppp_sss_mul) || (fp == opt_p_ppp_sss_hset)) - { /* (do ((i 0 (+ i 1))) ((= i 1) (let-ref lt 'a)) (let-set! lt sym i)) */ - s7_p_ppp_t fpt = o->v[4].p_ppp_f; - for (i = start; i < stop; i++) /* thash and below */ - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fpt(sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)); - }} - else - if (fp == opt_p_ppp_sfs) - { /* (do ((i 0 (+ i 1))) ((= i 9)) (vector-set! v4 (expt 2 i) i)) */ - s7_p_ppp_t fpt = o->v[3].p_ppp_f; - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fpt(sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)); - }} - else - if ((fp == opt_p_pip_sss_vset) && (start >= 0) && (stop <= vector_length(slot_value(o->v[1].p)))) - { /* (do ((i 0 (+ i 1))) ((= i 10) v) (vector-set! v i i)) */ - s7_pointer *vels = vector_elements(slot_value(o->v[1].p)); /* better in callgrind, possibly slightly slower in time */ - check_free_heap_size(sc, stop - start); - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer_unchecked(sc, i)); - vels[integer(slot_value(o->v[2].p))] = slot_value(o->v[3].p); - }} - else /* (do ((i 0 (+ i 1))) ((= i 1) (let-ref lt 'a)) (let-set! lt 'a i)) or (do ((i 0 (+ i 1))) ((= i 10)) (list-set! lst i i)) */ - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }} + { + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = o->v[0].fp; + if ((fp == opt_p_ppp_sss) || (fp == opt_p_ppp_sss_mul) || (fp == opt_p_ppp_sss_hset)) + { /* (do ((i 0 (+ i 1))) ((= i 1) (let-ref lt 'a)) (let-set! lt sym i)) */ + s7_p_ppp_t fpt = o->v[4].p_ppp_f; + for (i = start; i < stop; i++) /* thash and below */ + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fpt(sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)); + }} + else + if (fp == opt_p_ppp_sfs) + { /* (do ((i 0 (+ i 1))) ((= i 9)) (vector-set! v4 (expt 2 i) i)) */ + s7_p_ppp_t fpt = o->v[3].p_ppp_f; + for (i = start; i < stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fpt(sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)); + }} + else + if ((fp == opt_p_pip_sss_vset) && (start >= 0) && (stop <= vector_length(slot_value(o->v[1].p)))) + { /* (do ((i 0 (+ i 1))) ((= i 10) v) (vector-set! v i i)) */ + s7_pointer *vels = vector_elements(slot_value(o->v[1].p)); /* better in callgrind, possibly slightly slower in time */ + check_free_heap_size(sc, stop - start); + for (i = start; i < stop; i++) + { + slot_set_value(ctr_slot, make_integer_unchecked(sc, i)); + vels[integer(slot_value(o->v[2].p))] = slot_value(o->v[3].p); + }} + else /* (do ((i 0 (+ i 1))) ((= i 1) (let-ref lt 'a)) (let-set! lt 'a i)) or (do ((i 0 (+ i 1))) ((= i 10)) (list-set! lst i i)) */ + for (i = start; i < stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + }} else - { /* (do ((j (+ nv k -1) (- j 1))) ((< j k)) (set! (r j) (- (r j) (* (q k) (p2 (- j k)))))) */ - /* (do ((__i__ 0 (+ __i__ 1))) ((= __i__ 1) 32.0) (b 0)) and many more, all wrap-int safe I think */ - /* splitting out opt_float_any_nv here saves almost nothing */ - for (i = start; i < stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc); - }} + { /* (do ((j (+ nv k -1) (- j 1))) ((< j k)) (set! (r j) (- (r j) (* (q k) (p2 (- j k)))))) */ + /* (do ((__i__ 0 (+ __i__ 1))) ((= __i__ 1) 32.0) (b 0)) and many more, all wrap-int safe I think */ + /* splitting out opt_float_any_nv here saves almost nothing */ + for (i = start; i < stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc); + }} sc->value = sc->T; sc->code = cdadr(code); return(true); @@ -83268,22 +83268,22 @@ static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) { s7_int i, start = integer(slot_value(ctr_slot)), stop = integer(slot_value(end_slot)); if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - if (!opt_do_copy(sc, o, stop, start + 1)) - { /* (do ((i 9 (- i 1))) ((< i 0) v) (vector-set! v i i)) */ - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - for (i = start; i >= stop; i--) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }}} + { + opt_info *o = sc->opts[0]; + if (!opt_do_copy(sc, o, stop, start + 1)) + { /* (do ((i 9 (- i 1))) ((< i 0) v) (vector-set! v i i)) */ + s7_pointer (*fp)(opt_info *o) = o->v[0].fp; + for (i = start; i >= stop; i--) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + }}} else /* (do ((i 9 (- i 1))) ((< i 0)) (set! (v i) (delay gen 0.5 i))) */ - for (i = start; i >= stop; i--) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc); - } + for (i = start; i >= stop; i--) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc); + } sc->value = sc->T; sc->code = cdadr(code); return(true); @@ -83295,21 +83295,21 @@ static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) { s7_int i, start = integer(slot_value(ctr_slot)), stop = integer(slot_value(end_slot)), incr = integer(caddr(step_expr)); if (func == opt_cell_any_nv) - { /* (do ((i 0 (+ i 2))) ((= i 20)) (display (/ i 2))) */ - /* (do ((i 0 (+ i 8))) ((= i 64)) (write-byte (logand (ash int (- i)) 255))) */ - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - for (i = start; i < stop; i += incr) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }} + { /* (do ((i 0 (+ i 2))) ((= i 20)) (display (/ i 2))) */ + /* (do ((i 0 (+ i 8))) ((= i 64)) (write-byte (logand (ash int (- i)) 255))) */ + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = o->v[0].fp; + for (i = start; i < stop; i += incr) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + }} else - for (i = start; i < stop; i += incr) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - func(sc); - } + for (i = start; i < stop; i += incr) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc); + } sc->value = sc->T; sc->code = cdadr(code); return(true); @@ -83319,44 +83319,44 @@ static bool op_simple_do_1(s7_scheme *sc, s7_pointer code) opt_info *o = sc->opts[0]; s7_pointer (*fp)(opt_info *o) = o->v[0].fp; if ((stepf == g_add_x1) && (is_t_integer(slot_value(ctr_slot))) && - (endf == g_greater_2) && (is_t_integer(slot_value(end_slot)))) - { - s7_int start = integer(slot_value(ctr_slot)); - s7_int stop = integer(slot_value(end_slot)); - if (fp == opt_cond_1b) - { /* (do ((i 0 (+ i 1))) ((> i a)) (cond (i i))) ! */ - s7_pointer (*test_fp)(opt_info *o) = o->v[4].o1->v[O_WRAP].fp; - opt_info *test_o1 = o->v[4].o1; - opt_info *o2 = o->v[6].o1; - for (s7_int i = start; i <= stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - if (test_fp(test_o1) != sc->F) cond_value(o2); - }} - else /* (do ((i 0 (+ i 1))) ((> i a)) (vector-set! v i 1)) */ - for (s7_int i = start; i <= stop; i++) - { - slot_set_value(ctr_slot, make_integer(sc, i)); - fp(o); - }} + (endf == g_greater_2) && (is_t_integer(slot_value(end_slot)))) + { + s7_int start = integer(slot_value(ctr_slot)); + s7_int stop = integer(slot_value(end_slot)); + if (fp == opt_cond_1b) + { /* (do ((i 0 (+ i 1))) ((> i a)) (cond (i i))) ! */ + s7_pointer (*test_fp)(opt_info *o) = o->v[4].o1->v[O_WRAP].fp; + opt_info *test_o1 = o->v[4].o1; + opt_info *o2 = o->v[6].o1; + for (s7_int i = start; i <= stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + if (test_fp(test_o1) != sc->F) cond_value(o2); + }} + else /* (do ((i 0 (+ i 1))) ((> i a)) (vector-set! v i 1)) */ + for (s7_int i = start; i <= stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + }} else /* (do ((i 0 (+ i 1))) ((> i 10)) (display i)) */ - do { - fp(o); - set_car(sc->t2_1, slot_value(ctr_slot)); - set_car(sc->t2_2, step_var); - slot_set_value(ctr_slot, stepf(sc, sc->t2_1)); - set_car(sc->t2_1, slot_value(ctr_slot)); - set_car(sc->t2_2, slot_value(end_slot)); - } while ((sc->value = endf(sc, sc->t2_1)) == sc->F); + do { + fp(o); + set_car(sc->t2_1, slot_value(ctr_slot)); + set_car(sc->t2_2, step_var); + slot_set_value(ctr_slot, stepf(sc, sc->t2_1)); + set_car(sc->t2_1, slot_value(ctr_slot)); + set_car(sc->t2_2, slot_value(end_slot)); + } while ((sc->value = endf(sc, sc->t2_1)) == sc->F); } else /* (do ((i 0 (+ i 1))) ((> i 3) i) (set! i (* i 10))) */ do { - func(sc); - set_car(sc->t2_1, slot_value(ctr_slot)); - set_car(sc->t2_2, step_var); - slot_set_value(ctr_slot, stepf(sc, sc->t2_1)); - set_car(sc->t2_1, slot_value(ctr_slot)); - set_car(sc->t2_2, slot_value(end_slot)); + func(sc); + set_car(sc->t2_1, slot_value(ctr_slot)); + set_car(sc->t2_2, step_var); + slot_set_value(ctr_slot, stepf(sc, sc->t2_1)); + set_car(sc->t2_1, slot_value(ctr_slot)); + set_car(sc->t2_2, slot_value(end_slot)); } while ((sc->value = endf(sc, sc->t2_1)) == sc->F); sc->code = cdadr(code); return(true); @@ -83490,25 +83490,25 @@ static /* inline */ bool op_dotimes_step_o(s7_scheme *sc) /* called once in eval slot_set_value(ctr, make_integer(sc, integer(now) + 1)); now = slot_value(ctr); if (is_t_integer(end)) - { - if ((integer(now) == integer(end)) || - ((integer(now) > integer(end)) && (opt1_cfunc(end_test) == sc->geq_2))) - { - sc->value = sc->T; - sc->code = cdadr(code); - return(true); - }} + { + if ((integer(now) == integer(end)) || + ((integer(now) > integer(end)) && (opt1_cfunc(end_test) == sc->geq_2))) + { + sc->value = sc->T; + sc->code = cdadr(code); + return(true); + }} else - { - set_car(sc->t2_1, now); - set_car(sc->t2_2, end); - end = cadr(code); - sc->value = fn_proc(car(end))(sc, sc->t2_1); - if (is_true(sc, sc->value)) - { - sc->code = cdr(end); - return(true); - }}} + { + set_car(sc->t2_1, now); + set_car(sc->t2_2, end); + end = cadr(code); + sc->value = fn_proc(car(end))(sc, sc->t2_1); + if (is_true(sc, sc->value)) + { + sc->code = cdr(end); + return(true); + }}} else { slot_set_value(ctr, g_add_x1(sc, with_list_t1(now))); @@ -83518,10 +83518,10 @@ static /* inline */ bool op_dotimes_step_o(s7_scheme *sc) /* called once in eval end = cadr(code); sc->value = fn_proc(car(end))(sc, sc->t2_1); if (is_true(sc, sc->value)) - { - sc->code = cdr(end); - return(true); - }} + { + sc->code = cdr(end); + return(true); + }} push_stack_direct(sc, OP_DOTIMES_STEP_O); sc->code = caddr(code); return(false); @@ -83540,187 +83540,187 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool loo if (no_cell_opt(code)) return(false); func = s7_optimize_nv(sc, code); if (!func) - { - set_no_cell_opt(code); - return(false); - } + { + set_no_cell_opt(code); + return(false); + } if (loop_end_ok) - { - s7_int end = loop_end(sc->args); - s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); - slot_set_value(sc->args, stepper); - if ((func == opt_float_any_nv) || - (func == opt_cell_any_nv)) - { - opt_info *o = sc->opts[0]; - if (func == opt_float_any_nv) - { - s7_double (*fd)(opt_info *o) = o->v[0].fd; - if ((fd == opt_d_id_sf) && /* by far the most common case in clm: (outa i ...) etc */ - (is_slot(o->v[1].p)) && - (stepper == slot_value(o->v[1].p))) - { /* (do ((i 0 (+ i 1))) ((= i len) (set! *output* #f) v1) (outa i (- (* i incr) 0.5))) */ - opt_info *o1 = sc->opts[1]; - s7_int end8 = end - 8; - s7_d_id_t f0 = o->v[3].d_id_f; - fd = o1->v[0].fd; - while (integer(stepper) < end8) - LOOP_8(f0(integer(stepper), fd(o1)); integer(stepper)++); - while (integer(stepper) < end) - { - f0(integer(stepper), fd(o1)); - integer(stepper)++; - }} - else - if ((o->v[0].fd == opt_d_7pid_ss_ss) && (o->v[4].d_7pid_f == float_vector_set_d_7pid_direct) && - ((o->v[3].d_7pi_f == float_vector_ref_d_7pi) || (o->v[3].d_7pi_f == float_vector_ref_d_7pi_direct)) && - (o->v[2].p == o->v[6].p)) - copy_to_same_type(sc, slot_value(o->v[1].p), slot_value(o->v[5].p), integer(stepper), end, integer(stepper)); - else - if ((o->v[0].fd == opt_d_7pid_ssc) && - (o->v[4].d_7pid_f == float_vector_set_d_7pid_direct) && - (stepper == slot_value(o->v[2].p))) - s7_fill(sc, set_plist_4(sc, slot_value(o->v[1].p), wrap_real(sc, o->v[3].x), stepper, wrap_integer(sc, end))); /* wrapped 16-Nov-23 */ - else - { /* (do ((i 0 (+ i 1))) ((= i 2) fv) (float-vector-set! fv (+ i 0) (+ i 1) (* 2.0 3.0))) */ - s7_int end4 = end - 4; - while (integer(stepper) < end4) - LOOP_4(fd(o); integer(stepper)++); - for (; integer(stepper) < end; integer(stepper)++) - fd(o); - }} - else - { - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if ((fp == opt_p_pip_ssc) && - (stepper == slot_value(o->v[2].p)) && /* i.e. index by do counter */ - ((o->v[3].p_pip_f == string_set_p_pip_direct) || - (o->v[3].p_pip_f == t_vector_set_p_pip_direct) || - (o->v[3].p_pip_f == list_set_p_pip_unchecked))) - s7_fill(sc, set_plist_4(sc, slot_value(o->v[1].p), o->v[4].p, stepper, wrap_integer(sc, end))); /* wrapped 16-Nov-23 */ - else - if (fp == opt_if_bp) - { /* (do ((i 0 (+ i 1))) ((= i 3) y) (if (= (+ z 1) 2.2) (display (+ z 1)))) */ - for (; integer(stepper) < end; integer(stepper)++) - if (o->v[3].fb(o->v[2].o1)) o->v[5].fp(o->v[4].o1); - } - else - if (fp == opt_if_nbp_fs) - { /* (do ((i 0 (+ i 1))) ((= i len)) (if (not (= (list-ref lst i) i)) (display "oops"))) */ - for (; integer(stepper) < end; integer(stepper)++) - if (!(o->v[2].b_pi_f(sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p))))) o->v[11].fp(o->v[10].o1); - } - else - if (fp == opt_unless_p_1) - { /* (do ((i 0 (+ i 1))) ((= i size)) (unless (= (hash-table-ref vct-hash (float-vector i)) i) (display "oops"))) */ - for (; integer(stepper) < end; integer(stepper)++) - if (!(o->v[4].fb(o->v[3].o1))) o->v[5].o1->v[0].fp(o->v[5].o1); - } - else /* (do ((i 0 (+ i 1))) ((= i size) (vector-ref v 0)) (vector-set! v i 2)) */ - for (; integer(stepper) < end; integer(stepper)++) fp(o); - }} - else - if (func == opt_int_any_nv) - { - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - if ((fi == opt_i_7pii_ssc) && (stepper == slot_value(o->v[2].p)) && (o->v[3].i_7pii_f == int_vector_set_i_7pii_direct)) - s7_fill(sc, set_plist_4(sc, slot_value(o->v[1].p), wrap_integer(sc, o->v[4].i), stepper, wrap_integer(sc, end))); /* wrapped 16-Nov-23 */ - else - if ((o->v[3].i_7pii_f == int_vector_set_i_7pii_direct) && (o->v[5].fi == opt_i_pi_ss_ivref) && (o->v[2].p == o->v[4].o1->v[2].p)) - copy_to_same_type(sc, slot_value(o->v[1].p), slot_value(o->v[4].o1->v[1].p), integer(stepper), end, integer(stepper)); - else /* (do ((i 0 (+ i 1))) ((= i size) (byte-vector-ref v 0)) (byte-vector-set! v i 2)) */ - for (; integer(stepper) < end; integer(stepper)++) - fi(o); - } - else /* (do ((i 0 (+ i 1))) ((= i 1)) (char-alphabetic? (string-ref #u(0 1) 1))) or (logbit? i -1): kinda nutty */ - for (; integer(stepper) < end; integer(stepper)++) - func(sc); - clear_mutable_integer(stepper); - } + { + s7_int end = loop_end(sc->args); + s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); + slot_set_value(sc->args, stepper); + if ((func == opt_float_any_nv) || + (func == opt_cell_any_nv)) + { + opt_info *o = sc->opts[0]; + if (func == opt_float_any_nv) + { + s7_double (*fd)(opt_info *o) = o->v[0].fd; + if ((fd == opt_d_id_sf) && /* by far the most common case in clm: (outa i ...) etc */ + (is_slot(o->v[1].p)) && + (stepper == slot_value(o->v[1].p))) + { /* (do ((i 0 (+ i 1))) ((= i len) (set! *output* #f) v1) (outa i (- (* i incr) 0.5))) */ + opt_info *o1 = sc->opts[1]; + s7_int end8 = end - 8; + s7_d_id_t f0 = o->v[3].d_id_f; + fd = o1->v[0].fd; + while (integer(stepper) < end8) + LOOP_8(f0(integer(stepper), fd(o1)); integer(stepper)++); + while (integer(stepper) < end) + { + f0(integer(stepper), fd(o1)); + integer(stepper)++; + }} + else + if ((o->v[0].fd == opt_d_7pid_ss_ss) && (o->v[4].d_7pid_f == float_vector_set_d_7pid_direct) && + ((o->v[3].d_7pi_f == float_vector_ref_d_7pi) || (o->v[3].d_7pi_f == float_vector_ref_d_7pi_direct)) && + (o->v[2].p == o->v[6].p)) + copy_to_same_type(sc, slot_value(o->v[1].p), slot_value(o->v[5].p), integer(stepper), end, integer(stepper)); + else + if ((o->v[0].fd == opt_d_7pid_ssc) && + (o->v[4].d_7pid_f == float_vector_set_d_7pid_direct) && + (stepper == slot_value(o->v[2].p))) + s7_fill(sc, set_plist_4(sc, slot_value(o->v[1].p), wrap_real(sc, o->v[3].x), stepper, wrap_integer(sc, end))); /* wrapped 16-Nov-23 */ + else + { /* (do ((i 0 (+ i 1))) ((= i 2) fv) (float-vector-set! fv (+ i 0) (+ i 1) (* 2.0 3.0))) */ + s7_int end4 = end - 4; + while (integer(stepper) < end4) + LOOP_4(fd(o); integer(stepper)++); + for (; integer(stepper) < end; integer(stepper)++) + fd(o); + }} + else + { + s7_pointer (*fp)(opt_info *o) = o->v[0].fp; + if ((fp == opt_p_pip_ssc) && + (stepper == slot_value(o->v[2].p)) && /* i.e. index by do counter */ + ((o->v[3].p_pip_f == string_set_p_pip_direct) || + (o->v[3].p_pip_f == t_vector_set_p_pip_direct) || + (o->v[3].p_pip_f == list_set_p_pip_unchecked))) + s7_fill(sc, set_plist_4(sc, slot_value(o->v[1].p), o->v[4].p, stepper, wrap_integer(sc, end))); /* wrapped 16-Nov-23 */ + else + if (fp == opt_if_bp) + { /* (do ((i 0 (+ i 1))) ((= i 3) y) (if (= (+ z 1) 2.2) (display (+ z 1)))) */ + for (; integer(stepper) < end; integer(stepper)++) + if (o->v[3].fb(o->v[2].o1)) o->v[5].fp(o->v[4].o1); + } + else + if (fp == opt_if_nbp_fs) + { /* (do ((i 0 (+ i 1))) ((= i len)) (if (not (= (list-ref lst i) i)) (display "oops"))) */ + for (; integer(stepper) < end; integer(stepper)++) + if (!(o->v[2].b_pi_f(sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p))))) o->v[11].fp(o->v[10].o1); + } + else + if (fp == opt_unless_p_1) + { /* (do ((i 0 (+ i 1))) ((= i size)) (unless (= (hash-table-ref vct-hash (float-vector i)) i) (display "oops"))) */ + for (; integer(stepper) < end; integer(stepper)++) + if (!(o->v[4].fb(o->v[3].o1))) o->v[5].o1->v[0].fp(o->v[5].o1); + } + else /* (do ((i 0 (+ i 1))) ((= i size) (vector-ref v 0)) (vector-set! v i 2)) */ + for (; integer(stepper) < end; integer(stepper)++) fp(o); + }} + else + if (func == opt_int_any_nv) + { + opt_info *o = sc->opts[0]; + s7_int (*fi)(opt_info *o) = o->v[0].fi; + if ((fi == opt_i_7pii_ssc) && (stepper == slot_value(o->v[2].p)) && (o->v[3].i_7pii_f == int_vector_set_i_7pii_direct)) + s7_fill(sc, set_plist_4(sc, slot_value(o->v[1].p), wrap_integer(sc, o->v[4].i), stepper, wrap_integer(sc, end))); /* wrapped 16-Nov-23 */ + else + if ((o->v[3].i_7pii_f == int_vector_set_i_7pii_direct) && (o->v[5].fi == opt_i_pi_ss_ivref) && (o->v[2].p == o->v[4].o1->v[2].p)) + copy_to_same_type(sc, slot_value(o->v[1].p), slot_value(o->v[4].o1->v[1].p), integer(stepper), end, integer(stepper)); + else /* (do ((i 0 (+ i 1))) ((= i size) (byte-vector-ref v 0)) (byte-vector-set! v i 2)) */ + for (; integer(stepper) < end; integer(stepper)++) + fi(o); + } + else /* (do ((i 0 (+ i 1))) ((= i 1)) (char-alphabetic? (string-ref #u(0 1) 1))) or (logbit? i -1): kinda nutty */ + for (; integer(stepper) < end; integer(stepper)++) + func(sc); + clear_mutable_integer(stepper); + } else - { - s7_pointer step_slot = let_dox_slot1(sc->curlet); - s7_pointer end_slot = let_dox_slot2(sc->curlet); - s7_int step = integer(slot_value(step_slot)); - s7_int stop = integer(slot_value(end_slot)); - step_val = slot_value(step_slot); - - if (func == opt_cell_any_nv) - { - opt_info *o = sc->opts[0]; - s7_pointer (*fp)(opt_info *o) = o->v[0].fp; - if (!opt_do_copy(sc, o, step, stop)) - { - if ((step >= 0) && (stop < NUM_SMALL_INTS)) - { - if (fp == opt_when_p_2) - { /* (do ((i 0 (+ i 1))) ((= i len) (list mx loc)) (when (> (abs (vect i)) mx) (set! mx (vect i)) (set! loc i))) */ - for (; step < stop; step++) - { - slot_set_value(step_slot, small_int(step)); - if (o->v[4].fb(o->v[3].o1)) - { - o->v[6].fp(o->v[5].o1); - o->v[8].fp(o->v[7].o1); - }}} - else /* (do ((k 0 (+ k 1))) ((= k 10) sum) (do ((i 0 (+ i 1))) ((= i size/10)) (set! sum (+ sum (round (vector-ref v k i)))))) */ - for (; step < stop; step++) - { - slot_set_value(step_slot, small_int(step)); - fp(o); - }} - else /* (do ((i 0 (+ i 1))) ((= i len) (list mx loc)) (when (> (abs (vect i)) mx) (set! mx (vect i)) (set! loc i))) */ - for (; step < stop; step++) - { - slot_set_value(step_slot, make_integer(sc, step)); - fp(o); - }}} - else - if ((step >= 0) && (stop < NUM_SMALL_INTS)) - { /* (do ((i 0 (+ i 1))) ((= i 1) x) (set! x (+ (* x1 (block-ref b1 i)) (* x2 (block-ref b2 j))))) */ - for (; step < stop; step++) - { - slot_set_value(step_slot, small_int(step)); - func(sc); - }} - else - if (func == opt_int_any_nv) - { /* (do ((i 0 (+ i 1))) ((= i size) sum) (set! sum (+ sum (floor (vector-ref v i))))) */ - opt_info *o = sc->opts[0]; - s7_int (*fi)(opt_info *o) = o->v[0].fi; - if ((fi == opt_set_i_i_f) || (fi == opt_set_i_i_fo)) - { - slot_set_value(o->v[1].p, make_mutable_integer(sc, integer(slot_value(o->v[1].p)))); - fi = (fi == opt_set_i_i_f) ? opt_set_i_i_fm : opt_set_i_i_fom; - } - while (step < stop) - { - fi(o); - step = ++integer(step_val); - } - if ((fi == opt_set_i_i_fm) || (fi == opt_set_i_i_fom)) - clear_mutable_integer(slot_value(o->v[1].p)); - } - else - if (func == opt_float_any_nv) - { /* (do ((i 1 (+ i 1))) ((= i 1000)) (set! (v i) (filter f1 0.0))) */ - opt_info *o = sc->opts[0]; - s7_double (*fd)(opt_info *o) = o->v[0].fd; - if (fd == opt_set_d_d_f) - { /* (do ((i 0 (+ i 1))) ((= i 32768)) (set! sum (+ sum (float-vector-ref ndat i)))) */ - slot_set_value(o->v[1].p, make_mutable_real(sc, real(slot_value(o->v[1].p)))); - fd = opt_set_d_d_fm; - } - while (step < stop) - { - fd(o); - step = ++integer(step_val); - } - if (fd == opt_set_d_d_fm) - clear_mutable_number(slot_value(o->v[1].p)); - }} - /* there aren't any other possibilities */ + { + s7_pointer step_slot = let_dox_slot1(sc->curlet); + s7_pointer end_slot = let_dox_slot2(sc->curlet); + s7_int step = integer(slot_value(step_slot)); + s7_int stop = integer(slot_value(end_slot)); + step_val = slot_value(step_slot); + + if (func == opt_cell_any_nv) + { + opt_info *o = sc->opts[0]; + s7_pointer (*fp)(opt_info *o) = o->v[0].fp; + if (!opt_do_copy(sc, o, step, stop)) + { + if ((step >= 0) && (stop < NUM_SMALL_INTS)) + { + if (fp == opt_when_p_2) + { /* (do ((i 0 (+ i 1))) ((= i len) (list mx loc)) (when (> (abs (vect i)) mx) (set! mx (vect i)) (set! loc i))) */ + for (; step < stop; step++) + { + slot_set_value(step_slot, small_int(step)); + if (o->v[4].fb(o->v[3].o1)) + { + o->v[6].fp(o->v[5].o1); + o->v[8].fp(o->v[7].o1); + }}} + else /* (do ((k 0 (+ k 1))) ((= k 10) sum) (do ((i 0 (+ i 1))) ((= i size/10)) (set! sum (+ sum (round (vector-ref v k i)))))) */ + for (; step < stop; step++) + { + slot_set_value(step_slot, small_int(step)); + fp(o); + }} + else /* (do ((i 0 (+ i 1))) ((= i len) (list mx loc)) (when (> (abs (vect i)) mx) (set! mx (vect i)) (set! loc i))) */ + for (; step < stop; step++) + { + slot_set_value(step_slot, make_integer(sc, step)); + fp(o); + }}} + else + if ((step >= 0) && (stop < NUM_SMALL_INTS)) + { /* (do ((i 0 (+ i 1))) ((= i 1) x) (set! x (+ (* x1 (block-ref b1 i)) (* x2 (block-ref b2 j))))) */ + for (; step < stop; step++) + { + slot_set_value(step_slot, small_int(step)); + func(sc); + }} + else + if (func == opt_int_any_nv) + { /* (do ((i 0 (+ i 1))) ((= i size) sum) (set! sum (+ sum (floor (vector-ref v i))))) */ + opt_info *o = sc->opts[0]; + s7_int (*fi)(opt_info *o) = o->v[0].fi; + if ((fi == opt_set_i_i_f) || (fi == opt_set_i_i_fo)) + { + slot_set_value(o->v[1].p, make_mutable_integer(sc, integer(slot_value(o->v[1].p)))); + fi = (fi == opt_set_i_i_f) ? opt_set_i_i_fm : opt_set_i_i_fom; + } + while (step < stop) + { + fi(o); + step = ++integer(step_val); + } + if ((fi == opt_set_i_i_fm) || (fi == opt_set_i_i_fom)) + clear_mutable_integer(slot_value(o->v[1].p)); + } + else + if (func == opt_float_any_nv) + { /* (do ((i 1 (+ i 1))) ((= i 1000)) (set! (v i) (filter f1 0.0))) */ + opt_info *o = sc->opts[0]; + s7_double (*fd)(opt_info *o) = o->v[0].fd; + if (fd == opt_set_d_d_f) + { /* (do ((i 0 (+ i 1))) ((= i 32768)) (set! sum (+ sum (float-vector-ref ndat i)))) */ + slot_set_value(o->v[1].p, make_mutable_real(sc, real(slot_value(o->v[1].p)))); + fd = opt_set_d_d_fm; + } + while (step < stop) + { + fd(o); + step = ++integer(step_val); + } + if (fd == opt_set_d_d_fm) + clear_mutable_number(slot_value(o->v[1].p)); + }} + /* there aren't any other possibilities */ sc->value = sc->T; sc->code = cdadr(scc); return(true); @@ -83737,86 +83737,86 @@ static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool loo if (!no_float_opt(code)) { - 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 opt_set_d_d_f -> fm mutablizing body[k]->v[1].p? see 83033 but protect against (data i) as below */ - } - if (is_pair(p)) - { - sc->pc = 0; - set_no_float_opt(code); - } - else - { - if (loop_end_ok) - { /* (do ((i start (+ i 1))) ((= i end)) (outa i (* ampa (ina i *reverb*))) (outb i (* ampb (inb i *reverb*)))) */ - s7_int end = loop_end(sc->args); - s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); - slot_set_value(sc->args, stepper); - for (; integer(stepper) < end; integer(stepper)++) - for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fd(body[i]); - clear_mutable_integer(stepper); - } - else - { /* (do ((i 0 (+ i 1))) ((= i 5)) (set! (data i) (delay dly1 impulse -0.4)) (set! impulse 0.0)) */ - s7_pointer step_slot = let_dox_slot1(sc->curlet); - s7_pointer end_slot = let_dox_slot2(sc->curlet); - s7_int stop = integer(slot_value(end_slot)); - step_val = slot_value(step_slot); - for (s7_int step = integer(step_val); step < stop; step = ++integer(step_val)) - for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fd(body[i]); - /* tari[99 ff]: 4 calls here all safe (see d_syntax_ok, need to make the change and the list here dependent on two-sets bit(?) (3.3M calls) */ - /* tall: (3.3M calls) */ - } - sc->value = sc->T; - sc->code = cdadr(scc); - return(true); - }} + 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 opt_set_d_d_f -> fm mutablizing body[k]->v[1].p? see 83033 but protect against (data i) as below */ + } + if (is_pair(p)) + { + sc->pc = 0; + set_no_float_opt(code); + } + else + { + if (loop_end_ok) + { /* (do ((i start (+ i 1))) ((= i end)) (outa i (* ampa (ina i *reverb*))) (outb i (* ampb (inb i *reverb*)))) */ + s7_int end = loop_end(sc->args); + s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); + slot_set_value(sc->args, stepper); + for (; integer(stepper) < end; integer(stepper)++) + for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fd(body[i]); + clear_mutable_integer(stepper); + } + else + { /* (do ((i 0 (+ i 1))) ((= i 5)) (set! (data i) (delay dly1 impulse -0.4)) (set! impulse 0.0)) */ + s7_pointer step_slot = let_dox_slot1(sc->curlet); + s7_pointer end_slot = let_dox_slot2(sc->curlet); + s7_int stop = integer(slot_value(end_slot)); + step_val = slot_value(step_slot); + for (s7_int step = integer(step_val); step < stop; step = ++integer(step_val)) + for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fd(body[i]); + /* tari[99 ff]: 4 calls here all safe (see d_syntax_ok, need to make the change and the list here dependent on two-sets bit(?) (3.3M calls) */ + /* tall: (3.3M calls) */ + } + sc->value = sc->T; + sc->code = cdadr(scc); + return(true); + }} /* not float opt */ sc->pc = 0; for (k = 0, p = code; is_pair(p); k++, p = cdr(p)) { - opt_info *start = sc->opts[sc->pc]; - if (!cell_optimize(sc, p)) - break; - oo_idp_nr_fixup(start); - body[k] = start; + opt_info *start = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + oo_idp_nr_fixup(start); + body[k] = start; } if (is_null(p)) { - if ((S7_DEBUGGING) && (loop_end_ok) && (!has_loop_end(sc->args))) fprintf(stderr, "%s[%d]: loop_end_ok but not has_loop_end\n", __func__, __LINE__); - if (loop_end_ok) - { /* (do ((i 0 (+ i 1))) ((= i 1) strs) (copy (vector-ref strs i) (make-string 1)) (copy (vector-ref strs i) (make-string 0))) */ - s7_int end = loop_end(sc->args); - s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); - slot_set_value(sc->args, stepper); - if ((body_len & 0x3) == 0) - for (; integer(stepper) < end; integer(stepper)++) - for (int32_t i = 0; i < body_len; ) - LOOP_4(body[i]->v[0].fp(body[i]); i++); - else - for (; integer(stepper) < end; integer(stepper)++) - for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fp(body[i]); - clear_mutable_integer(stepper); - } - else - { /* (do ((k j (+ k 1))) ((= k len2) obj) (set! (obj n) (seq2 k)) (set! n (+ n 1))) */ - s7_pointer step_slot = let_dox_slot1(sc->curlet); - s7_pointer end_slot = let_dox_slot2(sc->curlet); - s7_int stop = integer(slot_value(end_slot)); - for (s7_int step = integer(slot_value(step_slot)); step < stop; step++) - { - slot_set_value(step_slot, make_integer(sc, step)); - for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fp(body[i]); - }} - sc->value = sc->T; - sc->code = cdadr(scc); - return(true); + if ((S7_DEBUGGING) && (loop_end_ok) && (!has_loop_end(sc->args))) fprintf(stderr, "%s[%d]: loop_end_ok but not has_loop_end\n", __func__, __LINE__); + if (loop_end_ok) + { /* (do ((i 0 (+ i 1))) ((= i 1) strs) (copy (vector-ref strs i) (make-string 1)) (copy (vector-ref strs i) (make-string 0))) */ + s7_int end = loop_end(sc->args); + s7_pointer stepper = make_mutable_integer(sc, integer(slot_value(sc->args))); + slot_set_value(sc->args, stepper); + if ((body_len & 0x3) == 0) + for (; integer(stepper) < end; integer(stepper)++) + for (int32_t i = 0; i < body_len; ) + LOOP_4(body[i]->v[0].fp(body[i]); i++); + else + for (; integer(stepper) < end; integer(stepper)++) + for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fp(body[i]); + clear_mutable_integer(stepper); + } + else + { /* (do ((k j (+ k 1))) ((= k len2) obj) (set! (obj n) (seq2 k)) (set! n (+ n 1))) */ + s7_pointer step_slot = let_dox_slot1(sc->curlet); + s7_pointer end_slot = let_dox_slot2(sc->curlet); + s7_int stop = integer(slot_value(end_slot)); + for (s7_int step = integer(slot_value(step_slot)); step < stop; step++) + { + slot_set_value(step_slot, make_integer(sc, step)); + for (int32_t i = 0; i < body_len; i++) body[i]->v[0].fp(body[i]); + }} + sc->value = sc->T; + sc->code = cdadr(scc); + return(true); }} return(false); } @@ -83849,17 +83849,17 @@ static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) for (var_len = 0, p = let_vars; (is_pair(p)) && (var_len < 32); var_len++, p = cdr(p)) { if ((!is_pair(car(p))) || - (!is_normal_symbol(caar(p))) || - (!is_pair(cdar(p)))) - return(false); + (!is_normal_symbol(caar(p))) || + (!is_pair(cdar(p)))) + return(false); vars[var_len] = sc->opts[sc->pc]; if (!float_optimize(sc, cdar(p))) /* each of these needs to set the associated variable */ - { - set_curlet(sc, old_e); - return(false); - } + { + set_curlet(sc, old_e); + return(false); + } if (let_star) - add_slot_checked(sc, sc->curlet, caar(p), make_mutable_real(sc, 1.5)); + add_slot_checked(sc, sc->curlet, caar(p), make_mutable_real(sc, 1.5)); } if (!let_star) @@ -83870,10 +83870,10 @@ static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) { body[k] = sc->opts[sc->pc]; if (!float_optimize(sc, p)) - { - set_curlet(sc, old_e); - return(false); - }} + { + set_curlet(sc, old_e); + return(false); + }} if (!is_null(p)) /* no hits in s7test or snd-test */ { set_curlet(sc, old_e); @@ -83886,92 +83886,92 @@ static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) if (body_len == 1) { if (var_len == 1) - { - opt_info *first = sc->opts[0]; - opt_info *o = body[0]; - s7_pointer xp = t_lookup(sc, caar(let_vars), let_vars); - s7_double (*f1)(opt_info *o) = first->v[0].fd; - s7_double (*f2)(opt_info *o) = o->v[0].fd; - set_integer(ip, numerator(stepper)); - set_real(xp, f1(first)); - 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))) - { - opt_info *o1 = o->v[12].o1; - opt_info *o2 = o->v[13].o1; - opt_info *o3 = o->v[14].o1; - s7_d_vid_t vf7 = o->v[4].d_vid_f; - s7_d_v_t vf1 = first->v[4].d_v_f; - s7_d_v_t vf2 = first->v[5].d_v_f; - s7_d_v_t vf3 = o1->v[2].d_v_f; - s7_d_v_t vf4 = o3->v[5].d_v_f; - s7_d_vd_t vf5 = o2->v[3].d_vd_f; - s7_d_vd_t vf6 = o3->v[6].d_vd_f; - void *obj1 = first->v[1].obj; - void *obj2 = first->v[2].obj; - void *obj3 = o1->v[1].obj; - void *obj4 = o3->v[1].obj; - void *obj5 = o->v[5].obj; - void *obj6 = o2->v[5].obj; - void *obj7 = o3->v[2].obj; - for (k = numerator(stepper) + 1; k < end; k++) - { - s7_double vib = vf1(obj1) + vf2(obj2); - s7_double amp_env = vf3(obj3); - vf7(obj5, k, amp_env * vf5(obj6, vib + (vf4(obj4) * vf6(obj7, vib)))); - }} - else - for (k = numerator(stepper) + 1; k < end; k++) - { - set_integer(ip, k); - set_real(xp, f1(first)); - f2(o); - }} /* body_len == 1 and var_len == 1 */ + { + opt_info *first = sc->opts[0]; + opt_info *o = body[0]; + s7_pointer xp = t_lookup(sc, caar(let_vars), let_vars); + s7_double (*f1)(opt_info *o) = first->v[0].fd; + s7_double (*f2)(opt_info *o) = o->v[0].fd; + set_integer(ip, numerator(stepper)); + set_real(xp, f1(first)); + 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))) + { + opt_info *o1 = o->v[12].o1; + opt_info *o2 = o->v[13].o1; + opt_info *o3 = o->v[14].o1; + s7_d_vid_t vf7 = o->v[4].d_vid_f; + s7_d_v_t vf1 = first->v[4].d_v_f; + s7_d_v_t vf2 = first->v[5].d_v_f; + s7_d_v_t vf3 = o1->v[2].d_v_f; + s7_d_v_t vf4 = o3->v[5].d_v_f; + s7_d_vd_t vf5 = o2->v[3].d_vd_f; + s7_d_vd_t vf6 = o3->v[6].d_vd_f; + void *obj1 = first->v[1].obj; + void *obj2 = first->v[2].obj; + void *obj3 = o1->v[1].obj; + void *obj4 = o3->v[1].obj; + void *obj5 = o->v[5].obj; + void *obj6 = o2->v[5].obj; + void *obj7 = o3->v[2].obj; + for (k = numerator(stepper) + 1; k < end; k++) + { + s7_double vib = vf1(obj1) + vf2(obj2); + s7_double amp_env = vf3(obj3); + vf7(obj5, k, amp_env * vf5(obj6, vib + (vf4(obj4) * vf6(obj7, vib)))); + }} + else + for (k = numerator(stepper) + 1; k < end; k++) + { + set_integer(ip, k); + set_real(xp, f1(first)); + f2(o); + }} /* body_len == 1 and var_len == 1 */ else - { - if (var_len == 2) - { - s7_pointer s1 = let_slots(sc->curlet); - s7_pointer s2 = next_slot(s1); - for (k = numerator(stepper); k < end; k++) - { - set_integer(ip, k); - 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++) - { - set_integer(ip, k); - p = let_slots(sc->curlet); - for (int32_t n = 0; 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]); - }}} /* end body_len == 1 */ + { + if (var_len == 2) + { + s7_pointer s1 = let_slots(sc->curlet); + s7_pointer s2 = next_slot(s1); + for (k = numerator(stepper); k < end; k++) + { + set_integer(ip, k); + 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++) + { + set_integer(ip, k); + p = let_slots(sc->curlet); + for (int32_t n = 0; 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]); + }}} /* end body_len == 1 */ else if ((body_len == 2) && (var_len == 1)) { - s7_pointer s1 = let_slots(sc->curlet); - for (k = numerator(stepper); k < end; k++) - { - set_integer(ip, k); - 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]); - }} + s7_pointer s1 = let_slots(sc->curlet); + for (k = numerator(stepper); k < end; k++) + { + set_integer(ip, k); + 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 for (k = numerator(stepper); k < end; k++) - { - int32_t i; - set_integer(ip, k); - for (i = 0, p = let_slots(sc->curlet); 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++) body[i]->v[0].fd(body[i]); - } + { + int32_t i; + set_integer(ip, k); + for (i = 0, p = let_slots(sc->curlet); 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++) body[i]->v[0].fd(body[i]); + } set_curlet(sc, old_e); sc->value = sc->T; sc->code = cdadr(scc); @@ -84001,82 +84001,82 @@ static goto_t op_safe_dotimes(s7_scheme *sc) s7_pointer code = sc->code; s7_pointer end_val = caddr(end_expr); if (is_symbol(end_val)) - end_val = lookup_checked(sc, end_val); + end_val = lookup_checked(sc, end_val); if (s7_is_integer(end_val)) - { - sc->code = cddr(code); - set_curlet(sc, make_let(sc, sc->curlet)); - sc->args = add_slot_checked(sc, sc->curlet, caaar(code), make_mutable_integer(sc, s7_integer_clamped_if_gmp(sc, init_val))); - set_loop_end(sc->args, s7_integer_clamped_if_gmp(sc, end_val)); - set_has_loop_end(sc->args); /* safe_dotimes step is by 1 */ - - /* (define (hi) (do ((i 1 (+ 1 i))) ((= i 1) i))) -- we need the let even if the loop is not evaluated */ - - /* safe_dotimes: (car(body) is known to be a pair here) - * if 1-expr body look for syntactic case, if let(*) goto do_let, else opt_dotimes - * if they are unhappy, got safe_dotimes_step_o - * else goto opt_dotimes then safe_dotimes_step_o - * if multi-line body, check opt_dotimes, then safe_dotimes_step - */ - if (s7_integer_clamped_if_gmp(sc, init_val) == s7_integer_clamped_if_gmp(sc, end_val)) - { - sc->value = sc->T; - sc->code = cdadr(code); - return(goto_safe_do_end_clauses); - } - if ((is_null(cdr(sc->code))) && - (is_pair(car(sc->code)))) - { - sc->code = car(sc->code); - set_opt2_pair(code, sc->code); /* is_pair above */ - if ((is_syntactic_pair(sc->code)) || - (is_symbol_and_syntactic(car(sc->code)))) - { - if (!is_unsafe_do(code)) - { - if (do_let_or_dotimes(sc, code, true)) - return(goto_safe_do_end_clauses); - set_unsafe_do(code); - } - push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code); - if (is_syntactic_pair(sc->code)) - sc->cur_op = (opcode_t)optimize_op(sc->code); - else - { - sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); - pair_set_syntax_op(sc->code, sc->cur_op); - } - return(goto_top_no_pop); - } - /* car not syntactic? */ - if ((!is_unsafe_do(code)) && - (opt_dotimes(sc, cddr(code), code, true))) - return(goto_safe_do_end_clauses); - set_unsafe_do(code); - - if (has_fx(cddr(code))) /* this almost never happens and the func case below is only in timing tests */ - { - s7_int end = s7_integer_clamped_if_gmp(sc, end_val); - s7_pointer body = cddr(code), stepper = slot_value(sc->args); - for (; integer(stepper) < end; integer(stepper)++) - fx_call(sc, body); - sc->value = sc->T; - sc->code = cdadr(code); - return(goto_safe_do_end_clauses); - } - push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code); /* arg is local step var slot, code is do form - do, sc->code is the body */ - return(goto_eval); - } - /* multi-line body */ - if ((!is_unsafe_do(code)) && - (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); - }} + { + sc->code = cddr(code); + set_curlet(sc, make_let(sc, sc->curlet)); + sc->args = add_slot_checked(sc, sc->curlet, caaar(code), make_mutable_integer(sc, s7_integer_clamped_if_gmp(sc, init_val))); + set_loop_end(sc->args, s7_integer_clamped_if_gmp(sc, end_val)); + set_has_loop_end(sc->args); /* safe_dotimes step is by 1 */ + + /* (define (hi) (do ((i 1 (+ 1 i))) ((= i 1) i))) -- we need the let even if the loop is not evaluated */ + + /* safe_dotimes: (car(body) is known to be a pair here) + * if 1-expr body look for syntactic case, if let(*) goto do_let, else opt_dotimes + * if they are unhappy, got safe_dotimes_step_o + * else goto opt_dotimes then safe_dotimes_step_o + * if multi-line body, check opt_dotimes, then safe_dotimes_step + */ + if (s7_integer_clamped_if_gmp(sc, init_val) == s7_integer_clamped_if_gmp(sc, end_val)) + { + sc->value = sc->T; + sc->code = cdadr(code); + return(goto_safe_do_end_clauses); + } + if ((is_null(cdr(sc->code))) && + (is_pair(car(sc->code)))) + { + sc->code = car(sc->code); + set_opt2_pair(code, sc->code); /* is_pair above */ + if ((is_syntactic_pair(sc->code)) || + (is_symbol_and_syntactic(car(sc->code)))) + { + if (!is_unsafe_do(code)) + { + if (do_let_or_dotimes(sc, code, true)) + return(goto_safe_do_end_clauses); + set_unsafe_do(code); + } + push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code); + if (is_syntactic_pair(sc->code)) + sc->cur_op = (opcode_t)optimize_op(sc->code); + else + { + sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); + pair_set_syntax_op(sc->code, sc->cur_op); + } + return(goto_top_no_pop); + } + /* car not syntactic? */ + if ((!is_unsafe_do(code)) && + (opt_dotimes(sc, cddr(code), code, true))) + return(goto_safe_do_end_clauses); + set_unsafe_do(code); + + if (has_fx(cddr(code))) /* this almost never happens and the func case below is only in timing tests */ + { + s7_int end = s7_integer_clamped_if_gmp(sc, end_val); + s7_pointer body = cddr(code), stepper = slot_value(sc->args); + for (; integer(stepper) < end; integer(stepper)++) + fx_call(sc, body); + sc->value = sc->T; + sc->code = cdadr(code); + return(goto_safe_do_end_clauses); + } + push_stack(sc, OP_SAFE_DOTIMES_STEP_O, sc->args, code); /* arg is local step var slot, code is do form - do, sc->code is the body */ + return(goto_eval); + } + /* multi-line body */ + if ((!is_unsafe_do(code)) && + (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); + }} pair_set_syntax_op(form, OP_SIMPLE_DO); sc->code = form; if (op_simple_do(sc)) return(goto_do_end_clauses); @@ -84135,7 +84135,7 @@ static goto_t op_safe_do(s7_scheme *sc) s7_pointer old_let = sc->curlet; sc->temp7 = old_let; if (opt_dotimes(sc, cddr(sc->code), sc->code, false)) - return(goto_safe_do_end_clauses); + return(goto_safe_do_end_clauses); set_curlet(sc, old_let); /* apparently s7_optimize can step on sc->curlet? */ sc->temp7 = sc->unused; } @@ -84144,29 +84144,29 @@ static goto_t op_safe_do(s7_scheme *sc) { s7_pointer body = caddr(sc->code); if ((car(body) == sc->set_symbol) && - (is_pair(cdr(body))) && - (is_symbol(cadr(body))) && - (is_pair(cddr(body))) && - (has_fx(cddr(body))) && - (is_null(cdddr(body)))) /* so we're (set! symbol (fxable-expr...)) */ - { - s7_pointer step_slot = let_dox_slot1(sc->curlet); - if (slot_symbol(step_slot) != cadr(body)) /* we're not setting the stepper */ - { - s7_int endi = integer(let_dox2_value(sc->curlet)); - s7_pointer fx_p = cddr(body); - s7_pointer val_slot = s7_slot(sc, cadr(body)); - s7_int step = integer(slot_value(step_slot)); - s7_pointer step_val = slot_value(step_slot); - do { - slot_set_value(val_slot, fx_call(sc, fx_p)); - set_integer(step_val, ++step); - } while (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); - }}} + (is_pair(cdr(body))) && + (is_symbol(cadr(body))) && + (is_pair(cddr(body))) && + (has_fx(cddr(body))) && + (is_null(cdddr(body)))) /* so we're (set! symbol (fxable-expr...)) */ + { + s7_pointer step_slot = let_dox_slot1(sc->curlet); + if (slot_symbol(step_slot) != cadr(body)) /* we're not setting the stepper */ + { + s7_int endi = integer(let_dox2_value(sc->curlet)); + s7_pointer fx_p = cddr(body); + s7_pointer val_slot = s7_slot(sc, cadr(body)); + s7_int step = integer(slot_value(step_slot)); + s7_pointer step_val = slot_value(step_slot); + do { + slot_set_value(val_slot, fx_call(sc, fx_p)); + set_integer(step_val, ++step); + } while (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); @@ -84223,7 +84223,7 @@ static goto_t op_dotimes_p(s7_scheme *sc) set_has_loop_end(sc->args); /* dotimes step is by 1 */ sc->code = cdr(sc->code); if (do_let_or_dotimes(sc, code, false)) - return(goto_do_end_clauses); /* not safe_do here */ + return(goto_do_end_clauses); /* not safe_do here */ slot_set_value(sc->args, old_init); set_curlet(sc, old_e); /* free_cell(sc, sc->curlet) beforehand is not safe */ sc->args = old_args; @@ -84246,18 +84246,18 @@ static bool op_do_init_1(s7_scheme *sc) /* here sc->code is a list like: ((i 0 (+ i 1)) ...) so cadar gets the init value */ init = cdar(sc->code); if (has_fx(init)) - sc->value = fx_call(sc, init); + sc->value = fx_call(sc, init); else - { - init = car(init); - if (is_pair(init)) - { - push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code)); /* OP_DO_INIT only used here */ - sc->code = init; - return(true); /* goto eval */ - } - sc->value = (is_symbol(init)) ? lookup_checked(sc, init) : init; - } + { + init = car(init); + if (is_pair(init)) + { + push_stack(sc, OP_DO_INIT, sc->args, cdr(sc->code)); /* OP_DO_INIT only used here */ + sc->code = init; + return(true); /* goto eval */ + } + sc->value = (is_symbol(init)) ? lookup_checked(sc, init) : init; + } sc->code = cdr(sc->code); } /* all the initial values are now in the args list */ @@ -84280,10 +84280,10 @@ static bool op_do_init_1(s7_scheme *sc) let_set_slots(sc->curlet, y); symbol_set_local_slot(sym, let_id(sc->curlet), y); if (is_pair(cddar(x))) /* else no incr expr, so ignore it henceforth */ - { - slot_set_expression(y, cddar(x)); - sc->value = cons_unchecked(sc, y, sc->value); - } + { + slot_set_expression(y, cddar(x)); + sc->value = cons_unchecked(sc, y, sc->value); + } y = args; } sc->args = cons(sc, sc->value = proper_list_reverse_in_place(sc, sc->value), cadr(sc->code)); @@ -84295,8 +84295,8 @@ static bool op_do_init(s7_scheme *sc) { if (is_multiple_value(sc->value)) /* (do ((i (values 1 2)))...) */ error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_2(sc, wrap_string(sc, "do: variable initial value can't be ~S", 38), - set_ulist_1(sc, sc->values_symbol, sc->value))); + set_elist_2(sc, wrap_string(sc, "do: variable initial value can't be ~S", 38), + set_ulist_1(sc, sc->values_symbol, sc->value))); return(!op_do_init_1(sc)); } @@ -84328,11 +84328,11 @@ static bool op_do_end(s7_scheme *sc) if (is_pair(cdr(sc->args))) { if (!has_fx(cdr(sc->args))) - { - push_stack_direct(sc, OP_DO_END1); - sc->code = cadr(sc->args); /* evaluate the end expr */ - return(true); - } + { + push_stack_direct(sc, OP_DO_END1); + sc->code = cadr(sc->args); /* evaluate the end expr */ + return(true); + } sc->value = fx_call(sc, cdr(sc->args)); } else sc->value = sc->F; /* goto "if (is_pair(sc->code))..." below */ @@ -84360,7 +84360,7 @@ static goto_t op_do_end_true(s7_scheme *sc) if (is_null(sc->code)) { if (is_multiple_value(sc->value)) /* (define (f) (+ 1 (do ((i 2 (+ i 1))) ((values i (+ i 1)))))) -> 6 */ - sc->value = splice_in_values(sc, multiple_value(sc->value)); + sc->value = splice_in_values(sc, multiple_value(sc->value)); /* similarly, if the result is a multiple value: (define (f) (+ 1 (do ((i 2 (+ i 1))) ((= i 3) (values i (+ i 1)))))) -> 8 */ return(goto_start); } @@ -84368,10 +84368,10 @@ static goto_t op_do_end_true(s7_scheme *sc) if (is_null(cdr(sc->code))) { if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - return(goto_start); - } + { + sc->value = fx_call(sc, sc->code); + return(goto_start); + } sc->code = car(sc->code); return(goto_eval); } @@ -84389,10 +84389,10 @@ static inline s7_pointer apply_c_function(s7_scheme *sc, s7_pointer func, s7_poi s7_int len = proper_list_length(args); if (len < c_function_min_args(func)) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), func, func, args)); + set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), func, func, args)); if (c_function_max_args(func) < len) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, args)); + set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, args)); return(c_function_call(func)(sc, args)); /* just by chance, this code is identical to macroexpand_c_macro's code (after macro expansion)! So, * gcc -O2 uses the macroexpand code, but then valgrind shows us calling macros all the time, and @@ -84405,10 +84405,10 @@ static s7_pointer apply_c_function_unopt(s7_scheme *sc, s7_pointer func, s7_poin s7_int len = proper_list_length(args); if (len < c_function_min_args(func)) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), func, func, args)); + set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), func, func, args)); if (c_function_max_args(func) < len) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, args)); + set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), func, func, args)); return(c_function_call(func)(sc, args)); } @@ -84418,15 +84418,15 @@ static void apply_c_rst_no_req_function(s7_scheme *sc) /* -------- C-based sc->value = c_function_call(sc->code)(sc, sc->args); } -static void apply_c_macro(s7_scheme *sc) /* -------- C-based macro -------- */ +static void apply_c_macro(s7_scheme *sc) /* -------- C-based macro -------- */ { s7_int len = proper_list_length(sc->args); if (len < c_macro_min_args(sc->code)) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), sc->code, sc->code, sc->args)); + set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), sc->code, sc->code, sc->args)); if (c_macro_max_args(sc->code) < len) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), sc->code, sc->code, sc->args)); + set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), sc->code, sc->code, sc->args)); sc->code = c_macro_call(sc->code)(sc, sc->args); } @@ -84437,21 +84437,21 @@ static void apply_syntax(s7_scheme *sc) /* -------- syntactic { len = s7_list_length(sc, sc->args); if (len == 0) - syntax_error_nr(sc, "attempt to evaluate a circular list: ~S", 39, sc->args); + syntax_error_nr(sc, "attempt to evaluate a circular list: ~S", 39, sc->args); if ((sc->safety > NO_SAFETY) && - (tree_is_cyclic(sc, sc->args))) - error_nr(sc, sc->syntax_error_symbol, - set_elist_3(sc, wrap_string(sc, "apply ~S: body is circular: ~S", 30), sc->code, sc->args)); + (tree_is_cyclic(sc, sc->args))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "apply ~S: body is circular: ~S", 30), sc->code, sc->args)); } else len = 0; if (len < syntax_min_args(sc->code)) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), sc->code, sc->code, sc->args)); + set_elist_4(sc, wrap_string(sc, "~A: not enough arguments: (~A~{~^ ~S~})", 39), sc->code, sc->code, sc->args)); if ((syntax_max_args(sc->code) < len) && (syntax_max_args(sc->code) != -1)) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), sc->code, sc->code, sc->args)); + set_elist_4(sc, wrap_string(sc, "~A: too many arguments: (~A~{~^ ~S~})", 37), sc->code, sc->code, sc->args)); sc->cur_op = syntax_opcode(sc->code); /* (apply begin '((define x 3) (+ x 2))) */ /* I had elaborate checks here for embedded circular lists, but now I think that is the caller's problem */ sc->code = cons(sc, sc->code, sc->args); @@ -84470,8 +84470,8 @@ static void apply_vector(s7_scheme *sc) /* -------- vector as { s7_int index = s7_integer_clamped_if_gmp(sc, car(sc->args)); if ((index >= 0) && - (index < vector_length(sc->code))) - sc->value = vector_getter(sc->code)(sc, sc->code, index); + (index < vector_length(sc->code))) + sc->value = vector_getter(sc->code)(sc, sc->code, index); else out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, car(sc->args), (index < 0) ? it_is_negative_string : it_is_too_large_string); } else sc->value = vector_ref_1(sc, sc->code, sc->args); @@ -84481,20 +84481,20 @@ static void apply_string(s7_scheme *sc) /* -------- string as { if (!is_pair(sc->args)) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "impicit string-ref needs an index argument: (~S~{~^ ~S~})", 57), sc->code, sc->args)); + set_elist_3(sc, wrap_string(sc, "impicit string-ref needs an index argument: (~S~{~^ ~S~})", 57), sc->code, sc->args)); if (!is_null(cdr(sc->args))) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "string ref: too many indices: (~S~{~^ ~S~})", 43), sc->code, sc->args)); + set_elist_3(sc, wrap_string(sc, "string ref: too many indices: (~S~{~^ ~S~})", 43), sc->code, sc->args)); if (s7_is_integer(car(sc->args))) { s7_int index = s7_integer_clamped_if_gmp(sc, car(sc->args)); if ((index >= 0) && - (index < string_length(sc->code))) - { - sc->value = chars[((uint8_t *)string_value(sc->code))[index]]; - return; - }} + (index < string_length(sc->code))) + { + sc->value = chars[((uint8_t *)string_value(sc->code))[index]]; + return; + }} sc->value = string_ref_1(sc, sc->code, car(sc->args)); } @@ -84540,7 +84540,7 @@ static void apply_iterator(s7_scheme *sc) /* -------- iterator { if (!is_null(sc->args)) error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "iterator takes no arguments: (~A~{~^ ~S~})", 42), sc->code, sc->args)); + set_elist_3(sc, wrap_string(sc, "iterator takes no arguments: (~A~{~^ ~S~})", 42), sc->code, sc->args)); sc->value = s7_iterate(sc, sc->code); } @@ -84553,15 +84553,15 @@ static Inline void inline_apply_lambda(s7_scheme *sc) /* -------- normal fu { s7_pointer sym = car(x); if (is_null(z)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_5(sc, wrap_string(sc, "~S: not enough arguments: ((~S ~S ...)~{~^ ~S~})", 48), - closure_name(sc, sc->code), - (is_closure(sc->code)) ? sc->lambda_symbol : ((is_bacro(sc->code)) ? sc->bacro_symbol : sc->macro_symbol), - closure_args(sc->code), sc->args)); + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_5(sc, wrap_string(sc, "~S: not enough arguments: ((~S ~S ...)~{~^ ~S~})", 48), + closure_name(sc, sc->code), + (is_closure(sc->code)) ? sc->lambda_symbol : ((is_bacro(sc->code)) ? sc->bacro_symbol : sc->macro_symbol), + closure_args(sc->code), sc->args)); slot = make_slot(sc, sym, T_Ext(unchecked_car(z))); symbol_set_local_slot(sym, id, slot); if (tis_slot(last_slot)) - slot_set_next(last_slot, slot); + slot_set_next(last_slot, slot); else let_set_slots(e, slot); last_slot = slot; slot_set_next(slot, slot_end); @@ -84569,18 +84569,18 @@ static Inline void inline_apply_lambda(s7_scheme *sc) /* -------- normal fu if (is_null(x)) { if (is_not_null(z)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_5(sc, wrap_string(sc, "~S: too many arguments: ((~S ~S ...)~{~^ ~S~})", 46), - closure_name(sc, sc->code), - (is_closure(sc->code)) ? sc->lambda_symbol : ((is_bacro(sc->code)) ? sc->bacro_symbol : sc->macro_symbol), - closure_args(sc->code), sc->args)); + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_5(sc, wrap_string(sc, "~S: too many arguments: ((~S ~S ...)~{~^ ~S~})", 46), + closure_name(sc, sc->code), + (is_closure(sc->code)) ? sc->lambda_symbol : ((is_bacro(sc->code)) ? sc->bacro_symbol : sc->macro_symbol), + closure_args(sc->code), sc->args)); } else { slot = make_slot(sc, x, z); symbol_set_local_slot(x, id, slot); if (tis_slot(last_slot)) - slot_set_next(last_slot, slot); + slot_set_next(last_slot, slot); else let_set_slots(e, slot); slot_set_next(slot, slot_end); } @@ -84616,24 +84616,24 @@ static void op_f_np(s7_scheme *sc) /* sc->code: ((lambda (x y) (+ x y)) (value { s7_pointer last_slot; if (is_null(cdr(sc->code))) /* ((lambda (x) 21)) */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), - cadar(sc->code), cdr(sc->code))); + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), + cadar(sc->code), cdr(sc->code))); if (is_constant(sc, car(pars))) - error_nr(sc, sc->syntax_error_symbol, /* (lambda (a) 1) where 'a is immutable (locally perhaps) */ - set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a constant: ((lambda ~S ...)~{~^ ~S~})", 61), - car(pars), cadar(sc->code), cdr(sc->code))); + error_nr(sc, sc->syntax_error_symbol, /* (lambda (a) 1) where 'a is immutable (locally perhaps) */ + set_elist_4(sc, wrap_string(sc, "lambda parameter ~S is a constant: ((lambda ~S ...)~{~^ ~S~})", 61), + car(pars), cadar(sc->code), cdr(sc->code))); add_slot_unchecked_no_local(sc, e, car(pars), sc->undefined); last_slot = let_slots(e); for (pars = cdr(pars); is_pair(pars); pars = cdr(pars)) - last_slot = add_slot_at_end_no_local(sc, last_slot, car(pars), sc->undefined); + last_slot = add_slot_at_end_no_local(sc, last_slot, car(pars), sc->undefined); /* last par might be rest par (dotted) */ if (!is_null(pars)) - { - last_slot = add_slot_at_end_no_local(sc, last_slot, pars, sc->undefined); - set_is_rest_slot(last_slot); - }} + { + last_slot = add_slot_at_end_no_local(sc, last_slot, pars, sc->undefined); + set_is_rest_slot(last_slot); + }} /* check_stack_size(sc); */ if ((sc->stack_end + 4) >= sc->stack_resize_trigger) resize_stack(sc); push_stack(sc, OP_GC_PROTECT, let_slots(e), cddr(sc->code)); /* not for gc-protection, but as implicit loop vars */ @@ -84648,19 +84648,19 @@ static bool op_f_np_1(s7_scheme *sc) { s7_pointer p, oslot = slot; for (p = sc->value; (is_pair(p)) && (tis_slot(slot)); p = cdr(p), oslot = slot, slot = next_slot(slot)) - if (is_rest_slot(slot)) - { - if (slot_value(slot) == sc->undefined) - slot_set_value(slot, copy_proper_list(sc, p)); - else slot_set_value(slot, pair_append(sc, slot_value(slot), copy_proper_list(sc, p))); - p = sc->nil; - break; - } - else slot_set_value(slot, car(p)); + if (is_rest_slot(slot)) + { + if (slot_value(slot) == sc->undefined) + slot_set_value(slot, copy_proper_list(sc, p)); + else slot_set_value(slot, pair_append(sc, slot_value(slot), copy_proper_list(sc, p))); + p = sc->nil; + break; + } + else slot_set_value(slot, car(p)); if (is_pair(p)) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), - cadar(sc->code), cdr(sc->code))); + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), + cadar(sc->code), cdr(sc->code))); slot = oslot; /* snd-test 22 grani */ } else /* not mv */ @@ -84668,15 +84668,15 @@ static bool op_f_np_1(s7_scheme *sc) slot_set_value(slot, sc->value); else if (slot_value(slot) == sc->undefined) - slot_set_value(slot, list_1(sc, sc->value)); + slot_set_value(slot, list_1(sc, sc->value)); else slot_set_value(slot, pair_append(sc, slot_value(slot), list_1(sc, sc->value))); if (is_pair(arg)) { if ((!tis_slot(next_slot(slot))) && (!is_rest_slot(slot))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "too many arguments: ((lambda ~S ...)~{~^ ~S~})", 46), - cadar(sc->code), cdr(sc->code))); + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "too many arguments: ((lambda ~S ...)~{~^ ~S~})", 46), + cadar(sc->code), cdr(sc->code))); set_stack_protected1(sc, (is_rest_slot(slot)) ? slot : next_slot(slot)); set_stack_protected2(sc, cdr(arg)); push_stack_direct(sc, OP_F_NP_1); /* sc->args=e, sc->code from start */ @@ -84686,11 +84686,11 @@ static bool op_f_np_1(s7_scheme *sc) if (tis_slot(next_slot(slot))) { if (!is_rest_slot(next_slot(slot))) - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), - cadar(sc->code), cdr(sc->code))); + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_3(sc, wrap_string(sc, "not enough arguments: ((lambda ~S ...)~{~^ ~S~})", 48), + cadar(sc->code), cdr(sc->code))); if (slot_value(next_slot(slot)) == sc->undefined) - slot_set_value(next_slot(slot), sc->nil); + slot_set_value(next_slot(slot), sc->nil); } e = sc->args; let_set_id(e, ++sc->let_number); @@ -84706,11 +84706,11 @@ static void op_lambda_star(s7_scheme *sc) check_lambda_star(sc); if (!is_pair(car(sc->code))) sc->value = make_closure(sc, car(sc->code), cdr(sc->code), - (is_symbol(car(sc->code))) ? (T_CLOSURE | T_COPY_ARGS) : T_CLOSURE, - CLOSURE_ARITY_NOT_SET); + (is_symbol(car(sc->code))) ? (T_CLOSURE | T_COPY_ARGS) : T_CLOSURE, + CLOSURE_ARITY_NOT_SET); else sc->value = make_closure(sc, car(sc->code), cdr(sc->code), - (!arglist_has_rest(sc, car(sc->code))) ? T_CLOSURE_STAR : (T_CLOSURE_STAR | T_COPY_ARGS), - CLOSURE_ARITY_NOT_SET); + (!arglist_has_rest(sc, car(sc->code))) ? T_CLOSURE_STAR : (T_CLOSURE_STAR | T_COPY_ARGS), + CLOSURE_ARITY_NOT_SET); } static void op_lambda_star_unchecked(s7_scheme *sc) @@ -84718,21 +84718,21 @@ static void op_lambda_star_unchecked(s7_scheme *sc) s7_pointer code = cdr(sc->code); if (!is_pair(car(code))) sc->value = make_closure(sc, car(code), cdr(code), - (is_symbol(car(code))) ? (T_CLOSURE | T_COPY_ARGS) : T_CLOSURE, - CLOSURE_ARITY_NOT_SET); + (is_symbol(car(code))) ? (T_CLOSURE | T_COPY_ARGS) : T_CLOSURE, + CLOSURE_ARITY_NOT_SET); else sc->value = make_closure(sc, car(code), cdr(code), - (!arglist_has_rest(sc, car(code))) ? T_CLOSURE_STAR : (T_CLOSURE_STAR | T_COPY_ARGS), - CLOSURE_ARITY_NOT_SET); + (!arglist_has_rest(sc, car(code))) ? T_CLOSURE_STAR : (T_CLOSURE_STAR | T_COPY_ARGS), + CLOSURE_ARITY_NOT_SET); } static s7_pointer star_set(s7_scheme *sc, s7_pointer slot, s7_pointer val, bool check_rest) { if (is_checked_slot(slot)) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); + set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); if ((check_rest) && (is_rest_slot(slot))) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), slot_symbol(slot), val)); + set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), slot_symbol(slot), val)); set_checked_slot(slot); slot_set_value(slot, val); return(val); @@ -84757,77 +84757,77 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc) bool allow_other_keys = ((is_pair(pars)) && (allows_other_keys(pars))); while ((is_pair(pars)) && - (is_pair(arg_vals))) + (is_pair(arg_vals))) { if (car(pars) == sc->rest_keyword) /* the rest arg: a default is not allowed here (see check_lambda_star_args) */ - { - /* next arg is bound to trailing args from this point as a list */ - pars = cdr(pars); - if ((is_symbol_and_keyword(car(arg_vals))) && - (is_pair(cdr(arg_vals))) && - (keyword_symbol(car(arg_vals)) == car(pars))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), - car(pars), cadr(arg_vals))); - lambda_star_argument_set_value(sc, car(pars), (in_heap(arg_vals)) ? arg_vals : copy_proper_list(sc, arg_vals), slot, false); /* sym5 :rest bug */ - rest_key = sc->rest_keyword; - arg_vals = cdr(arg_vals); - pars = cdr(pars); - slot = next_slot(slot); - } + { + /* next arg is bound to trailing args from this point as a list */ + pars = cdr(pars); + if ((is_symbol_and_keyword(car(arg_vals))) && + (is_pair(cdr(arg_vals))) && + (keyword_symbol(car(arg_vals)) == car(pars))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), + car(pars), cadr(arg_vals))); + lambda_star_argument_set_value(sc, car(pars), (in_heap(arg_vals)) ? arg_vals : copy_proper_list(sc, arg_vals), slot, false); /* sym5 :rest bug */ + rest_key = sc->rest_keyword; + arg_vals = cdr(arg_vals); + pars = cdr(pars); + slot = next_slot(slot); + } else - { - s7_pointer arg_val = car(arg_vals); - if (is_symbol_and_keyword(arg_val)) - { - if (!is_pair(cdr(arg_vals))) - { - if (!sc->accept_all_keyword_arguments) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, keyword_value_missing_string, closure_name(sc, code), arg_vals, args)); - slot_set_value(slot, arg_val); - set_checked_slot(slot); - arg_vals = cdr(arg_vals); - } - else - { - s7_pointer sym = keyword_symbol(arg_val); - if (lambda_star_argument_set_value(sc, sym, cadr(arg_vals), slot, true) == sc->no_value) - { - /* if default value is a key, go ahead and use this value. (define* (f (a :b)) a) (f :c), this has become much trickier than I anticipated... */ - if (allow_other_keys) - /* in CL: (defun hi (&key (a 1) &allow-other-keys) a) (hi :b :a :a 3) -> 3 - * in s7: (define* (hi (a 1) :allow-other-keys) a) (hi :b :a :a 3) -> 3 - */ - arg_vals = cddr(arg_vals); - else - { - if (!sc->accept_all_keyword_arguments) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: unknown key: ~S in ~S", 25), closure_name(sc, code), arg_vals, args)); - slot_set_value(slot, arg_val); - set_checked_slot(slot); - arg_vals = cdr(arg_vals); - pars = cdr(pars); - slot = next_slot(slot); - } - continue; - } - arg_vals = cddr(arg_vals); - } - slot = next_slot(slot); - } - else /* not a key/value pair */ - { - if (is_checked_slot(slot)) - error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); - set_checked_slot(slot); - slot_set_value(slot, car(arg_vals)); - slot = next_slot(slot); - arg_vals = cdr(arg_vals); - } - pars = cdr(pars); - }} + { + s7_pointer arg_val = car(arg_vals); + if (is_symbol_and_keyword(arg_val)) + { + if (!is_pair(cdr(arg_vals))) + { + if (!sc->accept_all_keyword_arguments) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, keyword_value_missing_string, closure_name(sc, code), arg_vals, args)); + slot_set_value(slot, arg_val); + set_checked_slot(slot); + arg_vals = cdr(arg_vals); + } + else + { + s7_pointer sym = keyword_symbol(arg_val); + if (lambda_star_argument_set_value(sc, sym, cadr(arg_vals), slot, true) == sc->no_value) + { + /* if default value is a key, go ahead and use this value. (define* (f (a :b)) a) (f :c), this has become much trickier than I anticipated... */ + if (allow_other_keys) + /* in CL: (defun hi (&key (a 1) &allow-other-keys) a) (hi :b :a :a 3) -> 3 + * in s7: (define* (hi (a 1) :allow-other-keys) a) (hi :b :a :a 3) -> 3 + */ + arg_vals = cddr(arg_vals); + else + { + if (!sc->accept_all_keyword_arguments) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A: unknown key: ~S in ~S", 25), closure_name(sc, code), arg_vals, args)); + slot_set_value(slot, arg_val); + set_checked_slot(slot); + arg_vals = cdr(arg_vals); + pars = cdr(pars); + slot = next_slot(slot); + } + continue; + } + arg_vals = cddr(arg_vals); + } + slot = next_slot(slot); + } + else /* not a key/value pair */ + { + if (is_checked_slot(slot)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); + set_checked_slot(slot); + slot_set_value(slot, car(arg_vals)); + slot = next_slot(slot); + arg_vals = cdr(arg_vals); + } + pars = cdr(pars); + }} /* (let () (define* (hi (a 1) :allow-other-keys) a) (hi :a 2 32)) -> 'error */ /* (let () (define* (f (a :b)) a) (list (f) (f 1) (f :c) (f :a :c) (f :a 1) (f))) -> 'error */ @@ -84835,38 +84835,38 @@ static s7_pointer lambda_star_set_args(s7_scheme *sc) if (is_not_null(arg_vals)) { if ((is_not_null(pars)) || - (rest_key == sc->rest_keyword)) - { - if (is_symbol(pars)) - { - if ((is_symbol_and_keyword(car(arg_vals))) && - (is_pair(cdr(arg_vals))) && - (keyword_symbol(car(arg_vals)) == pars)) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), pars, cadr(arg_vals))); - slot_set_value(slot, (in_heap(arg_vals)) ? arg_vals : copy_proper_list(sc, arg_vals)); /* sym5 :rest bug */ - }} + (rest_key == sc->rest_keyword)) + { + if (is_symbol(pars)) + { + if ((is_symbol_and_keyword(car(arg_vals))) && + (is_pair(cdr(arg_vals))) && + (keyword_symbol(car(arg_vals)) == pars)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "can't set rest argument ~S to ~S via keyword", 44), pars, cadr(arg_vals))); + slot_set_value(slot, (in_heap(arg_vals)) ? arg_vals : copy_proper_list(sc, arg_vals)); /* sym5 :rest bug */ + }} else - { - if (!allow_other_keys) /* ((lambda* (a) a) :a 1 2) */ - error_nr(sc, sc->wrong_number_of_args_symbol, - set_elist_4(sc, wrap_string(sc, "too many arguments: (~S ~S ...)~{~^ ~S~})", 41), - (is_closure_star(code)) ? sc->lambda_star_symbol : ((is_bacro_star(sc->code)) ? sc->bacro_star_symbol : sc->macro_star_symbol), - closure_args(code), args)); - /* check trailing args for repeated keys or keys with no values or values with no keys */ - while (is_pair(arg_vals)) - { - if ((!is_symbol_and_keyword(car(arg_vals))) || /* ((lambda* (a :allow-other-keys) a) :a 1 :b 2 3) */ - (!is_pair(cdr(arg_vals)))) /* ((lambda* (a :allow-other-keys) a) :a 1 :b) */ - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, wrap_string(sc, "~A: not a key/value pair: ~S", 28), closure_name(sc, code), arg_vals)); - slot = symbol_to_local_slot(sc, keyword_symbol(car(arg_vals)), sc->curlet); - if ((is_slot(slot)) && - (is_checked_slot(slot))) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); - arg_vals = cddr(arg_vals); - }}} + { + if (!allow_other_keys) /* ((lambda* (a) a) :a 1 2) */ + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "too many arguments: (~S ~S ...)~{~^ ~S~})", 41), + (is_closure_star(code)) ? sc->lambda_star_symbol : ((is_bacro_star(sc->code)) ? sc->bacro_star_symbol : sc->macro_star_symbol), + closure_args(code), args)); + /* check trailing args for repeated keys or keys with no values or values with no keys */ + while (is_pair(arg_vals)) + { + if ((!is_symbol_and_keyword(car(arg_vals))) || /* ((lambda* (a :allow-other-keys) a) :a 1 :b 2 3) */ + (!is_pair(cdr(arg_vals)))) /* ((lambda* (a :allow-other-keys) a) :a 1 :b) */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "~A: not a key/value pair: ~S", 28), closure_name(sc, code), arg_vals)); + slot = symbol_to_local_slot(sc, keyword_symbol(car(arg_vals)), sc->curlet); + if ((is_slot(slot)) && + (is_checked_slot(slot))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, parameter_set_twice_string, slot_symbol(slot), sc->args)); + arg_vals = cddr(arg_vals); + }}} return(sc->nil); } @@ -84875,46 +84875,46 @@ static inline bool lambda_star_default(s7_scheme *sc) for (s7_pointer z = sc->args; tis_slot(z); z = next_slot(z)) { if ((slot_value(z) == sc->undefined) && /* trouble: (lambda* ((e #<undefined>))...) */ - (slot_has_expression(z)) && /* if default val is not a pair or a symbol, this is false */ - (!is_checked_slot(z))) - { - s7_pointer val = slot_expression(z); - if (is_symbol(val)) - { - slot_set_value(z, lookup_checked(sc, val)); - if (slot_value(z) == sc->undefined) - { - /* the current environment here contains the function parameters which defaulted to #<undefined> - * (or maybe #<unused>?) earlier in apply_*_closure_star_1, so (define (f f) (define* (f (f f)) f) (f)) (f 0) - * looks for the default f, finds itself currently undefined, and raises an error! So, before - * claiming it is unbound, we need to check outlet as well. But in the case above, the inner - * define* shadows the caller's parameter before checking the default arg values, so the default f - * refers to the define* -- I'm not sure this is a bug. It means that (define* (f (a f)) a) - * returns f: (equal? f (f)) -> #t, so any outer f needs an extra let and endless outlets: - * (let ((f 3)) (let () (define* (f (a ((outlet (outlet (outlet (curlet)))) 'f))) a) (f))) -> 3 - * We want the shadowing once the define* is done, so the current mess is simplest. - */ - slot_set_value(z, s7_symbol_local_value(sc, val, let_outlet(sc->curlet))); - if (slot_value(z) == sc->undefined) - syntax_error_nr(sc, "lambda* defaults: ~A is unbound", 31, slot_symbol(z)); - }} - else - if (!is_pair(val)) - slot_set_value(z, val); - else - if (is_quote(car(val))) - { - if ((!is_pair(cdr(val))) || /* (lambda* ((a (quote))) a) or (lambda* ((a (quote 1 1))) a) etc */ - (is_pair(cddr(val)))) - syntax_error_nr(sc, "lambda* default: ~A is messed up", 32, val); - slot_set_value(z, cadr(val)); - } - else - { - push_stack(sc, OP_LAMBDA_STAR_DEFAULT, z, sc->code); - sc->code = val; - return(true); /* goto eval */ - }}} + (slot_has_expression(z)) && /* if default val is not a pair or a symbol, this is false */ + (!is_checked_slot(z))) + { + s7_pointer val = slot_expression(z); + if (is_symbol(val)) + { + slot_set_value(z, lookup_checked(sc, val)); + if (slot_value(z) == sc->undefined) + { + /* the current environment here contains the function parameters which defaulted to #<undefined> + * (or maybe #<unused>?) earlier in apply_*_closure_star_1, so (define (f f) (define* (f (f f)) f) (f)) (f 0) + * looks for the default f, finds itself currently undefined, and raises an error! So, before + * claiming it is unbound, we need to check outlet as well. But in the case above, the inner + * define* shadows the caller's parameter before checking the default arg values, so the default f + * refers to the define* -- I'm not sure this is a bug. It means that (define* (f (a f)) a) + * returns f: (equal? f (f)) -> #t, so any outer f needs an extra let and endless outlets: + * (let ((f 3)) (let () (define* (f (a ((outlet (outlet (outlet (curlet)))) 'f))) a) (f))) -> 3 + * We want the shadowing once the define* is done, so the current mess is simplest. + */ + slot_set_value(z, s7_symbol_local_value(sc, val, let_outlet(sc->curlet))); + if (slot_value(z) == sc->undefined) + syntax_error_nr(sc, "lambda* defaults: ~A is unbound", 31, slot_symbol(z)); + }} + else + if (!is_pair(val)) + slot_set_value(z, val); + else + if (is_quote(car(val))) + { + if ((!is_pair(cdr(val))) || /* (lambda* ((a (quote))) a) or (lambda* ((a (quote 1 1))) a) etc */ + (is_pair(cddr(val)))) + syntax_error_nr(sc, "lambda* default: ~A is messed up", 32, val); + slot_set_value(z, cadr(val)); + } + else + { + push_stack(sc, OP_LAMBDA_STAR_DEFAULT, z, sc->code); + sc->code = val; + return(true); /* goto eval */ + }}} return(false); /* goto BEGIN */ } @@ -84953,12 +84953,12 @@ static inline bool apply_safe_closure_star_1(s7_scheme *sc) /* -------- define* if (has_no_defaults(sc->code)) { for (s7_pointer z = let_slots(sc->curlet); tis_slot(z); z = next_slot(z)) - { - clear_checked_slot(z); - slot_set_value(z, sc->F); - } + { + clear_checked_slot(z); + slot_set_value(z, sc->F); + } if (!is_null(sc->args)) - lambda_star_set_args(sc); /* load up current arg vals */ + lambda_star_set_args(sc); /* load up current arg vals */ sc->code = closure_body(sc->code); return(false); /* goto BEGIN */ } @@ -84977,29 +84977,29 @@ static bool apply_unsafe_closure_star_1(s7_scheme *sc) { s7_pointer car_z = car(z); if (is_pair(car_z)) /* arg has a default value */ - { - s7_pointer slot, val = cadr(car_z); - if ((!is_pair(val)) && - (!is_symbol(val))) - slot = add_slot_checked(sc, sc->curlet, car(car_z), val); - else - { - add_slot(sc, sc->curlet, car(car_z), sc->undefined); - slot = let_slots(sc->curlet); - slot_set_expression(slot, val); - } - if (is_null(top)) - top = slot; - } + { + s7_pointer slot, val = cadr(car_z); + if ((!is_pair(val)) && + (!is_symbol(val))) + slot = add_slot_checked(sc, sc->curlet, car(car_z), val); + else + { + add_slot(sc, sc->curlet, car(car_z), sc->undefined); + slot = let_slots(sc->curlet); + slot_set_expression(slot, val); + } + if (is_null(top)) + top = slot; + } else - if (!is_keyword(car_z)) - add_slot(sc, sc->curlet, car_z, sc->F); - else - if (car_z == sc->rest_keyword) /* else it's :allow-other-keys? */ - { - set_is_rest_slot(add_slot_checked(sc, sc->curlet, cadr(z), sc->nil)); - z = cdr(z); - }} + if (!is_keyword(car_z)) + add_slot(sc, sc->curlet, car_z, sc->F); + else + if (car_z == sc->rest_keyword) /* else it's :allow-other-keys? */ + { + set_is_rest_slot(add_slot_checked(sc, sc->curlet, cadr(z), sc->nil)); + z = cdr(z); + }} if (is_symbol(z)) set_is_rest_slot(add_slot_checked(sc, sc->curlet, z, sc->nil)); /* set up rest arg */ let_set_slots(sc->curlet, reverse_slots(let_slots(sc->curlet))); @@ -85014,16 +85014,16 @@ static void apply_macro_star_1(s7_scheme *sc) { s7_pointer par = car(p); if (is_pair(par)) - add_slot_checked(sc, sc->curlet, car(par), cadr(par)); + add_slot_checked(sc, sc->curlet, car(par), cadr(par)); else - if (!is_keyword(par)) - add_slot_checked(sc, sc->curlet, par, sc->F); - else - if (par == sc->rest_keyword) - { - set_is_rest_slot(add_slot_checked(sc, sc->curlet, cadr(p), sc->nil)); - p = cdr(p); - }} + if (!is_keyword(par)) + add_slot_checked(sc, sc->curlet, par, sc->F); + else + if (par == sc->rest_keyword) + { + set_is_rest_slot(add_slot_checked(sc, sc->curlet, cadr(p), sc->nil)); + p = cdr(p); + }} if (is_symbol(p)) set_is_rest_slot(add_slot_checked(sc, sc->curlet, p, sc->nil)); let_set_slots(sc->curlet, reverse_slots(let_slots(sc->curlet))); @@ -85128,13 +85128,13 @@ static void op_safe_closure_star_a(s7_scheme *sc, s7_pointer code) if (is_pair(p)) for (s7_pointer x = next_slot(let_slots(closure_let(func))); is_pair(p); p = cdr(p), x = next_slot(x)) { - if (is_pair(car(p))) - { - s7_pointer defval = cadar(p); - slot_set_value(x, (is_pair(defval)) ? cadr(defval) : defval); - } - else slot_set_value(x, sc->F); - symbol_set_local_slot(slot_symbol(x), let_id(sc->curlet), x); + if (is_pair(car(p))) + { + s7_pointer defval = cadar(p); + slot_set_value(x, (is_pair(defval)) ? cadr(defval) : defval); + } + else slot_set_value(x, sc->F); + symbol_set_local_slot(slot_symbol(x), let_id(sc->curlet), x); } } @@ -85156,26 +85156,26 @@ static void op_safe_closure_star_aa(s7_scheme *sc, s7_pointer code) if (is_symbol_and_keyword(arg1)) { if (keyword_symbol(arg1) == slot_symbol(let_slots(closure_let(func)))) - { - arg1 = arg2; - arg2 = cadr(closure_args(func)); - if (is_pair(arg2)) arg2 = (is_pair(cadr(arg2))) ? cadadr(arg2) : cadr(arg2); else arg2 = sc->F; - } + { + arg1 = arg2; + 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(closure_let(func))))) - { - arg1 = car(closure_args(func)); - if (is_pair(arg1)) arg1 = (is_pair(cadr(arg1))) ? cadadr(arg1) : cadr(arg1); else arg1 = sc->F; - } - else - if (!sc->accept_all_keyword_arguments) - error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, wrap_string(sc, "~A: unknown keyword argument: ~S in ~S", 38), - closure_name(sc, func), arg1, code)); /* arg1 is already the value */ + if (keyword_symbol(arg1) == slot_symbol(next_slot(let_slots(closure_let(func))))) + { + arg1 = car(closure_args(func)); + if (is_pair(arg1)) arg1 = (is_pair(cadr(arg1))) ? cadadr(arg1) : cadr(arg1); else arg1 = sc->F; + } + else + if (!sc->accept_all_keyword_arguments) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "~A: unknown keyword argument: ~S in ~S", 38), + closure_name(sc, func), arg1, code)); /* arg1 is already the value */ } else if ((is_symbol_and_keyword(arg2)) && - (!sc->accept_all_keyword_arguments)) + (!sc->accept_all_keyword_arguments)) error_nr(sc, sc->wrong_type_arg_symbol, set_elist_4(sc, keyword_value_missing_string, closure_name(sc, func), arg2, code)); set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), arg1, arg2)); sc->code = T_Pair(closure_body(func)); @@ -85264,7 +85264,7 @@ static void op_closure_star_a(s7_scheme *sc, s7_pointer code) if ((is_symbol_and_keyword(sc->value)) && (!sc->accept_all_keyword_arguments)) error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_4(sc, keyword_value_missing_string, closure_name(sc, opt1_lambda(code)), sc->value, code)); + set_elist_4(sc, keyword_value_missing_string, closure_name(sc, opt1_lambda(code)), sc->value, code)); p = car(closure_args(func)); set_curlet(sc, make_let_with_slot(sc, closure_let(func), (is_pair(p)) ? car(p) : p, sc->value)); if (closure_star_arity_to_int(sc, func) > 1) @@ -85272,12 +85272,12 @@ static void op_closure_star_a(s7_scheme *sc, s7_pointer code) s7_pointer last_slot = let_slots(sc->curlet); s7_int id = let_id(sc->curlet); for (p = cdr(closure_args(func)); is_pair(p); p = cdr(p)) - { - s7_pointer par = car(p); - if (is_pair(par)) - last_slot = add_slot_at_end(sc, id, last_slot, car(par), (is_pair(cadr(par))) ? cadadr(par) : cadr(par)); /* possible quoted list as default value */ - else last_slot = add_slot_at_end(sc, id, last_slot, par, sc->F); - }} + { + s7_pointer par = car(p); + if (is_pair(par)) + last_slot = add_slot_at_end(sc, id, last_slot, car(par), (is_pair(cadr(par))) ? cadadr(par) : cadr(par)); /* possible quoted list as default value */ + else last_slot = add_slot_at_end(sc, id, last_slot, par, sc->F); + }} sc->code = T_Pair(closure_body(func)); } @@ -85289,7 +85289,7 @@ static inline bool op_closure_star_na(s7_scheme *sc, s7_pointer code) sc->w = cdr(code); /* args aren't evaluated yet */ sc->args = make_list(sc, opt3_arglen(cdr(code)), sc->unused); for (s7_pointer p = sc->args, old_args = sc->w; is_pair(p); p = cdr(p), old_args = cdr(old_args)) - set_car(p, fx_call(sc, old_args)); + set_car(p, fx_call(sc, old_args)); sc->w = sc->unused; } else sc->args = sc->nil; @@ -85323,28 +85323,28 @@ static bool op_define1(s7_scheme *sc) s7_pointer x; if (is_multiple_value(sc->value)) /* (define x (values 1 2)) */ error_nr(sc, sc->syntax_error_symbol, - set_elist_5(sc, wrap_string(sc, "~A: more than one value: (~A ~A ~S)", 35), - define1_caller(sc), define1_caller(sc), sc->code, sc->value)); + set_elist_5(sc, wrap_string(sc, "~A: more than one value: (~A ~A ~S)", 35), + define1_caller(sc), define1_caller(sc), sc->code, sc->value)); if (is_constant_symbol(sc, sc->code)) /* (define pi 3) or (define (pi a) a) */ { x = (is_slot(global_slot(sc->code))) ? global_slot(sc->code) : s7_slot(sc, sc->code); /* local_slot can be free even if sc->code is immutable (local constant now defunct) */ if (!((is_slot(x)) && - (type(sc->value) == unchecked_type(slot_value(x))) && - (s7_is_equivalent(sc, sc->value, slot_value(x))))) /* if value is unchanged, just ignore this (re)definition */ - syntax_error_with_caller_nr(sc, "~A: ~S is immutable", 19, define1_caller(sc), sc->code); /* can't use s7_is_equal because value might be NaN, etc */ + (type(sc->value) == unchecked_type(slot_value(x))) && + (s7_is_equivalent(sc, sc->value, slot_value(x))))) /* if value is unchanged, just ignore this (re)definition */ + syntax_error_with_caller_nr(sc, "~A: ~S is immutable", 19, define1_caller(sc), sc->code); /* can't use s7_is_equal because value might be NaN, etc */ if ((sc->safety > NO_SAFETY) && /* (define-constant x 3) (define x 3)... */ - (sc->cur_op == OP_DEFINE)) - s7_warn(sc, 256, "(define %s %s), but %s is a constant\n", display(sc->code), display(sc->value), display(sc->code)); + (sc->cur_op == OP_DEFINE)) + s7_warn(sc, 256, "(define %s %s), but %s is a constant\n", display(sc->code), display(sc->value), display(sc->code)); } else x = s7_slot(sc, sc->code); if ((is_slot(x)) && (slot_has_setter(x))) { sc->value = bind_symbol_with_setter(sc, OP_DEFINE_WITH_SETTER, sc->code, sc->value); if (sc->value == sc->no_value) - return(true); /* goto apply, if all goes well, OP_DEFINE_WITH_SETTER will jump to DEFINE2 */ + return(true); /* goto apply, if all goes well, OP_DEFINE_WITH_SETTER will jump to DEFINE2 */ } return(false); /* fall through */ } @@ -85354,26 +85354,26 @@ static void set_let_file_and_line(s7_scheme *sc, s7_pointer new_let, s7_pointer if (port_file(current_input_port(sc)) != stdin) { if ((is_pair(closure_args(new_func))) && - (has_location(closure_args(new_func)))) - { - let_set_file(new_let, pair_file_number(closure_args(new_func))); - let_set_line(new_let, pair_line_number(closure_args(new_func))); - } + (has_location(closure_args(new_func)))) + { + let_set_file(new_let, pair_file_number(closure_args(new_func))); + let_set_line(new_let, pair_line_number(closure_args(new_func))); + } else - if (has_location(closure_body(new_func))) - { - let_set_file(new_let, pair_file_number(closure_body(new_func))); - let_set_line(new_let, pair_line_number(closure_body(new_func))); - } - else - { - s7_pointer p; - for (p = cdr(closure_body(new_func)); is_pair(p); p = cdr(p)) - if ((is_pair(car(p))) && (has_location(car(p)))) - break; - let_set_file(new_let, (is_pair(p)) ? pair_file_number(car(p)) : port_file_number(current_input_port(sc))); - let_set_line(new_let, (is_pair(p)) ? pair_line_number(car(p)) : port_line_number(current_input_port(sc))); - } + if (has_location(closure_body(new_func))) + { + let_set_file(new_let, pair_file_number(closure_body(new_func))); + let_set_line(new_let, pair_line_number(closure_body(new_func))); + } + else + { + s7_pointer p; + for (p = cdr(closure_body(new_func)); is_pair(p); p = cdr(p)) + if ((is_pair(car(p))) && (has_location(car(p)))) + break; + let_set_file(new_let, (is_pair(p)) ? pair_file_number(car(p)) : port_file_number(current_input_port(sc))); + let_set_line(new_let, (is_pair(p)) ? pair_line_number(car(p)) : port_line_number(current_input_port(sc))); + } set_has_let_file(new_let); } else @@ -85397,11 +85397,11 @@ static void op_define_with_setter(s7_scheme *sc) { s7_pointer new_func = sc->value, new_let; if (is_safe_closure_body(closure_body(new_func))) - { - set_safe_closure(new_func); - if (is_very_safe_closure_body(closure_body(new_func))) - set_very_safe_closure(new_func); - } + { + set_safe_closure(new_func); + if (is_very_safe_closure_body(closure_body(new_func))) + set_very_safe_closure(new_func); + } new_let = make_funclet(sc, new_func, code, closure_let(new_func)); /* this should happen only if the closure* default values do not refer in any way to @@ -85412,68 +85412,68 @@ static void op_define_with_setter(s7_scheme *sc) set_let_file_and_line(sc, new_let, new_func); /* add the newly defined thing to the current environment */ if ((is_let(sc->curlet)) && (sc->curlet != sc->rootlet)) - { - if (let_id(sc->curlet) <= symbol_id(code)) /* we're adding a later-bound symbol to an old let (?) */ - { /* was < 16-Aug-22: (let ((a 3)) (define (a) 4) (curlet)) */ - s7_pointer slot; - sc->let_number++; /* dummy let, force symbol lookup */ - for (slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) - if (slot_symbol(slot) == code) - { - if (is_immutable_slot(slot)) - syntax_error_nr(sc, "define ~S, but it is immutable", 30, code); /* someday give the location of the immutable definition or setting */ - slot_set_value(slot, new_func); - symbol_set_local_slot(code, sc->let_number, slot); - set_local(code); - sc->value = new_func; /* probably not needed? */ - return; - } - new_cell_no_check(sc, slot, T_SLOT); - slot_set_symbol_and_value(slot, code, new_func); - symbol_set_local_slot(code, sc->let_number, slot); - slot_set_next(slot, let_slots(sc->curlet)); - let_set_slots(sc->curlet, slot); - } - else add_slot(sc, sc->curlet, code, new_func); - set_local(code); - } + { + if (let_id(sc->curlet) <= symbol_id(code)) /* we're adding a later-bound symbol to an old let (?) */ + { /* was < 16-Aug-22: (let ((a 3)) (define (a) 4) (curlet)) */ + s7_pointer slot; + sc->let_number++; /* dummy let, force symbol lookup */ + for (slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == code) + { + if (is_immutable_slot(slot)) + syntax_error_nr(sc, "define ~S, but it is immutable", 30, code); /* someday give the location of the immutable definition or setting */ + slot_set_value(slot, new_func); + symbol_set_local_slot(code, sc->let_number, slot); + set_local(code); + sc->value = new_func; /* probably not needed? */ + return; + } + new_cell_no_check(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, code, new_func); + symbol_set_local_slot(code, sc->let_number, slot); + slot_set_next(slot, let_slots(sc->curlet)); + let_set_slots(sc->curlet, slot); + } + else add_slot(sc, sc->curlet, code, new_func); + set_local(code); + } else - { - if ((is_slot(global_slot(code))) && - (is_immutable_slot(global_slot(code)))) - { - s7_pointer old_symbol = code, old_value = global_value(code); - if ((type(old_value) != type(new_func)) || - (!s7_is_equivalent(sc, old_value, new_func))) /* if value is unchanged, just ignore this (re)definition */ - syntax_error_nr(sc, "define ~S, but it is immutable", 30, old_symbol); - } - else s7_make_slot(sc, sc->curlet, code, new_func); - } + { + if ((is_slot(global_slot(code))) && + (is_immutable_slot(global_slot(code)))) + { + s7_pointer old_symbol = code, old_value = global_value(code); + if ((type(old_value) != type(new_func)) || + (!s7_is_equivalent(sc, old_value, new_func))) /* if value is unchanged, just ignore this (re)definition */ + syntax_error_nr(sc, "define ~S, but it is immutable", 30, old_symbol); + } + else s7_make_slot(sc, sc->curlet, code, new_func); + } sc->value = new_func; /* 25-Jul-14 so define returns the value not the name */ } else { s7_pointer slot = symbol_to_local_slot(sc, code, sc->curlet); if (is_slot(slot)) - { - if (is_immutable_slot(slot)) - { - s7_pointer old_symbol = code, old_value = slot_value(slot); - if ((type(old_value) != type(sc->value)) || - (!s7_is_equivalent(sc, old_value, sc->value))) /* if value is unchanged, just ignore this (re)definition */ - syntax_error_nr(sc, "define ~S, but it is immutable", 30, old_symbol); - } - else - { - slot_set_value_with_hook(slot, sc->value); - symbol_increment_ctr(code); - }} + { + if (is_immutable_slot(slot)) + { + s7_pointer old_symbol = code, old_value = slot_value(slot); + if ((type(old_value) != type(sc->value)) || + (!s7_is_equivalent(sc, old_value, sc->value))) /* if value is unchanged, just ignore this (re)definition */ + syntax_error_nr(sc, "define ~S, but it is immutable", 30, old_symbol); + } + else + { + slot_set_value_with_hook(slot, sc->value); + symbol_increment_ctr(code); + }} else s7_make_slot(sc, sc->curlet, code, sc->value); if ((is_any_macro(sc->value)) && (!is_c_macro(sc->value))) - { - set_pair_macro(closure_body(sc->value), code); - set_has_pair_macro(sc->value); - }} + { + set_pair_macro(closure_body(sc->value), code); + set_has_pair_macro(sc->value); + }} } @@ -85762,20 +85762,20 @@ static void op_any_closure_3p(s7_scheme *sc) sc->args = fx_call(sc, p); p = cdr(p); if (has_fx(p)) - { - stack_end_code(sc) = sc->code; /* push_stack_direct(sc, OP_ANY_CLOSURE_3P_3) here but trying to be too clever? */ - stack_end_args(sc) = sc->args; /* stack[args] == arg1 to closure) */ - stack_end_op(sc) = (s7_pointer)(opcode_t)(OP_ANY_CLOSURE_3P_3); - sc->stack_end += 4; - set_stack_protected3_with(sc, fx_call(sc, p), OP_ANY_CLOSURE_3P_3); - /* (i.e. stack[curlet] == arg2 of closure), fx_call might push_stack gc_protect etc, so push_stack via +4 before it */ - sc->code = cadr(p); - } + { + stack_end_code(sc) = sc->code; /* push_stack_direct(sc, OP_ANY_CLOSURE_3P_3) here but trying to be too clever? */ + stack_end_args(sc) = sc->args; /* stack[args] == arg1 to closure) */ + stack_end_op(sc) = (s7_pointer)(opcode_t)(OP_ANY_CLOSURE_3P_3); + sc->stack_end += 4; + set_stack_protected3_with(sc, fx_call(sc, p), OP_ANY_CLOSURE_3P_3); + /* (i.e. stack[curlet] == arg2 of closure), fx_call might push_stack gc_protect etc, so push_stack via +4 before it */ + sc->code = cadr(p); + } else - { - push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); /* arg1 == stack[args] */ - sc->code = car(p); - }} + { + push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); /* arg1 == stack[args] */ + sc->code = car(p); + }} else { push_stack_no_args_direct(sc, OP_ANY_CLOSURE_3P_1); @@ -85791,7 +85791,7 @@ static bool closure_3p_end(s7_scheme *sc, s7_pointer p) gc_protect_2_via_stack(sc, sc->args, sc->value); /* sc->args == arg1, sc->value == arg2 */ set_stack_protected3(sc, fx_call(sc, p)); if (is_safe_closure(func)) - set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc))); + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc))); else make_let_with_three_slots(sc, func, stack_protected1(sc), stack_protected2(sc), stack_protected3(sc)); unstack_gc_protect(sc); sc->code = T_Pair(closure_body(func)); @@ -85838,26 +85838,26 @@ static void op_any_closure_4p(s7_scheme *sc) gc_protect_via_stack(sc, fx_call(sc, p)); p = cdr(p); if (has_fx(p)) - { - set_stack_protected2(sc, fx_call(sc, p)); - p = cdr(p); - if (has_fx(p)) - { - set_stack_protected3(sc, fx_call(sc, p)); - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4); - sc->code = cadr(p); - } - else - { - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); - sc->code = car(p); - }} + { + set_stack_protected2(sc, fx_call(sc, p)); + p = cdr(p); + if (has_fx(p)) + { + set_stack_protected3(sc, fx_call(sc, p)); + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4); + sc->code = cadr(p); + } + else + { + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); + sc->code = car(p); + }} else - { - stack_end_args(sc) = sc->unused; /* copy_stack dangling pair */ - push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2); - sc->code = car(p); - }} + { + stack_end_args(sc) = sc->unused; /* copy_stack dangling pair */ + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2); + sc->code = car(p); + }} else { push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_1); @@ -85872,7 +85872,7 @@ static bool closure_4p_end(s7_scheme *sc, s7_pointer p) s7_pointer func = opt1_lambda(sc->code); sc->args = fx_call(sc, p); if (is_safe_closure(func)) - set_curlet(sc, update_let_with_four_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->args)); + set_curlet(sc, update_let_with_four_slots(sc, closure_let(func), stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->args)); else make_let_with_four_slots(sc, func, stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->args); sc->code = T_Pair(closure_body(func)); unstack_gc_protect(sc); @@ -85892,10 +85892,10 @@ static bool op_any_closure_4p_1(s7_scheme *sc) set_stack_protected2(sc, fx_call(sc, p)); p = cdr(p); if (has_fx(p)) - { - set_stack_protected3(sc, fx_call(sc, p)); - return(closure_4p_end(sc, cdr(p))); - } + { + set_stack_protected3(sc, fx_call(sc, p)); + return(closure_4p_end(sc, cdr(p))); + } push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); sc->code = car(p); } @@ -85958,8 +85958,8 @@ static inline void op_closure_ss(s7_scheme *sc) s7_pointer f = opt1_lambda(sc->code); check_stack_size(sc); set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(f), - car(closure_args(f)), lookup(sc, cadr(sc->code)), - cadr(closure_args(f)), lookup(sc, opt2_sym(sc->code)))); + car(closure_args(f)), lookup(sc, cadr(sc->code)), + cadr(closure_args(f)), lookup(sc, opt2_sym(sc->code)))); sc->code = T_Pair(closure_body(f)); push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); sc->code = car(sc->code); @@ -85969,8 +85969,8 @@ static inline void op_closure_ss_o(s7_scheme *sc) { s7_pointer f = opt1_lambda(sc->code); set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(f), - car(closure_args(f)), lookup(sc, cadr(sc->code)), - cadr(closure_args(f)), lookup(sc, opt2_sym(sc->code)))); + car(closure_args(f)), lookup(sc, cadr(sc->code)), + cadr(closure_args(f)), lookup(sc, opt2_sym(sc->code)))); sc->code = car(closure_body(f)); } @@ -86308,14 +86308,14 @@ static bool check_closure_sym(s7_scheme *sc, int32_t args) { s7_pointer f = lookup_unexamined(sc, car(sc->code)); if ((f != opt1_lambda_unchecked(sc->code)) && - ((!f) || - ((low_type_bits(f) & (TYPE_MASK | T_SAFE_CLOSURE)) != T_CLOSURE) || - (((args == 1) && (!is_symbol(closure_args(f)))) || - ((args == 2) && ((!is_pair(closure_args(f))) || (!is_symbol(cdr(closure_args(f))))))))) - { - sc->last_function = f; - return(false); - } + ((!f) || + ((low_type_bits(f) & (TYPE_MASK | T_SAFE_CLOSURE)) != T_CLOSURE) || + (((args == 1) && (!is_symbol(closure_args(f)))) || + ((args == 2) && ((!is_pair(closure_args(f))) || (!is_symbol(cdr(closure_args(f))))))))) + { + sc->last_function = f; + return(false); + } set_opt1_lambda(sc->code, f); } return(true); @@ -86328,28 +86328,28 @@ static void op_any_closure_sym(s7_scheme *sc) /* for (lambda a ...) */ if (num_args == 1) set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), closure_args(func), - ((is_safe_closure(func)) && (!sc->debug_or_profile)) ? - set_plist_1(sc, fx_call(sc, old_args)) : list_1(sc, sc->value = fx_call(sc, old_args)))); + ((is_safe_closure(func)) && (!sc->debug_or_profile)) ? + set_plist_1(sc, fx_call(sc, old_args)) : list_1(sc, sc->value = fx_call(sc, old_args)))); else if (num_args == 2) { - gc_protect_via_stack(sc, fx_call(sc, old_args)); /* not sc->value as GC protection! -- fx_call below can clobber it */ - sc->args = fx_call(sc, cdr(old_args)); - set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), closure_args(func), - ((is_safe_closure(func)) && (!sc->debug_or_profile)) ? - set_plist_2(sc, stack_protected1(sc), sc->args) : list_2(sc, stack_protected1(sc), sc->args))); - unstack_gc_protect(sc); + gc_protect_via_stack(sc, fx_call(sc, old_args)); /* not sc->value as GC protection! -- fx_call below can clobber it */ + sc->args = fx_call(sc, cdr(old_args)); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), closure_args(func), + ((is_safe_closure(func)) && (!sc->debug_or_profile)) ? + set_plist_2(sc, stack_protected1(sc), sc->args) : list_2(sc, stack_protected1(sc), sc->args))); + unstack_gc_protect(sc); } else if (num_args == 0) - set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), closure_args(func), sc->nil)); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), closure_args(func), sc->nil)); else - { - sc->args = make_list(sc, num_args, sc->unused); - for (s7_pointer p = sc->args; is_pair(p); p = cdr(p), old_args = cdr(old_args)) - set_car(p, fx_call(sc, old_args)); - set_curlet(sc, make_let_with_slot(sc, closure_let(func), closure_args(func), sc->args)); - } + { + sc->args = make_list(sc, num_args, sc->unused); + for (s7_pointer p = sc->args; is_pair(p); p = cdr(p), old_args = cdr(old_args)) + set_car(p, fx_call(sc, old_args)); + set_curlet(sc, make_let_with_slot(sc, closure_let(func), closure_args(func), sc->args)); + } sc->code = T_Pair(closure_body(func)); } @@ -86365,18 +86365,18 @@ static void op_any_closure_a_sym(s7_scheme *sc) /* for (lambda (a . b) ...) */ { gc_protect_via_stack(sc, fx_call(sc, old_args)); /* not sc->value as GC protection! -- fx_call below can clobber it */ if (num_args == 2) - { - sc->args = fx_call(sc, cdr(old_args)); - set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(func_args), stack_protected1(sc), cdr(func_args), list_1(sc, sc->args))); - } + { + sc->args = fx_call(sc, cdr(old_args)); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(func_args), stack_protected1(sc), cdr(func_args), list_1(sc, sc->args))); + } else - { - sc->args = make_list(sc, num_args - 1, sc->unused); - old_args = cdr(old_args); - for (s7_pointer p = sc->args; is_pair(p); p = cdr(p), old_args = cdr(old_args)) - set_car(p, fx_call(sc, old_args)); - set_curlet(sc, make_let_with_two_slots(sc, closure_let(func), car(func_args), stack_protected1(sc), cdr(func_args), sc->args)); - } + { + sc->args = make_list(sc, num_args - 1, sc->unused); + old_args = cdr(old_args); + for (s7_pointer p = sc->args; is_pair(p); p = cdr(p), old_args = cdr(old_args)) + set_car(p, fx_call(sc, old_args)); + set_curlet(sc, make_let_with_two_slots(sc, closure_let(func), car(func_args), stack_protected1(sc), cdr(func_args), sc->args)); + } unstack_gc_protect(sc); } sc->code = T_Pair(closure_body(func)); @@ -86418,30 +86418,30 @@ static bool op_tc_case_la(s7_scheme *sc, s7_pointer code) if (len == 3) { while (true) - { - s7_pointer selector = fx_call(sc, selp); - if (selector == opt1_any(clauses)) - endp = opt2_any(clauses); - else - { - s7_pointer p = cdr(clauses); - endp = (selector == opt1_any(p)) ? opt2_any(p) : opt2_any(cdr(p)); - } - if (has_tc(endp)) - slot_set_value(la_slot, fx_call(sc, cdr(endp))); - else break; - }} + { + s7_pointer selector = fx_call(sc, selp); + if (selector == opt1_any(clauses)) + endp = opt2_any(clauses); + else + { + s7_pointer p = cdr(clauses); + endp = (selector == opt1_any(p)) ? opt2_any(p) : opt2_any(cdr(p)); + } + if (has_tc(endp)) + slot_set_value(la_slot, fx_call(sc, cdr(endp))); + else break; + }} else while (true) { - s7_pointer p, selector = fx_call(sc, selp); - for (p = clauses; is_pair(cdr(p)); p = cdr(p)) - if (selector == opt1_any(p)) {endp = opt2_any(p); goto CASE_ALA_END;} - endp = opt2_any(p); + s7_pointer p, selector = fx_call(sc, selp); + for (p = clauses; is_pair(cdr(p)); p = cdr(p)) + if (selector == opt1_any(p)) {endp = opt2_any(p); goto CASE_ALA_END;} + endp = opt2_any(p); CASE_ALA_END: - if (has_tc(endp)) - slot_set_value(la_slot, fx_call(sc, cdr(endp))); - else break; + if (has_tc(endp)) + slot_set_value(la_slot, fx_call(sc, cdr(endp))); + else break; } if (has_fx(endp)) { @@ -86550,8 +86550,8 @@ static void op_tc_or_a_and_a_a_la(s7_scheme *sc, s7_pointer code) s7_pointer p = fx_call(sc, fx_or); if (p != sc->F) {sc->value = p; return;} if ((fx_call(sc, fx_and1) == sc->F) || - (fx_call(sc, fx_and2) == sc->F)) - {sc->value = sc->F; return;} + (fx_call(sc, fx_and2) == sc->F)) + {sc->value = sc->F; return;} slot_set_value(la_slot, fx_call(sc, fx_la)); } } @@ -86602,12 +86602,12 @@ static void op_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer code) { s7_pointer la_val = slot_value(la_slot), laa_val = slot_value(laa_slot); while (true) - { - if (is_null(laa_val)) {sc->value = sc->F; return;} - if (is_null(la_val)) {sc->value = sc->T; return;} - la_val = cdr(la_val); - laa_val = cdr(laa_val); - }} + { + if (is_null(laa_val)) {sc->value = sc->F; return;} + if (is_null(la_val)) {sc->value = sc->T; return;} + la_val = cdr(la_val); + laa_val = cdr(laa_val); + }} while (true) { s7_pointer p; @@ -86732,16 +86732,16 @@ static void op_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer code) fx_and1 = cdar(fx_and1); fx_and2 = cdar(fx_and2); while (true) - { - s7_pointer p = fx_call(sc, fx_or); - if (p != sc->F) {sc->value = p; return;} - if ((fx_call(sc, fx_and1) != sc->F) || (fx_call(sc, fx_and2) != sc->F)) {sc->value = sc->F; return;} - 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); - }} + { + s7_pointer p = fx_call(sc, fx_or); + if (p != sc->F) {sc->value = p; return;} + if ((fx_call(sc, fx_and1) != sc->F) || (fx_call(sc, fx_and2) != sc->F)) {sc->value = sc->F; return;} + 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); + }} while (true) { s7_pointer p = fx_call(sc, fx_or); @@ -86774,15 +86774,15 @@ static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code, bool cond) { sc->pc = 0; if (bool_optimize(sc, if_test)) - { - opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc]; - if (int_optimize(sc, la)) - { - s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); - slot_set_value(la_slot, val); - while (!(o->v[0].fb(o))){set_integer(val, o1->v[0].fi(o1));} - return(op_tc_z(sc, if_true)); - }}} + { + opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc]; + if (int_optimize(sc, la)) + { + s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); + slot_set_value(la_slot, val); + while (!(o->v[0].fb(o))){set_integer(val, o1->v[0].fi(o1));} + return(op_tc_z(sc, if_true)); + }}} while (fx_call(sc, if_test) == sc->F) {slot_set_value(la_slot, fx_call(sc, la));} return(op_tc_z(sc, if_true)); } @@ -86811,15 +86811,15 @@ static bool op_tc_if_a_la_z(s7_scheme *sc, s7_pointer code, bool cond) { sc->pc = 0; if (bool_optimize(sc, if_test)) - { - opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc]; - if (int_optimize(sc, la)) - { - s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); - slot_set_value(la_slot, val); - while (o->v[0].fb(o)) {set_integer(val, o1->v[0].fi(o1));} - return(op_tc_z(sc, if_false)); - }}} + { + opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc]; + if (int_optimize(sc, la)) + { + s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); + slot_set_value(la_slot, val); + while (o->v[0].fb(o)) {set_integer(val, o1->v[0].fi(o1));} + return(op_tc_z(sc, if_false)); + }}} while (fx_call(sc, if_test) != sc->F) {slot_set_value(la_slot, fx_call(sc, la));} return(op_tc_z(sc, if_false)); } @@ -86863,85 +86863,85 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first, tc_ch { sc->pc = 0; if (bool_optimize(sc, if_test)) - { - opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc], *o2; - int32_t start_pc = 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_int (*fi1)(opt_info *o) = o1->v[0].fi; - s7_int (*fi2)(opt_info *o) = o2->v[0].fi; - bool (*fb)(opt_info *o) = o->v[0].fb; - s7_pointer val1 = make_mutable_integer(sc, integer(slot_value(la_slot))); - s7_pointer val2; - slot_set_value(la_slot, val1); - slot_set_value(laa_slot, val2 = make_mutable_integer(sc, integer(slot_value(laa_slot)))); - if ((z_first) && - ((fb == opt_b_ii_sc_lt) || (fb == opt_b_ii_sc_lt_0)) && - (fi1 == opt_i_ii_sc_sub)) - { - s7_int lim = o->v[2].i, m = o1->v[2].i; - s7_pointer slot1 = o->v[1].p, slot2 = o1->v[1].p; - while (integer(slot_value(slot1)) >= lim) - { - s7_int i1 = integer(slot_value(slot2)) - m; - set_integer(val2, fi2(o2)); - set_integer(val1, i1); - }} - else - while (fb(o) != z_first) - { - s7_int i1 = fi1(o1); - set_integer(val2, fi2(o2)); - set_integer(val1, i1); - } - return(op_tc_z(sc, if_z)); - }}} - - if ((is_t_real(slot_value(la_slot))) && - (is_t_real(slot_value(laa_slot)))) - { - sc->pc = start_pc; - if (float_optimize(sc, la)) - { - o2 = sc->opts[sc->pc]; - if (float_optimize(sc, laa)) - { - s7_double (*fd1)(opt_info *o) = o1->v[0].fd; - s7_double (*fd2)(opt_info *o) = o2->v[0].fd; - bool (*fb)(opt_info *o) = o->v[0].fb; - s7_pointer val1 = make_mutable_real(sc, real(slot_value(la_slot))); - s7_pointer val2 = make_mutable_real(sc, real(slot_value(laa_slot))); - slot_set_value(la_slot, val1); - slot_set_value(laa_slot, val2); - if ((z_first) && - (fb == opt_b_dd_sc_lt) && - (fd1 == opt_d_dd_sc_sub)) - { - s7_double lim = o->v[2].x; - s7_double m = o1->v[2].x; - s7_pointer slot1 = o->v[1].p; - s7_pointer slot2 = o1->v[1].p; - while (real(slot_value(slot1)) >= lim) - { - s7_double x1 = real(slot_value(slot2)) - m; - set_real(val2, fd2(o2)); - set_real(val1, x1); - }} - else - while (fb(o) != z_first) - { - s7_double x1 = fd1(o1); - set_real(val2, fd2(o2)); - set_real(val1, x1); - } - return(op_tc_z(sc, if_z)); - }}}} + { + opt_info *o = sc->opts[0], *o1 = sc->opts[sc->pc], *o2; + int32_t start_pc = 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_int (*fi1)(opt_info *o) = o1->v[0].fi; + s7_int (*fi2)(opt_info *o) = o2->v[0].fi; + bool (*fb)(opt_info *o) = o->v[0].fb; + s7_pointer val1 = make_mutable_integer(sc, integer(slot_value(la_slot))); + s7_pointer val2; + slot_set_value(la_slot, val1); + slot_set_value(laa_slot, val2 = make_mutable_integer(sc, integer(slot_value(laa_slot)))); + if ((z_first) && + ((fb == opt_b_ii_sc_lt) || (fb == opt_b_ii_sc_lt_0)) && + (fi1 == opt_i_ii_sc_sub)) + { + s7_int lim = o->v[2].i, m = o1->v[2].i; + s7_pointer slot1 = o->v[1].p, slot2 = o1->v[1].p; + while (integer(slot_value(slot1)) >= lim) + { + s7_int i1 = integer(slot_value(slot2)) - m; + set_integer(val2, fi2(o2)); + set_integer(val1, i1); + }} + else + while (fb(o) != z_first) + { + s7_int i1 = fi1(o1); + set_integer(val2, fi2(o2)); + set_integer(val1, i1); + } + return(op_tc_z(sc, if_z)); + }}} + + if ((is_t_real(slot_value(la_slot))) && + (is_t_real(slot_value(laa_slot)))) + { + sc->pc = start_pc; + if (float_optimize(sc, la)) + { + o2 = sc->opts[sc->pc]; + if (float_optimize(sc, laa)) + { + s7_double (*fd1)(opt_info *o) = o1->v[0].fd; + s7_double (*fd2)(opt_info *o) = o2->v[0].fd; + bool (*fb)(opt_info *o) = o->v[0].fb; + s7_pointer val1 = make_mutable_real(sc, real(slot_value(la_slot))); + s7_pointer val2 = make_mutable_real(sc, real(slot_value(laa_slot))); + slot_set_value(la_slot, val1); + slot_set_value(laa_slot, val2); + if ((z_first) && + (fb == opt_b_dd_sc_lt) && + (fd1 == opt_d_dd_sc_sub)) + { + s7_double lim = o->v[2].x; + s7_double m = o1->v[2].x; + s7_pointer slot1 = o->v[1].p; + s7_pointer slot2 = o1->v[1].p; + while (real(slot_value(slot1)) >= lim) + { + s7_double x1 = real(slot_value(slot2)) - m; + set_real(val2, fd2(o2)); + set_real(val1, x1); + }} + else + while (fb(o) != z_first) + { + s7_double x1 = fd1(o1); + set_real(val2, fd2(o2)); + set_real(val1, x1); + } + return(op_tc_z(sc, if_z)); + }}}} set_no_bool_opt(code); } #endif @@ -86950,28 +86950,28 @@ static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first, tc_ch if (z_first) { if ((fx_proc(la) == fx_cdr_t) && (fx_proc(laa) == fx_subtract_u1) && - (fn_proc(if_test) == g_num_eq_xi) && /* was also (fx_proc(if_test) == fx_num_eq_ui) but we cloberred if_test above */ - (is_pair(slot_value(la_slot))) && (is_t_integer(slot_value(laa_slot)))) - { /* list-tail ferchrissake */ - s7_int end = integer(caddr(if_test)); - s7_pointer lst = slot_value(la_slot); - for (s7_int start = integer(slot_value(laa_slot)); start > end; start--) - lst = cdr(lst); - slot_set_value(la_slot, lst); - } + (fn_proc(if_test) == g_num_eq_xi) && /* was also (fx_proc(if_test) == fx_num_eq_ui) but we cloberred if_test above */ + (is_pair(slot_value(la_slot))) && (is_t_integer(slot_value(laa_slot)))) + { /* list-tail ferchrissake */ + s7_int end = integer(caddr(if_test)); + s7_pointer lst = slot_value(la_slot); + for (s7_int start = integer(slot_value(laa_slot)); start > end; start--) + lst = cdr(lst); + slot_set_value(la_slot, lst); + } 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); - }} + 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); + }} 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); + 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)); } @@ -87156,31 +87156,31 @@ static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code, bool z_first, opt_info *o = sc->opts[0]; sc->pc = 0; if (bool_optimize_nw(sc, if_test)) - { - opt_info *o1 = sc->opts[sc->pc]; - if (bool_optimize_nw(sc, f_test)) - { - opt_info *o2 = sc->opts[sc->pc]; - if (int_optimize(sc, la)) - { - s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); - slot_set_value(la_slot, val); - if (tc_and) - while (true) - { - if (!o->v[0].fb(o)) {sc->value = sc->F; return(true);} - if (o1->v[0].fb(o1) == z_first) {endp = f_z; break;} - set_integer(val, o2->v[0].fi(o2)); - } - else - while (true) - { - if (o->v[0].fb(o)) {endp = if_true; break;} - if (o1->v[0].fb(o1) == z_first) {endp = f_z; break;} - set_integer(val, o2->v[0].fi(o2)); - } - return(op_tc_z(sc, endp)); - }}}} + { + opt_info *o1 = sc->opts[sc->pc]; + if (bool_optimize_nw(sc, f_test)) + { + opt_info *o2 = sc->opts[sc->pc]; + if (int_optimize(sc, la)) + { + s7_pointer val = make_mutable_integer(sc, integer(slot_value(la_slot))); + slot_set_value(la_slot, val); + if (tc_and) + while (true) + { + if (!o->v[0].fb(o)) {sc->value = sc->F; return(true);} + if (o1->v[0].fb(o1) == z_first) {endp = f_z; break;} + set_integer(val, o2->v[0].fi(o2)); + } + else + while (true) + { + if (o->v[0].fb(o)) {endp = if_true; break;} + if (o1->v[0].fb(o1) == z_first) {endp = f_z; break;} + set_integer(val, o2->v[0].fi(o2)); + } + return(op_tc_z(sc, endp)); + }}}} #endif while (true) { @@ -87248,32 +87248,32 @@ static bool op_tc_if_a_z_if_a_z_laa(s7_scheme *sc, bool cond, s7_pointer code) if (slot1) { if ((slot1 == laa_slot) && (fx_proc(f_test) == fx_is_null_t) && (fx_proc(la) == fx_cdr_t) && (fx_proc(laa) == fx_cdr_u) && - (is_boolean(car(if_true))) && (is_boolean(car(f_true)))) - { - s7_pointer la_val = slot_value(la_slot), laa_val = slot_value(laa_slot); - while (true) - { - if (is_null(laa_val)) {sc->value = car(if_true); return(true);} - if (is_null(la_val)) {sc->value = car(f_true); return(true);} - la_val = cdr(la_val); - laa_val = cdr(laa_val); - }} + (is_boolean(car(if_true))) && (is_boolean(car(f_true)))) + { + s7_pointer la_val = slot_value(la_slot), laa_val = slot_value(laa_slot); + while (true) + { + if (is_null(laa_val)) {sc->value = car(if_true); return(true);} + if (is_null(la_val)) {sc->value = car(f_true); return(true);} + la_val = cdr(la_val); + laa_val = cdr(laa_val); + }} while (true) - { - if (is_null(slot_value(slot1))) {endp = if_true; break;} - if (fx_call(sc, f_test) != sc->F) {endp = f_true; break;} - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - }} + { + if (is_null(slot_value(slot1))) {endp = if_true; break;} + if (fx_call(sc, f_test) != sc->F) {endp = f_true; break;} + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + }} 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_true; break;} - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); + if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;} + if (fx_call(sc, f_test) != sc->F) {endp = f_true; break;} + 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, endp)); } @@ -87354,17 +87354,17 @@ static bool op_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer code) { 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)); - } + { + 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)); - } + { + 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); } @@ -87440,42 +87440,42 @@ static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) { sc->pc = 0; if (bool_optimize(sc, if_test)) - { - opt_info *o = sc->opts[0]; - opt_info *o1 = sc->opts[sc->pc], *o2, *o3; - 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)) - { - o3 = sc->opts[sc->pc]; - set_curlet(sc, outer_let); - if (int_optimize(sc, let_var)) - { - s7_pointer val1 = make_mutable_integer(sc, integer(slot_value(la_slot))); - s7_pointer val2 = make_mutable_integer(sc, integer(slot_value(laa_slot))); - s7_pointer val3 = make_mutable_integer(sc, integer(slot_value(let_slot))); - set_curlet(sc, inner_let); - slot_set_value(la_slot, val1); - slot_set_value(laa_slot, val2); - slot_set_value(let_slot, val3); - while (!(o->v[0].fb(o))) - { - s7_int i1 = o1->v[0].fi(o1); - set_integer(val2, o2->v[0].fi(o2)); - set_integer(val1, i1); - set_integer(val3, o3->v[0].fi(o3)); - } - unstack_gc_protect(sc); - if (!op_tc_z(sc, if_true)) /* sc->inner_let in effect here since it was the last set above */ - return(false); - free_cell(sc, let_slots(inner_let)); - free_cell(sc, inner_let); - return(true); - }}}}} + { + opt_info *o = sc->opts[0]; + opt_info *o1 = sc->opts[sc->pc], *o2, *o3; + 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)) + { + o3 = sc->opts[sc->pc]; + set_curlet(sc, outer_let); + if (int_optimize(sc, let_var)) + { + s7_pointer val1 = make_mutable_integer(sc, integer(slot_value(la_slot))); + s7_pointer val2 = make_mutable_integer(sc, integer(slot_value(laa_slot))); + s7_pointer val3 = make_mutable_integer(sc, integer(slot_value(let_slot))); + set_curlet(sc, inner_let); + slot_set_value(la_slot, val1); + slot_set_value(laa_slot, val2); + slot_set_value(let_slot, val3); + while (!(o->v[0].fb(o))) + { + s7_int i1 = o1->v[0].fi(o1); + set_integer(val2, o2->v[0].fi(o2)); + set_integer(val1, i1); + set_integer(val3, o3->v[0].fi(o3)); + } + unstack_gc_protect(sc); + if (!op_tc_z(sc, if_true)) /* sc->inner_let in effect here since it was the last set above */ + return(false); + free_cell(sc, let_slots(inner_let)); + free_cell(sc, inner_let); + return(true); + }}}}} set_no_bool_opt(code); } #endif @@ -87522,58 +87522,58 @@ static void op_tc_let_when_laa(s7_scheme *sc, bool when, s7_pointer code) (car(laa) == slot_symbol(next_slot(let_slots(outer_let))))) { if ((cdr(if_true) == p) && (!when)) - { - s7_pointer a1 = slot_value(let_slots(outer_let)); - s7_pointer a2 = slot_value(next_slot(let_slots(outer_let))); - if ((is_input_port(a1)) && (is_output_port(a2)) && (is_string_port(a1)) && (is_file_port(a2)) && - (!port_is_closed(a1)) && (!port_is_closed(a2)) && (fx_proc(if_true) == fx_c_tU_direct) && - (fx_proc(let_var) == fx_c_t_direct) && (((s7_p_pp_t)opt3_direct(cdar(if_true))) == write_char_p_pp) && - (((s7_p_p_t)opt2_direct(cdar(let_var))) == read_char_p_p) && (fx_proc(if_test) == fx_is_eof_t)) - { - int32_t c = (int32_t)s7_character(slot_value(let_slots(inner_let))); - a1 = slot_value(let_slots(outer_let)); - a2 = slot_value(next_slot(let_slots(outer_let))); - while (c != EOF) - { - inline_file_write_char(sc, (uint8_t)c, a2); - c = string_read_char(sc, a1); - }} - else - while (fx_call(sc, if_test) == sc->F) - { - fx_call(sc, if_true); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - }} + { + s7_pointer a1 = slot_value(let_slots(outer_let)); + s7_pointer a2 = slot_value(next_slot(let_slots(outer_let))); + if ((is_input_port(a1)) && (is_output_port(a2)) && (is_string_port(a1)) && (is_file_port(a2)) && + (!port_is_closed(a1)) && (!port_is_closed(a2)) && (fx_proc(if_true) == fx_c_tU_direct) && + (fx_proc(let_var) == fx_c_t_direct) && (((s7_p_pp_t)opt3_direct(cdar(if_true))) == write_char_p_pp) && + (((s7_p_p_t)opt2_direct(cdar(let_var))) == read_char_p_p) && (fx_proc(if_test) == fx_is_eof_t)) + { + int32_t c = (int32_t)s7_character(slot_value(let_slots(inner_let))); + a1 = slot_value(let_slots(outer_let)); + a2 = slot_value(next_slot(let_slots(outer_let))); + while (c != EOF) + { + inline_file_write_char(sc, (uint8_t)c, a2); + c = string_read_char(sc, a1); + }} + else + while (fx_call(sc, if_test) == sc->F) + { + fx_call(sc, if_true); + set_curlet(sc, outer_let); + slot_set_value(let_slot, fx_call(sc, let_var)); + set_curlet(sc, inner_let); + }} else - while (true) - { - 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); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - }} + while (true) + { + 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); + set_curlet(sc, outer_let); + slot_set_value(let_slot, fx_call(sc, let_var)); + set_curlet(sc, inner_let); + }} else { s7_pointer la_slot = let_slots(outer_let); s7_pointer laa_slot = next_slot(la_slot); while (true) - { - 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); - sc->rec_p1 = fx_call(sc, la); - slot_set_value(laa_slot, fx_call(sc, laa)); - slot_set_value(la_slot, sc->rec_p1); - set_curlet(sc, outer_let); - slot_set_value(let_slot, fx_call(sc, let_var)); - set_curlet(sc, inner_let); - }} + { + 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); + sc->rec_p1 = fx_call(sc, la); + slot_set_value(laa_slot, fx_call(sc, laa)); + slot_set_value(la_slot, sc->rec_p1); + set_curlet(sc, outer_let); + slot_set_value(let_slot, fx_call(sc, let_var)); + set_curlet(sc, inner_let); + }} unstack_gc_protect(sc); free_cell(sc, let_slots(inner_let)); free_cell(sc, inner_let); @@ -87625,7 +87625,7 @@ static bool op_tc_if_a_z_let_if_a_z_laa(s7_scheme *sc, s7_pointer code) slot_set_value(slot, fx_call(sc, cdar(let_vars))); set_curlet(sc, inner_let); for (var = cdr(let_vars), slot = next_slot(slot); is_pair(var); var = cdr(var), slot = next_slot(slot)) - slot_set_value(slot, fx_call(sc, cdar(var))); + slot_set_value(slot, fx_call(sc, cdar(var))); if (fx_call(sc, if2_test) != sc->F) {endp = if2_true; break;} sc->rec_p1 = fx_call(sc, la); @@ -87667,57 +87667,57 @@ static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) if (opt3_arglen(cdr(code)) == 0) /* (loop) etc -- no args */ while (true) { - for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) - if (fx_call(sc, car(p)) != sc->F) - { - result = cdar(p); - if (!has_tc(result)) - goto TC_LET_COND_DONE; - set_curlet(sc, outer_let); - slot_set_value(let_slot, letf(sc, let_var)); - set_curlet(sc, inner_let); - break; - }} + for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) + if (fx_call(sc, car(p)) != sc->F) + { + result = cdar(p); + if (!has_tc(result)) + goto TC_LET_COND_DONE; + set_curlet(sc, outer_let); + slot_set_value(let_slot, letf(sc, let_var)); + set_curlet(sc, inner_let); + break; + }} else if (opt3_arglen(cdr(code)) == 1) while (true) - for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) - if (fx_call(sc, car(p)) != sc->F) - { - result = cdar(p); - if (!has_tc(result)) - goto TC_LET_COND_DONE; - slot_set_value(slots, fx_call(sc, cdar(result))); /* arg to recursion */ - set_curlet(sc, outer_let); - slot_set_value(let_slot, letf(sc, let_var)); /* inner let var */ - set_curlet(sc, inner_let); - break; - } + for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) + if (fx_call(sc, car(p)) != sc->F) + { + result = cdar(p); + if (!has_tc(result)) + goto TC_LET_COND_DONE; + slot_set_value(slots, fx_call(sc, cdar(result))); /* arg to recursion */ + set_curlet(sc, outer_let); + slot_set_value(let_slot, letf(sc, let_var)); /* inner let var */ + set_curlet(sc, inner_let); + break; + } let_set_has_pending_value(outer_let); read_case = ((letf == read_char_p_p) && (is_input_port(let_var)) && (is_string_port(let_var)) && (!port_is_closed(let_var))); while (true) for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) if (fx_call(sc, car(p)) != sc->F) - { - result = cdar(p); - if (!has_tc(result)) - goto TC_LET_COND_DONE; - for (s7_pointer slot = slots, arg = cdar(result); is_pair(arg); slot = next_slot(slot), arg = cdr(arg)) - slot_simply_set_pending_value(slot, fx_call(sc, arg)); - for (s7_pointer slot = slots; tis_slot(slot); slot = next_slot(slot)) /* using two swapping lets instead is slightly slower */ - slot_set_value(slot, slot_pending_value(slot)); - - if (read_case) - slot_set_value(let_slot, chars[string_read_char(sc, let_var)]); - else - { - set_curlet(sc, outer_let); - slot_set_value(let_slot, letf(sc, let_var)); - set_curlet(sc, inner_let); - } - break; - } + { + result = cdar(p); + if (!has_tc(result)) + goto TC_LET_COND_DONE; + for (s7_pointer slot = slots, arg = cdar(result); is_pair(arg); slot = next_slot(slot), arg = cdr(arg)) + slot_simply_set_pending_value(slot, fx_call(sc, arg)); + for (s7_pointer slot = slots; tis_slot(slot); slot = next_slot(slot)) /* using two swapping lets instead is slightly slower */ + slot_set_value(slot, slot_pending_value(slot)); + + if (read_case) + slot_set_value(let_slot, chars[string_read_char(sc, let_var)]); + else + { + set_curlet(sc, outer_let); + slot_set_value(let_slot, letf(sc, let_var)); + set_curlet(sc, inner_let); + } + break; + } let_clear_has_pending_value(sc, outer_let); TC_LET_COND_DONE: @@ -87753,15 +87753,15 @@ static bool op_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer code) { if (fx_call(sc, c1) != sc->F) {c1 = cdr(c1); break;} if (fx_call(sc, c2) != sc->F) - { - sc->rec_p1 = fx_call(sc, la1); - slot_set_value(laa_slot, fx_call(sc, laa1)); - } + { + sc->rec_p1 = fx_call(sc, la1); + slot_set_value(laa_slot, fx_call(sc, laa1)); + } else - { - sc->rec_p1 = fx_call(sc, la2); - slot_set_value(laa_slot, fx_call(sc, laa2)); - } + { + sc->rec_p1 = fx_call(sc, la2); + slot_set_value(laa_slot, fx_call(sc, laa2)); + } slot_set_value(la_slot, sc->rec_p1); } return(op_tc_z(sc, c1)); @@ -87896,33 +87896,33 @@ static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op, s7_ if ((is_symbol(c_op)) && ((is_global(c_op)) || ((is_slot(global_slot(c_op))) && - (s7_slot(sc, c_op) == global_slot(c_op))))) + (s7_slot(sc, c_op) == global_slot(c_op))))) { s7_pointer s_func = global_value(c_op), slot = let_slots(sc->curlet); if (is_c_function(s_func)) - { - sc->pc = 0; - sc->rec_test_o = sc->opts[0]; - if (bool_optimize(sc, cdr(code))) - { - int32_t start_pc = sc->pc; - sc->rec_result_o = sc->opts[start_pc]; - if (is_t_integer(slot_value(slot))) - { - sc->rec_i_ii_f = s7_i_ii_function(s_func); - if ((sc->rec_i_ii_f) && - (int_optimize(sc, (a_op) ? cddr(code) : cdddr(code)))) - { - sc->rec_a1_o = sc->opts[sc->pc]; - if (int_optimize(sc, (la_op) ? cdr(caller) : cddr(caller))) /* cdadr? */ - { - sc->rec_a2_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(opt3_pair(caller)))) - { - sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(slot))); - slot_set_value(slot, sc->rec_val1); - return(OPT_INT); - }}}}}}} + { + sc->pc = 0; + sc->rec_test_o = sc->opts[0]; + if (bool_optimize(sc, cdr(code))) + { + int32_t start_pc = sc->pc; + sc->rec_result_o = sc->opts[start_pc]; + if (is_t_integer(slot_value(slot))) + { + sc->rec_i_ii_f = s7_i_ii_function(s_func); + if ((sc->rec_i_ii_f) && + (int_optimize(sc, (a_op) ? cddr(code) : cdddr(code)))) + { + sc->rec_a1_o = sc->opts[sc->pc]; + if (int_optimize(sc, (la_op) ? cdr(caller) : cddr(caller))) /* cdadr? */ + { + sc->rec_a2_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(opt3_pair(caller)))) + { + sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(slot))); + slot_set_value(slot, sc->rec_val1); + return(OPT_INT); + }}}}}}} #endif rec_set_test(sc, cdr(code)); rec_set_res(sc, (a_op) ? cddr(code) : cdddr(code)); @@ -88021,7 +88021,7 @@ static void wrap_recur_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op) { sc->rec_stack = recur_make_stack(sc); if (a_op) - sc->value = (la_op) ? oprec_if_a_a_opa_laq(sc) : oprec_if_a_a_opla_aq(sc); + sc->value = (la_op) ? oprec_if_a_a_opa_laq(sc) : oprec_if_a_a_opla_aq(sc); else sc->value = (la_op) ? oprec_if_a_opa_laq_a(sc) : oprec_if_a_opla_aq_a(sc); sc->rec_loc = 0; } @@ -88201,59 +88201,59 @@ static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op) if ((is_symbol(c_op)) && ((is_global(c_op)) || ((is_slot(global_slot(c_op))) && - (s7_slot(sc, c_op) == global_slot(c_op))))) + (s7_slot(sc, c_op) == global_slot(c_op))))) { s7_pointer s_func = global_value(c_op); s7_pointer slot = let_slots(sc->curlet); if (is_c_function(s_func)) - { - sc->pc = 0; - sc->rec_test_o = sc->opts[0]; - if (bool_optimize(sc, cdr(sc->code))) - { - int32_t start_pc = sc->pc; - sc->rec_result_o = sc->opts[start_pc]; - if (is_t_integer(slot_value(slot))) - { - sc->rec_i_ii_f = s7_i_ii_function(s_func); - if ((sc->rec_i_ii_f) && - (int_optimize(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)))) - { - sc->rec_a1_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdadr(caller))) - { - sc->rec_a2_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(opt3_pair(caller)))) - { - sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(slot))); - slot_set_value(slot, sc->rec_val1); - if (sc->pc != 4) - return(OPT_INT); - sc->rec_fb1 = sc->rec_test_o->v[0].fb; - sc->rec_fi1 = sc->rec_result_o->v[0].fi; - sc->rec_fi2 = sc->rec_a1_o->v[0].fi; - sc->rec_fi3 = sc->rec_a2_o->v[0].fi; - return(OPT_INT_0); - }}}} - if (is_t_real(slot_value(slot))) - { - sc->rec_d_dd_f = s7_d_dd_function(s_func); - if (sc->rec_d_dd_f) - { - sc->pc = start_pc; - sc->rec_result_o = sc->opts[start_pc]; - if (float_optimize(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code))) - { - sc->rec_a1_o = sc->opts[sc->pc]; - if (float_optimize(sc, cdadr(caller))) - { - sc->rec_a2_o = sc->opts[sc->pc]; - if (float_optimize(sc, cdr(opt3_pair(caller)))) - { - sc->rec_val1 = make_mutable_real(sc, real(slot_value(slot))); - slot_set_value(slot, sc->rec_val1); - return(OPT_DBL); - }}}}}}}} + { + sc->pc = 0; + sc->rec_test_o = sc->opts[0]; + if (bool_optimize(sc, cdr(sc->code))) + { + int32_t start_pc = sc->pc; + sc->rec_result_o = sc->opts[start_pc]; + if (is_t_integer(slot_value(slot))) + { + sc->rec_i_ii_f = s7_i_ii_function(s_func); + if ((sc->rec_i_ii_f) && + (int_optimize(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)))) + { + sc->rec_a1_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdadr(caller))) + { + sc->rec_a2_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(opt3_pair(caller)))) + { + sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(slot))); + slot_set_value(slot, sc->rec_val1); + if (sc->pc != 4) + return(OPT_INT); + sc->rec_fb1 = sc->rec_test_o->v[0].fb; + sc->rec_fi1 = sc->rec_result_o->v[0].fi; + sc->rec_fi2 = sc->rec_a1_o->v[0].fi; + sc->rec_fi3 = sc->rec_a2_o->v[0].fi; + return(OPT_INT_0); + }}}} + if (is_t_real(slot_value(slot))) + { + sc->rec_d_dd_f = s7_d_dd_function(s_func); + if (sc->rec_d_dd_f) + { + sc->pc = start_pc; + sc->rec_result_o = sc->opts[start_pc]; + if (float_optimize(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code))) + { + sc->rec_a1_o = sc->opts[sc->pc]; + if (float_optimize(sc, cdadr(caller))) + { + sc->rec_a2_o = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(opt3_pair(caller)))) + { + sc->rec_val1 = make_mutable_real(sc, real(slot_value(slot))); + slot_set_value(slot, sc->rec_val1); + return(OPT_DBL); + }}}}}}}} #endif rec_set_test(sc, cdr(sc->code)); rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code)); @@ -88390,15 +88390,15 @@ static void wrap_recur_if_a_a_opla_laq(s7_scheme *sc, bool a_op) if ((choice == OPT_INT) || (choice == OPT_INT_0)) { if (choice == OPT_INT_0) - sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq_0(sc) : oprec_i_if_a_opla_laq_a_0(sc)); + sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq_0(sc) : oprec_i_if_a_opla_laq_a_0(sc)); else sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq(sc) : oprec_i_if_a_opla_laq_a(sc)); } else if (choice == OPT_PTR) { - sc->rec_stack = recur_make_stack(sc); - sc->value = (a_op) ? oprec_if_a_a_opla_laq(sc) : oprec_if_a_opla_laq_a(sc); - sc->rec_loc = 0; + sc->rec_stack = recur_make_stack(sc); + sc->value = (a_op) ? oprec_if_a_a_opla_laq(sc) : oprec_if_a_opla_laq_a(sc); + sc->rec_loc = 0; } else sc->value = make_real(sc, (a_op) ? oprec_d_if_a_a_opla_laq(sc) : oprec_d_if_a_opla_laq_a(sc)); } @@ -88835,20 +88835,20 @@ static s7_pointer oprec_cond_a_a_a_laa_opa_laaq(s7_scheme *sc) else if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) { - recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); - slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_cond_a_a_a_laa_opa_laaq(sc)); /* first laa above */ + recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p)); + slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + set_car(sc->t2_2, oprec_cond_a_a_a_laa_opa_laaq(sc)); /* first laa above */ } else { - recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); - recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); - slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); - slot_set_value(sc->rec_slot1, recur_pop(sc)); - set_car(sc->t2_2, oprec_cond_a_a_a_laa_opa_laaq(sc)); - set_car(sc->t2_1, recur_pop(sc)); - set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); + recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p)); + recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p)); + slot_set_value(sc->rec_slot2, sc->rec_f6f(sc, sc->rec_f6p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + set_car(sc->t2_2, oprec_cond_a_a_a_laa_opa_laaq(sc)); + set_car(sc->t2_1, recur_pop(sc)); + set_car(sc->t2_2, sc->rec_fn(sc, sc->t2_1)); } set_car(sc->t2_1, recur_pop(sc)); return(sc->rec_fn(sc, sc->t2_1)); @@ -88881,46 +88881,46 @@ static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc) sc->pc = 0; sc->rec_test_o = sc->opts[0]; if (bool_optimize(sc, cadr(sc->code))) - { - sc->rec_result_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdadr(sc->code))) - { - s7_pointer laa1 = caddr(sc->code); - sc->rec_a1_o = sc->opts[sc->pc]; - if (bool_optimize(sc, laa1)) - { - sc->rec_a2_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdadr(laa1))) - { - sc->rec_a3_o = sc->opts[sc->pc]; - if (int_optimize(sc, cddadr(laa1))) - { - s7_pointer laa2 = cadr(cadddr(sc->code)), laa3 = caddr(laa2); - sc->rec_a4_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(laa2))) - { - sc->rec_a5_o = sc->opts[sc->pc]; - if (int_optimize(sc, cdr(laa3))) - { - sc->rec_a6_o = sc->opts[sc->pc]; - if (int_optimize(sc, cddr(laa3))) - { - sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(sc->rec_slot1))); - slot_set_value(sc->rec_slot1, sc->rec_val1); - sc->rec_val2 = make_mutable_integer(sc, integer(slot_value(sc->rec_slot2))); - slot_set_value(sc->rec_slot2, sc->rec_val2); - if (sc->pc != 8) - return(OPT_INT); - sc->rec_fb1 = sc->rec_test_o->v[0].fb; - sc->rec_fb2 = sc->rec_a1_o->v[0].fb; - sc->rec_fi1 = sc->rec_result_o->v[0].fi; - sc->rec_fi2 = sc->rec_a2_o->v[0].fi; - sc->rec_fi3 = sc->rec_a3_o->v[0].fi; - sc->rec_fi4 = sc->rec_a4_o->v[0].fi; - sc->rec_fi5 = sc->rec_a5_o->v[0].fi; - sc->rec_fi6 = sc->rec_a6_o->v[0].fi; - return(OPT_INT_0); - }}}}}}}}} + { + sc->rec_result_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdadr(sc->code))) + { + s7_pointer laa1 = caddr(sc->code); + sc->rec_a1_o = sc->opts[sc->pc]; + if (bool_optimize(sc, laa1)) + { + sc->rec_a2_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdadr(laa1))) + { + sc->rec_a3_o = sc->opts[sc->pc]; + if (int_optimize(sc, cddadr(laa1))) + { + s7_pointer laa2 = cadr(cadddr(sc->code)), laa3 = caddr(laa2); + sc->rec_a4_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(laa2))) + { + sc->rec_a5_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(laa3))) + { + sc->rec_a6_o = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(laa3))) + { + sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(sc->rec_slot1))); + slot_set_value(sc->rec_slot1, sc->rec_val1); + sc->rec_val2 = make_mutable_integer(sc, integer(slot_value(sc->rec_slot2))); + slot_set_value(sc->rec_slot2, sc->rec_val2); + if (sc->pc != 8) + return(OPT_INT); + sc->rec_fb1 = sc->rec_test_o->v[0].fb; + sc->rec_fb2 = sc->rec_a1_o->v[0].fb; + sc->rec_fi1 = sc->rec_result_o->v[0].fi; + sc->rec_fi2 = sc->rec_a2_o->v[0].fi; + sc->rec_fi3 = sc->rec_a3_o->v[0].fi; + sc->rec_fi4 = sc->rec_a4_o->v[0].fi; + sc->rec_fi5 = sc->rec_a5_o->v[0].fi; + sc->rec_fi6 = sc->rec_a6_o->v[0].fi; + return(OPT_INT_0); + }}}}}}}}} #endif rec_set_test(sc, cadr(sc->code)); rec_set_res(sc, cdadr(sc->code)); @@ -89135,11 +89135,11 @@ static bool op_s_g(s7_scheme *sc) static bool op_x_a(s7_scheme *sc, s7_pointer f) { if ((((type(f) == T_C_FUNCTION) && - (c_function_is_aritable(f, 1))) || + (c_function_is_aritable(f, 1))) || ((type(f) == T_C_RST_NO_REQ_FUNCTION) && - (c_function_max_args(f) >= 1) && - (f != initial_value(sc->hash_table_symbol)) && - (f != initial_value(sc->weak_hash_table_symbol)))) && + (c_function_max_args(f) >= 1) && + (f != initial_value(sc->hash_table_symbol)) && + (f != initial_value(sc->weak_hash_table_symbol)))) && (!needs_copied_args(f))) { sc->value = c_function_call(f)(sc, with_list_t1(fx_call(sc, cdr(sc->code)))); @@ -89161,8 +89161,8 @@ static bool op_x_a(s7_scheme *sc, s7_pointer f) sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code))); else { - sc->args = fx_call(sc, cdr(sc->code)); - sc->args = list_1(sc, sc->args); + sc->args = fx_call(sc, cdr(sc->code)); + sc->args = list_1(sc, sc->args); } sc->code = f; return(false); /* goto APPLY */ @@ -89172,13 +89172,13 @@ static bool op_x_sc(s7_scheme *sc, s7_pointer f) { s7_pointer code = sc->code; if (((type(f) == T_C_FUNCTION) && (c_function_is_aritable(f, 2))) || - ((type(f) == T_C_RST_NO_REQ_FUNCTION) && (c_function_max_args(f) >= 2))) + ((type(f) == T_C_RST_NO_REQ_FUNCTION) && (c_function_max_args(f) >= 2))) { /* ((L 'abs) x 0.0001) where 'abs is '* in timp.scm */ if (!needs_copied_args(f)) - { - sc->value = c_function_call(f)(sc, set_plist_2(sc, lookup_checked(sc, cadr(code)), caddr(code))); - return(true); - } + { + sc->value = c_function_call(f)(sc, set_plist_2(sc, lookup_checked(sc, cadr(code)), caddr(code))); + return(true); + } sc->args = list_2(sc, lookup_checked(sc, cadr(code)), caddr(code)); sc->code = f; return(false); /* goto APPLY */ @@ -89199,13 +89199,13 @@ static bool op_x_aa(s7_scheme *sc, s7_pointer f) { s7_pointer code = sc->code; if (((type(f) == T_C_FUNCTION) && (c_function_is_aritable(f, 2))) || - ((type(f) == T_C_RST_NO_REQ_FUNCTION) && (c_function_max_args(f) >= 2))) + ((type(f) == T_C_RST_NO_REQ_FUNCTION) && (c_function_max_args(f) >= 2))) { /* ((L 'abs) x 0.0001) where 'abs is '* in timp.scm */ if (!needs_copied_args(f)) - { - sc->value = c_function_call(f)(sc, with_list_t2(fx_call(sc, cdr(code)), fx_call(sc, cddr(code)))); - return(true); - } + { + sc->value = c_function_call(f)(sc, with_list_t2(fx_call(sc, cdr(code)), fx_call(sc, cddr(code)))); + return(true); + } sc->args = fx_call(sc, cddr(code)); sc->args = list_2(sc, sc->value = fx_call(sc, cdr(code)), sc->args); sc->code = f; @@ -89219,7 +89219,7 @@ static bool op_x_aa(s7_scheme *sc, s7_pointer f) { sc->args = fx_call(sc, cddr(code)); if (!needs_copied_args(f)) - sc->args = set_plist_2(sc, fx_call(sc, cdr(code)), sc->args); + sc->args = set_plist_2(sc, fx_call(sc, cdr(code)), sc->args); else sc->args = list_2(sc, sc->value = fx_call(sc, cdr(code)), sc->args); } sc->code = f; @@ -89264,7 +89264,7 @@ static void op_safe_c_star_a(s7_scheme *sc) sc->args = fx_call(sc, cdr(sc->code)); if (is_symbol_and_keyword(sc->args)) /* (blocks3 (car (list :asdf))) */ error_nr(sc, sc->syntax_error_symbol, - set_elist_4(sc, wrap_string(sc, "~A: keyword ~S, but no value: ~S", 32), car(sc->code), sc->args, sc->code)); + set_elist_4(sc, wrap_string(sc, "~A: keyword ~S, but no value: ~S", 32), car(sc->code), sc->args, sc->code)); /* scheme-level define* here also gives "not a parameter name" */ sc->args = list_1(sc, sc->args); sc->code = opt1_cfunc(sc->code); @@ -89549,9 +89549,9 @@ static Inline bool inline_collect_np_args(s7_scheme *sc, opcode_t op, s7_pointer sc->args = cons(sc, sc->value = fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */ else { - push_stack(sc, op, sc->args, cdr(p)); - sc->code = T_Pair(car(p)); - return(true); + push_stack(sc, op, sc->args, cdr(p)); + sc->code = T_Pair(car(p)); + return(true); } return(false); } @@ -89566,13 +89566,13 @@ static /* inline */ bool op_any_c_np(s7_scheme *sc) /* code: (func . args) where sc->args = cons(sc, sc->value = fx_call(sc, p), sc->args); /* reversed before apply in OP_ANY_C_NP_1 */ else { - if (sc->op_stack_now >= sc->op_stack_end) - resize_op_stack(sc); - push_op_stack(sc, sc->code); - check_stack_size(sc); - push_stack(sc, ((intptr_t)((is_pair(cdr(p))) ? OP_ANY_C_NP_1 : OP_ANY_C_NP_2)), sc->args, cdr(p)); - sc->code = T_Pair(car(p)); - return(true); + if (sc->op_stack_now >= sc->op_stack_end) + resize_op_stack(sc); + push_op_stack(sc, sc->code); + check_stack_size(sc); + push_stack(sc, ((intptr_t)((is_pair(cdr(p))) ? OP_ANY_C_NP_1 : OP_ANY_C_NP_2)), sc->args, cdr(p)); + sc->code = T_Pair(car(p)); + return(true); } sc->args = proper_list_reverse_in_place(sc, sc->args); sc->value = fn_proc(sc->code)(sc, sc->args); @@ -89620,7 +89620,7 @@ static void op_any_closure_np(s7_scheme *sc) sc->args = fx_call(sc, p); sc->args = list_1(sc, sc->args); for (p = cdr(p); (is_pair(p)) && (has_fx(p)); p = cdr(p)) - sc->args = cons_unchecked(sc, fx_call(sc, p), sc->args); + sc->args = cons_unchecked(sc, fx_call(sc, p), sc->args); } else sc->args = sc->nil; push_stack(sc, ((intptr_t)((is_pair(cdr(p))) ? OP_ANY_CLOSURE_NP_1 : OP_ANY_CLOSURE_NP_2)), sc->args, cdr(p)); @@ -89642,13 +89642,13 @@ static void op_any_closure_np_end(s7_scheme *sc) set_curlet(sc, closure_let(f)); let_set_id(sc->curlet, id); for (x = let_slots(sc->curlet), z = sc->args; tis_slot(x); x = next_slot(x), z = cdr(z)) - { - slot_set_value(x, car(z)); - symbol_set_local_slot(slot_symbol(x), id, x); - /* don't free sc->args -- it might be needed in the error below */ - } + { + slot_set_value(x, car(z)); + symbol_set_local_slot(slot_symbol(x), id, x); + /* don't free sc->args -- it might be needed in the error below */ + } if (tis_slot(x)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); } else { @@ -89661,11 +89661,11 @@ static void op_any_closure_np_end(s7_scheme *sc) let_set_slots(e, last_slot); symbol_set_local_slot(car(p), id, last_slot); for (p = cdr(p), z = cdr(sc->args); is_pair(p); p = cdr(p), z = cdr(z)) - last_slot = inline_add_slot_at_end(sc, id, last_slot, car(p), car(z)); /* sets last_slot, don't free sc->args -- used below */ + last_slot = inline_add_slot_at_end(sc, id, last_slot, car(p), car(z)); /* sets last_slot, don't free sc->args -- used below */ set_curlet(sc, e); sc->z = sc->unused; if (is_pair(p)) - error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); } if (is_pair(z)) /* these checks are needed because multiple-values might evade earlier arg num checks */ error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->code, sc->args)); @@ -89866,16 +89866,16 @@ static bool eval_args_no_eval_args(s7_scheme *sc) if (is_any_macro(sc->value)) { if (!s7_is_proper_list(sc, cdr(sc->code))) - error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "improper list of arguments: ~S", 30), sc->code)); + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "improper list of arguments: ~S", 30), sc->code)); sc->args = cdr(sc->code); if (is_symbol(car(sc->code))) /* not ((f p) args...) where (f p) has returned a macro, op_macro_d assumes car is a symbol */ - { - if (is_macro(sc->value)) - set_optimize_op(sc->code, fixup_macro_d(sc, OP_MACRO_D, sc->value)); - else - if (is_macro_star(sc->value)) - set_optimize_op(sc->code, fixup_macro_d(sc, OP_MACRO_STAR_D, sc->value)); - } + { + if (is_macro(sc->value)) + set_optimize_op(sc->code, fixup_macro_d(sc, OP_MACRO_D, sc->value)); + else + if (is_macro_star(sc->value)) + set_optimize_op(sc->code, fixup_macro_d(sc, OP_MACRO_STAR_D, sc->value)); + } sc->code = sc->value; return(true); } @@ -89885,8 +89885,8 @@ static bool eval_args_no_eval_args(s7_scheme *sc) { sc->cur_op = syntax_opcode(sc->value); if ((is_symbol(car(sc->code))) && /* don't opt pair to syntax op if sc->value is actually an arg not the op! ((write and)) should not be op_and */ - ((car(sc->code) == syntax_symbol(sc->value)) || (lookup_global(sc, car(sc->code)) == sc->value))) - pair_set_syntax_op(sc->code, sc->cur_op); + ((car(sc->code) == syntax_symbol(sc->value)) || (lookup_global(sc, car(sc->code)) == sc->value))) + pair_set_syntax_op(sc->code, sc->cur_op); /* weird that sc->cur_op setting above seems ok, but OP_PAIR_PAIR hangs?? */ } return(false); @@ -89905,11 +89905,11 @@ static s7_pointer unbound_last_arg(s7_scheme *sc, s7_pointer car_code) sc->w = (is_null(sc->args)) ? list_1(sc, car_code) : proper_list_reverse_in_place(sc, cons(sc, car_code, args)); sc->w = cons_unchecked(sc, ops, sc->w); error_nr(sc, sc->unbound_variable_symbol, - (probably_in_repl) ? - set_elist_3(sc, wrap_string(sc, "'~S is unbound in ~S", 20), car_code, sc->w) : - set_elist_5(sc, wrap_string(sc, "'~S is unbound in ~S (~A[~D])", 29), car_code, sc->w, - sc->file_names[location_to_file(loc)], - wrap_integer(sc, location_to_line(loc)))); + (probably_in_repl) ? + set_elist_3(sc, wrap_string(sc, "'~S is unbound in ~S", 20), car_code, sc->w) : + set_elist_5(sc, wrap_string(sc, "'~S is unbound in ~S (~A[~D])", 29), car_code, sc->w, + sc->file_names[location_to_file(loc)], + wrap_integer(sc, location_to_line(loc)))); } return(val); } @@ -89944,10 +89944,10 @@ static s7_pointer unbound_args_last_arg(s7_scheme *sc, s7_pointer car_code) sc->w = cons_unchecked(sc, car_code, sc->w); sc->w = cons_unchecked(sc, ops, proper_list_reverse_in_place(sc, sc->w)); error_nr(sc, sc->unbound_variable_symbol, - (probably_in_repl) ? - set_elist_3(sc, wrap_string(sc, "'~S is unbound in ~S", 20), car_code, sc->w) : - set_elist_5(sc, wrap_string(sc, "'~S is unbound in ~S (~A[~D])", 29), car_code, sc->w, - sc->file_names[location_to_file(loc)], wrap_integer(sc, location_to_line(loc)))); + (probably_in_repl) ? + set_elist_3(sc, wrap_string(sc, "'~S is unbound in ~S", 20), car_code, sc->w) : + set_elist_5(sc, wrap_string(sc, "'~S is unbound in ~S (~A[~D])", 29), car_code, sc->w, + sc->file_names[location_to_file(loc)], wrap_integer(sc, location_to_line(loc)))); } return(val); } @@ -89959,7 +89959,7 @@ static /* inline */ bool eval_args_last_arg(s7_scheme *sc) /* inline: no diff tm if (is_pair(car_code)) { if (sc->stack_end >= sc->stack_resize_trigger) - check_for_cyclic_code(sc, sc->code); + check_for_cyclic_code(sc, sc->code); push_stack(sc, OP_EVAL_ARGS5, sc->args, sc->value); sc->code = car_code; return(true); @@ -89987,10 +89987,10 @@ static inline void eval_args_pair_car(s7_scheme *sc) else { if (!is_pair(code)) /* (= 0 '(1 . 2) . 3) */ - improper_arglist_error_nr(sc); + improper_arglist_error_nr(sc); if ((is_null(cdr(code))) && - (!is_pair(car(code)))) - push_stack(sc, OP_EVAL_ARGS3, sc->args, car(code)); + (!is_pair(car(code)))) + push_stack(sc, OP_EVAL_ARGS3, sc->args, car(code)); else push_stack(sc, OP_EVAL_ARGS4, sc->args, code); } sc->code = car(sc->code); @@ -90008,66 +90008,66 @@ static bool eval_car_pair(s7_scheme *sc) /* was checking for is_syntactic (pair or symbol) here but that can be confused by successive optimizer passes: (define (hi) (((lambda () list)) 1 2 3)) etc */ { if (!no_int_opt(code)) - { - /* lambda */ - if ((car(carc) == sc->lambda_symbol) && /* ((lambda ...) expr) */ - (is_pair(cddr(carc))) && (s7_is_proper_list(sc, cddr(carc)))) /* not dotted! */ - { - set_opt3_pair(code, cddr(carc)); /* lambda body */ - if ((is_null(cadr(carc))) && (is_null(cdr(code)))) - { - set_optimize_op(code, OP_F); /* ((lambda () ...)) */ - return(false); - } - if (is_pair(cadr(carc))) - { - if ((is_normal_symbol(caadr(carc))) && (!is_constant(sc, caadr(carc))) && - (is_pair(cdr(code))) && (is_fxable(sc, cadr(code)))) - { - set_opt3_sym(cdr(code), caadr(carc)); /* new curlet symbol #1 (first arg of lambda) */ - if ((is_null(cdadr(carc))) && (is_null(cddr(code)))) - { - fx_annotate_args(sc, cdr(code), sc->curlet); /* ((lambda (x) ...) expr) */ - set_optimize_op(code, OP_F_A); - return(false); - } - if ((is_pair(cdadr(carc))) && (is_pair(cddr(code))) && (is_fxable(sc, caddr(code))) && - (is_null(cddadr(carc))) && (is_null(cdddr(code))) && - (is_normal_symbol(cadadr(carc))) && (!is_constant(sc, cadadr(carc))) && (caadr(carc) != cadadr(carc))) - { - fx_annotate_args(sc, cdr(code), sc->curlet); - set_optimize_op(code, OP_F_AA); /* ((lambda (x y) ...) expr exor) */ - return(false); - }} - set_optimize_op(code, OP_F_NP); - }} - set_no_int_opt(code); - } + { + /* lambda */ + if ((car(carc) == sc->lambda_symbol) && /* ((lambda ...) expr) */ + (is_pair(cddr(carc))) && (s7_is_proper_list(sc, cddr(carc)))) /* not dotted! */ + { + set_opt3_pair(code, cddr(carc)); /* lambda body */ + if ((is_null(cadr(carc))) && (is_null(cdr(code)))) + { + set_optimize_op(code, OP_F); /* ((lambda () ...)) */ + return(false); + } + if (is_pair(cadr(carc))) + { + if ((is_normal_symbol(caadr(carc))) && (!is_constant(sc, caadr(carc))) && + (is_pair(cdr(code))) && (is_fxable(sc, cadr(code)))) + { + set_opt3_sym(cdr(code), caadr(carc)); /* new curlet symbol #1 (first arg of lambda) */ + if ((is_null(cdadr(carc))) && (is_null(cddr(code)))) + { + fx_annotate_args(sc, cdr(code), sc->curlet); /* ((lambda (x) ...) expr) */ + set_optimize_op(code, OP_F_A); + return(false); + } + if ((is_pair(cdadr(carc))) && (is_pair(cddr(code))) && (is_fxable(sc, caddr(code))) && + (is_null(cddadr(carc))) && (is_null(cdddr(code))) && + (is_normal_symbol(cadadr(carc))) && (!is_constant(sc, cadadr(carc))) && (caadr(carc) != cadadr(carc))) + { + fx_annotate_args(sc, cdr(code), sc->curlet); + set_optimize_op(code, OP_F_AA); /* ((lambda (x y) ...) expr exor) */ + return(false); + }} + set_optimize_op(code, OP_F_NP); + }} + set_no_int_opt(code); + } /* ((if op1 op2) args...) is another somewhat common case */ push_stack_no_args(sc, OP_EVAL_ARGS, code); sc->code = carc; if (!no_cell_opt(carc)) - { - /* if */ - if ((car(carc) == sc->if_symbol) && - (is_pair(cdr(code))) && /* check that we got one or two args */ - ((is_null(cddr(code))) || - ((is_pair(cddr(code))) && (is_null(cdddr(code)))))) - { - check_if(sc, carc); - if ((fx_function[optimize_op(carc)]) && - (is_fxable(sc, cadr(code))) && - ((is_null(cddr(code))) || (is_fxable(sc, caddr(code))))) /* checked cdddr above */ - { - fx_annotate_args(sc, cdr(code), sc->curlet); - set_fx_direct(code, fx_function[optimize_op(carc)]); - if (is_null(cddr(code))) - set_optimize_op(code, OP_A_A); - else set_optimize_op(code, ((is_symbol(cadr(code))) && (!is_pair(caddr(code))) && (!is_normal_symbol(caddr(code)))) ? OP_A_SC : OP_A_AA); - return(false); /* goto eval in trailers */ - }} - set_no_cell_opt(carc); - } + { + /* if */ + if ((car(carc) == sc->if_symbol) && + (is_pair(cdr(code))) && /* check that we got one or two args */ + ((is_null(cddr(code))) || + ((is_pair(cddr(code))) && (is_null(cdddr(code)))))) + { + check_if(sc, carc); + if ((fx_function[optimize_op(carc)]) && + (is_fxable(sc, cadr(code))) && + ((is_null(cddr(code))) || (is_fxable(sc, caddr(code))))) /* checked cdddr above */ + { + fx_annotate_args(sc, cdr(code), sc->curlet); + set_fx_direct(code, fx_function[optimize_op(carc)]); + if (is_null(cddr(code))) + set_optimize_op(code, OP_A_A); + else set_optimize_op(code, ((is_symbol(cadr(code))) && (!is_pair(caddr(code))) && (!is_normal_symbol(caddr(code)))) ? OP_A_SC : OP_A_AA); + return(false); /* goto eval in trailers */ + }} + set_no_cell_opt(carc); + } sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); pair_set_syntax_op(sc->code, sc->cur_op); return(true); @@ -90077,23 +90077,23 @@ static bool eval_car_pair(s7_scheme *sc) if ((is_pair(cdr(code))) && (is_optimized(carc))) { if ((fx_function[optimize_op(carc)]) && - (is_fxable(sc, cadr(code))) && - ((is_null(cddr(code))) || - ((is_fxable(sc, caddr(code))) && (is_null(cdddr(code)))))) - { - fx_annotate_args(sc, cdr(code), sc->curlet); - set_fx_direct(code, fx_function[optimize_op(carc)]); - if (is_null(cddr(code))) - set_optimize_op(code, OP_A_A); - else set_optimize_op(code, ((is_symbol(cadr(code))) && (!is_pair(caddr(code))) && (!is_normal_symbol(caddr(code)))) ? OP_A_SC : OP_A_AA); - sc->code = carc; - return(false); /* goto eval in trailers */ - } + (is_fxable(sc, cadr(code))) && + ((is_null(cddr(code))) || + ((is_fxable(sc, caddr(code))) && (is_null(cdddr(code)))))) + { + fx_annotate_args(sc, cdr(code), sc->curlet); + set_fx_direct(code, fx_function[optimize_op(carc)]); + if (is_null(cddr(code))) + set_optimize_op(code, OP_A_A); + else set_optimize_op(code, ((is_symbol(cadr(code))) && (!is_pair(caddr(code))) && (!is_normal_symbol(caddr(code)))) ? OP_A_SC : OP_A_AA); + sc->code = carc; + return(false); /* goto eval in trailers */ + } if ((is_null(cddr(code))) && (is_symbol(cadr(code)))) - { - set_optimize_op(code, OP_P_S); - set_opt3_sym(code, cadr(code)); - } + { + set_optimize_op(code, OP_P_S); + set_opt3_sym(code, cadr(code)); + } /* possible op OP_P_ALL_A runs into opt2 fx overwrites in a case like ((values set!) x 32) */ else set_optimize_op(code, OP_PAIR_PAIR); } @@ -90112,28 +90112,28 @@ static goto_t trailers(s7_scheme *sc) { s7_pointer carc = T_Ext(car(code)); if (is_symbol(carc)) - { - /* car is a symbol, sc->code a list */ - if (is_syntactic_symbol(carc)) - { - sc->cur_op = (opcode_t)symbol_syntax_op_checked(code); - pair_set_syntax_op(sc->code, sc->cur_op); - return(goto_top_no_pop); - } - sc->value = lookup_global(sc, carc); - set_optimize_op(code, OP_PAIR_SYM); /* mostly stuff outside functions (unopt) */ - return(goto_eval_args_top); - } + { + /* car is a symbol, sc->code a list */ + if (is_syntactic_symbol(carc)) + { + sc->cur_op = (opcode_t)symbol_syntax_op_checked(code); + pair_set_syntax_op(sc->code, sc->cur_op); + return(goto_top_no_pop); + } + sc->value = lookup_global(sc, carc); + set_optimize_op(code, OP_PAIR_SYM); /* mostly stuff outside functions (unopt) */ + return(goto_eval_args_top); + } if (is_pair(carc)) /* ((if x y z) a b) etc */ - return((eval_car_pair(sc)) ? goto_top_no_pop : goto_eval); + return((eval_car_pair(sc)) ? goto_top_no_pop : goto_eval); /* here we can get syntax objects like quote */ if (is_syntax(carc)) - { - sc->cur_op = syntax_opcode(carc); - pair_set_syntax_op(sc->code, sc->cur_op); - return(goto_top_no_pop); - } + { + sc->cur_op = syntax_opcode(carc); + pair_set_syntax_op(sc->code, sc->cur_op); + return(goto_top_no_pop); + } /* car must be the function to be applied, or (for example) a syntax variable like quote that has been used locally */ set_optimize_op(code, OP_PAIR_ANY); /* usually an error: (#\a) etc, might be (#(0) 0) */ sc->value = carc; @@ -90185,18 +90185,18 @@ static token_t read_block_comment(s7_scheme *sc, s7_pointer pt) { char last_char = ' '; while (true) - { - int32_t c = fgetc(port_file(pt)); - if (c == EOF) - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #|", 40))); - if ((c == '#') && - (last_char == '|')) - break; - last_char = c; - if (c == '\n') - port_line_number(pt)++; - } + { + int32_t c = fgetc(port_file(pt)); + if (c == EOF) + error_nr(sc, sc->read_error_symbol, + set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #|", 40))); + if ((c == '#') && + (last_char == '|')) + break; + last_char = c; + if (c == '\n') + port_line_number(pt)++; + } return(token(sc)); } orig_str = (const char *)(port_data(pt) + port_position(pt)); @@ -90206,13 +90206,13 @@ static token_t read_block_comment(s7_scheme *sc, s7_pointer pt) { p = strchr(str, (int)'|'); if ((!p) || (p >= pend)) - { - port_position(pt) = port_data_size(pt); - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #|", 40))); - } + { + port_position(pt) = port_data_size(pt); + error_nr(sc, sc->read_error_symbol, + set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #|", 40))); + } if (p[1] == '#') - break; + break; str = (const char *)(p + 1); } port_position(pt) += (p - orig_str + 2); @@ -90223,10 +90223,10 @@ static token_t read_block_comment(s7_scheme *sc, s7_pointer pt) { p = strchr(str, (int)'\n'); if ((p) && (p < pend)) - { - port_line_number(pt)++; - str = (const char *)(p + 1); - } + { + port_line_number(pt)++; + str = (const char *)(p + 1); + } else break; } return(token(sc)); @@ -90248,20 +90248,20 @@ static token_t read_excl_comment(s7_scheme *sc, s7_pointer pt) for (s7_pointer reader = slot_value(sc->sharp_readers); is_pair(reader); reader = cdr(reader)) if (s7_character(caar(reader)) == '!') { - sc->strbuf[0] = (unsigned char)'!'; - return(TOKEN_SHARP_CONST); /* next stage notices any errors */ + sc->strbuf[0] = (unsigned char)'!'; + return(TOKEN_SHARP_CONST); /* next stage notices any errors */ } /* not #! as block comment (for Guile I guess) */ while ((c = inchar(pt)) != EOF) { if ((c == '#') && - (last_char == '!')) - break; + (last_char == '!')) + break; last_char = c; } if (c == EOF) error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #!", 40))); + set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #!", 40))); return(token(sc)); } @@ -90280,93 +90280,93 @@ static token_t read_sharp(s7_scheme *sc, s7_pointer pt) case 'i': /* #i(...) */ if (read_sharp(sc, pt) == TOKEN_VECTOR) - return(TOKEN_INT_VECTOR); + return(TOKEN_INT_VECTOR); backchar('i', pt); break; case 'r': /* #r(...) */ if (read_sharp(sc, pt) == TOKEN_VECTOR) - return(TOKEN_FLOAT_VECTOR); + return(TOKEN_FLOAT_VECTOR); backchar('r', pt); break; case 'u': /* #u(...) or #u8(...) */ if (s7_peek_char(sc, pt) == chars[(int32_t)('8')]) /* backwards compatibility: #u8(...) == #u(...) */ - { - int32_t bc = inchar(pt); - if (s7_peek_char(sc, pt) == chars[(int32_t)('(')]) - { - inchar(pt); - sc->w = int_one; - return(TOKEN_BYTE_VECTOR); - } - backchar(bc, pt); - } + { + int32_t bc = inchar(pt); + if (s7_peek_char(sc, pt) == chars[(int32_t)('(')]) + { + inchar(pt); + sc->w = int_one; + return(TOKEN_BYTE_VECTOR); + } + backchar(bc, pt); + } if (read_sharp(sc, pt) == TOKEN_VECTOR) - return(TOKEN_BYTE_VECTOR); + return(TOKEN_BYTE_VECTOR); backchar('u', pt); break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { - /* here we can get an overflow: #1231231231231232131D() */ - s7_int dims = digits[c]; - int32_t d = 0, loc = 0; - - sc->strbuf[loc++] = (unsigned char)c; - while (true) - { - s7_int dig; - d = inchar(pt); - if (d == EOF) - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #n...", 43))); - dig = digits[d]; - if (dig >= 10) break; - dims = dig + (dims * 10); - if (dims <= 0) - { - sc->strbuf[loc++] = (unsigned char)d; - error_nr(sc, sc->read_error_symbol, - set_elist_3(sc, wrap_string(sc, "reading #~A...: ~D must be a positive integer", 45), - wrap_string(sc, sc->strbuf, loc), - wrap_integer(sc, dims))); - } - if (dims > sc->max_vector_dimensions) - { - sc->strbuf[loc++] = (unsigned char)d; - sc->strbuf[loc + 1] = '\0'; - error_nr(sc, sc->read_error_symbol, - set_elist_4(sc, wrap_string(sc, "reading #~A...: ~D is too large, (*s7* 'max-vector-dimensions): ~D", 66), - wrap_string(sc, sc->strbuf, loc), - wrap_integer(sc, dims), wrap_integer(sc, sc->max_vector_dimensions))); - } - sc->strbuf[loc++] = (unsigned char)d; - } - sc->strbuf[loc++] = d; - if ((d == 'd') || (d == 'i') || (d == 'r') || (d == 'u')) - { - int32_t e = inchar(pt); - if (e == EOF) - error_nr(sc, sc->read_error_symbol, - set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #n()", 42))); - sc->strbuf[loc++] = (unsigned char)e; - if (e == '(') - { - sc->w = make_integer(sc, dims); - if (d == 'd') return(TOKEN_VECTOR); - if (d == 'r') return(TOKEN_FLOAT_VECTOR); - return((d == 'u') ? TOKEN_BYTE_VECTOR : TOKEN_INT_VECTOR); - }} - /* try to back out */ - for (d = loc - 1; d > 0; d--) - backchar(sc->strbuf[d], pt); + /* here we can get an overflow: #1231231231231232131D() */ + s7_int dims = digits[c]; + int32_t d = 0, loc = 0; + + sc->strbuf[loc++] = (unsigned char)c; + while (true) + { + s7_int dig; + d = inchar(pt); + if (d == EOF) + error_nr(sc, sc->read_error_symbol, + set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #n...", 43))); + dig = digits[d]; + if (dig >= 10) break; + dims = dig + (dims * 10); + if (dims <= 0) + { + sc->strbuf[loc++] = (unsigned char)d; + error_nr(sc, sc->read_error_symbol, + set_elist_3(sc, wrap_string(sc, "reading #~A...: ~D must be a positive integer", 45), + wrap_string(sc, sc->strbuf, loc), + wrap_integer(sc, dims))); + } + if (dims > sc->max_vector_dimensions) + { + sc->strbuf[loc++] = (unsigned char)d; + sc->strbuf[loc + 1] = '\0'; + error_nr(sc, sc->read_error_symbol, + set_elist_4(sc, wrap_string(sc, "reading #~A...: ~D is too large, (*s7* 'max-vector-dimensions): ~D", 66), + wrap_string(sc, sc->strbuf, loc), + wrap_integer(sc, dims), wrap_integer(sc, sc->max_vector_dimensions))); + } + sc->strbuf[loc++] = (unsigned char)d; + } + sc->strbuf[loc++] = d; + if ((d == 'd') || (d == 'i') || (d == 'r') || (d == 'u')) + { + int32_t e = inchar(pt); + if (e == EOF) + error_nr(sc, sc->read_error_symbol, + set_elist_1(sc, wrap_string(sc, "unexpected end of input while reading #n()", 42))); + sc->strbuf[loc++] = (unsigned char)e; + if (e == '(') + { + sc->w = make_integer(sc, dims); + if (d == 'd') return(TOKEN_VECTOR); + if (d == 'r') return(TOKEN_FLOAT_VECTOR); + return((d == 'u') ? TOKEN_BYTE_VECTOR : TOKEN_INT_VECTOR); + }} + /* try to back out */ + for (d = loc - 1; d > 0; d--) + backchar(sc->strbuf[d], pt); } break; case ':': /* turn #: into : -- this is for compatibility with Guile, sigh. I just noticed that Rick is using this -- - * I'll just leave it alone, but that means : readers need to handle this case specially. - */ + * I'll just leave it alone, but that means : readers need to handle this case specially. + */ sc->strbuf[0] = ':'; return(TOKEN_ATOM); @@ -90407,7 +90407,7 @@ static token_t read_dot(s7_scheme *sc, s7_pointer pt) { backchar(c, pt); if ((!char_ok_in_a_name[c]) && (c != 0)) - return(TOKEN_DOT); + return(TOKEN_DOT); } else { @@ -90449,58 +90449,58 @@ static int32_t read_x_char(s7_scheme *sc, int32_t i, s7_pointer pt) { int32_t d1, d2, c = inchar(pt); if (c == '"') /* "\x" -> error, "\x44" or "\x44;" -> #\D */ - { - if (c_ctr == 0) /* "\x" */ - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - backchar(c, pt); /* "\x44" I think -- not sure about this -- Guile is happy but I think it contradicts r7rs.pdf */ - return(i); - } + { + if (c_ctr == 0) /* "\x" */ + read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); + backchar(c, pt); /* "\x44" I think -- not sure about this -- Guile is happy but I think it contradicts r7rs.pdf */ + return(i); + } if (c == ';') - { - if (c_ctr == 0) /* "\x;" */ - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - return(i); /* "\x44;" */ - } + { + if (c_ctr == 0) /* "\x;" */ + read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); + return(i); /* "\x44;" */ + } if (c == EOF) /* "\x<eof> */ - { - read_error_nr(sc, "#<eof> in midst of hex-char"); - return(i); - } + { + read_error_nr(sc, "#<eof> in midst of hex-char"); + return(i); + } d1 = digits[c]; if (d1 >= 16) /* "\x4H", also "\x44H" which Guile thinks is ok -- it apparently reads 2 digits and quits? */ - { - if (c_ctr == 0) - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - backchar(c, pt); - return(i); - } + { + if (c_ctr == 0) + read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); + backchar(c, pt); + return(i); + } /* perhaps if c_ctr==0 error else backchar + return(i??) */ c = inchar(pt); if (c == '"') /* "\x4" */ - { - sc->strbuf[i++] = (unsigned char)d1; - backchar((char)c, pt); - return(i); - } + { + sc->strbuf[i++] = (unsigned char)d1; + backchar((char)c, pt); + return(i); + } if (c == ';') /* "\x4;" */ - { - sc->strbuf[i++] = (unsigned char)d1; - return(i); - } + { + sc->strbuf[i++] = (unsigned char)d1; + return(i); + } if (c == EOF) /* "\x4<eof */ - { - read_error_nr(sc, "#<eof> in midst of hex-char"); - return(i); - } + { + read_error_nr(sc, "#<eof> in midst of hex-char"); + return(i); + } d2 = digits[c]; if (d2 >= 16) - { - if (c_ctr == 0) - read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); - backchar(c, pt); - return(i); - } + { + if (c_ctr == 0) + read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?"); + backchar(c, pt); + return(i); + } sc->strbuf[i++] = (unsigned char)(16 * d1 + d2); } return(i); @@ -90513,7 +90513,7 @@ static s7_pointer unknown_string_constant(s7_scheme *sc, int32_t c) { s7_pointer result = s7_call(sc, sc->read_error_hook, set_plist_2(sc, sc->F, chars[(uint8_t)c])); if (is_character(result)) - return(result); + return(result); } return(sc->T); } @@ -90528,116 +90528,116 @@ static s7_pointer read_string_constant(s7_scheme *sc, s7_pointer pt) /* try the most common case first */ char *s, *end, *start = (char *)(port_data(pt) + port_position(pt)); if (*start == '"') - { - port_position(pt)++; - return(nil_string); - } + { + port_position(pt)++; + return(nil_string); + } end = (char *)(port_data(pt) + port_data_size(pt)); s = strpbrk(start, "\"\n\\"); if ((!s) || (s >= end)) /* can this read a huge string constant from a file? */ - { - if (start == end) - sc->strbuf[0] = '\0'; - else memcpy((void *)(sc->strbuf), (void *)start, (end - start > 8) ? 8 : (end - start)); - sc->strbuf[8] = '\0'; - return(sc->F); - } + { + if (start == end) + sc->strbuf[0] = '\0'; + else memcpy((void *)(sc->strbuf), (void *)start, (end - start > 8) ? 8 : (end - start)); + sc->strbuf[8] = '\0'; + return(sc->F); + } if (*s == '"') - { - s7_int len = s - start; - port_position(pt) += (len + 1); - return(make_string_with_length(sc, start, len)); - } + { + s7_int len = s - start; + port_position(pt) += (len + 1); + return(make_string_with_length(sc, start, len)); + } for (; s < end; s++) - { - if (*s == '"') /* switch here no faster */ - { - s7_int len = s - start; - port_position(pt) += (len + 1); - return(make_string_with_length(sc, start, len)); - } - if (*s == '\\') - { - /* all kinds of special cases here (resultant string is not the current string), so drop to loop below (setting "i") */ - s7_int len = (s7_int)(s - start); - if (len > 0) - { - if (len >= sc->strbuf_size) - resize_strbuf(sc, len); - memcpy((void *)(sc->strbuf), (void *)(port_data(pt) + port_position(pt)), len); - port_position(pt) += len; - } - i = len; - break; - } - else - if (*s == '\n') - port_line_number(pt)++; - }} + { + if (*s == '"') /* switch here no faster */ + { + s7_int len = s - start; + port_position(pt) += (len + 1); + return(make_string_with_length(sc, start, len)); + } + if (*s == '\\') + { + /* all kinds of special cases here (resultant string is not the current string), so drop to loop below (setting "i") */ + s7_int len = (s7_int)(s - start); + if (len > 0) + { + if (len >= sc->strbuf_size) + resize_strbuf(sc, len); + memcpy((void *)(sc->strbuf), (void *)(port_data(pt) + port_position(pt)), len); + port_position(pt) += len; + } + i = len; + break; + } + else + if (*s == '\n') + port_line_number(pt)++; + }} while (true) { /* splitting this check out and duplicating the loop was slower?!? */ int32_t c = port_read_character(pt)(sc, pt); switch (c) - { - case '\n': - port_line_number(pt)++; - sc->strbuf[i++] = (unsigned char)c; - break; - - case EOF: - sc->strbuf[(i > 8) ? 8 : i] = '\0'; - return(sc->F); - - case '"': - return(make_string_with_length(sc, sc->strbuf, i)); - - case '\\': - c = inchar(pt); - switch (c) - { - case EOF: - sc->strbuf[(i > 8) ? 8 : i] = '\0'; - return(sc->F); - - case '\\': case '"': case '|': - sc->strbuf[i++] = (unsigned char)c; + { + case '\n': + port_line_number(pt)++; + sc->strbuf[i++] = (unsigned char)c; + break; + + case EOF: + sc->strbuf[(i > 8) ? 8 : i] = '\0'; + return(sc->F); + + case '"': + return(make_string_with_length(sc, sc->strbuf, i)); + + case '\\': + c = inchar(pt); + switch (c) + { + case EOF: + sc->strbuf[(i > 8) ? 8 : i] = '\0'; + return(sc->F); + + case '\\': case '"': case '|': + sc->strbuf[i++] = (unsigned char)c; break; - case 'n': sc->strbuf[i++] = '\n'; break; - case 't': sc->strbuf[i++] = '\t'; break; - case 'r': sc->strbuf[i++] = '\r'; break; - case '/': sc->strbuf[i++] = '/'; break; - case 'b': sc->strbuf[i++] = (unsigned char)8; break; - case 'f': sc->strbuf[i++] = (unsigned char)12; break; + case 'n': sc->strbuf[i++] = '\n'; break; + case 't': sc->strbuf[i++] = '\t'; break; + case 'r': sc->strbuf[i++] = '\r'; break; + case '/': sc->strbuf[i++] = '/'; break; + case 'b': sc->strbuf[i++] = (unsigned char)8; break; + case 'f': sc->strbuf[i++] = (unsigned char)12; break; - case 'x': - i = read_x_char(sc, i, pt); + case 'x': + i = read_x_char(sc, i, pt); break; - default: /* if (!is_white_space(c)) */ /* changed 8-Apr-12 */ - if ((c != '\n') && (c != '\r')) /* i.e. line continuation via #\\ at end of line */ - { - s7_pointer result = unknown_string_constant(sc, c); - if (!is_character(result)) return(result); - sc->strbuf[i++] = character(result); - } - /* #f here would give confusing error message "end of input", so return #t=bad backslash. - * this is not optimal. It's easy to forget that backslash needs to be backslashed. - * the white_space business half-implements Scheme's \<newline>...<eol>... or \<space>...<eol>... - * feature -- the characters after \ are flushed if they're all white space and include a newline. - * (string->number "1\ 2") is 12?? Too bizarre. - */ - } - break; - - default: - sc->strbuf[i++] = (unsigned char)c; - break; - } + default: /* if (!is_white_space(c)) */ /* changed 8-Apr-12 */ + if ((c != '\n') && (c != '\r')) /* i.e. line continuation via #\\ at end of line */ + { + s7_pointer result = unknown_string_constant(sc, c); + if (!is_character(result)) return(result); + sc->strbuf[i++] = character(result); + } + /* #f here would give confusing error message "end of input", so return #t=bad backslash. + * this is not optimal. It's easy to forget that backslash needs to be backslashed. + * the white_space business half-implements Scheme's \<newline>...<eol>... or \<space>...<eol>... + * feature -- the characters after \ are flushed if they're all white space and include a newline. + * (string->number "1\ 2") is 12?? Too bizarre. + */ + } + break; + + default: + sc->strbuf[i++] = (unsigned char)c; + break; + } if (i >= sc->strbuf_size) - resize_strbuf(sc, i); + resize_strbuf(sc, i); } } @@ -90694,94 +90694,94 @@ static s7_pointer read_expression(s7_scheme *sc) while (true) { switch (sc->tok) - { - case TOKEN_EOF: - return(eof_object); - - case TOKEN_BYTE_VECTOR: - push_stack_no_let_no_code(sc, OP_READ_BYTE_VECTOR, sc->w); - sc->tok = TOKEN_LEFT_PAREN; - break; - - case TOKEN_INT_VECTOR: - push_stack_no_let_no_code(sc, OP_READ_INT_VECTOR, sc->w); - sc->tok = TOKEN_LEFT_PAREN; - break; - - case TOKEN_FLOAT_VECTOR: - push_stack_no_let_no_code(sc, OP_READ_FLOAT_VECTOR, sc->w); /* here sc->w (vector dimensions from read_sharp) -> sc->args */ - sc->tok = TOKEN_LEFT_PAREN; - break; - - case TOKEN_VECTOR: /* already read #( -- TOKEN_VECTOR is triggered by #( */ - push_stack_no_let_no_code(sc, OP_READ_VECTOR, sc->w); /* sc->w is the dimensions */ - /* fall through */ - - case TOKEN_LEFT_PAREN: - sc->tok = token(sc); - if (sc->tok == TOKEN_RIGHT_PAREN) - return(sc->nil); - if (sc->tok == TOKEN_DOT) - { - int32_t c; - back_up_stack(sc); - do {c = inchar(current_input_port(sc));} while ((c != ')') && (c != EOF)); - read_error_nr(sc, "stray dot after '('?"); /* (car '( . )) */ - } - if (sc->tok == TOKEN_EOF) - missing_close_paren_error_nr(sc); - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil); /* here we need to clear args, but code is ignored */ - check_stack_size(sc); /* s7test */ - break; - - case TOKEN_QUOTE: - check_stack_size(sc); /* no speed diff in tload.scm which looks like the worst case */ - push_stack_no_let_no_code(sc, OP_READ_QUOTE, sc->nil); - sc->tok = token(sc); - break; - - case TOKEN_BACK_QUOTE: - sc->tok = token(sc); - push_stack_no_let_no_code(sc, OP_READ_QUASIQUOTE, sc->nil); - break; - - case TOKEN_COMMA: - push_stack_no_let_no_code(sc, OP_READ_UNQUOTE, sc->nil); - sc->tok = token(sc); - if (sc->tok == TOKEN_RIGHT_PAREN) - read_expression_read_error_nr(sc); - if (sc->tok == TOKEN_EOF) - { - pop_stack(sc); - read_error_nr(sc, "stray comma at the end of the input?"); - } - break; - - case TOKEN_AT_MARK: - push_stack_no_let_no_code(sc, OP_READ_APPLY_VALUES, sc->nil); - sc->tok = token(sc); - break; - - case TOKEN_ATOM: - return(port_read_name(current_input_port(sc))(sc, current_input_port(sc))); - /* If reading list (from lparen), this will finally get us to op_read_list */ - - case TOKEN_DOUBLE_QUOTE: - read_double_quote(sc); - return(sc->value); - - case TOKEN_SHARP_CONST: - return(port_read_sharp(current_input_port(sc))(sc, current_input_port(sc))); - - case TOKEN_DOT: /* (catch #t (lambda () (+ 1 . . )) (lambda args 'hiho)) */ - back_up_stack(sc); - {int32_t c; do {c = inchar(current_input_port(sc));} while ((c != ')') && (c != EOF));} - read_error_nr(sc, "stray dot in list?"); /* (+ 1 . . ) */ - - case TOKEN_RIGHT_PAREN: /* (catch #t (lambda () '(1 2 . )) (lambda args 'hiho)) */ - back_up_stack(sc); - read_error_nr(sc, "unexpected close paren"); /* (+ 1 2)) or (+ 1 . ) */ - }} + { + case TOKEN_EOF: + return(eof_object); + + case TOKEN_BYTE_VECTOR: + push_stack_no_let_no_code(sc, OP_READ_BYTE_VECTOR, sc->w); + sc->tok = TOKEN_LEFT_PAREN; + break; + + case TOKEN_INT_VECTOR: + push_stack_no_let_no_code(sc, OP_READ_INT_VECTOR, sc->w); + sc->tok = TOKEN_LEFT_PAREN; + break; + + case TOKEN_FLOAT_VECTOR: + push_stack_no_let_no_code(sc, OP_READ_FLOAT_VECTOR, sc->w); /* here sc->w (vector dimensions from read_sharp) -> sc->args */ + sc->tok = TOKEN_LEFT_PAREN; + break; + + case TOKEN_VECTOR: /* already read #( -- TOKEN_VECTOR is triggered by #( */ + push_stack_no_let_no_code(sc, OP_READ_VECTOR, sc->w); /* sc->w is the dimensions */ + /* fall through */ + + case TOKEN_LEFT_PAREN: + sc->tok = token(sc); + if (sc->tok == TOKEN_RIGHT_PAREN) + return(sc->nil); + if (sc->tok == TOKEN_DOT) + { + int32_t c; + back_up_stack(sc); + do {c = inchar(current_input_port(sc));} while ((c != ')') && (c != EOF)); + read_error_nr(sc, "stray dot after '('?"); /* (car '( . )) */ + } + if (sc->tok == TOKEN_EOF) + missing_close_paren_error_nr(sc); + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil); /* here we need to clear args, but code is ignored */ + check_stack_size(sc); /* s7test */ + break; + + case TOKEN_QUOTE: + check_stack_size(sc); /* no speed diff in tload.scm which looks like the worst case */ + push_stack_no_let_no_code(sc, OP_READ_QUOTE, sc->nil); + sc->tok = token(sc); + break; + + case TOKEN_BACK_QUOTE: + sc->tok = token(sc); + push_stack_no_let_no_code(sc, OP_READ_QUASIQUOTE, sc->nil); + break; + + case TOKEN_COMMA: + push_stack_no_let_no_code(sc, OP_READ_UNQUOTE, sc->nil); + sc->tok = token(sc); + if (sc->tok == TOKEN_RIGHT_PAREN) + read_expression_read_error_nr(sc); + if (sc->tok == TOKEN_EOF) + { + pop_stack(sc); + read_error_nr(sc, "stray comma at the end of the input?"); + } + break; + + case TOKEN_AT_MARK: + push_stack_no_let_no_code(sc, OP_READ_APPLY_VALUES, sc->nil); + sc->tok = token(sc); + break; + + case TOKEN_ATOM: + return(port_read_name(current_input_port(sc))(sc, current_input_port(sc))); + /* If reading list (from lparen), this will finally get us to op_read_list */ + + case TOKEN_DOUBLE_QUOTE: + read_double_quote(sc); + return(sc->value); + + case TOKEN_SHARP_CONST: + return(port_read_sharp(current_input_port(sc))(sc, current_input_port(sc))); + + case TOKEN_DOT: /* (catch #t (lambda () (+ 1 . . )) (lambda args 'hiho)) */ + back_up_stack(sc); + {int32_t c; do {c = inchar(current_input_port(sc));} while ((c != ')') && (c != EOF));} + read_error_nr(sc, "stray dot in list?"); /* (+ 1 . . ) */ + + case TOKEN_RIGHT_PAREN: /* (catch #t (lambda () '(1 2 . )) (lambda args 'hiho)) */ + back_up_stack(sc); + read_error_nr(sc, "unexpected close paren"); /* (+ 1 2)) or (+ 1 . ) */ + }} /* we never get here */ return(sc->nil); } @@ -90835,7 +90835,7 @@ static void op_read_internal(s7_scheme *sc) */ if (port_is_closed(current_input_port(sc))) error_nr(sc, sc->read_error_symbol, /* not read_error here because it paws through the port string which doesn't exist here */ - set_elist_1(sc, wrap_string(sc, (is_loader_port(current_input_port(sc))) ? "load input port is closed!" : "read input port is closed!", 26))); + set_elist_1(sc, wrap_string(sc, (is_loader_port(current_input_port(sc))) ? "load input port is closed!" : "read input port is closed!", 26))); sc->tok = token(sc); switch (sc->tok) @@ -90874,25 +90874,25 @@ static void op_read_s(s7_scheme *sc) { sc->value = (*(port_input_function(port)))(sc, S7_READ, port); if (is_multiple_value(sc->value)) - { - clear_multiple_value(sc->value); - error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read returned: ~S", 37), sc->value)); - }} + { + clear_multiple_value(sc->value); + error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read returned: ~S", 37), sc->value)); + }} else /* we used to check for string port at end here, but that is rarely true so checking takes up more time than it saves */ { push_input_port(sc, port); push_stack_op(sc, OP_READ_DONE); /* this stops the internal read process so we only get one form */ sc->tok = token(sc); switch (sc->tok) - { - case TOKEN_EOF: return; - case TOKEN_RIGHT_PAREN: read_error_nr(sc, "unexpected close paren"); - case TOKEN_COMMA: read_error_nr(sc, "unexpected comma"); - default: - sc->value = read_expression(sc); - sc->current_line = port_line_number(current_input_port(sc)); /* this info is used to track down missing close parens */ - sc->current_file = port_filename(current_input_port(sc)); - }} + { + case TOKEN_EOF: return; + case TOKEN_RIGHT_PAREN: read_error_nr(sc, "unexpected close paren"); + case TOKEN_COMMA: read_error_nr(sc, "unexpected comma"); + default: + sc->value = read_expression(sc); + sc->current_line = port_line_number(current_input_port(sc)); /* this info is used to track down missing close parens */ + sc->current_file = port_filename(current_input_port(sc)); + }} } static bool op_read_quasiquote(s7_scheme *sc) @@ -90937,8 +90937,8 @@ static bool op_load_close_and_pop_if_eof(s7_scheme *sc) { push_stack_op_let(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF); /* was push args, code */ if ((!is_string_port(current_input_port(sc))) || - (port_position(current_input_port(sc)) < port_data_size(current_input_port(sc)))) - push_stack_op_let(sc, OP_READ_INTERNAL); + (port_position(current_input_port(sc)) < port_data_size(current_input_port(sc)))) + push_stack_op_let(sc, OP_READ_INTERNAL); else sc->tok = TOKEN_EOF; sc->code = sc->value; return(true); /* we read an expression, now evaluate it, and return to read the next */ @@ -90965,12 +90965,12 @@ static goto_t op_read_dot(s7_scheme *sc) if (c != TOKEN_RIGHT_PAREN) /* '(1 . (2) 3) -> '(1 2 3), Guile says "missing close paren" */ { if (is_pair(sc->value)) - { - for (s7_pointer p = sc->value; is_pair(p); p = cdr(p)) - sc->args = cons(sc, car(p), sc->args); - sc->tok = c; - return(goto_read_tok); - } + { + for (s7_pointer p = sc->value; is_pair(p); p = cdr(p)) + sc->args = cons(sc, car(p), sc->args); + sc->tok = c; + return(goto_read_tok); + } back_up_stack(sc); read_error_nr(sc, "stray dot?"); /* (+ 1 . 2 3) or (list . ) */ } @@ -91086,36 +91086,36 @@ static bool op_unknown(s7_scheme *sc) case T_CLOSURE: case T_CLOSURE_STAR: if (!has_methods(f)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - if (is_null(closure_args(f))) - { - s7_pointer body = closure_body(f); - bool one_form = is_null(cdr(body)); - bool safe_case = is_safe_closure(f); - set_opt1_lambda_add(code, f); - if (one_form) - { - if ((safe_case) && (is_fxable(sc, car(body)))) - { - set_safe_closure(f); /* safe because no args so no reference to funclet? needed because op_safe_thunk_a will check for it */ - fx_annotate_arg(sc, body, sc->curlet); - set_safe_optimize_op(code, hop + OP_SAFE_THUNK_A); - set_closure_one_form_fx_arg(f); - sc->value = fx_safe_thunk_a(sc, sc->code); - return(false); - } - clear_has_fx(code); - } - set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_THUNK : ((one_form) ? OP_THUNK_O : OP_THUNK))); - return(true); - } - if (is_closure_star(f)) - { - set_safe_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA_0 : OP_CLOSURE_STAR_NA)); - set_opt1_lambda_add(code, f); - return(true); - }} + { + int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + if (is_null(closure_args(f))) + { + s7_pointer body = closure_body(f); + bool one_form = is_null(cdr(body)); + bool safe_case = is_safe_closure(f); + set_opt1_lambda_add(code, f); + if (one_form) + { + if ((safe_case) && (is_fxable(sc, car(body)))) + { + set_safe_closure(f); /* safe because no args so no reference to funclet? needed because op_safe_thunk_a will check for it */ + fx_annotate_arg(sc, body, sc->curlet); + set_safe_optimize_op(code, hop + OP_SAFE_THUNK_A); + set_closure_one_form_fx_arg(f); + sc->value = fx_safe_thunk_a(sc, sc->code); + return(false); + } + clear_has_fx(code); + } + set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_THUNK : ((one_form) ? OP_THUNK_O : OP_THUNK))); + return(true); + } + if (is_closure_star(f)) + { + set_safe_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA_0 : OP_CLOSURE_STAR_NA)); + set_opt1_lambda_add(code, f); + return(true); + }} break; case T_GOTO: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_GOTO)); @@ -91125,8 +91125,8 @@ static bool op_unknown(s7_scheme *sc) default: if ((is_symbol(car(code))) && - (!is_slot(s7_slot(sc, car(code))))) - unbound_variable_error_nr(sc, car(code)); + (!is_slot(s7_slot(sc, car(code))))) + unbound_variable_error_nr(sc, car(code)); } return(fixup_unknown_op(sc, code, f, OP_S)); } @@ -91141,16 +91141,16 @@ static bool fxify_closure_star_g(s7_scheme *sc, s7_pointer f, s7_pointer code) fx_annotate_arg(sc, cdr(code), sc->curlet); set_opt3_arglen(cdr(code), 1); if ((safe_case) && (is_null(cdr(closure_args(f))))) - set_optimize_op(code, hop + OP_SAFE_CLOSURE_STAR_A1); + 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(sc, code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); - else fixup_unknown_op(sc, 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 (lambda_has_simple_defaults(f)) + { + if (arglist_has_rest(sc, closure_args(f))) + fixup_unknown_op(sc, code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); + else fixup_unknown_op(sc, 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); + } fixup_unknown_op(sc, code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); return(true); } @@ -91175,23 +91175,23 @@ static bool op_unknown_closure_s(s7_scheme *sc, s7_pointer f, s7_pointer code) if (is_unknopt(code)) { switch (op_no_hop(code)) - { - case OP_CLOSURE_S: - set_optimize_op(code, (is_safe_closure(f)) ? ((one_form) ? OP_SAFE_CLOSURE_S_O : OP_SAFE_CLOSURE_S) : OP_S_G); break; - case OP_CLOSURE_S_O: - case OP_SAFE_CLOSURE_S: - set_optimize_op(code, ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); break; - case OP_SAFE_CLOSURE_S_O: - case OP_SAFE_CLOSURE_S_A: - case OP_SAFE_CLOSURE_S_TO_S: - case OP_SAFE_CLOSURE_S_TO_SC: - set_optimize_op(code, (is_safe_closure(f)) ? - ((one_form) ? OP_SAFE_CLOSURE_S_O : OP_SAFE_CLOSURE_S) : - ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); - break; - default: - set_optimize_op(code, OP_S_G); break; - } + { + case OP_CLOSURE_S: + set_optimize_op(code, (is_safe_closure(f)) ? ((one_form) ? OP_SAFE_CLOSURE_S_O : OP_SAFE_CLOSURE_S) : OP_S_G); break; + case OP_CLOSURE_S_O: + case OP_SAFE_CLOSURE_S: + set_optimize_op(code, ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); break; + case OP_SAFE_CLOSURE_S_O: + case OP_SAFE_CLOSURE_S_A: + case OP_SAFE_CLOSURE_S_TO_S: + case OP_SAFE_CLOSURE_S_TO_SC: + set_optimize_op(code, (is_safe_closure(f)) ? + ((one_form) ? OP_SAFE_CLOSURE_S_O : OP_SAFE_CLOSURE_S) : + ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S)); + break; + default: + set_optimize_op(code, OP_S_G); break; + } set_opt1_lambda_add(code, f); return(true); } @@ -91202,7 +91202,7 @@ static bool op_unknown_closure_s(s7_scheme *sc, s7_pointer f, s7_pointer code) set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_S); else if (is_fxable(sc, car(body))) - fxify_closure_s(sc, f, code, sc->curlet, hop); + fxify_closure_s(sc, f, code, sc->curlet, hop); else set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_S_O); /* hop if is_constant(sc, car(code)) is not foolproof here (see t967.scm): * (define (f) (define-constant (f1) ... (f1))...) where each call on f makes a different f1 @@ -91234,20 +91234,20 @@ static bool op_unknown_s(s7_scheme *sc) case T_C_RST_NO_REQ_FUNCTION: set_c_function(code, f); if (is_safe_procedure(f)) - { - set_optimize_op(code, OP_SAFE_C_S); - sc->value = fx_c_s(sc, sc->code); - } + { + set_optimize_op(code, OP_SAFE_C_S); + sc->value = fx_c_s(sc, sc->code); + } else - { - set_optimize_op(code, OP_C_S); - op_c_s(sc); - } + { + set_optimize_op(code, OP_C_S); + op_c_s(sc); + } return(false); case T_CLOSURE: if ((!has_methods(f)) && (closure_arity_to_int(sc, f) == 1)) - return(op_unknown_closure_s(sc, f, code)); + return(op_unknown_closure_s(sc, f, code)); break; case T_CLOSURE_STAR: @@ -91273,10 +91273,10 @@ static bool op_unknown_s(s7_scheme *sc) case T_C_OBJECT: if (s7_is_aritable(sc, f, 1)) - { - fx_annotate_arg(sc, cdr(code), sc->curlet); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_C_OBJECT_REF_A)); - } + { + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_C_OBJECT_REF_A)); + } break; case T_LET: @@ -91318,30 +91318,30 @@ static bool op_unknown_a(s7_scheme *sc) clear_has_fx(code); set_c_function(code, f); if (is_safe_procedure(f)) - { - set_optimize_op(code, OP_SAFE_C_A); - sc->value = fx_c_a(sc, code); - } + { + set_optimize_op(code, OP_SAFE_C_A); + sc->value = fx_c_a(sc, code); + } else - { - set_optimize_op(code, OP_C_A); - op_c_a(sc); - } + { + set_optimize_op(code, OP_C_A); + op_c_a(sc); + } return(false); case T_CLOSURE: if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == 1)) - { - s7_pointer body = closure_body(f); - bool safe_case = is_safe_closure(f); - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool one_form = is_null(cdr(body)); - - fxify_closure_a(sc, f, one_form, safe_case, hop, code, sc->curlet); - set_opt1_lambda_add(code, f); - return(true); - } + (closure_arity_to_int(sc, f) == 1)) + { + s7_pointer body = closure_body(f); + bool safe_case = is_safe_closure(f); + int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + bool one_form = is_null(cdr(body)); + + fxify_closure_a(sc, f, one_form, safe_case, hop, code, sc->curlet); + set_opt1_lambda_add(code, f); + return(true); + } break; case T_CLOSURE_STAR: @@ -91364,15 +91364,15 @@ static bool op_unknown_a(s7_scheme *sc) case T_LET: { - s7_pointer arg1 = cadr(code); - if ((is_quoted_symbol(arg1)) || (is_symbol_and_keyword(arg1))) - { - s7_pointer sym = (is_pair(arg1)) ? cadr(arg1) : arg1; - if (is_keyword(sym)) sym = keyword_symbol(sym); - set_opt3_con(code, sym); - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_C)); - } - return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_A)); /* "A" might be a symbol */ + s7_pointer arg1 = cadr(code); + if ((is_quoted_symbol(arg1)) || (is_symbol_and_keyword(arg1))) + { + s7_pointer sym = (is_pair(arg1)) ? cadr(arg1) : arg1; + if (is_keyword(sym)) sym = keyword_symbol(sym); + set_opt3_con(code, sym); + return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_C)); + } + return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_A)); /* "A" might be a symbol */ } default: break; @@ -91406,27 +91406,27 @@ static bool op_unknown_gg(s7_scheme *sc) if (!(c_function_is_aritable(f, 2))) break; case T_C_RST_NO_REQ_FUNCTION: if (is_safe_procedure(f)) - { - if (s1) - { - set_optimize_op(code, (s2) ? OP_SAFE_C_SS : OP_SAFE_C_SC); - if (s2) - set_opt2_sym(cdr(code), caddr(code)); - else set_opt2_con(cdr(code), caddr(code)); - } - else - { - set_optimize_op(code, (s2) ? OP_SAFE_C_CS : OP_SAFE_C_NC); - if (s2) - { - set_opt1_con(cdr(code), (is_pair(cadr(code))) ? cadadr(code) : cadr(code)); - set_opt2_sym(cdr(code), caddr(code)); - }}} + { + if (s1) + { + set_optimize_op(code, (s2) ? OP_SAFE_C_SS : OP_SAFE_C_SC); + if (s2) + set_opt2_sym(cdr(code), caddr(code)); + else set_opt2_con(cdr(code), caddr(code)); + } + else + { + set_optimize_op(code, (s2) ? OP_SAFE_C_CS : OP_SAFE_C_NC); + if (s2) + { + set_opt1_con(cdr(code), (is_pair(cadr(code))) ? cadadr(code) : cadr(code)); + set_opt2_sym(cdr(code), caddr(code)); + }}} else - { - set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); - fx_annotate_args(sc, cdr(code), sc->curlet); - } + { + set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); + fx_annotate_args(sc, cdr(code), sc->curlet); + } set_opt3_arglen(cdr(code), 2); set_c_function(code, f); return(true); @@ -91434,71 +91434,71 @@ static bool op_unknown_gg(s7_scheme *sc) case T_CLOSURE: if (has_methods(f)) break; if (closure_arity_to_int(sc, f) == 2) - { - s7_pointer body = closure_body(f); - bool safe_case = is_safe_closure(f); - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool one_form = is_null(cdr(body)); - - if ((s1) && (s2)) - { - set_opt2_sym(code, caddr(code)); - if (!one_form) - set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_SS : OP_CLOSURE_SS)); - else - if (!safe_case) - set_optimize_op(code, hop + OP_CLOSURE_SS_O); - else - if (!is_fxable(sc, car(body))) - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_O); - else - { - fx_annotate_arg(sc, body, sc->curlet); - fx_tree(sc, body, car(closure_args(f)), cadr(closure_args(f)), NULL, false); - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_A); - set_closure_one_form_fx_arg(f); - }} - else - if (s1) - { - set_opt2_con(code, caddr(code)); - if (one_form) - set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC_O : OP_CLOSURE_SC_O)); - else set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC : OP_CLOSURE_SC)); - } - else - { - set_opt3_arglen(cdr(code), 2); - fx_annotate_args(sc, cdr(code), sc->curlet); - if (safe_case) - set_safe_optimize_op(code, hop + ((one_form) ? OP_SAFE_CLOSURE_AA_O : OP_SAFE_CLOSURE_AA)); - else set_safe_optimize_op(code, hop + ((one_form) ? OP_CLOSURE_AA_O : OP_CLOSURE_AA)); - } - set_opt1_lambda_add(code, f); - return(true); - } + { + s7_pointer body = closure_body(f); + bool safe_case = is_safe_closure(f); + int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + bool one_form = is_null(cdr(body)); + + if ((s1) && (s2)) + { + set_opt2_sym(code, caddr(code)); + if (!one_form) + set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_SS : OP_CLOSURE_SS)); + else + if (!safe_case) + set_optimize_op(code, hop + OP_CLOSURE_SS_O); + else + if (!is_fxable(sc, car(body))) + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_O); + else + { + fx_annotate_arg(sc, body, sc->curlet); + fx_tree(sc, body, car(closure_args(f)), cadr(closure_args(f)), NULL, false); + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_A); + set_closure_one_form_fx_arg(f); + }} + else + if (s1) + { + set_opt2_con(code, caddr(code)); + if (one_form) + set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC_O : OP_CLOSURE_SC_O)); + else set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_SC : OP_CLOSURE_SC)); + } + else + { + set_opt3_arglen(cdr(code), 2); + fx_annotate_args(sc, cdr(code), sc->curlet); + if (safe_case) + set_safe_optimize_op(code, hop + ((one_form) ? OP_SAFE_CLOSURE_AA_O : OP_SAFE_CLOSURE_AA)); + else set_safe_optimize_op(code, hop + ((one_form) ? OP_CLOSURE_AA_O : OP_CLOSURE_AA)); + } + set_opt1_lambda_add(code, f); + return(true); + } break; case T_CLOSURE_STAR: if ((closure_star_arity_to_int(sc, f) != 0) && - (closure_star_arity_to_int(sc, f) != 1)) - { - fx_annotate_args(sc, cdr(code), sc->curlet); - if (!has_methods(f)) - { - fixup_closure_star_aa(sc, f, code, (is_immutable_and_stable(sc, car(code))) ? 1 : 0); - set_opt1_lambda_add(code, f); - } - else set_optimize_op(code, OP_S_AA); - return(true); - } + (closure_star_arity_to_int(sc, f) != 1)) + { + fx_annotate_args(sc, cdr(code), sc->curlet); + if (!has_methods(f)) + { + fixup_closure_star_aa(sc, f, code, (is_immutable_and_stable(sc, car(code))) ? 1 : 0); + set_opt1_lambda_add(code, f); + } + else set_optimize_op(code, OP_S_AA); + return(true); + } break; case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_PAIR: set_opt3_arglen(cdr(code), 2); fx_annotate_args(sc, cdr(code), sc->curlet); if ((!is_pair(f)) && (vector_rank(f) != 2)) - return(fixup_unknown_op(sc, code, f, OP_S_AA)); + return(fixup_unknown_op(sc, code, f, OP_S_AA)); return(fixup_unknown_op(sc, code, f, (is_pair(f)) ? OP_IMPLICIT_PAIR_REF_AA : OP_IMPLICIT_VECTOR_REF_AA)); case T_HASH_TABLE: @@ -91537,48 +91537,48 @@ static bool op_unknown_ns(s7_scheme *sc) if (!(c_function_is_aritable(f, num_args))) break; case T_C_RST_NO_REQ_FUNCTION: if (is_safe_procedure(f)) - { - if (num_args == 3) - { - set_safe_optimize_op(code, OP_SAFE_C_SSS); - set_opt1_sym(cdr(code), caddr(code)); - set_opt2_sym(cdr(code), cadddr(code)); - } - else set_safe_optimize_op(code, OP_SAFE_C_NS); - } + { + if (num_args == 3) + { + set_safe_optimize_op(code, OP_SAFE_C_SSS); + set_opt1_sym(cdr(code), caddr(code)); + set_opt2_sym(cdr(code), cadddr(code)); + } + else set_safe_optimize_op(code, OP_SAFE_C_NS); + } else - { - set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); - fx_annotate_args(sc, cdr(code), sc->curlet); - } + { + set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); + fx_annotate_args(sc, cdr(code), sc->curlet); + } set_c_function(code, f); return(true); case T_CLOSURE: if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == num_args)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool one_form = is_null(cdr(closure_body(f))); - fx_annotate_args(sc, cdr(code), sc->curlet); - if (num_args == 3) - return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_3S : ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)))); - if (num_args == 4) - return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_NS : ((one_form) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S)))); - return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_NS : ((num_args == 5) ? OP_CLOSURE_5S : OP_CLOSURE_NS)))); - } + (closure_arity_to_int(sc, f) == num_args)) + { + int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + bool one_form = is_null(cdr(closure_body(f))); + fx_annotate_args(sc, cdr(code), sc->curlet); + if (num_args == 3) + return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_3S : ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)))); + if (num_args == 4) + return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_NS : ((one_form) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S)))); + return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_NS : ((num_args == 5) ? OP_CLOSURE_5S : OP_CLOSURE_NS)))); + } break; case T_CLOSURE_STAR: if ((!has_methods(f)) && - ((closure_star_arity_to_int(sc, f) < 0) || ((closure_star_arity_to_int(sc, f) * 2) >= num_args))) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - fx_annotate_args(sc, cdr(code), sc->curlet); - if ((is_safe_closure(f)) && (num_args == 3) && (closure_star_arity_to_int(sc, f) == 3)) - return(fixup_unknown_op(sc, code, f, OP_SAFE_CLOSURE_STAR_3A)); - return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA))); - } + ((closure_star_arity_to_int(sc, f) < 0) || ((closure_star_arity_to_int(sc, f) * 2) >= num_args))) + { + int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + fx_annotate_args(sc, cdr(code), sc->curlet); + if ((is_safe_closure(f)) && (num_args == 3) && (closure_star_arity_to_int(sc, f) == 3)) + return(fixup_unknown_op(sc, code, f, OP_SAFE_CLOSURE_STAR_3A)); + return(fixup_unknown_op(sc, code, f, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA))); + } break; case T_BACRO: case T_MACRO: @@ -91605,56 +91605,56 @@ static bool op_unknown_aa(s7_scheme *sc) if (!(c_function_is_aritable(f, 2))) break; case T_C_RST_NO_REQ_FUNCTION: if (is_safe_procedure(f)) /* why is this different from unknown_a and unknown_na? */ - { - if (!safe_c_aa_to_ag_ga(sc, code, 0)) - { - set_safe_optimize_op(code, OP_SAFE_C_AA); - set_opt3_pair(code, cddr(code)); - }} + { + if (!safe_c_aa_to_ag_ga(sc, code, 0)) + { + set_safe_optimize_op(code, OP_SAFE_C_AA); + set_opt3_pair(code, cddr(code)); + }} else set_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); set_c_function(code, f); return(true); case T_CLOSURE: if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == 2)) - { - s7_pointer body = closure_body(f); - bool safe_case = is_safe_closure(f); - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - bool one_form = is_null(cdr(body)); - if (!one_form) - set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_AA : OP_CLOSURE_AA)); - else - if (!safe_case) - set_optimize_op(code, hop + OP_CLOSURE_AA_O); - else - if (!is_fxable(sc, car(body))) - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_O); - else - { - fx_annotate_arg(sc, body, sc->curlet); - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_A); - set_closure_one_form_fx_arg(f); - } - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); - set_opt1_lambda_add(code, f); - return(true); - } + (closure_arity_to_int(sc, f) == 2)) + { + s7_pointer body = closure_body(f); + bool safe_case = is_safe_closure(f); + int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + bool one_form = is_null(cdr(body)); + if (!one_form) + set_safe_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_AA : OP_CLOSURE_AA)); + else + if (!safe_case) + set_optimize_op(code, hop + OP_CLOSURE_AA_O); + else + if (!is_fxable(sc, car(body))) + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_O); + else + { + fx_annotate_arg(sc, body, sc->curlet); + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_AA_A); + set_closure_one_form_fx_arg(f); + } + if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); + set_opt1_lambda_add(code, f); + return(true); + } break; case T_CLOSURE_STAR: if (!has_methods(f)) - { - fixup_closure_star_aa(sc, f, code, (is_immutable_and_stable(sc, car(code))) ? 1 : 0); - set_opt1_lambda_add(code, f); - } + { + fixup_closure_star_aa(sc, f, code, (is_immutable_and_stable(sc, car(code))) ? 1 : 0); + set_opt1_lambda_add(code, f); + } else set_optimize_op(code, OP_S_AA); return(true); case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: if (vector_rank(f) != 2) - return(fixup_unknown_op(sc, code, f, OP_S_AA)); + return(fixup_unknown_op(sc, code, f, OP_S_AA)); return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_VECTOR_REF_AA)); case T_PAIR: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_PAIR_REF_AA)); @@ -91694,30 +91694,30 @@ static bool op_unknown_na(s7_scheme *sc) if (!(c_function_is_aritable(f, num_args))) break; case T_C_RST_NO_REQ_FUNCTION: if (is_safe_procedure(f)) - { - if (num_args == 3) - { - int32_t pairs = 0, symbols = 0, quotes = 0; /* specialize aaa->ssc etc, this makes less difference than I expected */ - for (s7_pointer p = cdr(code); is_pair(p); p = cdr(p)) - { - s7_pointer car_p = car(p); - if (is_normal_happy_symbol(sc, car_p)) - symbols++; - else - if (is_pair(car_p)) - { - pairs++; - if (is_proper_quote(sc, car_p)) - quotes++; - }} - if (optimize_safe_c_func_three_args(sc, code, f, 0 /* hop */, pairs, symbols, quotes, sc->curlet) == OPT_T) - return(true); - set_opt3_pair(cdr(code), cdddr(code)); - set_opt3_pair(code, cddr(code)); - set_safe_optimize_op(code, OP_SAFE_C_AAA); - } - else set_safe_optimize_op(code, (num_args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA); - } + { + if (num_args == 3) + { + int32_t pairs = 0, symbols = 0, quotes = 0; /* specialize aaa->ssc etc, this makes less difference than I expected */ + for (s7_pointer p = cdr(code); is_pair(p); p = cdr(p)) + { + s7_pointer car_p = car(p); + if (is_normal_happy_symbol(sc, car_p)) + symbols++; + else + if (is_pair(car_p)) + { + pairs++; + if (is_proper_quote(sc, car_p)) + quotes++; + }} + if (optimize_safe_c_func_three_args(sc, code, f, 0 /* hop */, pairs, symbols, quotes, sc->curlet) == OPT_T) + return(true); + set_opt3_pair(cdr(code), cdddr(code)); + set_opt3_pair(code, cddr(code)); + set_safe_optimize_op(code, OP_SAFE_C_AAA); + } + else set_safe_optimize_op(code, (num_args == 4) ? OP_SAFE_C_4A : OP_SAFE_C_NA); + } else set_safe_optimize_op(code, (is_semisafe(f)) ? OP_CL_NA : OP_C_NA); fx_annotate_args(sc, cdr(code), sc->curlet); set_c_function(code, f); @@ -91725,65 +91725,65 @@ static bool op_unknown_na(s7_scheme *sc) case T_CLOSURE: if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == num_args)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - fx_annotate_args(sc, cdr(code), sc->curlet); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); - if (is_safe_closure(f)) - { - if (num_args != 3) - set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_NA); - else - if (is_normal_happy_symbol(sc, cadr(code))) - set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, caddr(code))) ? OP_SAFE_CLOSURE_SSA : OP_SAFE_CLOSURE_SAA)); - else set_safe_optimize_op(code, hop + (((!is_pair(caddr(code))) && (!is_pair(cadddr(code)))) ? OP_SAFE_CLOSURE_AGG : OP_SAFE_CLOSURE_3A)); - } - else - if (num_args != 3) - set_safe_optimize_op(code, hop + ((num_args == 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA)); - else - if ((is_normal_happy_symbol(sc, caddr(code))) && (is_normal_happy_symbol(sc, cadddr(code)))) - set_safe_optimize_op(code, hop + OP_CLOSURE_ASS); - else - if (is_normal_happy_symbol(sc, cadr(code))) - set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, cadddr(code))) ? OP_CLOSURE_SAS : OP_CLOSURE_SAA)); - else - if (is_normal_happy_symbol(sc, caddr(code))) - set_safe_optimize_op(code, hop + OP_CLOSURE_ASA); - else set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, cadddr(code))) ? OP_CLOSURE_AAS : OP_CLOSURE_3A)); - set_opt1_lambda_add(code, f); - return(true); - } + (closure_arity_to_int(sc, f) == num_args)) + { + int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + fx_annotate_args(sc, cdr(code), sc->curlet); + if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); + if (is_safe_closure(f)) + { + if (num_args != 3) + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_NA); + else + if (is_normal_happy_symbol(sc, cadr(code))) + set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, caddr(code))) ? OP_SAFE_CLOSURE_SSA : OP_SAFE_CLOSURE_SAA)); + else set_safe_optimize_op(code, hop + (((!is_pair(caddr(code))) && (!is_pair(cadddr(code)))) ? OP_SAFE_CLOSURE_AGG : OP_SAFE_CLOSURE_3A)); + } + else + if (num_args != 3) + set_safe_optimize_op(code, hop + ((num_args == 4) ? OP_CLOSURE_4A : OP_CLOSURE_NA)); + else + if ((is_normal_happy_symbol(sc, caddr(code))) && (is_normal_happy_symbol(sc, cadddr(code)))) + set_safe_optimize_op(code, hop + OP_CLOSURE_ASS); + else + if (is_normal_happy_symbol(sc, cadr(code))) + set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, cadddr(code))) ? OP_CLOSURE_SAS : OP_CLOSURE_SAA)); + else + if (is_normal_happy_symbol(sc, caddr(code))) + set_safe_optimize_op(code, hop + OP_CLOSURE_ASA); + else set_safe_optimize_op(code, hop + ((is_normal_happy_symbol(sc, cadddr(code))) ? OP_CLOSURE_AAS : OP_CLOSURE_3A)); + set_opt1_lambda_add(code, f); + return(true); + } if (is_symbol(closure_args(f))) - { - optimize_closure_sym(sc, code, f, 0, num_args, sc->curlet); - if (optimize_op(code) == OP_ANY_CLOSURE_SYM) return(true); - } + { + optimize_closure_sym(sc, code, f, 0, num_args, sc->curlet); + if (optimize_op(code) == OP_ANY_CLOSURE_SYM) return(true); + } break; case T_CLOSURE_STAR: if ((!has_methods(f)) && - ((closure_star_arity_to_int(sc, f) < 0) || ((closure_star_arity_to_int(sc, f) * 2) >= num_args))) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - if (num_args > 0) - { - set_opt3_arglen(cdr(code), num_args); - fx_annotate_args(sc, cdr(code), sc->curlet); - if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); - } - if (is_safe_closure(f)) - switch (num_args) - { - case 0: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA_0)); - case 1: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA_1)); - case 2: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA_2)); - case 3: if (closure_star_arity_to_int(sc, f) == 3) return(fixup_unknown_op(sc, code, f, OP_SAFE_CLOSURE_STAR_3A)); - default: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA)); - } - return(fixup_unknown_op(sc, code, f, hop + OP_CLOSURE_STAR_NA)); - } + ((closure_star_arity_to_int(sc, f) < 0) || ((closure_star_arity_to_int(sc, f) * 2) >= num_args))) + { + int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + if (num_args > 0) + { + set_opt3_arglen(cdr(code), num_args); + fx_annotate_args(sc, cdr(code), sc->curlet); + if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); + } + if (is_safe_closure(f)) + switch (num_args) + { + case 0: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA_0)); + case 1: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA_1)); + case 2: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA_2)); + case 3: if (closure_star_arity_to_int(sc, f) == 3) return(fixup_unknown_op(sc, code, f, OP_SAFE_CLOSURE_STAR_3A)); + default: return(fixup_unknown_op(sc, code, f, hop + OP_SAFE_CLOSURE_STAR_NA)); + } + return(fixup_unknown_op(sc, code, f, hop + OP_CLOSURE_STAR_NA)); + } break; case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); @@ -91804,7 +91804,7 @@ static bool op_unknown_np(s7_scheme *sc) if (!f) unbound_variable_error_nr(sc, car(sc->code)); if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %s %s\n", - __func__, __LINE__, display_truncated(f), type_name(sc, f, NO_ARTICLE), display_truncated(sc->code)); + __func__, __LINE__, display_truncated(f), type_name(sc, f, NO_ARTICLE), display_truncated(sc->code)); switch (type(f)) { @@ -91812,71 +91812,71 @@ static bool op_unknown_np(s7_scheme *sc) if (!(c_function_is_aritable(f, num_args))) break; case T_C_RST_NO_REQ_FUNCTION: if (num_args == 1) - set_any_c_np(sc, f, code, sc->curlet, num_args, (is_safe_procedure(f)) ? OP_SAFE_C_P : OP_C_P); + set_any_c_np(sc, f, code, sc->curlet, num_args, (is_safe_procedure(f)) ? OP_SAFE_C_P : OP_C_P); else - if ((num_args == 2) && (is_safe_procedure(f))) - { - set_any_c_np(sc, f, code, sc->curlet, 2, OP_SAFE_C_PP); - opt_sp_1(sc, c_function_call(f), code); - } - else - if ((num_args == 3) && - ((is_safe_procedure(f)) || - ((is_semisafe(f)) && - (((car(code) != sc->assoc_symbol) && (car(code) != sc->member_symbol)) || - (unsafe_is_safe(sc, cadddr(code), sc->curlet)))))) - set_any_c_np(sc, f, code, sc->curlet, 3, OP_SAFE_C_3P); - else set_any_c_np(sc, f, code, sc->curlet, num_args, OP_ANY_C_NP); + if ((num_args == 2) && (is_safe_procedure(f))) + { + set_any_c_np(sc, f, code, sc->curlet, 2, OP_SAFE_C_PP); + opt_sp_1(sc, c_function_call(f), code); + } + else + if ((num_args == 3) && + ((is_safe_procedure(f)) || + ((is_semisafe(f)) && + (((car(code) != sc->assoc_symbol) && (car(code) != sc->member_symbol)) || + (unsafe_is_safe(sc, cadddr(code), sc->curlet)))))) + set_any_c_np(sc, f, code, sc->curlet, 3, OP_SAFE_C_3P); + else set_any_c_np(sc, f, code, sc->curlet, num_args, OP_ANY_C_NP); return(true); case T_CLOSURE: if ((!has_methods(f)) && - (closure_arity_to_int(sc, f) == num_args)) - { - int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; - switch (num_args) - { - case 1: - if (is_safe_closure(f)) - { - s7_pointer body = closure_body(f); - if ((is_null(cdr(body))) && (is_fxable(sc, car(body)))) - { - set_optimize_op(code, hop + OP_SAFE_CLOSURE_P_A); - fx_annotate_arg(sc, body, sc->curlet); - } - else set_optimize_op(code, hop + OP_SAFE_CLOSURE_P); - } - else set_optimize_op(code, hop + OP_CLOSURE_P); - set_opt1_lambda_add(code, f); /* added 8-Jun-22 */ - set_opt3_arglen(cdr(code), 1); - set_unsafely_optimized(code); - break; - - case 2: - if (is_fxable(sc, cadr(code))) - { - fx_annotate_arg(sc, cdr(code), sc->curlet); - set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP)); - } - else - if (is_fxable(sc, caddr(code))) - { - fx_annotate_arg(sc, cddr(code), sc->curlet); - set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); - } - else set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_PP : OP_CLOSURE_PP)); - set_opt1_lambda_add(code, f); /* added 8-Jun-22 */ - set_opt3_arglen(cdr(code), 2); /* for later op_unknown_np */ - set_unsafely_optimized(code); - break; - - case 3: set_any_closure_np(sc, f, code, sc->curlet, 3, hop + OP_ANY_CLOSURE_3P); break; - case 4: set_any_closure_np(sc, f, code, sc->curlet, 4, hop + OP_ANY_CLOSURE_4P); break; - default: set_any_closure_np(sc, f, code, sc->curlet, num_args, hop + OP_ANY_CLOSURE_NP); break; - } - return(true); - } + (closure_arity_to_int(sc, f) == num_args)) + { + int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + switch (num_args) + { + case 1: + if (is_safe_closure(f)) + { + s7_pointer body = closure_body(f); + if ((is_null(cdr(body))) && (is_fxable(sc, car(body)))) + { + set_optimize_op(code, hop + OP_SAFE_CLOSURE_P_A); + fx_annotate_arg(sc, body, sc->curlet); + } + else set_optimize_op(code, hop + OP_SAFE_CLOSURE_P); + } + else set_optimize_op(code, hop + OP_CLOSURE_P); + set_opt1_lambda_add(code, f); /* added 8-Jun-22 */ + set_opt3_arglen(cdr(code), 1); + set_unsafely_optimized(code); + break; + + case 2: + if (is_fxable(sc, cadr(code))) + { + fx_annotate_arg(sc, cdr(code), sc->curlet); + set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_AP : OP_CLOSURE_AP)); + } + else + if (is_fxable(sc, caddr(code))) + { + fx_annotate_arg(sc, cddr(code), sc->curlet); + set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); + } + else set_optimize_op(code, hop + ((is_safe_closure(f)) ? OP_SAFE_CLOSURE_PP : OP_CLOSURE_PP)); + set_opt1_lambda_add(code, f); /* added 8-Jun-22 */ + set_opt3_arglen(cdr(code), 2); /* for later op_unknown_np */ + set_unsafely_optimized(code); + break; + + case 3: set_any_closure_np(sc, f, code, sc->curlet, 3, hop + OP_ANY_CLOSURE_3P); break; + case 4: set_any_closure_np(sc, f, code, sc->curlet, 4, hop + OP_ANY_CLOSURE_4P); break; + default: set_any_closure_np(sc, f, code, sc->curlet, num_args, hop + OP_ANY_CLOSURE_NP); break; + } + return(true); + } break; case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f))); @@ -92013,10 +92013,10 @@ static bool closure_star_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type static noreturn void eval_apply_error_nr(s7_scheme *sc) { error_nr(sc, sc->syntax_error_symbol, /* apply_error_nr expanded */ - set_elist_4(sc, wrap_string(sc, "attempt to apply ~A ~$ in ~$?", 29), - ((is_symbol_and_keyword(sc->code)) ? wrap_string(sc, "a keyword", 9) : type_name_string(sc, sc->code)), - sc->code, - cons(sc, sc->code, sc->args))); + set_elist_4(sc, wrap_string(sc, "attempt to apply ~A ~$ in ~$?", 29), + ((is_symbol_and_keyword(sc->code)) ? wrap_string(sc, "a keyword", 9) : type_name_string(sc, sc->code)), + sc->code, + cons(sc, sc->code, sc->args))); } @@ -92024,7 +92024,7 @@ static noreturn void eval_apply_error_nr(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_truncated(sc->code), display_truncated(sc->args))); + __LINE__, op_names[first_op], display_truncated(sc->code), display_truncated(sc->args))); sc->cur_op = first_op; goto TOP_NO_POP; @@ -92035,10 +92035,10 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) BEGIN: if (is_pair(cdr(sc->code))) - { - set_current_code(sc, sc->code); - push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); - } + { + set_current_code(sc, sc->code); + push_stack_no_args(sc, sc->begin_op, cdr(sc->code)); + } sc->code = car(sc->code); EVAL: @@ -92058,1786 +92058,1786 @@ static s7_pointer eval(s7_scheme *sc, opcode_t first_op) * so the switch statement is unnecessary -- maybe a table eval_functions[cur_op] eventually */ switch (sc->cur_op) - { - /* safe c_functions */ - case OP_SAFE_C_NC: if (!c_function_is_ok(sc, sc->code)) break; /* break refers to the switch statement */ - case HOP_SAFE_C_NC: sc->value = fn_call(sc, sc->code); continue; /* continue refers to the outer while loop -- unfortunate C ambiguity */ + { + /* safe c_functions */ + case OP_SAFE_C_NC: if (!c_function_is_ok(sc, sc->code)) break; /* break refers to the switch statement */ + case HOP_SAFE_C_NC: sc->value = fn_call(sc, sc->code); continue; /* continue refers to the outer while loop -- unfortunate C ambiguity */ - case OP_SAFE_C_S: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_s(sc)) goto EVAL; continue;} /* checking symbol_ctr(car(sc->code)) == 1 just slows us down */ - case HOP_SAFE_C_S: inline_op_safe_c_s(sc); continue; + case OP_SAFE_C_S: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_s(sc)) goto EVAL; continue;} /* checking symbol_ctr(car(sc->code)) == 1 just slows us down */ + case HOP_SAFE_C_S: inline_op_safe_c_s(sc); continue; - case OP_SAFE_C_SS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SS: inline_op_safe_c_ss(sc); continue; + case OP_SAFE_C_SS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SS: inline_op_safe_c_ss(sc); continue; - case OP_SAFE_C_NS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_NS: sc->value = fx_c_ns(sc, sc->code); continue; + case OP_SAFE_C_NS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_NS: sc->value = fx_c_ns(sc, sc->code); continue; - case OP_SAFE_C_SC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SC: op_safe_c_sc(sc); continue; + case OP_SAFE_C_SC: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SC: op_safe_c_sc(sc); continue; - case OP_SAFE_C_CS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CS: sc->value = fx_c_cs(sc, sc->code); continue; + case OP_SAFE_C_CS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_CS: sc->value = fx_c_cs(sc, sc->code); continue; - case OP_SAFE_C_CQ: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CQ: sc->value = fx_c_cq(sc, sc->code); continue; + case OP_SAFE_C_CQ: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_CQ: sc->value = fx_c_cq(sc, sc->code); continue; - case OP_SAFE_C_FF: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_C_FF: sc->value = fx_c_ff(sc, sc->code); continue; + case OP_SAFE_C_FF: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_np(sc)) goto EVAL; continue;} + case HOP_SAFE_C_FF: sc->value = fx_c_ff(sc, sc->code); continue; - case OP_SAFE_C_P: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_P: op_safe_c_p(sc); goto EVAL; - case OP_SAFE_C_P_1: op_safe_c_p_1(sc); continue; + case OP_SAFE_C_P: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_P: op_safe_c_p(sc); goto EVAL; + case OP_SAFE_C_P_1: op_safe_c_p_1(sc); continue; - case OP_ANY_C_NP: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_ANY_C_NP: if (op_any_c_np(sc)) goto EVAL; continue; - case OP_ANY_C_NP_1: if (inline_op_any_c_np_1(sc)) goto EVAL; continue; - case OP_ANY_C_NP_2: op_any_c_np_2(sc); continue; - case OP_ANY_C_NP_MV: if (op_any_c_np_mv(sc)) goto EVAL; goto APPLY; + case OP_ANY_C_NP: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_np(sc)) goto EVAL; continue;} + case HOP_ANY_C_NP: if (op_any_c_np(sc)) goto EVAL; continue; + case OP_ANY_C_NP_1: if (inline_op_any_c_np_1(sc)) goto EVAL; continue; + case OP_ANY_C_NP_2: op_any_c_np_2(sc); continue; + case OP_ANY_C_NP_MV: if (op_any_c_np_mv(sc)) goto EVAL; goto APPLY; - case OP_SAFE_C_SSP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSP: op_safe_c_ssp(sc); goto EVAL; - case OP_SAFE_C_SSP_1: op_safe_c_ssp_1(sc); continue; + case OP_SAFE_C_SSP: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SSP: op_safe_c_ssp(sc); goto EVAL; + case OP_SAFE_C_SSP_1: op_safe_c_ssp_1(sc); continue; - case OP_SAFE_C_A: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_C_A: sc->value = fx_c_a(sc, sc->code); continue; + case OP_SAFE_C_A: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_a(sc)) goto EVAL; continue;} + case HOP_SAFE_C_A: sc->value = fx_c_a(sc, sc->code); continue; - case OP_SAFE_C_opAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAq: sc->value = fx_c_opaq(sc, sc->code); continue; + case OP_SAFE_C_opAq: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_opAq: sc->value = fx_c_opaq(sc, sc->code); continue; - case OP_SAFE_C_opAAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAAq: sc->value = fx_c_opaaq(sc, sc->code); continue; + case OP_SAFE_C_opAAq: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_opAAq: sc->value = fx_c_opaaq(sc, sc->code); continue; - case OP_SAFE_C_opAAAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAAAq: sc->value = fx_c_opaaaq(sc, sc->code); continue; + case OP_SAFE_C_opAAAq: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_opAAAq: sc->value = fx_c_opaaaq(sc, sc->code); continue; - case OP_SAFE_C_S_opAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_S_opAq: sc->value = fx_c_s_opaq(sc, sc->code); continue; + case OP_SAFE_C_S_opAq: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_S_opAq: sc->value = fx_c_s_opaq(sc, sc->code); continue; - case OP_SAFE_C_opAq_S: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_opAq_S: sc->value = fx_c_opaq_s(sc, sc->code); continue; + case OP_SAFE_C_opAq_S: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_opAq_S: sc->value = fx_c_opaq_s(sc, sc->code); continue; - case OP_SAFE_C_S_opAAq: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_S_opAAq: sc->value = fx_c_s_opaaq(sc, sc->code); continue; + case OP_SAFE_C_S_opAAq: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_S_opAAq: sc->value = fx_c_s_opaaq(sc, sc->code); continue; - case OP_SAFE_C_AA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_AA: sc->value = fx_c_aa(sc, sc->code); continue; + case OP_SAFE_C_AA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_SAFE_C_AA: sc->value = fx_c_aa(sc, sc->code); continue; - case OP_SAFE_C_SA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_SA: sc->value = fx_c_sa(sc, sc->code); continue; + case OP_SAFE_C_SA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_SAFE_C_SA: sc->value = fx_c_sa(sc, sc->code); continue; - case OP_SAFE_C_AS: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_AS: sc->value = fx_c_as(sc, sc->code); continue; + case OP_SAFE_C_AS: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_SAFE_C_AS: sc->value = fx_c_as(sc, sc->code); continue; - case OP_SAFE_C_CA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_CA: sc->value = fx_c_ca(sc, sc->code); continue; + case OP_SAFE_C_CA: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_SAFE_C_CA: sc->value = fx_c_ca(sc, sc->code); continue; - case OP_SAFE_C_AC: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_C_AC: sc->value = fx_c_ac(sc, sc->code); continue; + case OP_SAFE_C_AC: if (!c_function_is_ok(sc, sc->code)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_SAFE_C_AC: sc->value = fx_c_ac(sc, sc->code); continue; - case OP_SAFE_C_AAA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_AAA: sc->value = fx_c_aaa(sc, sc->code); continue; + case OP_SAFE_C_AAA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_AAA: sc->value = fx_c_aaa(sc, sc->code); continue; - case OP_SAFE_C_SAA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SAA: sc->value = fx_c_saa(sc, sc->code); continue; + case OP_SAFE_C_SAA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SAA: sc->value = fx_c_saa(sc, sc->code); continue; - case OP_SAFE_C_SSA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSA: sc->value = fx_c_ssa(sc, sc->code); continue; + case OP_SAFE_C_SSA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SSA: sc->value = fx_c_ssa(sc, sc->code); continue; case HOP_HASH_TABLE_INCREMENT: sc->value = fx_hash_table_increment(sc, sc->code); continue; /* a placeholder, almost never called */ - case OP_SAFE_C_SAS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SAS: sc->value = fx_c_sas(sc, sc->code); continue; + case OP_SAFE_C_SAS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SAS: sc->value = fx_c_sas(sc, sc->code); continue; - case OP_SAFE_C_ASS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_ASS: sc->value = fx_c_ass(sc, sc->code); continue; + case OP_SAFE_C_ASS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_ASS: sc->value = fx_c_ass(sc, sc->code); continue; - case OP_SAFE_C_AGG: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_AGG: sc->value = fx_c_agg(sc, sc->code); continue; + case OP_SAFE_C_AGG: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_AGG: sc->value = fx_c_agg(sc, sc->code); continue; - case OP_SAFE_C_CAC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CAC: sc->value = fx_c_cac(sc, sc->code); continue; + case OP_SAFE_C_CAC: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_CAC: sc->value = fx_c_cac(sc, sc->code); continue; - case OP_SAFE_C_CSA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CSA: sc->value = fx_c_csa(sc, sc->code); continue; + case OP_SAFE_C_CSA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_CSA: sc->value = fx_c_csa(sc, sc->code); continue; - case OP_SAFE_C_SCA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SCA: sc->value = fx_c_sca(sc, sc->code); continue; + case OP_SAFE_C_SCA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SCA: sc->value = fx_c_sca(sc, sc->code); continue; - case OP_SAFE_C_4A: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_4A: sc->value = fx_c_4a(sc, sc->code); continue; + case OP_SAFE_C_4A: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_4A: sc->value = fx_c_4a(sc, sc->code); continue; - case OP_SAFE_C_NA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_NA: sc->value = fx_c_na(sc, sc->code); continue; + case OP_SAFE_C_NA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_NA: sc->value = fx_c_na(sc, sc->code); continue; - case OP_SAFE_C_ALL_CA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_ALL_CA: sc->value = fx_c_all_ca(sc, sc->code); continue; + case OP_SAFE_C_ALL_CA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_ALL_CA: sc->value = fx_c_all_ca(sc, sc->code); continue; - case OP_SAFE_C_SCS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SCS: sc->value = fx_c_scs(sc, sc->code); continue; + case OP_SAFE_C_SCS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SCS: sc->value = fx_c_scs(sc, sc->code); continue; - case OP_SAFE_C_SSC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSC: sc->value = fx_c_ssc(sc, sc->code); continue; + case OP_SAFE_C_SSC: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SSC: sc->value = fx_c_ssc(sc, sc->code); continue; - case OP_SAFE_C_SCC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SCC: sc->value = fx_c_scc(sc, sc->code); continue; + case OP_SAFE_C_SCC: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SCC: sc->value = fx_c_scc(sc, sc->code); continue; - case OP_SAFE_C_CSC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CSC: sc->value = fx_c_csc(sc, sc->code); continue; + case OP_SAFE_C_CSC: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_CSC: sc->value = fx_c_csc(sc, sc->code); continue; - case OP_SAFE_C_CCS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CCS: sc->value = fx_c_ccs(sc, sc->code); continue; + case OP_SAFE_C_CCS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_CCS: sc->value = fx_c_ccs(sc, sc->code); continue; - case OP_SAFE_C_CSS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CSS: sc->value = fx_c_css(sc, sc->code); continue; + case OP_SAFE_C_CSS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_CSS: sc->value = fx_c_css(sc, sc->code); continue; - case OP_SAFE_C_SSS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SSS: sc->value = fx_c_sss(sc, sc->code); continue; + case OP_SAFE_C_SSS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SSS: sc->value = fx_c_sss(sc, sc->code); continue; - case OP_SAFE_C_opNCq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opNCq: sc->value = fx_c_opncq(sc, sc->code); continue; + case OP_SAFE_C_opNCq: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opNCq: sc->value = fx_c_opncq(sc, sc->code); continue; - 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_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_opSqq: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; - case HOP_SAFE_C_op_opSqq: sc->value = fx_c_op_opsqq(sc, sc->code); continue; /* lg cb (splits to not) */ + case OP_SAFE_C_op_opSqq: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; + case HOP_SAFE_C_op_opSqq: sc->value = fx_c_op_opsqq(sc, sc->code); continue; /* lg cb (splits to not) */ - case OP_SAFE_C_op_S_opSqq: if (!c_function_is_ok_cadr_caddadr(sc, sc->code)) break; - case HOP_SAFE_C_op_S_opSqq: sc->value = fx_c_op_s_opsqq(sc, sc->code); continue; /* tlet sg (splits to not) */ + case OP_SAFE_C_op_S_opSqq: if (!c_function_is_ok_cadr_caddadr(sc, sc->code)) break; + case HOP_SAFE_C_op_S_opSqq: sc->value = fx_c_op_s_opsqq(sc, sc->code); continue; /* tlet sg (splits to not) */ - case OP_SAFE_C_op_opSq_Sq: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; - case HOP_SAFE_C_op_opSq_Sq: sc->value = fx_c_op_opsq_sq(sc, sc->code); continue; /* lg cb (splits to not etc) */ + case OP_SAFE_C_op_opSq_Sq: if (!c_function_is_ok_cadr_cadadr(sc, sc->code)) break; + case HOP_SAFE_C_op_opSq_Sq: sc->value = fx_c_op_opsq_sq(sc, sc->code); continue; /* lg cb (splits to not etc) */ - 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; - case OP_SAFE_C_PS_1: op_safe_c_ps_1(sc); 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; + case OP_SAFE_C_PS_1: op_safe_c_ps_1(sc); continue; - case OP_SAFE_C_PC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_PC: op_safe_c_pc(sc); goto EVAL; - case OP_SAFE_C_PC_1: op_safe_c_pc_1(sc); continue; + case OP_SAFE_C_PC: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_PC: op_safe_c_pc(sc); goto EVAL; + case OP_SAFE_C_PC_1: op_safe_c_pc_1(sc); continue; - case OP_SAFE_C_SP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_SP: op_safe_c_sp(sc); goto EVAL; - case OP_SAFE_C_SP_1: op_safe_c_sp_1(sc); continue; + case OP_SAFE_C_SP: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_SP: op_safe_c_sp(sc); goto EVAL; + case OP_SAFE_C_SP_1: op_safe_c_sp_1(sc); continue; - case OP_SAFE_CONS_SP_1: sc->value = cons(sc, sc->args, sc->value); continue; - case OP_SAFE_ADD_SP_1: op_safe_add_sp_1(sc); continue; - case OP_SAFE_MULTIPLY_SP_1: op_safe_multiply_sp_1(sc); continue; + case OP_SAFE_CONS_SP_1: sc->value = cons(sc, sc->args, sc->value); continue; + case OP_SAFE_ADD_SP_1: op_safe_add_sp_1(sc); continue; + case OP_SAFE_MULTIPLY_SP_1: op_safe_multiply_sp_1(sc); continue; - case OP_SAFE_C_AP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_AP: if (op_safe_c_ap(sc)) goto EVAL; continue; + case OP_SAFE_C_AP: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_AP: if (op_safe_c_ap(sc)) goto EVAL; continue; - case OP_SAFE_C_PA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_PA: if (op_safe_c_pa(sc)) goto EVAL; continue; - case OP_SAFE_C_PA_1: op_safe_c_pa_1(sc); continue; + case OP_SAFE_C_PA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_PA: if (op_safe_c_pa(sc)) goto EVAL; continue; + case OP_SAFE_C_PA_1: op_safe_c_pa_1(sc); continue; - case OP_SAFE_C_CP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_CP: op_safe_c_cp(sc); goto EVAL; - /* mv case goes through opt_sp_1 to op_safe_c_sp_mv */ + case OP_SAFE_C_CP: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_CP: op_safe_c_cp(sc); goto EVAL; + /* mv case goes through opt_sp_1 to op_safe_c_sp_mv */ - case OP_SAFE_C_PP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_PP: op_safe_c_pp(sc); goto EVAL; - case OP_SAFE_C_PP_1: op_safe_c_pp_1(sc); goto EVAL; - case OP_SAFE_C_PP_3_MV: op_safe_c_pp_3_mv(sc); goto EVAL; - case OP_SAFE_C_PP_5: op_safe_c_pp_5(sc); continue; + case OP_SAFE_C_PP: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_PP: op_safe_c_pp(sc); goto EVAL; + case OP_SAFE_C_PP_1: op_safe_c_pp_1(sc); goto EVAL; + case OP_SAFE_C_PP_3_MV: op_safe_c_pp_3_mv(sc); goto EVAL; + case OP_SAFE_C_PP_5: op_safe_c_pp_5(sc); continue; - case OP_SAFE_C_3P: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_3P: op_safe_c_3p(sc); goto EVAL; - case OP_SAFE_C_3P_1: op_safe_c_3p_1(sc); goto EVAL; - case OP_SAFE_C_3P_2: op_safe_c_3p_2(sc); goto EVAL; - case OP_SAFE_C_3P_3: op_safe_c_3p_3(sc); continue; - case OP_SAFE_C_3P_1_MV: op_safe_c_3p_1_mv(sc); goto EVAL; - case OP_SAFE_C_3P_2_MV: op_safe_c_3p_2_mv(sc); goto EVAL; - case OP_SAFE_C_3P_3_MV: op_safe_c_3p_3_mv(sc); continue; + case OP_SAFE_C_3P: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_3P: op_safe_c_3p(sc); goto EVAL; + case OP_SAFE_C_3P_1: op_safe_c_3p_1(sc); goto EVAL; + case OP_SAFE_C_3P_2: op_safe_c_3p_2(sc); goto EVAL; + case OP_SAFE_C_3P_3: op_safe_c_3p_3(sc); continue; + case OP_SAFE_C_3P_1_MV: op_safe_c_3p_1_mv(sc); goto EVAL; + case OP_SAFE_C_3P_2_MV: op_safe_c_3p_2_mv(sc); goto EVAL; + case OP_SAFE_C_3P_3_MV: op_safe_c_3p_3_mv(sc); continue; - case OP_SAFE_C_opSSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq: sc->value = fx_c_opssq(sc, sc->code); continue; + case OP_SAFE_C_opSSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opSSq: sc->value = fx_c_opssq(sc, sc->code); continue; - case OP_SAFE_C_opSCq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSCq: sc->value = fx_c_opscq(sc, sc->code); continue; + case OP_SAFE_C_opSCq: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opSCq: sc->value = fx_c_opscq(sc, sc->code); continue; - case OP_SAFE_C_opCSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opCSq: sc->value = fx_c_opcsq(sc, sc->code); continue; + case OP_SAFE_C_opCSq: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opCSq: sc->value = fx_c_opcsq(sc, sc->code); continue; - case OP_SAFE_C_S_opSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opSq: sc->value = fx_c_s_opsq(sc, sc->code); continue; + case OP_SAFE_C_S_opSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; + case HOP_SAFE_C_S_opSq: sc->value = fx_c_s_opsq(sc, sc->code); continue; - case OP_SAFE_C_C_opSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opSq: sc->value = fx_c_c_opsq(sc, sc->code); continue; + case OP_SAFE_C_C_opSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; + case HOP_SAFE_C_C_opSq: sc->value = fx_c_c_opsq(sc, sc->code); continue; - case OP_SAFE_C_C_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opSSq: sc->value = fx_c_c_opssq(sc, sc->code); continue; + case OP_SAFE_C_C_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; + case HOP_SAFE_C_C_opSSq: sc->value = fx_c_c_opssq(sc, sc->code); continue; - case OP_SAFE_C_opCSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opCSq_C: sc->value = fx_c_opcsq_c(sc, sc->code); continue; + case OP_SAFE_C_opCSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opCSq_C: sc->value = fx_c_opcsq_c(sc, sc->code); continue; - case OP_SAFE_C_opSSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_C: sc->value = fx_c_opssq_c(sc, sc->code); continue; + case OP_SAFE_C_opSSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opSSq_C: sc->value = fx_c_opssq_c(sc, sc->code); continue; - 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_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_opSSqq_S: if (!c_function_is_ok_cadr_cadadr(sc, 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_opSSqq_S: if (!c_function_is_ok_cadr_cadadr(sc, 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_opSCq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSCq_C: sc->value = fx_c_opscq_c(sc, sc->code); continue; + case OP_SAFE_C_opSCq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opSCq_C: sc->value = fx_c_opscq_c(sc, sc->code); continue; - case OP_SAFE_C_opCSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opCSq_S: sc->value = fx_c_opcsq_s(sc, sc->code); continue; + case OP_SAFE_C_opCSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opCSq_S: sc->value = fx_c_opcsq_s(sc, sc->code); continue; - case OP_SAFE_C_S_opSCq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opSCq: sc->value = fx_c_s_opscq(sc, sc->code); continue; + case OP_SAFE_C_S_opSCq: if (!c_function_is_ok_caddr(sc, sc->code)) break; + case HOP_SAFE_C_S_opSCq: sc->value = fx_c_s_opscq(sc, sc->code); continue; - case OP_SAFE_C_C_opSCq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_C_opSCq: sc->value = fx_c_c_opscq(sc, sc->code); continue; + case OP_SAFE_C_C_opSCq: if (!c_function_is_ok_caddr(sc, sc->code)) break; + case HOP_SAFE_C_C_opSCq: sc->value = fx_c_c_opscq(sc, sc->code); continue; - case OP_SAFE_C_S_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opSSq: sc->value = fx_c_s_opssq(sc, sc->code); continue; + case OP_SAFE_C_S_opSSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; + case HOP_SAFE_C_S_opSSq: sc->value = fx_c_s_opssq(sc, sc->code); continue; - case OP_SAFE_C_S_opCSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; - case HOP_SAFE_C_S_opCSq: sc->value = fx_c_s_opcsq(sc, sc->code); continue; + case OP_SAFE_C_S_opCSq: if (!c_function_is_ok_caddr(sc, sc->code)) break; + case HOP_SAFE_C_S_opCSq: sc->value = fx_c_s_opcsq(sc, sc->code); continue; - case OP_SAFE_C_opSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_S: sc->value = fx_c_opsq_s(sc, sc->code); continue; + case OP_SAFE_C_opSq_S: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opSq_S: sc->value = fx_c_opsq_s(sc, sc->code); continue; - case OP_SAFE_C_opSq_CS: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_CS: sc->value = fx_c_opsq_cs(sc, sc->code); continue; + case OP_SAFE_C_opSq_CS: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opSq_CS: sc->value = fx_c_opsq_cs(sc, sc->code); continue; - case OP_SAFE_C_opSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_C: sc->value = fx_c_opsq_c(sc, sc->code); continue; + case OP_SAFE_C_opSq_C: if (!c_function_is_ok_cadr(sc, sc->code)) break; + case HOP_SAFE_C_opSq_C: sc->value = fx_c_opsq_c(sc, sc->code); continue; - case OP_SAFE_C_opSq_opSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_opSq: sc->value = fx_c_opsq_opsq(sc, sc->code); continue; + case OP_SAFE_C_opSq_opSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; + case HOP_SAFE_C_opSq_opSq: sc->value = fx_c_opsq_opsq(sc, sc->code); continue; - case OP_SAFE_C_opSSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_opSSq: sc->value = fx_c_opssq_opssq(sc, sc->code); continue; + case OP_SAFE_C_opSSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; + case HOP_SAFE_C_opSSq_opSSq: sc->value = fx_c_opssq_opssq(sc, sc->code); continue; - case OP_SAFE_C_opSSq_opSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSSq_opSq: sc->value = fx_c_opssq_opsq(sc, sc->code); continue; + case OP_SAFE_C_opSSq_opSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; + case HOP_SAFE_C_opSSq_opSq: sc->value = fx_c_opssq_opsq(sc, sc->code); continue; - case OP_SAFE_C_opSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; - case HOP_SAFE_C_opSq_opSSq: sc->value = fx_c_opsq_opssq(sc, sc->code); continue; + case OP_SAFE_C_opSq_opSSq: if (!c_function_is_ok_cadr_caddr(sc, sc->code)) break; + case HOP_SAFE_C_opSq_opSSq: sc->value = fx_c_opsq_opssq(sc, sc->code); continue; - /* semisafe c_functions */ - case OP_CL_S: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_S: inline_op_safe_c_s(sc); continue; + /* semisafe c_functions */ + case OP_CL_S: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_S: inline_op_safe_c_s(sc); continue; - case OP_CL_SS: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_SS: inline_op_safe_c_ss(sc); continue; /* safe_c case has the code we want */ + case OP_CL_SS: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_SS: inline_op_safe_c_ss(sc); continue; /* safe_c case has the code we want */ - case OP_CL_A: if (!cl_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_A); goto EVAL;} - case HOP_CL_A: op_cl_a(sc); continue; + case OP_CL_A: if (!cl_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_A); goto EVAL;} + case HOP_CL_A: op_cl_a(sc); continue; - case OP_CL_AA: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_AA: op_cl_aa(sc); continue; + case OP_CL_AA: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_AA: op_cl_aa(sc); continue; - case OP_CL_SAS: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_SAS: op_cl_sas(sc); continue; + case OP_CL_SAS: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_SAS: op_cl_sas(sc); continue; - case OP_CL_NA: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_NA: op_cl_na(sc); continue; + case OP_CL_NA: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_NA: op_cl_na(sc); continue; - case OP_CL_FA: if (!cl_function_is_ok(sc, sc->code)) break; - case HOP_CL_FA: op_cl_fa(sc); continue; /* op_c_fs was not faster if fx_s below */ - case OP_MAP_FOR_EACH_FA: op_map_for_each_fa(sc); continue; /* here only if for-each or map + one seq */ - case OP_MAP_FOR_EACH_FAA: op_map_for_each_faa(sc); continue; /* here only if for-each or map + twp seqs */ + case OP_CL_FA: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_FA: op_cl_fa(sc); continue; /* op_c_fs was not faster if fx_s below */ + case OP_MAP_FOR_EACH_FA: op_map_for_each_fa(sc); continue; /* here only if for-each or map + one seq */ + case OP_MAP_FOR_EACH_FAA: op_map_for_each_faa(sc); continue; /* here only if for-each or map + twp seqs */ - /* unsafe c_functions */ - case OP_C: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S); goto EVAL;} - case HOP_C: sc->value = fn_proc(sc->code)(sc, sc->nil); continue; + /* unsafe c_functions */ + case OP_C: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S); goto EVAL;} + case HOP_C: sc->value = fn_proc(sc->code)(sc, sc->nil); continue; - case OP_C_S: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_G); goto EVAL;} - case HOP_C_S: op_c_s(sc); continue; + case OP_C_S: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_G); goto EVAL;} + case HOP_C_S: op_c_s(sc); continue; - case OP_READ_S: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_G); goto EVAL;} - case HOP_READ_S: op_read_s(sc); continue; + case OP_READ_S: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_G); goto EVAL;} + case HOP_READ_S: op_read_s(sc); continue; - case OP_C_A: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_A); goto EVAL;} - case HOP_C_A: op_c_a(sc); continue; + case OP_C_A: if (!c_function_is_ok(sc, sc->code)) {set_optimize_op(sc->code, OP_S_A); goto EVAL;} + case HOP_C_A: op_c_a(sc); continue; - case OP_C_P: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_P: op_c_p(sc); goto EVAL; - case OP_C_P_1: sc->value = fn_proc(sc->code)(sc, list_1(sc, sc->value)); continue; + case OP_C_P: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_P: op_c_p(sc); goto EVAL; + case OP_C_P_1: sc->value = fn_proc(sc->code)(sc, list_1(sc, sc->value)); continue; - case OP_C_SS: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_SS: op_c_ss(sc); continue; + case OP_C_SS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_SS: op_c_ss(sc); continue; - case OP_C_AP: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_AP: op_c_ap(sc); goto EVAL; - case OP_C_AP_1: sc->value = fn_proc(sc->code)(sc, sc->args = list_2(sc, sc->args, sc->value)); continue; + case OP_C_AP: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_AP: op_c_ap(sc); goto EVAL; + case OP_C_AP_1: sc->value = fn_proc(sc->code)(sc, sc->args = list_2(sc, sc->args, sc->value)); continue; - case OP_C_AA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_AA: op_c_aa(sc); continue; + case OP_C_AA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_AA: op_c_aa(sc); continue; - case OP_C_NC: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_NC: op_c_nc(sc); continue; - case OP_C_NA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_C_NA: op_c_na(sc); continue; + case OP_C_NC: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_NC: op_c_nc(sc); continue; + case OP_C_NA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_NA: op_c_na(sc); continue; - case OP_APPLY_SS: inline_op_apply_ss(sc); goto APPLY; - case OP_APPLY_SA: op_apply_sa(sc); goto APPLY; - case OP_APPLY_SL: op_apply_sl(sc); goto APPLY; + case OP_APPLY_SS: inline_op_apply_ss(sc); goto APPLY; + case OP_APPLY_SA: op_apply_sa(sc); goto APPLY; + case OP_APPLY_SL: op_apply_sl(sc); goto APPLY; - case OP_CALL_WITH_EXIT: op_call_with_exit(sc); goto BEGIN; - case OP_CALL_CC: op_call_cc(sc); goto BEGIN; - case OP_CALL_WITH_EXIT_O: op_call_with_exit_o(sc); goto EVAL; - case OP_C_CATCH: op_c_catch(sc); goto BEGIN; - case OP_C_CATCH_ALL: op_c_catch_all(sc); goto BEGIN; - case OP_C_CATCH_ALL_O: op_c_catch_all(sc); goto EVAL; - case OP_C_CATCH_ALL_A: op_c_catch_all_a(sc); continue; + case OP_CALL_WITH_EXIT: op_call_with_exit(sc); goto BEGIN; + case OP_CALL_CC: op_call_cc(sc); goto BEGIN; + case OP_CALL_WITH_EXIT_O: op_call_with_exit_o(sc); goto EVAL; + case OP_C_CATCH: op_c_catch(sc); goto BEGIN; + case OP_C_CATCH_ALL: op_c_catch_all(sc); goto BEGIN; + case OP_C_CATCH_ALL_O: op_c_catch_all(sc); goto EVAL; + case OP_C_CATCH_ALL_A: op_c_catch_all_a(sc); continue; - case OP_WITH_IO: if (op_with_io_op(sc)) goto EVAL; goto BEGIN; - case OP_WITH_IO_1: - if (!is_string(sc->value)) {op_with_io_1_method(sc); continue;} - sc->code = op_with_io_1(sc); - goto BEGIN; + case OP_WITH_IO: if (op_with_io_op(sc)) goto EVAL; goto BEGIN; + case OP_WITH_IO_1: + if (!is_string(sc->value)) {op_with_io_1_method(sc); continue;} + sc->code = op_with_io_1(sc); + goto BEGIN; - case OP_WITH_IO_C: sc->value = cadr(sc->code); sc->code = op_with_io_1(sc); goto BEGIN; - case OP_WITH_OUTPUT_TO_STRING: op_with_output_to_string(sc); goto BEGIN; - case OP_CALL_WITH_OUTPUT_STRING: op_call_with_output_string(sc); goto BEGIN; + case OP_WITH_IO_C: sc->value = cadr(sc->code); sc->code = op_with_io_1(sc); goto BEGIN; + case OP_WITH_OUTPUT_TO_STRING: op_with_output_to_string(sc); goto BEGIN; + case OP_CALL_WITH_OUTPUT_STRING: op_call_with_output_string(sc); goto BEGIN; - case OP_F: op_f(sc); goto BEGIN; - case OP_F_A: op_f_a(sc); goto BEGIN; - case OP_F_AA: op_f_aa(sc); goto BEGIN; - case OP_F_NP: op_f_np(sc); goto EVAL; - case OP_F_NP_1: if (op_f_np_1(sc)) goto EVAL; goto BEGIN; + case OP_F: op_f(sc); goto BEGIN; + case OP_F_A: op_f_a(sc); goto BEGIN; + case OP_F_AA: op_f_aa(sc); goto BEGIN; + case OP_F_NP: op_f_np(sc); goto EVAL; + case OP_F_NP_1: if (op_f_np_1(sc)) goto EVAL; goto BEGIN; - case OP_S: op_s(sc); goto APPLY; - case OP_S_G: if (op_s_g(sc)) continue; goto APPLY; - case OP_S_A: if (op_x_a(sc, lookup_checked(sc, car(sc->code)))) continue; goto APPLY; - case OP_A_A: if (op_x_a(sc, fx_call(sc, sc->code))) continue; goto APPLY; - case OP_S_AA: if (op_x_aa(sc, lookup_checked(sc, car(sc->code)))) continue; goto APPLY; - case OP_A_AA: if (op_x_aa(sc, fx_call(sc, sc->code))) continue; goto APPLY; - case OP_A_SC: if (op_x_sc(sc, fx_call(sc, sc->code))) continue; goto APPLY; - case OP_P_S: push_stack_no_args_direct(sc, OP_P_S_1); sc->code = car(sc->code); goto EVAL; - case OP_P_S_1: op_p_s_1(sc); goto APPLY; + case OP_S: op_s(sc); goto APPLY; + case OP_S_G: if (op_s_g(sc)) continue; goto APPLY; + case OP_S_A: if (op_x_a(sc, lookup_checked(sc, car(sc->code)))) continue; goto APPLY; + case OP_A_A: if (op_x_a(sc, fx_call(sc, sc->code))) continue; goto APPLY; + case OP_S_AA: if (op_x_aa(sc, lookup_checked(sc, car(sc->code)))) continue; goto APPLY; + case OP_A_AA: if (op_x_aa(sc, fx_call(sc, sc->code))) continue; goto APPLY; + case OP_A_SC: if (op_x_sc(sc, fx_call(sc, sc->code))) continue; goto APPLY; + case OP_P_S: push_stack_no_args_direct(sc, OP_P_S_1); sc->code = car(sc->code); goto EVAL; + case OP_P_S_1: op_p_s_1(sc); goto APPLY; - case OP_SAFE_C_STAR: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR: op_safe_c_star(sc); continue; + case OP_SAFE_C_STAR: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_STAR: op_safe_c_star(sc); continue; - case OP_SAFE_C_STAR_A: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR_A: op_safe_c_star_a(sc); continue; + case OP_SAFE_C_STAR_A: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_STAR_A: op_safe_c_star_a(sc); continue; - case OP_SAFE_C_STAR_AA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR_AA: op_safe_c_star_aa(sc); continue; + case OP_SAFE_C_STAR_AA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_STAR_AA: op_safe_c_star_aa(sc); continue; - case OP_SAFE_C_STAR_NA: if (!c_function_is_ok(sc, sc->code)) break; - case HOP_SAFE_C_STAR_NA: op_safe_c_star_na(sc); continue; + case OP_SAFE_C_STAR_NA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_STAR_NA: op_safe_c_star_na(sc); continue; - case OP_THUNK: if (!closure_is_ok(sc, sc->code, FINE_UNSAFE_CLOSURE, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_THUNK: op_thunk(sc); goto EVAL; + case OP_THUNK: if (!closure_is_ok(sc, sc->code, FINE_UNSAFE_CLOSURE, 0)) {if (op_unknown(sc)) goto EVAL; continue;} + case HOP_THUNK: op_thunk(sc); goto EVAL; - case OP_THUNK_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_THUNK_O: op_thunk_o(sc); goto EVAL; + case OP_THUNK_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 0)) {if (op_unknown(sc)) goto EVAL; continue;} + case HOP_THUNK_O: op_thunk_o(sc); goto EVAL; - case OP_SAFE_THUNK: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_SAFE_THUNK: op_safe_thunk(sc); goto EVAL; + case OP_SAFE_THUNK: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 0)) {if (op_unknown(sc)) goto EVAL; continue;} + case HOP_SAFE_THUNK: op_safe_thunk(sc); goto EVAL; - case OP_THUNK_ANY: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) break; /* symbol as arglist */ - case HOP_THUNK_ANY: op_thunk_any(sc); goto BEGIN; + case OP_THUNK_ANY: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) break; /* symbol as arglist */ + case HOP_THUNK_ANY: op_thunk_any(sc); goto BEGIN; - case OP_SAFE_THUNK_ANY: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) break; /* symbol as arglist */ - case HOP_SAFE_THUNK_ANY: op_safe_thunk_any(sc); goto EVAL; + case OP_SAFE_THUNK_ANY: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) break; /* symbol as arglist */ + case HOP_SAFE_THUNK_ANY: op_safe_thunk_any(sc); goto EVAL; - case OP_SAFE_THUNK_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_SAFE_THUNK_A: sc->value = op_safe_thunk_a(sc, sc->code); continue; + case OP_SAFE_THUNK_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 0)) {if (op_unknown(sc)) goto EVAL; continue;} + case HOP_SAFE_THUNK_A: sc->value = op_safe_thunk_a(sc, sc->code); continue; - case OP_CLOSURE_S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_CLOSURE_S: op_closure_s(sc); goto EVAL; + case OP_CLOSURE_S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_CLOSURE_S: op_closure_s(sc); goto EVAL; - case OP_CLOSURE_S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_CLOSURE_S_O: op_closure_s_o(sc); goto EVAL; + case OP_CLOSURE_S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_CLOSURE_S_O: op_closure_s_o(sc); goto EVAL; - case OP_SAFE_CLOSURE_S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S: op_safe_closure_s(sc); goto EVAL; + case OP_SAFE_CLOSURE_S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_S: op_safe_closure_s(sc); goto EVAL; - case OP_SAFE_CLOSURE_S_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S_O: op_safe_closure_s_o(sc); goto EVAL; + case OP_SAFE_CLOSURE_S_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_S_O: op_safe_closure_s_o(sc); goto EVAL; - case OP_SAFE_CLOSURE_S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S_A: sc->value = op_safe_closure_s_a(sc, sc->code); continue; + case OP_SAFE_CLOSURE_S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_S_A: sc->value = op_safe_closure_s_a(sc, sc->code); continue; - case OP_SAFE_CLOSURE_S_TO_S: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_s(sc)) goto EVAL; continue;} - 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_S: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_s(sc)) goto EVAL; continue;} + 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 ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_s(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_S_TO_SC: sc->value = fx_proc(cdr(sc->code))(sc, sc->code); continue; + case OP_SAFE_CLOSURE_S_TO_SC: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_s(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_S_TO_SC: sc->value = fx_proc(cdr(sc->code))(sc, sc->code); continue; - case OP_SAFE_CLOSURE_A_TO_SC: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_A_TO_SC: sc->value = fx_proc(sc->code)(sc, sc->code); continue; + case OP_SAFE_CLOSURE_A_TO_SC: if ((symbol_ctr(car(sc->code)) > 1) && (!closure_is_eq(sc))) {if (op_unknown_a(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_A_TO_SC: sc->value = fx_proc(sc->code)(sc, sc->code); continue; - case OP_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {if (op_unknown_np(sc)) goto EVAL; continue;} - 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: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {if (op_unknown_np(sc)) goto EVAL; continue;} + case HOP_CLOSURE_P: op_closure_p(sc); goto EVAL; + case OP_CLOSURE_P_1: op_closure_p_1(sc); goto BEGIN; - case OP_SAFE_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_P: op_safe_closure_p(sc); goto EVAL; - case OP_SAFE_CLOSURE_P_1: op_safe_closure_p_1(sc); goto BEGIN; + case OP_SAFE_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_np(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_P: op_safe_closure_p(sc); goto EVAL; + case OP_SAFE_CLOSURE_P_1: op_safe_closure_p_1(sc); goto BEGIN; - case OP_SAFE_CLOSURE_P_A: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_P_A: op_safe_closure_p_a(sc); goto EVAL; - case OP_SAFE_CLOSURE_P_A_1: op_safe_closure_p_a_1(sc); continue; + case OP_SAFE_CLOSURE_P_A: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {if (op_unknown_np(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_P_A: op_safe_closure_p_a(sc); goto EVAL; + case OP_SAFE_CLOSURE_P_A_1: op_safe_closure_p_a_1(sc); continue; - case OP_CLOSURE_A: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_CLOSURE_A: inline_op_closure_a(sc); push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); sc->code = car(sc->code); goto EVAL; + case OP_CLOSURE_A: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} + case HOP_CLOSURE_A: inline_op_closure_a(sc); push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code))); sc->code = car(sc->code); goto EVAL; - case OP_CLOSURE_A_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_CLOSURE_A_O: inline_op_closure_a(sc); sc->code = car(sc->code); goto EVAL; + case OP_CLOSURE_A_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} + case HOP_CLOSURE_A_O: inline_op_closure_a(sc); sc->code = car(sc->code); goto EVAL; - case OP_SAFE_CLOSURE_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_A: op_safe_closure_a(sc); goto EVAL; + case OP_SAFE_CLOSURE_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_A: op_safe_closure_a(sc); goto EVAL; - case OP_SAFE_CLOSURE_A_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_A_O: op_safe_closure_a_o(sc); goto EVAL; + case OP_SAFE_CLOSURE_A_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_A_O: op_safe_closure_a_o(sc); goto EVAL; - case OP_SAFE_CLOSURE_A_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_A_A: sc->value = op_safe_closure_a_a(sc, sc->code); continue; + case OP_SAFE_CLOSURE_A_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_A_A: sc->value = op_safe_closure_a_a(sc, sc->code); continue; - case OP_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - 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: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} + 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_PA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - 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: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} + 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_PP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_CLOSURE_PP: op_closure_pp(sc); goto EVAL; - case OP_CLOSURE_PP_1: op_closure_pp_1(sc); goto EVAL; + case OP_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} + 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)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AP: op_safe_closure_ap(sc); goto EVAL; - case OP_SAFE_CLOSURE_AP_1: op_safe_closure_ap_1(sc); goto BEGIN; + case OP_SAFE_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_AP: op_safe_closure_ap(sc); goto EVAL; + case OP_SAFE_CLOSURE_AP_1: op_safe_closure_ap_1(sc); goto BEGIN; - case OP_SAFE_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} - 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_PA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} + 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)) {if (op_unknown_np(sc)) goto EVAL; continue;} - 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; + case OP_SAFE_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {if (op_unknown_np(sc)) goto EVAL; continue;} + 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; - case OP_ANY_CLOSURE_3P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_ANY_CLOSURE_3P: op_any_closure_3p(sc); goto EVAL; - case OP_ANY_CLOSURE_3P_1: if (!op_any_closure_3p_1(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_3P_2: if (!op_any_closure_3p_2(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_3P_3: op_any_closure_3p_3(sc); goto BEGIN; + case OP_ANY_CLOSURE_3P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_np(sc)) goto EVAL; continue;} + case HOP_ANY_CLOSURE_3P: op_any_closure_3p(sc); goto EVAL; + case OP_ANY_CLOSURE_3P_1: if (!op_any_closure_3p_1(sc)) goto EVAL; goto BEGIN; + case OP_ANY_CLOSURE_3P_2: if (!op_any_closure_3p_2(sc)) goto EVAL; goto BEGIN; + case OP_ANY_CLOSURE_3P_3: op_any_closure_3p_3(sc); goto BEGIN; - case OP_ANY_CLOSURE_4P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 4)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_ANY_CLOSURE_4P: op_any_closure_4p(sc); goto EVAL; - case OP_ANY_CLOSURE_4P_1: if (!op_any_closure_4p_1(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_4P_2: if (!op_any_closure_4p_2(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_4P_3: if (!op_any_closure_4p_3(sc)) goto EVAL; goto BEGIN; - case OP_ANY_CLOSURE_4P_4: op_any_closure_4p_4(sc); goto BEGIN; + case OP_ANY_CLOSURE_4P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 4)) {if (op_unknown_np(sc)) goto EVAL; continue;} + case HOP_ANY_CLOSURE_4P: op_any_closure_4p(sc); goto EVAL; + case OP_ANY_CLOSURE_4P_1: if (!op_any_closure_4p_1(sc)) goto EVAL; goto BEGIN; + case OP_ANY_CLOSURE_4P_2: if (!op_any_closure_4p_2(sc)) goto EVAL; goto BEGIN; + case OP_ANY_CLOSURE_4P_3: if (!op_any_closure_4p_3(sc)) goto EVAL; goto BEGIN; + case OP_ANY_CLOSURE_4P_4: op_any_closure_4p_4(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; + 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; - case OP_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SS: op_closure_ss(sc); goto EVAL; + case OP_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} + case HOP_CLOSURE_SS: op_closure_ss(sc); goto EVAL; - case OP_CLOSURE_SS_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SS_O: op_closure_ss_o(sc); goto EVAL; + case OP_CLOSURE_SS_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} + case HOP_CLOSURE_SS_O: op_closure_ss_o(sc); goto EVAL; - case OP_SAFE_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SS: op_safe_closure_ss(sc); goto EVAL; + case OP_SAFE_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_SS: op_safe_closure_ss(sc); goto EVAL; - case OP_SAFE_CLOSURE_SS_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SS_O: op_safe_closure_ss_o(sc); goto EVAL; + case OP_SAFE_CLOSURE_SS_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_SS_O: op_safe_closure_ss_o(sc); goto EVAL; - case OP_SAFE_CLOSURE_SS_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SS_A: sc->value = op_safe_closure_ss_a(sc, sc->code); continue; + case OP_SAFE_CLOSURE_SS_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_SS_A: sc->value = op_safe_closure_ss_a(sc, sc->code); continue; - case OP_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_3S: op_closure_3s(sc); goto EVAL; /* "fine" here means changing func (as arg) does not constantly call op_unknown_ns */ + case OP_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} + case HOP_CLOSURE_3S: op_closure_3s(sc); goto EVAL; /* "fine" here means changing func (as arg) does not constantly call op_unknown_ns */ - case OP_CLOSURE_3S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_3S_O: op_closure_3s_o(sc); goto EVAL; + case OP_CLOSURE_3S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} + case HOP_CLOSURE_3S_O: op_closure_3s_o(sc); goto EVAL; - case OP_CLOSURE_4S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_4S: op_closure_4s(sc); goto EVAL; + case OP_CLOSURE_4S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {if (op_unknown_ns(sc)) goto EVAL; continue;} + case HOP_CLOSURE_4S: op_closure_4s(sc); goto EVAL; - case OP_CLOSURE_4S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 4)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_4S_O: op_closure_4s_o(sc); goto EVAL; + case OP_CLOSURE_4S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 4)) {if (op_unknown_ns(sc)) goto EVAL; continue;} + case HOP_CLOSURE_4S_O: op_closure_4s_o(sc); goto EVAL; - case OP_CLOSURE_5S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 5)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_5S: op_closure_5s(sc); goto EVAL; + case OP_CLOSURE_5S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 5)) {if (op_unknown_ns(sc)) goto EVAL; continue;} + case HOP_CLOSURE_5S: op_closure_5s(sc); goto EVAL; - case OP_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SC: op_closure_sc(sc); goto EVAL; + case OP_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} + case HOP_CLOSURE_SC: op_closure_sc(sc); goto EVAL; - case OP_CLOSURE_SC_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SC_O: op_closure_sc_o(sc); goto EVAL; + case OP_CLOSURE_SC_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} + case HOP_CLOSURE_SC_O: op_closure_sc_o(sc); goto EVAL; - case OP_SAFE_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SC: op_safe_closure_sc(sc); goto EVAL; + case OP_SAFE_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_SC: op_safe_closure_sc(sc); goto EVAL; - case OP_SAFE_CLOSURE_SC_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SC_O: op_safe_closure_sc_o(sc); goto EVAL; + case OP_SAFE_CLOSURE_SC_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_gg(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_SC_O: op_safe_closure_sc_o(sc); goto EVAL; - case OP_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_CLOSURE_AA: op_closure_aa(sc); goto EVAL; + case OP_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_CLOSURE_AA: op_closure_aa(sc); goto EVAL; - case OP_CLOSURE_AA_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_CLOSURE_AA_O: inline_op_closure_aa_o(sc); goto EVAL; + case OP_CLOSURE_AA_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_CLOSURE_AA_O: inline_op_closure_aa_o(sc); goto EVAL; - case OP_SAFE_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AA: op_safe_closure_aa(sc); goto EVAL; + case OP_SAFE_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_AA: op_safe_closure_aa(sc); goto EVAL; - case OP_SAFE_CLOSURE_AA_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AA_O: op_safe_closure_aa_o(sc); goto EVAL; + case OP_SAFE_CLOSURE_AA_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_AA_O: op_safe_closure_aa_o(sc); goto EVAL; - case OP_SAFE_CLOSURE_AA_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AA_A: sc->value = fx_safe_closure_aa_a(sc, sc->code); continue; + case OP_SAFE_CLOSURE_AA_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_AA_A: sc->value = fx_safe_closure_aa_a(sc, sc->code); continue; - case OP_SAFE_CLOSURE_SSA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SSA: op_safe_closure_ssa(sc); goto EVAL; + case OP_SAFE_CLOSURE_SSA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_SSA: op_safe_closure_ssa(sc); goto EVAL; - case OP_SAFE_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_SAA: op_safe_closure_saa(sc); goto EVAL; + case OP_SAFE_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_SAA: op_safe_closure_saa(sc); goto EVAL; - case OP_SAFE_CLOSURE_AGG: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_AGG: op_safe_closure_agg(sc); goto EVAL; + case OP_SAFE_CLOSURE_AGG: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_AGG: op_safe_closure_agg(sc); goto EVAL; - case OP_SAFE_CLOSURE_3A: if (!closure_is_ok(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_3A: op_safe_closure_3a(sc); goto EVAL; + case OP_SAFE_CLOSURE_3A: if (!closure_is_ok(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_3A: op_safe_closure_3a(sc); goto EVAL; - case OP_SAFE_CLOSURE_NS: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_NS: op_safe_closure_ns(sc); goto EVAL; + case OP_SAFE_CLOSURE_NS: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_ns(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_NS: op_safe_closure_ns(sc); goto EVAL; - case OP_SAFE_CLOSURE_NA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_NA: op_safe_closure_na(sc); goto EVAL; + case OP_SAFE_CLOSURE_NA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_NA: op_safe_closure_na(sc); goto EVAL; - case OP_SAFE_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_3S: op_safe_closure_3s(sc); goto EVAL; + case OP_SAFE_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_3S: op_safe_closure_3s(sc); goto EVAL; - case OP_SAFE_CLOSURE_3S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_3S_A: sc->value = op_safe_closure_3s_a(sc, sc->code); continue; + case OP_SAFE_CLOSURE_3S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 3)) {if (op_unknown_ns(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_3S_A: sc->value = op_safe_closure_3s_a(sc, sc->code); continue; - case OP_CLOSURE_NS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_ns(sc)) goto EVAL; continue;} - case HOP_CLOSURE_NS: op_closure_ns(sc); goto EVAL; + case OP_CLOSURE_NS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_ns(sc)) goto EVAL; continue;} + case HOP_CLOSURE_NS: op_closure_ns(sc); goto EVAL; - case OP_CLOSURE_ASS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_ASS: op_closure_ass(sc); goto EVAL; + case OP_CLOSURE_ASS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_CLOSURE_ASS: op_closure_ass(sc); goto EVAL; - case OP_CLOSURE_AAS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_AAS: op_closure_aas(sc); goto EVAL; + case OP_CLOSURE_AAS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_CLOSURE_AAS: op_closure_aas(sc); goto EVAL; - case OP_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SAA: op_closure_saa(sc); goto EVAL; - - case OP_CLOSURE_ASA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_ASA: op_closure_asa(sc); goto EVAL; - - case OP_CLOSURE_SAS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_SAS: op_closure_sas(sc); goto EVAL; - - case OP_CLOSURE_3A: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_3A: op_closure_3a(sc); goto EVAL; - - case OP_CLOSURE_4A: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_4A: op_closure_4a(sc); goto EVAL; - - case OP_CLOSURE_NA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_NA: op_closure_na(sc); goto EVAL; - - case OP_ANY_CLOSURE_NP: if (!closure_np_is_ok(sc, sc->code)) {if (op_unknown_np(sc)) goto EVAL; continue;} - case HOP_ANY_CLOSURE_NP: op_any_closure_np(sc); goto EVAL; - case OP_ANY_CLOSURE_NP_1: - if (!(inline_collect_np_args(sc, OP_ANY_CLOSURE_NP_1, cons(sc, sc->value, sc->args)))) - op_any_closure_np_end(sc); - goto EVAL; - case OP_ANY_CLOSURE_NP_2: - sc->args = cons(sc, sc->value, sc->args); - op_any_closure_np_end(sc); - goto EVAL; - - case OP_ANY_CLOSURE_SYM: if (!check_closure_sym(sc, 1)) break; /* (lambda args ...) */ - case HOP_ANY_CLOSURE_SYM: op_any_closure_sym(sc); goto BEGIN; - case OP_ANY_CLOSURE_A_SYM: if (!check_closure_sym(sc, 2)) break; /* (lambda (a . args) ...) */ - case HOP_ANY_CLOSURE_A_SYM: op_any_closure_a_sym(sc); goto BEGIN; - - - case OP_TC_AND_A_OR_A_LA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_la(sc, sc->code); continue; - case OP_TC_AND_A_OR_A_LAA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_laa(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_LAA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_laa(sc, sc->code); continue; - case OP_TC_AND_A_OR_A_L3A: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_l3a(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_L3A: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_l3a(sc, sc->code); continue; - case OP_TC_AND_A_OR_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_A_AND_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_a_and_a_a_la(sc, sc->code); continue; - case OP_TC_OR_A_AND_A_A_L3A: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_a_l3a(sc, sc->code); continue; - - case OP_TC_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_la(sc, sc->code, false)) continue; goto EVAL; - case OP_TC_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_la_z(sc, sc->code, false)) continue; goto EVAL; - case OP_TC_COND_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_la(sc, sc->code, true)) continue; goto EVAL; - case OP_TC_COND_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_la_z(sc, sc->code, true)) continue; goto EVAL; - - case OP_TC_IF_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, false, TC_IF)) continue; goto EVAL; - case OP_TC_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, true, TC_IF)) continue; goto EVAL; - case OP_TC_COND_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, true, TC_COND)) continue; goto EVAL; - case OP_TC_COND_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, false, TC_COND)) continue; goto EVAL; - case OP_TC_WHEN_LA: tick_tc(sc, sc->cur_op); op_tc_when_la(sc, sc->code); continue; - case OP_TC_WHEN_LAA: tick_tc(sc, sc->cur_op); op_tc_when_laa(sc, sc->code); continue; - case OP_TC_WHEN_L3A: tick_tc(sc, sc->cur_op); op_tc_when_l3a(sc, sc->code); continue; - - case OP_TC_IF_A_Z_L3A: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_l3a(sc, sc->code, true)) continue; goto EVAL; - case OP_TC_IF_A_L3A_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_l3a(sc, sc->code, false)) continue; goto EVAL; - - case OP_TC_IF_A_Z_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_IF)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_IF)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_COND)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_COND))continue; goto EVAL; - case OP_TC_AND_A_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_AND)) continue; goto EVAL; - case OP_TC_AND_A_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_AND)) continue; goto EVAL; - - case OP_TC_IF_A_Z_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); 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(sc, sc->cur_op); if (op_tc_if_a_z_if_a_laa_z(sc, false, sc->code)) continue; goto EVAL; - case OP_TC_COND_A_Z_A_Z_LAA: tick_tc(sc, sc->cur_op); 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_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_laa_z(sc, true, sc->code)) continue; goto EVAL; - - case OP_TC_LET_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_let_if_a_z_la(sc, sc->code)) continue; goto EVAL; - case OP_TC_LET_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_LET_WHEN_LAA: tick_tc(sc, sc->cur_op); op_tc_let_when_laa(sc, true, sc->code); continue; - case OP_TC_LET_UNLESS_LAA: tick_tc(sc, sc->cur_op); op_tc_let_when_laa(sc, false, sc->code); continue; - - case OP_TC_COND_A_Z_A_LAA_LAA: tick_tc(sc, sc->cur_op); if (op_tc_cond_a_z_a_laa_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_IF_A_L3A_L3A: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_l3a_l3a(sc, sc->code)) continue; goto EVAL; - case OP_TC_IF_A_Z_LET_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; - case OP_TC_CASE_LA: tick_tc(sc, sc->cur_op); if (op_tc_case_la(sc, sc->code)) continue; goto BEGIN; - case OP_TC_LET_COND: tick_tc(sc, sc->cur_op); if (op_tc_let_cond(sc, sc->code)) continue; goto EVAL; - - case OP_RECUR_IF_A_A_opA_LAq: wrap_recur_if_a_a_opa_laq(sc, true, true); continue; - case OP_RECUR_IF_A_A_opLA_Aq: wrap_recur_if_a_a_opa_laq(sc, true, false); continue; - case OP_RECUR_IF_A_opA_LAq_A: wrap_recur_if_a_a_opa_laq(sc, false, true); continue; - case OP_RECUR_IF_A_opLA_Aq_A: wrap_recur_if_a_a_opa_laq(sc, false, false); 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; - case OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq: wrap_recur(sc, op_recur_if_a_a_if_a_laa_opa_laaq); continue; - case OP_RECUR_IF_A_A_IF_A_A_opLA_LAq: wrap_recur(sc, op_recur_if_a_a_if_a_a_opla_laq); continue; - case OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq: wrap_recur(sc, op_recur_if_a_a_if_a_a_oplaa_laaq); continue; - case OP_RECUR_COND_A_A_opA_LAq: wrap_recur(sc, op_recur_cond_a_a_opa_laq); continue; - case OP_RECUR_COND_A_A_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_opa_laaq); continue; - case OP_RECUR_COND_A_A_A_A_opLA_LAq: wrap_recur(sc, op_recur_cond_a_a_a_a_opla_laq); continue; - case OP_RECUR_COND_A_A_A_A_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_a_opa_laaq); continue; - case OP_RECUR_COND_A_A_A_A_opLAA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_a_oplaa_laaq); continue; - case OP_RECUR_COND_A_A_A_LAA_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_laa_opa_laaq); continue; - case OP_RECUR_COND_A_A_A_LAA_LopA_LAAq: wrap_recur_cond_a_a_a_laa_lopa_laaq(sc); continue; - case OP_RECUR_AND_A_OR_A_LAA_LAA: wrap_recur(sc, op_recur_and_a_or_a_laa_laa); continue; - - - case OP_SAFE_CLOSURE_STAR_A: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_A: op_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)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_A1: op_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)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_KA: op_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)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_AA: op_safe_closure_star_aa(sc, sc->code); goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_AA_O: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_AA_O: op_safe_closure_star_aa(sc, sc->code); sc->code = car(sc->code); goto EVAL; - - case OP_SAFE_CLOSURE_STAR_3A: if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_3A: if (op_safe_closure_star_aaa(sc, sc->code)) goto EVAL; goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_NA: - if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? opt3_arglen(cdr(sc->code)) : 0)) - {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_NA: if (op_safe_closure_star_na(sc, sc->code)) goto EVAL; goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_NA_0: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 0)) {if (op_unknown(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_NA_0: if (op_safe_closure_star_na_0(sc, sc->code)) goto EVAL; goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_NA_1: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_NA_1: if (op_safe_closure_star_na_1(sc, sc->code)) goto EVAL; goto BEGIN; - - case OP_SAFE_CLOSURE_STAR_NA_2: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} - case HOP_SAFE_CLOSURE_STAR_NA_2: if (op_safe_closure_star_na_2(sc, sc->code)) goto EVAL; goto BEGIN; - - - case OP_CLOSURE_STAR_A: if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} - case HOP_CLOSURE_STAR_A: 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_aa(sc)) goto EVAL; continue;} - case HOP_CLOSURE_STAR_KA: op_closure_star_ka(sc, sc->code); goto BEGIN; - - case OP_CLOSURE_STAR_NA: - if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? opt3_arglen(cdr(sc->code)) : 0)) - {if (op_unknown_na(sc)) goto EVAL; continue;} - case HOP_CLOSURE_STAR_NA: if (op_closure_star_na(sc, sc->code)) goto EVAL; goto BEGIN; - - - case OP_UNKNOWN: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown(sc)) goto EVAL; continue; - case OP_UNKNOWN_NS: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_ns(sc)) goto EVAL; continue; - case OP_UNKNOWN_S: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_s(sc)) goto EVAL; continue; - case OP_UNKNOWN_GG: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_gg(sc)) goto EVAL; continue; - case OP_UNKNOWN_A: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_a(sc)) goto EVAL; continue; - case OP_UNKNOWN_AA: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_aa(sc)) goto EVAL; continue; - case OP_UNKNOWN_NA: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_na(sc)) goto EVAL; continue; - case OP_UNKNOWN_NP: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_np(sc)) goto EVAL; continue; - - - case OP_IMPLICIT_VECTOR_REF_A: if (!inline_op_implicit_vector_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_VECTOR_REF_AA: if (!op_implicit_vector_ref_aa(sc)) {if (op_unknown_aa(sc)) goto EVAL;} continue; - case OP_IMPLICIT_STRING_REF_A: if (!op_implicit_string_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_HASH_TABLE_REF_A: if (!op_implicit_hash_table_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_HASH_TABLE_REF_AA: if (!op_implicit_hash_table_ref_aa(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_CONTINUATION_A: if (!op_implicit_continuation_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_ITERATE: if (!op_implicit_iterate(sc)) {if (op_unknown(sc)) goto EVAL;} continue; - case OP_IMPLICIT_LET_REF_C: if (!op_implicit_let_ref_c(sc)) {if ((has_fx(cdr(sc->code))) && (op_unknown_a(sc))) goto EVAL;} continue; - case OP_IMPLICIT_LET_REF_A: if (!op_implicit_let_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_PAIR_REF_A: if (!op_implicit_pair_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_PAIR_REF_AA: if (!op_implicit_pair_ref_aa(sc)) {if (op_unknown_aa(sc)) goto EVAL;} continue; - case OP_IMPLICIT_C_OBJECT_REF_A: if (!op_implicit_c_object_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_GOTO: if (!op_implicit_goto(sc)) {if (op_unknown(sc)) goto EVAL;} continue; - case OP_IMPLICIT_GOTO_A: if (!op_implicit_goto_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; - case OP_IMPLICIT_VECTOR_SET_3: if (op_implicit_vector_set_3(sc)) goto EVAL; continue; - case OP_IMPLICIT_VECTOR_SET_4: if (op_implicit_vector_set_4(sc)) goto EVAL; continue; - case OP_IMPLICIT_S7_STARLET_REF_S: sc->value = s7_starlet(sc, opt3_int(sc->code)); continue; - case OP_IMPLICIT_S7_STARLET_SET: sc->value = s7_starlet_set_1(sc, opt3_sym(sc->code), fx_call(sc, cddr(sc->code))); continue; - - case OP_UNOPT: goto UNOPT; - case OP_SYMBOL: sc->value = lookup_checked(sc, sc->code); continue; - case OP_CONSTANT: sc->value = sc->code; continue; - case OP_PAIR_PAIR: if (op_pair_pair(sc)) goto EVAL; continue; /* car is pair ((if x car cadr) ...) */ - case OP_PAIR_ANY: sc->value = car(sc->code); goto EVAL_ARGS_TOP; - case OP_PAIR_SYM: if (op_pair_sym(sc)) goto EVAL_ARGS_TOP; continue; - - case OP_EVAL_SET1_NO_MV: - sc->args = list_1(sc, sc->value); - goto APPLY; /* args = (val), code = setter */ - - case OP_EVAL_SET2_NO_MV: sc->args = pair_append(sc, sc->args, list_1(sc, sc->value)); goto APPLY; /* <val> is a normal value */ - /* perhaps in_place is safe here: args=list_1(sc->value) if eval_set2, mv if eval_set2_mv */ - - case OP_EVAL_SET2_MV: /* <inds> = sc->value is a mv */ - push_stack(sc, OP_EVAL_SET2_NO_MV, sc->value, sc->code); /* sc->value = inds */ - goto EVAL_SET2; - - case OP_EVAL_SET2: /* <ind> = sc->value is a normal value */ - push_stack(sc, OP_EVAL_SET2_NO_MV, list_1(sc, sc->value), sc->code); /* sc->value = ind */ - EVAL_SET2: - sc->code = sc->args; /* value */ - sc->cur_op = optimize_op(sc->code); - goto TOP_NO_POP; - - case OP_EVAL_SET3_NO_MV: op_eval_set3_no_mv(sc); goto APPLY; /* <val> is a normal value */ - - case OP_EVAL_SET3_MV: /* <inds> = sc->value is a mv */ - sc->args = (is_null(sc->args)) ? sc->value : pair_append(sc, sc->args, T_Lst(sc->value)); - goto EVAL_SET3; - - case OP_EVAL_SET3: /* <ind> = sc->value is a normal value */ - sc->args = (is_null(sc->args)) ? list_1(sc, sc->value) : pair_append(sc, sc->args, list_1(sc, sc->value)); /* not in_place here */ - EVAL_SET3: - op_eval_set3(sc); - goto TOP_NO_POP; - - case OP_EVAL_ARGS1: sc->args = cons(sc, sc->value, sc->args); goto EVAL_ARGS; - case OP_EVAL_ARGS2: op_eval_args2(sc); goto APPLY; /* sc->value is the last arg, [so if is_null(cdr(sc->code) and current is pair, push args2] */ - case OP_EVAL_ARGS3: op_eval_args3(sc); goto APPLY; /* sc->value is the next-to-last arg, and the last arg is not a list (so values can't mess us up!) */ - case OP_EVAL_ARGS4: sc->args = cons(sc, sc->value, sc->args); goto EVAL_ARGS_PAIR; - case OP_EVAL_ARGS5: op_eval_args5(sc); goto APPLY; - - EVAL_ARGS_TOP: - case OP_EVAL_ARGS: - if (dont_eval_args(sc->value)) - { - if (eval_args_no_eval_args(sc)) goto APPLY; - goto TOP_NO_POP; - } - sc->code = cdr(sc->code); - /* sc->value is the func (but can be anything if the code is messed up: (#\a 3)) - * we don't have to delay lookup of the func because arg evaluation order is not specified, so - * (let ((func +)) (func (let () (set! func -) 3) 2)) - * can return 5. - */ - push_op_stack(sc, sc->value); - if (sc->op_stack_now >= sc->op_stack_end) - resize_op_stack(sc); - sc->args = sc->nil; - - EVAL_ARGS: /* first time, value = op, args = nil, code is args */ - 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) && - (!is_safety_checked(sc->code))) - { - if (tree_is_cyclic(sc, sc->code)) - syntax_error_nr(sc, "attempt to evaluate a circular list: ~A", 39, sc->code); - set_safety_checked(sc->code); - } - EVAL_ARGS_PAIR: - if (is_pair(car(sc->code))) - { - eval_args_pair_car(sc); - goto EVAL; - } - if (is_pair(cdr(sc->code))) - { - s7_pointer car_code = car(sc->code); /* not a pair */ - sc->code = cdr(sc->code); - sc->value = (is_symbol(car_code)) ? lookup_checked(sc, car_code) : T_Ext(car_code); - /* sc->value is the current arg's value, sc->code is pointing to the next */ - - /* cdr(sc->code) might not be a pair or nil here! (eq? #f . 1) -> sc->code is 1 */ - if (is_null(cdr(sc->code))) - { - if (eval_args_last_arg(sc)) goto EVAL; - /* drop into APPLY */ - } - else - { - /* here we know sc->code is a pair, cdr(sc->code) is not null, sc->value is the previous arg's value */ - sc->args = cons(sc, sc->value, sc->args); - goto EVAL_ARGS_PAIR; - }} - else eval_last_arg(sc, car(sc->code)); - /* drop into APPLY */ - } - else /* got all args -- go to apply */ - { - /* *(--sc->op_stack_now) is the "function" (sc->value perhaps), sc->code is the arglist end, sc->args might be the preceding args reversed? */ - if (is_not_null(sc->code)) - improper_arglist_error_nr(sc); - sc->code = pop_op_stack(sc); - sc->args = proper_list_reverse_in_place(sc, sc->args); - } - /* turning this into a call on an array of functions was not a complete disaster, but tauto.scm was ~1.5% slower. - * the array-index overhead is the same as the current switch statement's, but there was also the boolean+jump overhead, - * and the function-local overhead currently otherwise 0 if inlined. - */ - APPLY: - case OP_APPLY: - if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, " %s[%d]: op_apply %s (%s) to %s\n", __func__, __LINE__, - display_truncated(sc->code), s7_type_names[type(sc->code)], display_truncated(sc->args))); - switch (type(sc->code)) - { - case T_C_FUNCTION: sc->value = apply_c_function(sc, sc->code, sc->args); continue; - case T_C_RST_NO_REQ_FUNCTION: apply_c_rst_no_req_function(sc); continue; - case T_C_FUNCTION_STAR: apply_c_function_star(sc); continue; - case T_CONTINUATION: call_with_current_continuation(sc); continue; - case T_GOTO: call_with_exit(sc); continue; - case T_C_OBJECT: apply_c_object(sc); continue; - case T_STRING: apply_string(sc); continue; - case T_HASH_TABLE: apply_hash_table(sc); continue; - case T_ITERATOR: apply_iterator(sc); continue; - case T_LET: apply_let(sc); continue; - case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: - case T_VECTOR: apply_vector(sc); continue; - case T_SYNTAX: apply_syntax(sc); goto TOP_NO_POP; - case T_PAIR: if (apply_pair(sc)) continue; goto APPLY; - case T_CLOSURE: apply_closure(sc); goto APPLY_LAMBDA; - case T_CLOSURE_STAR: if (apply_closure_star(sc)) goto EVAL; goto BEGIN; - case T_C_MACRO: apply_c_macro(sc); goto EVAL; - case T_MACRO: apply_macro(sc); goto APPLY_LAMBDA; - case T_BACRO: apply_bacro(sc); goto APPLY_LAMBDA; - case T_MACRO_STAR: apply_macro_star(sc); goto BEGIN; - case T_BACRO_STAR: apply_bacro_star(sc); goto BEGIN; - default: eval_apply_error_nr(sc); - } - - case OP_MACRO_STAR_D: if (op_macro_star_d(sc)) goto EVAL_ARGS_TOP; goto BEGIN; - case OP_MACRO_D: if (op_macro_d(sc, T_MACRO)) goto EVAL_ARGS_TOP; /* fall through presumably */ - - APPLY_LAMBDA: - case OP_APPLY_LAMBDA: - inline_apply_lambda(sc); - goto BEGIN; - - case OP_LAMBDA_STAR_DEFAULT: if (op_lambda_star_default(sc)) goto EVAL; goto BEGIN; - - case OP_MACROEXPAND_1: - switch (op_macroexpand_1(sc)) {case goto_begin: goto BEGIN; case goto_eval: goto EVAL; case goto_start: continue; default: goto APPLY_LAMBDA;} - case OP_MACROEXPAND: - switch (op_macroexpand(sc)) {case goto_begin: goto BEGIN; case goto_eval: goto EVAL; case goto_start: continue; default: goto APPLY_LAMBDA;} - - - HEAPSORT: if (op_heapsort(sc)) continue; if (sc->value != sc->F) goto APPLY; - case OP_SORT1: op_sort1(sc); goto APPLY; - case OP_SORT2: if (op_sort2(sc)) continue; goto HEAPSORT; - case OP_SORT: if (!op_sort(sc)) goto HEAPSORT; - case OP_SORT3: if (op_sort3(sc)) continue; goto HEAPSORT; - case OP_SORT_PAIR_END: sc->value = vector_into_list(sc, sc->value, car(sc->args)); continue; - case OP_SORT_VECTOR_END: sc->value = vector_into_fi_vector(sc->value, car(sc->args)); continue; - case OP_SORT_STRING_END: sc->value = vector_into_string(sc->value, car(sc->args)); continue; + case OP_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_CLOSURE_SAA: op_closure_saa(sc); goto EVAL; + + case OP_CLOSURE_ASA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_CLOSURE_ASA: op_closure_asa(sc); goto EVAL; + + case OP_CLOSURE_SAS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_CLOSURE_SAS: op_closure_sas(sc); goto EVAL; + + case OP_CLOSURE_3A: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_CLOSURE_3A: op_closure_3a(sc); goto EVAL; + + case OP_CLOSURE_4A: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_CLOSURE_4A: op_closure_4a(sc); goto EVAL; + + case OP_CLOSURE_NA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_CLOSURE_NA: op_closure_na(sc); goto EVAL; + + case OP_ANY_CLOSURE_NP: if (!closure_np_is_ok(sc, sc->code)) {if (op_unknown_np(sc)) goto EVAL; continue;} + case HOP_ANY_CLOSURE_NP: op_any_closure_np(sc); goto EVAL; + case OP_ANY_CLOSURE_NP_1: + if (!(inline_collect_np_args(sc, OP_ANY_CLOSURE_NP_1, cons(sc, sc->value, sc->args)))) + op_any_closure_np_end(sc); + goto EVAL; + case OP_ANY_CLOSURE_NP_2: + sc->args = cons(sc, sc->value, sc->args); + op_any_closure_np_end(sc); + goto EVAL; + + case OP_ANY_CLOSURE_SYM: if (!check_closure_sym(sc, 1)) break; /* (lambda args ...) */ + case HOP_ANY_CLOSURE_SYM: op_any_closure_sym(sc); goto BEGIN; + case OP_ANY_CLOSURE_A_SYM: if (!check_closure_sym(sc, 2)) break; /* (lambda (a . args) ...) */ + case HOP_ANY_CLOSURE_A_SYM: op_any_closure_a_sym(sc); goto BEGIN; + + + case OP_TC_AND_A_OR_A_LA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_la(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_LAA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_laa(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_LAA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_laa(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_L3A: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_l3a(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_L3A: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_l3a(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_and_a_or_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_A_AND_A_A_LA: tick_tc(sc, sc->cur_op); op_tc_or_a_a_and_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_A_L3A: tick_tc(sc, sc->cur_op); op_tc_or_a_and_a_a_l3a(sc, sc->code); continue; + + case OP_TC_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_la(sc, sc->code, false)) continue; goto EVAL; + case OP_TC_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_la_z(sc, sc->code, false)) continue; goto EVAL; + case OP_TC_COND_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_la(sc, sc->code, true)) continue; goto EVAL; + case OP_TC_COND_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_la_z(sc, sc->code, true)) continue; goto EVAL; + + case OP_TC_IF_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, false, TC_IF)) continue; goto EVAL; + case OP_TC_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, true, TC_IF)) continue; goto EVAL; + case OP_TC_COND_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, true, TC_COND)) continue; goto EVAL; + case OP_TC_COND_A_LAA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_laa(sc, sc->code, false, TC_COND)) continue; goto EVAL; + case OP_TC_WHEN_LA: tick_tc(sc, sc->cur_op); op_tc_when_la(sc, sc->code); continue; + case OP_TC_WHEN_LAA: tick_tc(sc, sc->cur_op); op_tc_when_laa(sc, sc->code); continue; + case OP_TC_WHEN_L3A: tick_tc(sc, sc->cur_op); op_tc_when_l3a(sc, sc->code); continue; + + case OP_TC_IF_A_Z_L3A: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_l3a(sc, sc->code, true)) continue; goto EVAL; + case OP_TC_IF_A_L3A_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_l3a(sc, sc->code, false)) continue; goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_IF)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_IF)) continue; goto EVAL; + case OP_TC_COND_A_Z_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_COND)) continue; goto EVAL; + case OP_TC_COND_A_Z_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_COND))continue; goto EVAL; + case OP_TC_AND_A_IF_A_LA_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false, TC_AND)) continue; goto EVAL; + case OP_TC_AND_A_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true, TC_AND)) continue; goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); 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(sc, sc->cur_op); if (op_tc_if_a_z_if_a_laa_z(sc, false, sc->code)) continue; goto EVAL; + case OP_TC_COND_A_Z_A_Z_LAA: tick_tc(sc, sc->cur_op); 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_Z: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_laa_z(sc, true, sc->code)) continue; goto EVAL; + + case OP_TC_LET_IF_A_Z_LA: tick_tc(sc, sc->cur_op); if (op_tc_let_if_a_z_la(sc, sc->code)) continue; goto EVAL; + case OP_TC_LET_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; + case OP_TC_LET_WHEN_LAA: tick_tc(sc, sc->cur_op); op_tc_let_when_laa(sc, true, sc->code); continue; + case OP_TC_LET_UNLESS_LAA: tick_tc(sc, sc->cur_op); op_tc_let_when_laa(sc, false, sc->code); continue; + + case OP_TC_COND_A_Z_A_LAA_LAA: tick_tc(sc, sc->cur_op); if (op_tc_cond_a_z_a_laa_laa(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_L3A_L3A: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_if_a_l3a_l3a(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_LET_IF_A_Z_LAA: tick_tc(sc, sc->cur_op); if (op_tc_if_a_z_let_if_a_z_laa(sc, sc->code)) continue; goto EVAL; + case OP_TC_CASE_LA: tick_tc(sc, sc->cur_op); if (op_tc_case_la(sc, sc->code)) continue; goto BEGIN; + case OP_TC_LET_COND: tick_tc(sc, sc->cur_op); if (op_tc_let_cond(sc, sc->code)) continue; goto EVAL; + + case OP_RECUR_IF_A_A_opA_LAq: wrap_recur_if_a_a_opa_laq(sc, true, true); continue; + case OP_RECUR_IF_A_A_opLA_Aq: wrap_recur_if_a_a_opa_laq(sc, true, false); continue; + case OP_RECUR_IF_A_opA_LAq_A: wrap_recur_if_a_a_opa_laq(sc, false, true); continue; + case OP_RECUR_IF_A_opLA_Aq_A: wrap_recur_if_a_a_opa_laq(sc, false, false); 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; + case OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq: wrap_recur(sc, op_recur_if_a_a_if_a_laa_opa_laaq); continue; + case OP_RECUR_IF_A_A_IF_A_A_opLA_LAq: wrap_recur(sc, op_recur_if_a_a_if_a_a_opla_laq); continue; + case OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq: wrap_recur(sc, op_recur_if_a_a_if_a_a_oplaa_laaq); continue; + case OP_RECUR_COND_A_A_opA_LAq: wrap_recur(sc, op_recur_cond_a_a_opa_laq); continue; + case OP_RECUR_COND_A_A_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_opa_laaq); continue; + case OP_RECUR_COND_A_A_A_A_opLA_LAq: wrap_recur(sc, op_recur_cond_a_a_a_a_opla_laq); continue; + case OP_RECUR_COND_A_A_A_A_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_a_opa_laaq); continue; + case OP_RECUR_COND_A_A_A_A_opLAA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_a_oplaa_laaq); continue; + case OP_RECUR_COND_A_A_A_LAA_opA_LAAq: wrap_recur(sc, op_recur_cond_a_a_a_laa_opa_laaq); continue; + case OP_RECUR_COND_A_A_A_LAA_LopA_LAAq: wrap_recur_cond_a_a_a_laa_lopa_laaq(sc); continue; + case OP_RECUR_AND_A_OR_A_LAA_LAA: wrap_recur(sc, op_recur_and_a_or_a_laa_laa); continue; + + + case OP_SAFE_CLOSURE_STAR_A: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_STAR_A: op_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)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_STAR_A1: op_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)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_STAR_KA: op_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)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_STAR_AA: op_safe_closure_star_aa(sc, sc->code); goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_AA_O: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_STAR_AA_O: op_safe_closure_star_aa(sc, sc->code); sc->code = car(sc->code); goto EVAL; + + case OP_SAFE_CLOSURE_STAR_3A: if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 3)) {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_STAR_3A: if (op_safe_closure_star_aaa(sc, sc->code)) goto EVAL; goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_NA: + if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? opt3_arglen(cdr(sc->code)) : 0)) + {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_STAR_NA: if (op_safe_closure_star_na(sc, sc->code)) goto EVAL; goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_NA_0: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 0)) {if (op_unknown(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_STAR_NA_0: if (op_safe_closure_star_na_0(sc, sc->code)) goto EVAL; goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_NA_1: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_STAR_NA_1: if (op_safe_closure_star_na_1(sc, sc->code)) goto EVAL; goto BEGIN; + + case OP_SAFE_CLOSURE_STAR_NA_2: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {if (op_unknown_aa(sc)) goto EVAL; continue;} + case HOP_SAFE_CLOSURE_STAR_NA_2: if (op_safe_closure_star_na_2(sc, sc->code)) goto EVAL; goto BEGIN; + + + case OP_CLOSURE_STAR_A: if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 1)) {if (op_unknown_a(sc)) goto EVAL; continue;} + case HOP_CLOSURE_STAR_A: 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_aa(sc)) goto EVAL; continue;} + case HOP_CLOSURE_STAR_KA: op_closure_star_ka(sc, sc->code); goto BEGIN; + + case OP_CLOSURE_STAR_NA: + if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, (is_pair(cdr(sc->code))) ? opt3_arglen(cdr(sc->code)) : 0)) + {if (op_unknown_na(sc)) goto EVAL; continue;} + case HOP_CLOSURE_STAR_NA: if (op_closure_star_na(sc, sc->code)) goto EVAL; goto BEGIN; + + + case OP_UNKNOWN: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown(sc)) goto EVAL; continue; + case OP_UNKNOWN_NS: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_ns(sc)) goto EVAL; continue; + case OP_UNKNOWN_S: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_s(sc)) goto EVAL; continue; + case OP_UNKNOWN_GG: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_gg(sc)) goto EVAL; continue; + case OP_UNKNOWN_A: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_a(sc)) goto EVAL; continue; + case OP_UNKNOWN_AA: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_aa(sc)) goto EVAL; continue; + case OP_UNKNOWN_NA: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_na(sc)) goto EVAL; continue; + case OP_UNKNOWN_NP: sc->last_function = lookup_checked(sc, car(sc->code)); if (op_unknown_np(sc)) goto EVAL; continue; + + + case OP_IMPLICIT_VECTOR_REF_A: if (!inline_op_implicit_vector_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; + case OP_IMPLICIT_VECTOR_REF_AA: if (!op_implicit_vector_ref_aa(sc)) {if (op_unknown_aa(sc)) goto EVAL;} continue; + case OP_IMPLICIT_STRING_REF_A: if (!op_implicit_string_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; + case OP_IMPLICIT_HASH_TABLE_REF_A: if (!op_implicit_hash_table_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; + case OP_IMPLICIT_HASH_TABLE_REF_AA: if (!op_implicit_hash_table_ref_aa(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; + case OP_IMPLICIT_CONTINUATION_A: if (!op_implicit_continuation_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; + case OP_IMPLICIT_ITERATE: if (!op_implicit_iterate(sc)) {if (op_unknown(sc)) goto EVAL;} continue; + case OP_IMPLICIT_LET_REF_C: if (!op_implicit_let_ref_c(sc)) {if ((has_fx(cdr(sc->code))) && (op_unknown_a(sc))) goto EVAL;} continue; + case OP_IMPLICIT_LET_REF_A: if (!op_implicit_let_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; + case OP_IMPLICIT_PAIR_REF_A: if (!op_implicit_pair_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; + case OP_IMPLICIT_PAIR_REF_AA: if (!op_implicit_pair_ref_aa(sc)) {if (op_unknown_aa(sc)) goto EVAL;} continue; + case OP_IMPLICIT_C_OBJECT_REF_A: if (!op_implicit_c_object_ref_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; + case OP_IMPLICIT_GOTO: if (!op_implicit_goto(sc)) {if (op_unknown(sc)) goto EVAL;} continue; + case OP_IMPLICIT_GOTO_A: if (!op_implicit_goto_a(sc)) {if (op_unknown_a(sc)) goto EVAL;} continue; + case OP_IMPLICIT_VECTOR_SET_3: if (op_implicit_vector_set_3(sc)) goto EVAL; continue; + case OP_IMPLICIT_VECTOR_SET_4: if (op_implicit_vector_set_4(sc)) goto EVAL; continue; + case OP_IMPLICIT_S7_STARLET_REF_S: sc->value = s7_starlet(sc, opt3_int(sc->code)); continue; + case OP_IMPLICIT_S7_STARLET_SET: sc->value = s7_starlet_set_1(sc, opt3_sym(sc->code), fx_call(sc, cddr(sc->code))); continue; + + case OP_UNOPT: goto UNOPT; + case OP_SYMBOL: sc->value = lookup_checked(sc, sc->code); continue; + case OP_CONSTANT: sc->value = sc->code; continue; + case OP_PAIR_PAIR: if (op_pair_pair(sc)) goto EVAL; continue; /* car is pair ((if x car cadr) ...) */ + case OP_PAIR_ANY: sc->value = car(sc->code); goto EVAL_ARGS_TOP; + case OP_PAIR_SYM: if (op_pair_sym(sc)) goto EVAL_ARGS_TOP; continue; + + case OP_EVAL_SET1_NO_MV: + sc->args = list_1(sc, sc->value); + goto APPLY; /* args = (val), code = setter */ + + case OP_EVAL_SET2_NO_MV: sc->args = pair_append(sc, sc->args, list_1(sc, sc->value)); goto APPLY; /* <val> is a normal value */ + /* perhaps in_place is safe here: args=list_1(sc->value) if eval_set2, mv if eval_set2_mv */ + + case OP_EVAL_SET2_MV: /* <inds> = sc->value is a mv */ + push_stack(sc, OP_EVAL_SET2_NO_MV, sc->value, sc->code); /* sc->value = inds */ + goto EVAL_SET2; + + case OP_EVAL_SET2: /* <ind> = sc->value is a normal value */ + push_stack(sc, OP_EVAL_SET2_NO_MV, list_1(sc, sc->value), sc->code); /* sc->value = ind */ + EVAL_SET2: + sc->code = sc->args; /* value */ + sc->cur_op = optimize_op(sc->code); + goto TOP_NO_POP; + + case OP_EVAL_SET3_NO_MV: op_eval_set3_no_mv(sc); goto APPLY; /* <val> is a normal value */ + + case OP_EVAL_SET3_MV: /* <inds> = sc->value is a mv */ + sc->args = (is_null(sc->args)) ? sc->value : pair_append(sc, sc->args, T_Lst(sc->value)); + goto EVAL_SET3; + + case OP_EVAL_SET3: /* <ind> = sc->value is a normal value */ + sc->args = (is_null(sc->args)) ? list_1(sc, sc->value) : pair_append(sc, sc->args, list_1(sc, sc->value)); /* not in_place here */ + EVAL_SET3: + op_eval_set3(sc); + goto TOP_NO_POP; + + case OP_EVAL_ARGS1: sc->args = cons(sc, sc->value, sc->args); goto EVAL_ARGS; + case OP_EVAL_ARGS2: op_eval_args2(sc); goto APPLY; /* sc->value is the last arg, [so if is_null(cdr(sc->code) and current is pair, push args2] */ + case OP_EVAL_ARGS3: op_eval_args3(sc); goto APPLY; /* sc->value is the next-to-last arg, and the last arg is not a list (so values can't mess us up!) */ + case OP_EVAL_ARGS4: sc->args = cons(sc, sc->value, sc->args); goto EVAL_ARGS_PAIR; + case OP_EVAL_ARGS5: op_eval_args5(sc); goto APPLY; + + EVAL_ARGS_TOP: + case OP_EVAL_ARGS: + if (dont_eval_args(sc->value)) + { + if (eval_args_no_eval_args(sc)) goto APPLY; + goto TOP_NO_POP; + } + sc->code = cdr(sc->code); + /* sc->value is the func (but can be anything if the code is messed up: (#\a 3)) + * we don't have to delay lookup of the func because arg evaluation order is not specified, so + * (let ((func +)) (func (let () (set! func -) 3) 2)) + * can return 5. + */ + push_op_stack(sc, sc->value); + if (sc->op_stack_now >= sc->op_stack_end) + resize_op_stack(sc); + sc->args = sc->nil; + + EVAL_ARGS: /* first time, value = op, args = nil, code is args */ + 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) && + (!is_safety_checked(sc->code))) + { + if (tree_is_cyclic(sc, sc->code)) + syntax_error_nr(sc, "attempt to evaluate a circular list: ~A", 39, sc->code); + set_safety_checked(sc->code); + } + EVAL_ARGS_PAIR: + if (is_pair(car(sc->code))) + { + eval_args_pair_car(sc); + goto EVAL; + } + if (is_pair(cdr(sc->code))) + { + s7_pointer car_code = car(sc->code); /* not a pair */ + sc->code = cdr(sc->code); + sc->value = (is_symbol(car_code)) ? lookup_checked(sc, car_code) : T_Ext(car_code); + /* sc->value is the current arg's value, sc->code is pointing to the next */ + + /* cdr(sc->code) might not be a pair or nil here! (eq? #f . 1) -> sc->code is 1 */ + if (is_null(cdr(sc->code))) + { + if (eval_args_last_arg(sc)) goto EVAL; + /* drop into APPLY */ + } + else + { + /* here we know sc->code is a pair, cdr(sc->code) is not null, sc->value is the previous arg's value */ + sc->args = cons(sc, sc->value, sc->args); + goto EVAL_ARGS_PAIR; + }} + else eval_last_arg(sc, car(sc->code)); + /* drop into APPLY */ + } + else /* got all args -- go to apply */ + { + /* *(--sc->op_stack_now) is the "function" (sc->value perhaps), sc->code is the arglist end, sc->args might be the preceding args reversed? */ + if (is_not_null(sc->code)) + improper_arglist_error_nr(sc); + sc->code = pop_op_stack(sc); + sc->args = proper_list_reverse_in_place(sc, sc->args); + } + /* turning this into a call on an array of functions was not a complete disaster, but tauto.scm was ~1.5% slower. + * the array-index overhead is the same as the current switch statement's, but there was also the boolean+jump overhead, + * and the function-local overhead currently otherwise 0 if inlined. + */ + APPLY: + case OP_APPLY: + if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, " %s[%d]: op_apply %s (%s) to %s\n", __func__, __LINE__, + display_truncated(sc->code), s7_type_names[type(sc->code)], display_truncated(sc->args))); + switch (type(sc->code)) + { + case T_C_FUNCTION: sc->value = apply_c_function(sc, sc->code, sc->args); continue; + case T_C_RST_NO_REQ_FUNCTION: apply_c_rst_no_req_function(sc); continue; + case T_C_FUNCTION_STAR: apply_c_function_star(sc); continue; + case T_CONTINUATION: call_with_current_continuation(sc); continue; + case T_GOTO: call_with_exit(sc); continue; + case T_C_OBJECT: apply_c_object(sc); continue; + case T_STRING: apply_string(sc); continue; + case T_HASH_TABLE: apply_hash_table(sc); continue; + case T_ITERATOR: apply_iterator(sc); continue; + case T_LET: apply_let(sc); continue; + case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: + case T_VECTOR: apply_vector(sc); continue; + case T_SYNTAX: apply_syntax(sc); goto TOP_NO_POP; + case T_PAIR: if (apply_pair(sc)) continue; goto APPLY; + case T_CLOSURE: apply_closure(sc); goto APPLY_LAMBDA; + case T_CLOSURE_STAR: if (apply_closure_star(sc)) goto EVAL; goto BEGIN; + case T_C_MACRO: apply_c_macro(sc); goto EVAL; + case T_MACRO: apply_macro(sc); goto APPLY_LAMBDA; + case T_BACRO: apply_bacro(sc); goto APPLY_LAMBDA; + case T_MACRO_STAR: apply_macro_star(sc); goto BEGIN; + case T_BACRO_STAR: apply_bacro_star(sc); goto BEGIN; + default: eval_apply_error_nr(sc); + } + + case OP_MACRO_STAR_D: if (op_macro_star_d(sc)) goto EVAL_ARGS_TOP; goto BEGIN; + case OP_MACRO_D: if (op_macro_d(sc, T_MACRO)) goto EVAL_ARGS_TOP; /* fall through presumably */ + + APPLY_LAMBDA: + case OP_APPLY_LAMBDA: + inline_apply_lambda(sc); + goto BEGIN; + + case OP_LAMBDA_STAR_DEFAULT: if (op_lambda_star_default(sc)) goto EVAL; goto BEGIN; + + case OP_MACROEXPAND_1: + switch (op_macroexpand_1(sc)) {case goto_begin: goto BEGIN; case goto_eval: goto EVAL; case goto_start: continue; default: goto APPLY_LAMBDA;} + case OP_MACROEXPAND: + switch (op_macroexpand(sc)) {case goto_begin: goto BEGIN; case goto_eval: goto EVAL; case goto_start: continue; default: goto APPLY_LAMBDA;} + + + HEAPSORT: if (op_heapsort(sc)) continue; if (sc->value != sc->F) goto APPLY; + case OP_SORT1: op_sort1(sc); goto APPLY; + case OP_SORT2: if (op_sort2(sc)) continue; goto HEAPSORT; + case OP_SORT: if (!op_sort(sc)) goto HEAPSORT; + case OP_SORT3: if (op_sort3(sc)) continue; goto HEAPSORT; + case OP_SORT_PAIR_END: sc->value = vector_into_list(sc, sc->value, car(sc->args)); continue; + case OP_SORT_VECTOR_END: sc->value = vector_into_fi_vector(sc->value, car(sc->args)); continue; + case OP_SORT_STRING_END: sc->value = vector_into_string(sc->value, car(sc->args)); continue; #if S7_DEBUGGING - case OP_MAP_UNWIND: /* this probably can't happen -- left on stack only if opt succeeds then func called */ - fprintf(stderr, "%s[%d]: op_map_unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); - sc->map_call_ctr--; - if (sc->map_call_ctr < 0) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} - continue; -#endif - case OP_MAP_GATHER: inline_op_map_gather(sc); - case OP_MAP: if (op_map(sc)) continue; goto APPLY; - - case OP_MAP_GATHER_1: inline_op_map_gather(sc); - case OP_MAP_1: if (op_map_1(sc)) continue; goto BEGIN; - - case OP_MAP_GATHER_2: - case OP_MAP_GATHER_3: inline_op_map_gather(sc); - case OP_MAP_2: if (op_map_2(sc)) continue; goto EVAL; - - case OP_FOR_EACH: if (op_for_each(sc)) continue; goto APPLY; - case OP_FOR_EACH_1: if (inline_op_for_each_1(sc)) continue; goto BEGIN; - - case OP_FOR_EACH_2: - case OP_FOR_EACH_3: if (inline_op_for_each_2(sc)) continue; goto EVAL; - - case OP_MEMBER_IF: - case OP_MEMBER_IF1: if (op_member_if(sc)) continue; goto APPLY; - - case OP_ASSOC_IF: - case OP_ASSOC_IF1: if (op_assoc_if(sc)) continue; goto APPLY; - - - case OP_SAFE_DOTIMES: /* gen form */ - SAFE_DOTIMES: /* check_do */ - 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; - case goto_eval: goto EVAL; - case goto_top_no_pop: goto TOP_NO_POP; - default: goto BEGIN; - } - - case OP_SAFE_DO: - SAFE_DO: /* from check_do */ - switch (op_safe_do(sc)) /* mat */ - { - case goto_safe_do_end_clauses: - if (is_null(sc->code)) continue; /* multiple values (as test result) can't happen -- safe do loops involve counters by 1 to some integer end */ - goto DO_END_CODE; - case goto_do_unchecked: goto DO_UNCHECKED; - default: goto BEGIN; - } - - case OP_DOTIMES_P: - DOTIMES_P: /* from check_do */ - switch (op_dotimes_p(sc)) - { - case goto_do_end_clauses: goto DO_END_CLAUSES; - case goto_do_unchecked: goto DO_UNCHECKED; - default: goto EVAL; - } - - case OP_DOX: - DOX: /* from check_do */ - switch (op_dox(sc)) /* lg fft exit */ - { - case goto_do_end_clauses: goto DO_END_CLAUSES; - case goto_start: continue; - case goto_top_no_pop: goto TOP_NO_POP; /* includes dox_step_o */ - default: goto BEGIN; - } - - DO_NO_BODY: - case OP_DO_NO_BODY_NA_VARS: op_do_no_body_na_vars(sc); goto EVAL; - case OP_DO_NO_BODY_NA_VARS_STEP: if (op_do_no_body_na_vars_step(sc)) goto DO_END_CLAUSES; goto EVAL; - case OP_DO_NO_BODY_NA_VARS_STEP_1: if (op_do_no_body_na_vars_step_1(sc)) goto DO_END_CLAUSES; goto EVAL; - - case OP_DO_NO_VARS_NO_OPT: op_do_no_vars_no_opt(sc); /* fall through */ - case OP_DO_NO_VARS_NO_OPT_1: if (op_do_no_vars_no_opt_1(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_DO_NO_VARS: if (op_do_no_vars(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_SAFE_DOTIMES_STEP_O: if (op_safe_dotimes_step_o(sc)) goto DO_END_CLAUSES; goto EVAL; - case OP_SAFE_DOTIMES_STEP: if (op_safe_dotimes_step(sc)) goto DO_END_CLAUSES; goto EVAL; - case OP_SAFE_DO_STEP: if (op_safe_do_step(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_SIMPLE_DO: if (op_simple_do(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_SIMPLE_DO_STEP: if (op_simple_do_step(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_DOTIMES_STEP_O: if (op_dotimes_step_o(sc)) goto DO_END_CLAUSES; goto EVAL; - case OP_DOX_INIT: if (op_dox_init(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_DOX_STEP: if (op_dox_step_1(sc)) goto DO_END_CLAUSES; op_dox_step(sc); goto BEGIN; - case OP_DOX_STEP_O: if (op_dox_step_1(sc)) goto DO_END_CLAUSES; op_dox_step_o(sc); goto EVAL; - case OP_DOX_NO_BODY: op_dox_no_body(sc); continue; - case OP_DOX_PENDING_NO_BODY: op_dox_pending_no_body(sc); goto DO_END_CLAUSES; - - case OP_DO_INIT: if (op_do_init(sc)) goto DO_END; goto EVAL; - - case OP_DO: - if (is_null(check_do(sc))) - switch (optimize_op(sc->code)) - { - case OP_DOX: goto DOX; - case OP_SAFE_DOTIMES: goto SAFE_DOTIMES; - case OP_DOTIMES_P: goto DOTIMES_P; - case OP_SAFE_DO: goto SAFE_DO; - case OP_DO_NO_BODY_NA_VARS: goto DO_NO_BODY; - case OP_DO_NO_VARS: if (op_do_no_vars(sc)) goto DO_END_CLAUSES; goto BEGIN; - case OP_DOX_NO_BODY: op_dox_no_body(sc); continue; - case OP_DOX_PENDING_NO_BODY: op_dox_pending_no_body(sc); goto DO_END_CLAUSES; - default: if (op_simple_do(sc)) goto DO_END_CLAUSES; goto BEGIN; - } - - case OP_DO_UNCHECKED: - op_do_unchecked(sc); - DO_UNCHECKED: - if (do_unchecked(sc)) goto EVAL; - - DO_END: - case OP_DO_END: - if (op_do_end(sc)) goto EVAL; - - case OP_DO_END1: - if (is_true(sc, sc->value)) - { - goto_t next = op_do_end_true(sc); - if (next == goto_start) continue; - if (next == goto_eval) goto EVAL; - goto FEED_TO; - } - else - { - goto_t next = op_do_end_false(sc); - if (next == goto_begin) goto BEGIN; - if (next == goto_do_end) goto DO_END; - /* fall through */ - } - - case OP_DO_STEP: if (op_do_step(sc)) goto DO_END; goto EVAL; - case OP_DO_STEP2: if (op_do_step2(sc)) goto DO_END; goto EVAL; - - DO_END_CLAUSES: - if (do_end_clauses(sc)) continue; - DO_END_CODE: - { - goto_t next = do_end_code(sc); - if (next == goto_eval) goto EVAL; - if (next == goto_start) continue; - goto FEED_TO; - } - - - case OP_BEGIN_UNCHECKED: - set_current_code(sc, sc->code); - sc->code = T_Pair(cdr(sc->code)); - goto BEGIN; - - case OP_BEGIN: - if (op_begin(sc, sc->code)) continue; - sc->code = T_Pair(cdr(sc->code)); - - case OP_BEGIN_HOOK: - if (sc->begin_hook) - { - /* call_begin_hook might clobber sc->code? via s7_eval_string probably yes */ - set_current_code(sc, sc->code); - if (call_begin_hook(sc)) - return(sc->F); - } - case OP_BEGIN_NO_HOOK: - goto BEGIN; - - case OP_BEGIN_2_UNCHECKED: - push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); - sc->code = cadr(sc->code); - goto EVAL; - - case OP_BEGIN_AA: sc->value = fx_begin_aa(sc, sc->code); continue; - case OP_BEGIN_NA: sc->value = fx_begin_na(sc, sc->code); continue; - - - case OP_EVAL: goto EVAL; - case OP_EVAL_STRING: op_eval_string(sc); goto EVAL; - - case OP_QUOTE: sc->value = check_quote(sc, sc->code); continue; - case OP_QUOTE_UNCHECKED: sc->value = cadr(sc->code); continue; - - case OP_DEFINE_FUNCHECKED: define_funchecked(sc); continue; - case OP_DEFINE_CONSTANT1: op_define_constant1(sc); continue; - - case OP_DEFINE_CONSTANT_UNCHECKED: - push_stack_no_args(sc, OP_DEFINE_CONSTANT1, cadr(sc->code)); - goto DEFCONS; - - case OP_DEFINE_CONSTANT: - if (op_define_constant(sc)) continue; - - case OP_DEFINE_STAR: case OP_DEFINE: - check_define(sc); - - DEFCONS: - case OP_DEFINE_STAR_UNCHECKED: - case OP_DEFINE_UNCHECKED: - if (op_define_unchecked(sc)) goto TOP_NO_POP; - - case OP_DEFINE1: if (op_define1(sc)) goto APPLY; - case OP_DEFINE_WITH_SETTER: op_define_with_setter(sc); continue; - - case OP_SET_opSq_A: if (op_set_opsq_a(sc)) goto APPLY; continue; - case OP_SET_opSAq_A: if (op_set_opsaq_a(sc)) goto APPLY; continue; - case OP_SET_opSAq_P: if (op_set_opsaq_p(sc)) goto APPLY; goto EVAL; - case OP_SET_opSAq_P_1: if (op_set_opsaq_p_1(sc)) goto APPLY; continue; - case OP_SET_opSAAq_A: if (op_set_opsaaq_a(sc)) goto APPLY; continue; - case OP_SET_opSAAq_P: if (op_set_opsaaq_p(sc)) goto APPLY; goto EVAL; - case OP_SET_opSAAq_P_1: if (op_set_opsaaq_p_1(sc)) goto APPLY; continue; - - case OP_INCREMENT_BY_1: inline_op_increment_by_1(sc); continue; - case OP_DECREMENT_BY_1: op_decrement_by_1(sc); continue; - case OP_INCREMENT_SA: op_increment_sa(sc); continue; - case OP_INCREMENT_SAA: op_increment_saa(sc); continue; - - case OP_SET_S_C: op_set_s_c(sc); continue; - case OP_SET_S_S: op_set_s_s(sc); continue; - case OP_SET_S_A: op_set_s_a(sc); continue; - case OP_SET_S_P: op_set_s_p(sc); goto EVAL; - case OP_SET_CONS: op_set_cons(sc); continue; - case OP_SET_SAFE: op_set_safe(sc); continue; - - case OP_SET_FROM_SETTER: slot_set_value(sc->code, sc->value); continue; /* mv caught in splice_in_values */ - case OP_SET_FROM_LET_TEMP: op_set_from_let_temp(sc); continue; - - case OP_SET2: - switch (op_set2(sc)) /* imp */ - { - case goto_eval: goto EVAL; - case goto_top_no_pop: goto TOP_NO_POP; - case goto_start: continue; - case goto_apply: goto APPLY; - case goto_unopt: goto UNOPT; - default: goto EVAL_ARGS; /* goto_eval_args in funcs called by op_set2, unopt */ - } - - case OP_SET: check_set(sc); - case OP_SET_UNCHECKED: - SET_UNCHECKED: - if (is_pair(cadr(sc->code))) /* has setter */ - switch (set_implicit(sc)) - { - case goto_top_no_pop: goto TOP_NO_POP; - case goto_start: continue; - case goto_apply: goto APPLY; - case goto_unopt: goto UNOPT; - default: goto EVAL_ARGS; /* very common, op_unopt at this point */ - } - case OP_SET_NORMAL: if (op_set_normal(sc)) goto EVAL; - case OP_SET1: if (op_set1(sc)) continue; goto APPLY; - - case OP_SET_WITH_LET_1: if (op_set_with_let_1(sc)) goto TOP_NO_POP; goto SET_WITH_LET; - case OP_SET_WITH_LET_2: if (op_set_with_let_2(sc)) continue; - SET_WITH_LET: - activate_with_let(sc, sc->value); /* this activates sc->value, so the set! will happen in that environment */ - if (is_pair(cadr(sc->code))) - switch (set_implicit(sc)) /* imp misc */ - { - case goto_top_no_pop: goto TOP_NO_POP; - case goto_start: continue; - case goto_apply: goto APPLY; - case goto_unopt: goto UNOPT; - default: goto EVAL_ARGS; /* unopt */ - } - set_with_let_error_nr(sc); - - case OP_IF: op_if(sc); goto EVAL; - case OP_IF_UNCHECKED: op_if_unchecked(sc); goto EVAL; - case OP_IF1: if (op_if1(sc)) goto EVAL; continue; - - #define if_a_p(sc) if (is_true(sc, fx_call(sc, cdr(sc->code)))) - #define if_not_a_p(sc) if (is_false(sc, fx_call(sc, opt3_pair(sc->code)))) /* cdadr(sc->code) */ - - case OP_IF_A_C_C: sc->value = (is_true(sc, fx_call(sc, cdr(sc->code)))) ? opt1_con(sc->code) : opt2_con(sc->code); continue; - case OP_IF_A_A: sc->value = (is_true(sc, fx_call(sc, cdr(sc->code)))) ? fx_call(sc, opt1_pair(sc->code)) : sc->unspecified; continue; - case OP_IF_S_A_A: sc->value = (is_true(sc, lookup(sc, cadr(sc->code)))) ? fx_call(sc, opt1_pair(sc->code)) : fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_A_A_A: sc->value = (is_true(sc, fx_call(sc, cdr(sc->code)))) ? fx_call(sc, opt1_pair(sc->code)) : fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_A_A_P: if_a_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_A_P_A: if_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_NOT_A_A: sc->value = (is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ? fx_call(sc, opt2_pair(sc->code)) : sc->unspecified; continue; - case OP_IF_NOT_A_A_A: sc->value = (is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ? fx_call(sc, opt2_pair(sc->code)) : fx_call(sc, opt3_pair(sc->code)); continue; - case OP_IF_AND2_S_A: sc->value = fx_if_and2_s_a(sc, sc->code); continue; - - #define call_bfunc(Sc, Expr) ((s7_bfunc)opt3_any(cdr(Sc->code)))(Sc, Expr) - case OP_IF_B_A: sc->value = (call_bfunc(sc, cadr(sc->code))) ? fx_call(sc, opt1_pair(sc->code)) : sc->unspecified; continue; - case OP_IF_B_A_P: if (call_bfunc(sc, cadr(sc->code))) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_B_P_A: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_B_P_P: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_s_p(sc) if (is_true(sc, lookup(sc, cadr(sc->code)))) - #define if_not_s_p(sc) if (is_false(sc, lookup(sc, opt1_sym(cdr(sc->code))))) /* cadadr(sc->code) */ - - case OP_IF_S_P: if_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_S_R: if_s_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_S_P_P: if_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_S_N: if_not_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_S_N_N: if_not_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_S_P_A: if_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_S_A_P: if_s_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; - - case OP_IF_A_P: if_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_A_R: if_a_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_A_P_P: if_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_A_N: if_not_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_A_N_N: if_not_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - case OP_IF_B_P: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_B_R: if (call_bfunc(sc, cadr(sc->code))) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_B_N_N: if (call_bfunc(sc, car(opt3_pair(sc->code)))) {sc->code = opt2_any(sc->code); goto EVAL;} sc->code = opt1_any(sc->code); goto EVAL; - - #define if_is_type_s_p(sc) if (gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))) - #define if_is_not_type_s_p(sc) if (!gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))) - - case OP_IF_IS_TYPE_S_P: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_IS_TYPE_S_R: if_is_type_s_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_IS_TYPE_S_P_P: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_IS_TYPE_S_N: if_is_not_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_IS_TYPE_S_N_N: if_is_not_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_IS_TYPE_S_A_A: if_is_type_s_p(sc) sc->value = fx_call(sc, opt1_pair(sc->code)); else sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_IS_TYPE_S_P_A: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; - case OP_IF_IS_TYPE_S_A_P: if_is_type_s_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_true(sc, fn_proc(cadr(sc->code))(sc, sc->t1_1))) - #define if_not_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_false(sc, fn_proc(opt1_pair(cdr(sc->code)))(sc, sc->t1_1))) /* cadadr */ - - case OP_IF_opSq_P: if_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_opSq_R: if_opsq_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_opSq_P_P: if_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_opSq_N: if_not_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_opSq_N_N: if_not_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_and2_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) - #define if_not_and2_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) - - case OP_IF_AND2_P: if_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_AND2_R: if_and2_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_AND2_P_P: if_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_AND2_N: if_not_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_AND2_N_N: if_not_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_or2_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) - #define if_not_or2_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) - - case OP_IF_OR2_P: if_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_OR2_R: if_or2_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_OR2_P_P: if_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_OR2_N: if_not_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_OR2_N_N: if_not_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_and3_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && \ + case OP_MAP_UNWIND: /* this probably can't happen -- left on stack only if opt succeeds then func called */ + fprintf(stderr, "%s[%d]: op_map_unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); + sc->map_call_ctr--; + if (sc->map_call_ctr < 0) {fprintf(stderr, "%s[%d]: map ctr: %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); sc->map_call_ctr = 0;} + continue; +#endif + case OP_MAP_GATHER: inline_op_map_gather(sc); + case OP_MAP: if (op_map(sc)) continue; goto APPLY; + + case OP_MAP_GATHER_1: inline_op_map_gather(sc); + case OP_MAP_1: if (op_map_1(sc)) continue; goto BEGIN; + + case OP_MAP_GATHER_2: + case OP_MAP_GATHER_3: inline_op_map_gather(sc); + case OP_MAP_2: if (op_map_2(sc)) continue; goto EVAL; + + case OP_FOR_EACH: if (op_for_each(sc)) continue; goto APPLY; + case OP_FOR_EACH_1: if (inline_op_for_each_1(sc)) continue; goto BEGIN; + + case OP_FOR_EACH_2: + case OP_FOR_EACH_3: if (inline_op_for_each_2(sc)) continue; goto EVAL; + + case OP_MEMBER_IF: + case OP_MEMBER_IF1: if (op_member_if(sc)) continue; goto APPLY; + + case OP_ASSOC_IF: + case OP_ASSOC_IF1: if (op_assoc_if(sc)) continue; goto APPLY; + + + case OP_SAFE_DOTIMES: /* gen form */ + SAFE_DOTIMES: /* check_do */ + 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; + case goto_eval: goto EVAL; + case goto_top_no_pop: goto TOP_NO_POP; + default: goto BEGIN; + } + + case OP_SAFE_DO: + SAFE_DO: /* from check_do */ + switch (op_safe_do(sc)) /* mat */ + { + case goto_safe_do_end_clauses: + if (is_null(sc->code)) continue; /* multiple values (as test result) can't happen -- safe do loops involve counters by 1 to some integer end */ + goto DO_END_CODE; + case goto_do_unchecked: goto DO_UNCHECKED; + default: goto BEGIN; + } + + case OP_DOTIMES_P: + DOTIMES_P: /* from check_do */ + switch (op_dotimes_p(sc)) + { + case goto_do_end_clauses: goto DO_END_CLAUSES; + case goto_do_unchecked: goto DO_UNCHECKED; + default: goto EVAL; + } + + case OP_DOX: + DOX: /* from check_do */ + switch (op_dox(sc)) /* lg fft exit */ + { + case goto_do_end_clauses: goto DO_END_CLAUSES; + case goto_start: continue; + case goto_top_no_pop: goto TOP_NO_POP; /* includes dox_step_o */ + default: goto BEGIN; + } + + DO_NO_BODY: + case OP_DO_NO_BODY_NA_VARS: op_do_no_body_na_vars(sc); goto EVAL; + case OP_DO_NO_BODY_NA_VARS_STEP: if (op_do_no_body_na_vars_step(sc)) goto DO_END_CLAUSES; goto EVAL; + case OP_DO_NO_BODY_NA_VARS_STEP_1: if (op_do_no_body_na_vars_step_1(sc)) goto DO_END_CLAUSES; goto EVAL; + + case OP_DO_NO_VARS_NO_OPT: op_do_no_vars_no_opt(sc); /* fall through */ + case OP_DO_NO_VARS_NO_OPT_1: if (op_do_no_vars_no_opt_1(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_DO_NO_VARS: if (op_do_no_vars(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_SAFE_DOTIMES_STEP_O: if (op_safe_dotimes_step_o(sc)) goto DO_END_CLAUSES; goto EVAL; + case OP_SAFE_DOTIMES_STEP: if (op_safe_dotimes_step(sc)) goto DO_END_CLAUSES; goto EVAL; + case OP_SAFE_DO_STEP: if (op_safe_do_step(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_SIMPLE_DO: if (op_simple_do(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_SIMPLE_DO_STEP: if (op_simple_do_step(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_DOTIMES_STEP_O: if (op_dotimes_step_o(sc)) goto DO_END_CLAUSES; goto EVAL; + case OP_DOX_INIT: if (op_dox_init(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_DOX_STEP: if (op_dox_step_1(sc)) goto DO_END_CLAUSES; op_dox_step(sc); goto BEGIN; + case OP_DOX_STEP_O: if (op_dox_step_1(sc)) goto DO_END_CLAUSES; op_dox_step_o(sc); goto EVAL; + case OP_DOX_NO_BODY: op_dox_no_body(sc); continue; + case OP_DOX_PENDING_NO_BODY: op_dox_pending_no_body(sc); goto DO_END_CLAUSES; + + case OP_DO_INIT: if (op_do_init(sc)) goto DO_END; goto EVAL; + + case OP_DO: + if (is_null(check_do(sc))) + switch (optimize_op(sc->code)) + { + case OP_DOX: goto DOX; + case OP_SAFE_DOTIMES: goto SAFE_DOTIMES; + case OP_DOTIMES_P: goto DOTIMES_P; + case OP_SAFE_DO: goto SAFE_DO; + case OP_DO_NO_BODY_NA_VARS: goto DO_NO_BODY; + case OP_DO_NO_VARS: if (op_do_no_vars(sc)) goto DO_END_CLAUSES; goto BEGIN; + case OP_DOX_NO_BODY: op_dox_no_body(sc); continue; + case OP_DOX_PENDING_NO_BODY: op_dox_pending_no_body(sc); goto DO_END_CLAUSES; + default: if (op_simple_do(sc)) goto DO_END_CLAUSES; goto BEGIN; + } + + case OP_DO_UNCHECKED: + op_do_unchecked(sc); + DO_UNCHECKED: + if (do_unchecked(sc)) goto EVAL; + + DO_END: + case OP_DO_END: + if (op_do_end(sc)) goto EVAL; + + case OP_DO_END1: + if (is_true(sc, sc->value)) + { + goto_t next = op_do_end_true(sc); + if (next == goto_start) continue; + if (next == goto_eval) goto EVAL; + goto FEED_TO; + } + else + { + goto_t next = op_do_end_false(sc); + if (next == goto_begin) goto BEGIN; + if (next == goto_do_end) goto DO_END; + /* fall through */ + } + + case OP_DO_STEP: if (op_do_step(sc)) goto DO_END; goto EVAL; + case OP_DO_STEP2: if (op_do_step2(sc)) goto DO_END; goto EVAL; + + DO_END_CLAUSES: + if (do_end_clauses(sc)) continue; + DO_END_CODE: + { + goto_t next = do_end_code(sc); + if (next == goto_eval) goto EVAL; + if (next == goto_start) continue; + goto FEED_TO; + } + + + case OP_BEGIN_UNCHECKED: + set_current_code(sc, sc->code); + sc->code = T_Pair(cdr(sc->code)); + goto BEGIN; + + case OP_BEGIN: + if (op_begin(sc, sc->code)) continue; + sc->code = T_Pair(cdr(sc->code)); + + case OP_BEGIN_HOOK: + if (sc->begin_hook) + { + /* call_begin_hook might clobber sc->code? via s7_eval_string probably yes */ + set_current_code(sc, sc->code); + if (call_begin_hook(sc)) + return(sc->F); + } + case OP_BEGIN_NO_HOOK: + goto BEGIN; + + case OP_BEGIN_2_UNCHECKED: + push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); + sc->code = cadr(sc->code); + goto EVAL; + + case OP_BEGIN_AA: sc->value = fx_begin_aa(sc, sc->code); continue; + case OP_BEGIN_NA: sc->value = fx_begin_na(sc, sc->code); continue; + + + case OP_EVAL: goto EVAL; + case OP_EVAL_STRING: op_eval_string(sc); goto EVAL; + + case OP_QUOTE: sc->value = check_quote(sc, sc->code); continue; + case OP_QUOTE_UNCHECKED: sc->value = cadr(sc->code); continue; + + case OP_DEFINE_FUNCHECKED: define_funchecked(sc); continue; + case OP_DEFINE_CONSTANT1: op_define_constant1(sc); continue; + + case OP_DEFINE_CONSTANT_UNCHECKED: + push_stack_no_args(sc, OP_DEFINE_CONSTANT1, cadr(sc->code)); + goto DEFCONS; + + case OP_DEFINE_CONSTANT: + if (op_define_constant(sc)) continue; + + case OP_DEFINE_STAR: case OP_DEFINE: + check_define(sc); + + DEFCONS: + case OP_DEFINE_STAR_UNCHECKED: + case OP_DEFINE_UNCHECKED: + if (op_define_unchecked(sc)) goto TOP_NO_POP; + + case OP_DEFINE1: if (op_define1(sc)) goto APPLY; + case OP_DEFINE_WITH_SETTER: op_define_with_setter(sc); continue; + + case OP_SET_opSq_A: if (op_set_opsq_a(sc)) goto APPLY; continue; + case OP_SET_opSAq_A: if (op_set_opsaq_a(sc)) goto APPLY; continue; + case OP_SET_opSAq_P: if (op_set_opsaq_p(sc)) goto APPLY; goto EVAL; + case OP_SET_opSAq_P_1: if (op_set_opsaq_p_1(sc)) goto APPLY; continue; + case OP_SET_opSAAq_A: if (op_set_opsaaq_a(sc)) goto APPLY; continue; + case OP_SET_opSAAq_P: if (op_set_opsaaq_p(sc)) goto APPLY; goto EVAL; + case OP_SET_opSAAq_P_1: if (op_set_opsaaq_p_1(sc)) goto APPLY; continue; + + case OP_INCREMENT_BY_1: inline_op_increment_by_1(sc); continue; + case OP_DECREMENT_BY_1: op_decrement_by_1(sc); continue; + case OP_INCREMENT_SA: op_increment_sa(sc); continue; + case OP_INCREMENT_SAA: op_increment_saa(sc); continue; + + case OP_SET_S_C: op_set_s_c(sc); continue; + case OP_SET_S_S: op_set_s_s(sc); continue; + case OP_SET_S_A: op_set_s_a(sc); continue; + case OP_SET_S_P: op_set_s_p(sc); goto EVAL; + case OP_SET_CONS: op_set_cons(sc); continue; + case OP_SET_SAFE: op_set_safe(sc); continue; + + case OP_SET_FROM_SETTER: slot_set_value(sc->code, sc->value); continue; /* mv caught in splice_in_values */ + case OP_SET_FROM_LET_TEMP: op_set_from_let_temp(sc); continue; + + case OP_SET2: + switch (op_set2(sc)) /* imp */ + { + case goto_eval: goto EVAL; + case goto_top_no_pop: goto TOP_NO_POP; + case goto_start: continue; + case goto_apply: goto APPLY; + case goto_unopt: goto UNOPT; + default: goto EVAL_ARGS; /* goto_eval_args in funcs called by op_set2, unopt */ + } + + case OP_SET: check_set(sc); + case OP_SET_UNCHECKED: + SET_UNCHECKED: + if (is_pair(cadr(sc->code))) /* has setter */ + switch (set_implicit(sc)) + { + case goto_top_no_pop: goto TOP_NO_POP; + case goto_start: continue; + case goto_apply: goto APPLY; + case goto_unopt: goto UNOPT; + default: goto EVAL_ARGS; /* very common, op_unopt at this point */ + } + case OP_SET_NORMAL: if (op_set_normal(sc)) goto EVAL; + case OP_SET1: if (op_set1(sc)) continue; goto APPLY; + + case OP_SET_WITH_LET_1: if (op_set_with_let_1(sc)) goto TOP_NO_POP; goto SET_WITH_LET; + case OP_SET_WITH_LET_2: if (op_set_with_let_2(sc)) continue; + SET_WITH_LET: + activate_with_let(sc, sc->value); /* this activates sc->value, so the set! will happen in that environment */ + if (is_pair(cadr(sc->code))) + switch (set_implicit(sc)) /* imp misc */ + { + case goto_top_no_pop: goto TOP_NO_POP; + case goto_start: continue; + case goto_apply: goto APPLY; + case goto_unopt: goto UNOPT; + default: goto EVAL_ARGS; /* unopt */ + } + set_with_let_error_nr(sc); + + case OP_IF: op_if(sc); goto EVAL; + case OP_IF_UNCHECKED: op_if_unchecked(sc); goto EVAL; + case OP_IF1: if (op_if1(sc)) goto EVAL; continue; + + #define if_a_p(sc) if (is_true(sc, fx_call(sc, cdr(sc->code)))) + #define if_not_a_p(sc) if (is_false(sc, fx_call(sc, opt3_pair(sc->code)))) /* cdadr(sc->code) */ + + case OP_IF_A_C_C: sc->value = (is_true(sc, fx_call(sc, cdr(sc->code)))) ? opt1_con(sc->code) : opt2_con(sc->code); continue; + case OP_IF_A_A: sc->value = (is_true(sc, fx_call(sc, cdr(sc->code)))) ? fx_call(sc, opt1_pair(sc->code)) : sc->unspecified; continue; + case OP_IF_S_A_A: sc->value = (is_true(sc, lookup(sc, cadr(sc->code)))) ? fx_call(sc, opt1_pair(sc->code)) : fx_call(sc, opt2_pair(sc->code)); continue; + case OP_IF_A_A_A: sc->value = (is_true(sc, fx_call(sc, cdr(sc->code)))) ? fx_call(sc, opt1_pair(sc->code)) : fx_call(sc, opt2_pair(sc->code)); continue; + case OP_IF_A_A_P: if_a_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_A_P_A: if_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; + case OP_IF_NOT_A_A: sc->value = (is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ? fx_call(sc, opt2_pair(sc->code)) : sc->unspecified; continue; + case OP_IF_NOT_A_A_A: sc->value = (is_false(sc, fx_call(sc, opt1_pair(sc->code)))) ? fx_call(sc, opt2_pair(sc->code)) : fx_call(sc, opt3_pair(sc->code)); continue; + case OP_IF_AND2_S_A: sc->value = fx_if_and2_s_a(sc, sc->code); continue; + + #define call_bfunc(Sc, Expr) ((s7_bfunc)opt3_any(cdr(Sc->code)))(Sc, Expr) + case OP_IF_B_A: sc->value = (call_bfunc(sc, cadr(sc->code))) ? fx_call(sc, opt1_pair(sc->code)) : sc->unspecified; continue; + case OP_IF_B_A_P: if (call_bfunc(sc, cadr(sc->code))) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_B_P_A: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; + case OP_IF_B_P_P: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + + #define if_s_p(sc) if (is_true(sc, lookup(sc, cadr(sc->code)))) + #define if_not_s_p(sc) if (is_false(sc, lookup(sc, opt1_sym(cdr(sc->code))))) /* cadadr(sc->code) */ + + case OP_IF_S_P: if_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_S_R: if_s_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; + case OP_IF_S_P_P: if_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_S_N: if_not_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_S_N_N: if_not_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_S_P_A: if_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; + case OP_IF_S_A_P: if_s_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; + + case OP_IF_A_P: if_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_A_R: if_a_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; + case OP_IF_A_P_P: if_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_A_N: if_not_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_A_N_N: if_not_a_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + + case OP_IF_B_P: if (call_bfunc(sc, cadr(sc->code))) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_B_R: if (call_bfunc(sc, cadr(sc->code))) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; + case OP_IF_B_N_N: if (call_bfunc(sc, car(opt3_pair(sc->code)))) {sc->code = opt2_any(sc->code); goto EVAL;} sc->code = opt1_any(sc->code); goto EVAL; + + #define if_is_type_s_p(sc) if (gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))) + #define if_is_not_type_s_p(sc) if (!gen_type_match(sc, lookup(sc, opt2_sym(cdr(sc->code))), opt3_byte(cdr(sc->code)))) + + case OP_IF_IS_TYPE_S_P: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_IS_TYPE_S_R: if_is_type_s_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; + case OP_IF_IS_TYPE_S_P_P: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_IS_TYPE_S_N: if_is_not_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_IS_TYPE_S_N_N: if_is_not_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_IS_TYPE_S_A_A: if_is_type_s_p(sc) sc->value = fx_call(sc, opt1_pair(sc->code)); else sc->value = fx_call(sc, opt2_pair(sc->code)); continue; + case OP_IF_IS_TYPE_S_P_A: if_is_type_s_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = fx_call(sc, opt2_pair(sc->code)); continue; + case OP_IF_IS_TYPE_S_A_P: if_is_type_s_p(sc) {sc->value = fx_call(sc, opt1_pair(sc->code)); continue;} sc->code = opt2_any(sc->code); goto EVAL; + + #define if_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_true(sc, fn_proc(cadr(sc->code))(sc, sc->t1_1))) + #define if_not_opsq_p(sc) set_car(sc->t1_1, lookup(sc, opt2_sym(cdr(sc->code)))); if (is_false(sc, fn_proc(opt1_pair(cdr(sc->code)))(sc, sc->t1_1))) /* cadadr */ + + case OP_IF_opSq_P: if_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_opSq_R: if_opsq_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; + case OP_IF_opSq_P_P: if_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_opSq_N: if_not_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_opSq_N_N: if_not_opsq_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + + #define if_and2_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) + #define if_not_and2_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) + + case OP_IF_AND2_P: if_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_AND2_R: if_and2_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; + case OP_IF_AND2_P_P: if_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_AND2_N: if_not_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_AND2_N_N: if_not_and2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + + #define if_or2_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) + #define if_not_or2_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code)))))) + + case OP_IF_OR2_P: if_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_OR2_R: if_or2_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; + case OP_IF_OR2_P_P: if_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_OR2_N: if_not_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_OR2_N_N: if_not_or2_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + + #define if_and3_p(sc) if ((is_true(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) && \ (is_true(sc, fx_call(sc, opt3_pair(cdr(sc->code))))) && (is_true(sc, fx_call(sc, opt1_pair(cdr(sc->code)))))) - #define if_not_and3_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || \ + #define if_not_and3_p(sc) if ((is_false(sc, fx_call(sc, opt2_pair(cdr(sc->code))))) || \ (is_false(sc, fx_call(sc, opt3_pair(cdr(sc->code))))) || (is_false(sc, fx_call(sc, opt1_pair(cdr(sc->code)))))) - case OP_IF_AND3_P: if_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_AND3_R: if_and3_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; - case OP_IF_AND3_P_P: if_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - case OP_IF_AND3_N: if_not_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; - case OP_IF_AND3_N_N: if_not_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; - - #define if_p_push(op) do {push_stack_no_args(sc, op, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code));} while (0) - case OP_IF_P_P: if_p_push(OP_IF_PP); goto EVAL; - case OP_IF_P_N: if_p_push(OP_IF_PN); goto EVAL; - case OP_IF_P_P_P: if_p_push(OP_IF_PPP); goto EVAL; - case OP_IF_P_R: if_p_push(OP_IF_PR); goto EVAL; - case OP_IF_P_N_N: if_p_push(OP_IF_PRR); goto EVAL; - - #define if_bp_push(op) do {push_stack_no_args(sc, op, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code));} while (0) - case OP_IF_ANDP_P: if_bp_push(OP_IF_PP); goto AND_P; - case OP_IF_ANDP_R: if_bp_push(OP_IF_PR); goto AND_P; - case OP_IF_ANDP_P_P: if_bp_push(OP_IF_PPP); goto AND_P; - case OP_IF_ANDP_N: if_bp_push(OP_IF_PR); goto AND_P; - case OP_IF_ANDP_N_N: if_bp_push(OP_IF_PRR); goto AND_P; - - case OP_IF_ORP_P: if_bp_push(OP_IF_PP); goto OR_P; - case OP_IF_ORP_R: if_bp_push(OP_IF_PR); goto OR_P; - case OP_IF_ORP_P_P: if_bp_push(OP_IF_PPP); goto OR_P; - case OP_IF_ORP_N: if_bp_push(OP_IF_PR); goto OR_P; - case OP_IF_ORP_N_N: if_bp_push(OP_IF_PRR); goto OR_P; - - case OP_IF_PP: if (sc->value != sc->F) goto EVAL; sc->value = sc->unspecified; continue; - case OP_IF_PN: - case OP_IF_PR: if (sc->value == sc->F) goto EVAL; sc->value = sc->unspecified; continue; - case OP_IF_PPP: sc->code = (sc->value != sc->F) ? car(sc->code) : cadr(sc->code); goto EVAL; - case OP_IF_PRR: sc->code = (sc->value == sc->F) ? car(sc->code) : cadr(sc->code); goto EVAL; - - case OP_WHEN: check_when(sc); goto EVAL; - case OP_WHEN_S: if (op_when_s(sc)) continue; goto EVAL; - case OP_WHEN_A: if (op_when_a(sc)) continue; goto EVAL; + case OP_IF_AND3_P: if_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_AND3_R: if_and3_p(sc) {sc->value = sc->unspecified; continue;} sc->code = opt1_any(sc->code); goto EVAL; + case OP_IF_AND3_P_P: if_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + case OP_IF_AND3_N: if_not_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->value = sc->unspecified; continue; + case OP_IF_AND3_N_N: if_not_and3_p(sc) {sc->code = opt1_any(sc->code); goto EVAL;} sc->code = opt2_any(sc->code); goto EVAL; + + #define if_p_push(op) do {push_stack_no_args(sc, op, opt2_any(cdr(sc->code))); sc->code = opt3_any(cdr(sc->code));} while (0) + case OP_IF_P_P: if_p_push(OP_IF_PP); goto EVAL; + case OP_IF_P_N: if_p_push(OP_IF_PN); goto EVAL; + case OP_IF_P_P_P: if_p_push(OP_IF_PPP); goto EVAL; + case OP_IF_P_R: if_p_push(OP_IF_PR); goto EVAL; + case OP_IF_P_N_N: if_p_push(OP_IF_PRR); goto EVAL; + + #define if_bp_push(op) do {push_stack_no_args(sc, op, opt2_any(cdr(sc->code))); sc->code = opt3_pair(cdr(sc->code));} while (0) + case OP_IF_ANDP_P: if_bp_push(OP_IF_PP); goto AND_P; + case OP_IF_ANDP_R: if_bp_push(OP_IF_PR); goto AND_P; + case OP_IF_ANDP_P_P: if_bp_push(OP_IF_PPP); goto AND_P; + case OP_IF_ANDP_N: if_bp_push(OP_IF_PR); goto AND_P; + case OP_IF_ANDP_N_N: if_bp_push(OP_IF_PRR); goto AND_P; + + case OP_IF_ORP_P: if_bp_push(OP_IF_PP); goto OR_P; + case OP_IF_ORP_R: if_bp_push(OP_IF_PR); goto OR_P; + case OP_IF_ORP_P_P: if_bp_push(OP_IF_PPP); goto OR_P; + case OP_IF_ORP_N: if_bp_push(OP_IF_PR); goto OR_P; + case OP_IF_ORP_N_N: if_bp_push(OP_IF_PRR); goto OR_P; + + case OP_IF_PP: if (sc->value != sc->F) goto EVAL; sc->value = sc->unspecified; continue; + case OP_IF_PN: + case OP_IF_PR: if (sc->value == sc->F) goto EVAL; sc->value = sc->unspecified; continue; + case OP_IF_PPP: sc->code = (sc->value != sc->F) ? car(sc->code) : cadr(sc->code); goto EVAL; + case OP_IF_PRR: sc->code = (sc->value == sc->F) ? car(sc->code) : cadr(sc->code); goto EVAL; + + case OP_WHEN: check_when(sc); goto EVAL; + case OP_WHEN_S: if (op_when_s(sc)) continue; goto EVAL; + case OP_WHEN_A: if (op_when_a(sc)) continue; goto EVAL; case OP_WHEN_P: op_when_p(sc); goto EVAL; - case OP_WHEN_AND_2A: if (op_when_and_2a(sc)) continue; goto EVAL; - case OP_WHEN_AND_3A: if (op_when_and_3a(sc)) continue; goto EVAL; - case OP_WHEN_AND_AP: if (op_when_and_ap(sc)) continue; goto EVAL; - case OP_WHEN_PP: if (op_when_pp(sc)) continue; goto EVAL; - - case OP_UNLESS: check_unless(sc); goto EVAL; - case OP_UNLESS_S: if (op_unless_s(sc)) continue; goto EVAL; - case OP_UNLESS_A: if (op_unless_a(sc)) continue; goto EVAL; + case OP_WHEN_AND_2A: if (op_when_and_2a(sc)) continue; goto EVAL; + case OP_WHEN_AND_3A: if (op_when_and_3a(sc)) continue; goto EVAL; + case OP_WHEN_AND_AP: if (op_when_and_ap(sc)) continue; goto EVAL; + case OP_WHEN_PP: if (op_when_pp(sc)) continue; goto EVAL; + + case OP_UNLESS: check_unless(sc); goto EVAL; + case OP_UNLESS_S: if (op_unless_s(sc)) continue; goto EVAL; + case OP_UNLESS_A: if (op_unless_a(sc)) continue; goto EVAL; case OP_UNLESS_P: op_unless_p(sc); goto EVAL; - case OP_UNLESS_PP: if (op_unless_pp(sc)) continue; goto EVAL; - - - case OP_COND_FEED: if (op_cond_feed(sc)) goto EVAL; /* else fall through */ - case OP_COND_FEED_1: if (is_true(sc, sc->value)) {op_cond_feed_1(sc); goto EVAL;} sc->value = sc->unspecified; continue; - - case OP_COND: check_cond(sc); - case OP_COND_UNCHECKED: if (op_cond_unchecked(sc)) goto EVAL; - case OP_COND1: if (op_cond1(sc)) goto TOP_NO_POP; /* else fall through */ - FEED_TO: - if (feed_to(sc)) goto APPLY; - goto EVAL; - case OP_FEED_TO_1: sc->code = sc->value; goto APPLY; /* sc->args saved in feed_to via push_stack */ - - case OP_COND_SIMPLE: if (op_cond_simple(sc)) goto EVAL; - case OP_COND1_SIMPLE: if (op_cond1_simple(sc)) goto TOP_NO_POP; goto BEGIN; - case OP_COND_SIMPLE_O: if (op_cond_simple_o(sc)) goto EVAL; - case OP_COND1_SIMPLE_O: if (op_cond1_simple_o(sc)) continue; goto EVAL; - - case OP_COND_NA_NA: sc->value = fx_cond_na_na(sc, sc->code); continue; - case OP_COND_NA_NP: if (op_cond_na_np(sc)) continue; goto EVAL; - case OP_COND_NA_NP_1: if (op_cond_na_np_1(sc)) continue; goto EVAL; - case OP_COND_NA_NP_O: if (inline_op_cond_na_np_o(sc)) continue; goto EVAL; - case OP_COND_NA_2E: if (op_cond_na_2e(sc)) continue; goto EVAL; - case OP_COND_NA_3E: if (op_cond_na_3e(sc)) continue; goto EVAL; - - - case OP_AND: - if (check_and(sc, sc->code)) continue; - case OP_AND_P: - sc->code = cdr(sc->code); - AND_P: /* this code (and OR_P below) is ugly, but the pretty version (procedurized) is much slower */ - if (has_fx(sc->code)) /* all fx_proc's are set via fx_choose which can return nil, but it is not cleared when type is */ - { /* so, if (fx_proc(sc->code)) here and in OR_P is not safe */ - sc->value = fx_call(sc, sc->code); - if (is_false(sc, sc->value)) continue; - sc->code = cdr(sc->code); - if (is_null(sc->code)) continue; /* this order of checks appears to be faster than any of the alternatives */ - goto AND_P; - } - if (is_pair(cdr(sc->code))) /* apparently exactly as fast as is_not_null */ - push_stack_no_args(sc, OP_AND_P1, cdr(sc->code)); - sc->code = car(sc->code); - goto EVAL; - - case OP_AND_P1: - if ((is_false(sc, sc->value)) || - (is_null(sc->code))) - continue; - goto AND_P; - - case OP_AND_AP: if (op_and_ap(sc)) continue; goto EVAL; - case OP_AND_2A: sc->value = fx_and_2a(sc, sc->code); continue; - case OP_AND_3A: sc->value = fx_and_3a(sc, sc->code); continue; - case OP_AND_N: sc->value = fx_and_n(sc, sc->code); continue; - case OP_AND_S_2: sc->value = fx_and_s_2(sc, sc->code); continue; - case OP_AND_PAIR_P: if (op_and_pair_p(sc)) continue; goto EVAL; - case OP_AND_SAFE_P1: op_and_safe_p1(sc); goto EVAL; - case OP_AND_SAFE_P2: if (op_and_safe_p2(sc)) continue; goto EVAL; - case OP_AND_SAFE_P3: if (op_and_safe_p3(sc)) continue; goto EVAL; - case OP_AND_SAFE_P_REST: if (is_true(sc, sc->value)) sc->value = fx_and_n(sc, sc->code); continue; - - - case OP_OR: - if (check_or(sc, sc->code)) continue; - case OP_OR_P: - sc->code = cdr(sc->code); - OR_P: - if (has_fx(sc->code)) - { - sc->value = fx_call(sc, sc->code); - if (is_true(sc, sc->value)) continue; - sc->code = cdr(sc->code); - if (is_null(sc->code)) continue; - goto OR_P; - } - if (is_pair(cdr(sc->code))) - push_stack_no_args(sc, OP_OR_P1, cdr(sc->code)); - sc->code = car(sc->code); - goto EVAL; - - case OP_OR_P1: - if ((is_true(sc, sc->value)) || - (is_null(sc->code))) - continue; - goto OR_P; - - case OP_OR_AP: if (op_or_ap(sc)) continue; goto EVAL; - case OP_OR_2A: sc->value = fx_or_2a(sc, sc->code); continue; - case OP_OR_S_2: sc->value = fx_or_s_2(sc, sc->code); continue; - case OP_OR_S_TYPE_2: sc->value = fx_or_s_type_2(sc, sc->code); continue; - case OP_OR_3A: sc->value = fx_or_3a(sc, sc->code); continue; - case OP_OR_N: sc->value = fx_or_n(sc, sc->code); continue; - - - case OP_NAMED_LET_NO_VARS: op_named_let_no_vars(sc); goto BEGIN; - case OP_NAMED_LET: if (op_named_let(sc)) goto BEGIN; goto EVAL; - case OP_NAMED_LET_A: op_named_let_a(sc); goto BEGIN; - case OP_NAMED_LET_AA: op_named_let_aa(sc); goto BEGIN; - case OP_NAMED_LET_NA: if (op_named_let_na(sc)) goto BEGIN; goto EVAL; - - case OP_LET: if (op_let(sc)) goto BEGIN; goto EVAL; - case OP_LET_UNCHECKED: if (op_let_unchecked(sc)) goto BEGIN; goto EVAL; - case OP_LET1: if (op_let1(sc)) goto BEGIN; goto EVAL; - case OP_LET_NO_VARS: op_let_no_vars(sc); goto BEGIN; - - case OP_LET_A_A_OLD: op_let_a_a_old(sc); continue; - case OP_LET_A_A_NEW: op_let_a_a_new(sc); continue; - case OP_LET_A_NA_OLD: op_let_a_na_old(sc); continue; - case OP_LET_A_NA_NEW: op_let_a_na_new(sc); continue; - case OP_LET_NA_OLD: op_let_na_old(sc); goto BEGIN; - case OP_LET_NA_NEW: inline_op_let_na_new(sc); goto BEGIN; - case OP_LET_2A_OLD: op_let_2a_old(sc); goto EVAL; - case OP_LET_2A_NEW: op_let_2a_new(sc); goto EVAL; - case OP_LET_3A_OLD: op_let_3a_old(sc); goto EVAL; - case OP_LET_3A_NEW: op_let_3a_new(sc); goto EVAL; - case OP_LET_ONE_OLD: op_let_one_old(sc); goto EVAL; - case OP_LET_ONE_NEW: op_let_one_new(sc); goto EVAL; - case OP_LET_ONE_P_OLD: op_let_one_p_old(sc); goto EVAL; - case OP_LET_ONE_P_NEW: op_let_one_p_new(sc); goto EVAL; - - case OP_LET_A_OLD: op_let_a_old(sc); sc->code = cdr(sc->code); goto BEGIN; - case OP_LET_A_NEW: inline_op_let_a_new(sc); sc->code = cdr(sc->code); goto BEGIN; - case OP_LET_A_OLD_2: inline_op_let_a_old(sc); push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); sc->code = cadr(sc->code); goto EVAL; - case OP_LET_A_NEW_2: inline_op_let_a_new(sc); push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); sc->code = cadr(sc->code); goto EVAL; - case OP_LET_A_P_OLD: inline_op_let_a_old(sc); sc->code = cadr(sc->code); goto EVAL; - case OP_LET_A_P_NEW: inline_op_let_a_new(sc); sc->code = cadr(sc->code); goto EVAL; - case OP_LET_ONE_OLD_1: op_let_one_old_1(sc); goto BEGIN; - case OP_LET_ONE_P_OLD_1: op_let_one_p_old_1(sc); goto EVAL; - case OP_LET_ONE_NEW_1: set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code), sc->value)); goto BEGIN; - case OP_LET_ONE_P_NEW_1: set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code), sc->value)); sc->code = car(sc->code); goto EVAL; - case OP_LET_opaSSq_OLD: op_let_opassq_old(sc); goto BEGIN; - case OP_LET_opaSSq_NEW: op_let_opassq_new(sc); goto BEGIN; - - case OP_LET_STAR_NA: op_let_star_na(sc); goto BEGIN; - case OP_LET_STAR_NA_A: op_let_star_na_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; - case OP_LET_STAR: if (check_let_star(sc)) goto EVAL; goto BEGIN; - case OP_LET_STAR1: if (op_let_star1(sc)) goto EVAL; goto BEGIN; - case OP_LET_STAR_SHADOWED: if (op_let_star_shadowed(sc)) goto EVAL; goto BEGIN; - - case OP_LETREC: check_letrec(sc, true); - case OP_LETREC_UNCHECKED: if (op_letrec_unchecked(sc)) goto EVAL; goto BEGIN; - case OP_LETREC1: if (op_letrec1(sc)) goto EVAL; goto BEGIN; - - case OP_LETREC_STAR: check_letrec(sc, false); - case OP_LETREC_STAR_UNCHECKED: if (op_letrec_star_unchecked(sc)) goto EVAL; goto BEGIN; - case OP_LETREC_STAR1: if (op_letrec_star1(sc)) goto EVAL; goto BEGIN; - - - case OP_LET_TEMPORARILY: check_let_temporarily(sc); - case OP_LET_TEMP_UNCHECKED: op_let_temp_unchecked(sc); goto LET_TEMP_INIT1; - - case OP_LET_TEMP_INIT1: - op_let_temp_init1_1(sc); - LET_TEMP_INIT1: - if (op_let_temp_init1(sc)) goto EVAL; - case OP_LET_TEMP_INIT2: - switch (op_let_temp_init2(sc)) /* let misc obj */ - { - case goto_begin: goto BEGIN; - case goto_eval: goto EVAL; - case goto_set_unchecked: goto SET_UNCHECKED; - case fall_through: - default: break; - } - - case OP_LET_TEMP_DONE: - sc->code = sc->value; - push_stack(sc, OP_GC_PROTECT, sc->args, sc->value); /* save let-temp body val as sc->code */ - case OP_LET_TEMP_DONE1: - if (op_let_temp_done1(sc)) continue; - goto SET_UNCHECKED; - - case OP_LET_TEMP_S7: if(op_let_temp_s7(sc)) goto BEGIN; sc->value = sc->nil; continue; - case OP_LET_TEMP_S7_DIRECT: if (op_let_temp_s7_direct(sc)) goto BEGIN; sc->value = sc->nil; continue; - case OP_LET_TEMP_NA: if (op_let_temp_na(sc)) goto BEGIN; sc->value = sc->nil; continue; - case OP_LET_TEMP_A: if (op_let_temp_a(sc)) goto BEGIN; sc->value = sc->nil; continue; - case OP_LET_TEMP_SETTER: if (op_let_temp_setter(sc)) goto BEGIN; sc->value = sc->nil; continue; - 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; - case OP_LET_TEMP_S7_DIRECT_UNWIND: op_let_temp_s7_direct_unwind(sc); continue; - case OP_LET_TEMP_SETTER_UNWIND: op_let_temp_setter_unwind(sc); continue; - - - case OP_EVAL_MACRO: op_eval_macro(sc); goto EVAL; - case OP_EVAL_MACRO_MV: if (op_eval_macro_mv(sc)) continue; goto EVAL; - case OP_EXPANSION: op_finish_expansion(sc); continue; - - case OP_DEFINE_BACRO: case OP_DEFINE_BACRO_STAR: - case OP_DEFINE_EXPANSION: case OP_DEFINE_EXPANSION_STAR: - case OP_DEFINE_MACRO: case OP_DEFINE_MACRO_STAR: - op_define_macro(sc); - continue; - - case OP_MACRO: case OP_BACRO: case OP_MACRO_STAR: case OP_BACRO_STAR: - op_macro(sc); - continue; - - case OP_LAMBDA: sc->value = op_lambda(sc, sc->code); continue; - case OP_LAMBDA_UNCHECKED: sc->value = op_lambda_unchecked(sc, sc->code); continue; - case OP_LAMBDA_STAR: op_lambda_star(sc); continue; - case OP_LAMBDA_STAR_UNCHECKED: op_lambda_star_unchecked(sc); continue; - - - case OP_CASE: /* car(sc->code) is the selector */ - /* selector A, key type: E=eq (symbol/char), I=integer, G=any, S=single keys and single bodies */ - if (check_case(sc)) goto EVAL; else goto G_G; /* selector is a symbol or constant, stupid "else" to shut up the compiler */ - - case OP_CASE_A_G_G: sc->value = fx_call(sc, cdr(sc->code)); - G_G: case OP_CASE_G_G: if (op_case_g_g(sc)) goto TOP_NO_POP; goto FEED_TO; - case OP_CASE_A_E_S: sc->value = fx_call(sc, cdr(sc->code)); - case OP_CASE_E_S: op_case_e_s(sc); goto EVAL; + case OP_UNLESS_PP: if (op_unless_pp(sc)) continue; goto EVAL; + + + case OP_COND_FEED: if (op_cond_feed(sc)) goto EVAL; /* else fall through */ + case OP_COND_FEED_1: if (is_true(sc, sc->value)) {op_cond_feed_1(sc); goto EVAL;} sc->value = sc->unspecified; continue; + + case OP_COND: check_cond(sc); + case OP_COND_UNCHECKED: if (op_cond_unchecked(sc)) goto EVAL; + case OP_COND1: if (op_cond1(sc)) goto TOP_NO_POP; /* else fall through */ + FEED_TO: + if (feed_to(sc)) goto APPLY; + goto EVAL; + case OP_FEED_TO_1: sc->code = sc->value; goto APPLY; /* sc->args saved in feed_to via push_stack */ + + case OP_COND_SIMPLE: if (op_cond_simple(sc)) goto EVAL; + case OP_COND1_SIMPLE: if (op_cond1_simple(sc)) goto TOP_NO_POP; goto BEGIN; + case OP_COND_SIMPLE_O: if (op_cond_simple_o(sc)) goto EVAL; + case OP_COND1_SIMPLE_O: if (op_cond1_simple_o(sc)) continue; goto EVAL; + + case OP_COND_NA_NA: sc->value = fx_cond_na_na(sc, sc->code); continue; + case OP_COND_NA_NP: if (op_cond_na_np(sc)) continue; goto EVAL; + case OP_COND_NA_NP_1: if (op_cond_na_np_1(sc)) continue; goto EVAL; + case OP_COND_NA_NP_O: if (inline_op_cond_na_np_o(sc)) continue; goto EVAL; + case OP_COND_NA_2E: if (op_cond_na_2e(sc)) continue; goto EVAL; + case OP_COND_NA_3E: if (op_cond_na_3e(sc)) continue; goto EVAL; + + + case OP_AND: + if (check_and(sc, sc->code)) continue; + case OP_AND_P: + sc->code = cdr(sc->code); + AND_P: /* this code (and OR_P below) is ugly, but the pretty version (procedurized) is much slower */ + if (has_fx(sc->code)) /* all fx_proc's are set via fx_choose which can return nil, but it is not cleared when type is */ + { /* so, if (fx_proc(sc->code)) here and in OR_P is not safe */ + sc->value = fx_call(sc, sc->code); + if (is_false(sc, sc->value)) continue; + sc->code = cdr(sc->code); + if (is_null(sc->code)) continue; /* this order of checks appears to be faster than any of the alternatives */ + goto AND_P; + } + if (is_pair(cdr(sc->code))) /* apparently exactly as fast as is_not_null */ + push_stack_no_args(sc, OP_AND_P1, cdr(sc->code)); + sc->code = car(sc->code); + goto EVAL; + + case OP_AND_P1: + if ((is_false(sc, sc->value)) || + (is_null(sc->code))) + continue; + goto AND_P; + + case OP_AND_AP: if (op_and_ap(sc)) continue; goto EVAL; + case OP_AND_2A: sc->value = fx_and_2a(sc, sc->code); continue; + case OP_AND_3A: sc->value = fx_and_3a(sc, sc->code); continue; + case OP_AND_N: sc->value = fx_and_n(sc, sc->code); continue; + case OP_AND_S_2: sc->value = fx_and_s_2(sc, sc->code); continue; + case OP_AND_PAIR_P: if (op_and_pair_p(sc)) continue; goto EVAL; + case OP_AND_SAFE_P1: op_and_safe_p1(sc); goto EVAL; + case OP_AND_SAFE_P2: if (op_and_safe_p2(sc)) continue; goto EVAL; + case OP_AND_SAFE_P3: if (op_and_safe_p3(sc)) continue; goto EVAL; + case OP_AND_SAFE_P_REST: if (is_true(sc, sc->value)) sc->value = fx_and_n(sc, sc->code); continue; + + + case OP_OR: + if (check_or(sc, sc->code)) continue; + case OP_OR_P: + sc->code = cdr(sc->code); + OR_P: + if (has_fx(sc->code)) + { + sc->value = fx_call(sc, sc->code); + if (is_true(sc, sc->value)) continue; + sc->code = cdr(sc->code); + if (is_null(sc->code)) continue; + goto OR_P; + } + if (is_pair(cdr(sc->code))) + push_stack_no_args(sc, OP_OR_P1, cdr(sc->code)); + sc->code = car(sc->code); + goto EVAL; + + case OP_OR_P1: + if ((is_true(sc, sc->value)) || + (is_null(sc->code))) + continue; + goto OR_P; + + case OP_OR_AP: if (op_or_ap(sc)) continue; goto EVAL; + case OP_OR_2A: sc->value = fx_or_2a(sc, sc->code); continue; + case OP_OR_S_2: sc->value = fx_or_s_2(sc, sc->code); continue; + case OP_OR_S_TYPE_2: sc->value = fx_or_s_type_2(sc, sc->code); continue; + case OP_OR_3A: sc->value = fx_or_3a(sc, sc->code); continue; + case OP_OR_N: sc->value = fx_or_n(sc, sc->code); continue; + + + case OP_NAMED_LET_NO_VARS: op_named_let_no_vars(sc); goto BEGIN; + case OP_NAMED_LET: if (op_named_let(sc)) goto BEGIN; goto EVAL; + case OP_NAMED_LET_A: op_named_let_a(sc); goto BEGIN; + case OP_NAMED_LET_AA: op_named_let_aa(sc); goto BEGIN; + case OP_NAMED_LET_NA: if (op_named_let_na(sc)) goto BEGIN; goto EVAL; + + case OP_LET: if (op_let(sc)) goto BEGIN; goto EVAL; + case OP_LET_UNCHECKED: if (op_let_unchecked(sc)) goto BEGIN; goto EVAL; + case OP_LET1: if (op_let1(sc)) goto BEGIN; goto EVAL; + case OP_LET_NO_VARS: op_let_no_vars(sc); goto BEGIN; + + case OP_LET_A_A_OLD: op_let_a_a_old(sc); continue; + case OP_LET_A_A_NEW: op_let_a_a_new(sc); continue; + case OP_LET_A_NA_OLD: op_let_a_na_old(sc); continue; + case OP_LET_A_NA_NEW: op_let_a_na_new(sc); continue; + case OP_LET_NA_OLD: op_let_na_old(sc); goto BEGIN; + case OP_LET_NA_NEW: inline_op_let_na_new(sc); goto BEGIN; + case OP_LET_2A_OLD: op_let_2a_old(sc); goto EVAL; + case OP_LET_2A_NEW: op_let_2a_new(sc); goto EVAL; + case OP_LET_3A_OLD: op_let_3a_old(sc); goto EVAL; + case OP_LET_3A_NEW: op_let_3a_new(sc); goto EVAL; + case OP_LET_ONE_OLD: op_let_one_old(sc); goto EVAL; + case OP_LET_ONE_NEW: op_let_one_new(sc); goto EVAL; + case OP_LET_ONE_P_OLD: op_let_one_p_old(sc); goto EVAL; + case OP_LET_ONE_P_NEW: op_let_one_p_new(sc); goto EVAL; + + case OP_LET_A_OLD: op_let_a_old(sc); sc->code = cdr(sc->code); goto BEGIN; + case OP_LET_A_NEW: inline_op_let_a_new(sc); sc->code = cdr(sc->code); goto BEGIN; + case OP_LET_A_OLD_2: inline_op_let_a_old(sc); push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); sc->code = cadr(sc->code); goto EVAL; + case OP_LET_A_NEW_2: inline_op_let_a_new(sc); push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); sc->code = cadr(sc->code); goto EVAL; + case OP_LET_A_P_OLD: inline_op_let_a_old(sc); sc->code = cadr(sc->code); goto EVAL; + case OP_LET_A_P_NEW: inline_op_let_a_new(sc); sc->code = cadr(sc->code); goto EVAL; + case OP_LET_ONE_OLD_1: op_let_one_old_1(sc); goto BEGIN; + case OP_LET_ONE_P_OLD_1: op_let_one_p_old_1(sc); goto EVAL; + case OP_LET_ONE_NEW_1: set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code), sc->value)); goto BEGIN; + case OP_LET_ONE_P_NEW_1: set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt2_sym(sc->code), sc->value)); sc->code = car(sc->code); goto EVAL; + case OP_LET_opaSSq_OLD: op_let_opassq_old(sc); goto BEGIN; + case OP_LET_opaSSq_NEW: op_let_opassq_new(sc); goto BEGIN; + + case OP_LET_STAR_NA: op_let_star_na(sc); goto BEGIN; + case OP_LET_STAR_NA_A: op_let_star_na_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; + case OP_LET_STAR: if (check_let_star(sc)) goto EVAL; goto BEGIN; + case OP_LET_STAR1: if (op_let_star1(sc)) goto EVAL; goto BEGIN; + case OP_LET_STAR_SHADOWED: if (op_let_star_shadowed(sc)) goto EVAL; goto BEGIN; + + case OP_LETREC: check_letrec(sc, true); + case OP_LETREC_UNCHECKED: if (op_letrec_unchecked(sc)) goto EVAL; goto BEGIN; + case OP_LETREC1: if (op_letrec1(sc)) goto EVAL; goto BEGIN; + + case OP_LETREC_STAR: check_letrec(sc, false); + case OP_LETREC_STAR_UNCHECKED: if (op_letrec_star_unchecked(sc)) goto EVAL; goto BEGIN; + case OP_LETREC_STAR1: if (op_letrec_star1(sc)) goto EVAL; goto BEGIN; + + + case OP_LET_TEMPORARILY: check_let_temporarily(sc); + case OP_LET_TEMP_UNCHECKED: op_let_temp_unchecked(sc); goto LET_TEMP_INIT1; + + case OP_LET_TEMP_INIT1: + op_let_temp_init1_1(sc); + LET_TEMP_INIT1: + if (op_let_temp_init1(sc)) goto EVAL; + case OP_LET_TEMP_INIT2: + switch (op_let_temp_init2(sc)) /* let misc obj */ + { + case goto_begin: goto BEGIN; + case goto_eval: goto EVAL; + case goto_set_unchecked: goto SET_UNCHECKED; + case fall_through: + default: break; + } + + case OP_LET_TEMP_DONE: + sc->code = sc->value; + push_stack(sc, OP_GC_PROTECT, sc->args, sc->value); /* save let-temp body val as sc->code */ + case OP_LET_TEMP_DONE1: + if (op_let_temp_done1(sc)) continue; + goto SET_UNCHECKED; + + case OP_LET_TEMP_S7: if(op_let_temp_s7(sc)) goto BEGIN; sc->value = sc->nil; continue; + case OP_LET_TEMP_S7_DIRECT: if (op_let_temp_s7_direct(sc)) goto BEGIN; sc->value = sc->nil; continue; + case OP_LET_TEMP_NA: if (op_let_temp_na(sc)) goto BEGIN; sc->value = sc->nil; continue; + case OP_LET_TEMP_A: if (op_let_temp_a(sc)) goto BEGIN; sc->value = sc->nil; continue; + case OP_LET_TEMP_SETTER: if (op_let_temp_setter(sc)) goto BEGIN; sc->value = sc->nil; continue; + 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; + case OP_LET_TEMP_S7_DIRECT_UNWIND: op_let_temp_s7_direct_unwind(sc); continue; + case OP_LET_TEMP_SETTER_UNWIND: op_let_temp_setter_unwind(sc); continue; + + + case OP_EVAL_MACRO: op_eval_macro(sc); goto EVAL; + case OP_EVAL_MACRO_MV: if (op_eval_macro_mv(sc)) continue; goto EVAL; + case OP_EXPANSION: op_finish_expansion(sc); continue; + + case OP_DEFINE_BACRO: case OP_DEFINE_BACRO_STAR: + case OP_DEFINE_EXPANSION: case OP_DEFINE_EXPANSION_STAR: + case OP_DEFINE_MACRO: case OP_DEFINE_MACRO_STAR: + op_define_macro(sc); + continue; + + case OP_MACRO: case OP_BACRO: case OP_MACRO_STAR: case OP_BACRO_STAR: + op_macro(sc); + continue; + + case OP_LAMBDA: sc->value = op_lambda(sc, sc->code); continue; + case OP_LAMBDA_UNCHECKED: sc->value = op_lambda_unchecked(sc, sc->code); continue; + case OP_LAMBDA_STAR: op_lambda_star(sc); continue; + case OP_LAMBDA_STAR_UNCHECKED: op_lambda_star_unchecked(sc); continue; + + + case OP_CASE: /* car(sc->code) is the selector */ + /* selector A, key type: E=eq (symbol/char), I=integer, G=any, S=single keys and single bodies */ + if (check_case(sc)) goto EVAL; else goto G_G; /* selector is a symbol or constant, stupid "else" to shut up the compiler */ + + case OP_CASE_A_G_G: sc->value = fx_call(sc, cdr(sc->code)); + G_G: case OP_CASE_G_G: if (op_case_g_g(sc)) goto TOP_NO_POP; goto FEED_TO; + case OP_CASE_A_E_S: sc->value = fx_call(sc, cdr(sc->code)); + case OP_CASE_E_S: op_case_e_s(sc); goto EVAL; #if (!WITH_GMP) - case OP_CASE_P_I_S: push_stack_no_args_direct(sc, OP_CASE_I_S); sc->code = cadr(sc->code); goto EVAL; - case OP_CASE_A_I_S: sc->value = fx_call(sc, cdr(sc->code)); - case OP_CASE_I_S: if (op_case_i_s(sc)) continue; goto EVAL; -#endif - case OP_CASE_A_G_S: sc->value = fx_call(sc, cdr(sc->code)); /* this almost never happens? */ - case OP_CASE_G_S: op_case_g_s(sc); goto EVAL; - - case OP_CASE_A_E_G: sc->value = fx_call(sc, cdr(sc->code)); - case OP_CASE_E_G: if (op_case_e_g_1(sc, sc->value, is_simple(sc->value))) goto TOP_NO_POP; goto FEED_TO; - case OP_CASE_A_S_G: /* splitting this case out matters in lint */ - sc->value = fx_call(sc, cdr(sc->code)); - if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value))) goto TOP_NO_POP; else goto FEED_TO; - - case OP_CASE_P_G_G: push_stack_no_args_direct(sc, OP_CASE_G_G); 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 = cadr(sc->code); goto EVAL; - case OP_CASE_P_G_S: push_stack_no_args_direct(sc, OP_CASE_G_S); 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 = cadr(sc->code); goto EVAL; + case OP_CASE_P_I_S: push_stack_no_args_direct(sc, OP_CASE_I_S); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_A_I_S: sc->value = fx_call(sc, cdr(sc->code)); + case OP_CASE_I_S: if (op_case_i_s(sc)) continue; goto EVAL; +#endif + case OP_CASE_A_G_S: sc->value = fx_call(sc, cdr(sc->code)); /* this almost never happens? */ + case OP_CASE_G_S: op_case_g_s(sc); goto EVAL; + + case OP_CASE_A_E_G: sc->value = fx_call(sc, cdr(sc->code)); + case OP_CASE_E_G: if (op_case_e_g_1(sc, sc->value, is_simple(sc->value))) goto TOP_NO_POP; goto FEED_TO; + case OP_CASE_A_S_G: /* splitting this case out matters in lint */ + sc->value = fx_call(sc, cdr(sc->code)); + if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value))) goto TOP_NO_POP; else goto FEED_TO; + + case OP_CASE_P_G_G: push_stack_no_args_direct(sc, OP_CASE_G_G); 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 = cadr(sc->code); goto EVAL; + case OP_CASE_P_G_S: push_stack_no_args_direct(sc, OP_CASE_G_S); 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 = cadr(sc->code); goto EVAL; #if (!WITH_GMP) - case OP_CASE_A_I_S_A: sc->value = fx_case_a_i_s_a(sc, sc->code); continue; -#endif - case OP_CASE_A_E_S_A: sc->value = fx_case_a_e_s_a(sc, sc->code); continue; - case OP_CASE_A_G_S_A: sc->value = fx_case_a_g_s_a(sc, sc->code); continue; - case OP_CASE_A_S_G_A: sc->value = fx_case_a_s_g_a(sc, sc->code); continue; - - - case OP_ERROR_QUIT: - if (sc->stack_end <= sc->stack_start) stack_reset(sc); /* sets stack_end to stack_start, then pushes op_eval_done, (can <= be <?) */ - return(sc->F); - - case OP_ERROR_HOOK_QUIT: - op_error_hook_quit(sc); - - case OP_EVAL_DONE: - return(sc->F); - - case OP_SPLICE_VALUES: /* if splice_in_values hits eval_done, it needs to continue the splice after returning, so we get here */ - sc->value = splice_in_values(sc, sc->args); - continue; - - case OP_GC_PROTECT: case OP_BARRIER: case OP_NO_VALUES: - case OP_CATCH_ALL: case OP_CATCH: case OP_CATCH_1: case OP_CATCH_2: - if (SHOW_EVAL_OPS) fprintf(stderr, " flush %s\n", op_names[sc->cur_op]); - continue; - - case OP_GET_OUTPUT_STRING: op_get_output_string(sc); /* from call-with-output-string|with-output-to-string; return the port string directly *//* fall through */ - case OP_UNWIND_OUTPUT: op_unwind_output(sc); continue; - case OP_UNWIND_INPUT: op_unwind_input(sc); continue; - case OP_DYNAMIC_UNWIND: dynamic_unwind(sc, sc->code, sc->args); continue; - case OP_PROFILE_IN: g_profile_in(sc, set_plist_2(sc, cadr(sc->code), sc->curlet)); continue; - case OP_DYNAMIC_UNWIND_PROFILE: g_profile_out(sc, set_plist_1(sc, sc->args)); continue; - case OP_DYNAMIC_WIND: if (op_dynamic_wind(sc)) goto APPLY; continue; - case OP_DEACTIVATE_GOTO: call_exit_active(sc->args) = false; continue; /* deactivate the exiter */ - - case OP_WITH_LET_S: sc->value = fx_with_let_s(sc, sc->code); continue; - case OP_WITH_LET: check_with_let(sc); - case OP_WITH_LET_UNCHECKED: if (op_with_let_unchecked(sc)) goto EVAL; - case OP_WITH_LET1: if (sc->value != sc->curlet) activate_with_let(sc, sc->value); goto BEGIN; - - case OP_WITH_BAFFLE: check_with_baffle(sc); - case OP_WITH_BAFFLE_UNCHECKED: if (op_with_baffle_unchecked(sc)) continue; goto BEGIN; - - - case OP_READ_INTERNAL: op_read_internal(sc); continue; - case OP_READ_DONE: op_read_done(sc); continue; - case OP_LOAD_RETURN_IF_EOF: if (op_load_return_if_eof(sc)) goto EVAL; return(sc->F); - case OP_LOAD_CLOSE_AND_POP_IF_EOF: if (op_load_close_and_pop_if_eof(sc)) goto EVAL; continue; - - POP_READ_LIST: - if (pop_read_list(sc)) goto READ_NEXT; - - READ_LIST: - case OP_READ_LIST: /* sc->args is sc->nil at first */ - sc->args = cons(sc, sc->value, sc->args); - - READ_NEXT: - case OP_READ_NEXT: /* this is 75% of the token calls, so expanding it saves lots of time */ - { - int32_t c; - s7_pointer pt = current_input_port(sc); - c = port_read_white_space(pt)(sc, pt); - - READ_C: - switch (c) - { - case '(': - c = port_read_white_space(pt)(sc, pt); /* sc->tok = token(sc) */ - switch (c) - { - case '(': sc->tok = TOKEN_LEFT_PAREN; break; - case ')': sc->value = sc->nil; goto READ_LIST; /* was tok = TOKEN_RIGHT_PAREN */ - case '.': sc->tok = read_dot(sc, pt); break; - case '\'': sc->tok = TOKEN_QUOTE; break; - case ';': sc->tok = port_read_semicolon(pt)(sc, pt); break; - case '"': sc->tok = TOKEN_DOUBLE_QUOTE; break; - case '`': sc->tok = TOKEN_BACK_QUOTE; break; - case ',': sc->tok = read_comma(sc, pt); break; - case '#': sc->tok = read_sharp(sc, pt); break; - case '\0': case EOF: sc->tok = TOKEN_EOF; break; - - default: /* read first element of list (ignore callgrind confusion -- this happens a lot) */ - c = read_start_list(sc, pt, c); - goto READ_C; - } - if (sc->tok == TOKEN_ATOM) - { - c = read_atom(sc, pt); - goto READ_C; - } - if (sc->tok == TOKEN_RIGHT_PAREN) - { - sc->value = sc->nil; - goto READ_LIST; - } - if (sc->tok == TOKEN_DOT) - { - do {c = inchar(pt);} while ((c != ')') && (c != EOF)); - read_error_nr(sc, "stray dot after '('?"); /* (car '( . )) */ - } - if (sc->tok == TOKEN_EOF) - missing_close_paren_error_nr(sc); - - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil); - /* check_stack_size(sc); */ - sc->value = read_expression(sc); - if (stack_top_op(sc) == OP_READ_LIST) goto POP_READ_LIST; - continue; - - case ')': - sc->tok = TOKEN_RIGHT_PAREN; - break; - - case '.': - sc->tok = read_dot(sc, pt); /* dot or atom */ - break; - - case '\'': - sc->tok = TOKEN_QUOTE; - /* might need check_stack_size(sc) here */ - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - sc->value = read_expression(sc); - continue; - - case ';': - sc->tok = port_read_semicolon(pt)(sc, pt); - break; - - case '"': - sc->tok = TOKEN_DOUBLE_QUOTE; - read_double_quote(sc); - goto READ_LIST; - - case '`': - sc->tok = TOKEN_BACK_QUOTE; - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - sc->value = read_expression(sc); - if (stack_top_op(sc) == OP_READ_LIST) goto POP_READ_LIST; - continue; - - case ',': - sc->tok = read_comma(sc, pt); /* at_mark or comma */ - push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); - sc->value = read_expression(sc); - continue; - - case '#': - sc->tok = read_sharp(sc, pt); - break; - - case '\0': - case EOF: - missing_close_paren_error_nr(sc); - - default: - sc->strbuf[0] = (unsigned char)c; - sc->value = port_read_name(pt)(sc, pt); - goto READ_LIST; - }} - - READ_TOK: - switch (sc->tok) - { - case TOKEN_RIGHT_PAREN: /* sc->args can't be null here */ - sc->value = proper_list_reverse_in_place(sc, sc->args); - if ((is_expansion(car(sc->value))) && - (sc->is_expanding)) - switch (op_expansion(sc)) - { - case goto_begin: goto BEGIN; - case goto_apply_lambda: goto APPLY_LAMBDA; - default: break; - } - break; - - case TOKEN_EOF: missing_close_paren_error_nr(sc); /* can't happen, I believe */ - case TOKEN_ATOM: sc->value = port_read_name(current_input_port(sc))(sc, current_input_port(sc)); goto READ_LIST; - case TOKEN_SHARP_CONST: if (read_sharp_const(sc)) goto READ_TOK; goto READ_LIST; - case TOKEN_DOUBLE_QUOTE: read_double_quote(sc); goto READ_LIST; - case TOKEN_DOT: read_dot_and_expression(sc); break; - default: read_tok_default(sc); break; - } - if (stack_top_op(sc) == OP_READ_LIST) goto POP_READ_LIST; - continue; - - case OP_READ_DOT: - switch (op_read_dot(sc)) - { - case goto_start: continue; - case goto_pop_read_list: goto POP_READ_LIST; - default: goto READ_TOK; - } - case OP_READ_QUOTE: if (op_read_quote(sc)) continue; goto POP_READ_LIST; - case OP_READ_QUASIQUOTE: if (op_read_quasiquote(sc)) continue; goto POP_READ_LIST; - case OP_READ_UNQUOTE: if (op_read_unquote(sc)) continue; goto POP_READ_LIST; - case OP_READ_APPLY_VALUES: if (op_read_apply_values(sc)) continue; goto POP_READ_LIST; - case OP_READ_VECTOR: if (op_read_vector(sc)) continue; goto POP_READ_LIST; - case OP_READ_INT_VECTOR: if (op_read_int_vector(sc)) continue; goto POP_READ_LIST; - case OP_READ_FLOAT_VECTOR: if (op_read_float_vector(sc)) continue; goto POP_READ_LIST; - case OP_READ_BYTE_VECTOR: if (op_read_byte_vector(sc)) continue; goto POP_READ_LIST; - - case OP_CLEAR_OPTS: - break; - - default: - return(sc->F); - } + case OP_CASE_A_I_S_A: sc->value = fx_case_a_i_s_a(sc, sc->code); continue; +#endif + case OP_CASE_A_E_S_A: sc->value = fx_case_a_e_s_a(sc, sc->code); continue; + case OP_CASE_A_G_S_A: sc->value = fx_case_a_g_s_a(sc, sc->code); continue; + case OP_CASE_A_S_G_A: sc->value = fx_case_a_s_g_a(sc, sc->code); continue; + + + case OP_ERROR_QUIT: + if (sc->stack_end <= sc->stack_start) stack_reset(sc); /* sets stack_end to stack_start, then pushes op_eval_done, (can <= be <?) */ + return(sc->F); + + case OP_ERROR_HOOK_QUIT: + op_error_hook_quit(sc); + + case OP_EVAL_DONE: + return(sc->F); + + case OP_SPLICE_VALUES: /* if splice_in_values hits eval_done, it needs to continue the splice after returning, so we get here */ + sc->value = splice_in_values(sc, sc->args); + continue; + + case OP_GC_PROTECT: case OP_BARRIER: case OP_NO_VALUES: + case OP_CATCH_ALL: case OP_CATCH: case OP_CATCH_1: case OP_CATCH_2: + if (SHOW_EVAL_OPS) fprintf(stderr, " flush %s\n", op_names[sc->cur_op]); + continue; + + case OP_GET_OUTPUT_STRING: op_get_output_string(sc); /* from call-with-output-string|with-output-to-string; return the port string directly *//* fall through */ + case OP_UNWIND_OUTPUT: op_unwind_output(sc); continue; + case OP_UNWIND_INPUT: op_unwind_input(sc); continue; + case OP_DYNAMIC_UNWIND: dynamic_unwind(sc, sc->code, sc->args); continue; + case OP_PROFILE_IN: g_profile_in(sc, set_plist_2(sc, cadr(sc->code), sc->curlet)); continue; + case OP_DYNAMIC_UNWIND_PROFILE: g_profile_out(sc, set_plist_1(sc, sc->args)); continue; + case OP_DYNAMIC_WIND: if (op_dynamic_wind(sc)) goto APPLY; continue; + case OP_DEACTIVATE_GOTO: call_exit_active(sc->args) = false; continue; /* deactivate the exiter */ + + case OP_WITH_LET_S: sc->value = fx_with_let_s(sc, sc->code); continue; + case OP_WITH_LET: check_with_let(sc); + case OP_WITH_LET_UNCHECKED: if (op_with_let_unchecked(sc)) goto EVAL; + case OP_WITH_LET1: if (sc->value != sc->curlet) activate_with_let(sc, sc->value); goto BEGIN; + + case OP_WITH_BAFFLE: check_with_baffle(sc); + case OP_WITH_BAFFLE_UNCHECKED: if (op_with_baffle_unchecked(sc)) continue; goto BEGIN; + + + case OP_READ_INTERNAL: op_read_internal(sc); continue; + case OP_READ_DONE: op_read_done(sc); continue; + case OP_LOAD_RETURN_IF_EOF: if (op_load_return_if_eof(sc)) goto EVAL; return(sc->F); + case OP_LOAD_CLOSE_AND_POP_IF_EOF: if (op_load_close_and_pop_if_eof(sc)) goto EVAL; continue; + + POP_READ_LIST: + if (pop_read_list(sc)) goto READ_NEXT; + + READ_LIST: + case OP_READ_LIST: /* sc->args is sc->nil at first */ + sc->args = cons(sc, sc->value, sc->args); + + READ_NEXT: + case OP_READ_NEXT: /* this is 75% of the token calls, so expanding it saves lots of time */ + { + int32_t c; + s7_pointer pt = current_input_port(sc); + c = port_read_white_space(pt)(sc, pt); + + READ_C: + switch (c) + { + case '(': + c = port_read_white_space(pt)(sc, pt); /* sc->tok = token(sc) */ + switch (c) + { + case '(': sc->tok = TOKEN_LEFT_PAREN; break; + case ')': sc->value = sc->nil; goto READ_LIST; /* was tok = TOKEN_RIGHT_PAREN */ + case '.': sc->tok = read_dot(sc, pt); break; + case '\'': sc->tok = TOKEN_QUOTE; break; + case ';': sc->tok = port_read_semicolon(pt)(sc, pt); break; + case '"': sc->tok = TOKEN_DOUBLE_QUOTE; break; + case '`': sc->tok = TOKEN_BACK_QUOTE; break; + case ',': sc->tok = read_comma(sc, pt); break; + case '#': sc->tok = read_sharp(sc, pt); break; + case '\0': case EOF: sc->tok = TOKEN_EOF; break; + + default: /* read first element of list (ignore callgrind confusion -- this happens a lot) */ + c = read_start_list(sc, pt, c); + goto READ_C; + } + if (sc->tok == TOKEN_ATOM) + { + c = read_atom(sc, pt); + goto READ_C; + } + if (sc->tok == TOKEN_RIGHT_PAREN) + { + sc->value = sc->nil; + goto READ_LIST; + } + if (sc->tok == TOKEN_DOT) + { + do {c = inchar(pt);} while ((c != ')') && (c != EOF)); + read_error_nr(sc, "stray dot after '('?"); /* (car '( . )) */ + } + if (sc->tok == TOKEN_EOF) + missing_close_paren_error_nr(sc); + + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil); + /* check_stack_size(sc); */ + sc->value = read_expression(sc); + if (stack_top_op(sc) == OP_READ_LIST) goto POP_READ_LIST; + continue; + + case ')': + sc->tok = TOKEN_RIGHT_PAREN; + break; + + case '.': + sc->tok = read_dot(sc, pt); /* dot or atom */ + break; + + case '\'': + sc->tok = TOKEN_QUOTE; + /* might need check_stack_size(sc) here */ + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + sc->value = read_expression(sc); + continue; + + case ';': + sc->tok = port_read_semicolon(pt)(sc, pt); + break; + + case '"': + sc->tok = TOKEN_DOUBLE_QUOTE; + read_double_quote(sc); + goto READ_LIST; + + case '`': + sc->tok = TOKEN_BACK_QUOTE; + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + sc->value = read_expression(sc); + if (stack_top_op(sc) == OP_READ_LIST) goto POP_READ_LIST; + continue; + + case ',': + sc->tok = read_comma(sc, pt); /* at_mark or comma */ + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + sc->value = read_expression(sc); + continue; + + case '#': + sc->tok = read_sharp(sc, pt); + break; + + case '\0': + case EOF: + missing_close_paren_error_nr(sc); + + default: + sc->strbuf[0] = (unsigned char)c; + sc->value = port_read_name(pt)(sc, pt); + goto READ_LIST; + }} + + READ_TOK: + switch (sc->tok) + { + case TOKEN_RIGHT_PAREN: /* sc->args can't be null here */ + sc->value = proper_list_reverse_in_place(sc, sc->args); + if ((is_expansion(car(sc->value))) && + (sc->is_expanding)) + switch (op_expansion(sc)) + { + case goto_begin: goto BEGIN; + case goto_apply_lambda: goto APPLY_LAMBDA; + default: break; + } + break; + + case TOKEN_EOF: missing_close_paren_error_nr(sc); /* can't happen, I believe */ + case TOKEN_ATOM: sc->value = port_read_name(current_input_port(sc))(sc, current_input_port(sc)); goto READ_LIST; + case TOKEN_SHARP_CONST: if (read_sharp_const(sc)) goto READ_TOK; goto READ_LIST; + case TOKEN_DOUBLE_QUOTE: read_double_quote(sc); goto READ_LIST; + case TOKEN_DOT: read_dot_and_expression(sc); break; + default: read_tok_default(sc); break; + } + if (stack_top_op(sc) == OP_READ_LIST) goto POP_READ_LIST; + continue; + + case OP_READ_DOT: + switch (op_read_dot(sc)) + { + case goto_start: continue; + case goto_pop_read_list: goto POP_READ_LIST; + default: goto READ_TOK; + } + case OP_READ_QUOTE: if (op_read_quote(sc)) continue; goto POP_READ_LIST; + case OP_READ_QUASIQUOTE: if (op_read_quasiquote(sc)) continue; goto POP_READ_LIST; + case OP_READ_UNQUOTE: if (op_read_unquote(sc)) continue; goto POP_READ_LIST; + case OP_READ_APPLY_VALUES: if (op_read_apply_values(sc)) continue; goto POP_READ_LIST; + case OP_READ_VECTOR: if (op_read_vector(sc)) continue; goto POP_READ_LIST; + case OP_READ_INT_VECTOR: if (op_read_int_vector(sc)) continue; goto POP_READ_LIST; + case OP_READ_FLOAT_VECTOR: if (op_read_float_vector(sc)) continue; goto POP_READ_LIST; + case OP_READ_BYTE_VECTOR: if (op_read_byte_vector(sc)) continue; goto POP_READ_LIST; + + case OP_CLEAR_OPTS: + break; + + default: + return(sc->F); + } /* this code is reached from OP_CLEAR_OPTS and many others where the optimization has turned out to be incorrect, OP_CLOSURE_SYM for example; search for break */ if (!tree_is_cyclic(sc, sc->code)) - clear_all_optimizations(sc, sc->code); + clear_all_optimizations(sc, sc->code); UNOPT: switch (trailers(sc)) - { - case goto_top_no_pop: goto TOP_NO_POP; - case goto_eval_args_top: goto EVAL_ARGS_TOP; - case goto_eval: goto EVAL; - case goto_start: continue; /* sc->value has been set, this is OP_SYMBOL|CONSTANT on the next pass */ - default: - if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: unexpected switch default: %s\n", __func__, __LINE__, display(sc->code)); - break; - }} + { + case goto_top_no_pop: goto TOP_NO_POP; + case goto_eval_args_top: goto EVAL_ARGS_TOP; + case goto_eval: goto EVAL; + case goto_start: continue; /* sc->value has been set, this is OP_SYMBOL|CONSTANT on the next pass */ + default: + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: unexpected switch default: %s\n", __func__, __LINE__, display(sc->code)); + break; + }} return(sc->F); /* this never happens (make the compiler happy) */ } @@ -93858,14 +93858,14 @@ static void mark_stack_holdees(s7_scheme *sc, s7_pointer p, s7_int top) s7_pointer heap0 = *(sc->heap); s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size); for (s7_pointer *tp = (s7_pointer *)(stack_elements(p)), *tend = (s7_pointer *)(tp + top); (tp < tend); tp++) - { - s7_pointer x = *tp++; - if ((x >= heap0) && (x < heap1)) mark_holdee(p, x, NULL); - x = *tp++; - if ((x >= heap0) && (x < heap1)) mark_holdee(p, x, NULL); - x = *tp++; - if ((x >= heap0) && (x < heap1)) mark_holdee(p, x, NULL); - }} + { + s7_pointer x = *tp++; + if ((x >= heap0) && (x < heap1)) mark_holdee(p, x, NULL); + x = *tp++; + if ((x >= heap0) && (x < heap1)) mark_holdee(p, x, NULL); + x = *tp++; + if ((x >= heap0) && (x < heap1)) mark_holdee(p, x, NULL); + }} } static void save_holder_data(s7_scheme *sc, s7_pointer p) @@ -93896,7 +93896,7 @@ static void save_holder_data(s7_scheme *sc, s7_pointer p) case T_VECTOR: if (is_subvector(p)) mark_holdee(p, subvector_vector(p), NULL); for (s7_int i = 0, len = vector_length(p); i < len; i++) - if (vector_element(p, i)) mark_holdee(p, vector_element(p, i), NULL); + if (vector_element(p, i)) mark_holdee(p, vector_element(p, i), NULL); break; case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: @@ -93905,17 +93905,17 @@ static void save_holder_data(s7_scheme *sc, s7_pointer p) case T_LET: if (p != sc->rootlet) /* do rootlet later? */ - { - for (s7_pointer slot = let_slots(p); tis_slot(slot); slot = next_slot(slot)) mark_holdee(p, slot, NULL); - if (has_dox_slot1(p)) mark_holdee(p, let_dox_slot1(p), NULL); - if ((has_dox_slot2(p)) && (is_slot(let_dox_slot2(p)))) mark_holdee(p, let_dox_slot2(p), NULL); - } + { + for (s7_pointer slot = let_slots(p); tis_slot(slot); slot = next_slot(slot)) mark_holdee(p, slot, NULL); + if (has_dox_slot1(p)) mark_holdee(p, let_dox_slot1(p), NULL); + if ((has_dox_slot2(p)) && (is_slot(let_dox_slot2(p)))) mark_holdee(p, let_dox_slot2(p), NULL); + } break; case T_C_FUNCTION_STAR: if ((!c_func_has_simple_defaults(p)) && (c_function_call_args(p))) - for (s7_pointer arg = c_function_call_args(p); is_pair(arg); arg = cdr(arg)) - mark_holdee(p, car(arg), NULL); + for (s7_pointer arg = c_function_call_args(p); is_pair(arg); arg = cdr(arg)) + mark_holdee(p, car(arg), NULL); break; case T_CLOSURE: case T_CLOSURE_STAR: @@ -93930,28 +93930,28 @@ static void save_holder_data(s7_scheme *sc, s7_pointer p) case T_HASH_TABLE: mark_holdee(p, hash_table_procedures(p), NULL); if (is_pair(hash_table_procedures(p))) - { - mark_holdee(p, hash_table_key_typer_unchecked(p), NULL); - mark_holdee(p, hash_table_value_typer_unchecked(p), NULL); - } + { + mark_holdee(p, hash_table_key_typer_unchecked(p), NULL); + mark_holdee(p, hash_table_value_typer_unchecked(p), NULL); + } if (hash_table_entries(p) > 0) - { - s7_int len = hash_table_size(p); - hash_entry_t **entries = hash_table_elements(p); - hash_entry_t **last = (hash_entry_t **)(entries + len); - if ((is_weak_hash_table(p)) && (weak_hash_iters(p) == 0)) - while (entries < last) - { - for (hash_entry_t *xp = *entries++; xp; xp = hash_entry_next(xp)) - mark_holdee(p, hash_entry_value(xp), NULL); - } - else - while (entries < last) - for (hash_entry_t *xp = *entries++; xp; xp = hash_entry_next(xp)) - { - mark_holdee(p, hash_entry_key(xp), NULL); - mark_holdee(p, hash_entry_value(xp), NULL); - }} + { + s7_int len = hash_table_size(p); + hash_entry_t **entries = hash_table_elements(p); + hash_entry_t **last = (hash_entry_t **)(entries + len); + if ((is_weak_hash_table(p)) && (weak_hash_iters(p) == 0)) + while (entries < last) + { + for (hash_entry_t *xp = *entries++; xp; xp = hash_entry_next(xp)) + mark_holdee(p, hash_entry_value(xp), NULL); + } + else + while (entries < last) + for (hash_entry_t *xp = *entries++; xp; xp = hash_entry_next(xp)) + { + mark_holdee(p, hash_entry_key(xp), NULL); + mark_holdee(p, hash_entry_value(xp), NULL); + }} break; case T_CONTINUATION: @@ -93984,8 +93984,8 @@ void s7_heap_analyze(s7_scheme *sc) if (tmps_top > sc->previous_free_heap_top) tmps_top = sc->previous_free_heap_top; while (tmps < tmps_top) { - s7_pointer p = *tmps++; - mark_holdee(NULL, p, "gc temp"); + s7_pointer p = *tmps++; + mark_holdee(NULL, p, "gc temp"); }} mark_holdee(NULL, sc->w, "sc->w"); @@ -94090,15 +94090,15 @@ void s7_heap_analyze(s7_scheme *sc) gc_list_t *gp = sc->opt1_funcs; for (s7_int i = 0; i < gp->loc; i++) { - s7_pointer s1 = T_Pair(gp->list[i]); - mark_holdee(NULL, opt1_any(s1), "opt1_funcs"); + s7_pointer s1 = T_Pair(gp->list[i]); + mark_holdee(NULL, opt1_any(s1), "opt1_funcs"); }} for (int32_t i = 1; i < NUM_SAFE_LISTS; i++) if ((is_pair(sc->safe_lists[i])) && - (list_is_in_use(sc->safe_lists[i]))) + (list_is_in_use(sc->safe_lists[i]))) for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p)) - mark_holdee(NULL, car(p), "safe_lists"); + mark_holdee(NULL, car(p), "safe_lists"); for (s7_pointer p = sc->wrong_type_arg_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "wrong-type-arg"); for (s7_pointer p = sc->sole_arg_wrong_type_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "simple wrong-type-arg"); @@ -94128,22 +94128,22 @@ void s7_heap_scan(s7_scheme *sc, int32_t typ) { s7_pointer obj = sc->heap[k]; if (unchecked_type(obj) == typ) - { - found_one = true; - if (obj->holders == 0) - fprintf(stderr, "%s found no holder (alloc: %s[%d])\n", display_truncated(obj), obj->alloc_func, obj->alloc_line); - else - if (!obj->holder) - fprintf(stderr, "%s has built-in holder (holders: %d, alloc: %s[%d])\n", display_truncated(obj), obj->holders, obj->alloc_func, obj->alloc_line); - else - if (obj->root) - fprintf(stderr, "%s from %s alloc: %s[%d] (%d holder%s, alloc: %s[%d])\n", - display_truncated(obj), obj->root, obj->alloc_func, obj->alloc_line, - obj->holders, (obj->holders != 1) ? "s" : "", obj->holder->alloc_func, obj->holder->alloc_line); - else fprintf(stderr, "%s (%s, alloc: %s[%d], holder%s: %d %p %s alloc: %s[%d])\n", - display_truncated(obj), s7_type_names[unchecked_type(obj->holder)], obj->alloc_func, obj->alloc_line, - (obj->holders != 1) ? "s" : "", obj->holders, obj->holder, display(obj->holder), obj->holder->alloc_func, obj->holder->alloc_line); - }} + { + found_one = true; + if (obj->holders == 0) + fprintf(stderr, "%s found no holder (alloc: %s[%d])\n", display_truncated(obj), obj->alloc_func, obj->alloc_line); + else + if (!obj->holder) + fprintf(stderr, "%s has built-in holder (holders: %d, alloc: %s[%d])\n", display_truncated(obj), obj->holders, obj->alloc_func, obj->alloc_line); + else + if (obj->root) + fprintf(stderr, "%s from %s alloc: %s[%d] (%d holder%s, alloc: %s[%d])\n", + display_truncated(obj), obj->root, obj->alloc_func, obj->alloc_line, + obj->holders, (obj->holders != 1) ? "s" : "", obj->holder->alloc_func, obj->holder->alloc_line); + else fprintf(stderr, "%s (%s, alloc: %s[%d], holder%s: %d %p %s alloc: %s[%d])\n", + display_truncated(obj), s7_type_names[unchecked_type(obj->holder)], obj->alloc_func, obj->alloc_line, + (obj->holders != 1) ? "s" : "", obj->holders, obj->holder, display(obj->holder), obj->holder->alloc_func, obj->holder->alloc_line); + }} if (!found_one) fprintf(stderr, "heap-scan: no %s found\n", s7_type_names[typ]); } @@ -94231,21 +94231,21 @@ static s7_pointer g_is_op_stack(s7_scheme *sc, s7_pointer args) static noreturn void s7_starlet_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typ) { error_nr(sc, sc->wrong_type_arg_symbol, - set_elist_5(sc, wrap_string(sc, "(set! (*s7* '~A) ~S): new value is ~A but should be ~A", 54), - caller, arg, object_type_name(sc, arg), typ)); + set_elist_5(sc, wrap_string(sc, "(set! (*s7* '~A) ~S): new value is ~A but should be ~A", 54), + caller, arg, object_type_name(sc, arg), typ)); } static noreturn void sl_stacktrace_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int num, s7_pointer arg, s7_pointer typ, s7_pointer val) { set_elist_7(sc, wrap_string(sc, "(set! (*s7* '~A) '~S): the ~:D list element ~S is ~A but should be ~A", 69), - caller, val, wrap_integer(sc, num), arg, object_type_name(sc, arg), typ); + caller, val, wrap_integer(sc, num), arg, object_type_name(sc, arg), typ); error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_7); } static noreturn void s7_starlet_out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer descr) { error_nr(sc, sc->out_of_range_symbol, - set_elist_4(sc, wrap_string(sc, "(set! (*s7* '~A) ~S): new value is out of range (~A)", 52), caller, arg, descr)); + set_elist_4(sc, wrap_string(sc, "(set! (*s7* '~A) ~S): new value is out of range (~A)", 52), caller, arg, descr)); } static s7_int s7_starlet_length(void) {return(SL_NUM_FIELDS - 1);} @@ -94295,21 +94295,21 @@ static void add_symbol_table(s7_scheme *sc, s7_pointer mu_let) s7_pointer x; s7_int k = 0; for (x = els[i]; is_not_null(x); x = cdr(x), k++) - { - syms++; - if (is_gensym(car(x))) gens++; - if (is_keyword(car(x))) keys++; - } + { + syms++; + if (is_gensym(car(x))) gens++; + if (is_keyword(car(x))) keys++; + } if (k > mx_list) mx_list = k; } add_slot_unchecked_with_id(sc, mu_let, sc->symbol_table_symbol, - s7_inlet(sc, - s7_list(sc, 10, - sc->size_symbol, make_integer(sc, SYMBOL_TABLE_SIZE), - make_symbol(sc, "max-bin", 7), make_integer(sc, mx_list), - make_symbol(sc, "symbols", 7), cons(sc, make_integer(sc, syms), make_integer(sc, syms - gens - keys)), - make_symbol(sc, "gensyms", 7), make_integer(sc, gens), - make_symbol(sc, "keys", 4), make_integer(sc, keys)))); + s7_inlet(sc, + s7_list(sc, 10, + sc->size_symbol, make_integer(sc, SYMBOL_TABLE_SIZE), + make_symbol(sc, "max-bin", 7), make_integer(sc, mx_list), + make_symbol(sc, "symbols", 7), cons(sc, make_integer(sc, syms), make_integer(sc, syms - gens - keys)), + make_symbol(sc, "gensyms", 7), make_integer(sc, gens), + make_symbol(sc, "keys", 4), make_integer(sc, keys)))); } static s7_pointer kmg(s7_scheme *sc, s7_int bytes) @@ -94323,7 +94323,7 @@ static s7_pointer kmg(s7_scheme *sc, s7_int bytes) len = snprintf((char *)block_data(b), 128, "%.1fk", bytes / 1000.0); else if (bytes < 1000000000) - len = snprintf((char *)block_data(b), 128, "%.1fM", bytes / 1000000.0); + len = snprintf((char *)block_data(b), 128, "%.1fM", bytes / 1000000.0); else len = snprintf((char *)block_data(b), 128, "%.1fG", bytes / 1000000000.0); return(cons(sc, make_integer(sc, bytes), block_to_string(sc, b, len))); } @@ -94342,25 +94342,25 @@ static void add_gc_list_sizes(s7_scheme *sc, s7_pointer mu_let) add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-lists", 8), s7_inlet(sc, s7_list(sc, 6, - make_symbol(sc, "active/total", 12), cons(sc, make_integer(sc, loc), make_integer(sc, len)), - make_symbol(sc, "total-bytes", 11), kmg(sc, len * sizeof(s7_pointer)), - make_symbol(sc, "lists", 5), + make_symbol(sc, "active/total", 12), cons(sc, make_integer(sc, loc), make_integer(sc, len)), + make_symbol(sc, "total-bytes", 11), kmg(sc, len * sizeof(s7_pointer)), + make_symbol(sc, "lists", 5), s7_inlet(sc, s7_list(sc, 28, - sc->string_symbol, cons(sc, make_integer(sc, sc->strings->loc), make_integer(sc, sc->strings->size)), - sc->vector_symbol, cons(sc, make_integer(sc, sc->vectors->loc), make_integer(sc, sc->vectors->size)), - sc->hash_table_symbol, cons(sc, make_integer(sc, sc->hash_tables->loc), make_integer(sc, sc->hash_tables->size)), - make_symbol(sc, "multivector", 11), cons(sc, make_integer(sc, sc->multivectors->loc), make_integer(sc, sc->multivectors->size)), - make_symbol(sc, "input", 5), cons(sc, make_integer(sc, sc->input_ports->loc), make_integer(sc, sc->input_ports->size)), - make_symbol(sc, "output", 6), cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, sc->output_ports->size)), - make_symbol(sc, "input-string", 12), cons(sc, make_integer(sc, sc->input_string_ports->loc), make_integer(sc, sc->input_string_ports->size)), - make_symbol(sc, "continuation", 12), cons(sc, make_integer(sc, sc->continuations->loc), make_integer(sc, sc->continuations->size)), - make_symbol(sc, "c-object", 8), cons(sc, make_integer(sc, sc->c_objects->loc), make_integer(sc, sc->c_objects->size)), - sc->gensym_symbol, cons(sc, make_integer(sc, sc->gensyms->loc), make_integer(sc, sc->gensyms->size)), - make_symbol(sc, "undefined", 9), cons(sc, make_integer(sc, sc->undefineds->loc), make_integer(sc, sc->undefineds->size)), - make_symbol(sc, "weak-ref", 8), cons(sc, make_integer(sc, sc->weak_refs->loc), make_integer(sc, sc->weak_refs->size)), - make_symbol(sc, "weak-hash-iter", 14),cons(sc, make_integer(sc, sc->weak_hash_iterators->loc), make_integer(sc, sc->weak_hash_iterators->size)), - make_symbol(sc, "opt1-func", 9), cons(sc, make_integer(sc, sc->opt1_funcs->loc), make_integer(sc, sc->opt1_funcs->size))))))); + sc->string_symbol, cons(sc, make_integer(sc, sc->strings->loc), make_integer(sc, sc->strings->size)), + sc->vector_symbol, cons(sc, make_integer(sc, sc->vectors->loc), make_integer(sc, sc->vectors->size)), + sc->hash_table_symbol, cons(sc, make_integer(sc, sc->hash_tables->loc), make_integer(sc, sc->hash_tables->size)), + make_symbol(sc, "multivector", 11), cons(sc, make_integer(sc, sc->multivectors->loc), make_integer(sc, sc->multivectors->size)), + make_symbol(sc, "input", 5), cons(sc, make_integer(sc, sc->input_ports->loc), make_integer(sc, sc->input_ports->size)), + make_symbol(sc, "output", 6), cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, sc->output_ports->size)), + make_symbol(sc, "input-string", 12), cons(sc, make_integer(sc, sc->input_string_ports->loc), make_integer(sc, sc->input_string_ports->size)), + make_symbol(sc, "continuation", 12), cons(sc, make_integer(sc, sc->continuations->loc), make_integer(sc, sc->continuations->size)), + make_symbol(sc, "c-object", 8), cons(sc, make_integer(sc, sc->c_objects->loc), make_integer(sc, sc->c_objects->size)), + sc->gensym_symbol, cons(sc, make_integer(sc, sc->gensyms->loc), make_integer(sc, sc->gensyms->size)), + make_symbol(sc, "undefined", 9), cons(sc, make_integer(sc, sc->undefineds->loc), make_integer(sc, sc->undefineds->size)), + make_symbol(sc, "weak-ref", 8), cons(sc, make_integer(sc, sc->weak_refs->loc), make_integer(sc, sc->weak_refs->size)), + make_symbol(sc, "weak-hash-iter", 14),cons(sc, make_integer(sc, sc->weak_hash_iterators->loc), make_integer(sc, sc->weak_hash_iterators->size)), + make_symbol(sc, "opt1-func", 9), cons(sc, make_integer(sc, sc->opt1_funcs->loc), make_integer(sc, sc->opt1_funcs->size))))))); } /* handling all *s7* fields via fallbacks lets us use direct field accesses in the rest of s7, and avoids @@ -94402,17 +94402,17 @@ static s7_pointer memory_usage(s7_scheme *sc) add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "rootlet-size", 12), make_integer(sc, let_length(sc, sc->rootlet))); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "heap-size", 9), - cons(sc, make_integer(sc, sc->heap_size), kmg(sc, sc->heap_size * (sizeof(s7_cell) + 2 * sizeof(s7_pointer))))); + cons(sc, make_integer(sc, sc->heap_size), kmg(sc, sc->heap_size * (sizeof(s7_cell) + 2 * sizeof(s7_pointer))))); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "cell-size", 9), make_integer(sc, sizeof(s7_cell))); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-total-freed", 14), make_integer(sc, sc->gc_total_freed)); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-total-time", 13), make_real(sc, (double)(sc->gc_total_time) / ticks_per_second())); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-calls", 8), make_integer(sc, sc->gc_calls)); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "small_ints", 10), - cons(sc, make_integer(sc, NUM_SMALL_INTS), kmg(sc, NUM_SMALL_INTS * (sizeof(s7_pointer) + sizeof(s7_cell))))); + cons(sc, make_integer(sc, NUM_SMALL_INTS), kmg(sc, NUM_SMALL_INTS * (sizeof(s7_pointer) + sizeof(s7_cell))))); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent-cells", 15), - cons(sc, make_integer(sc, sc->semipermanent_cells), kmg(sc, sc->semipermanent_cells * sizeof(s7_cell)))); + cons(sc, make_integer(sc, sc->semipermanent_cells), kmg(sc, sc->semipermanent_cells * sizeof(s7_cell)))); i = 0; for (gc_obj_t *g = sc->semipermanent_objects; g; i++, g = (gc_obj_t *)(g->nxt)); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent_objects", 17), make_integer(sc, i)); @@ -94425,18 +94425,18 @@ static s7_pointer memory_usage(s7_scheme *sc) s7_int live = 0, in_use = 0, line_used = 0; for (i = 1; i < NUM_SAFE_LISTS; i++) if (is_pair(sc->safe_lists[i])) - { - live++; - if (list_is_in_use(sc->safe_lists[i])) {in_use++; line_used = i;} - } + { + live++; + if (list_is_in_use(sc->safe_lists[i])) {in_use++; line_used = i;} + } sc->w = sc->nil; #if S7_DEBUGGING for (i = NUM_SAFE_LISTS - 1; i > 0; i--) /* omit safe_lists[0]=() since it is never used */ sc->w = cons(sc, make_integer(sc, sc->safe_list_uses[i]), sc->w); #endif add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "safe-lists", 10), - (in_use == 0) ? list_3(sc, small_int(live), int_zero, sc->w) : - list_4(sc, small_int(live), small_int(in_use), small_int(line_used), sc->w)); + (in_use == 0) ? list_3(sc, small_int(live), int_zero, sc->w) : + list_4(sc, small_int(live), small_int(in_use), small_int(line_used), sc->w)); #if S7_DEBUGGING sc->w = sc->unused; #endif @@ -94451,26 +94451,26 @@ static s7_pointer memory_usage(s7_scheme *sc) { if (i > 0) in_use += ts[i]; if (ts[i] > 0) /* was 50, 26-Sep-23 */ - { - /* can't use bare type name here ("let" is a syntactic symbol) */ - const char *tname = (i == 0) ? "free" : type_name_from_type(i, NO_ARTICLE); - s7_int len = safe_strlen(tname); - uint8_t name[32]; /* not 16 -- gmp overflows this buffer with "big-complex-number", len=18 */ - memcpy((void *)name, (const void *)tname, len); - name[len] = (uint8_t)'\0'; - name[0] = (uint8_t)toupper((int)name[0]); - sc->w = cons_unchecked(sc, make_integer(sc, ts[i]), cons(sc, make_symbol(sc, (const char *)name, len), sc->w)); - }} + { + /* can't use bare type name here ("let" is a syntactic symbol) */ + const char *tname = (i == 0) ? "free" : type_name_from_type(i, NO_ARTICLE); + s7_int len = safe_strlen(tname); + uint8_t name[32]; /* not 16 -- gmp overflows this buffer with "big-complex-number", len=18 */ + memcpy((void *)name, (const void *)tname, len); + name[len] = (uint8_t)'\0'; + name[0] = (uint8_t)toupper((int)name[0]); + sc->w = cons_unchecked(sc, make_integer(sc, ts[i]), cons(sc, make_symbol(sc, (const char *)name, len), sc->w)); + }} if (is_pair(sc->w)) add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "heap-by-type", 12), s7_inlet(sc, proper_list_reverse_in_place(sc, sc->w))); sc->w = sc->unused; /* same for semipermanent cells requires traversing saved_pointers and the alloc and big_alloc blocks up to alloc_k, or keeping explicit counts */ add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "cells-in-use/free", 17), - cons(sc, make_integer(sc, in_use), make_integer(sc, sc->free_heap_top - sc->free_heap))); + cons(sc, make_integer(sc, in_use), make_integer(sc, sc->free_heap_top - sc->free_heap))); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-protected-objects", 20), - cons(sc, make_integer(sc, sc->protected_objects_size - sc->protected_objects_free_list_loc), - make_integer(sc, sc->protected_objects_size))); + cons(sc, make_integer(sc, sc->protected_objects_size - sc->protected_objects_free_list_loc), + make_integer(sc, sc->protected_objects_size))); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "setters", 7), make_integer(sc, sc->protected_setters_loc)); add_symbol_table(sc, mu_let); @@ -94481,7 +94481,7 @@ static s7_pointer memory_usage(s7_scheme *sc) add_slot_unchecked_with_id(sc, mu_let, sc->autoload_symbol, make_integer(sc, len)); add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "circle_info", 11), - make_integer(sc, sc->circle_info->size * (sizeof(s7_pointer) + sizeof(int32_t) + sizeof(bool)))); + make_integer(sc, sc->circle_info->size * (sizeof(s7_pointer) + sizeof(int32_t) + sizeof(bool)))); add_gc_list_sizes(sc, mu_let); @@ -94496,28 +94496,28 @@ static s7_pointer memory_usage(s7_scheme *sc) s7_int vlen = 0, vs = 0, flen = 0, fvs = 0, ilen = 0, ivs = 0, blen = 0, bvs = 0; for (k = 0, gp = sc->vectors; k < 2; k++, gp = sc->multivectors) for (i = 0; i < gp->loc; i++) - { - s7_pointer v = gp->list[i]; - if (is_float_vector(v)) - {fvs++; flen += vector_length(v);} - else - if (is_int_vector(v)) - {ivs++; ilen += vector_length(v);} - else - if (is_byte_vector(v)) - {bvs++; blen += vector_length(v);} - else {vs++; vlen += vector_length(v);} - } + { + s7_pointer v = gp->list[i]; + if (is_float_vector(v)) + {fvs++; flen += vector_length(v);} + else + if (is_int_vector(v)) + {ivs++; ilen += vector_length(v);} + else + if (is_byte_vector(v)) + {bvs++; blen += vector_length(v);} + else {vs++; vlen += vector_length(v);} + } all_len += blen + ilen * sizeof(s7_int) + flen * sizeof(s7_double) + vlen * sizeof(s7_pointer); add_slot_unchecked_with_id(sc, mu_let, - make_symbol(sc, "vectors", 7), - s7_inlet(sc, - s7_list(sc, 10, - make_symbol(sc, "total", 5), make_integer(sc, sc->vectors->loc + sc->multivectors->loc), - make_symbol(sc, "normal", 6), cons(sc, make_integer(sc, vs), make_integer(sc, vlen)), - make_symbol(sc, "float", 5), cons(sc, make_integer(sc, fvs), make_integer(sc, flen)), - make_symbol(sc, "int", 3), cons(sc, make_integer(sc, ivs), make_integer(sc, ilen)), - make_symbol(sc, "byte", 4), cons(sc, make_integer(sc, bvs), make_integer(sc, blen))))); + make_symbol(sc, "vectors", 7), + s7_inlet(sc, + s7_list(sc, 10, + make_symbol(sc, "total", 5), make_integer(sc, sc->vectors->loc + sc->multivectors->loc), + make_symbol(sc, "normal", 6), cons(sc, make_integer(sc, vs), make_integer(sc, vlen)), + make_symbol(sc, "float", 5), cons(sc, make_integer(sc, fvs), make_integer(sc, flen)), + make_symbol(sc, "int", 3), cons(sc, make_integer(sc, ivs), make_integer(sc, ilen)), + make_symbol(sc, "byte", 4), cons(sc, make_integer(sc, bvs), make_integer(sc, blen))))); } /* hash-tables */ { @@ -94530,11 +94530,11 @@ static s7_pointer memory_usage(s7_scheme *sc) } all_len += all_len; add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "hash-tables", 11), - cons(sc, make_integer(sc, sc->hash_tables->loc), make_integer(sc, hlen))); + cons(sc, make_integer(sc, sc->hash_tables->loc), make_integer(sc, hlen))); } /* ports */ add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "input-port-stack", 16), - cons(sc, make_integer(sc, sc->input_port_stack_loc), make_integer(sc, sc->input_port_stack_size))); + cons(sc, make_integer(sc, sc->input_port_stack_loc), make_integer(sc, sc->input_port_stack_size))); gp = sc->input_ports; for (i = 0, len = 0; i < gp->loc; i++) { @@ -94542,7 +94542,7 @@ static s7_pointer memory_usage(s7_scheme *sc) if (port_data(v)) len += port_data_size(v); } add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "input-ports", 11), - cons(sc, make_integer(sc, sc->input_ports->loc), make_integer(sc, len))); + cons(sc, make_integer(sc, sc->input_ports->loc), make_integer(sc, len))); gp = sc->input_string_ports; for (i = 0, len = 0; i < gp->loc; i++) @@ -94551,7 +94551,7 @@ static s7_pointer memory_usage(s7_scheme *sc) if (port_data(v)) len += port_data_size(v); } add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "input-string-ports", 18), - cons(sc, make_integer(sc, sc->input_string_ports->loc), make_integer(sc, len))); + cons(sc, make_integer(sc, sc->input_string_ports->loc), make_integer(sc, len))); gp = sc->output_ports; for (i = 0, len = 0; i < gp->loc; i++) @@ -94560,7 +94560,7 @@ static s7_pointer memory_usage(s7_scheme *sc) if (port_data(v)) len += port_data_size(v); } add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "output-ports", 12), - cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, len))); + cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, len))); i = 0; for (s7_pointer p = sc->format_ports; p; i++, p = (s7_pointer)port_next(p)); @@ -94573,21 +94573,21 @@ static s7_pointer memory_usage(s7_scheme *sc) len += continuation_stack_size(gp->list[i]); if (len > 0) add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "continuations", 13), - cons(sc, make_integer(sc, sc->continuations->loc), make_integer(sc, len * sizeof(s7_pointer)))); + cons(sc, make_integer(sc, sc->continuations->loc), make_integer(sc, len * sizeof(s7_pointer)))); /* c-objects */ if (sc->c_objects->loc > 0) add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "c-objects", 9), make_integer(sc, sc->c_objects->loc)); if (sc->num_c_object_types > 0) add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "c-types", 7), - cons(sc, make_integer(sc, sc->num_c_object_types), - make_integer(sc, (sc->c_object_types_size * sizeof(c_object_t *)) + (sc->num_c_object_types * sizeof(c_object_t))))); - /* we're ignoring c_type->scheme_name: make_permanent_string(sc, name) */ + cons(sc, make_integer(sc, sc->num_c_object_types), + make_integer(sc, (sc->c_object_types_size * sizeof(c_object_t *)) + (sc->num_c_object_types * sizeof(c_object_t))))); + /* we're ignoring c_type->scheme_name: make_permanent_string(sc, name) */ #if WITH_GMP add_slot_unchecked_with_id(sc, mu_let, - make_symbol(sc, "bignums", 7), - s7_list(sc, 5, make_integer(sc, sc->big_integers->loc), make_integer(sc, sc->big_ratios->loc), - make_integer(sc, sc->big_reals->loc), make_integer(sc, sc->big_complexes->loc), - make_integer(sc, sc->big_random_states->loc))); + make_symbol(sc, "bignums", 7), + s7_list(sc, 5, make_integer(sc, sc->big_integers->loc), make_integer(sc, sc->big_ratios->loc), + make_integer(sc, sc->big_reals->loc), make_integer(sc, sc->big_complexes->loc), + make_integer(sc, sc->big_random_states->loc))); #endif /* free-lists (mallocate) */ { @@ -94597,11 +94597,11 @@ static s7_pointer memory_usage(s7_scheme *sc) #endif for (i = 0, len = 0, sc->w = sc->nil; i < TOP_BLOCK_LIST; i++) { - for (b = sc->block_lists[i], k = 0; b; b = block_next(b), k++); - sc->w = cons(sc, make_integer(sc, k), sc->w); - len += ((sizeof(block_t) + (1LL << i)) * k); + for (b = sc->block_lists[i], k = 0; b; b = block_next(b), k++); + sc->w = cons(sc, make_integer(sc, k), sc->w); + len += ((sizeof(block_t) + (1LL << i)) * k); #if S7_DEBUGGING - num_blocks += k; + num_blocks += k; #endif } for (b = sc->block_lists[TOP_BLOCK_LIST], k = 0; b; b = block_next(b), k++) @@ -94610,17 +94610,17 @@ static s7_pointer memory_usage(s7_scheme *sc) #if S7_DEBUGGING num_blocks += k; add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "blocks-allocated", 16), - cons(sc, make_integer(sc, num_blocks), make_integer(sc, sc->blocks_allocated))); + cons(sc, make_integer(sc, num_blocks), make_integer(sc, sc->blocks_allocated))); #endif add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "free-lists", 10), - s7_inlet(sc, list_2(sc, cons(sc, make_symbol(sc, "bytes", 5), kmg(sc, len)), - cons(sc, make_symbol(sc, "bins", 4), proper_list_reverse_in_place(sc, sc->w))))); + s7_inlet(sc, list_2(sc, cons(sc, make_symbol(sc, "bytes", 5), kmg(sc, len)), + cons(sc, make_symbol(sc, "bins", 4), proper_list_reverse_in_place(sc, sc->w))))); sc->w = sc->unused; add_slot_unchecked_with_id(sc, mu_let, - make_symbol(sc, "approximate-s7-size", 19), - kmg(sc, ((sc->semipermanent_cells + NUM_SMALL_INTS + sc->heap_size) * (sizeof(s7_pointer) + sizeof(s7_cell))) + - ((2 * sc->heap_size + SYMBOL_TABLE_SIZE + sc->stack_size) * sizeof(s7_pointer)) + - len + all_len)); + make_symbol(sc, "approximate-s7-size", 19), + kmg(sc, ((sc->semipermanent_cells + NUM_SMALL_INTS + sc->heap_size) * (sizeof(s7_pointer) + sizeof(s7_cell))) + + ((2 * sc->heap_size + SYMBOL_TABLE_SIZE + sc->stack_size) * sizeof(s7_pointer)) + + len + all_len)); } s7_gc_unprotect_at(sc, gc_loc); @@ -94674,11 +94674,11 @@ static s7_pointer sl_active_catches(s7_scheme *sc) switch (stack_op(sc->stack, i)) { case OP_CATCH_ALL: - lst = cons(sc, sc->T, lst); - break; + lst = cons(sc, sc->T, lst); + break; case OP_CATCH_2: case OP_CATCH_1: case OP_CATCH: - lst = cons(sc, catch_tag(stack_code(sc->stack, i)), lst); - break; + lst = cons(sc, catch_tag(stack_code(sc->stack, i)), lst); + break; } return(reverse_in_place_unchecked(sc, sc->nil, lst)); } @@ -94785,9 +94785,9 @@ s7_pointer s7_starlet_ref(s7_scheme *sc, s7_pointer sym) /* s7.h, not used here if (is_symbol(sym)) { if (is_keyword(sym)) - sym = keyword_symbol(sym); + sym = keyword_symbol(sym); if (s7_starlet_symbol(sym) != SL_NO_FIELD) - return(s7_starlet(sc, s7_starlet_symbol(sym))); + return(s7_starlet(sc, s7_starlet_symbol(sym))); } return(sc->undefined); } @@ -94958,10 +94958,10 @@ static s7_pointer sl_set_gc_info(s7_scheme *sc, s7_pointer sym, s7_pointer val) } else if ((is_pair(val)) && (s7_is_integer(car(val))) && - (is_pair(cdr(val))) && (s7_is_integer(cadr(val)))) /* caddr is ticks_per_second which can't sensibly be set */ + (is_pair(cdr(val))) && (s7_is_integer(cadr(val)))) /* caddr is ticks_per_second which can't sensibly be set */ { - sc->gc_total_time = s7_integer(car(val)); - sc->gc_calls = s7_integer(cadr(val)); + sc->gc_total_time = s7_integer(car(val)); + sc->gc_calls = s7_integer(cadr(val)); } else s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f or a list of two or three integers (the third is ignored)", 60)); return(sc->F); @@ -94976,11 +94976,11 @@ static s7_pointer sl_set_profile(s7_scheme *sc, s7_pointer sym, s7_pointer val) if (sc->profile > 0) { if (!is_a_feature(make_symbol(sc, "profile.scm", 11), s7_symbol_value(sc, sc->features_symbol))) - s7_load(sc, "profile.scm"); + s7_load(sc, "profile.scm"); if (!sc->profile_data) - make_profile_info(sc); + make_profile_info(sc); if (!sc->profile_out) - sc->profile_out = s7_make_function(sc, "profile-out", g_profile_out, 2, 0, false, NULL); + sc->profile_out = s7_make_function(sc, "profile-out", g_profile_out, 2, 0, false, NULL); } return(val); } @@ -95126,7 +95126,7 @@ static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val case SL_HEAP_SIZE: iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); if (iv > sc->heap_size) - resize_heap_to(sc, iv); + resize_heap_to(sc, iv); return(val); case SL_HISTORY: /* (set! (*s7* 'history) val) */ @@ -95160,7 +95160,7 @@ static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val case SL_MAX_STACK_SIZE: iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); if (iv < INITIAL_STACK_SIZE) - s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be greater than the initial stack size", 48)); + s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be greater than the initial stack size", 48)); sc->max_stack_size = (uint32_t)iv; return(val); @@ -95207,9 +95207,9 @@ static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val case SL_SAFETY: if (!s7_is_integer(val)) - s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); + s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); if ((s7_integer_clamped_if_gmp(sc, val) > 2) || (s7_integer_clamped_if_gmp(sc, val) < -1)) - s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be between -1 (no safety) and 2 (max safety)", 54)); + s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be between -1 (no safety) and 2 (max safety)", 54)); sc->safety = s7_integer_clamped_if_gmp(sc, val); return(val); @@ -95236,7 +95236,7 @@ static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val default: error_nr(sc, sc->out_of_range_symbol, - set_elist_2(sc, wrap_string(sc, "can't set (*s7* '~S); no such field in *s7*", 43), sym)); + set_elist_2(sc, wrap_string(sc, "can't set (*s7* '~S); no such field in *s7*", 43), sym)); } return(sc->undefined); } @@ -95246,9 +95246,9 @@ s7_pointer s7_starlet_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value) if (is_symbol(sym)) { if (is_keyword(sym)) - sym = keyword_symbol(sym); + sym = keyword_symbol(sym); if (s7_starlet_symbol(sym) != SL_NO_FIELD) - return(s7_starlet_set_1(sc, sym, new_value)); + return(s7_starlet_set_1(sc, sym, new_value)); } return(sc->undefined); } @@ -95334,10 +95334,10 @@ static bool is_decodable(s7_scheme *sc, const s7_pointer p) for (i = 0; i < SYMBOL_TABLE_SIZE; i++) for (s7_pointer x = vector_element(sc->symbol_table, i); is_not_null(x); x = cdr(x)) { - s7_pointer sym = car(x); - if ((sym == p) || - ((is_global(sym)) && (is_slot(global_slot(sym))) && (p == global_value(sym)))) - return(true); + s7_pointer sym = car(x); + if ((sym == p) || + ((is_global(sym)) && (is_slot(global_slot(sym))) && (p == global_value(sym)))) + return(true); } for (i = 0; i < NUM_CHARS; i++) if (p == chars[i]) return(true); @@ -95371,64 +95371,64 @@ const char *s7_decode_bt(s7_scheme *sc) bt = (uint8_t *)block_data(bt_block); bytes = fread(bt, sizeof(uint8_t), size, fp); if (bytes != (size_t)size) - { - fclose(fp); - liberate(sc, bt_block); - return(" oops "); - } + { + fclose(fp); + liberate(sc, bt_block); + return(" oops "); + } bt[size] = '\0'; fclose(fp); for (int64_t i = 0; i < size; i++) - { - fputc(bt[i], stdout); - if ((bt[i] == '"') && ((i == 0) || (bt[i - 1] != '\\'))) - in_quotes = (!in_quotes); - else - if ((!in_quotes) && (i < size - 8) && - ((bt[i] == '=') && - (((bt[i + 1] == '0') && (bt[i + 2] == 'x')) || - ((bt[i + 1] == ' ') && (bt[i + 2] == '0') && (bt[i + 3] == 'x'))))) - { - void *vp; - int32_t vals = sscanf((const char *)(bt + i + 1), "%p", &vp); - if ((vp) && (vals == 1)) - { - int32_t k; - for (k = i + ((bt[i + 2] == 'x') ? 3 : 4); (k < size) && (is_digit(bt[k], 16)); k++); - if ((bt[k] != ' ') || (bt[k + 1] != '"')) - { - if (vp == (void *)sc) - { - if (bt[i + 1] == ' ') fputc(' ', stdout); - fprintf(stdout, "%s[s7]%s", bold_text, unbold_text); - i = k - 1; - } - else - { - s7_pointer p = (s7_pointer)vp; - const char *dname = decoded_name(sc, p); - if (dname) - { - if (bt[i + 1] == ' ') fputc(' ', stdout); - fprintf(stdout, "%s[%s]%s", bold_text, dname, unbold_text); - } - if ((dname) || (is_decodable(sc, p))) - { - if (bt[i + 1] == ' ') fputc(' ', stdout); - i = k - 1; - if (s7_is_valid(sc, p)) - { - s7_pointer strp = object_to_string_truncated(sc, p); - if (dname) fprintf(stdout, " "); - fprintf(stdout, "%s%s%s", bold_text, string_value(strp), unbold_text); - if ((is_pair(p)) && - (has_location(p))) - { - uint32_t line = pair_line_number(p), file = pair_file_number(p); - if (line > 0) - fprintf(stdout, " %s(%s[%u])%s", bold_text, string_value(sc->file_names[file]), line, unbold_text); - }}}}}}}} + { + fputc(bt[i], stdout); + if ((bt[i] == '"') && ((i == 0) || (bt[i - 1] != '\\'))) + in_quotes = (!in_quotes); + else + if ((!in_quotes) && (i < size - 8) && + ((bt[i] == '=') && + (((bt[i + 1] == '0') && (bt[i + 2] == 'x')) || + ((bt[i + 1] == ' ') && (bt[i + 2] == '0') && (bt[i + 3] == 'x'))))) + { + void *vp; + int32_t vals = sscanf((const char *)(bt + i + 1), "%p", &vp); + if ((vp) && (vals == 1)) + { + int32_t k; + for (k = i + ((bt[i + 2] == 'x') ? 3 : 4); (k < size) && (is_digit(bt[k], 16)); k++); + if ((bt[k] != ' ') || (bt[k + 1] != '"')) + { + if (vp == (void *)sc) + { + if (bt[i + 1] == ' ') fputc(' ', stdout); + fprintf(stdout, "%s[s7]%s", bold_text, unbold_text); + i = k - 1; + } + else + { + s7_pointer p = (s7_pointer)vp; + const char *dname = decoded_name(sc, p); + if (dname) + { + if (bt[i + 1] == ' ') fputc(' ', stdout); + fprintf(stdout, "%s[%s]%s", bold_text, dname, unbold_text); + } + if ((dname) || (is_decodable(sc, p))) + { + if (bt[i + 1] == ' ') fputc(' ', stdout); + i = k - 1; + if (s7_is_valid(sc, p)) + { + s7_pointer strp = object_to_string_truncated(sc, p); + if (dname) fprintf(stdout, " "); + fprintf(stdout, "%s%s%s", bold_text, string_value(strp), unbold_text); + if ((is_pair(p)) && + (has_location(p))) + { + uint32_t line = pair_line_number(p), file = pair_file_number(p); + if (line > 0) + fprintf(stdout, " %s(%s[%u])%s", bold_text, string_value(sc->file_names[file]), line, unbold_text); + }}}}}}}} liberate(sc, bt_block); sc->stop_at_error = old_stop; } @@ -96410,9 +96410,9 @@ static void init_setters(s7_scheme *sc) #if (WITH_PURE_S7) /* we need to be able at least to set (current-output-port) to #f */ c_function_set_setter(global_value(sc->current_input_port_symbol), - s7_make_safe_function(sc, "#<set-*stdin*>", g_set_current_input_port, 1, 0, false, "*stdin* setter")); + s7_make_safe_function(sc, "#<set-*stdin*>", g_set_current_input_port, 1, 0, false, "*stdin* setter")); c_function_set_setter(global_value(sc->current_output_port_symbol), - s7_make_safe_function(sc, "#<set-*stdout*>", g_set_current_output_port, 1, 0, false, "*stdout* setter")); + s7_make_safe_function(sc, "#<set-*stdout*>", g_set_current_output_port, 1, 0, false, "*stdout* setter")); #else set_is_setter(sc->set_current_input_port_symbol); set_is_setter(sc->set_current_output_port_symbol); @@ -96437,21 +96437,21 @@ static void init_setters(s7_scheme *sc) s7_function_set_setter(sc, sc->let_ref_symbol, sc->let_set_symbol); s7_function_set_setter(sc, sc->string_ref_symbol, sc->string_set_symbol); c_function_set_setter(global_value(sc->outlet_symbol), - s7_make_safe_function(sc, "#<set-outlet>", g_set_outlet, 2, 0, false, "outlet setter")); + s7_make_safe_function(sc, "#<set-outlet>", g_set_outlet, 2, 0, false, "outlet setter")); c_function_set_setter(global_value(sc->port_line_number_symbol), - s7_make_safe_function(sc, "#<set-port-line-number>", g_set_port_line_number, 1, 1, false, "port-line setter")); + s7_make_safe_function(sc, "#<set-port-line-number>", g_set_port_line_number, 1, 1, false, "port-line setter")); c_function_set_setter(global_value(sc->port_string_symbol), - s7_make_safe_function(sc, "#<set-port-string>", g_set_port_string, 2, 0, false, "port-string setter")); + s7_make_safe_function(sc, "#<set-port-string>", g_set_port_string, 2, 0, false, "port-string setter")); c_function_set_setter(global_value(sc->port_position_symbol), - s7_make_safe_function(sc, "#<set-port-position>", g_set_port_position, 2, 0, false, "port-position setter")); + s7_make_safe_function(sc, "#<set-port-position>", g_set_port_position, 2, 0, false, "port-position setter")); c_function_set_setter(global_value(sc->vector_typer_symbol), - s7_make_safe_function(sc, "#<set-vector-typer>", g_set_vector_typer, 2, 0, false, "vector-typer setter")); + s7_make_safe_function(sc, "#<set-vector-typer>", g_set_vector_typer, 2, 0, false, "vector-typer setter")); c_function_set_setter(global_value(sc->hash_table_key_typer_symbol), - s7_make_safe_function(sc, "#<set-hash-table-key-typer>", g_set_hash_table_key_typer, 2, 0, false, "hash-table-key-typer setter")); + s7_make_safe_function(sc, "#<set-hash-table-key-typer>", g_set_hash_table_key_typer, 2, 0, false, "hash-table-key-typer setter")); c_function_set_setter(global_value(sc->hash_table_value_typer_symbol), - s7_make_safe_function(sc, "#<set-hash-table-value-typer>", g_set_hash_table_value_typer, 2, 0, false, "hash-table-value-typer setter")); + s7_make_safe_function(sc, "#<set-hash-table-value-typer>", g_set_hash_table_value_typer, 2, 0, false, "hash-table-value-typer setter")); c_function_set_setter(global_value(sc->symbol_symbol), - s7_make_safe_function(sc, "#<symbol-set>", g_symbol_set, 2, 0, true, "symbol setter")); + s7_make_safe_function(sc, "#<symbol-set>", g_symbol_set, 2, 0, true, "symbol setter")); } static void init_syntax(s7_scheme *sc) @@ -96624,57 +96624,57 @@ static void init_rootlet(s7_scheme *sc) sc->is_boolean_symbol = make_symbol(sc, "boolean?", 8); sc->pl_bt = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->T); - sc->is_symbol_symbol = bool_defun("symbol?", is_symbol, 0, T_SYMBOL, mark_symbol_vector, true); - sc->is_syntax_symbol = bool_defun("syntax?", is_syntax, 0, T_SYNTAX, just_mark_vector, true); - sc->is_gensym_symbol = bool_defun("gensym?", is_gensym, 0, T_FREE, mark_symbol_vector, true); - sc->is_keyword_symbol = bool_defun("keyword?", is_keyword, 0, T_FREE, just_mark_vector, true); - sc->is_let_symbol = bool_defun("let?", is_let, 0, T_LET, mark_vector_1, false); - sc->is_openlet_symbol = bool_defun("openlet?", is_openlet, 0, T_FREE, mark_vector_1, false); - sc->is_iterator_symbol = bool_defun("iterator?", is_iterator, 0, T_ITERATOR, mark_vector_1, false); - sc->is_macro_symbol = bool_defun("macro?", is_macro, 0, T_FREE, mark_vector_1, false); - sc->is_c_pointer_symbol = bool_defun("c-pointer?", is_c_pointer, 1, T_C_POINTER, mark_vector_1, false); - sc->is_input_port_symbol = bool_defun("input-port?", is_input_port, 0, T_INPUT_PORT, mark_vector_1, true); + sc->is_symbol_symbol = bool_defun("symbol?", is_symbol, 0, T_SYMBOL, mark_symbol_vector, true); + sc->is_syntax_symbol = bool_defun("syntax?", is_syntax, 0, T_SYNTAX, just_mark_vector, true); + sc->is_gensym_symbol = bool_defun("gensym?", is_gensym, 0, T_FREE, mark_symbol_vector, true); + sc->is_keyword_symbol = bool_defun("keyword?", is_keyword, 0, T_FREE, just_mark_vector, true); + sc->is_let_symbol = bool_defun("let?", is_let, 0, T_LET, mark_vector_1, false); + sc->is_openlet_symbol = bool_defun("openlet?", is_openlet, 0, T_FREE, mark_vector_1, false); + sc->is_iterator_symbol = bool_defun("iterator?", is_iterator, 0, T_ITERATOR, mark_vector_1, false); + sc->is_macro_symbol = bool_defun("macro?", is_macro, 0, T_FREE, mark_vector_1, false); + sc->is_c_pointer_symbol = bool_defun("c-pointer?", is_c_pointer, 1, T_C_POINTER, mark_vector_1, false); + sc->is_input_port_symbol = bool_defun("input-port?", is_input_port, 0, T_INPUT_PORT, mark_vector_1, true); sc->is_output_port_symbol = bool_defun("output-port?", is_output_port, 0, T_OUTPUT_PORT, mark_simple_vector, true); - sc->is_eof_object_symbol = bool_defun("eof-object?", is_eof_object, 0, T_EOF, just_mark_vector, true); - sc->is_integer_symbol = bool_defun("integer?", is_integer, 0, (WITH_GMP) ? T_FREE : T_INTEGER, mark_simple_vector, true); - sc->is_byte_symbol = bool_defun("byte?", is_byte, 0, T_FREE, mark_simple_vector, true); - sc->is_number_symbol = bool_defun("number?", is_number, 0, T_FREE, mark_simple_vector, true); - sc->is_real_symbol = bool_defun("real?", is_real, 0, T_FREE, mark_simple_vector, true); + sc->is_eof_object_symbol = bool_defun("eof-object?", is_eof_object, 0, T_EOF, just_mark_vector, true); + sc->is_integer_symbol = bool_defun("integer?", is_integer, 0, (WITH_GMP) ? T_FREE : T_INTEGER, mark_simple_vector, true); + sc->is_byte_symbol = bool_defun("byte?", is_byte, 0, T_FREE, mark_simple_vector, true); + sc->is_number_symbol = bool_defun("number?", is_number, 0, T_FREE, mark_simple_vector, true); + sc->is_real_symbol = bool_defun("real?", is_real, 0, T_FREE, mark_simple_vector, true); sc->is_float_symbol = bool_defun("float?", is_float, 0, T_FREE, mark_simple_vector, true); - sc->is_complex_symbol = bool_defun("complex?", is_complex, 0, T_FREE, mark_simple_vector, true); - sc->is_rational_symbol = bool_defun("rational?", is_rational, 0, T_FREE, mark_simple_vector, true); + sc->is_complex_symbol = bool_defun("complex?", is_complex, 0, T_FREE, mark_simple_vector, true); + sc->is_rational_symbol = bool_defun("rational?", is_rational, 0, T_FREE, mark_simple_vector, true); sc->is_random_state_symbol = bool_defun("random-state?", is_random_state, 0, T_RANDOM_STATE, mark_simple_vector, true); - sc->is_char_symbol = bool_defun("char?", is_char, 0, T_CHARACTER, just_mark_vector, true); - sc->is_string_symbol = bool_defun("string?", is_string, 0, T_STRING, mark_simple_vector, true); - sc->is_list_symbol = bool_defun("list?", is_list, 0, T_FREE, mark_vector_1, false); - sc->is_pair_symbol = bool_defun("pair?", is_pair, 0, T_PAIR, mark_vector_1, false); - sc->is_vector_symbol = bool_defun("vector?", is_vector, 0, T_FREE, mark_vector_1, false); + sc->is_char_symbol = bool_defun("char?", is_char, 0, T_CHARACTER, just_mark_vector, true); + sc->is_string_symbol = bool_defun("string?", is_string, 0, T_STRING, mark_simple_vector, true); + sc->is_list_symbol = bool_defun("list?", is_list, 0, T_FREE, mark_vector_1, false); + sc->is_pair_symbol = bool_defun("pair?", is_pair, 0, T_PAIR, mark_vector_1, false); + sc->is_vector_symbol = bool_defun("vector?", is_vector, 0, T_FREE, mark_vector_1, false); sc->is_float_vector_symbol = bool_defun("float-vector?", is_float_vector, 0, T_FLOAT_VECTOR, mark_simple_vector, true); - sc->is_int_vector_symbol = bool_defun("int-vector?", is_int_vector, 0, T_INT_VECTOR, mark_simple_vector, true); + sc->is_int_vector_symbol = bool_defun("int-vector?", is_int_vector, 0, T_INT_VECTOR, mark_simple_vector, true); sc->is_byte_vector_symbol = bool_defun("byte-vector?", is_byte_vector, 0, T_BYTE_VECTOR, mark_simple_vector, true); sc->is_hash_table_symbol = bool_defun("hash-table?", is_hash_table, 0, T_HASH_TABLE, mark_vector_1, false); sc->is_continuation_symbol = bool_defun("continuation?", is_continuation, 0, T_CONTINUATION, mark_vector_1, false); - sc->is_procedure_symbol = bool_defun("procedure?", is_procedure, 0, T_FREE, mark_vector_1, false); - sc->is_dilambda_symbol = bool_defun("dilambda?", is_dilambda, 0, T_FREE, mark_vector_1, false); - /* set above */ bool_defun("boolean?", is_boolean, 0, T_BOOLEAN, just_mark_vector, true); + sc->is_procedure_symbol = bool_defun("procedure?", is_procedure, 0, T_FREE, mark_vector_1, false); + sc->is_dilambda_symbol = bool_defun("dilambda?", is_dilambda, 0, T_FREE, mark_vector_1, false); + /* set above */ bool_defun("boolean?", is_boolean, 0, T_BOOLEAN, just_mark_vector, true); sc->is_proper_list_symbol = bool_defun("proper-list?", is_proper_list, 0, T_FREE, mark_vector_1, false); - sc->is_sequence_symbol = bool_defun("sequence?", is_sequence, 0, T_FREE, mark_vector_1, false); - sc->is_null_symbol = bool_defun("null?", is_null, 0, T_NIL, just_mark_vector, true); + sc->is_sequence_symbol = bool_defun("sequence?", is_sequence, 0, T_FREE, mark_vector_1, false); + sc->is_null_symbol = bool_defun("null?", is_null, 0, T_NIL, just_mark_vector, true); sc->is_undefined_symbol = bool_defun("undefined?", is_undefined, 0, T_UNDEFINED, just_mark_vector, true); sc->is_unspecified_symbol = bool_defun("unspecified?", is_unspecified, 0, T_UNSPECIFIED, just_mark_vector, true); - sc->is_c_object_symbol = bool_defun("c-object?", is_c_object, 0, T_C_OBJECT, mark_vector_1, false); - sc->is_subvector_symbol = bool_defun("subvector?", is_subvector, 0, T_FREE, mark_vector_1, false); + sc->is_c_object_symbol = bool_defun("c-object?", is_c_object, 0, T_C_OBJECT, mark_vector_1, false); + sc->is_subvector_symbol = bool_defun("subvector?", is_subvector, 0, T_FREE, mark_vector_1, false); sc->is_weak_hash_table_symbol = bool_defun("weak-hash-table?", is_weak_hash_table, 0, T_FREE, mark_vector_1, false); - sc->is_goto_symbol = bool_defun("goto?", is_goto, 0, T_GOTO, mark_vector_1, true); + sc->is_goto_symbol = bool_defun("goto?", is_goto, 0, T_GOTO, mark_vector_1, true); /* these are for signatures */ - sc->not_symbol = defun("not", not, 1, 0, false); + sc->not_symbol = defun("not", not, 1, 0, false); sc->is_integer_or_real_at_end_symbol = make_symbol(sc, "integer:real?", 13); sc->is_integer_or_any_at_end_symbol = make_symbol(sc, "integer:any?", 12); sc->pl_p = s7_make_signature(sc, 2, sc->T, sc->is_pair_symbol); sc->pl_tl = s7_make_signature(sc, 3, - s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol); /* memq and memv signature */ + s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol); /* memq and memv signature */ sc->pl_bc = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_char_symbol); sc->pl_bn = s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_number_symbol); sc->pl_nn = s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_number_symbol); @@ -96697,114 +96697,114 @@ static void init_rootlet(s7_scheme *sc) sc->is_bignum_symbol = defun("bignum?", is_bignum, 1, 0, false); sc->bignum_symbol = defun("bignum", bignum, 1, 1, false); - sc->gensym_symbol = defun("gensym", gensym, 0, 1, false); - sc->symbol_table_symbol = defun("symbol-table", symbol_table, 0, 0, false); - sc->symbol_to_string_symbol = defun("symbol->string", symbol_to_string, 1, 0, false); - sc->string_to_symbol_symbol = defun("string->symbol", string_to_symbol, 1, 0, false); - sc->symbol_symbol = defun("symbol", symbol, 1, 0, true); - sc->symbol_to_value_symbol = defun("symbol->value", symbol_to_value, 1, 1, false); + sc->gensym_symbol = defun("gensym", gensym, 0, 1, false); + sc->symbol_table_symbol = defun("symbol-table", symbol_table, 0, 0, false); + sc->symbol_to_string_symbol = defun("symbol->string", symbol_to_string, 1, 0, false); + sc->string_to_symbol_symbol = defun("string->symbol", string_to_symbol, 1, 0, false); + sc->symbol_symbol = defun("symbol", symbol, 1, 0, true); + sc->symbol_to_value_symbol = defun("symbol->value", symbol_to_value, 1, 1, false); sc->symbol_to_dynamic_value_symbol = defun("symbol->dynamic-value", symbol_to_dynamic_value, 1, 0, false); - sc->immutable_symbol = unsafe_defun("immutable!", immutable, 1, 1, false); /* unsafe 11-Oct-23, added let arg 13-Oct-23 */ + sc->immutable_symbol = unsafe_defun("immutable!", immutable, 1, 1, false); /* unsafe 11-Oct-23, added let arg 13-Oct-23 */ set_func_is_definer(sc->immutable_symbol); - sc->is_immutable_symbol = defun("immutable?", is_immutable, 1, 1, false); /* added optional let arg 13-Oct-23 */ - sc->is_constant_symbol = defun("constant?", is_constant, 1, 0, false); - sc->string_to_keyword_symbol = defun("string->keyword", string_to_keyword, 1, 0, false); - sc->symbol_to_keyword_symbol = defun("symbol->keyword", symbol_to_keyword, 1, 0, false); - sc->keyword_to_symbol_symbol = defun("keyword->symbol", keyword_to_symbol, 1, 0, false); - - sc->outlet_symbol = defun("outlet", outlet, 1, 0, false); - sc->rootlet_symbol = defun("rootlet", rootlet, 0, 0, false); - sc->curlet_symbol = unsafe_defun("curlet", curlet, 0, 0, false); /* (define (f a) (curlet)) exports the funclet, see s7test 50215 */ + sc->is_immutable_symbol = defun("immutable?", is_immutable, 1, 1, false); /* added optional let arg 13-Oct-23 */ + sc->is_constant_symbol = defun("constant?", is_constant, 1, 0, false); + sc->string_to_keyword_symbol = defun("string->keyword", string_to_keyword, 1, 0, false); + sc->symbol_to_keyword_symbol = defun("symbol->keyword", symbol_to_keyword, 1, 0, false); + sc->keyword_to_symbol_symbol = defun("keyword->symbol", keyword_to_symbol, 1, 0, false); + + sc->outlet_symbol = defun("outlet", outlet, 1, 0, false); + sc->rootlet_symbol = defun("rootlet", rootlet, 0, 0, false); + sc->curlet_symbol = unsafe_defun("curlet", curlet, 0, 0, false); /* (define (f a) (curlet)) exports the funclet, see s7test 50215 */ set_func_is_definer(sc->curlet_symbol); - sc->unlet_symbol = defun("unlet", unlet, 0, 0, false); + sc->unlet_symbol = defun("unlet", unlet, 0, 0, false); set_local_slot(sc->unlet_symbol, global_slot(sc->unlet_symbol)); /* for set_locals */ set_immutable(sc->unlet_symbol); set_immutable_slot(global_slot(sc->unlet_symbol)); /* unlet (and with-let) don't actually need to be immutable, but s7.html says they are... */ sc->is_funclet_symbol = defun("funclet?", is_funclet, 1, 0, false); - sc->sublet_symbol = defun("sublet", sublet, 1, 0, true); - sc->varlet_symbol = semisafe_defun("varlet", varlet, 2, 0, true); /* was 1,0 13-Aug-22 */ + sc->sublet_symbol = defun("sublet", sublet, 1, 0, true); + sc->varlet_symbol = semisafe_defun("varlet", varlet, 2, 0, true); /* was 1,0 13-Aug-22 */ set_func_is_definer(sc->varlet_symbol); - sc->cutlet_symbol = semisafe_defun("cutlet", cutlet, 2, 0, true); /* was 1,0 13-Aug-22 */ + sc->cutlet_symbol = semisafe_defun("cutlet", cutlet, 2, 0, true); /* was 1,0 13-Aug-22 */ set_func_is_definer(sc->cutlet_symbol); - sc->inlet_symbol = defun("inlet", inlet, 0, 0, true); - sc->owlet_symbol = defun("owlet", owlet, 0, 0, false); - sc->coverlet_symbol = defun("coverlet", coverlet, 1, 0, false); - sc->openlet_symbol = defun("openlet", openlet, 1, 0, false); - sc->let_ref_symbol = defun("let-ref", let_ref, 2, 0, false); + sc->inlet_symbol = defun("inlet", inlet, 0, 0, true); + sc->owlet_symbol = defun("owlet", owlet, 0, 0, false); + sc->coverlet_symbol = defun("coverlet", coverlet, 1, 0, false); + sc->openlet_symbol = defun("openlet", openlet, 1, 0, false); + sc->let_ref_symbol = defun("let-ref", let_ref, 2, 0, false); set_immutable(sc->let_ref_symbol); /* 16-Sep-19 */ set_immutable_slot(global_slot(sc->let_ref_symbol)); - sc->let_set_symbol = defun("let-set!", let_set, 3, 0, false); + sc->let_set_symbol = defun("let-set!", let_set, 3, 0, false); set_immutable(sc->let_set_symbol); set_immutable_slot(global_slot(sc->let_set_symbol)); sc->let_ref_fallback_symbol = make_symbol(sc, "let-ref-fallback", 16); sc->let_set_fallback_symbol = make_symbol(sc, "let-set-fallback", 16); /* was let-set!-fallback until 9-Oct-17 */ - sc->make_iterator_symbol = defun("make-iterator", make_iterator, 1, 1, false); - sc->iterate_symbol = defun("iterate", iterate, 1, 0, false); - sc->iterator_sequence_symbol = defun("iterator-sequence", iterator_sequence, 1, 0, false); - sc->iterator_is_at_end_symbol = defun("iterator-at-end?", iterator_is_at_end, 1, 0, false); + sc->make_iterator_symbol = defun("make-iterator", make_iterator, 1, 1, false); + sc->iterate_symbol = defun("iterate", iterate, 1, 0, false); + sc->iterator_sequence_symbol = defun("iterator-sequence", iterator_sequence, 1, 0, false); + sc->iterator_is_at_end_symbol = defun("iterator-at-end?", iterator_is_at_end, 1, 0, false); - sc->is_provided_symbol = defun("provided?", is_provided, 1, 0, false); - sc->provide_symbol = semisafe_defun("provide", provide, 1, 0, false); /* can add *features* to curlet */ + sc->is_provided_symbol = defun("provided?", is_provided, 1, 0, false); + sc->provide_symbol = semisafe_defun("provide", provide, 1, 0, false); /* can add *features* to curlet */ set_func_is_definer(sc->provide_symbol); - sc->is_defined_symbol = defun("defined?", is_defined, 1, 2, false); - - sc->c_object_type_symbol = defun("c-object-type", c_object_type, 1, 0, false); - sc->c_pointer_symbol = defun("c-pointer", c_pointer, 1, 4, false); - sc->c_pointer_info_symbol = defun("c-pointer-info", c_pointer_info, 1, 0, false); - sc->c_pointer_type_symbol = defun("c-pointer-type", c_pointer_type, 1, 0, false); - sc->c_pointer_weak1_symbol = defun("c-pointer-weak1", c_pointer_weak1, 1, 0, false); - sc->c_pointer_weak2_symbol = defun("c-pointer-weak2", c_pointer_weak2, 1, 0, false); + sc->is_defined_symbol = defun("defined?", is_defined, 1, 2, false); + + sc->c_object_type_symbol = defun("c-object-type", c_object_type, 1, 0, false); + sc->c_pointer_symbol = defun("c-pointer", c_pointer, 1, 4, false); + sc->c_pointer_info_symbol = defun("c-pointer-info", c_pointer_info, 1, 0, false); + sc->c_pointer_type_symbol = defun("c-pointer-type", c_pointer_type, 1, 0, false); + sc->c_pointer_weak1_symbol = defun("c-pointer-weak1", c_pointer_weak1, 1, 0, false); + sc->c_pointer_weak2_symbol = defun("c-pointer-weak2", c_pointer_weak2, 1, 0, false); sc->c_pointer_to_list_symbol = defun("c-pointer->list", c_pointer_to_list, 1, 0, false); - sc->port_string_symbol = defun("port-string", port_string, 1, 0, false); - sc->port_file_symbol = defun("port-file", port_file, 1, 0, false); - sc->port_position_symbol = defun("port-position", port_position, 1, 0, false); - sc->port_line_number_symbol = defun("port-line-number", port_line_number, 0, 1, false); - sc->port_filename_symbol = defun("port-filename", port_filename, 0, 1, false); - sc->pair_line_number_symbol = defun("pair-line-number", pair_line_number, 1, 0, false); - sc->pair_filename_symbol = defun("pair-filename", pair_filename, 1, 0, false); - sc->is_port_closed_symbol = defun("port-closed?", is_port_closed, 1, 0, false); + sc->port_string_symbol = defun("port-string", port_string, 1, 0, false); + sc->port_file_symbol = defun("port-file", port_file, 1, 0, false); + sc->port_position_symbol = defun("port-position", port_position, 1, 0, false); + sc->port_line_number_symbol = defun("port-line-number", port_line_number, 0, 1, false); + sc->port_filename_symbol = defun("port-filename", port_filename, 0, 1, false); + sc->pair_line_number_symbol = defun("pair-line-number", pair_line_number, 1, 0, false); + sc->pair_filename_symbol = defun("pair-filename", pair_filename, 1, 0, false); + sc->is_port_closed_symbol = defun("port-closed?", is_port_closed, 1, 0, false); sc->current_input_port_symbol = defun("current-input-port", current_input_port, 0, 0, false); sc->current_output_port_symbol = defun("current-output-port", current_output_port, 0, 0, false); sc->current_error_port_symbol = defun("current-error-port", current_error_port, 0, 0, false); sc->set_current_error_port_symbol = defun("set-current-error-port", set_current_error_port, 1, 0, false); #if (!WITH_PURE_S7) - sc->let_to_list_symbol = defun("let->list", let_to_list, 1, 0, false); + sc->let_to_list_symbol = defun("let->list", let_to_list, 1, 0, false); sc->set_current_input_port_symbol = defun("set-current-input-port", set_current_input_port, 1, 0, false); sc->set_current_output_port_symbol = defun("set-current-output-port", set_current_output_port, 1, 0, false); - sc->is_char_ready_symbol = defun("char-ready?", is_char_ready, 0, 1, false); /* the least-used scheme function */ + sc->is_char_ready_symbol = defun("char-ready?", is_char_ready, 0, 1, false); /* the least-used scheme function */ #endif - sc->close_input_port_symbol = defun("close-input-port", close_input_port, 1, 0, false); - sc->close_output_port_symbol = defun("close-output-port", close_output_port, 1, 0, false); - sc->flush_output_port_symbol = defun("flush-output-port", flush_output_port, 0, 1, false); - sc->open_input_file_symbol = defun("open-input-file", open_input_file, 1, 1, false); - sc->open_output_file_symbol = defun("open-output-file", open_output_file, 1, 1, false); - sc->open_input_string_symbol = defun("open-input-string", open_input_string, 1, 0, false); - sc->open_output_string_symbol = defun("open-output-string", open_output_string, 0, 0, false); - sc->get_output_string_symbol = defun("get-output-string", get_output_string, 1, 1, false); + sc->close_input_port_symbol = defun("close-input-port", close_input_port, 1, 0, false); + sc->close_output_port_symbol = defun("close-output-port", close_output_port, 1, 0, false); + sc->flush_output_port_symbol = defun("flush-output-port", flush_output_port, 0, 1, false); + sc->open_input_file_symbol = defun("open-input-file", open_input_file, 1, 1, false); + sc->open_output_file_symbol = defun("open-output-file", open_output_file, 1, 1, false); + sc->open_input_string_symbol = defun("open-input-string", open_input_string, 1, 0, false); + sc->open_output_string_symbol = defun("open-output-string", open_output_string, 0, 0, false); + sc->get_output_string_symbol = defun("get-output-string", get_output_string, 1, 1, false); sc->get_output_string_uncopied = s7_make_safe_function(sc, "get-output-string", g_get_output_string_uncopied, 1, 1, false, NULL); - sc->open_input_function_symbol = defun("open-input-function",open_input_function, 1, 0, false); - sc->open_output_function_symbol = defun("open-output-function",open_output_function, 1, 0, false); + sc->open_input_function_symbol = defun("open-input-function",open_input_function, 1, 0, false); + sc->open_output_function_symbol = defun("open-output-function",open_output_function, 1, 0, false); sc->closed_input_function = s7_make_safe_function(sc, "closed-input-function", g_closed_input_function_port, 2, 0, false, "input-function error"), sc->closed_output_function = s7_make_safe_function(sc, "closed-output-function", g_closed_output_function_port, 1, 0, false, "output-function error"), - sc->newline_symbol = defun("newline", newline, 0, 1, false); - sc->write_symbol = defun("write", write, 1, 1, false); - sc->display_symbol = defun("display", display, 1, 1, false); - sc->read_char_symbol = defun("read-char", read_char, 0, 1, false); - sc->peek_char_symbol = defun("peek-char", peek_char, 0, 1, false); - sc->write_char_symbol = defun("write-char", write_char, 1, 1, false); - sc->write_string_symbol = defun("write-string", write_string, 1, 3, false); - sc->read_byte_symbol = defun("read-byte", read_byte, 0, 1, false); - sc->write_byte_symbol = defun("write-byte", write_byte, 1, 1, false); - sc->read_line_symbol = defun("read-line", read_line, 0, 2, false); - sc->read_string_symbol = defun("read-string", read_string, 1, 1, false); - sc->read_symbol = semisafe_defun("read", read, 0, 1, false); + sc->newline_symbol = defun("newline", newline, 0, 1, false); + sc->write_symbol = defun("write", write, 1, 1, false); + sc->display_symbol = defun("display", display, 1, 1, false); + sc->read_char_symbol = defun("read-char", read_char, 0, 1, false); + sc->peek_char_symbol = defun("peek-char", peek_char, 0, 1, false); + sc->write_char_symbol = defun("write-char", write_char, 1, 1, false); + sc->write_string_symbol = defun("write-string", write_string, 1, 3, false); + sc->read_byte_symbol = defun("read-byte", read_byte, 0, 1, false); + sc->write_byte_symbol = defun("write-byte", write_byte, 1, 1, false); + sc->read_line_symbol = defun("read-line", read_line, 0, 2, false); + sc->read_string_symbol = defun("read-string", read_string, 1, 1, false); + sc->read_symbol = semisafe_defun("read", read, 0, 1, false); /* read can't be safe because it messes with the stack, expecting to be all by itself in the call sequence * (not embedded in OP_SAFE_C_opSq for example) -- that is, it pushes OP_READ_INTERNAL, then returns * expecting continue (goto top-of-eval-loop), which would be nonsense if arg=fn|x_proc(read) -> fn|x_proc(arg). @@ -96826,288 +96826,288 @@ static void init_rootlet(s7_scheme *sc) sc->with_output_to_file_symbol = semisafe_defun("with-output-to-file", with_output_to_file, 2, 0, false); #if WITH_SYSTEM_EXTRAS - sc->is_directory_symbol = defun("directory?", is_directory, 1, 0, false); - sc->file_exists_symbol = defun("file-exists?", file_exists, 1, 0, false); - sc->delete_file_symbol = defun("delete-file", delete_file, 1, 0, false); - sc->getenv_symbol = defun("getenv", getenv, 1, 0, false); - sc->system_symbol = defun("system", system, 1, 1, false); + sc->is_directory_symbol = defun("directory?", is_directory, 1, 0, false); + sc->file_exists_symbol = defun("file-exists?", file_exists, 1, 0, false); + sc->delete_file_symbol = defun("delete-file", delete_file, 1, 0, false); + sc->getenv_symbol = defun("getenv", getenv, 1, 0, false); + sc->system_symbol = defun("system", system, 1, 1, false); #if (!MS_WINDOWS) - sc->directory_to_list_symbol = defun("directory->list", directory_to_list, 1, 0, false); - sc->file_mtime_symbol = defun("file-mtime", file_mtime, 1, 0, false); -#endif -#endif - - sc->real_part_symbol = defun("real-part", real_part, 1, 0, false); - sc->imag_part_symbol = defun("imag-part", imag_part, 1, 0, false); - sc->numerator_symbol = defun("numerator", numerator, 1, 0, false); - sc->denominator_symbol = defun("denominator", denominator, 1, 0, false); - sc->is_even_symbol = defun("even?", is_even, 1, 0, false); - sc->is_odd_symbol = defun("odd?", is_odd, 1, 0, false); - sc->is_zero_symbol = defun("zero?", is_zero, 1, 0, false); - sc->is_positive_symbol = defun("positive?", is_positive, 1, 0, false); - sc->is_negative_symbol = defun("negative?", is_negative, 1, 0, false); - sc->is_infinite_symbol = defun("infinite?", is_infinite, 1, 0, false); - sc->is_nan_symbol = defun("nan?", is_nan, 1, 0, false); - sc->complex_symbol = defun("complex", complex, 2, 0, false); - - sc->add_symbol = defun("+", add, 0, 0, true); set_all_integer_and_float(sc->add_symbol); - sc->subtract_symbol = defun("-", subtract, 1, 0, true); set_all_integer_and_float(sc->subtract_symbol); - sc->multiply_symbol = defun("*", multiply, 0, 0, true); set_all_integer_and_float(sc->multiply_symbol); - sc->divide_symbol = defun("/", divide, 1, 0, true); set_all_float(sc->divide_symbol); - sc->min_symbol = defun("min", min, 1, 0, true); set_all_integer_and_float(sc->min_symbol); - sc->max_symbol = defun("max", max, 1, 0, true); set_all_integer_and_float(sc->max_symbol); - - sc->quotient_symbol = defun("quotient", quotient, 2, 0, false); set_all_integer(sc->quotient_symbol); - sc->remainder_symbol = defun("remainder", remainder, 2, 0, false); set_all_integer(sc->remainder_symbol); - sc->modulo_symbol = defun("modulo", modulo, 2, 0, false); set_all_integer(sc->modulo_symbol); - sc->num_eq_symbol = defun("=", num_eq, 2, 0, true); - sc->lt_symbol = defun("<", less, 2, 0, true); - sc->gt_symbol = defun(">", greater, 2, 0, true); - sc->leq_symbol = defun("<=", less_or_equal, 2, 0, true); - sc->geq_symbol = defun(">=", greater_or_equal, 2, 0, true); - sc->gcd_symbol = defun("gcd", gcd, 0, 0, true); - sc->lcm_symbol = defun("lcm", lcm, 0, 0, true); - sc->rationalize_symbol = defun("rationalize", rationalize, 1, 1, false); - sc->random_symbol = defun("random", random, 1, 1, false); set_all_integer_and_float(sc->random_symbol); - sc->random_state_symbol = defun("random-state", random_state, 0, (WITH_GMP) ? 1 : 2, false); - sc->expt_symbol = defun("expt", expt, 2, 0, false); - sc->log_symbol = defun("log", log, 1, 1, false); - sc->ash_symbol = defun("ash", ash, 2, 0, false); - sc->exp_symbol = defun("exp", exp, 1, 0, false); set_all_float(sc->exp_symbol); - sc->abs_symbol = defun("abs", abs, 1, 0, false); set_all_integer_and_float(sc->abs_symbol); - sc->magnitude_symbol = defun("magnitude", magnitude, 1, 0, false); set_all_integer_and_float(sc->magnitude_symbol); - sc->angle_symbol = defun("angle", angle, 1, 0, false); - sc->sin_symbol = defun("sin", sin, 1, 0, false); set_all_float(sc->sin_symbol); - sc->cos_symbol = defun("cos", cos, 1, 0, false); set_all_float(sc->cos_symbol); - sc->tan_symbol = defun("tan", tan, 1, 0, false); set_all_float(sc->tan_symbol); - sc->sinh_symbol = defun("sinh", sinh, 1, 0, false); set_all_float(sc->sinh_symbol); - sc->cosh_symbol = defun("cosh", cosh, 1, 0, false); set_all_float(sc->cosh_symbol); - sc->tanh_symbol = defun("tanh", tanh, 1, 0, false); set_all_float(sc->tanh_symbol); - sc->asin_symbol = defun("asin", asin, 1, 0, false); - sc->acos_symbol = defun("acos", acos, 1, 0, false); - sc->atan_symbol = defun("atan", atan, 1, 1, false); - sc->asinh_symbol = defun("asinh", asinh, 1, 0, false); - sc->acosh_symbol = defun("acosh", acosh, 1, 0, false); - sc->atanh_symbol = defun("atanh", atanh, 1, 0, false); - sc->sqrt_symbol = defun("sqrt", sqrt, 1, 0, false); - sc->floor_symbol = defun("floor", floor, 1, 0, false); - sc->ceiling_symbol = defun("ceiling", ceiling, 1, 0, false); - sc->truncate_symbol = defun("truncate", truncate, 1, 0, false); - sc->round_symbol = defun("round", round, 1, 0, false); - sc->logand_symbol = defun("logand", logand, 0, 0, true); - sc->logior_symbol = defun("logior", logior, 0, 0, true); - sc->logxor_symbol = defun("logxor", logxor, 0, 0, true); - sc->lognot_symbol = defun("lognot", lognot, 1, 0, false); - sc->logbit_symbol = defun("logbit?", logbit, 2, 0, false); + sc->directory_to_list_symbol = defun("directory->list", directory_to_list, 1, 0, false); + sc->file_mtime_symbol = defun("file-mtime", file_mtime, 1, 0, false); +#endif +#endif + + sc->real_part_symbol = defun("real-part", real_part, 1, 0, false); + sc->imag_part_symbol = defun("imag-part", imag_part, 1, 0, false); + sc->numerator_symbol = defun("numerator", numerator, 1, 0, false); + sc->denominator_symbol = defun("denominator", denominator, 1, 0, false); + sc->is_even_symbol = defun("even?", is_even, 1, 0, false); + sc->is_odd_symbol = defun("odd?", is_odd, 1, 0, false); + sc->is_zero_symbol = defun("zero?", is_zero, 1, 0, false); + sc->is_positive_symbol = defun("positive?", is_positive, 1, 0, false); + sc->is_negative_symbol = defun("negative?", is_negative, 1, 0, false); + sc->is_infinite_symbol = defun("infinite?", is_infinite, 1, 0, false); + sc->is_nan_symbol = defun("nan?", is_nan, 1, 0, false); + sc->complex_symbol = defun("complex", complex, 2, 0, false); + + sc->add_symbol = defun("+", add, 0, 0, true); set_all_integer_and_float(sc->add_symbol); + sc->subtract_symbol = defun("-", subtract, 1, 0, true); set_all_integer_and_float(sc->subtract_symbol); + sc->multiply_symbol = defun("*", multiply, 0, 0, true); set_all_integer_and_float(sc->multiply_symbol); + sc->divide_symbol = defun("/", divide, 1, 0, true); set_all_float(sc->divide_symbol); + sc->min_symbol = defun("min", min, 1, 0, true); set_all_integer_and_float(sc->min_symbol); + sc->max_symbol = defun("max", max, 1, 0, true); set_all_integer_and_float(sc->max_symbol); + + sc->quotient_symbol = defun("quotient", quotient, 2, 0, false); set_all_integer(sc->quotient_symbol); + sc->remainder_symbol = defun("remainder", remainder, 2, 0, false); set_all_integer(sc->remainder_symbol); + sc->modulo_symbol = defun("modulo", modulo, 2, 0, false); set_all_integer(sc->modulo_symbol); + sc->num_eq_symbol = defun("=", num_eq, 2, 0, true); + sc->lt_symbol = defun("<", less, 2, 0, true); + sc->gt_symbol = defun(">", greater, 2, 0, true); + sc->leq_symbol = defun("<=", less_or_equal, 2, 0, true); + sc->geq_symbol = defun(">=", greater_or_equal, 2, 0, true); + sc->gcd_symbol = defun("gcd", gcd, 0, 0, true); + sc->lcm_symbol = defun("lcm", lcm, 0, 0, true); + sc->rationalize_symbol = defun("rationalize", rationalize, 1, 1, false); + sc->random_symbol = defun("random", random, 1, 1, false); set_all_integer_and_float(sc->random_symbol); + sc->random_state_symbol = defun("random-state", random_state, 0, (WITH_GMP) ? 1 : 2, false); + sc->expt_symbol = defun("expt", expt, 2, 0, false); + sc->log_symbol = defun("log", log, 1, 1, false); + sc->ash_symbol = defun("ash", ash, 2, 0, false); + sc->exp_symbol = defun("exp", exp, 1, 0, false); set_all_float(sc->exp_symbol); + sc->abs_symbol = defun("abs", abs, 1, 0, false); set_all_integer_and_float(sc->abs_symbol); + sc->magnitude_symbol = defun("magnitude", magnitude, 1, 0, false); set_all_integer_and_float(sc->magnitude_symbol); + sc->angle_symbol = defun("angle", angle, 1, 0, false); + sc->sin_symbol = defun("sin", sin, 1, 0, false); set_all_float(sc->sin_symbol); + sc->cos_symbol = defun("cos", cos, 1, 0, false); set_all_float(sc->cos_symbol); + sc->tan_symbol = defun("tan", tan, 1, 0, false); set_all_float(sc->tan_symbol); + sc->sinh_symbol = defun("sinh", sinh, 1, 0, false); set_all_float(sc->sinh_symbol); + sc->cosh_symbol = defun("cosh", cosh, 1, 0, false); set_all_float(sc->cosh_symbol); + sc->tanh_symbol = defun("tanh", tanh, 1, 0, false); set_all_float(sc->tanh_symbol); + sc->asin_symbol = defun("asin", asin, 1, 0, false); + sc->acos_symbol = defun("acos", acos, 1, 0, false); + sc->atan_symbol = defun("atan", atan, 1, 1, false); + sc->asinh_symbol = defun("asinh", asinh, 1, 0, false); + sc->acosh_symbol = defun("acosh", acosh, 1, 0, false); + sc->atanh_symbol = defun("atanh", atanh, 1, 0, false); + sc->sqrt_symbol = defun("sqrt", sqrt, 1, 0, false); + sc->floor_symbol = defun("floor", floor, 1, 0, false); + sc->ceiling_symbol = defun("ceiling", ceiling, 1, 0, false); + sc->truncate_symbol = defun("truncate", truncate, 1, 0, false); + sc->round_symbol = defun("round", round, 1, 0, false); + sc->logand_symbol = defun("logand", logand, 0, 0, true); + sc->logior_symbol = defun("logior", logior, 0, 0, true); + sc->logxor_symbol = defun("logxor", logxor, 0, 0, true); + sc->lognot_symbol = defun("lognot", lognot, 1, 0, false); + sc->logbit_symbol = defun("logbit?", logbit, 2, 0, false); sc->integer_decode_float_symbol = defun("integer-decode-float", integer_decode_float, 1, 0, false); sc->nan_symbol = defun("nan", nan, 0, 1, false); /* (nan) -> +nan.0, (nan 123) -> +nan.123 */ sc->nan_payload_symbol = defun("nan-payload", nan_payload, 1, 0, false); #if (!WITH_PURE_S7) - sc->integer_length_symbol = defun("integer-length", integer_length, 1, 0, false); - sc->inexact_to_exact_symbol = defun("inexact->exact", inexact_to_exact, 1, 0, false); - sc->exact_to_inexact_symbol = defun("exact->inexact", exact_to_inexact, 1, 0, false); - sc->is_exact_symbol = defun("exact?", is_exact, 1, 0, false); - sc->is_inexact_symbol = defun("inexact?", is_inexact, 1, 0, false); + sc->integer_length_symbol = defun("integer-length", integer_length, 1, 0, false); + sc->inexact_to_exact_symbol = defun("inexact->exact", inexact_to_exact, 1, 0, false); + sc->exact_to_inexact_symbol = defun("exact->inexact", exact_to_inexact, 1, 0, false); + sc->is_exact_symbol = defun("exact?", is_exact, 1, 0, false); + sc->is_inexact_symbol = defun("inexact?", is_inexact, 1, 0, false); #endif sc->random_state_to_list_symbol = defun("random-state->list", random_state_to_list, 0, 1, false); - sc->number_to_string_symbol = defun("number->string", number_to_string, 1, 1, false); - sc->string_to_number_symbol = defun("string->number", string_to_number, 1, 1, false); - - sc->char_upcase_symbol = defun("char-upcase", char_upcase, 1, 0, false); - sc->char_downcase_symbol = defun("char-downcase", char_downcase, 1, 0, false); - sc->char_to_integer_symbol = defun("char->integer", char_to_integer, 1, 0, false); - sc->integer_to_char_symbol = defun("integer->char", integer_to_char, 1, 0, false); - - sc->is_char_upper_case_symbol = defun("char-upper-case?", is_char_upper_case, 1, 0, false); - sc->is_char_lower_case_symbol = defun("char-lower-case?", is_char_lower_case, 1, 0, false); - sc->is_char_alphabetic_symbol = defun("char-alphabetic?", is_char_alphabetic, 1, 0, false); - sc->is_char_numeric_symbol = defun("char-numeric?", is_char_numeric, 1, 0, false); - sc->is_char_whitespace_symbol = defun("char-whitespace?", is_char_whitespace, 1, 0, false); - - sc->char_eq_symbol = defun("char=?", chars_are_equal, 2, 0, true); - sc->char_lt_symbol = defun("char<?", chars_are_less, 2, 0, true); - sc->char_gt_symbol = defun("char>?", chars_are_greater, 2, 0, true); - sc->char_leq_symbol = defun("char<=?", chars_are_leq, 2, 0, true); - sc->char_geq_symbol = defun("char>=?", chars_are_geq, 2, 0, true); - sc->char_position_symbol = defun("char-position", char_position, 2, 1, false); - sc->string_position_symbol = defun("string-position", string_position, 2, 1, false); - - sc->make_string_symbol = defun("make-string", make_string, 1, 1, false); - sc->string_ref_symbol = defun("string-ref", string_ref, 2, 0, false); - sc->string_set_symbol = defun("string-set!", string_set, 3, 0, false); - - sc->string_eq_symbol = defun("string=?", strings_are_equal, 2, 0, true); - sc->string_lt_symbol = defun("string<?", strings_are_less, 2, 0, true); - sc->string_gt_symbol = defun("string>?", strings_are_greater, 2, 0, true); - sc->string_leq_symbol = defun("string<=?", strings_are_leq, 2, 0, true); - sc->string_geq_symbol = defun("string>=?", strings_are_geq, 2, 0, true); + sc->number_to_string_symbol = defun("number->string", number_to_string, 1, 1, false); + sc->string_to_number_symbol = defun("string->number", string_to_number, 1, 1, false); + + sc->char_upcase_symbol = defun("char-upcase", char_upcase, 1, 0, false); + sc->char_downcase_symbol = defun("char-downcase", char_downcase, 1, 0, false); + sc->char_to_integer_symbol = defun("char->integer", char_to_integer, 1, 0, false); + sc->integer_to_char_symbol = defun("integer->char", integer_to_char, 1, 0, false); + + sc->is_char_upper_case_symbol = defun("char-upper-case?", is_char_upper_case, 1, 0, false); + sc->is_char_lower_case_symbol = defun("char-lower-case?", is_char_lower_case, 1, 0, false); + sc->is_char_alphabetic_symbol = defun("char-alphabetic?", is_char_alphabetic, 1, 0, false); + sc->is_char_numeric_symbol = defun("char-numeric?", is_char_numeric, 1, 0, false); + sc->is_char_whitespace_symbol = defun("char-whitespace?", is_char_whitespace, 1, 0, false); + + sc->char_eq_symbol = defun("char=?", chars_are_equal, 2, 0, true); + sc->char_lt_symbol = defun("char<?", chars_are_less, 2, 0, true); + sc->char_gt_symbol = defun("char>?", chars_are_greater, 2, 0, true); + sc->char_leq_symbol = defun("char<=?", chars_are_leq, 2, 0, true); + sc->char_geq_symbol = defun("char>=?", chars_are_geq, 2, 0, true); + sc->char_position_symbol = defun("char-position", char_position, 2, 1, false); + sc->string_position_symbol = defun("string-position", string_position, 2, 1, false); + + sc->make_string_symbol = defun("make-string", make_string, 1, 1, false); + sc->string_ref_symbol = defun("string-ref", string_ref, 2, 0, false); + sc->string_set_symbol = defun("string-set!", string_set, 3, 0, false); + + sc->string_eq_symbol = defun("string=?", strings_are_equal, 2, 0, true); + sc->string_lt_symbol = defun("string<?", strings_are_less, 2, 0, true); + sc->string_gt_symbol = defun("string>?", strings_are_greater, 2, 0, true); + sc->string_leq_symbol = defun("string<=?", strings_are_leq, 2, 0, true); + sc->string_geq_symbol = defun("string>=?", strings_are_geq, 2, 0, true); #if (!WITH_PURE_S7) - sc->char_ci_eq_symbol = defun("char-ci=?", chars_are_ci_equal, 2, 0, true); - sc->char_ci_lt_symbol = defun("char-ci<?", chars_are_ci_less, 2, 0, true); - sc->char_ci_gt_symbol = defun("char-ci>?", chars_are_ci_greater, 2, 0, true); - sc->char_ci_leq_symbol = defun("char-ci<=?", chars_are_ci_leq, 2, 0, true); - sc->char_ci_geq_symbol = defun("char-ci>=?", chars_are_ci_geq, 2, 0, true); - sc->string_ci_eq_symbol = defun("string-ci=?", strings_are_ci_equal, 2, 0, true); - sc->string_ci_lt_symbol = defun("string-ci<?", strings_are_ci_less, 2, 0, true); - sc->string_ci_gt_symbol = defun("string-ci>?", strings_are_ci_greater, 2, 0, true); - sc->string_ci_leq_symbol = defun("string-ci<=?", strings_are_ci_leq, 2, 0, true); - sc->string_ci_geq_symbol = defun("string-ci>=?", strings_are_ci_geq, 2, 0, true); - sc->string_fill_symbol = defun("string-fill!", string_fill, 2, 2, false); - sc->list_to_string_symbol = defun("list->string", list_to_string, 1, 0, false); - sc->string_length_symbol = defun("string-length", string_length, 1, 0, false); - sc->string_to_list_symbol = defun("string->list", string_to_list, 1, 2, false); -#endif - sc->string_copy_symbol = defun("string-copy", string_copy, 1, 3, false); - - sc->string_downcase_symbol = defun("string-downcase", string_downcase, 1, 0, false); - sc->string_upcase_symbol = defun("string-upcase", string_upcase, 1, 0, false); - sc->string_append_symbol = defun("string-append", string_append, 0, 0, true); - sc->substring_symbol = defun("substring", substring, 2, 1, false); - sc->string_symbol = defun("string", string, 0, 0, true); - sc->object_to_string_symbol = defun("object->string", object_to_string, 1, 2, false); - sc->format_symbol = defun("format", format, 2, 0, true); - sc->object_to_let_symbol = defun("object->let", object_to_let, 1, 0, false); - - sc->cons_symbol = defun("cons", cons, 2, 0, false); - sc->car_symbol = defun("car", car, 1, 0, false); - sc->cdr_symbol = defun("cdr", cdr, 1, 0, false); - sc->set_car_symbol = defun("set-car!", set_car, 2, 0, false); - sc->set_cdr_symbol = defun("set-cdr!", set_cdr, 2, 0, false); - sc->caar_symbol = defun("caar", caar, 1, 0, false); - sc->cadr_symbol = defun("cadr", cadr, 1, 0, false); - sc->cdar_symbol = defun("cdar", cdar, 1, 0, false); - sc->cddr_symbol = defun("cddr", cddr, 1, 0, false); - sc->caaar_symbol = defun("caaar", caaar, 1, 0, false); - sc->caadr_symbol = defun("caadr", caadr, 1, 0, false); - sc->cadar_symbol = defun("cadar", cadar, 1, 0, false); - sc->cdaar_symbol = defun("cdaar", cdaar, 1, 0, false); - sc->caddr_symbol = defun("caddr", caddr, 1, 0, false); - sc->cdddr_symbol = defun("cdddr", cdddr, 1, 0, false); - sc->cdadr_symbol = defun("cdadr", cdadr, 1, 0, false); - sc->cddar_symbol = defun("cddar", cddar, 1, 0, false); - sc->caaaar_symbol = defun("caaaar", caaaar, 1, 0, false); - sc->caaadr_symbol = defun("caaadr", caaadr, 1, 0, false); - sc->caadar_symbol = defun("caadar", caadar, 1, 0, false); - sc->cadaar_symbol = defun("cadaar", cadaar, 1, 0, false); - sc->caaddr_symbol = defun("caaddr", caaddr, 1, 0, false); - sc->cadddr_symbol = defun("cadddr", cadddr, 1, 0, false); - sc->cadadr_symbol = defun("cadadr", cadadr, 1, 0, false); - sc->caddar_symbol = defun("caddar", caddar, 1, 0, false); - sc->cdaaar_symbol = defun("cdaaar", cdaaar, 1, 0, false); - sc->cdaadr_symbol = defun("cdaadr", cdaadr, 1, 0, false); - sc->cdadar_symbol = defun("cdadar", cdadar, 1, 0, false); - sc->cddaar_symbol = defun("cddaar", cddaar, 1, 0, false); - sc->cdaddr_symbol = defun("cdaddr", cdaddr, 1, 0, false); - sc->cddddr_symbol = defun("cddddr", cddddr, 1, 0, false); - sc->cddadr_symbol = defun("cddadr", cddadr, 1, 0, false); - sc->cdddar_symbol = defun("cdddar", cdddar, 1, 0, false); - - sc->assq_symbol = defun("assq", assq, 2, 0, false); - sc->assv_symbol = defun("assv", assv, 2, 0, false); - sc->assoc_symbol = semisafe_defun("assoc", assoc, 2, 1, false); - sc->memq_symbol = defun("memq", memq, 2, 0, false); - sc->memv_symbol = defun("memv", memv, 2, 0, false); - sc->member_symbol = semisafe_defun("member", member, 2, 1, false); - - sc->list_symbol = defun("list", list, 0, 0, true); - sc->list_ref_symbol = defun("list-ref", list_ref, 2, 0, true); - sc->list_set_symbol = defun("list-set!", list_set, 3, 0, true); - sc->list_tail_symbol = defun("list-tail", list_tail, 2, 0, false); - sc->make_list_symbol = defun("make-list", make_list, 1, 1, false); - - sc->length_symbol = defun("length", length, 1, 0, false); - sc->copy_symbol = defun("copy", copy, 1, 3, false); + sc->char_ci_eq_symbol = defun("char-ci=?", chars_are_ci_equal, 2, 0, true); + sc->char_ci_lt_symbol = defun("char-ci<?", chars_are_ci_less, 2, 0, true); + sc->char_ci_gt_symbol = defun("char-ci>?", chars_are_ci_greater, 2, 0, true); + sc->char_ci_leq_symbol = defun("char-ci<=?", chars_are_ci_leq, 2, 0, true); + sc->char_ci_geq_symbol = defun("char-ci>=?", chars_are_ci_geq, 2, 0, true); + sc->string_ci_eq_symbol = defun("string-ci=?", strings_are_ci_equal, 2, 0, true); + sc->string_ci_lt_symbol = defun("string-ci<?", strings_are_ci_less, 2, 0, true); + sc->string_ci_gt_symbol = defun("string-ci>?", strings_are_ci_greater, 2, 0, true); + sc->string_ci_leq_symbol = defun("string-ci<=?", strings_are_ci_leq, 2, 0, true); + sc->string_ci_geq_symbol = defun("string-ci>=?", strings_are_ci_geq, 2, 0, true); + sc->string_fill_symbol = defun("string-fill!", string_fill, 2, 2, false); + sc->list_to_string_symbol = defun("list->string", list_to_string, 1, 0, false); + sc->string_length_symbol = defun("string-length", string_length, 1, 0, false); + sc->string_to_list_symbol = defun("string->list", string_to_list, 1, 2, false); +#endif + sc->string_copy_symbol = defun("string-copy", string_copy, 1, 3, false); + + sc->string_downcase_symbol = defun("string-downcase", string_downcase, 1, 0, false); + sc->string_upcase_symbol = defun("string-upcase", string_upcase, 1, 0, false); + sc->string_append_symbol = defun("string-append", string_append, 0, 0, true); + sc->substring_symbol = defun("substring", substring, 2, 1, false); + sc->string_symbol = defun("string", string, 0, 0, true); + sc->object_to_string_symbol = defun("object->string", object_to_string, 1, 2, false); + sc->format_symbol = defun("format", format, 2, 0, true); + sc->object_to_let_symbol = defun("object->let", object_to_let, 1, 0, false); + + sc->cons_symbol = defun("cons", cons, 2, 0, false); + sc->car_symbol = defun("car", car, 1, 0, false); + sc->cdr_symbol = defun("cdr", cdr, 1, 0, false); + sc->set_car_symbol = defun("set-car!", set_car, 2, 0, false); + sc->set_cdr_symbol = defun("set-cdr!", set_cdr, 2, 0, false); + sc->caar_symbol = defun("caar", caar, 1, 0, false); + sc->cadr_symbol = defun("cadr", cadr, 1, 0, false); + sc->cdar_symbol = defun("cdar", cdar, 1, 0, false); + sc->cddr_symbol = defun("cddr", cddr, 1, 0, false); + sc->caaar_symbol = defun("caaar", caaar, 1, 0, false); + sc->caadr_symbol = defun("caadr", caadr, 1, 0, false); + sc->cadar_symbol = defun("cadar", cadar, 1, 0, false); + sc->cdaar_symbol = defun("cdaar", cdaar, 1, 0, false); + sc->caddr_symbol = defun("caddr", caddr, 1, 0, false); + sc->cdddr_symbol = defun("cdddr", cdddr, 1, 0, false); + sc->cdadr_symbol = defun("cdadr", cdadr, 1, 0, false); + sc->cddar_symbol = defun("cddar", cddar, 1, 0, false); + sc->caaaar_symbol = defun("caaaar", caaaar, 1, 0, false); + sc->caaadr_symbol = defun("caaadr", caaadr, 1, 0, false); + sc->caadar_symbol = defun("caadar", caadar, 1, 0, false); + sc->cadaar_symbol = defun("cadaar", cadaar, 1, 0, false); + sc->caaddr_symbol = defun("caaddr", caaddr, 1, 0, false); + sc->cadddr_symbol = defun("cadddr", cadddr, 1, 0, false); + sc->cadadr_symbol = defun("cadadr", cadadr, 1, 0, false); + sc->caddar_symbol = defun("caddar", caddar, 1, 0, false); + sc->cdaaar_symbol = defun("cdaaar", cdaaar, 1, 0, false); + sc->cdaadr_symbol = defun("cdaadr", cdaadr, 1, 0, false); + sc->cdadar_symbol = defun("cdadar", cdadar, 1, 0, false); + sc->cddaar_symbol = defun("cddaar", cddaar, 1, 0, false); + sc->cdaddr_symbol = defun("cdaddr", cdaddr, 1, 0, false); + sc->cddddr_symbol = defun("cddddr", cddddr, 1, 0, false); + sc->cddadr_symbol = defun("cddadr", cddadr, 1, 0, false); + sc->cdddar_symbol = defun("cdddar", cdddar, 1, 0, false); + + sc->assq_symbol = defun("assq", assq, 2, 0, false); + sc->assv_symbol = defun("assv", assv, 2, 0, false); + sc->assoc_symbol = semisafe_defun("assoc", assoc, 2, 1, false); + sc->memq_symbol = defun("memq", memq, 2, 0, false); + sc->memv_symbol = defun("memv", memv, 2, 0, false); + sc->member_symbol = semisafe_defun("member", member, 2, 1, false); + + sc->list_symbol = defun("list", list, 0, 0, true); + sc->list_ref_symbol = defun("list-ref", list_ref, 2, 0, true); + sc->list_set_symbol = defun("list-set!", list_set, 3, 0, true); + sc->list_tail_symbol = defun("list-tail", list_tail, 2, 0, false); + sc->make_list_symbol = defun("make-list", make_list, 1, 1, false); + + sc->length_symbol = defun("length", length, 1, 0, false); + sc->copy_symbol = defun("copy", copy, 1, 3, false); /* set_is_definer(sc->copy_symbol); */ /* (copy (inlet 'a 1) (curlet)), but this check needs to be smarter */ - sc->fill_symbol = defun("fill!", fill, 2, 2, false); - sc->reverse_symbol = defun("reverse", reverse, 1, 0, false); - sc->reverseb_symbol = defun("reverse!", reverse_in_place, 1, 0, false); - sc->sort_symbol = unsafe_defun("sort!", sort, 2, 0, false); /* not semisafe! */ - sc->append_symbol = defun("append", append, 0, 0, true); + sc->fill_symbol = defun("fill!", fill, 2, 2, false); + sc->reverse_symbol = defun("reverse", reverse, 1, 0, false); + sc->reverseb_symbol = defun("reverse!", reverse_in_place, 1, 0, false); + sc->sort_symbol = unsafe_defun("sort!", sort, 2, 0, false); /* not semisafe! */ + sc->append_symbol = defun("append", append, 0, 0, true); #if (!WITH_PURE_S7) - sc->vector_append_symbol = defun("vector-append", vector_append, 0, 0, true); - sc->list_to_vector_symbol = defun("list->vector", list_to_vector, 1, 0, false); - sc->vector_fill_symbol = defun("vector-fill!", vector_fill, 2, 2, false); - sc->vector_length_symbol = defun("vector-length", vector_length, 1, 0, false); - sc->vector_to_list_symbol = defun("vector->list", vector_to_list, 1, 2, false); + sc->vector_append_symbol = defun("vector-append", vector_append, 0, 0, true); + sc->list_to_vector_symbol = defun("list->vector", list_to_vector, 1, 0, false); + sc->vector_fill_symbol = defun("vector-fill!", vector_fill, 2, 2, false); + sc->vector_length_symbol = defun("vector-length", vector_length, 1, 0, false); + sc->vector_to_list_symbol = defun("vector->list", vector_to_list, 1, 2, false); #else sc->vector_append_symbol = sc->append_symbol; sc->vector_fill_symbol = sc->fill_symbol; sc->string_fill_symbol = sc->fill_symbol; #endif - sc->vector_ref_symbol = defun("vector-ref", vector_ref, 2, 0, true); - sc->vector_set_symbol = defun("vector-set!", vector_set, 3, 0, true); - sc->vector_dimension_symbol = defun("vector-dimension", vector_dimension, 2, 0, false); - sc->vector_dimensions_symbol = defun("vector-dimensions", vector_dimensions, 1, 0, false); - sc->vector_rank_symbol = defun("vector-rank", vector_rank, 1, 0, false); - sc->make_vector_symbol = defun("make-vector", make_vector, 1, 2, false); - sc->vector_symbol = defun("vector", vector, 0, 0, true); + sc->vector_ref_symbol = defun("vector-ref", vector_ref, 2, 0, true); + sc->vector_set_symbol = defun("vector-set!", vector_set, 3, 0, true); + sc->vector_dimension_symbol = defun("vector-dimension", vector_dimension, 2, 0, false); + sc->vector_dimensions_symbol = defun("vector-dimensions", vector_dimensions, 1, 0, false); + sc->vector_rank_symbol = defun("vector-rank", vector_rank, 1, 0, false); + sc->make_vector_symbol = defun("make-vector", make_vector, 1, 2, false); + sc->vector_symbol = defun("vector", vector, 0, 0, true); set_is_setter(sc->vector_symbol); /* like cons, I guess */ - sc->vector_typer_symbol = defun("vector-typer", vector_typer, 1, 0, false); + sc->vector_typer_symbol = defun("vector-typer", vector_typer, 1, 0, false); - sc->subvector_symbol = defun("subvector", subvector, 1, 3, false); + sc->subvector_symbol = defun("subvector", subvector, 1, 3, false); sc->subvector_position_symbol = defun("subvector-position", subvector_position, 1, 0, false); sc->subvector_vector_symbol = defun("subvector-vector", subvector_vector, 1, 0, false); - sc->float_vector_symbol = defun("float-vector", float_vector, 0, 0, true); - sc->make_float_vector_symbol = defun("make-float-vector", make_float_vector, 1, 1, false); - sc->float_vector_set_symbol = defun("float-vector-set!", float_vector_set, 3, 0, true); - sc->float_vector_ref_symbol = defun("float-vector-ref", float_vector_ref, 2, 0, true); + sc->float_vector_symbol = defun("float-vector", float_vector, 0, 0, true); + sc->make_float_vector_symbol = defun("make-float-vector", make_float_vector, 1, 1, false); + sc->float_vector_set_symbol = defun("float-vector-set!", float_vector_set, 3, 0, true); + sc->float_vector_ref_symbol = defun("float-vector-ref", float_vector_ref, 2, 0, true); - sc->int_vector_symbol = defun("int-vector", int_vector, 0, 0, true); - sc->make_int_vector_symbol = defun("make-int-vector", make_int_vector, 1, 1, false); - sc->int_vector_set_symbol = defun("int-vector-set!", int_vector_set, 3, 0, true); - sc->int_vector_ref_symbol = defun("int-vector-ref", int_vector_ref, 2, 0, true); + sc->int_vector_symbol = defun("int-vector", int_vector, 0, 0, true); + sc->make_int_vector_symbol = defun("make-int-vector", make_int_vector, 1, 1, false); + sc->int_vector_set_symbol = defun("int-vector-set!", int_vector_set, 3, 0, true); + sc->int_vector_ref_symbol = defun("int-vector-ref", int_vector_ref, 2, 0, true); - sc->byte_vector_symbol = defun("byte-vector", byte_vector, 0, 0, true); - sc->make_byte_vector_symbol = defun("make-byte-vector", make_byte_vector, 1, 1, false); - sc->byte_vector_ref_symbol = defun("byte-vector-ref", byte_vector_ref, 2, 0, true); - sc->byte_vector_set_symbol = defun("byte-vector-set!", byte_vector_set, 3, 0, true); + sc->byte_vector_symbol = defun("byte-vector", byte_vector, 0, 0, true); + sc->make_byte_vector_symbol = defun("make-byte-vector", make_byte_vector, 1, 1, false); + sc->byte_vector_ref_symbol = defun("byte-vector-ref", byte_vector_ref, 2, 0, true); + sc->byte_vector_set_symbol = defun("byte-vector-set!", byte_vector_set, 3, 0, true); sc->string_to_byte_vector_symbol = defun("string->byte-vector", string_to_byte_vector, 1, 0, false); sc->byte_vector_to_string_symbol = defun("byte-vector->string", byte_vector_to_string, 1, 0, false); - sc->hash_table_symbol = defun("hash-table", hash_table, 0, 0, true); - sc->make_hash_table_symbol = defun("make-hash-table", make_hash_table, 0, 3, false); + sc->hash_table_symbol = defun("hash-table", hash_table, 0, 0, true); + sc->make_hash_table_symbol = defun("make-hash-table", make_hash_table, 0, 3, false); sc->make_weak_hash_table_symbol = defun("make-weak-hash-table", make_weak_hash_table,0, 3, false); sc->weak_hash_table_symbol = defun("weak-hash-table", weak_hash_table, 0, 0, true); - sc->hash_table_ref_symbol = defun("hash-table-ref", hash_table_ref, 2, 0, true); - sc->hash_table_set_symbol = defun("hash-table-set!", hash_table_set, 3, 0, false); - sc->hash_table_entries_symbol = defun("hash-table-entries", hash_table_entries, 1, 0, false); + sc->hash_table_ref_symbol = defun("hash-table-ref", hash_table_ref, 2, 0, true); + sc->hash_table_set_symbol = defun("hash-table-set!", hash_table_set, 3, 0, false); + sc->hash_table_entries_symbol = defun("hash-table-entries", hash_table_entries, 1, 0, false); sc->hash_code_symbol = defun("hash-code", hash_code, 1, 1, false); sc->dummy_equal_hash_table = make_dummy_hash_table(sc); sc->hash_table_key_typer_symbol = defun("hash-table-key-typer", hash_table_key_typer, 1, 0, false); sc->hash_table_value_typer_symbol = defun("hash-table-value-typer", hash_table_value_typer, 1, 0, false); - sc->cyclic_sequences_symbol = defun("cyclic-sequences", cyclic_sequences, 1, 0, false); - sc->call_cc_symbol = semisafe_defun("call/cc", call_cc, 1, 0, false); + sc->cyclic_sequences_symbol = defun("cyclic-sequences", cyclic_sequences, 1, 0, false); + sc->call_cc_symbol = semisafe_defun("call/cc", call_cc, 1, 0, false); sc->call_with_current_continuation_symbol = semisafe_defun("call-with-current-continuation", call_cc, 1, 0, false); sc->call_with_exit_symbol = semisafe_defun("call-with-exit", call_with_exit, 1, 0, false); - sc->load_symbol = semisafe_defun("load", load, 1, 1, false); - sc->autoload_symbol = defun("autoload", autoload, 2, 0, false); - sc->eval_symbol = semisafe_defun("eval", eval, 1, 1, false); + sc->load_symbol = semisafe_defun("load", load, 1, 1, false); + sc->autoload_symbol = defun("autoload", autoload, 2, 0, false); + sc->eval_symbol = semisafe_defun("eval", eval, 1, 1, false); set_func_is_definer(sc->eval_symbol); - sc->eval_string_symbol = semisafe_defun("eval-string", eval_string, 1, 1, false); + sc->eval_string_symbol = semisafe_defun("eval-string", eval_string, 1, 1, false); set_func_is_definer(sc->eval_string_symbol); - sc->apply_symbol = unsafe_defun("apply", apply, 1, 0, true); /* not semisafe */ + sc->apply_symbol = unsafe_defun("apply", apply, 1, 0, true); /* not semisafe */ set_func_is_definer(sc->apply_symbol); /* yow... (apply (inlet) (f)) in do body where (f) returns '(define...) -- see s7test.scm under apply * perhaps better: if closure returns a definer in some way set its name as a definer? even this is not fool-proof */ - sc->for_each_symbol = semisafe_defun("for-each", for_each, 2, 0, true); - sc->map_symbol = semisafe_defun("map", map, 2, 0, true); + sc->for_each_symbol = semisafe_defun("for-each", for_each, 2, 0, true); + sc->map_symbol = semisafe_defun("map", map, 2, 0, true); sc->dynamic_wind_symbol = semisafe_defun("dynamic-wind", dynamic_wind, 3, 0, false); sc->dynamic_unwind_symbol = semisafe_defun("dynamic-unwind", dynamic_unwind, 2, 0, false); - sc->catch_symbol = semisafe_defun("catch", catch, 3, 0, false); - sc->throw_symbol = unsafe_defun("throw", throw, 1, 0, true); - sc->error_symbol = unsafe_defun("error", error, 1, 0, true); /* was 0,0 -- 1-Aug-22 */ + sc->catch_symbol = semisafe_defun("catch", catch, 3, 0, false); + sc->throw_symbol = unsafe_defun("throw", throw, 1, 0, true); + sc->error_symbol = unsafe_defun("error", error, 1, 0, true); /* was 0,0 -- 1-Aug-22 */ /* unsafe example: catch if macro as error handler, (define-macro (m . args) `(apply ,(car args) ',(cadr args))) (catch #t (lambda () (error abs -1)) m) */ - sc->stacktrace_symbol = defun("stacktrace", stacktrace, 0, 5, false); + sc->stacktrace_symbol = defun("stacktrace", stacktrace, 0, 5, false); - /* sc->values_symbol = */ unsafe_defun("values", values, 0, 0, true); /* values_symbol set above for signatures, not semisafe! */ + /* sc->values_symbol = */ unsafe_defun("values", values, 0, 0, true); /* values_symbol set above for signatures, not semisafe! */ /* set_immutable(c_function_setter(global_value(sc->values_symbol))); */ /* not needed, I think */ /* quasiquote helper funcs */ @@ -97117,7 +97117,7 @@ static void init_rootlet(s7_scheme *sc) #else sc->unquote_symbol = make_symbol(sc, "unquote", 7); #endif - sc->qq_append_symbol = defun("<list*>", qq_append, 2, 0, false); /* occurs via quasiquote only as #_<list*> */ + sc->qq_append_symbol = defun("<list*>", qq_append, 2, 0, false); /* occurs via quasiquote only as #_<list*> */ #if (!DISABLE_DEPRECATED) defun("[list*]", qq_append, 2, 0, false); #endif @@ -97125,29 +97125,29 @@ static void init_rootlet(s7_scheme *sc) sc->list_values_symbol = defun("list-values", list_values, 0, 0, true); sc->documentation_symbol = defun("documentation", documentation, 1, 0, false); - sc->signature_symbol = defun("signature", signature, 1, 0, false); - sc->help_symbol = defun("help", help, 1, 0, false); - sc->procedure_source_symbol = defun("procedure-source", procedure_source, 1, 0, false); - sc->funclet_symbol = defun("funclet", funclet, 1, 0, false); - sc->_function__symbol = defun("*function*", function, 0, 2, false); + sc->signature_symbol = defun("signature", signature, 1, 0, false); + sc->help_symbol = defun("help", help, 1, 0, false); + sc->procedure_source_symbol = defun("procedure-source", procedure_source, 1, 0, false); + sc->funclet_symbol = defun("funclet", funclet, 1, 0, false); + sc->_function__symbol = defun("*function*", function, 0, 2, false); sc->dilambda_symbol = defun("dilambda", dilambda, 2, 0, false); { s7_pointer get_func; get_func = s7_typed_dilambda(sc, "setter", g_setter, 1, 1, g_set_setter, 2, 1, H_setter, Q_setter, NULL); set_immutable(c_function_setter(get_func)); } - sc->arity_symbol = defun("arity", arity, 1, 0, false); - sc->is_aritable_symbol = defun("aritable?", is_aritable, 2, 0, false); + sc->arity_symbol = defun("arity", arity, 1, 0, false); + sc->is_aritable_symbol = defun("aritable?", is_aritable, 2, 0, false); - sc->is_eq_symbol = defun("eq?", is_eq, 2, 0, false); - sc->is_eqv_symbol = defun("eqv?", is_eqv, 2, 0, false); - sc->is_equal_symbol = defun("equal?", is_equal, 2, 0, false); - sc->is_equivalent_symbol = defun("equivalent?", is_equivalent, 2, 0, false); - sc->type_of_symbol = defun("type-of", type_of, 1, 0, false); + sc->is_eq_symbol = defun("eq?", is_eq, 2, 0, false); + sc->is_eqv_symbol = defun("eqv?", is_eqv, 2, 0, false); + sc->is_equal_symbol = defun("equal?", is_equal, 2, 0, false); + sc->is_equivalent_symbol = defun("equivalent?", is_equivalent, 2, 0, false); + sc->type_of_symbol = defun("type-of", type_of, 1, 0, false); - sc->gc_symbol = semisafe_defun("gc", gc, 0, 1, false); - defun("emergency-exit", emergency_exit, 0, 1, false); - sc->exit_symbol = defun("exit", exit, 0, 1, false); + sc->gc_symbol = semisafe_defun("gc", gc, 0, 1, false); + defun("emergency-exit", emergency_exit, 0, 1, false); + sc->exit_symbol = defun("exit", exit, 0, 1, false); #if WITH_GCC s7_define_function(sc, "abort", g_abort, 0, 0, false, "drop into gdb I hope"); @@ -97207,7 +97207,7 @@ static void init_rootlet(s7_scheme *sc) /* -------- *load-path* -------- */ sc->load_path_symbol = s7_define_variable_with_documentation(sc, "*load-path*", sc->nil, /* list_1(sc, make_string_with_length(sc, ".", 1)), */ /* not plist! */ - "*load-path* is a list of directories (strings) that the load function searches if it is passed an incomplete file name"); + "*load-path* is a list of directories (strings) that the load function searches if it is passed an incomplete file name"); s7_set_setter(sc, sc->load_path_symbol, s7_make_safe_function(sc, "#<set-*load-path*>", g_load_path_set, 2, 0, false, "*load-path* setter")); #ifdef CLOAD_DIR @@ -97217,7 +97217,7 @@ static void init_rootlet(s7_scheme *sc) sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", nil_string); #endif s7_set_setter(sc, sc->cload_directory_symbol, - s7_make_safe_function(sc, "#<set-*cload-directory*>", g_cload_directory_set, 2, 0, false, "*cload-directory* setter")); + s7_make_safe_function(sc, "#<set-*cload-directory*>", g_cload_directory_set, 2, 0, false, "*cload-directory* setter")); /* -------- *autoload* -------- this pretends to be a hash-table or environment, but it's actually a function */ sc->autoloader_symbol = s7_define_typed_function(sc, "*autoload*", g_autoloader, 1, 0, false, H_autoloader, Q_autoloader); @@ -97458,19 +97458,19 @@ s7_scheme *s7_init(void) add_saved_pointer(sc, (void *)cells); for (i = 0; i < INITIAL_HEAP_SIZE; i++) /* LOOP_4 here is slower! */ { - sc->heap[i] = &cells[i]; - sc->free_heap[i] = sc->heap[i]; + sc->heap[i] = &cells[i]; + sc->free_heap[i] = sc->heap[i]; #if S7_DEBUGGING - sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL; + sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL; #endif - clear_type(sc->heap[i]); /* type(sc->heap[i]) = T_FREE */ - i++; - sc->heap[i] = &cells[i]; - sc->free_heap[i] = sc->heap[i]; + clear_type(sc->heap[i]); /* type(sc->heap[i]) = T_FREE */ + i++; + sc->heap[i] = &cells[i]; + sc->free_heap[i] = sc->heap[i]; #if S7_DEBUGGING - sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL; + sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL; #endif - clear_type(sc->heap[i]); + clear_type(sc->heap[i]); } /* memcpy((void *)(sc->free_heap), (const void *)(sc->heap), sizeof(s7_pointer) * INITIAL_HEAP_SIZE); */ /* weird that this memcpy (without the equivalent sets above) is much slower */ @@ -97542,9 +97542,9 @@ s7_scheme *s7_init(void) add_saved_pointer(sc, os); for (i = 0; i < OPTS_SIZE; i++) { - opt_info *o = &os[i]; - sc->opts[i] = o; - o->sc = sc; + opt_info *o = &os[i]; + sc->opts[i] = o; + o->sc = sc; }} for (i = 0; i < NUM_TYPES; i++) @@ -97736,7 +97736,7 @@ s7_scheme *s7_init(void) ((funclet hook) 'body)) \n\ (lambda (hook lst) \n\ (when (or (not (procedure? hook)) (continuation? hook) (goto? hook)) \n\ - (error 'wrong-type-arg \"hook-functions hook must be a procedure created by make-hook: ~S\" hook)) \n\ + (error 'wrong-type-arg \"hook-functions hook must be a procedure created by make-hook: ~S\" hook)) \n\ (if (do ((p lst (cdr p))) \n\ ((not (and (pair? p) \n\ (procedure? (car p)) \n\ @@ -97748,37 +97748,37 @@ s7_scheme *s7_init(void) /* -------- *unbound-variable-hook* -------- */ sc->unbound_variable_hook = s7_eval_c_string(sc, "(make-hook 'variable)"); s7_define_constant_with_documentation(sc, "*unbound-variable-hook*", sc->unbound_variable_hook, - "*unbound-variable-hook* functions are called when an unbound variable is encountered, passed (hook 'variable)."); + "*unbound-variable-hook* functions are called when an unbound variable is encountered, passed (hook 'variable)."); /* -------- *missing-close-paren-hook* -------- */ sc->missing_close_paren_hook = s7_eval_c_string(sc, "(make-hook)"); s7_define_constant_with_documentation(sc, "*missing-close-paren-hook*", sc->missing_close_paren_hook, - "*missing-close-paren-hook* functions are called when the reader thinks a close paren is missing"); + "*missing-close-paren-hook* functions are called when the reader thinks a close paren is missing"); /* -------- *load-hook* -------- */ sc->load_hook = s7_eval_c_string(sc, "(make-hook 'name)"); s7_define_constant_with_documentation(sc, "*load-hook*", sc->load_hook, - "*load-hook* functions are invoked by load, passing the to-be-loaded filename as (hook 'name)"); + "*load-hook* functions are invoked by load, passing the to-be-loaded filename as (hook 'name)"); /* -------- *autoload-hook* -------- */ sc->autoload_hook = s7_eval_c_string(sc, "(make-hook 'name 'file)"); s7_define_constant_with_documentation(sc, "*autoload-hook*", sc->autoload_hook, - "*autoload-hook* functions are invoked by autoload, passing the to-be-autoloaded filename as (hook 'name) and (hook 'file))"); + "*autoload-hook* functions are invoked by autoload, passing the to-be-autoloaded filename as (hook 'name) and (hook 'file))"); /* -------- *error-hook* -------- */ sc->error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); s7_define_constant_with_documentation(sc, "*error-hook*", sc->error_hook, - "*error-hook* functions are called in the error handler, passed (hook 'type) and (hook 'data)."); + "*error-hook* functions are called in the error handler, passed (hook 'type) and (hook 'data)."); /* -------- *read-error-hook* -------- */ sc->read_error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); s7_define_constant_with_documentation(sc, "*read-error-hook*", sc->read_error_hook, - "*read-error-hook* functions are called by the reader if it is unhappy, passing the current program string as (hook 'data)."); + "*read-error-hook* functions are called by the reader if it is unhappy, passing the current program string as (hook 'data)."); /* -------- *rootlet-redefinition-hook* -------- */ sc->rootlet_redefinition_hook = s7_eval_c_string(sc, "(make-hook 'name 'value)"); s7_define_constant_with_documentation(sc, "*rootlet-redefinition-hook*", sc->rootlet_redefinition_hook, - "*rootlet-redefinition-hook* functions are called when a top-level variable's value is changed, (hook 'name 'value)."); + "*rootlet-redefinition-hook* functions are called when a top-level variable's value is changed, (hook 'name 'value)."); sc->let_temp_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); @@ -97791,7 +97791,7 @@ s7_scheme *s7_init(void) (lambda (clause) \n\ (if (not (pair? clause)) \n\ (error 'syntax-error \"reader-cond: clause is not a pair, ~S\" clause)) \n\ - (let ((val (eval (car clause)))) \n\ + (let ((val (eval (car clause)))) \n\ (when val \n\ (return \n\ (cond ((null? (cdr clause)) val) \n\ @@ -97823,17 +97823,17 @@ s7_scheme *s7_init(void) (if (null? clauses) \n\ (error 'syntax-error \"cond-expand: no clauses?\")) \n\ (letrec ((traverse (lambda (tree) \n\ - (if (pair? tree) \n\ - (cons (traverse (car tree)) \n\ - (case (cdr tree) ((())) (else => traverse))) \n\ - (if (memq tree '(and or not else)) tree \n\ - (and (symbol? tree) (provided? tree))))))) \n\ + (if (pair? tree) \n\ + (cons (traverse (car tree)) \n\ + (case (cdr tree) ((())) (else => traverse))) \n\ + (if (memq tree '(and or not else)) tree \n\ + (and (symbol? tree) (provided? tree))))))) \n\ (cons 'cond (map (lambda (clause) \n\ - (if (pair? clause) \n\ + (if (pair? clause) \n\ (cons (traverse (car clause)) \n\ - (case (cdr clause) ((()) '(#f)) (else))) \n\ + (case (cdr clause) ((()) '(#f)) (else))) \n\ (error 'syntax-error \"cond-expand: clause is not a pair, ~S\" clause))) \n\ - clauses))))"); + clauses))))"); /* cond-expand should expand into an expansion (or inline macro?) so that if there's no else clause, we can add (else (values)) * r7rs says: "If none of the <feature requirement>s evaluate to #t, then if there is an else clause, its <expression>s are included. * Otherwise, the cond-expand has no effect." The code above returns #<unspecified>, but I read that prose to say that @@ -97911,18 +97911,18 @@ void s7_free(s7_scheme *sc) for (i = 0; i < gp->loc; i++) { if ((unchecked_port_data_block(gp->list[i])) && - (block_index(unchecked_port_data_block(gp->list[i])) == TOP_BLOCK_LIST)) - free(block_data(unchecked_port_data_block(gp->list[i]))); /* the file contents, port_block is other stuff */ + (block_index(unchecked_port_data_block(gp->list[i])) == TOP_BLOCK_LIST)) + free(block_data(unchecked_port_data_block(gp->list[i]))); /* the file contents, port_block is other stuff */ if ((is_file_port(gp->list[i])) && - (!port_is_closed(gp->list[i]))) - fclose(port_file(gp->list[i])); + (!port_is_closed(gp->list[i]))) + fclose(port_file(gp->list[i])); } gc_list_free(gp); gp = sc->input_ports; for (i = 0; i < gp->loc; i++) if ((unchecked_port_data_block(gp->list[i])) && - (block_index(unchecked_port_data_block(gp->list[i])) == TOP_BLOCK_LIST)) + (block_index(unchecked_port_data_block(gp->list[i])) == TOP_BLOCK_LIST)) free(block_data(unchecked_port_data_block(gp->list[i]))); /* the file contents, port_block is other stuff */ gc_list_free(gp); gc_list_free(sc->input_string_ports); /* port_data_block is null, port_block is the const char* data, so I assume it is handled elsewhere */ @@ -97993,7 +97993,7 @@ void s7_free(s7_scheme *sc) if (sc->autoloaded_already) { for (i = 0; i < sc->autoload_names_loc; i++) - if (sc->autoloaded_already[i]) free(sc->autoloaded_already[i]); + if (sc->autoloaded_already[i]) free(sc->autoloaded_already[i]); free(sc->autoloaded_already); } for (block_t *top = sc->block_lists[TOP_BLOCK_LIST]; top; top = block_next(top)) @@ -98034,9 +98034,9 @@ void s7_free(s7_scheme *sc) for (i = 0; i < sc->num_fdats; i++) if (sc->fdats[i]) /* init val is NULL */ { - if (sc->fdats[i]->curly_str) - free(sc->fdats[i]->curly_str); - free(sc->fdats[i]); + if (sc->fdats[i]->curly_str) + free(sc->fdats[i]->curly_str); + free(sc->fdats[i]); } free(sc->fdats); @@ -98053,11 +98053,11 @@ void s7_free(s7_scheme *sc) if (sc->c_object_types) { for (i = 0; i < sc->num_c_object_types; i++) - { - c_object_t *c_type = sc->c_object_types[i]; - if (c_type->scheme_name) {free(c_type->scheme_name); c_type->scheme_name = NULL;} - free(c_type); - } + { + c_object_t *c_type = sc->c_object_types[i]; + if (c_type->scheme_name) {free(c_type->scheme_name); c_type->scheme_name = NULL;} + free(c_type); + } free(sc->c_object_types); } free(sc); @@ -98085,11 +98085,11 @@ static void dumb_repl(s7_scheme *sc) 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); - }} + { + 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"); @@ -98178,10 +98178,10 @@ int main(int argc, char **argv) { fprintf(stderr, "load %s\n", argv[1]); if (!s7_load(sc, argv[1])) - { - fprintf(stderr, "can't load %s\n", argv[1]); - return(2); - }} + { + fprintf(stderr, "can't load %s\n", argv[1]); + return(2); + }} else { #if (MS_WINDOWS) || (!WITH_C_LOADER) || ((defined(__linux__)) && (!defined(__GLIBC__))) /* musl? */ @@ -98192,10 +98192,10 @@ int main(int argc, char **argv) #else char *dir = realdir(argv[0]); if (dir) - { - s7_add_to_load_path(sc, dir); - free(dir); - } + { + s7_add_to_load_path(sc, dir); + free(dir); + } #endif s7_repl(sc); #endif |