summaryrefslogtreecommitdiff
path: root/sources
diff options
context:
space:
mode:
authorHenrique Alves <henrique.alves@itsjungle.xyz>2024-04-24 02:44:33 +0300
committerHenrique Alves <henrique.alves@itsjungle.xyz>2024-04-24 02:44:33 +0300
commit150738de9fb42159f6b60bc5cf817d99e6718988 (patch)
tree78202018253cd3771784872898688a675ce52dcb /sources
parent1d579be7f2469afdc2074af29d96dece70a62daa (diff)
downloadgamejam-slgj-2024-150738de9fb42159f6b60bc5cf817d99e6718988.tar.gz
gamejam-slgj-2024-150738de9fb42159f6b60bc5cf817d99e6718988.tar.bz2
gamejam-slgj-2024-150738de9fb42159f6b60bc5cf817d99e6718988.zip
Successful test with s7!
Diffstat (limited to 'sources')
-rw-r--r--sources/main.c36
-rw-r--r--sources/s7.c98288
-rw-r--r--sources/s7.h1245
-rw-r--r--sources/text.h32
4 files changed, 99576 insertions, 25 deletions
diff --git a/sources/main.c b/sources/main.c
index d914ed2..3ee655a 100644
--- a/sources/main.c
+++ b/sources/main.c
@@ -1,14 +1,16 @@
#include "raylib.h"
#include "text.h"
+#include "s7.h"
-#include <libguile.h>
#include <math.h>
#include <stdio.h>
-#include <stdlib.h>
+#include <stdlib.h>
-static void* game (void* data)
-{
- rl_text_define_methods();
+
+int main(int argc, char* argv[]) {
+ s7_scheme *s7 = s7_init();
+
+ rl_text_define_methods(s7);
const int screen_width = 800;
const int screen_height = 600;
@@ -17,30 +19,24 @@ static void* game (void* data)
SetTargetFPS(60);
char filename[] = SCRIPTS_PATH"main.scm";
+ s7_load(s7, filename);
- scm_c_primitive_load(filename);
-
- SCM guile_draw = scm_variable_ref(scm_c_lookup("draw"));
-
+ s7_pointer s7_update_fn = s7_name_to_value(s7, "update");
+ s7_pointer s7_draw_fn = s7_name_to_value(s7, "draw");
+
while (!WindowShouldClose())
- {
+ {
+ s7_call(s7, s7_update_fn, s7_list(s7, 0));
+
BeginDrawing();
ClearBackground(RAYWHITE);
- DrawText("a", 200, 80, 20, RED); // <- this line works
-
- //scm_call_0(guile_draw); // <- this will crash the game
-
+ s7_call(s7, s7_draw_fn, s7_list(s7, 0));
EndDrawing();
+ s7_eval_c_string(s7, "(display 'noice')");
}
CloseWindow();
- return NULL;
-}
-
-
-int main(int argc, char* argv[]) {
- scm_with_guile (&game, NULL);
return 0;
}
diff --git a/sources/s7.c b/sources/s7.c
new file mode 100644
index 0000000..a13d857
--- /dev/null
+++ b/sources/s7.c
@@ -0,0 +1,98288 @@
+/* s7, a Scheme interpreter
+ *
+ * derived from TinyScheme 1.39, but not a single byte of that code remains
+ * SPDX-License-Identifier: 0BSD
+ *
+ * Bill Schottstaedt, bil@ccrma.stanford.edu
+ *
+ * Mike Scholz provided the FreeBSD support (complex trig funcs, etc)
+ * Rick Taube, Andrew Burnson, Donny Ward, Greg Santucci, and Christos Vagias provided the MS Visual C++ support
+ * Kjetil Matheussen provided the mingw support
+ *
+ * Documentation is in s7.h and s7.html.
+ * s7test.scm is a regression test.
+ * repl.scm is a vt100-based listener.
+ * nrepl.scm is a notcurses-based listener.
+ * cload.scm and lib*.scm tie in various C libraries.
+ * lint.scm checks Scheme code for infelicities.
+ * r7rs.scm implements some of r7rs (small).
+ * write.scm currrently has pretty-print.
+ * mockery.scm has the mock-data definitions.
+ * reactive.scm has reactive-set and friends.
+ * stuff.scm has some stuff.
+ * profile.scm has code to display profile data.
+ * debug.scm has debugging aids.
+ * case.scm has case*, an extension of case to pattern matching.
+ * timing tests are in the s7 tools directory
+ *
+ * s7.c is organized as follows:
+ * structs and type flags
+ * internal debugging stuff
+ * constants
+ * GC
+ * stacks
+ * symbols and keywords
+ * lets
+ * continuations
+ * numbers
+ * characters
+ * strings
+ * ports
+ * format
+ * lists
+ * vectors
+ * hash-tables
+ * c-objects
+ * functions
+ * equal?
+ * generic length, copy, reverse, fill!, append
+ * error handlers
+ * sundry leftovers
+ * the optimizers
+ * multiple-values, quasiquote
+ * eval
+ * *s7*
+ * initialization and free
+ * repl
+ *
+ * naming conventions: s7_* usually are C accessible (s7.h), g_* are scheme accessible,
+ * H_* are documentation strings, Q_* are procedure signatures, scheme "?" corresponds to C "is_", scheme "->" to C "_to_",
+ * *_1 are ancillary functions, big_* refer to gmp, *_nr means no return, inline_* means always-inline.
+ *
+ * ---------------- compile time switches ----------------
+ */
+
+#if defined __has_include
+# if __has_include ("mus-config.h")
+# include "mus-config.h"
+# endif
+#else
+ #include "mus-config.h"
+#endif
+
+/*
+ * Your config file goes here, or just replace that #include line with the defines you need.
+ * The compile-time switches involve booleans, complex numbers, and multiprecision arithmetic.
+ * Currently we assume we have setjmp.h (used by the error handlers).
+ *
+ * Complex number support, which is problematic in C++, Solaris, and netBSD
+ * is on the HAVE_COMPLEX_NUMBERS switch. In OSX or Linux, if you're not using C++,
+ *
+ * #define HAVE_COMPLEX_NUMBERS 1
+ * #define HAVE_COMPLEX_TRIG 1
+ *
+ * In C++ I use:
+ *
+ * #define HAVE_COMPLEX_NUMBERS 1
+ * #define HAVE_COMPLEX_TRIG 0
+ *
+ * In Windows and tcc, both are 0.
+ *
+ * Some systems (FreeBSD) have complex.h, but some random subset of the trig funcs, so
+ * HAVE_COMPLEX_NUMBERS means we can find
+ * cimag creal cabs csqrt carg conj
+ * and HAVE_COMPLEX_TRIG means we have
+ * cacos cacosh casin casinh catan catanh ccos ccosh cexp clog cpow csin csinh ctan ctanh
+ *
+ * When HAVE_COMPLEX_NUMBERS is 0, the complex functions are stubs that simply return their
+ * argument -- this will be very confusing for the s7 user because, for example, (sqrt -2)
+ * will return something bogus (it might not signal an error).
+ *
+ * so the incoming (non-s7-specific) compile-time switches are
+ * HAVE_COMPLEX_NUMBERS, HAVE_COMPLEX_TRIG, SIZEOF_VOID_P
+ * if SIZEOF_VOID_P is not defined, we look for __SIZEOF_POINTER__ instead,
+ * the default is to assume that we're running on a 64-bit machine.
+ *
+ * To get multiprecision arithmetic, set WITH_GMP to 1.
+ * You'll also need libgmp, libmpfr, and libmpc (version 0.8.0 or later)
+ *
+ * and we use these predefined macros: __cplusplus, _MSC_VER, __GNUC__, __clang__, __ANDROID__
+ *
+ * if WITH_SYSTEM_EXTRAS is 1 (default is 1 unless _MSC_VER), various OS and file related functions are included.
+ * if you want this file to compile into a stand-alone interpreter, define WITH_MAIN,
+ * to use nrepl also define WITH_NOTCURSES
+ *
+ * -O3 is often slower than -O2 (at least according to callgrind)
+ * -march=native seems to improve tree-vectorization which is important in Snd
+ * -ffast-math makes a mess of NaNs, and does not appear to be faster
+ * -fno-math-errno -fno-signed-zeros appear to be slightly faster, and I don't see any errors
+ * I also tried -fno-signaling-nans -fno-trapping-math -fassociative-math, but at least one of them is much slower
+ * this code doesn't compile anymore in gcc 4.3
+ */
+
+#if (defined(__GNUC__) || defined(__clang__) || defined(__TINYC__)) /* s7 uses PRId64 so (for example) g++ 4.4 is too old */
+ #define WITH_GCC 1
+#else
+ #define WITH_GCC 0
+#endif
+
+
+/* ---------------- initial sizes ---------------- */
+
+#ifndef INITIAL_HEAP_SIZE
+ #define INITIAL_HEAP_SIZE 64000 /* 29-Jul-21 -- seems faster */
+#endif
+/* the heap grows as needed, this is its initial size. If the initial heap is small, s7 can run in about 2.5 Mbytes of memory.
+ * There are many cases where a bigger heap is faster (but harware cache size probably matters more).
+ * The heap size must be a multiple of 32. Each object takes 48 bytes.
+ */
+
+#ifndef SYMBOL_TABLE_SIZE
+ #define SYMBOL_TABLE_SIZE 32749
+#endif
+/* names are hashed into the symbol table (a vector) and collisions are chained as lists */
+/* 16381: thash +80 [string_to_symbol_p_p] +40 if 24001, tlet +80 [symbol_p_p], +32 24001 */
+
+#ifndef INITIAL_STACK_SIZE
+ #define INITIAL_STACK_SIZE 4096 /* was 2048 17-Mar-21 */
+#endif
+/* the stack grows as needed, each frame takes 4 entries, this is its initial size. (*s7* 'stack-top) divides size by 4 */
+
+#define STACK_RESIZE_TRIGGER (INITIAL_STACK_SIZE / 2)
+
+#ifndef INITIAL_PROTECTED_OBJECTS_SIZE
+ #define INITIAL_PROTECTED_OBJECTS_SIZE 16
+#endif
+/* a vector of objects that are (semi-permanently) protected from the GC, grows as needed */
+
+#ifndef GC_TEMPS_SIZE
+ #define GC_TEMPS_SIZE 256
+#endif
+/* the number of recent objects that are temporarily gc-protected; 8 works for s7test and snd-test.
+ * For the FFI, this sets the lag between a call on s7_cons and the first moment when its result
+ * might be vulnerable to the GC.
+ */
+
+
+/* ---------------- scheme choices ---------------- */
+
+#ifndef WITH_GMP
+ #define WITH_GMP 0
+ /* this includes multiprecision arithmetic for all numeric types and functions, using gmp, mpfr, and mpc
+ * WITH_GMP adds the following functions: bignum and bignum?, and (*s7* 'bignum-precision)
+ */
+#endif
+
+#ifndef DEFAULT_BIGNUM_PRECISION
+ #define DEFAULT_BIGNUM_PRECISION 128 /* (*s7* 'bignum-precision) initial value, must be >= 2 */
+#endif
+
+#ifndef WITH_PURE_S7
+ #define WITH_PURE_S7 0
+#endif
+#if WITH_PURE_S7
+ #define WITH_EXTRA_EXPONENT_MARKERS 0
+ #define WITH_IMMUTABLE_UNQUOTE 1
+ /* also omitted: *-ci* functions, char-ready?, cond-expand, multiple-values-bind|set!, call-with-values
+ * and a lot more (inexact/exact, integer-length, etc) -- see s7.html.
+ */
+#endif
+
+#ifndef WITH_EXTRA_EXPONENT_MARKERS
+ #define WITH_EXTRA_EXPONENT_MARKERS 0
+#endif
+/* if 1, s7 recognizes "d", "f", "l", and "s" as exponent markers, in addition to "e" (also "D", "F", "L", "S") */
+
+#ifndef WITH_SYSTEM_EXTRAS
+ #define WITH_SYSTEM_EXTRAS (!_MSC_VER)
+ /* this adds several functions that access file info, directories, times, etc */
+#endif
+
+#ifndef WITH_IMMUTABLE_UNQUOTE
+ #define WITH_IMMUTABLE_UNQUOTE 0 /* this removes the name "unquote" */
+#endif
+
+#ifndef WITH_C_LOADER
+ #if WITH_GCC && (!__MINGW32__) && (!__CYGWIN__)
+ #define WITH_C_LOADER 1
+ /* (load file.so [e]) looks for ([e] 'init_func) and if found, calls it as the shared object init function.
+ * If WITH_SYSTEM_EXTRAS is 0, the caller needs to supply system and delete-file so that cload.scm works.
+ */
+ #else
+ #define WITH_C_LOADER 0
+ /* I think dlopen et al are available in MS C, but I have no way to test them; see load_shared_object below */
+ #endif
+#endif
+
+#ifndef WITH_HISTORY
+ #define WITH_HISTORY 0
+ /* this includes a circular buffer of previous evaluations for debugging, ((owlet) 'error-history) and (*s7* 'history-size) */
+#endif
+
+#ifndef DEFAULT_HISTORY_SIZE
+ #define DEFAULT_HISTORY_SIZE 8
+ /* this is the default length of the eval history buffer */
+#endif
+#if WITH_HISTORY
+ #define MAX_HISTORY_SIZE 1048576
+#endif
+
+#ifndef DEFAULT_PRINT_LENGTH
+ #define DEFAULT_PRINT_LENGTH 12 /* (*s7* 'print-length) initial value, was 32 but Snd uses 12, 23-Jul-21 */
+#endif
+
+#ifndef WITH_NUMBER_SEPARATOR
+ #define WITH_NUMBER_SEPARATOR 0
+#endif
+
+/* in case mus-config.h forgets these */
+#ifdef _MSC_VER
+ #ifndef HAVE_COMPLEX_NUMBERS
+ #define HAVE_COMPLEX_NUMBERS 0
+ #endif
+ #ifndef HAVE_COMPLEX_TRIG
+ #define HAVE_COMPLEX_TRIG 0
+ #endif
+#else
+ #ifndef HAVE_COMPLEX_NUMBERS
+ #if __TINYC__
+ #define HAVE_COMPLEX_NUMBERS 0
+ #else
+ #define HAVE_COMPLEX_NUMBERS 1
+ #endif
+ #endif
+ #if __cplusplus || __TINYC__
+ #ifndef HAVE_COMPLEX_TRIG
+ #define HAVE_COMPLEX_TRIG 0
+ #endif
+ #else
+ #ifndef HAVE_COMPLEX_TRIG
+ #define HAVE_COMPLEX_TRIG 1
+ #endif
+ #endif
+#endif
+
+#ifndef WITH_MULTITHREAD_CHECKS
+ #define WITH_MULTITHREAD_CHECKS 0
+ /* debugging aid if using s7 in a multithreaded program -- this code courtesy of Kjetil Matheussen */
+#endif
+
+#ifndef WITH_WARNINGS
+ #define WITH_WARNINGS 0
+ /* int+int overflows to real, etc: this adds warnings which are expensive even though they are never called (procedure overhead) */
+#endif
+
+#ifndef S7_DEBUGGING
+ #define S7_DEBUGGING 0
+#endif
+
+#undef DEBUGGING
+#define DEBUGGING typo!
+#define HAVE_GMP typo!
+
+#define SHOW_EVAL_OPS 0
+
+#ifndef _GNU_SOURCE
+ #define _GNU_SOURCE /* for qsort_r, grumble... */
+#endif
+
+#ifndef _MSC_VER
+ #include <unistd.h>
+ #include <sys/param.h>
+ #include <strings.h>
+ #include <errno.h>
+ #include <locale.h>
+#else
+ /* in Snd these are in mus-config.h */
+ #ifndef MUS_CONFIG_H_LOADED
+ #if _MSC_VER < 1900
+ #define snprintf _snprintf
+ #endif
+ #if _MSC_VER > 1200
+ #define _CRT_SECURE_NO_DEPRECATE 1
+ #define _CRT_NONSTDC_NO_DEPRECATE 1
+ #define _CRT_SECURE_CPP_OVERLOAD_STANDARD_NAMES 1
+ #endif
+ #endif
+ #include <io.h>
+ #pragma warning(disable: 4244) /* conversion might cause loss of data warning */
+#endif
+
+#if WITH_GCC && (!S7_DEBUGGING)
+ #define Inline inline __attribute__((__always_inline__))
+#else
+ #ifdef _MSC_VER
+ #define Inline __forceinline
+ #else
+ #define Inline inline
+ #endif
+#endif
+
+#ifndef WITH_VECTORIZE
+ #define WITH_VECTORIZE 1
+#endif
+
+#if (WITH_VECTORIZE) && (defined(__GNUC__) && __GNUC__ >= 5) /* is this included -in -O2 now? */
+ #define Vectorized __attribute__((optimize("tree-vectorize")))
+#else
+ #define Vectorized
+#endif
+
+#if WITH_GCC
+ #define Sentinel __attribute__((sentinel))
+#else
+ #define Sentinel
+#endif
+
+#ifdef _MSC_VER
+ #define noreturn _Noreturn /* deprecated in C23 */
+#else
+ #define noreturn __attribute__((noreturn))
+ /* this is ok in gcc/g++/clang and tcc; pure attribute is rarely applicable here, and does not seem to be helpful (maybe safe_strlen) */
+#endif
+
+#ifndef S7_ALIGNED
+ #define S7_ALIGNED 0
+ /* memclr and local_memset */
+#endif
+
+#include <stdio.h>
+#include <limits.h>
+#include <ctype.h>
+#include <string.h>
+#include <stdlib.h>
+#include <sys/types.h>
+#include <time.h>
+#include <stdarg.h>
+#include <stddef.h>
+#include <stdint.h>
+#include <inttypes.h>
+#include <setjmp.h>
+
+#ifdef _MSC_VER
+ #define MS_WINDOWS 1
+#else
+ #define MS_WINDOWS 0
+#endif
+
+#if defined(_MSC_VER) || defined(__MINGW32__)
+ #define Jmp_Buf jmp_buf
+ #define SetJmp(A, B) setjmp(A)
+ #define LongJmp(A, B) longjmp(A, B)
+#else
+ #define Jmp_Buf sigjmp_buf
+ #define SetJmp(A, B) sigsetjmp(A, B)
+ #define LongJmp(A, B) siglongjmp(A, B)
+ /* we need sigsetjmp, not setjmp for nrepl's interrupt (something to do with signal masks??)
+ * unfortunately sigsetjmp is noticeably slower than setjmp, especially when s7_optimize_1 is called a lot.
+ * In one case, the sigsetjmp version runs in 24 seconds, but the setjmp version takes 10 seconds, and
+ * yet callgrind says there is almost no difference? I removed setjmp from s7_optimize.
+ */
+#endif
+
+#if (!MS_WINDOWS)
+ #include <pthread.h>
+#endif
+
+#if __cplusplus
+ #include <cmath>
+#else
+ #include <math.h>
+#endif
+
+/* there is also apparently __STDC_NO_COMPLEX__ */
+#if HAVE_COMPLEX_NUMBERS
+ #if __cplusplus
+ #include <complex>
+ #else
+ #include <complex.h>
+ #if defined(__sun) && defined(__SVR4)
+ #undef _Complex_I
+ #define _Complex_I 1.0i
+ #endif
+ #endif
+
+ #ifndef CMPLX
+ #if (!(defined(__cplusplus))) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 7)) && !defined(__INTEL_COMPILER)
+ #define CMPLX(x, y) __builtin_complex ((double) (x), (double) (y))
+ #else
+ #define CMPLX(r, i) ((r) + ((i) * (s7_complex)_Complex_I))
+ #endif
+ #endif
+#endif
+
+#if (defined(__GNUC__))
+ #define s7_complex_i 1.0i
+#else
+ #define s7_complex_i (s7_complex)_Complex_I /* a float, but we want a double */
+#endif
+
+#include "s7.h"
+
+#ifndef M_PI
+ #define M_PI 3.1415926535897932384626433832795029L
+#endif
+
+#ifndef INFINITY
+ #ifndef HUGE_VAL
+ #define INFINITY (1.0/0.0) /* -log(0.0) is triggering dumb complaints from cppcheck */
+ /* there is sometimes a function, infinity(), MSC apparently uses HUGE_VALF, gcc has __builtin_huge_val() */
+ #else
+ #define INFINITY HUGE_VAL
+ #endif
+#endif
+
+#ifndef NAN
+ #define NAN (INFINITY / INFINITY) /* apparently ieee754 suggests 0.0/0.0 */
+#endif
+
+#if ((!__NetBSD__) && ((_MSC_VER) || (!defined(__STC__)) || (defined(__STDC_VERSION__) && (__STDC_VERSION__ < 199901L))))
+ #define __func__ __FUNCTION__
+#endif
+
+#if (((defined(SIZEOF_VOID_P)) && (SIZEOF_VOID_P == 4)) || ((defined(__SIZEOF_POINTER__)) && (__SIZEOF_POINTER__ == 4)) || (!defined(__LP64__)))
+ #define NUMBER_NAME_SIZE 2 /* pointless */
+ #define POINTER_32 true
+#else
+ #define NUMBER_NAME_SIZE 22 /* leave 1 for uint8_t name len (byte 0), 1 for terminating nul */
+ #define POINTER_32 false
+#endif
+
+#define WRITE_REAL_PRECISION 16
+#ifdef __TINYC__
+ typedef double long_double; /* (- .1 1) -> 0.9! and others similarly: (- double long_double) is broken */
+#else
+ typedef long double long_double;
+#endif
+
+#define ld64 PRId64
+#define p64 PRIdPTR
+
+#define MAX_FLOAT_FORMAT_PRECISION 128
+
+/* types */
+enum {T_FREE = 0,
+ T_PAIR, T_NIL, T_UNUSED, T_UNDEFINED, T_UNSPECIFIED, T_EOF, T_BOOLEAN, T_CHARACTER, T_SYNTAX, T_SYMBOL,
+ T_INTEGER, T_RATIO, T_REAL, T_COMPLEX, T_BIG_INTEGER, T_BIG_RATIO, T_BIG_REAL, T_BIG_COMPLEX,
+ T_STRING, T_C_OBJECT, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR,
+ T_CATCH, T_DYNAMIC_WIND, T_HASH_TABLE, T_LET, T_ITERATOR,
+ T_STACK, T_COUNTER, T_SLOT, T_C_POINTER, T_OUTPUT_PORT, T_INPUT_PORT, T_RANDOM_STATE, T_CONTINUATION, T_GOTO,
+ T_CLOSURE, T_CLOSURE_STAR, T_MACRO, T_MACRO_STAR, T_BACRO, T_BACRO_STAR,
+ T_C_MACRO, T_C_FUNCTION_STAR, T_C_FUNCTION, T_C_RST_NO_REQ_FUNCTION,
+ NUM_TYPES};
+/* T_UNUSED, T_STACK, T_SLOT, T_DYNAMIC_WIND, T_CATCH, and T_COUNTER are internal */
+
+static const char *s7_type_names[] =
+ {"free", "pair", "nil", "unused", "undefined", "unspecified", "eof_object", "boolean", "character", "syntax", "symbol",
+ "integer", "ratio", "real", "complex", "big_integer", "big_ratio", "big_real", "big_complex",
+ "string", "c_object", "vector", "int_vector", "float_vector", "byte_vector",
+ "catch", "dynamic_wind", "hash_table", "let", "iterator",
+ "stack", "counter", "slot", "c_pointer", "output_port", "input_port", "random_state", "continuation", "goto",
+ "closure", "closure*", "macro", "macro*", "bacro", "bacro*",
+ "c_macro", "c_function*", "c_function", "c_rst_no_req_function",
+ };
+
+/* 1:t_pair, 2:t_nil, 3:t_unused, 4:t_undefined, 5:t_unspecified, 6:t_eof, 7:t_boolean, 8:t_character, 9:t_syntax, 10:t_symbol,
+ 11:t_integer, 12:t_ratio, 13:t_real, 14:t_complex, 15:t_big_integer, 16:t_big_ratio, 17:t_big_real, 18:t_big_complex,
+ 19:t_string, 20:t_c_object, 21:t_vector, 22:t_int_vector, 23:t_float_vector, 24:t_byte_vector,
+ 25:t_catch, 26:t_dynamic_wind, 27:t_hash_table, 28:t_let, 29:t_iterator,
+ 30:t_stack, 31:t_counter, 32:t_slot, 33:t_c_pointer, 34:t_output_port, 35:t_input_port, 36:t_random_state, 37:t_continuation, 38:t_goto,
+ 39:t_closure, 40:t_closure_star, 41:t_macro, 42:t_macro_star, 43:t_bacro, 44:t_bacro_star,
+ 45:t_c_macro, 46:t_c_function_star, 47:t_c_function, 48:t_c_rst_no_req_function,
+ 49:num_types
+*/
+
+typedef struct block_t {
+ union {
+ void *data;
+ s7_pointer d_ptr;
+ s7_int *i_ptr;
+ } dx;
+ int32_t index;
+ union {
+ bool needs_free;
+ uint32_t tag;
+ } ln;
+ s7_int size;
+ union {
+ struct block_t *next;
+ char *documentation;
+ s7_pointer ksym;
+ s7_int nx_int;
+ s7_int *ix_ptr;
+ struct {
+ uint32_t i1, i2;
+ } ix;
+ } nx;
+ union {
+ s7_pointer ex_ptr;
+ void *ex_info;
+ s7_int ckey;
+ } ex;
+} block_t;
+
+#define NUM_BLOCK_LISTS 18
+#define TOP_BLOCK_LIST 17
+#define BLOCK_LIST 0
+
+#define block_data(p) p->dx.data
+#define block_index(p) p->index
+#define block_set_index(p, Index) p->index = Index
+#define block_size(p) p->size
+#define block_set_size(p, Size) p->size = Size
+#define block_next(p) p->nx.next
+#define block_info(p) p->ex.ex_info
+
+typedef block_t hash_entry_t; /* I think this means we waste 8 bytes per entry but can use the mallocate functions */
+#define hash_entry_key(p) p->dx.d_ptr
+#define hash_entry_value(p) (p)->ex.ex_ptr
+#define hash_entry_set_value(p, Val) p->ex.ex_ptr = Val
+#define hash_entry_next(p) block_next(p)
+#define hash_entry_raw_hash(p) block_size(p)
+#define hash_entry_set_raw_hash(p, Hash) block_set_size(p, Hash)
+
+typedef block_t vdims_t;
+#define vdims_rank(p) p->size
+#define vector_elements_should_be_freed(p) p->ln.needs_free
+#define vdims_dims(p) p->dx.i_ptr
+#define vdims_offsets(p) p->nx.ix_ptr
+#define vdims_original(p) p->ex.ex_ptr
+
+
+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;
+
+typedef enum {NO_ARTICLE, INDEFINITE_ARTICLE} article_t;
+typedef enum {DWIND_INIT, DWIND_BODY, DWIND_FINISH} dwind_t;
+enum {NO_SAFETY = 0, IMMUTABLE_VECTOR_SAFETY, MORE_SAFETY_WARNINGS}; /* (*s7* 'safety) settings */
+
+typedef enum {FILE_PORT, STRING_PORT, FUNCTION_PORT} port_type_t;
+
+typedef struct {
+ int32_t (*read_character)(s7_scheme *sc, s7_pointer port); /* function to read a character, int32_t for EOF */
+ void (*write_character)(s7_scheme *sc, uint8_t c, s7_pointer port); /* function to write a character */
+ void (*write_string)(s7_scheme *sc, const char *str, s7_int len, s7_pointer port); /* function to write a string of known length */
+ token_t (*read_semicolon)(s7_scheme *sc, s7_pointer port); /* internal skip-to-semicolon reader */
+ int32_t (*read_white_space)(s7_scheme *sc, s7_pointer port); /* internal skip white space reader */
+ s7_pointer (*read_name)(s7_scheme *sc, s7_pointer pt); /* internal get-next-name reader */
+ s7_pointer (*read_sharp)(s7_scheme *sc, s7_pointer pt); /* internal get-next-sharp-constant reader */
+ s7_pointer (*read_line)(s7_scheme *sc, s7_pointer pt, bool eol_case); /* function to read a string up to \n */
+ void (*displayer)(s7_scheme *sc, const char *s, s7_pointer pt);
+ void (*close_port)(s7_scheme *sc, s7_pointer p); /* close-in|output-port */
+} port_functions_t;
+
+typedef struct {
+ bool needs_free, is_closed;
+ port_type_t ptype;
+ FILE *file;
+ char *filename;
+ block_t *filename_block;
+ uint32_t line_number, file_number;
+ s7_int filename_length;
+ block_t *block;
+ s7_pointer orig_str; /* GC protection for string port string or function port function */
+ const port_functions_t *pf;
+ s7_pointer (*input_function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port);
+ void (*output_function)(s7_scheme *sc, uint8_t c, s7_pointer port);
+} 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;
+
+typedef struct opt_funcs_t {
+ opt_func_t typ;
+ void *func;
+ struct opt_funcs_t *next;
+} opt_funcs_t;
+
+typedef struct {
+ const char *name;
+ int32_t name_length;
+ uint32_t id;
+ const char *doc;
+ opt_funcs_t *opt_data; /* vunion-functions (see below) */
+ s7_pointer generic_ff, setter, signature, pars;
+ s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr);
+ /* arg_defaults|names call_args only T_C_FUNCTION_STAR -- call args for GC protection */
+ union {
+ s7_pointer *arg_defaults;
+ s7_pointer bool_setter;
+ } dam;
+ union {
+ s7_pointer *arg_names;
+ s7_pointer c_sym;
+ } sam;
+ union {
+ s7_pointer call_args;
+ void (*marker)(s7_pointer p, s7_int len);
+ } cam;
+} c_proc_t;
+
+
+typedef struct {
+ s7_int type, outer_type;
+ s7_pointer scheme_name, getter, setter;
+ void (*mark)(void *val);
+ void (*free)(void *value); /* this will go away someday (use gc_free) */
+ bool (*eql)(void *val1, void *val2); /* this will go away someday (use equal) */
+#if (!DISABLE_DEPRECATED)
+ char *(*print)(s7_scheme *sc, void *value);
+#endif
+ s7_pointer (*equal) (s7_scheme *sc, s7_pointer args);
+ s7_pointer (*equivalent) (s7_scheme *sc, s7_pointer args);
+ s7_pointer (*ref) (s7_scheme *sc, s7_pointer args);
+ s7_pointer (*set) (s7_scheme *sc, s7_pointer args);
+ s7_pointer (*length) (s7_scheme *sc, s7_pointer args);
+ s7_pointer (*reverse) (s7_scheme *sc, s7_pointer args);
+ s7_pointer (*copy) (s7_scheme *sc, s7_pointer args);
+ s7_pointer (*fill) (s7_scheme *sc, s7_pointer args);
+ s7_pointer (*to_list) (s7_scheme *sc, s7_pointer args);
+ s7_pointer (*to_string) (s7_scheme *sc, s7_pointer args);
+ s7_pointer (*gc_mark) (s7_scheme *sc, s7_pointer args);
+ s7_pointer (*gc_free) (s7_scheme *sc, s7_pointer args);
+} c_object_t;
+
+
+typedef s7_int (*hash_map_t)(s7_scheme *sc, s7_pointer table, s7_pointer key); /* hash-table object->location mapper */
+typedef hash_entry_t *(*hash_check_t)(s7_scheme *sc, s7_pointer table, s7_pointer key); /* hash-table object equality function */
+static hash_map_t default_hash_map[NUM_TYPES];
+
+typedef s7_int (*s7_i_7pi_t)(s7_scheme *sc, s7_pointer p, s7_int i1);
+typedef s7_int (*s7_i_7pii_t)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2);
+typedef s7_int (*s7_i_7piii_t)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2, s7_int i3);
+typedef s7_int (*s7_i_iii_t)(s7_int i1, s7_int i2, s7_int i3);
+typedef s7_int (*s7_i_7i_t)(s7_scheme *sc, s7_int i1);
+typedef s7_int (*s7_i_7ii_t)(s7_scheme *sc, s7_int i1, s7_int i2);
+typedef bool (*s7_b_pp_t)(s7_pointer p1, s7_pointer p2);
+typedef bool (*s7_b_7pp_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2);
+typedef bool (*s7_b_7p_t)(s7_scheme *sc, s7_pointer p1);
+typedef bool (*s7_b_pi_t)(s7_scheme *sc, s7_pointer p1, s7_int i2);
+typedef bool (*s7_b_d_t)(s7_double p1);
+typedef bool (*s7_b_i_t)(s7_int p1);
+typedef bool (*s7_b_ii_t)(s7_int p1, s7_int p2);
+typedef bool (*s7_b_7ii_t)(s7_scheme *sc, s7_int p1, s7_int p2);
+typedef bool (*s7_b_dd_t)(s7_double p1, s7_double p2);
+typedef s7_pointer (*s7_p_t)(s7_scheme *sc);
+typedef s7_pointer (*s7_p_ppi_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_int i1);
+typedef s7_pointer (*s7_p_pi_t)(s7_scheme *sc, s7_pointer p1, s7_int i1);
+typedef s7_pointer (*s7_p_pii_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2);
+typedef s7_pointer (*s7_p_pip_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2);
+typedef s7_pointer (*s7_p_piip_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_pointer p3);
+typedef s7_pointer (*s7_p_i_t)(s7_scheme *sc, s7_int i);
+typedef s7_pointer (*s7_p_ii_t)(s7_scheme *sc, s7_int i1, s7_int i2);
+typedef s7_pointer (*s7_p_dd_t)(s7_scheme *sc, s7_double x1, s7_double x2);
+typedef s7_double (*s7_d_7d_t)(s7_scheme *sc, s7_double p1);
+typedef s7_double (*s7_d_7dd_t)(s7_scheme *sc, s7_double p1, s7_double p2);
+typedef s7_double (*s7_d_7pii_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2);
+typedef s7_double (*s7_d_7piid_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_double x1);
+typedef s7_double (*s7_d_7piii_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_int i3);
+typedef s7_double (*s7_d_7piiid_t)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_int i3, s7_double x1);
+
+typedef struct opt_info opt_info;
+
+typedef union {
+ s7_int i;
+ s7_double x;
+ s7_pointer p;
+ void *obj;
+ opt_info *o1;
+ s7_function call;
+ s7_double (*d_f)(void);
+ s7_double (*d_d_f)(s7_double x);
+ s7_double (*d_7d_f)(s7_scheme *sc, s7_double x);
+ s7_double (*d_dd_f)(s7_double x1, s7_double x2);
+ s7_double (*d_7dd_f)(s7_scheme *sc, s7_double x1, s7_double x2);
+ s7_double (*d_ddd_f)(s7_double x1, s7_double x2, s7_double x3);
+ s7_double (*d_dddd_f)(s7_double x1, s7_double x2, s7_double x3, s7_double x4);
+ s7_double (*d_v_f)(void *obj);
+ s7_double (*d_vd_f)(void *obj, s7_double fm);
+ s7_double (*d_vdd_f)(void *obj, s7_double x1, s7_double x2);
+ s7_double (*d_vid_f)(void *obj, s7_int i, s7_double fm);
+ s7_double (*d_id_f)(s7_int i, s7_double fm);
+ s7_double (*d_7pi_f)(s7_scheme *sc, s7_pointer obj, s7_int i1);
+ s7_double (*d_7pid_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_double x);
+ s7_double (*d_7pii_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_int i2);
+ s7_double (*d_7piid_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_int i2, s7_double x);
+ s7_double (*d_7piii_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_int i2, s7_int i3);
+ s7_double (*d_7piiid_f)(s7_scheme *sc, s7_pointer obj, s7_int i1, s7_int i2, s7_int i3, s7_double x);
+ s7_double (*d_ip_f)(s7_int i1, s7_pointer p);
+ s7_double (*d_pd_f)(s7_pointer obj, s7_double x);
+ s7_double (*d_p_f)(s7_pointer p);
+ s7_int (*i_7d_f)(s7_scheme *sc, s7_double i1);
+ s7_int (*i_7p_f)(s7_scheme *sc, s7_pointer i1);
+ s7_int (*i_i_f)(s7_int i1);
+ s7_int (*i_7i_f)(s7_scheme *sc, s7_int i1);
+ s7_int (*i_ii_f)(s7_int i1, s7_int i2);
+ s7_int (*i_7ii_f)(s7_scheme *sc, s7_int i1, s7_int i2);
+ s7_int (*i_iii_f)(s7_int i1, s7_int i2, s7_int i3);
+ s7_int (*i_7pi_f)(s7_scheme *sc, s7_pointer p, s7_int i1);
+ s7_int (*i_7pii_f)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2);
+ s7_int (*i_7piii_f)(s7_scheme *sc, s7_pointer p, s7_int i1, s7_int i2, s7_int i3);
+ bool (*b_i_f)(s7_int p);
+ bool (*b_d_f)(s7_double p);
+ bool (*b_p_f)(s7_pointer p);
+ bool (*b_pp_f)(s7_pointer p1, s7_pointer p2);
+ bool (*b_7pp_f)(s7_scheme *sc, s7_pointer p1, s7_pointer p2);
+ bool (*b_7p_f)(s7_scheme *sc, s7_pointer p1);
+ bool (*b_pi_f)(s7_scheme *sc, s7_pointer p1, s7_int i2);
+ bool (*b_ii_f)(s7_int i1, s7_int i2);
+ bool (*b_7ii_f)(s7_scheme *sc, s7_int i1, s7_int i2);
+ bool (*b_dd_f)(s7_double x1, s7_double x2);
+ s7_pointer (*p_f)(s7_scheme *sc);
+ s7_pointer (*p_p_f)(s7_scheme *sc, s7_pointer p);
+ s7_pointer (*p_pp_f)(s7_scheme *sc, s7_pointer p1, s7_pointer p2);
+ s7_pointer (*p_ppp_f)(s7_scheme *sc, s7_pointer p, s7_pointer p2, s7_pointer p3);
+ s7_pointer (*p_pi_f)(s7_scheme *sc, s7_pointer p1, s7_int i1);
+ s7_pointer (*p_pii_f)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2);
+ s7_pointer (*p_ppi_f)(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_int i1);
+ s7_pointer (*p_pip_f)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2);
+ s7_pointer (*p_piip_f)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2, s7_pointer p3);
+ s7_pointer (*p_i_f)(s7_scheme *sc, s7_int i);
+ s7_pointer (*p_ii_f)(s7_scheme *sc, s7_int x1, s7_int x2);
+ s7_pointer (*p_d_f)(s7_scheme *sc, s7_double x);
+ s7_pointer (*p_dd_f)(s7_scheme *sc, s7_double x1, s7_double x2);
+ s7_double (*fd)(opt_info *o);
+ s7_int (*fi)(opt_info *o);
+ bool (*fb)(opt_info *o);
+ s7_pointer (*fp)(opt_info *o);
+} vunion;
+/* libgsl 15 d_i */
+
+#define NUM_VUNIONS 15
+struct opt_info {
+ vunion v[NUM_VUNIONS];
+ s7_scheme *sc;
+};
+
+#define O_WRAP (NUM_VUNIONS - 1)
+
+#if WITH_GMP
+typedef struct bigint {mpz_t n; struct bigint *nxt;} bigint;
+typedef struct bigrat {mpq_t q; struct bigrat *nxt;} bigrat;
+typedef struct bigflt {mpfr_t x; struct bigflt *nxt;} bigflt;
+typedef struct bigcmp {mpc_t z; struct bigcmp *nxt;} bigcmp;
+
+typedef struct {
+ mpfr_t error, ux, x0, x1;
+ mpz_t i, i0, i1, n;
+ mpz_t p0, q0, r, r1, p1, q1, old_p1, old_q1;
+ mpfr_t val, e0, e1, e0p, e1p, old_e0, old_e1, old_e0p;
+ mpq_t q;
+} rat_locals_t;
+#endif
+
+typedef intptr_t opcode_t;
+
+
+/* -------------------------------- cell structure -------------------------------- */
+
+typedef struct s7_cell {
+ union {
+ uint64_t u64_type; /* type info */
+ int64_t s64_type;
+ uint8_t type_field;
+ struct {
+ uint16_t low_bits; /* 8 bits for type (type_field above, pair?/string? etc, 6 bits in use), 8 flag bits */
+ uint16_t mid_bits; /* 16 more flag bits */
+ uint16_t opt_bits; /* 16 bits for opcode_t (eval choice), 10 in use) */
+ uint16_t high_bits; /* 16 more flag bits */
+ } bits;
+ } tf;
+ union {
+
+ union { /* integers, floats */
+ s7_int integer_value;
+ s7_double real_value;
+
+ struct { /* ratios */
+ s7_int numerator;
+ s7_int denominator;
+ } fraction_value;
+
+ struct { /* complex numbers */
+ s7_double rl;
+ s7_double im;
+ } complex_value;
+
+#if WITH_GMP
+ bigint *bgi; /* bignums */
+ bigrat *bgr;
+ bigflt *bgf;
+ bigcmp *bgc;
+#endif
+ } number;
+
+ struct {
+ s7_int unused1, unused2; /* always int64_t so this is 16 bytes */
+ uint8_t name[24];
+ } number_name;
+
+ struct { /* ports */
+ port_t *port;
+ uint8_t *data;
+ s7_int size, point;
+ block_t *block;
+ } prt;
+
+ struct{ /* characters */
+ uint8_t c, up_c;
+ int32_t length;
+ bool alpha_c, digit_c, space_c, upper_c, lower_c;
+ char c_name[12];
+ } chr;
+
+ struct { /* c-pointers */
+ void *c_pointer;
+ s7_pointer c_type, info, weak1, weak2;
+ } cptr;
+
+ struct { /* vectors */
+ s7_int length;
+ union {
+ 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;
+ } setv;
+ } vector;
+
+ struct { /* stacks (internal) struct must match vector above for length/objects */
+ s7_int length;
+ s7_pointer *objects;
+ block_t *block;
+ int64_t top, flags;
+ } stk;
+
+ struct { /* hash-tables */
+ s7_int mask;
+ hash_entry_t **elements; /* a pointer into block below: takes up a field in object.hasher but is faster (50 in thash) */
+ hash_check_t hash_func;
+ hash_map_t *loc;
+ block_t *block;
+ } hasher;
+
+ struct { /* iterators */
+ s7_pointer obj, cur;
+ union {
+ s7_int loc;
+ s7_pointer lcur;
+ } lc;
+ union {
+ s7_int len;
+ s7_pointer slow;
+ hash_entry_t *hcur;
+ } lw;
+ s7_pointer (*next)(s7_scheme *sc, s7_pointer iterator);
+ } iter;
+
+ struct {
+ c_proc_t *c_proc; /* C functions, macros */
+ s7_function ff;
+ s7_int required_args, optional_args, all_args; /* these could be uint32_t */
+ } fnc;
+
+ struct { /* pairs */
+ s7_pointer car, cdr, opt1;
+ union
+ {
+ s7_pointer opt2;
+ s7_int n;
+ } o2;
+ union {
+ s7_pointer opt3;
+ s7_int n;
+ uint8_t opt_type;
+ } o3;
+ } cons;
+
+ struct { /* special purpose pairs (symbol-table etc) */
+ s7_pointer unused_car, unused_cdr;
+ uint64_t hash;
+ const char *fstr;
+ uint64_t location; /* line/file/position, also used in symbol_table as raw_len */
+ } sym_cons;
+
+ struct { /* scheme functions */
+ s7_pointer args, body, env, setter; /* args can be a symbol, as well as a list, setter can be #f as well as a procedure/closure */
+ int32_t arity;
+ } func;
+
+ struct { /* strings */
+ s7_int length;
+ char *svalue;
+ uint64_t hash; /* string hash-index */
+ block_t *block;
+ block_t *gensym_block;
+ } string;
+
+ struct { /* symbols */
+ s7_pointer name, global_slot, local_slot;
+ int64_t id; /* which let last bound the symbol -- for faster symbol lookup */
+ uint32_t ctr; /* how many times has symbol been bound */
+ uint32_t tag; /* symbol as member of a set (tree-set-memq etc), high 32 bits are in symbol_info (the string block) */
+ } sym;
+
+ struct { /* syntax */
+ s7_pointer symbol;
+ opcode_t op;
+ int32_t min_args, max_args;
+ const char *documentation;
+ } syn;
+
+ struct { /* slots (bindings) */
+ s7_pointer sym, val, nxt, pending_value, expr; /* pending_value is also the setter field which works by a whisker */
+ } slt;
+
+ struct { /* lets (environments) */
+ 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 */
+ } edat;
+ } envr;
+
+ struct { /* special stuff like #<unspecified> */
+ s7_pointer car, cdr; /* unique_car|cdr, for sc->nil these are sc->unspecified for faster assoc etc */
+ int64_t unused_let_id; /* let_id(sc->nil) is -1, so this needs to align with envr.id above, only used by sc->nil, so free elsewhere */
+ const char *name;
+ s7_int len;
+ } unq;
+
+ struct { /* #<...> */
+ char *name; /* not const because the GC frees it */
+ s7_int len;
+ } undef;
+
+ struct { /* #<eof> */
+ const char *name;
+ s7_int len;
+ } eof;
+
+ struct { /* counter (internal) */
+ s7_pointer result, list, env, slots; /* env = counter_let (curlet after map/for-each let created) */
+ uint64_t cap; /* sc->capture_let_counter for let reuse */
+ } ctr;
+
+ struct { /* random-state */
+#if WITH_GMP
+ gmp_randstate_t state;
+#else
+ uint64_t seed, carry;
+ /* for 64-bit floats we probably need 4 state fields */
+#endif
+ } rng;
+
+ struct { /* additional object types (C) */
+ s7_int type;
+ void *value; /* the value the caller associates with the c_object */
+ s7_pointer e; /* the method list, if any (openlet) */
+ s7_scheme *sc;
+ } c_obj;
+
+ struct { /* continuations */
+ block_t *block;
+ s7_pointer stack, op_stack;
+ s7_pointer *stack_start, *stack_end;
+ } cwcc;
+
+ struct { /* call-with-exit */
+ uint64_t goto_loc, op_stack_loc;
+ bool active;
+ s7_pointer name;
+ } rexit;
+
+ struct { /* catch */
+ uint64_t goto_loc, op_stack_loc;
+ s7_pointer tag;
+ s7_pointer handler;
+ Jmp_Buf *cstack;
+ } rcatch; /* C++ reserves "catch" I guess */
+
+ struct { /* dynamic-wind */
+ s7_pointer in, out, body;
+ dwind_t state;
+ } winder;
+ } object;
+
+#if S7_DEBUGGING
+ int32_t alloc_line, uses, explicit_free_line, gc_line, holders;
+ int64_t alloc_type, debugger_bits;
+ const char *alloc_func, *gc_func, *root;
+ s7_pointer holder;
+#endif
+} s7_cell;
+
+
+typedef struct s7_big_cell {
+ s7_cell cell;
+ int64_t big_hloc;
+} s7_big_cell;
+typedef struct s7_big_cell *s7_big_pointer;
+
+typedef struct heap_block_t {
+ intptr_t start, end;
+ int64_t offset;
+ struct heap_block_t *next;
+} heap_block_t;
+
+typedef struct {
+ s7_pointer *objs;
+ int32_t size, top, ref, size2;
+ bool has_hits;
+ int32_t *refs;
+ s7_pointer cycle_port, init_port;
+ s7_int cycle_loc, init_loc, ctr;
+ bool *defined;
+} shared_info_t;
+
+typedef struct {
+ s7_int loc, curly_len, ctr;
+ char *curly_str;
+ s7_pointer args, orig_str, curly_arg, port, strport;
+} format_data_t;
+
+typedef struct gc_obj_t {
+ s7_pointer p;
+ struct gc_obj_t *nxt;
+} gc_obj_t;
+
+typedef struct {
+ s7_pointer *list;
+ s7_int size, loc;
+} gc_list_t;
+
+typedef struct {
+ s7_int size, top, excl_size, excl_top;
+ s7_pointer *funcs, *let_names, *files;
+ s7_int *timing_data, *excl, *lines;
+} profile_data_t;
+
+typedef enum {NO_JUMP, CALL_WITH_EXIT_JUMP, THROW_JUMP, CATCH_JUMP, ERROR_JUMP, ERROR_QUIT_JUMP} jump_loc_t;
+typedef enum {NO_SET_JUMP, READ_SET_JUMP, LOAD_SET_JUMP, DYNAMIC_WIND_SET_JUMP, S7_CALL_SET_JUMP, EVAL_SET_JUMP} setjmp_loc_t;
+static const char *jump_string[6] = {"no_jump", "call_with_exit_jump", "throw_jump", "catch_jump", "error_jump", "error_quit_jump"};
+
+
+/* -------------------------------- s7_scheme struct -------------------------------- */
+struct s7_scheme {
+ s7_pointer code; /* layout of first 4 entries should match stack frame layout */
+ s7_pointer curlet;
+ s7_pointer args;
+ opcode_t cur_op;
+ s7_pointer value, cur_code;
+ token_t tok;
+
+ s7_pointer stack; /* stack is a vector */
+ uint32_t stack_size;
+ s7_pointer *stack_start, *stack_end, *stack_resize_trigger;
+
+ s7_pointer *op_stack, *op_stack_now, *op_stack_end;
+ uint32_t op_stack_size, max_stack_size;
+
+ s7_cell **heap, **free_heap, **free_heap_top, **free_heap_trigger, **previous_free_heap_top;
+ int64_t heap_size, gc_freed, gc_total_freed, max_heap_size, gc_temps_size;
+ s7_double gc_resize_heap_fraction, gc_resize_heap_by_4_fraction;
+ s7_int gc_calls, gc_total_time, gc_start, gc_end;
+ heap_block_t *heap_blocks;
+
+#if WITH_HISTORY
+ s7_pointer eval_history1, eval_history2, error_history, history_sink, history_pairs, old_cur_code;
+ bool using_history1;
+#endif
+
+#if WITH_MULTITHREAD_CHECKS
+ int32_t lock_count;
+ pthread_mutex_t lock;
+#endif
+
+ gc_obj_t *semipermanent_objects, *semipermanent_lets;
+ s7_pointer protected_objects, protected_setters, protected_setter_symbols; /* vectors of gc-protected objects */
+ s7_int *protected_objects_free_list; /* to avoid a linear search for a place to store an object in sc->protected_objects */
+ s7_int protected_objects_size, protected_setters_size, protected_setters_loc;
+ s7_int protected_objects_free_list_loc;
+
+ s7_pointer nil; /* empty list */
+ s7_pointer T; /* #t */
+ s7_pointer F; /* #f */
+ s7_pointer undefined; /* #<undefined> */
+ s7_pointer unspecified; /* #<unspecified> */
+ s7_pointer no_value; /* the (values) value */
+ s7_pointer unused; /* a marker for an unoccupied slot in sc->protected_objects (and other similar stuff) */
+
+ s7_pointer symbol_table;
+ s7_pointer rootlet, rootlet_slots, shadow_rootlet;
+ s7_pointer unlet_slots; /* original bindings of predefined functions */
+
+ s7_pointer input_port; /* current-input-port */
+ s7_pointer *input_port_stack; /* input port stack (load and read internally) */
+ uint32_t input_port_stack_size, input_port_stack_loc;
+
+ s7_pointer output_port; /* current-output-port */
+ s7_pointer error_port; /* current-error-port */
+ s7_pointer owlet; /* owlet */
+ s7_pointer error_type, error_data, error_code, error_line, error_file, error_position; /* owlet slots */
+ s7_pointer standard_input, standard_output, standard_error;
+
+ s7_pointer sharp_readers; /* the binding pair for the global *#readers* list */
+ s7_pointer load_hook; /* *load-hook* hook object */
+ s7_pointer autoload_hook; /* *autoload-hook* hook object */
+ s7_pointer unbound_variable_hook; /* *unbound-variable-hook* hook object */
+ s7_pointer missing_close_paren_hook, rootlet_redefinition_hook;
+ s7_pointer error_hook, read_error_hook; /* *error-hook* hook object, and *read-error-hook* */
+ bool gc_off, gc_in_progress; /* gc_off: if true, the GC won't run */
+ uint32_t gc_stats, gensym_counter, f_class, add_class, multiply_class, subtract_class, num_eq_class;
+ int32_t format_column, error_argnum;
+ uint64_t capture_let_counter;
+ bool short_print, is_autoloading, in_with_let, object_out_locked, has_openlets, is_expanding, accept_all_keyword_arguments, muffle_warnings;
+ bool got_tc, got_rec, not_tc;
+ s7_int rec_tc_args, continuation_counter;
+ int64_t let_number;
+ unsigned char number_separator;
+ s7_double default_rationalize_error, equivalent_float_epsilon, hash_table_float_epsilon;
+ s7_int default_hash_table_length, initial_string_port_length, print_length, objstr_max_len, history_size, true_history_size, output_file_port_data_size;
+ s7_int max_vector_length, max_string_length, max_list_length, max_vector_dimensions, max_format_length, max_port_data_size, rec_loc, rec_len, show_stack_limit;
+ s7_pointer stacktrace_defaults;
+
+ s7_pointer rec_stack, rec_testp, rec_f1p, rec_f2p, rec_f3p, rec_f4p, rec_f5p, rec_f6p, rec_f7p, rec_f8p, rec_f9p;
+ s7_pointer rec_resp, rec_slot1, rec_slot2, rec_slot3, rec_p1, rec_p2;
+ s7_pointer *rec_els;
+ s7_function rec_testf, rec_f1f, rec_f2f, rec_f3f, rec_f4f, rec_f5f, rec_f6f, rec_f7f, rec_f8f, rec_f9f, rec_resf, rec_fn;
+ s7_int (*rec_fi1)(opt_info *o);
+ s7_int (*rec_fi2)(opt_info *o);
+ s7_int (*rec_fi3)(opt_info *o);
+ s7_int (*rec_fi4)(opt_info *o);
+ s7_int (*rec_fi5)(opt_info *o);
+ s7_int (*rec_fi6)(opt_info *o);
+ bool (*rec_fb1)(opt_info *o);
+ bool (*rec_fb2)(opt_info *o);
+
+ opt_info *rec_test_o, *rec_result_o, *rec_a1_o, *rec_a2_o, *rec_a3_o, *rec_a4_o, *rec_a5_o, *rec_a6_o;
+ s7_i_ii_t rec_i_ii_f;
+ s7_d_dd_t rec_d_dd_f;
+ s7_pointer rec_val1, rec_val2;
+
+ int32_t float_format_precision;
+ vdims_t *wrap_only;
+
+ char *typnam;
+ int32_t typnam_len, print_width;
+ s7_pointer *singletons;
+ block_t *unentry; /* hash-table lookup failure indicator */
+
+ #define INITIAL_FILE_NAMES_SIZE 8
+ s7_pointer *file_names;
+ int32_t file_names_size, file_names_top;
+
+ #define INITIAL_STRBUF_SIZE 1024
+ s7_int strbuf_size;
+ char *strbuf;
+
+ char *read_line_buf;
+ s7_int read_line_buf_size;
+
+ s7_pointer w, x, y, z;
+ s7_pointer temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, temp9, temp10;
+ s7_pointer t1_1, t2_1, t2_2, t3_1, t3_2, t3_3, t4_1, u1_1;
+ s7_pointer elist_1, elist_2, elist_3, elist_4, elist_5, elist_6, elist_7;
+ s7_pointer plist_1, plist_2, plist_2_2, plist_3, plist_4;
+ s7_pointer qlist_2, qlist_3, clist_1, clist_2, dlist_1, mlist_1, mlist_2; /* dlist|clist and ulist can't overlap */
+
+ Jmp_Buf *goto_start;
+ bool longjmp_ok;
+ setjmp_loc_t setjmp_loc;
+
+ void (*begin_hook)(s7_scheme *sc, bool *val);
+ opcode_t begin_op;
+
+ bool debug_or_profile, profiling_gensyms;
+ s7_int current_line, s7_call_line, debug, profile, profile_position;
+ s7_pointer profile_prefix;
+ profile_data_t *profile_data;
+ const char *current_file, *s7_call_file, *s7_call_name;
+
+ shared_info_t *circle_info;
+ format_data_t **fdats;
+ int32_t num_fdats, safety;
+ gc_list_t *strings, *vectors, *input_ports, *output_ports, *input_string_ports, *continuations, *c_objects, *hash_tables;
+ gc_list_t *gensyms, *undefineds, *multivectors, *weak_refs, *weak_hash_iterators, *opt1_funcs;
+#if (WITH_GMP)
+ gc_list_t *big_integers, *big_ratios, *big_reals, *big_complexes, *big_random_states;
+ mpz_t mpz_1, mpz_2, mpz_3, mpz_4;
+ mpq_t mpq_1, mpq_2, mpq_3;
+ mpfr_t mpfr_1, mpfr_2, mpfr_3;
+ mpc_t mpc_1, mpc_2;
+ rat_locals_t *ratloc;
+ bigint *bigints;
+ bigrat *bigrats;
+ bigflt *bigflts;
+ bigcmp *bigcmps;
+#endif
+ s7_pointer *setters;
+ s7_int setters_size, setters_loc;
+ s7_pointer *tree_pointers;
+ int32_t tree_pointers_size, tree_pointers_top, semipermanent_cells, num_to_str_size;
+ s7_pointer format_ports;
+ uint32_t alloc_pointer_k, alloc_function_k, alloc_symbol_k;
+ s7_cell *alloc_pointer_cells;
+ c_proc_t *alloc_function_cells;
+ uint32_t alloc_big_pointer_k;
+ s7_big_cell *alloc_big_pointer_cells;
+ s7_pointer string_wrappers, integer_wrappers, real_wrappers, c_pointer_wrappers;
+ uint8_t *alloc_symbol_cells;
+ char *num_to_str;
+
+ block_t *block_lists[NUM_BLOCK_LISTS];
+ size_t alloc_string_k;
+ char *alloc_string_cells;
+
+ c_object_t **c_object_types;
+ int32_t c_object_types_size, num_c_object_types;
+ s7_pointer type_to_typers[NUM_TYPES];
+
+ uint32_t syms_tag, syms_tag2;
+ int32_t bignum_precision;
+ s7_int baffle_ctr, map_call_ctr;
+ s7_pointer default_random_state;
+
+ s7_pointer sort_body, sort_begin, sort_v1, sort_v2;
+ opcode_t sort_op;
+ s7_int sort_body_len;
+ s7_b_7pp_t sort_f;
+ opt_info *sort_o;
+ bool (*sort_fb)(opt_info *o);
+
+ #define INT_TO_STR_SIZE 32
+ char int_to_str1[INT_TO_STR_SIZE], int_to_str2[INT_TO_STR_SIZE], int_to_str3[INT_TO_STR_SIZE], int_to_str4[INT_TO_STR_SIZE], int_to_str5[INT_TO_STR_SIZE];
+
+ s7_pointer abs_symbol, acos_symbol, acosh_symbol, add_symbol, angle_symbol, append_symbol, apply_symbol, apply_values_symbol, arity_symbol,
+ ash_symbol, asin_symbol, asinh_symbol, assoc_symbol, assq_symbol, assv_symbol, atan_symbol, atanh_symbol, autoload_symbol, autoloader_symbol,
+ bacro_symbol, bacro_star_symbol, bignum_symbol, byte_vector_symbol, byte_vector_ref_symbol, byte_vector_set_symbol, byte_vector_to_string_symbol,
+ c_pointer_symbol, c_pointer_info_symbol, c_pointer_to_list_symbol, c_pointer_type_symbol, c_pointer_weak1_symbol, c_pointer_weak2_symbol,
+ caaaar_symbol, caaadr_symbol, caaar_symbol, caadar_symbol, caaddr_symbol, caadr_symbol,
+ caar_symbol, cadaar_symbol, cadadr_symbol, cadar_symbol, caddar_symbol, cadddr_symbol, caddr_symbol, cadr_symbol,
+ call_cc_symbol, call_with_current_continuation_symbol, call_with_exit_symbol, call_with_input_file_symbol,
+ call_with_input_string_symbol, call_with_output_file_symbol, call_with_output_string_symbol, car_symbol,
+ catch_symbol, cdaaar_symbol, cdaadr_symbol, cdaar_symbol, cdadar_symbol, cdaddr_symbol, cdadr_symbol, cdar_symbol,
+ cddaar_symbol, cddadr_symbol, cddar_symbol, cdddar_symbol, cddddr_symbol, cdddr_symbol, cddr_symbol, cdr_symbol,
+ ceiling_symbol, char_downcase_symbol, char_eq_symbol, char_geq_symbol, char_gt_symbol, char_leq_symbol, char_lt_symbol,
+ char_position_symbol, char_to_integer_symbol, char_upcase_symbol, cload_directory_symbol, close_input_port_symbol,
+ close_output_port_symbol, complex_symbol, cons_symbol, copy_symbol, cos_symbol, cosh_symbol, coverlet_symbol,
+ curlet_symbol, current_error_port_symbol, current_input_port_symbol, current_output_port_symbol, cutlet_symbol, cyclic_sequences_symbol,
+ denominator_symbol, dilambda_symbol, display_symbol, divide_symbol, documentation_symbol, dynamic_wind_symbol, dynamic_unwind_symbol,
+ num_eq_symbol, error_symbol, eval_string_symbol, eval_symbol, exact_to_inexact_symbol, exit_symbol, exp_symbol, expt_symbol,
+ features_symbol, file__symbol, fill_symbol, float_vector_ref_symbol, float_vector_set_symbol, float_vector_symbol, floor_symbol,
+ flush_output_port_symbol, for_each_symbol, format_symbol, funclet_symbol, _function__symbol,
+ gc_symbol, gcd_symbol, gensym_symbol, geq_symbol, get_output_string_symbol, gt_symbol,
+ hash_table_entries_symbol, hash_table_key_typer_symbol, hash_table_ref_symbol, hash_table_set_symbol, hash_table_symbol,
+ hash_table_value_typer_symbol, help_symbol,
+ imag_part_symbol, immutable_symbol, inexact_to_exact_symbol, inlet_symbol, int_vector_ref_symbol, int_vector_set_symbol, int_vector_symbol,
+ integer_decode_float_symbol, integer_to_char_symbol,
+ is_aritable_symbol, is_bignum_symbol, is_boolean_symbol, is_byte_symbol, is_byte_vector_symbol,
+ is_c_object_symbol, c_object_type_symbol, is_c_pointer_symbol, is_char_alphabetic_symbol, is_char_lower_case_symbol, is_char_numeric_symbol,
+ is_char_symbol, is_char_upper_case_symbol, is_char_whitespace_symbol, is_complex_symbol, is_constant_symbol,
+ is_continuation_symbol, is_defined_symbol, is_dilambda_symbol, is_eof_object_symbol, is_eq_symbol, is_equal_symbol,
+ is_eqv_symbol, is_even_symbol, is_exact_symbol, is_float_vector_symbol, is_funclet_symbol,
+ is_gensym_symbol, is_goto_symbol, is_hash_table_symbol, is_immutable_symbol,
+ is_inexact_symbol, is_infinite_symbol, is_input_port_symbol, is_int_vector_symbol, is_integer_symbol, is_iterator_symbol,
+ is_keyword_symbol, is_let_symbol, is_list_symbol, is_macro_symbol, is_equivalent_symbol, is_nan_symbol, is_negative_symbol,
+ is_null_symbol, is_number_symbol, is_odd_symbol, is_openlet_symbol, is_output_port_symbol, is_pair_symbol,
+ is_port_closed_symbol, is_positive_symbol, is_procedure_symbol, is_proper_list_symbol, is_provided_symbol,
+ is_random_state_symbol, is_rational_symbol, is_real_symbol, is_sequence_symbol, is_string_symbol, is_subvector_symbol,
+ is_symbol_symbol, is_syntax_symbol, is_vector_symbol, is_weak_hash_table_symbol, is_zero_symbol,
+ is_float_symbol, is_integer_or_real_at_end_symbol, is_integer_or_any_at_end_symbol, is_unspecified_symbol, is_undefined_symbol,
+ iterate_symbol, iterator_is_at_end_symbol, iterator_sequence_symbol,
+ keyword_to_symbol_symbol,
+ lcm_symbol, length_symbol, leq_symbol, let_ref_fallback_symbol, let_ref_symbol, let_set_fallback_symbol,
+ let_set_symbol, let_temporarily_symbol, libraries_symbol, list_ref_symbol, list_set_symbol, list_symbol, list_tail_symbol, list_values_symbol,
+ load_path_symbol, load_symbol, log_symbol, logand_symbol, logbit_symbol, logior_symbol, lognot_symbol, logxor_symbol, lt_symbol,
+ macro_symbol, macro_star_symbol, magnitude_symbol, make_byte_vector_symbol, make_float_vector_symbol, make_hash_table_symbol,
+ make_weak_hash_table_symbol, make_int_vector_symbol, make_iterator_symbol, string_to_keyword_symbol, make_list_symbol, make_string_symbol,
+ make_vector_symbol, map_symbol, max_symbol, member_symbol, memq_symbol, memv_symbol, min_symbol, modulo_symbol, multiply_symbol,
+ name_symbol, nan_symbol, nan_payload_symbol, newline_symbol, not_symbol, number_to_string_symbol, numerator_symbol,
+ object_to_string_symbol, object_to_let_symbol, open_input_file_symbol, open_input_function_symbol, open_input_string_symbol,
+ open_output_file_symbol, open_output_function_symbol, open_output_string_symbol, openlet_symbol, outlet_symbol, owlet_symbol,
+ pair_filename_symbol, pair_line_number_symbol, peek_char_symbol, pi_symbol, port_filename_symbol, port_line_number_symbol,
+ port_file_symbol, port_position_symbol, port_string_symbol, procedure_source_symbol, provide_symbol,
+ qq_append_symbol, quotient_symbol,
+ random_state_symbol, random_state_to_list_symbol, random_symbol, rationalize_symbol, read_byte_symbol,
+ read_char_symbol, read_line_symbol, read_string_symbol, read_symbol, real_part_symbol, remainder_symbol,
+ require_symbol, reverse_symbol, reverseb_symbol, rootlet_symbol, round_symbol,
+ setter_symbol, set_car_symbol, set_cdr_symbol,
+ set_current_error_port_symbol, set_current_input_port_symbol, set_current_output_port_symbol,
+ signature_symbol, sin_symbol, sinh_symbol, sort_symbol, sqrt_symbol,
+ stacktrace_symbol, string_append_symbol, string_copy_symbol, string_downcase_symbol, string_eq_symbol, string_fill_symbol,
+ string_geq_symbol, string_gt_symbol, string_leq_symbol, string_lt_symbol, string_position_symbol, string_ref_symbol,
+ string_set_symbol, string_symbol, string_to_number_symbol, string_to_symbol_symbol, string_upcase_symbol,
+ sublet_symbol, substring_symbol, subtract_symbol, subvector_symbol, subvector_position_symbol, subvector_vector_symbol,
+ symbol_symbol, symbol_to_dynamic_value_symbol,
+ symbol_to_keyword_symbol, symbol_to_string_symbol, symbol_to_value_symbol,
+ tan_symbol, tanh_symbol, throw_symbol, string_to_byte_vector_symbol,
+ tree_count_symbol, tree_leaves_symbol, tree_memq_symbol, tree_set_memq_symbol, tree_is_cyclic_symbol, truncate_symbol, type_of_symbol,
+ unlet_symbol,
+ values_symbol, varlet_symbol, vector_append_symbol, vector_dimension_symbol, vector_dimensions_symbol, vector_fill_symbol,
+ vector_rank_symbol, vector_ref_symbol, vector_set_symbol, vector_symbol, vector_typer_symbol,
+ weak_hash_table_symbol, with_input_from_file_symbol, with_input_from_string_symbol, with_output_to_file_symbol, with_output_to_string_symbol,
+ write_byte_symbol, write_char_symbol, write_string_symbol, write_symbol,
+ local_documentation_symbol, local_signature_symbol, local_setter_symbol, local_iterator_symbol;
+ s7_pointer hash_code_symbol, dummy_equal_hash_table, features_setter;
+#if (!WITH_PURE_S7)
+ s7_pointer is_char_ready_symbol, char_ci_leq_symbol, char_ci_lt_symbol, char_ci_eq_symbol, char_ci_geq_symbol, char_ci_gt_symbol,
+ let_to_list_symbol, integer_length_symbol, string_ci_leq_symbol, string_ci_lt_symbol, string_ci_eq_symbol,
+ string_ci_geq_symbol, string_ci_gt_symbol, string_to_list_symbol, vector_to_list_symbol, string_length_symbol,
+ list_to_string_symbol, list_to_vector_symbol, vector_length_symbol;
+#endif
+
+ /* syntax symbols et al */
+ s7_pointer else_symbol, lambda_symbol, lambda_star_symbol, let_symbol, quote_symbol, quasiquote_symbol, unquote_symbol, macroexpand_symbol,
+ define_expansion_symbol, define_expansion_star_symbol, with_let_symbol, if_symbol, autoload_error_symbol,
+ when_symbol, unless_symbol, begin_symbol, cond_symbol, case_symbol, and_symbol, or_symbol, do_symbol, number_to_real_symbol,
+ define_symbol, define_star_symbol, define_constant_symbol, with_baffle_symbol, define_macro_symbol, no_setter_symbol,
+ define_macro_star_symbol, define_bacro_symbol, define_bacro_star_symbol, letrec_symbol, letrec_star_symbol, let_star_symbol,
+ rest_keyword, allow_other_keys_keyword, readable_keyword, display_keyword, write_keyword, value_symbol, type_symbol,
+ baffled_symbol, set_symbol, body_symbol, class_name_symbol, feed_to_symbol, format_error_symbol, immutable_error_symbol,
+ wrong_number_of_args_symbol, read_error_symbol, string_read_error_symbol, syntax_error_symbol, division_by_zero_symbol, bad_result_symbol,
+ io_error_symbol, invalid_escape_function_symbol, wrong_type_arg_symbol, out_of_range_symbol, out_of_memory_symbol,
+ missing_method_symbol, unbound_variable_symbol, if_keyword, symbol_table_symbol, profile_in_symbol, trace_in_symbol,
+ quote_function, quasiquote_function;
+
+ /* signatures of sequences used as applicable objects: ("hi" 1) */
+ s7_pointer string_signature, vector_signature, float_vector_signature, int_vector_signature, byte_vector_signature,
+ c_object_signature, let_signature, hash_table_signature, pair_signature;
+ /* common signatures */
+ s7_pointer pcl_bc, pcl_bs, pcl_bt, pcl_c, pcl_e, pcl_f, pcl_i, pcl_n, pcl_r, pcl_s, pcl_v, pl_bc, pl_bn, pl_bt, pl_p, pl_sf, pl_tl, pl_nn;
+
+ /* optimizer s7_functions */
+ s7_pointer add_2, add_3, add_1x, add_x1, subtract_1, subtract_2, subtract_3, subtract_x1, subtract_2f, subtract_f2, simple_char_eq,
+ char_equal_2, char_greater_2, char_less_2, char_position_csi, string_equal_2, substring_uncopied, display_2, display_f,
+ string_greater_2, string_less_2, symbol_to_string_uncopied, get_output_string_uncopied, string_equal_2c, string_c1, string_append_2,
+ vector_ref_2, vector_ref_3, vector_set_3, vector_set_4, read_char_1, dynamic_wind_unchecked, dynamic_wind_body, dynamic_wind_init, append_2,
+ fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, iv_ref_2, iv_ref_3, iv_set_3, bv_ref_2, bv_ref_3, bv_set_3, vector_2, vector_3,
+ list_0, list_1, list_2, list_3, list_4, list_set_i, hash_table_ref_2, hash_table_2, list_ref_at_0, list_ref_at_1, list_ref_at_2,
+ format_f, format_no_column, format_just_control_string, format_as_objstr, values_uncopied, int_log2,
+ memq_2, memq_3, memq_4, memq_any, tree_set_memq_syms, simple_inlet, sublet_curlet, profile_out, simple_list_values,
+ simple_let_ref, simple_let_set, geq_2, add_i_random, is_defined_in_rootlet;
+
+ s7_pointer multiply_2, invert_1, invert_x, divide_2, divide_by_2, max_2, min_2, max_3, min_3,
+ num_eq_2, num_eq_xi, num_eq_ix, less_xi, less_xf, less_x0, less_2, greater_xi, greater_xf, greater_2,
+ leq_xi, leq_2, leq_ixx, geq_xi, geq_xf, random_i, random_f, random_1,
+ mul_2_ff, mul_2_ii, mul_2_if, mul_2_fi, mul_2_xi, mul_2_ix, mul_2_fx, mul_2_xf,
+ add_2_ff, add_2_ii, add_2_if, add_2_fi, add_2_xi, add_2_ix, add_2_fx, add_2_xf;
+ s7_pointer seed_symbol, carry_symbol;
+
+ /* object->let symbols */
+ s7_pointer active_symbol, data_symbol, weak_symbol, dimensions_symbol, info_symbol, c_type_symbol, source_symbol, c_object_ref_symbol,
+ at_end_symbol, sequence_symbol, position_symbol, entries_symbol, function_symbol, open_symbol, alias_symbol, port_type_symbol,
+ file_symbol, file_info_symbol, line_symbol, c_object_let_symbol, class_symbol, current_value_symbol, closed_symbol,
+ is_mutable_symbol, size_symbol, original_vector_symbol, pointer_symbol;
+
+#if WITH_SYSTEM_EXTRAS
+ s7_pointer is_directory_symbol, file_exists_symbol, delete_file_symbol, getenv_symbol, system_symbol, directory_to_list_symbol, file_mtime_symbol;
+#endif
+ s7_pointer open_input_function_choices[S7_NUM_READ_CHOICES];
+ s7_pointer closed_input_function, closed_output_function;
+ s7_pointer vector_set_function, string_set_function, list_set_function, hash_table_set_function, let_set_function, c_object_set_function, last_function;
+ s7_pointer wrong_type_arg_info, out_of_range_info, sole_arg_wrong_type_info, sole_arg_out_of_range_info;
+
+ #define NUM_SAFE_PRELISTS 8
+ #define NUM_SAFE_LISTS 32 /* 36 is the biggest normally (lint.scm), 49 in s7test, 57 in snd-test, > 16 doesn't happen much */
+ s7_pointer safe_lists[NUM_SAFE_LISTS];
+ int32_t current_safe_list;
+#if S7_DEBUGGING
+ s7_int safe_list_uses[NUM_SAFE_LISTS];
+#endif
+
+ s7_pointer autoload_table, s7_starlet, s7_starlet_symbol, let_temp_hook;
+ const char ***autoload_names;
+ s7_int *autoload_names_sizes;
+ bool **autoloaded_already;
+ s7_int autoload_names_loc, autoload_names_top;
+ int32_t format_depth;
+ bool undefined_identifier_warnings, undefined_constant_warnings, stop_at_error;
+
+ opt_funcs_t *alloc_opt_func_cells;
+ int32_t alloc_opt_func_k;
+
+ int32_t pc;
+ #define OPTS_SIZE 256 /* pqw-vox needs 178 */
+ opt_info *opts[OPTS_SIZE + 1]; /* this form is a lot faster than opt_info**! */
+
+ #define INITIAL_SAVED_POINTERS_SIZE 256
+ void **saved_pointers;
+ s7_int saved_pointers_loc, saved_pointers_size;
+
+ s7_pointer type_names[NUM_TYPES];
+
+#if S7_DEBUGGING
+ int32_t *tc_rec_calls;
+ bool printing_gc_info;
+ s7_int blocks_allocated;
+#endif
+};
+
+
+static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info);
+static s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len);
+
+#if S7_DEBUGGING
+ static void gdb_break(void) {};
+#endif
+
+#ifndef DISABLE_FILE_OUTPUT
+ #define DISABLE_FILE_OUTPUT 0
+#endif
+
+static s7_scheme *cur_sc = NULL; /* intended for gdb (see gdbinit), but also used elsewhere unfortunately */
+static s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1);
+
+#if DISABLE_FILE_OUTPUT
+static FILE *old_fopen(const char *pathname, const char *mode) {return(fopen(pathname, mode));}
+
+#define fwrite local_fwrite
+#define fopen local_fopen /* open only used for file_probe (O_RDONLY), creat and write not used */
+
+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)));
+}
+
+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)));
+ return(old_fopen(pathname, mode));
+}
+#endif
+
+
+#if POINTER_32
+static void *Malloc(size_t bytes)
+{
+ void *p = malloc(bytes);
+ if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, set_elist_1(cur_sc, wrap_string(cur_sc, "malloc failed", 13)));
+ return(p);
+}
+
+static void *Calloc(size_t nmemb, size_t size)
+{
+ void *p = calloc(nmemb, size);
+ if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, set_elist_1(cur_sc, wrap_string(cur_sc, "calloc failed", 13)));
+ return(p);
+}
+
+static void *Realloc(void *ptr, size_t size)
+{
+ void *p = realloc(ptr, size);
+ if (!p) error_nr(cur_sc, cur_sc->out_of_memory_symbol, set_elist_1(cur_sc, wrap_string(cur_sc, "realloc failed", 14)));
+ return(p);
+}
+#else
+#define Malloc malloc
+#define Calloc calloc
+#define Realloc realloc
+#endif
+
+
+/* -------------------------------- mallocate -------------------------------- */
+static void add_saved_pointer(s7_scheme *sc, void *p)
+{
+ if (sc->saved_pointers_loc == sc->saved_pointers_size)
+ {
+ sc->saved_pointers_size *= 2;
+ sc->saved_pointers = (void **)Realloc(sc->saved_pointers, sc->saved_pointers_size * sizeof(void *));
+ }
+ sc->saved_pointers[sc->saved_pointers_loc++] = p;
+}
+
+static const int32_t intlen_bits[256] =
+ {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, 5,
+ 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6, 6,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, 7,
+ 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
+ 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
+ 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8,
+ 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8, 8};
+
+static void memclr(void *s, size_t n)
+{
+ uint8_t *s2;
+#if S7_ALIGNED
+ s2 = (uint8_t *)s;
+#else
+#if (defined(__x86_64__) || defined(__i386__))
+ if (n >= 8)
+ {
+ int64_t *s1 = (int64_t *)s;
+ size_t n8 = n >> 3;
+ do {*s1++ = 0;} while (--n8 > 0); /* LOOP_4 here is slower */
+ n &= 7;
+ s2 = (uint8_t *)s1;
+ }
+ else s2 = (uint8_t *)s;
+#else
+ s2 = (uint8_t *)s;
+#endif
+#endif
+ while (n > 0)
+ {
+ *s2++ = 0;
+ n--;
+ }
+}
+
+#define LOOP_4(Code) do {Code; Code; Code; Code;} while (0)
+#define LOOP_8(Code) do {Code; Code; Code; Code; Code; Code; Code; Code;} while (0)
+#define STEP_8(Var) (((Var) & 0x7) == 0)
+#define STEP_64(Var) (((Var) & 0x3f) == 0)
+
+#if POINTER_32
+#define memclr64 memclr
+#else
+static Vectorized void memclr64(void *p, size_t bytes)
+{
+ size_t n = bytes >> 3;
+ int64_t *vals = (int64_t *)p;
+ for (size_t i = 0; i < n; )
+ LOOP_8(vals[i++] = 0);
+}
+#endif
+
+static void init_block_lists(s7_scheme *sc)
+{
+ for (int32_t i = 0; i < NUM_BLOCK_LISTS; i++)
+ sc->block_lists[i] = NULL;
+#if S7_DEBUGGING
+ sc->blocks_allocated = 0;
+#endif
+}
+
+static inline void liberate(s7_scheme *sc, block_t *p)
+{
+ if (block_index(p) != TOP_BLOCK_LIST)
+ {
+ block_next(p) = (struct block_t *)sc->block_lists[block_index(p)];
+ sc->block_lists[block_index(p)] = p;
+ }
+ else
+ {
+ if (block_data(p))
+ {
+ 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;
+ }
+}
+
+static inline void liberate_block(s7_scheme *sc, block_t *p)
+{
+ block_next(p) = (struct block_t *)sc->block_lists[BLOCK_LIST]; /* BLOCK_LIST==0 */
+ sc->block_lists[BLOCK_LIST] = p;
+}
+
+static void fill_block_list(s7_scheme *sc)
+{
+ #define BLOCK_MALLOC_SIZE 256
+ block_t *b = (block_t *)Malloc(BLOCK_MALLOC_SIZE * sizeof(block_t)); /* batch alloc means blocks in this batch can't be freed, only returned to the list */
+#if S7_DEBUGGING
+ sc->blocks_allocated += BLOCK_MALLOC_SIZE;
+#endif
+ add_saved_pointer(sc, b);
+ sc->block_lists[BLOCK_LIST] = b;
+ for (int32_t i = 0; i < BLOCK_MALLOC_SIZE - 1; b++, i++)
+ block_next(b) = (block_t *)(b + 1);
+ block_next(b) = NULL;
+}
+
+static inline block_t *mallocate_block(s7_scheme *sc)
+{
+ block_t *p;
+ if (!sc->block_lists[BLOCK_LIST])
+ fill_block_list(sc); /* this is much faster than allocating blocks as needed */
+ p = sc->block_lists[BLOCK_LIST];
+ sc->block_lists[BLOCK_LIST] = (block_t *)(block_next(p));
+ block_set_index(p, BLOCK_LIST);
+ return(p);
+}
+
+static inline char *permalloc(s7_scheme *sc, size_t len)
+{
+ #define ALLOC_STRING_SIZE (65536 * 8) /* going up to 16 made no difference in timings */
+ #define ALLOC_MAX_STRING (512 * 8) /* was 256 -- sets max size of block space lost at the end, but smaller = more direct malloc calls */
+ char *result;
+ size_t next_k;
+
+ len = (len + 7) & (~7); /* 8-byte aligned -- more than half the time, len is already 8-byte aligned */
+ next_k = sc->alloc_string_k + len;
+ if (next_k > ALLOC_STRING_SIZE)
+ {
+ if (len >= ALLOC_MAX_STRING)
+ {
+ 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;
+ next_k = len;
+ }
+ result = &(sc->alloc_string_cells[sc->alloc_string_k]);
+ sc->alloc_string_k = next_k;
+ return(result);
+}
+
+static Inline block_t *inline_mallocate(s7_scheme *sc, size_t bytes)
+{
+ block_t *p;
+ if (bytes > 0)
+ {
+ int32_t index;
+ if (bytes <= 8) /* presetting a version of intlen_bits with 3's gave only a small speed-up */
+ 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 */
+ }
+ p = sc->block_lists[index];
+ if (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);
+ }}
+ else p = mallocate_block(sc);
+ block_set_size(p, bytes);
+ return(p);
+}
+
+static block_t *mallocate(s7_scheme *sc, size_t bytes) {return(inline_mallocate(sc, bytes));}
+
+static block_t *callocate(s7_scheme *sc, size_t bytes)
+{
+ block_t *p = inline_mallocate(sc, bytes);
+ if ((block_data(p)) && (block_index(p) != BLOCK_LIST))
+ {
+ if ((bytes & (~0x3f)) > 0)
+ memclr64((void *)block_data(p), bytes & (~0x3f));
+ if ((bytes & 0x3f) > 0)
+ memclr((void *)((uint8_t *)block_data(p) + (bytes & (~0x3f))), bytes & 0x3f);
+ }
+ return(p);
+}
+
+static block_t *reallocate(s7_scheme *sc, block_t *op, size_t bytes)
+{
+ block_t *np = inline_mallocate(sc, bytes);
+ if (block_data(op)) /* presumably block_data(np) is not null */
+ memcpy((uint8_t *)(block_data(np)), (uint8_t *)(block_data(op)), block_size(op));
+ liberate(sc, op);
+ return(np);
+}
+
+/* we can't export mallocate et al without also exporting block_t or accessors for it
+ * that is, the block_t* pointer returned can't be used as if it were the void* pointer returned by malloc
+ * ideally we'd have a way to release excessive mallocate bins, but they are permalloc'd individually
+ */
+
+
+/* -------------------------------------------------------------------------------- */
+typedef enum {P_DISPLAY, P_WRITE, P_READABLE, P_KEY, P_CODE} use_write_t;
+
+static s7_pointer too_many_arguments_string, not_enough_arguments_string, cant_bind_immutable_string,
+ a_boolean_string, a_byte_vector_string, a_format_port_string, a_let_string, a_list_string, a_non_constant_symbol_string,
+ a_non_negative_integer_string, a_normal_procedure_string, a_normal_real_string, a_number_string, a_procedure_string, a_procedure_or_a_macro_string,
+ a_proper_list_string, a_random_state_object_string, a_rational_string, a_sequence_string, a_symbol_string, a_thunk_string, a_valid_radix_string,
+ an_association_list_string, an_eq_func_string, an_input_file_port_string, an_input_port_string, an_input_string_port_string, an_open_input_port_string,
+ an_open_output_port_string, an_output_port_or_f_string, an_output_file_port_string, an_output_port_string, an_output_string_port_string,
+ an_unsigned_byte_string, caaar_a_list_string, caadr_a_list_string, caar_a_list_string, cadar_a_list_string, caddr_a_list_string,
+ cadr_a_list_string, car_a_list_string, cdaar_a_list_string, cdadr_a_list_string, cdar_a_list_string, cddar_a_list_string,
+ cdddr_a_list_string, cddr_a_list_string, cdr_a_list_string, immutable_error_string, it_is_infinite_string, it_is_nan_string,
+ it_is_negative_string, it_is_too_large_string, it_is_too_small_string, parameter_set_twice_string, result_is_too_large_string,
+ something_applicable_string, too_many_indices_string, intermediate_too_large_string,
+ format_string_1, format_string_2, format_string_3, format_string_4, keyword_value_missing_string;
+
+static bool t_number_p[NUM_TYPES], t_small_real_p[NUM_TYPES], t_rational_p[NUM_TYPES], t_real_p[NUM_TYPES], t_big_number_p[NUM_TYPES];
+static bool t_simple_p[NUM_TYPES], t_structure_p[NUM_TYPES], t_immutable_p[NUM_TYPES];
+static bool t_any_macro_p[NUM_TYPES], t_any_closure_p[NUM_TYPES], t_has_closure_let[NUM_TYPES];
+static bool t_mappable_p[NUM_TYPES], t_sequence_p[NUM_TYPES], t_vector_p[NUM_TYPES];
+static bool t_procedure_p[NUM_TYPES], t_applicable_p[NUM_TYPES], t_macro_setter_p[NUM_TYPES];
+#if S7_DEBUGGING
+static bool t_freeze_p[NUM_TYPES]; /* free_cell sanity check */
+static bool t_ext_p[NUM_TYPES], t_exs_p[NUM_TYPES]; /* make sure internal types don't leak out */
+#endif
+
+static void init_types(void)
+{
+ for (int32_t i = 0; i < NUM_TYPES; i++)
+ {
+ t_number_p[i] = false;
+ t_small_real_p[i] = false;
+ t_real_p[i] = false;
+ t_rational_p[i] = false;
+ t_simple_p[i] = false;
+ t_structure_p[i] = false;
+ t_any_macro_p[i] = false;
+ t_any_closure_p[i] = false;
+ t_has_closure_let[i] = false;
+ t_sequence_p[i] = false;
+ t_mappable_p[i] = false;
+ t_vector_p[i] = false;
+ t_applicable_p[i] = false;
+ t_procedure_p[i] = false;
+ t_macro_setter_p[i] = false;
+ t_immutable_p[i] = true;
+#if S7_DEBUGGING
+ t_freeze_p[i] = false;
+ t_ext_p[i] = false;
+ t_exs_p[i] = false;
+#endif
+ }
+ t_number_p[T_INTEGER] = true; t_number_p[T_RATIO] = true; t_number_p[T_REAL] = true; t_number_p[T_COMPLEX] = true;
+ t_number_p[T_BIG_INTEGER] = true; t_number_p[T_BIG_RATIO] = true; t_number_p[T_BIG_REAL] = true; t_number_p[T_BIG_COMPLEX] = true;
+
+ t_rational_p[T_INTEGER] = true; t_rational_p[T_RATIO] = true;
+ t_rational_p[T_BIG_INTEGER] = true; t_rational_p[T_BIG_RATIO] = true;
+
+ t_small_real_p[T_INTEGER] = true; t_small_real_p[T_RATIO] = true; t_small_real_p[T_REAL] = true;
+
+ t_real_p[T_INTEGER] = true; t_real_p[T_RATIO] = true; t_real_p[T_REAL] = true;
+ t_real_p[T_BIG_INTEGER] = true; t_real_p[T_BIG_RATIO] = true; t_real_p[T_BIG_REAL] = true;
+
+ t_big_number_p[T_BIG_INTEGER] = true; t_big_number_p[T_BIG_RATIO] = true; t_big_number_p[T_BIG_REAL] = true; t_big_number_p[T_BIG_COMPLEX] = true;
+
+ t_structure_p[T_PAIR] = true;
+ t_structure_p[T_VECTOR] = true;
+ t_structure_p[T_HASH_TABLE] = true;
+ t_structure_p[T_SLOT] = true;
+ t_structure_p[T_LET] = true;
+ t_structure_p[T_ITERATOR] = true;
+ t_structure_p[T_C_OBJECT] = true; t_structure_p[T_C_POINTER] = true;
+
+ t_sequence_p[T_NIL] = true; t_sequence_p[T_PAIR] = true;
+ t_sequence_p[T_STRING] = true;
+ t_sequence_p[T_VECTOR] = true; t_sequence_p[T_INT_VECTOR] = true; t_sequence_p[T_FLOAT_VECTOR] = true; t_sequence_p[T_BYTE_VECTOR] = true;
+ t_sequence_p[T_HASH_TABLE] = true;
+ t_sequence_p[T_LET] = true;
+ t_sequence_p[T_C_OBJECT] = true; /* this assumes the object has a length method? */
+
+ t_mappable_p[T_PAIR] = true;
+ t_mappable_p[T_STRING] = true;
+ t_mappable_p[T_VECTOR] = true; t_mappable_p[T_INT_VECTOR] = true; t_mappable_p[T_FLOAT_VECTOR] = true; t_mappable_p[T_BYTE_VECTOR] = true;
+ t_mappable_p[T_HASH_TABLE] = true;
+ t_mappable_p[T_LET] = true;
+ t_mappable_p[T_C_OBJECT] = true;
+ t_mappable_p[T_ITERATOR] = true;
+ t_mappable_p[T_C_MACRO] = true;
+ t_mappable_p[T_MACRO] = true; t_mappable_p[T_MACRO_STAR] = true;
+ t_mappable_p[T_BACRO] = true; t_mappable_p[T_BACRO_STAR] = true;
+ t_mappable_p[T_CLOSURE] = true; t_mappable_p[T_CLOSURE_STAR] = true;
+
+ t_vector_p[T_VECTOR] = true; t_vector_p[T_INT_VECTOR] = true; t_vector_p[T_FLOAT_VECTOR] = true; t_vector_p[T_BYTE_VECTOR] = true;
+
+ t_applicable_p[T_PAIR] = true;
+ t_applicable_p[T_STRING] = true;
+ t_applicable_p[T_VECTOR] = true; t_applicable_p[T_INT_VECTOR] = true; t_applicable_p[T_FLOAT_VECTOR] = true; t_applicable_p[T_BYTE_VECTOR] = true;
+ t_applicable_p[T_HASH_TABLE] = true;
+ t_applicable_p[T_ITERATOR] = true;
+ t_applicable_p[T_LET] = true;
+ t_applicable_p[T_C_OBJECT] = true;
+ t_applicable_p[T_C_MACRO] = true;
+ t_applicable_p[T_MACRO] = true; t_applicable_p[T_MACRO_STAR] = true;
+ t_applicable_p[T_BACRO] = true; t_applicable_p[T_BACRO_STAR] = true;
+ t_applicable_p[T_SYNTAX] = true;
+ t_applicable_p[T_C_FUNCTION] = true; t_applicable_p[T_C_FUNCTION_STAR] = true; t_applicable_p[T_C_RST_NO_REQ_FUNCTION] = true;
+ t_applicable_p[T_CLOSURE] = true; t_applicable_p[T_CLOSURE_STAR] = true;
+ t_applicable_p[T_GOTO] = true; t_applicable_p[T_CONTINUATION] = true;
+
+ /* t_procedure_p[T_C_OBJECT] = true; */
+ t_procedure_p[T_C_FUNCTION] = true; t_procedure_p[T_C_FUNCTION_STAR] = true; t_procedure_p[T_C_RST_NO_REQ_FUNCTION] = true;
+ t_procedure_p[T_CLOSURE] = true; t_procedure_p[T_CLOSURE_STAR] = true;
+ t_procedure_p[T_GOTO] = true; t_procedure_p[T_CONTINUATION] = true;
+
+ for (int32_t i = T_CLOSURE; i < NUM_TYPES; i++) t_macro_setter_p[i] = true;
+ t_macro_setter_p[T_SYMBOL] = true; /* (slot setter); apparently T_LET and T_C_OBJECT are not possible here */
+
+ t_any_macro_p[T_C_MACRO] = true;
+ t_any_macro_p[T_MACRO] = true; t_any_macro_p[T_MACRO_STAR] = true;
+ t_any_macro_p[T_BACRO] = true; t_any_macro_p[T_BACRO_STAR] = true;
+
+ t_any_closure_p[T_CLOSURE] = true; t_any_closure_p[T_CLOSURE_STAR] = true;
+
+ t_has_closure_let[T_MACRO] = true; t_has_closure_let[T_MACRO_STAR] = true;
+ t_has_closure_let[T_BACRO] = true; t_has_closure_let[T_BACRO_STAR] = true;
+ t_has_closure_let[T_CLOSURE] = true; t_has_closure_let[T_CLOSURE_STAR] = true;
+
+ t_simple_p[T_NIL] = true;
+ /* t_simple_p[T_UNDEFINED] = true; */ /* only #<undefined> itself will work with eq? */
+ t_simple_p[T_EOF] = true;
+ t_simple_p[T_BOOLEAN] = true;
+ t_simple_p[T_CHARACTER] = true;
+ t_simple_p[T_SYMBOL] = true;
+ t_simple_p[T_SYNTAX] = true;
+ t_simple_p[T_C_MACRO] = true;
+ t_simple_p[T_C_FUNCTION] = true; t_simple_p[T_C_FUNCTION_STAR] = true; t_simple_p[T_C_RST_NO_REQ_FUNCTION] = true;
+ /* not completely sure about the next ones */
+ /* t_simple_p[T_LET] = true; */ /* this needs let_equal in member et al, 29-Nov-22 */
+ t_simple_p[T_INPUT_PORT] = true; t_simple_p[T_OUTPUT_PORT] = true;
+
+ t_immutable_p[T_PAIR] = false;
+ t_immutable_p[T_UNDEFINED] = false;
+ t_immutable_p[T_SYMBOL] = false;
+ t_immutable_p[T_STRING] = false;
+ t_immutable_p[T_C_OBJECT] = false; t_immutable_p[T_C_POINTER] = false;
+ t_immutable_p[T_VECTOR] = false; t_immutable_p[T_FLOAT_VECTOR] = false; t_immutable_p[T_INT_VECTOR] = false; t_immutable_p[T_BYTE_VECTOR] = false;
+ t_immutable_p[T_HASH_TABLE] = false;
+ t_immutable_p[T_LET] = false;
+ /* t_immutable_p[T_ITERATOR] = false; t_immutable_p[T_INPUT_PORT] = false; t_immutable_p[T_OUTPUT_PORT] = false; */ /* ?? */
+ t_immutable_p[T_SLOT] = false;
+ t_immutable_p[T_RANDOM_STATE] = false;
+
+#if S7_DEBUGGING
+ t_freeze_p[T_STRING] = true;
+ t_freeze_p[T_VECTOR] = true; t_freeze_p[T_FLOAT_VECTOR] = true; t_freeze_p[T_INT_VECTOR] = true; t_freeze_p[T_BYTE_VECTOR] = true;
+ t_freeze_p[T_UNDEFINED] = true;
+ t_freeze_p[T_C_OBJECT] = true;
+ t_freeze_p[T_HASH_TABLE] = true;
+ t_freeze_p[T_C_FUNCTION] = true;
+ t_freeze_p[T_CONTINUATION] = true;
+ t_freeze_p[T_INPUT_PORT] = true; t_freeze_p[T_OUTPUT_PORT] = true;
+#if WITH_GMP
+ t_freeze_p[T_BIG_INTEGER] = true; t_freeze_p[T_BIG_RATIO] = true; t_freeze_p[T_BIG_REAL] = true; t_freeze_p[T_BIG_COMPLEX] = true;
+ t_freeze_p[T_RANDOM_STATE] = true;
+#endif
+
+ t_ext_p[T_UNUSED] = true;
+ t_ext_p[T_STACK] = true;
+ t_ext_p[T_SLOT] = true;
+ t_ext_p[T_DYNAMIC_WIND] = true;
+ t_ext_p[T_CATCH] = true;
+ t_ext_p[T_COUNTER] = true;
+#if (!WITH_GMP)
+ t_ext_p[T_BIG_INTEGER] = true; t_ext_p[T_BIG_RATIO] = true; t_ext_p[T_BIG_REAL] = true; t_ext_p[T_BIG_COMPLEX] = true;
+#endif
+ t_exs_p[T_STACK] = true;
+ t_exs_p[T_DYNAMIC_WIND] = true;
+ t_exs_p[T_CATCH] = true;
+ t_exs_p[T_COUNTER] = true;
+#endif
+}
+
+#if WITH_HISTORY
+#define current_code(Sc) car(Sc->cur_code)
+#define set_current_code(Sc, Code) do {Sc->cur_code = cdr(Sc->cur_code); set_car(Sc->cur_code, T_Ext(Code));} while (0)
+#define replace_current_code(Sc, Code) set_car(Sc->cur_code, T_Ext(Code))
+#define mark_current_code(Sc) do {int32_t _i_; s7_pointer _p_; for (_p_ = Sc->cur_code, _i_ = 0; _i_ < Sc->history_size; _i_++, _p_ = cdr(_p_)) gc_mark(car(_p_));} while (0)
+#else
+#define current_code(Sc) Sc->cur_code
+#define set_current_code(Sc, Code) Sc->cur_code = T_Ext(Code)
+#define replace_current_code(Sc, Code) Sc->cur_code = T_Ext(Code)
+#define mark_current_code(Sc) gc_mark(Sc->cur_code)
+#endif
+
+#define full_type(p) ((p)->tf.u64_type)
+#define low_type_bits(p) ((p)->tf.bits.low_bits)
+#define TYPE_MASK 0xff
+
+#if S7_DEBUGGING
+ static void print_gc_info(s7_scheme *sc, s7_pointer obj, const char *func, int32_t line);
+ static s7_pointer check_ref_one(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2);
+ static s7_pointer check_ref_num(s7_pointer p, const char *func, int32_t line);
+ static s7_pointer check_ref_app(s7_pointer p, const char *func, int32_t line);
+ static s7_pointer check_ref_ext(s7_pointer p, const char *func, int32_t line);
+ static s7_pointer check_ref_exs(s7_pointer p, const char *func, int32_t line);
+ static s7_pointer check_ref_out(s7_pointer p, const char *func, int32_t line);
+ static s7_pointer check_ref_sln(s7_pointer p, const char *func, int32_t line);
+ static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line);
+ static s7_pointer check_opcode(s7_pointer p, const char *func, int32_t line);
+ static s7_pointer check_let_ref(s7_pointer p, uint64_t role, const char *func, int32_t line);
+ #define unchecked_type(p) ((p)->tf.type_field)
+#if WITH_GCC
+ #define type(p) ({uint8_t _t_; _t_ = (p)->tf.type_field; if ((!cur_sc->printing_gc_info) && ((_t_ == T_FREE) || (_t_ >= NUM_TYPES))) print_gc_info(cur_sc, p, __func__, __LINE__); _t_;})
+#else
+ #define type(p) (p)->tf.type_field
+#endif
+
+ #define set_full_type(p, f) set_type_1(p, f, __func__, __LINE__)
+ /* these check most s7_cell field references (and many type bits) for consistency */
+ #define T_App(P) check_ref_app(P, __func__, __LINE__) /* applicable or #f */
+ #define T_Arg(P) check_ref_arg(P, __func__, __LINE__) /* closure arg (list, symbol) */
+ #define T_BVc(P) check_ref_one(P, T_BYTE_VECTOR, __func__, __LINE__, "sweep", NULL)
+ #define T_Bgf(P) check_ref_one(P, T_BIG_RATIO, __func__, __LINE__, "sweep", NULL)
+ #define T_Bgi(P) check_ref_one(P, T_BIG_INTEGER, __func__, __LINE__, "sweep", NULL)
+ #define T_Bgr(P) check_ref_one(P, T_BIG_REAL, __func__, __LINE__, "sweep", NULL)
+ #define T_Bgz(P) check_ref_one(P, T_BIG_COMPLEX, __func__, __LINE__, "sweep", NULL)
+ #define T_CMac(P) check_ref_one(P, T_C_MACRO, __func__, __LINE__, NULL, NULL)
+ #define T_Cat(P) check_ref_one(P, T_CATCH, __func__, __LINE__, NULL, NULL)
+ #define T_Chr(P) check_ref_one(P, T_CHARACTER, __func__, __LINE__, NULL, NULL)
+ #define T_Clo(P) check_ref_clo(P, __func__, __LINE__) /* has closure let */
+ #define T_Cmp(P) check_ref_one(P, T_COMPLEX, __func__, __LINE__, NULL, NULL)
+ #define T_Con(P) check_ref_one(P, T_CONTINUATION, __func__, __LINE__, "sweep", "process_continuation")
+ #define T_Ctr(P) check_ref_one(P, T_COUNTER, __func__, __LINE__, NULL, NULL)
+ #define T_Dyn(P) check_ref_one(P, T_DYNAMIC_WIND, __func__, __LINE__, NULL, NULL)
+ #define T_Eof(P) check_ref_one(P, T_EOF, __func__, __LINE__, "sweep", NULL)
+ #define T_Exs(P) check_ref_exs(P, __func__, __LINE__) /* not an internal type, but #<unused> and slot are ok */
+ #define T_Ext(P) check_ref_ext(P, __func__, __LINE__) /* not an internal type */
+ #define T_Fnc(P) check_ref_fnc(P, __func__, __LINE__) /* any c_function|c_macro */
+ #define T_Frc(P) check_ref_two(P, T_RATIO, T_INTEGER, __func__, __LINE__, NULL, NULL)
+ #define T_Fst(P) check_ref_one(P, T_C_FUNCTION_STAR, __func__, __LINE__, NULL, NULL)
+ #define T_Fvc(P) check_ref_one(P, T_FLOAT_VECTOR, __func__, __LINE__, "sweep", NULL)
+ #define T_Got(P) check_ref_one(P, T_GOTO, __func__, __LINE__, NULL, NULL)
+ #define T_Hsh(P) check_ref_one(P, T_HASH_TABLE, __func__, __LINE__, "sweep", "free_hash_table")
+ #define T_Int(P) check_ref_one(P, T_INTEGER, __func__, __LINE__, NULL, NULL)
+ #define T_Itr(P) check_ref_one(P, T_ITERATOR, __func__, __LINE__, "sweep", "process_iterator")
+ #define T_Ivc(P) check_ref_one(P, T_INT_VECTOR, __func__, __LINE__, "sweep", NULL)
+ #define T_Key(P) check_ref_key(P, __func__, __LINE__) /* keyword */
+ #define T_Let(P) check_ref_one(P, T_LET, __func__, __LINE__, NULL, NULL) /* let+rootlet but not nil */
+ #define T_Lst(P) check_ref_two(P, T_PAIR, T_NIL, __func__, __LINE__, "gc", NULL)
+ #define T_Mac(P) check_ref_mac(P, __func__, __LINE__) /* a non-C macro */
+ #define T_Met(P) check_ref_met(P, __func__, __LINE__) /* anything that might contain a method */
+ #define T_Nmv(P) check_ref_nmv(P, __func__, __LINE__) /* not multiple-value, not free, only affects slot values */
+ #define T_Num(P) check_ref_num(P, __func__, __LINE__) /* any number (not bignums) */
+ #define T_Nvc(P) check_ref_one(P, T_VECTOR, __func__, __LINE__, "sweep", NULL)
+ #define T_Obj(P) check_ref_one(P, T_C_OBJECT, __func__, __LINE__, "sweep", "s7_c_object_value")
+ #define T_Op(P) check_opcode(P, __func__, __LINE__)
+ #define T_Out(P) check_ref_out(P, __func__, __LINE__) /* let or NULL */
+ #define T_Pair(P) check_ref_one(P, T_PAIR, __func__, __LINE__, NULL, NULL)
+ #define T_Pcs(P) check_ref_two(P, T_PAIR, T_CLOSURE_STAR, __func__, __LINE__, NULL, NULL)
+ #define T_Pos(P) check_nref(P, __func__, __LINE__) /* not free */
+ #define T_Prc(P) check_ref_prc(P, __func__, __LINE__) /* any procedure (3-arg setters) or #f|#t */
+ #define T_Pri(P) check_ref_pri(P, __func__, __LINE__) /* input_port or #f */
+ #define T_Pro(P) check_ref_pro(P, __func__, __LINE__) /* output_port or #f */
+ #define T_Prt(P) check_ref_prt(P, __func__, __LINE__) /* input|output_port */
+ #define T_Ptr(P) check_ref_one(P, T_C_POINTER, __func__, __LINE__, NULL, NULL)
+ #define T_Ran(P) check_ref_one(P, T_RANDOM_STATE, __func__, __LINE__, NULL, NULL)
+ #define T_Rel(P) check_ref_one(P, T_REAL, __func__, __LINE__, NULL, NULL)
+ #define T_Seq(P) check_ref_seq(P, __func__, __LINE__) /* any sequence or structure */
+ #define T_Sld(P) check_ref_two(P, T_SLOT, T_UNDEFINED, __func__, __LINE__, NULL, NULL)
+ #define T_Sln(P) check_ref_sln(P, __func__, __LINE__) /* slot or nil or NULL */
+ #define T_Slt(P) check_ref_one(P, T_SLOT, __func__, __LINE__, NULL, NULL)
+ #define T_Stk(P) check_ref_one(P, T_STACK, __func__, __LINE__, NULL, NULL)
+ #define T_Str(P) check_ref_one(P, T_STRING, __func__, __LINE__, "sweep", NULL)
+ #define T_SVec(P) check_ref_svec(P, __func__, __LINE__) /* subvector */
+ #define T_Sym(P) check_ref_one(P, T_SYMBOL, __func__, __LINE__, "sweep", "remove_gensym_from_symbol_table")
+ #define T_Syn(P) check_ref_one(P, T_SYNTAX, __func__, __LINE__, NULL, NULL)
+ #define T_Undf(P) check_ref_one(P, T_UNDEFINED, __func__, __LINE__, "sweep", NULL)
+ #define T_Vec(P) check_ref_vec(P, __func__, __LINE__) /* any vector */
+#else
+ /* if not debugging, all those checks go away */
+ #define T_App(P) P
+ #define T_Arg(P) P
+ #define T_BVc(P) P
+ #define T_Bgf(P) P
+ #define T_Bgi(P) P
+ #define T_Bgr(P) P
+ #define T_Bgz(P) P
+ #define T_CMac(P) P
+ #define T_Cat(P) P
+ #define T_Chr(P) P
+ #define T_Clo(P) P
+ #define T_Cmp(P) P
+ #define T_Con(P) P
+ #define T_Ctr(P) P
+ #define T_Dyn(P) P
+ #define T_Eof(P) P
+ #define T_Exs(P) P
+ #define T_Ext(P) P
+ #define T_Fnc(P) P
+ #define T_Frc(P) P
+ #define T_Fst(P) P
+ #define T_Fvc(P) P
+ #define T_Got(P) P
+ #define T_Hsh(P) P
+ #define T_Int(P) P
+ #define T_Itr(P) P
+ #define T_Ivc(P) P
+ #define T_Key(P) P
+ #define T_Let(P) P
+ #define T_Lst(P) P
+ #define T_Mac(P) P
+ #define T_Met(P) P
+ #define T_Nmv(P) P
+ #define T_Num(P) P
+ #define T_Nvc(P) P
+ #define T_Obj(P) P
+ #define T_Op(P) P
+ #define T_Out(P) P
+ #define T_Pair(P) P
+ #define T_Pcs(P) P
+ #define T_Pos(P) P
+ #define T_Prc(P) P
+ #define T_Pri(P) P
+ #define T_Pro(P) P
+ #define T_Prt(P) P
+ #define T_Ptr(P) P
+ #define T_Ran(P) P
+ #define T_Rel(P) P
+ #define T_Seq(P) P
+ #define T_Sld(P) P
+ #define T_Sln(P) P
+ #define T_Slt(P) P
+ #define T_Stk(P) P
+ #define T_Str(P) P
+ #define T_SVec(P) P
+ #define T_Sym(P) P
+ #define T_Syn(P) P
+ #define T_Undf(P) P
+ #define T_Vec(P) P
+
+ #define unchecked_type(p) ((p)->tf.type_field)
+ #define type(p) ((p)->tf.type_field)
+ #define set_full_type(p, f) full_type(p) = f
+#endif
+#define signed_type(p) (p)->tf.s64_type
+#define clear_type(p) full_type(p) = T_FREE
+
+#define is_number(P) t_number_p[type(P)]
+#define is_small_real(P) t_small_real_p[type(P)]
+#define is_real(P) t_real_p[type(P)]
+#define is_rational(P) t_rational_p[type(P)]
+#define is_big_number(p) t_big_number_p[type(p)]
+#define is_t_integer(p) (type(p) == T_INTEGER)
+#define is_t_ratio(p) (type(p) == T_RATIO)
+#define is_t_real(p) (type(p) == T_REAL)
+#define is_t_complex(p) (type(p) == T_COMPLEX)
+#define is_t_big_integer(p) (type(p) == T_BIG_INTEGER)
+#define is_t_big_ratio(p) (type(p) == T_BIG_RATIO)
+#define is_t_big_real(p) (type(p) == T_BIG_REAL)
+#define is_t_big_complex(p) (type(p) == T_BIG_COMPLEX)
+
+#define is_boolean(p) (type(p) == T_BOOLEAN)
+
+#define is_free(p) (type(p) == T_FREE)
+#define is_free_and_clear(p) (full_type(p) == T_FREE) /* protect against new_cell in-between states? */
+#define is_simple(P) t_simple_p[type(P)] /* eq? */
+#define has_structure(P) ((t_structure_p[type(P)]) && ((!is_t_vector(P)) || (!has_simple_elements(P))))
+
+#define is_any_macro(P) t_any_macro_p[type(P)]
+#define is_any_closure(P) t_any_closure_p[type(P)]
+#define is_any_procedure(P) (type(P) >= T_CLOSURE)
+#define has_closure_let(P) t_has_closure_let[type(P)]
+
+#define is_simple_sequence(P) (t_sequence_p[type(P)])
+#define is_sequence(P) ((t_sequence_p[type(P)]) || (has_methods(P)))
+#define is_mutable_sequence(P) (((t_sequence_p[type(P)]) || (has_methods(P))) && (!is_immutable(P)))
+#define is_sequence_or_iterator(P) ((t_sequence_p[type(P)]) || (is_iterator(P)))
+#define is_mappable(P) (t_mappable_p[type(P)])
+#define is_applicable(P) (t_applicable_p[type(P)])
+/* this misses #() which is not applicable to anything, and "", and inapplicable c-objects like random-state */
+#define is_procedure(p) ((t_procedure_p[type(p)]) || ((is_c_object(p)) && (is_safe_procedure(p))))
+#define is_t_procedure(p) (t_procedure_p[type(p)])
+
+/* the layout of these bits does matter in several cases -- don't shadow SYNTACTIC_PAIR and OPTIMIZED_PAIR */
+
+#define set_type_bit(p, b) full_type(p) |= (b)
+#define clear_type_bit(p, b) full_type(p) &= (~(b))
+#define has_type_bit(p, b) ((full_type(p) & (b)) != 0)
+
+#define set_low_type_bit(p, b) low_type_bits(p) |= (b)
+#define clear_low_type_bit(p, b) low_type_bits(p) &= (~(b))
+#define has_low_type_bit(p, b) ((low_type_bits(p) & (b)) != 0)
+
+#define set_mid_type_bit(p, b) (p)->tf.bits.mid_bits |= (b)
+#define clear_mid_type_bit(p, b) (p)->tf.bits.mid_bits &= (~(b))
+#define has_mid_type_bit(p, b) (((p)->tf.bits.mid_bits & (b)) != 0)
+
+#define set_high_type_bit(p, b) (p)->tf.bits.high_bits |= (b)
+#define clear_high_type_bit(p, b) (p)->tf.bits.high_bits &= (~(b))
+#define has_high_type_bit(p, b) (((p)->tf.bits.high_bits & (b)) != 0)
+
+/* -------- low type bits -------- */
+#define T_SYNTACTIC (1 << (8 + 1))
+#define is_symbol_and_syntactic(p) (low_type_bits(T_Ext(p)) == (uint16_t)(T_SYMBOL | T_SYNTACTIC))
+#define is_syntactic_symbol(p) has_low_type_bit(T_Sym(p), T_SYNTACTIC)
+#define is_syntactic_pair(p) has_low_type_bit(T_Pair(p), T_SYNTACTIC)
+#define clear_syntactic(p) clear_low_type_bit(T_Pair(p), T_SYNTACTIC)
+#define set_syntactic_pair(p) full_type(T_Pair(p)) = (T_PAIR | T_SYNTACTIC | (full_type(p) & (0xffffffffffff0000 & ~T_OPTIMIZED))) /* used only in pair_set_syntax_op */
+/* this marks symbols that represent syntax objects, it should be in the second byte */
+
+#define T_SIMPLE_ARG_DEFAULTS (1 << (8 + 2))
+#define lambda_has_simple_defaults(p) has_low_type_bit(T_Pair(closure_body(p)), T_SIMPLE_ARG_DEFAULTS)
+#define lambda_set_simple_defaults(p) set_low_type_bit(T_Pair(p), T_SIMPLE_ARG_DEFAULTS)
+/* are all lambda* default values simple? This is set on closure_body, so it doesn't mess up closure_is_ok_1 */
+
+#define T_LIST_IN_USE T_SIMPLE_ARG_DEFAULTS
+#define list_is_in_use(p) has_low_type_bit(T_Pair(p), T_LIST_IN_USE)
+#define set_list_in_use(p) set_low_type_bit(T_Pair(p), T_LIST_IN_USE)
+#define clear_list_in_use(p) do {clear_low_type_bit(T_Pair(p), T_LIST_IN_USE); sc->current_safe_list = 0;} while (0)
+
+#define T_ONE_FORM T_SIMPLE_ARG_DEFAULTS
+#define set_closure_has_one_form(p) set_low_type_bit(T_Clo(p), T_ONE_FORM)
+#define T_MULTIFORM (1 << (8 + 0))
+#define set_closure_has_multiform(p) set_low_type_bit(T_Clo(p), T_MULTIFORM)
+#define T_ONE_FORM_FX_ARG (T_ONE_FORM | T_MULTIFORM)
+#define set_closure_one_form_fx_arg(p) set_low_type_bit(T_Clo(p), T_ONE_FORM_FX_ARG)
+/* can't use T_HAS_FX here because closure_is_ok wants to examine low_type_bits */
+
+#define T_OPTIMIZED (1 << (8 + 3))
+#define set_optimized(p) set_low_type_bit(T_Pair(p), T_OPTIMIZED)
+#define clear_optimized(p) clear_low_type_bit(T_Pair(p), T_OPTIMIZED | T_SYNTACTIC | T_HAS_FX | T_HAS_FN)
+#define is_optimized(p) (low_type_bits(T_Ext(p)) == (uint16_t)(T_PAIR | T_OPTIMIZED))
+/* optimizer flag for an expression that has optimization info, it should be in the second byte */
+
+#define T_SCOPE_SAFE T_OPTIMIZED
+#define is_scope_safe(p) has_low_type_bit(T_Fnc(p), T_SCOPE_SAFE)
+#define set_scope_safe(p) set_low_type_bit(T_Fnc(p), T_SCOPE_SAFE)
+
+#define T_SAFE_CLOSURE (1 << (8 + 4))
+#define is_safe_closure(p) has_low_type_bit(T_Clo(p), T_SAFE_CLOSURE)
+#define set_safe_closure(p) set_low_type_bit(T_Clo(p), T_SAFE_CLOSURE)
+#define is_safe_closure_body(p) has_low_type_bit(T_Pair(p), T_SAFE_CLOSURE)
+#define set_safe_closure_body(p) set_low_type_bit(T_Pair(p), T_SAFE_CLOSURE)
+#define clear_safe_closure_body(p) clear_low_type_bit(T_Pair(p), T_SAFE_CLOSURE)
+
+/* optimizer flag for a closure body that is completely simple (every expression is safe)
+ * set_safe_closure happens in define_funchcecked letrec_setup_closures etc, clear only in procedure_source, bits only here
+ * this has to be separate from T_SAFE_PROCEDURE, and should be in the second byte (closure_is_ok_1 checks low_type_bits).
+ * define -> optimize_lambda sets safe -> define_funchecked -> make_funclet for the let
+ * similarly, named let -> optimize_lambda, then let creates the let if safe
+ * thereafter, optimizer uses OP_SAFE_CLOSURE* which calls update_let*
+ */
+
+#define T_DONT_EVAL_ARGS (1 << (8 + 5))
+#define dont_eval_args(p) has_low_type_bit(T_Ext(p), T_DONT_EVAL_ARGS)
+/* this marks things that don't evaluate their arguments */
+
+#define T_EXPANSION (1 << (8 + 6))
+#define is_expansion(p) has_low_type_bit(T_Ext(p), T_EXPANSION)
+#define clear_expansion(p) clear_low_type_bit(T_Sym(p), T_EXPANSION)
+/* this marks the symbol and its run-time macro value, distinguishing it from an ordinary macro */
+
+#define T_MULTIPLE_VALUE (1 << (8 + 7))
+#define is_multiple_value(p) has_low_type_bit(T_Exs(p), T_MULTIPLE_VALUE) /* not T_Ext -- can be a slot */
+#if S7_DEBUGGING
+#define set_multiple_value(p) do {if (!in_heap(p)) {fprintf(stderr, "%s[%d] (from set_multiple_value): arg not in heap\n", __func__, __LINE__); abort();} set_low_type_bit(T_Pair(p), T_MULTIPLE_VALUE);} while (0)
+#else
+#define set_multiple_value(p) set_low_type_bit(T_Pair(p), T_MULTIPLE_VALUE)
+#endif
+#define clear_multiple_value(p) clear_low_type_bit(T_Pair(p), T_MULTIPLE_VALUE)
+#define multiple_value(p) p
+/* this bit marks a list (from "values") that is waiting for a chance to be spliced into its caller's argument list */
+
+#define T_MATCHED T_MULTIPLE_VALUE
+#define is_matched_pair(p) has_low_type_bit(T_Pair(p), T_MATCHED)
+#define clear_match_pair(p) clear_low_type_bit(T_Pair(p), T_MATCHED)
+#define set_match_pair(p) set_low_type_bit(T_Pair(p), T_MATCHED)
+#define set_match_symbol(p) set_low_type_bit(T_Sym(p), T_MATCHED)
+#define is_matched_symbol(p) has_low_type_bit(T_Sym(p), T_MATCHED)
+#define clear_match_symbol(p) clear_low_type_bit(T_Sym(p), T_MATCHED)
+
+
+/* -------- mid type bits -------- */
+#define T_GLOBAL (1 << (16 + 0))
+#define T_MID_GLOBAL (1 << 0)
+#define T_LOCAL (1 << (16 + 4))
+#define T_MID_LOCAL (1 << 4)
+#define is_global(p) has_mid_type_bit(T_Sym(p), T_MID_GLOBAL)
+#define set_global(p) do {if (!has_mid_type_bit(T_Sym(p), T_MID_LOCAL)) set_mid_type_bit(p, T_MID_GLOBAL);} while (0)
+/* T_LOCAL marks a symbol that has been used locally */
+/* T_GLOBAL marks something defined (bound) at the top-level, and never defined locally */
+
+#define REPORT_ROOTLET_REDEF 0
+#if REPORT_ROOTLET_REDEF
+ /* to find who is stomping on our symbols: */
+ static void set_local_1(s7_scheme *sc, s7_pointer symbol, const char *func, int32_t line);
+ #define set_local(Symbol) set_local_1(sc, Symbol, __func__, __LINE__)
+#else
+ #define set_local(p) full_type(T_Sym(p)) = ((full_type(p) | T_LOCAL) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC))
+#endif
+
+#define T_LOW_COUNT T_MID_LOCAL
+#define has_low_count(p) has_mid_type_bit(T_Pair(p), T_LOW_COUNT)
+#define set_has_low_count(p) set_mid_type_bit(T_Pair(p), T_LOW_COUNT)
+
+#define T_TC T_MID_LOCAL
+#define has_tc(p) has_mid_type_bit(T_Pair(p), T_TC)
+#define set_has_tc(p) set_mid_type_bit(T_Pair(p), T_TC)
+
+#define T_UNSAFE_DO T_MID_GLOBAL
+#define is_unsafe_do(p) has_mid_type_bit(T_Pair(p), T_UNSAFE_DO)
+#define set_unsafe_do(p) set_mid_type_bit(T_Pair(p), T_UNSAFE_DO)
+/* marks do-loops that resist optimization */
+
+#define T_DOX_SLOT1 T_MID_GLOBAL
+#define has_dox_slot1(p) has_mid_type_bit(T_Let(p), T_DOX_SLOT1)
+#define set_has_dox_slot1(p) set_mid_type_bit(T_Let(p), T_DOX_SLOT1)
+/* marks a let that includes the dox_slot1 */
+
+#define T_COLLECTED (1 << (16 + 1))
+#define T_MID_COLLECTED (1 << 1)
+#define is_collected(p) has_mid_type_bit(T_Seq(p), T_MID_COLLECTED)
+#define is_collected_unchecked(p) has_mid_type_bit(p, T_MID_COLLECTED)
+#define set_collected(p) set_mid_type_bit(T_Seq(p), T_MID_COLLECTED)
+/* #define clear_collected(p) clear_mid_type_bit(T_Seq(p), T_MID_COLLECTED) */
+/* this is a transient flag used by the printer to catch cycles. It affects only objects that have structure.
+ * We can't use a low bit (bit 7 for example), because collect_shared_info inspects the object's type.
+ */
+
+#define T_LOCATION (1 << (16 + 2))
+#define T_MID_LOCATION (1 << 2)
+#define has_location(p) has_mid_type_bit(T_Pair(p), T_MID_LOCATION)
+#define set_has_location(p) set_mid_type_bit(T_Pair(p), T_MID_LOCATION)
+/* pair in question has line/file/position info added during read, or the environment has function placement info
+ * this bit should not be in the first byte -- SYNTACTIC_PAIR ignores it.
+ */
+
+#define T_LOADER_PORT T_MID_LOCATION
+#define is_loader_port(p) has_mid_type_bit(T_Pri(p), T_LOADER_PORT)
+#define set_loader_port(p) set_mid_type_bit(T_Pri(p), T_LOADER_PORT)
+#define clear_loader_port(p) clear_mid_type_bit(T_Pri(p), T_LOADER_PORT)
+/* this bit marks a port used by the loader so that random load-time reads do not screw up the load process */
+
+#define T_HAS_SETTER T_MID_LOCATION
+#define slot_has_setter(p) has_mid_type_bit(T_Slt(p), T_HAS_SETTER)
+#define slot_set_has_setter(p) set_mid_type_bit(T_Slt(p), T_HAS_SETTER)
+/* marks a slot that has a setter or symbol that might have a setter */
+
+#define T_WITH_LET_LET T_MID_LOCATION
+#define is_with_let_let(p) has_mid_type_bit(T_Let(p), T_WITH_LET_LET)
+#define set_with_let_let(p) set_mid_type_bit(T_Let(p), T_WITH_LET_LET)
+/* marks a let that is the argument to with-let (but not rootlet in its uses) */
+
+#define T_SIMPLE_DEFAULTS T_MID_LOCATION
+#define c_func_has_simple_defaults(p) has_mid_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS)
+#define c_func_set_simple_defaults(p) set_mid_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS)
+#define c_func_clear_simple_defaults(p) clear_mid_type_bit(T_Fst(p), T_SIMPLE_DEFAULTS)
+/* flag c_func_star arg defaults that need GC protection */
+
+#define T_NO_SETTER T_MID_LOCATION
+#define closure_no_setter(p) has_mid_type_bit(T_Clo(p), T_NO_SETTER)
+#define closure_set_no_setter(p) set_mid_type_bit(T_Clo(p), T_NO_SETTER)
+
+#define T_SHARED (1 << (16 + 3))
+#define T_MID_SHARED (1 << 3)
+#define is_shared(p) has_mid_type_bit(T_Seq(p), T_MID_SHARED)
+#define set_shared(p) set_mid_type_bit(T_Seq(p), T_MID_SHARED)
+#define is_collected_or_shared(p) has_mid_type_bit(p, T_MID_COLLECTED | T_MID_SHARED)
+#define clear_collected_and_shared(p) clear_mid_type_bit(p, T_MID_COLLECTED | T_MID_SHARED) /* this can clear free cells = calloc */
+/* T_LOCAL is bit 4 mid-wise) */
+
+#define T_SAFE_PROCEDURE (1 << (16 + 5))
+#define T_MID_SAFE_PROCEDURE (1 << 5)
+#define is_safe_procedure(p) has_mid_type_bit(T_App(p), T_MID_SAFE_PROCEDURE)
+#define is_safe_or_scope_safe_procedure(p) ((full_type(T_Fnc(p)) & (T_SCOPE_SAFE | T_SAFE_PROCEDURE)) != 0) /* T_SCOPE_SAFE is a low_type bit */
+/* applicable objects that do not return or modify their arg list directly (no :rest arg in particular),
+ * and that can't call themselves either directly or via s7_call, and that don't mess with the stack.
+ */
+
+#define T_CHECKED (1 << (16 + 6))
+#define T_MID_CHECKED (1 << 6)
+#define set_checked(p) set_mid_type_bit(T_Pair(p), T_MID_CHECKED)
+#define is_checked(p) has_mid_type_bit(T_Pair(p), T_MID_CHECKED)
+#define clear_checked(p) clear_mid_type_bit(T_Pair(p), T_MID_CHECKED)
+#define set_checked_slot(p) set_mid_type_bit(T_Slt(p), T_MID_CHECKED)
+#define is_checked_slot(p) has_mid_type_bit(T_Slt(p), T_MID_CHECKED)
+#define clear_checked_slot(p) clear_mid_type_bit(T_Slt(p), T_MID_CHECKED)
+
+#define T_ALL_INTEGER T_MID_CHECKED
+#define is_all_integer(p) has_mid_type_bit(T_Sym(p), T_ALL_INTEGER)
+#define set_all_integer(p) set_mid_type_bit(T_Sym(p), T_ALL_INTEGER)
+
+#define T_UNSAFE (1 << (16 + 7))
+#define T_MID_UNSAFE (1 << 7)
+#define set_unsafe(p) set_mid_type_bit(T_Pair(p), T_MID_UNSAFE)
+#define set_unsafely_optimized(p) full_type(T_Pair(p)) = (full_type(p) | T_UNSAFE | T_OPTIMIZED) /* T_OPTIMIZED is a low_type bit */
+#define is_unsafe(p) has_mid_type_bit(T_Pair(p), T_MID_UNSAFE)
+#define clear_unsafe(p) clear_mid_type_bit(T_Pair(p), T_MID_UNSAFE)
+#define is_safely_optimized(p) ((full_type(T_Pair(p)) & (T_OPTIMIZED | T_UNSAFE)) == T_OPTIMIZED)
+/* optimizer flag saying "this expression is not completely self-contained. It might involve the stack, etc" */
+
+#define T_CLEAN_SYMBOL T_MID_UNSAFE
+#define is_clean_symbol(p) has_mid_type_bit(T_Sym(p), T_CLEAN_SYMBOL)
+#define set_clean_symbol(p) set_mid_type_bit(T_Sym(p), T_CLEAN_SYMBOL)
+/* set if we know the symbol name can be printed without quotes (slashification) */
+
+#define T_HAS_STEPPER T_MID_UNSAFE
+#define has_stepper(p) has_mid_type_bit(T_Slt(p), T_HAS_STEPPER)
+#define set_has_stepper(p) set_mid_type_bit(T_Slt(p), T_HAS_STEPPER)
+
+#define T_DOX_SLOT2 T_MID_UNSAFE
+#define has_dox_slot2(p) has_mid_type_bit(T_Let(p), T_DOX_SLOT2)
+#define set_has_dox_slot2(p) set_mid_type_bit(T_Let(p), T_DOX_SLOT2)
+/* marks a let that includes the dox_slot2 */
+
+#define T_IMMUTABLE (1 << (16 + 8))
+#define T_MID_IMMUTABLE (1 << 8)
+#define is_immutable(p) has_mid_type_bit(T_Exs(p), T_MID_IMMUTABLE)
+#define set_immutable(p) set_mid_type_bit(T_Exs(p), T_MID_IMMUTABLE) /* can be a slot, so not T_Ext */
+#define set_immutable_let(p) set_mid_type_bit(T_Let(p), T_MID_IMMUTABLE)
+#define set_immutable_slot(p) set_mid_type_bit(T_Slt(p), T_MID_IMMUTABLE)
+#define is_immutable_port(p) has_mid_type_bit(T_Prt(p), T_MID_IMMUTABLE)
+#define is_immutable_symbol(p) has_mid_type_bit(T_Sym(p), T_MID_IMMUTABLE)
+#define is_immutable_slot(p) has_mid_type_bit(T_Slt(p), T_MID_IMMUTABLE)
+#define is_immutable_pair(p) has_mid_type_bit(T_Pair(p), T_MID_IMMUTABLE)
+#define is_immutable_vector(p) has_mid_type_bit(T_Vec(p), T_MID_IMMUTABLE)
+#define is_immutable_string(p) has_mid_type_bit(T_Str(p), T_MID_IMMUTABLE)
+#define is_immutable_hash_table(p) has_mid_type_bit(T_Hsh(p), T_MID_IMMUTABLE)
+#define is_immutable_let(p) has_mid_type_bit(T_Let(p), T_MID_IMMUTABLE)
+/* T_IMMUTABLE is compatible with T_MUTABLE -- the latter is an internal bit for locally mutable numbers */
+
+#define T_SETTER (1 << (16 + 9))
+#define T_MID_SETTER (1 << 9)
+#define set_is_setter(p) set_mid_type_bit(T_Sym(p), T_MID_SETTER)
+#define is_setter(p) has_mid_type_bit(T_Sym(p), T_MID_SETTER)
+/* optimizer flag for a procedure that sets some variable (set-car! for example) */
+
+#define T_ALLOW_OTHER_KEYS T_MID_SETTER
+#define set_allow_other_keys(p) set_mid_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS)
+#define allows_other_keys(p) has_mid_type_bit(T_Pair(p), T_ALLOW_OTHER_KEYS)
+#define c_function_set_allow_other_keys(p) set_mid_type_bit(T_Fst(p), T_ALLOW_OTHER_KEYS)
+#define c_function_allows_other_keys(p) has_mid_type_bit(T_Fst(p), T_ALLOW_OTHER_KEYS)
+/* marks arglist (or c_function*) that allows keyword args other than those in the parameter list;
+ * we can't allow (define* (f :allow-other-keys)...) because there's only one nil, and besides, it does say "other".
+ */
+
+#define T_LET_REMOVED T_MID_SETTER
+#define let_set_removed(p) set_mid_type_bit(T_Let(p), T_LET_REMOVED)
+#define let_removed(p) has_mid_type_bit(T_Let(p), T_LET_REMOVED)
+/* mark lets that have been removed from the heap or checked for that possibility */
+
+#define T_HAS_EXPRESSION T_MID_SETTER
+#define slot_set_has_expression(p) set_mid_type_bit(T_Slt(p), T_HAS_EXPRESSION)
+#define slot_has_expression(p) has_mid_type_bit(T_Slt(p), T_HAS_EXPRESSION)
+
+#define T_MUTABLE (1 << (16 + 10))
+#define T_MID_MUTABLE (1 << 10)
+#define is_mutable_number(p) has_mid_type_bit(p, T_MID_MUTABLE)
+#define is_mutable_integer(p) has_mid_type_bit(T_Int(p), T_MID_MUTABLE)
+#define clear_mutable_number(p) clear_mid_type_bit(p, T_MID_MUTABLE)
+#define clear_mutable_integer(p) clear_mid_type_bit(T_Int(p), T_MID_MUTABLE)
+/* used for mutable numbers, can occur with T_IMMUTABLE (outside view vs inside) */
+
+#define T_HAS_KEYWORD T_MID_MUTABLE
+#define has_keyword(p) has_mid_type_bit(T_Sym(p), T_HAS_KEYWORD)
+#define set_has_keyword(p) set_mid_type_bit(T_Sym(p), T_HAS_KEYWORD)
+
+#define T_MARK_SEQ T_MID_MUTABLE
+#define is_mark_seq(p) has_mid_type_bit(T_Itr(p), T_MARK_SEQ)
+#define set_mark_seq(p) set_mid_type_bit(T_Itr(p), T_MARK_SEQ)
+/* used in iterators for GC mark of sequence */
+
+#define T_HAS_LOOP_END T_MID_MUTABLE
+#define has_loop_end(p) has_mid_type_bit(T_Slt(p), T_HAS_LOOP_END)
+#define loop_end_fits(Slot, Len) ((has_loop_end(Slot)) && (denominator(slot_value(Slot)) <= Len))
+#define set_has_loop_end(p) set_mid_type_bit(T_Slt(p), T_HAS_LOOP_END)
+/* marks a slot that holds a do-loop's step-or-end variable, numerator=current, denominator=end */
+
+#define T_NO_CELL_OPT T_MID_MUTABLE
+#define set_no_cell_opt(p) set_mid_type_bit(T_Pair(p), T_NO_CELL_OPT)
+#define no_cell_opt(p) has_mid_type_bit(T_Pair(p), T_NO_CELL_OPT)
+
+#define T_IS_ELIST T_MUTABLE
+#define T_MID_IS_ELIST T_MID_MUTABLE
+#define set_is_elist(p) set_mid_type_bit(T_Lst(p), T_MID_IS_ELIST)
+#define is_elist(p) has_mid_type_bit(T_Lst(p), T_MID_IS_ELIST)
+
+#define T_NO_INT_OPT T_MID_SETTER
+#define set_no_int_opt(p) set_mid_type_bit(T_Pair(p), T_NO_INT_OPT)
+#define no_int_opt(p) has_mid_type_bit(T_Pair(p), T_NO_INT_OPT)
+
+#define T_NO_FLOAT_OPT T_MID_UNSAFE
+#define set_no_float_opt(p) set_mid_type_bit(T_Pair(p), T_NO_FLOAT_OPT)
+#define no_float_opt(p) has_mid_type_bit(T_Pair(p), T_NO_FLOAT_OPT)
+
+#define T_INTEGER_KEYS T_MID_SETTER
+#define set_has_integer_keys(p) set_mid_type_bit(T_Pair(p), T_INTEGER_KEYS)
+#define has_integer_keys(p) has_mid_type_bit(T_Pair(p), T_INTEGER_KEYS)
+
+#define T_SAFE_STEPPER (1 << (16 + 11))
+#define T_MID_SAFE_STEPPER (1 << 11)
+#define is_safe_stepper(p) has_mid_type_bit(T_Slt(p), T_MID_SAFE_STEPPER)
+#define set_safe_stepper(p) set_mid_type_bit(T_Slt(p), T_MID_SAFE_STEPPER)
+#define clear_safe_stepper(p) clear_mid_type_bit(T_Slt(p), T_MID_SAFE_STEPPER)
+#define is_safe_stepper_expr(p) has_mid_type_bit(T_Pair(p), T_MID_SAFE_STEPPER)
+#define set_safe_stepper_expr(p) set_mid_type_bit(T_Pair(p), T_MID_SAFE_STEPPER)
+
+#define T_NO_BOOL_OPT T_MID_SAFE_STEPPER
+#define set_no_bool_opt(p) set_mid_type_bit(T_Pair(p), T_NO_BOOL_OPT)
+#define no_bool_opt(p) has_mid_type_bit(T_Pair(p), T_NO_BOOL_OPT)
+
+#define T_NUMBER_NAME T_MID_SAFE_STEPPER
+#define has_number_name(p) has_mid_type_bit(T_Num(p), T_NUMBER_NAME)
+#define set_has_number_name(p) set_mid_type_bit(T_Num(p), T_NUMBER_NAME)
+/* marks numbers that have a saved version of their string representation; this only matters in teq.scm, maybe tread.scm */
+
+#define T_MAYBE_SAFE T_MID_SAFE_STEPPER
+#define is_maybe_safe(p) has_mid_type_bit(T_Fnc(p), T_MAYBE_SAFE)
+#define set_maybe_safe(p) set_mid_type_bit(T_Fnc(p), T_MAYBE_SAFE)
+
+#define T_PAIR_MACRO T_MID_SAFE_STEPPER
+#define has_pair_macro(p) has_mid_type_bit(T_Mac(p), T_PAIR_MACRO)
+#define set_has_pair_macro(p) set_mid_type_bit(T_Mac(p), T_PAIR_MACRO)
+
+#define T_WEAK_HASH T_MID_SAFE_STEPPER
+#define set_weak_hash_table(p) set_mid_type_bit(T_Hsh(p), T_WEAK_HASH)
+#define is_weak_hash_table(p) has_mid_type_bit(T_Hsh(p), T_WEAK_HASH)
+
+#define T_ALL_FLOAT T_MID_SAFE_STEPPER
+#define is_all_float(p) has_mid_type_bit(T_Sym(p), T_ALL_FLOAT)
+#define set_all_float(p) set_mid_type_bit(T_Sym(p), T_ALL_FLOAT)
+#define set_all_integer_and_float(p) set_mid_type_bit(T_Sym(p), (T_ALL_INTEGER | T_ALL_FLOAT))
+
+#define T_COPY_ARGS (1 << (16 + 12))
+#define T_MID_COPY_ARGS (1 << 12)
+#define needs_copied_args(p) has_mid_type_bit(T_Ext(p), T_MID_COPY_ARGS) /* set via explicit T_COPY_ARGS, on T_Pos see s7_apply_function */
+#define set_needs_copied_args(p) set_mid_type_bit(T_Pair(p), T_MID_COPY_ARGS)
+#define clear_needs_copied_args(p) clear_mid_type_bit(T_Pair(p), T_MID_COPY_ARGS)
+/* this marks something that might mess with its argument list, it should not be in the second byte */
+
+#define T_GENSYM (1 << (16 + 13))
+#define T_MID_GENSYM (1 << 13)
+#define is_gensym(p) has_mid_type_bit(T_Sym(p), T_MID_GENSYM)
+/* symbol is from gensym (GC-able etc) */
+
+#define T_FUNCLET T_GENSYM
+#define T_MID_FUNCLET T_MID_GENSYM
+#define is_funclet(p) has_mid_type_bit(T_Let(p), T_MID_FUNCLET)
+#define set_funclet(p) set_mid_type_bit(T_Let(p), T_MID_FUNCLET)
+/* this marks a funclet */
+
+#define T_HASH_CHOSEN T_MID_GENSYM
+#define hash_chosen(p) has_mid_type_bit(T_Hsh(p), T_HASH_CHOSEN)
+#define hash_set_chosen(p) set_mid_type_bit(T_Hsh(p), T_HASH_CHOSEN)
+#define hash_clear_chosen(p) clear_mid_type_bit(T_Hsh(p), T_HASH_CHOSEN)
+
+#define T_DOCUMENTED T_MID_GENSYM
+#define is_documented(p) has_mid_type_bit(T_Str(p), T_DOCUMENTED)
+#define set_documented(p) set_mid_type_bit(T_Str(p), T_DOCUMENTED)
+/* this marks a symbol that has documentation (bit is set on name cell) */
+
+#define T_FX_TREED T_MID_GENSYM
+#define is_fx_treed(p) has_mid_type_bit(T_Pair(p), T_FX_TREED)
+#define set_fx_treed(p) set_mid_type_bit(T_Pair(p), T_FX_TREED)
+
+#define T_SUBVECTOR T_GENSYM
+#define T_MID_SUBVECTOR T_MID_GENSYM
+#define is_subvector(p) has_mid_type_bit(T_Vec(p), T_MID_SUBVECTOR)
+
+#define T_HAS_PENDING_VALUE T_MID_GENSYM
+#define slot_set_has_pending_value(p) set_mid_type_bit(T_Slt(p), T_HAS_PENDING_VALUE)
+#define slot_has_pending_value(p) has_mid_type_bit(T_Slt(p), T_HAS_PENDING_VALUE)
+#define slot_clear_has_pending_value(p) do {clear_mid_type_bit(T_Slt(p), T_HAS_PENDING_VALUE); slot_set_pending_value(p, sc->F);} while (0)
+#define slot_has_setter_or_pending_value(p) has_mid_type_bit(p, T_HAS_SETTER | T_HAS_PENDING_VALUE)
+
+#define T_HAS_METHODS (1 << (16 + 14))
+#define T_MID_HAS_METHODS (1 << 14)
+#define has_methods(p) has_mid_type_bit(T_Exs(p), T_MID_HAS_METHODS) /* display slot hits T_Ext here */
+#define is_openlet(p) has_mid_type_bit(T_Let(p), T_MID_HAS_METHODS)
+#define has_active_methods(sc, p) ((has_mid_type_bit(T_Ext(p), T_MID_HAS_METHODS)) && (sc->has_openlets)) /* g_char #<eof> */
+#define set_has_methods(p) set_mid_type_bit(T_Met(p), T_MID_HAS_METHODS)
+#define clear_has_methods(p) clear_mid_type_bit(T_Met(p), T_MID_HAS_METHODS)
+/* this marks an environment or closure that is "open" for generic functions etc, don't reuse this bit */
+
+/* T_HAS_METHODS: pair (and other types like symbol) are available here */
+
+#define mid_type(p) (p)->tf.bits.mid_bits
+#define T_HAS_LET_SET_FALLBACK T_SAFE_STEPPER
+#define T_MID_HAS_LET_SET_FALLBACK T_MID_SAFE_STEPPER
+#define T_HAS_LET_REF_FALLBACK T_MUTABLE
+#define T_MID_HAS_LET_REF_FALLBACK T_MID_MUTABLE
+#define has_let_ref_fallback(p) ((mid_type(T_Let(p)) & (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_METHODS)) == (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_METHODS))
+#define has_let_set_fallback(p) ((mid_type(T_Let(p)) & (T_MID_HAS_LET_SET_FALLBACK | T_MID_HAS_METHODS)) == (T_MID_HAS_LET_SET_FALLBACK | T_MID_HAS_METHODS))
+#define set_has_let_ref_fallback(p) set_mid_type_bit(T_Let(p), T_MID_HAS_LET_REF_FALLBACK)
+#define set_has_let_set_fallback(p) set_mid_type_bit(T_Let(p), T_MID_HAS_LET_SET_FALLBACK)
+#define has_let_fallback(p) has_mid_type_bit(T_Let(p), (T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_LET_SET_FALLBACK))
+#define set_all_methods(p, e) mid_type(T_Let(p)) |= (mid_type(e) & (T_MID_HAS_METHODS | T_MID_HAS_LET_REF_FALLBACK | T_MID_HAS_LET_SET_FALLBACK))
+
+#define T_ITER_OK (1LL << (16 + 15))
+#define T_MID_ITER_OK (1 << 15)
+#define iter_ok(p) has_mid_type_bit(T_Itr(p), T_MID_ITER_OK)
+#define clear_iter_ok(p) clear_mid_type_bit(T_Itr(p), T_MID_ITER_OK)
+
+#define T_LOOP_END_POSSIBLE T_MID_ITER_OK
+#define loop_end_possible(p) has_mid_type_bit(T_Pair(p), T_LOOP_END_POSSIBLE)
+#define set_loop_end_possible(p) set_mid_type_bit(T_Pair(p), T_LOOP_END_POSSIBLE)
+
+#define T_IN_ROOTLET T_MID_ITER_OK
+#define in_rootlet(p) has_mid_type_bit(T_Slt(p), T_IN_ROOTLET)
+#define set_in_rootlet(p) set_mid_type_bit(T_Slt(p), T_IN_ROOTLET)
+
+#define T_BOOL_FUNCTION T_MID_ITER_OK
+#define is_bool_function(p) has_mid_type_bit(T_Prc(p), T_BOOL_FUNCTION)
+#define set_is_bool_function(p) set_mid_type_bit(T_Fnc(p), T_BOOL_FUNCTION)
+
+#define T_SYMBOL_FROM_SYMBOL T_MID_ITER_OK
+#define is_symbol_from_symbol(p) has_mid_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL)
+#define set_is_symbol_from_symbol(p) set_mid_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL)
+#define clear_symbol_from_symbol(p) clear_mid_type_bit(T_Sym(p), T_SYMBOL_FROM_SYMBOL) /* was high_type?? 20-Dec-23 */
+
+
+/* -------- high type bits -------- */
+/* it's faster here to use the high_bits bits rather than typeflag bits */
+#define T_FULL_SYMCONS (1LL << (48 + 0))
+#define T_SYMCONS (1 << 0)
+#define is_possibly_constant(p) has_high_type_bit(T_Sym(p), T_SYMCONS)
+#define set_possibly_constant(p) set_high_type_bit(T_Sym(p), T_SYMCONS)
+#define is_probably_constant(p) has_type_bit(T_Sym(p), (T_FULL_SYMCONS | T_IMMUTABLE))
+
+#define T_HAS_LET_ARG T_SYMCONS
+#define has_let_arg(p) has_high_type_bit(T_Prc(p), T_HAS_LET_ARG)
+#define set_has_let_arg(p) set_high_type_bit(T_Prc(p), T_HAS_LET_ARG)
+/* p is a setter procedure, "let arg" refers to the setter's optional third (let) argument */
+
+#define T_HASH_VALUE_TYPE T_SYMCONS
+#define has_hash_value_type(p) has_high_type_bit(T_Hsh(p), T_HASH_VALUE_TYPE)
+#define set_has_hash_value_type(p) set_high_type_bit(T_Hsh(p), T_HASH_VALUE_TYPE)
+
+#define T_INT_OPTABLE T_SYMCONS
+#define is_int_optable(p) has_high_type_bit(T_Pair(p), T_INT_OPTABLE)
+#define set_is_int_optable(p) set_high_type_bit(T_Pair(p), T_INT_OPTABLE)
+
+#define T_UNLET T_SYMCONS
+#define is_unlet(p) has_high_type_bit(T_Let(p), T_UNLET)
+#define set_is_unlet(p) set_high_type_bit(T_Let(p), T_UNLET)
+
+#define T_SYMBOL_TABLE T_SYMCONS
+#define is_symbol_table(p) has_high_type_bit(T_Nvc(p), T_SYMBOL_TABLE)
+#define set_is_symbol_table(p) set_high_type_bit(T_Nvc(p), T_SYMBOL_TABLE)
+
+#define T_FULL_HAS_LET_FILE (1LL << (48 + 1))
+#define T_HAS_LET_FILE (1 << 1)
+#define has_let_file(p) has_high_type_bit(T_Let(p), T_HAS_LET_FILE)
+#define set_has_let_file(p) set_high_type_bit(T_Let(p), T_HAS_LET_FILE)
+#define clear_has_let_file(p) clear_high_type_bit(T_Let(p), T_HAS_LET_FILE)
+
+#define T_TYPED_VECTOR T_HAS_LET_FILE
+#define is_typed_vector(p) has_high_type_bit(T_Nvc(p), T_TYPED_VECTOR)
+#define is_typed_t_vector(p) ((is_t_vector(p)) && (is_typed_vector(p)))
+#define set_typed_vector(p) set_high_type_bit(T_Nvc(p), T_TYPED_VECTOR)
+#define clear_typed_vector(p) clear_high_type_bit(T_Nvc(p), T_TYPED_VECTOR)
+
+#define T_TYPED_HASH_TABLE T_HAS_LET_FILE
+#define is_typed_hash_table(p) has_high_type_bit(T_Hsh(p), T_TYPED_HASH_TABLE)
+#define set_is_typed_hash_table(p) set_high_type_bit(T_Hsh(p), T_TYPED_HASH_TABLE)
+#define clear_is_typed_hash_table(p) clear_high_type_bit(T_Hsh(p), T_TYPED_HASH_TABLE)
+
+#define T_BOOL_SETTER T_HAS_LET_FILE
+#define c_function_has_bool_setter(p) has_high_type_bit(T_Fnc(p), T_BOOL_SETTER)
+#define c_function_set_has_bool_setter(p) set_high_type_bit(T_Fnc(p), T_BOOL_SETTER)
+
+#define T_REST_SLOT T_HAS_LET_FILE
+#define is_rest_slot(p) has_high_type_bit(T_Slt(p), T_REST_SLOT)
+#define set_is_rest_slot(p) set_high_type_bit(T_Slt(p), T_REST_SLOT)
+
+#define T_NO_DEFAULTS T_HAS_LET_FILE
+#define T_FULL_NO_DEFAULTS T_FULL_HAS_LET_FILE
+#define has_no_defaults(p) has_high_type_bit(T_Pcs(p), T_NO_DEFAULTS)
+#define set_has_no_defaults(p) set_high_type_bit(T_Pcs(p), T_NO_DEFAULTS)
+/* pair=closure* body, transferred to closure* */
+
+#define T_FULL_DEFINER (1LL << (48 + 2))
+#define T_DEFINER (1 << 2)
+#define is_definer(p) has_high_type_bit(T_Sym(p), T_DEFINER)
+#define set_is_definer(p) set_high_type_bit(T_Sym(p), T_DEFINER)
+#define is_func_definer(p) has_high_type_bit(T_Fnc(p), T_DEFINER)
+#define set_func_is_definer(p) do {set_high_type_bit(T_Fnc(initial_value(p)), T_DEFINER); set_high_type_bit(T_Sym(p), T_DEFINER);} while (0)
+#define is_syntax_definer(p) has_high_type_bit(T_Syn(p), T_DEFINER)
+#define set_syntax_is_definer(p) do {set_high_type_bit(T_Syn(initial_value(p)), T_DEFINER); set_high_type_bit(T_Sym(p), T_DEFINER);} while (0)
+/* this marks "definers" like define and define-macro */
+
+#define T_MACLET T_DEFINER
+#define is_maclet(p) has_high_type_bit(T_Let(p), T_MACLET)
+#define set_maclet(p) set_high_type_bit(T_Let(p), T_MACLET)
+/* this marks a maclet */
+
+#define T_HAS_FX T_DEFINER
+#define set_has_fx(p) set_high_type_bit(T_Pair(p), T_HAS_FX)
+#define has_fx(p) has_high_type_bit(T_Pair(p), T_HAS_FX)
+#define clear_has_fx(p) clear_high_type_bit(T_Pair(p), T_HAS_FX)
+
+#define T_SLOT_DEFAULTS T_DEFINER
+#define slot_defaults(p) has_high_type_bit(T_Slt(p), T_SLOT_DEFAULTS)
+#define set_slot_defaults(p) set_high_type_bit(T_Slt(p), T_SLOT_DEFAULTS)
+
+#define T_WEAK_HASH_ITERATOR T_DEFINER
+#define is_weak_hash_iterator(p) has_high_type_bit(T_Itr(p), T_WEAK_HASH_ITERATOR)
+#define set_weak_hash_iterator(p) set_high_type_bit(T_Itr(p), T_WEAK_HASH_ITERATOR)
+#define clear_weak_hash_iterator(p) clear_high_type_bit(T_Itr(p), T_WEAK_HASH_ITERATOR)
+
+#define T_HASH_KEY_TYPE T_DEFINER
+#define has_hash_key_type(p) has_high_type_bit(T_Hsh(p), T_HASH_KEY_TYPE)
+#define set_has_hash_key_type(p) set_high_type_bit(T_Hsh(p), T_HASH_KEY_TYPE)
+
+#define T_FULL_BINDER (1LL << (48 + 3))
+#define T_BINDER (1 << 3)
+#define set_syntax_is_binder(p) do {set_high_type_bit(T_Syn(initial_value(p)), T_BINDER); set_high_type_bit(T_Sym(p), T_BINDER);} while (0)
+#define is_definer_or_binder(p) has_high_type_bit(T_Sym(p), T_DEFINER | T_BINDER)
+/* this marks "binders" like let */
+
+#define T_SEMISAFE T_BINDER
+#define is_semisafe(p) has_high_type_bit(T_Fnc(p), T_SEMISAFE)
+#define set_is_semisafe(p) set_high_type_bit(T_Fnc(p), T_SEMISAFE)
+
+/* #define T_TREE_COLLECTED T_FULL_BINDER */
+#define T_SHORT_TREE_COLLECTED T_BINDER
+#define tree_is_collected(p) has_high_type_bit(T_Pair(p), T_SHORT_TREE_COLLECTED)
+#define tree_set_collected(p) set_high_type_bit(T_Pair(p), T_SHORT_TREE_COLLECTED)
+#define tree_clear_collected(p) clear_high_type_bit(T_Pair(p), T_SHORT_TREE_COLLECTED)
+
+#define T_SIMPLE_VALUES T_BINDER
+#define has_simple_values(p) has_high_type_bit(T_Hsh(p), T_SIMPLE_VALUES)
+#define set_has_simple_values(p) set_high_type_bit(T_Hsh(p), T_SIMPLE_VALUES)
+#define clear_has_simple_values(p) clear_high_type_bit(T_Hsh(p), T_SIMPLE_VALUES)
+
+#define T_VERY_SAFE_CLOSURE (1LL << (48 + 4))
+#define T_SHORT_VERY_SAFE_CLOSURE (1 << 4)
+#define is_very_safe_closure(p) has_high_type_bit(T_Clo(p), T_SHORT_VERY_SAFE_CLOSURE)
+#define set_very_safe_closure(p) set_high_type_bit(T_Clo(p), T_SHORT_VERY_SAFE_CLOSURE)
+#define closure_bits(p) (full_type(T_Pair(p)) & (T_SAFE_CLOSURE | T_VERY_SAFE_CLOSURE | T_FULL_NO_DEFAULTS))
+#define is_very_safe_closure_body(p) has_high_type_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE)
+#define set_very_safe_closure_body(p) set_high_type_bit(T_Pair(p), T_SHORT_VERY_SAFE_CLOSURE)
+
+#define T_BAFFLE_LET T_SHORT_VERY_SAFE_CLOSURE
+#define is_baffle_let(p) has_high_type_bit(T_Let(p), T_BAFFLE_LET)
+#define set_baffle_let(p) set_high_type_bit(T_Let(p), T_BAFFLE_LET)
+
+#define T_CYCLIC (1LL << (48 + 5))
+#define T_SHORT_CYCLIC (1 << 5)
+#define is_cyclic(p) has_high_type_bit(T_Seq(p), T_SHORT_CYCLIC)
+#define set_cyclic(p) set_high_type_bit(T_Seq(p), T_SHORT_CYCLIC)
+
+#define T_CYCLIC_SET (1LL << (48 + 6))
+#define T_SHORT_CYCLIC_SET (1 << 6)
+#define is_cyclic_set(p) has_high_type_bit(T_Seq(p), T_SHORT_CYCLIC_SET)
+#define set_cyclic_set(p) set_high_type_bit(T_Seq(p), T_SHORT_CYCLIC_SET)
+#define clear_cyclic_bits(p) clear_type_bit(p, T_COLLECTED | T_SHARED | T_CYCLIC | T_CYCLIC_SET)
+
+#define T_KEYWORD (1LL << (48 + 7))
+#define T_SHORT_KEYWORD (1 << 7)
+#define is_keyword(p) has_high_type_bit(T_Sym(p), T_SHORT_KEYWORD)
+#define is_symbol_and_keyword(p) ((is_symbol(p)) && (is_keyword(p)))
+/* this bit distinguishes a symbol from a symbol that is also a keyword */
+
+#define T_FX_TREEABLE T_SHORT_KEYWORD
+#define is_fx_treeable(p) has_high_type_bit(T_Pair(p), T_FX_TREEABLE)
+#define set_is_fx_treeable(p) set_high_type_bit(T_Pair(p), T_FX_TREEABLE)
+
+#define T_FULL_SIMPLE_ELEMENTS (1LL << (48 + 8))
+#define T_SIMPLE_ELEMENTS (1 << 8)
+#define has_simple_elements(p) has_high_type_bit(T_Nvc(p), T_SIMPLE_ELEMENTS)
+#define set_has_simple_elements(p) set_high_type_bit(T_Nvc(p), T_SIMPLE_ELEMENTS)
+#define clear_has_simple_elements(p) clear_high_type_bit(T_Nvc(p), T_SIMPLE_ELEMENTS)
+#define c_function_has_simple_elements(p) has_high_type_bit(T_Fnc(p), T_SIMPLE_ELEMENTS)
+#define c_function_set_has_simple_elements(p) set_high_type_bit(T_Fnc(p), T_SIMPLE_ELEMENTS)
+/* c_func case here refers to boolean? et al -- structure element type declaration that ensures a simple object */
+
+#define T_SIMPLE_KEYS T_SIMPLE_ELEMENTS
+#define has_simple_keys(p) has_high_type_bit(T_Hsh(p), T_SIMPLE_KEYS)
+#define set_has_simple_keys(p) set_high_type_bit(T_Hsh(p), T_SIMPLE_KEYS)
+#define clear_has_simple_keys(p) clear_high_type_bit(T_Hsh(p), T_SIMPLE_KEYS)
+
+#define T_SAFE_SETTER T_SIMPLE_ELEMENTS
+#define is_safe_setter(p) has_high_type_bit(T_Sym(p), T_SAFE_SETTER)
+#define set_is_safe_setter(p) set_high_type_bit(T_Sym(p), T_SAFE_SETTER)
+
+#define T_FLOAT_OPTABLE T_SIMPLE_ELEMENTS
+#define is_float_optable(p) has_high_type_bit(T_Pair(p), T_FLOAT_OPTABLE)
+#define set_is_float_optable(p) set_high_type_bit(T_Pair(p), T_FLOAT_OPTABLE)
+
+#define T_FULL_CASE_KEY (1LL << (48 + 9))
+#define T_CASE_KEY (1 << 9)
+#define is_case_key(p) has_high_type_bit(T_Ext(p), T_CASE_KEY)
+#define set_case_key(p) set_high_type_bit(T_Sym(p), T_CASE_KEY)
+
+#define T_OPT1_FUNC_LISTED T_CASE_KEY
+#define opt1_func_listed(p) has_high_type_bit(T_Pair(p), T_OPT1_FUNC_LISTED)
+#define set_opt1_func_listed(p) set_high_type_bit(T_Pair(p), T_OPT1_FUNC_LISTED)
+
+/* (1LL << (48 + 10)) was HAS_GX, is now free */
+
+#define T_FULL_UNKNOPT (1LL << (48 + 11))
+#define T_UNKNOPT (1 << 11)
+#define is_unknopt(p) has_high_type_bit(T_Pair(p), T_UNKNOPT)
+#define set_is_unknopt(p) set_high_type_bit(T_Pair(p), T_UNKNOPT)
+
+#define T_MAC_OK T_UNKNOPT
+#define mac_is_ok(p) has_high_type_bit(T_Pair(p), T_MAC_OK)
+#define set_mac_is_ok(p) set_high_type_bit(T_Pair(p), T_MAC_OK)
+/* marks a macro (via (macro...)) that has been checked -- easier (and slower) than making 4 or 5 more ops, op_macro_unchecked and so on */
+
+#define T_FULL_SAFETY_CHECKED (1LL << (48 + 12))
+#define T_SAFETY_CHECKED (1 << 12)
+#define is_safety_checked(p) has_high_type_bit(T_Pair(p), T_SAFETY_CHECKED)
+#define set_safety_checked(p) do {if (in_heap(p)) set_high_type_bit(T_Pair(p), T_SAFETY_CHECKED);} while (0)
+
+#define T_FULL_HAS_FN (1LL << (48 + 13))
+#define T_HAS_FN (1 << 13)
+#define set_has_fn(p) set_high_type_bit(T_Pair(p), T_HAS_FN)
+#define has_fn(p) has_high_type_bit(T_Pair(p), T_HAS_FN)
+
+#define T_GC_MARK 0x8000000000000000
+#define is_marked(p) has_type_bit(p, T_GC_MARK)
+#define set_mark(p) set_type_bit(T_Pos(p), T_GC_MARK)
+#define clear_mark(p) clear_type_bit(p, T_GC_MARK)
+/* using the sign bit, bit 23 (or 55) == 31 (or 63) for this makes a big difference in the GC */
+
+#define T_UNHEAP 0x4000000000000000
+#define T_SHORT_UNHEAP (1 << 14)
+#define in_heap(p) (((T_Pos(p))->tf.bits.high_bits & T_SHORT_UNHEAP) == 0) /* can be slot, make_s7_starlet let_set_slot */
+#define unheap(sc, p) set_high_type_bit(T_Ext(p), T_SHORT_UNHEAP)
+
+#define is_eof(p) ((T_Ext(p)) == eof_object)
+#define is_true(Sc, p) ((T_Ext(p)) != Sc->F)
+#define is_false(Sc, p) ((T_Ext(p)) == Sc->F)
+
+#ifdef _MSC_VER
+ static s7_pointer make_boolean(s7_scheme *sc, bool val) {if (val) return(sc->T); return(sc->F);}
+#else
+ #define make_boolean(sc, Val) ((Val) ? sc->T : sc->F)
+#endif
+
+#define is_pair(p) (type(p) == T_PAIR)
+#define is_mutable_pair(p) ((is_pair(p)) && (!is_immutable(p))) /* same speed: ((full_type(p) & (TYPE_MASK | T_IMMUTABLE)) == T_PAIR) */
+#define is_null(p) ((T_Exs(p)) == sc->nil) /* can be a slot */
+#define is_not_null(p) ((T_Exs(p)) != sc->nil)
+#define is_list(p) ((is_pair(p)) || (type(p) == T_NIL))
+#define is_quote(p) (((p) == sc->quote_symbol) || ((p) == sc->quote_function)) /* order here apparently does not matter */
+#define is_safe_quote(p) ((((p) == sc->quote_symbol) && (is_global(sc->quote_symbol))) || ((p) == sc->quote_function))
+#define is_quoted_pair(p) ((is_pair(p)) && (is_quote(car(p))))
+#define is_safe_quoted_pair(p) ((is_pair(p)) && (is_safe_quote(car(p))))
+#define is_unquoted_pair(p) ((is_pair(p)) && (!is_quote(car(p))))
+#define is_quoted_symbol(p) ((is_quoted_pair(p)) && (is_symbol(cadr(p))))
+
+
+/* pair line/file/position */
+#define PAIR_LINE_BITS 24
+#define PAIR_FILE_BITS 12
+#define PAIR_POSITION_BITS 28
+#define PAIR_LINE_OFFSET 0
+#define PAIR_FILE_OFFSET PAIR_LINE_BITS
+#define PAIR_POSITION_OFFSET (PAIR_LINE_BITS + PAIR_FILE_BITS)
+#define PAIR_LINE_MASK ((1 << PAIR_LINE_BITS) - 1)
+#define PAIR_FILE_MASK ((1 << PAIR_FILE_BITS) - 1)
+#define PAIR_POSITION_MASK ((1 << PAIR_POSITION_BITS) - 1)
+
+#define port_location(Pt) (((port_line_number(Pt) & PAIR_LINE_MASK) << PAIR_LINE_OFFSET) | \
+ ((port_file_number(Pt) & PAIR_FILE_MASK) << PAIR_FILE_OFFSET) | \
+ ((port_position(Pt) & PAIR_POSITION_MASK) << PAIR_POSITION_OFFSET))
+
+#define location_to_line(Loc) ((Loc >> PAIR_LINE_OFFSET) & PAIR_LINE_MASK)
+#define location_to_file(Loc) ((Loc >> PAIR_FILE_OFFSET) & PAIR_FILE_MASK)
+#define location_to_position(Loc) ((Loc >> PAIR_POSITION_OFFSET) & PAIR_POSITION_MASK)
+
+#define pair_line_number(p) location_to_line(pair_location(p))
+#define pair_file_number(p) location_to_file(pair_location(p))
+#define pair_position(p) location_to_position(pair_location(p))
+
+#if (!S7_DEBUGGING)
+#define pair_location(p) (p)->object.sym_cons.location
+#define pair_set_location(p, X) (p)->object.sym_cons.location = X
+#define pair_raw_hash(p) (p)->object.sym_cons.hash
+#define pair_set_raw_hash(p, X) (p)->object.sym_cons.hash = X
+#define pair_raw_len(p) (p)->object.sym_cons.location
+#define pair_set_raw_len(p, X) (p)->object.sym_cons.location = X
+#define pair_raw_name(p) (p)->object.sym_cons.fstr
+#define pair_set_raw_name(p, X) (p)->object.sym_cons.fstr = X
+/* opt1 == raw_hash, opt2 == raw_name, opt3 == line|ctr + len, but hash/name/len only apply to the symbol table so there's no collision */
+
+#define opt1(p, r) ((p)->object.cons.opt1)
+#define set_opt1(p, x, r) (p)->object.cons.opt1 = x
+#define opt2(p, r) ((p)->object.cons.o2.opt2)
+#define set_opt2(p, x, r) (p)->object.cons.o2.opt2 = (s7_pointer)(x)
+#define opt2_n(p, r) ((p)->object.cons.o2.n)
+#define set_opt2_n(p, x, r) (p)->object.cons.o2.n = x
+#define opt3(p, r) ((p)->object.cons.o3.opt3)
+#define set_opt3(p, x, r) do {(p)->object.cons.o3.opt3 = x; clear_type_bit(p, T_LOCATION);} while (0)
+#define opt3_n(p, r) ((p)->object.cons.o3.n)
+#define set_opt3_n(p, x, r) do {(p)->object.cons.o3.n = x; clear_type_bit(p, T_LOCATION);} while (0)
+
+#else
+
+/* the 3 opt fields hold most of the varigated optimizer info, so they are used in many conflicting ways.
+ * the bits and funcs here try to track each such use, and report any cross-talk or collisions.
+ * all of this machinery vanishes if debugging is turned off.
+ */
+#define OPT1_SET (1 << 0)
+#define OPT2_SET (1 << 1)
+#define OPT3_SET (1 << 2)
+
+#define OPT1_FAST (1 << 3) /* fast list in member/assoc circular list check */
+#define OPT1_CFUNC (1 << 4) /* c-function */
+#define OPT1_CLAUSE (1 << 5) /* case clause */
+#define OPT1_LAMBDA (1 << 6) /* lambda(*) */
+#define OPT1_SYM (1 << 7) /* symbol */
+#define OPT1_PAIR (1 << 8) /* pair */
+#define OPT1_CON (1 << 9) /* constant from eval's point of view */ /* 10 was opt1_goto, unused */
+#define OPT1_ANY (1 << 11) /* anything -- deliberate unchecked case */
+#define OPT1_HASH (1 << 12) /* hash code used in the symbol table (pair_raw_hash) */
+#define OPT1_MASK (OPT1_FAST | OPT1_CFUNC | OPT1_CLAUSE | OPT1_LAMBDA | OPT1_SYM | OPT1_PAIR | OPT1_CON | OPT1_ANY | OPT1_HASH)
+
+#define opt1_is_set(p) (((T_Pair(p))->debugger_bits & OPT1_SET) != 0)
+#define set_opt1_is_set(p) (T_Pair(p))->debugger_bits |= OPT1_SET
+#define opt1_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT1_MASK) == Role)
+#define set_opt1_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT1_MASK))
+#define opt1(p, Role) opt1_1(sc, T_Pair(p), Role, __func__, __LINE__)
+#define set_opt1(p, x, Role) set_opt1_1(T_Pair(p), x, Role, __func__, __LINE__)
+
+#define OPT2_KEY (1 << 13) /* case key */
+#define OPT2_SLOW (1 << 14) /* slow list in member/assoc circular list check */
+#define OPT2_SYM (1 << 15) /* symbol */
+#define OPT2_PAIR (1 << 16) /* pair */
+#define OPT2_CON (1 << 17) /* constant as above */
+#define OPT2_FX (1 << 18) /* fx (fx_*) func (sc, form) */
+#define OPT2_FN (1 << 19) /* fn (s7_function) func (sc, arglist) */
+#define OPT2_LAMBDA (1 << 20) /* lambda form */
+#define OPT2_NAME (1 << 21) /* named used by symbol table (pair_raw_name) */
+#define OPT2_DIRECT (1LL << 32)
+#define OPT2_INT (1LL << 33)
+#define OPT2_MASK (OPT2_KEY | OPT2_SLOW | OPT2_SYM | OPT2_PAIR | OPT2_CON | OPT2_FX | \
+ OPT2_FN | OPT2_LAMBDA | OPT2_DIRECT | OPT2_NAME | OPT2_INT)
+
+#define opt2_is_set(p) (((T_Pair(p))->debugger_bits & OPT2_SET) != 0)
+#define set_opt2_is_set(p) (T_Pair(p))->debugger_bits |= OPT2_SET
+#define opt2_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT2_MASK) == Role)
+#define set_opt2_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT2_MASK))
+#define opt2(p, Role) opt2_1(sc, T_Pair(p), Role, __func__, __LINE__)
+#define set_opt2(p, x, Role) set_opt2_1(sc, T_Pair(p), (s7_pointer)(x), Role, __func__, __LINE__)
+#define opt2_n(p, Role) opt2_n_1(sc, T_Pair(p), Role, __func__, __LINE__)
+#define set_opt2_n(p, x, Role) set_opt2_n_1(sc, T_Pair(p), x, Role, __func__, __LINE__)
+
+#define OPT3_ARGLEN (1 << 22) /* arglist length */
+#define OPT3_SYM (1 << 23) /* expression symbol access */
+#define OPT3_AND (1 << 24) /* and second clause */
+#define OPT3_DIRECT (1 << 25) /* direct call info */
+#define OPT3_ANY (1 << 26)
+#define OPT3_LET (1 << 27) /* let or #f */
+#define OPT3_CON (1 << 28)
+#define OPT3_LOCATION (1 << 29)
+#define OPT3_LEN (1 << 30)
+#define OPT3_BYTE (1LL << 31)
+#define OPT3_INT (1LL << 34)
+#define OPT3_MASK (OPT3_ARGLEN | OPT3_SYM | OPT3_AND | OPT3_ANY | OPT3_LET | OPT3_BYTE | \
+ OPT3_LOCATION | OPT3_LEN | OPT3_DIRECT | OPT3_CON | OPT3_INT)
+
+#define opt3_is_set(p) (((T_Pair(p))->debugger_bits & OPT3_SET) != 0)
+#define set_opt3_is_set(p) (T_Pair(p))->debugger_bits |= OPT3_SET
+#define opt3_role_matches(p, Role) (((T_Pair(p))->debugger_bits & OPT3_MASK) == Role)
+#define set_opt3_role(p, Role) (T_Pair(p))->debugger_bits = (Role | ((p)->debugger_bits & ~OPT3_MASK))
+#define opt3(p, Role) opt3_1(sc, T_Pair(p), Role, __func__, __LINE__)
+#define set_opt3(p, x, Role) set_opt3_1(T_Pair(p), x, Role)
+#define opt3_n(p, Role) opt3_n_1(sc, T_Pair(p), Role, __func__, __LINE__)
+#define set_opt3_n(p, x, Role) set_opt3_n_1(T_Pair(p), x, Role)
+
+#define pair_location(p) opt3_location_1(sc, T_Pair(p), __func__, __LINE__)
+#define pair_set_location(p, X) set_opt3_location_1(T_Pair(p), X)
+#define pair_raw_hash(p) opt1_hash_1(sc, T_Pair(p), __func__, __LINE__)
+#define pair_set_raw_hash(p, X) set_opt1_hash_1(T_Pair(p), X)
+#define pair_raw_len(p) opt3_len_1(sc, T_Pair(p), __func__, __LINE__)
+#define pair_set_raw_len(p, X) set_opt3_len_1(T_Pair(p), X)
+#define pair_raw_name(p) opt2_name_1(sc, T_Pair(p), __func__, __LINE__)
+#define pair_set_raw_name(p, X) set_opt2_name_1(T_Pair(p), X)
+
+#define L_HIT (1LL << 40) /* "L_SET" is taken */
+#define L_FUNC (1LL << 41)
+#define L_DOX (1LL << 42)
+#define L_MASK (L_FUNC | L_DOX)
+#endif
+
+#define opt1_fast(P) T_Lst(opt1(P, OPT1_FAST))
+#define set_opt1_fast(P, X) set_opt1(P, T_Pair(X), OPT1_FAST)
+#define opt1_cfunc(P) T_Exs(opt1(P, OPT1_CFUNC))
+#define set_opt1_cfunc(P, X) set_opt1(P, T_Fnc(X), OPT1_CFUNC)
+#define opt1_lambda_unchecked(P) opt1(P, OPT1_LAMBDA) /* can be free/null? from s7_call? */
+#define opt1_lambda(P) T_Clo(opt1(P, OPT1_LAMBDA))
+#define set_opt1_lambda(P, X) set_opt1(P, T_Clo(X), OPT1_LAMBDA)
+#define set_opt1_lambda_add(P, X) do {set_opt1(P, T_Clo(X), OPT1_LAMBDA); add_opt1_func(sc, P);} while (0)
+#define opt1_clause(P) T_Exs(opt1(P, OPT1_CLAUSE))
+#define set_opt1_clause(P, X) set_opt1(P, T_Exs(X), OPT1_CLAUSE)
+#define opt1_sym(P) T_Sym(opt1(P, OPT1_SYM))
+#define set_opt1_sym(P, X) set_opt1(P, T_Sym(X), OPT1_SYM)
+#define opt1_pair(P) T_Lst(opt1(P, OPT1_PAIR))
+#define set_opt1_pair(P, X) set_opt1(P, T_Lst(X), OPT1_PAIR)
+#define opt1_con(P) T_Exs(opt1(P, OPT1_CON))
+#define set_opt1_con(P, X) set_opt1(P, T_Exs(X), OPT1_CON) /* can be #<unused> */
+#define opt1_any(P) opt1(P, OPT1_ANY) /* can be free in closure_is_ok */
+#define set_opt1_any(P, X) set_opt1(P, X, OPT1_ANY)
+
+#define opt2_any(P) opt2(P, OPT2_KEY)
+#define set_opt2_any(P, X) set_opt2(P, X, OPT2_KEY)
+#define opt2_int(P) opt2_n(P, OPT2_INT)
+#define set_opt2_int(P, X) set_opt2_n(P, X, OPT2_INT)
+#define opt2_slow(P) T_Lst(opt2(P, OPT2_SLOW))
+#define set_opt2_slow(P, X) set_opt2(P, T_Pair(X), OPT2_SLOW)
+#define opt2_sym(P) T_Sym(opt2(P, OPT2_SYM))
+#define set_opt2_sym(P, X) set_opt2(P, T_Sym(X), OPT2_SYM)
+#define opt2_pair(P) T_Lst(opt2(P, OPT2_PAIR))
+#define set_opt2_pair(P, X) set_opt2(P, T_Lst(X), OPT2_PAIR)
+#define opt2_con(P) T_Exs(opt2(P, OPT2_CON))
+#define set_opt2_con(P, X) set_opt2(P, T_Exs(X), OPT2_CON)
+#define opt2_lambda(P) T_Pair(opt2(P, OPT2_LAMBDA))
+#define set_opt2_lambda(P, X) set_opt2(P, T_Pair(X), OPT2_LAMBDA)
+#define opt2_direct(P) opt2(P, OPT2_DIRECT)
+#define set_opt2_direct(P, X) set_opt2(P, (s7_pointer)(X), OPT2_DIRECT)
+
+#define opt3_arglen(P) opt3_n(P, OPT3_ARGLEN)
+#define set_opt3_arglen(P, X) set_opt3_n(P, X, OPT3_ARGLEN)
+#define opt3_int(P) opt3_n(P, OPT3_INT)
+#define set_opt3_int(P, X) set_opt3_n(P, X, OPT3_INT)
+#define opt3_sym(P) T_Sym(opt3(P, OPT3_SYM))
+#define set_opt3_sym(P, X) set_opt3(P, T_Sym(X), OPT3_SYM)
+#define opt3_con(P) T_Exs(opt3(P, OPT3_CON))
+#define set_opt3_con(P, X) set_opt3(P, T_Exs(X), OPT3_CON)
+#define opt3_pair(P) T_Pair(opt3(P, OPT3_AND))
+#define set_opt3_pair(P, X) set_opt3(P, T_Pair(X), OPT3_AND)
+#define opt3_any(P) opt3(P, OPT3_ANY)
+#define set_opt3_any(P, X) set_opt3(P, X, OPT3_ANY)
+#define opt3_let(P) T_Let(opt3(P, OPT3_LET))
+#define set_opt3_let(P, X) set_opt3(P, T_Let(X), OPT3_LET)
+#define opt3_direct(P) opt3(P, OPT3_DIRECT)
+#define set_opt3_direct(P, X) set_opt3(P, (s7_pointer)(X), OPT3_DIRECT)
+
+#if S7_DEBUGGING
+#define opt3_byte(p) opt3_byte_1(sc, T_Pair(p), OPT3_BYTE, __func__, __LINE__)
+#define set_opt3_byte(p, x) set_opt3_byte_1(T_Pair(p), x, OPT3_BYTE, __func__, __LINE__)
+#else
+#define opt3_byte(P) T_Pair(P)->object.cons.o3.opt_type /* op_if_is_type, opt_type == opt3 in cons */
+#define set_opt3_byte(P, X) do {T_Pair(P)->object.cons.o3.opt_type = X; clear_type_bit(P, T_LOCATION);} while (0)
+#endif
+
+#define pair_macro(P) opt2_sym(P)
+#define set_pair_macro(P, Name) set_opt2_sym(P, Name)
+
+#define fn_proc(f) ((s7_function)(opt2(f, OPT2_FN)))
+#define fx_proc(f) ((s7_function)(opt2(f, OPT2_FX)))
+#define fn_proc_unchecked(f) ((s7_function)(T_Pair(f)->object.cons.o2.opt2))
+#define fx_proc_unchecked(f) ((s7_function)(T_Pair(f)->object.cons.o2.opt2)) /* unused */
+
+#define set_fx(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); set_opt2(f, X, OPT2_FX); if (X) set_has_fx(f); else clear_has_fx(f);} while (0)
+#define set_fx_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FX); set_has_fx(f);} while (0)
+#define set_fn(f, _X_) do {s7_pointer X; X = (s7_pointer)(_X_); set_opt2(f, X, OPT2_FN); if (X) set_has_fn(f); else clear_has_fx(f);} while (0)
+#define set_fn_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FN); set_has_fn(f);} while (0)
+
+#if WITH_GCC
+#define fx_call(Sc, F) ({s7_pointer _P_; _P_ = F; fx_proc(_P_)(Sc, car(_P_));})
+#define fn_call(Sc, F) ({s7_pointer _P_; _P_ = F; fn_proc(_P_)(Sc, cdr(_P_));})
+#else
+#define fx_call(Sc, F) fx_proc(F)(Sc, car(F))
+#define fn_call(Sc, F) fn_proc(F)(Sc, cdr(F))
+#endif
+/* fx_call can affect the stack and sc->value */
+
+#define car(p) (T_Pair(p))->object.cons.car
+#define unchecked_car(p) (T_Pos(p))->object.cons.car
+#define set_car(p, Val) car(p) = T_Pos(Val) /* can be a slot or #<unused> or #<catch> etc */
+#define cdr(p) (T_Pair(p))->object.cons.cdr
+#if S7_DEBUGGING
+static void check_set_cdr(s7_pointer p, s7_pointer Val, const char *func, int32_t line);
+#define set_cdr(p, Val) check_set_cdr(p, Val, __func__, __LINE__)
+#else
+#define set_cdr(p, Val) cdr(p) = T_Ext(Val)
+#endif
+#define unchecked_set_cdr(p, Val) cdr(p) = T_Exs(Val) /* #<unused> in g_gc */
+#define unchecked_cdr(p) (T_Exs(p))->object.cons.cdr
+
+#define caar(p) car(car(p))
+#define cadr(p) car(cdr(p))
+#define set_cadr(p, Val) car(cdr(p)) = T_Exs(Val) /* #<unused> in g_gc */
+#define cdar(p) cdr(car(p))
+#define set_cdar(p, Val) cdr(car(p)) = T_Ext(Val)
+#define cddr(p) cdr(cdr(p))
+
+#define caaar(p) car(car(car(p)))
+#define cadar(p) car(cdr(car(p)))
+#define cdadr(p) cdr(car(cdr(p)))
+#define caddr(p) car(cdr(cdr(p)))
+#define set_caddr(p, Val) car(cdr(cdr(p))) = T_Ext(Val)
+#define caadr(p) car(car(cdr(p)))
+#define cdaar(p) cdr(car(car(p)))
+#define cdddr(p) cdr(cdr(cdr(p)))
+#define set_cdddr(p, Val) cdr(cdr(cdr(p))) = T_Ext(Val)
+#define cddar(p) cdr(cdr(car(p)))
+
+#define caaadr(p) car(car(car(cdr(p))))
+#define caadar(p) car(car(cdr(car(p))))
+#define cadaar(p) car(cdr(car(car(p))))
+#define cadddr(p) car(cdr(cdr(cdr(p))))
+#define caaddr(p) car(car(cdr(cdr(p))))
+#define cddddr(p) cdr(cdr(cdr(cdr(p))))
+#define caddar(p) car(cdr(cdr(car(p))))
+#define cdadar(p) cdr(car(cdr(car(p))))
+#define cdaddr(p) cdr(car(cdr(cdr(p))))
+#define caaaar(p) car(car(car(car(p))))
+#define cadadr(p) car(cdr(car(cdr(p))))
+#define cdaadr(p) cdr(car(car(cdr(p))))
+#define cdaaar(p) cdr(car(car(car(p))))
+#define cdddar(p) cdr(cdr(cdr(car(p))))
+#define cddadr(p) cdr(cdr(car(cdr(p))))
+#define cddaar(p) cdr(cdr(car(car(p))))
+
+#define cadaddr(p) cadr(caddr(p))
+#define caddadr(p) caddr(cadr(p))
+#define caddaddr(p) caddr(caddr(p))
+
+#if WITH_GCC
+ /* slightly tricky because cons can be called recursively, macro here is faster than inline function */
+ #define cons(Sc, A, B) ({s7_pointer _X_, _A_, _B_; _A_ = A; _B_ = B; new_cell(Sc, _X_, T_PAIR | T_SAFE_PROCEDURE); set_car(_X_, _A_); set_cdr(_X_, _B_); _X_;})
+#else
+ #define cons(Sc, A, B) s7_cons(Sc, A, B)
+#endif
+
+#define list_1(Sc, A) cons(Sc, A, Sc->nil)
+#define list_1_unchecked(Sc, A) cons_unchecked(Sc, A, Sc->nil)
+#define list_2(Sc, A, B) cons_unchecked(Sc, A, cons(Sc, B, Sc->nil))
+#define list_2_unchecked(Sc, A, B) cons_unchecked(Sc, A, cons_unchecked(Sc, B, Sc->nil))
+#define list_3(Sc, A, B, C) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons(Sc, C, Sc->nil)))
+#define list_4(Sc, A, B, C, D) cons_unchecked(Sc, A, cons_unchecked(Sc, B, cons_unchecked(Sc, C, cons(Sc, D, Sc->nil))))
+#define with_list_t1(A) (set_car(sc->t1_1, A), sc->t1_1) /* this is slower than explicit code, esp t3, procedures are same as this */
+#define with_list_t2(A, B) (set_car(sc->t2_1, A), set_car(sc->t2_2, B), sc->t2_1)
+#define with_list_t3(A, B, C) (set_car(sc->t3_1, A), set_car(sc->t3_2, B), set_car(sc->t3_3, C), sc->t3_1)
+/* #define with_list_t4(A, B, C, D) (set_car(sc->t4_1, A), set_car(sc->t3_1, B), set_car(sc->t3_2, C), set_car(sc->t3_3, D), sc->t4_1) */
+
+#define is_string(p) (type(p) == T_STRING)
+#define is_mutable_string(p) ((full_type(T_Ext(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_STRING)
+#define string_value(p) (T_Str(p))->object.string.svalue
+#define string_length(p) (T_Str(p))->object.string.length
+#define string_hash(p) (T_Str(p))->object.string.hash
+#define string_block(p) (T_Str(p))->object.string.block
+#define unchecked_string_block(p) p->object.string.block
+
+#define character(p) (T_Chr(p))->object.chr.c
+#define is_character(p) (type(p) == T_CHARACTER)
+#define upper_character(p) (T_Chr(p))->object.chr.up_c
+#define is_char_alphabetic(p) (T_Chr(p))->object.chr.alpha_c
+#define is_char_numeric(p) (T_Chr(p))->object.chr.digit_c
+#define is_char_whitespace(p) (T_Chr(p))->object.chr.space_c
+#define is_char_uppercase(p) (T_Chr(p))->object.chr.upper_c
+#define is_char_lowercase(p) (T_Chr(p))->object.chr.lower_c
+#define character_name(p) (T_Chr(p))->object.chr.c_name
+#define character_name_length(p) (T_Chr(p))->object.chr.length
+
+#define optimize_op(P) (T_Ext(P))->tf.bits.opt_bits
+#define unchecked_optimize_op(P) (P)->tf.bits.opt_bits
+#define set_optimize_op(P, Op) (T_Ext(P))->tf.bits.opt_bits = (Op) /* not T_Pair -- needs legit cur_sc in init_chars|strings */
+#define OP_HOP_MASK 0xfffe
+#define optimize_op_match(P, Q) ((is_optimized(P)) && ((optimize_op(P) & OP_HOP_MASK) == (Q)))
+#define op_no_hop(P) (optimize_op(P) & OP_HOP_MASK)
+#define op_has_hop(P) ((optimize_op(P) & 1) != 0)
+#define clear_optimize_op(P) set_optimize_op(P, OP_UNOPT)
+#define set_safe_optimize_op(P, Q) do {set_optimized(P); set_optimize_op(P, Q);} while (0)
+#define set_unsafe_optimize_op(P, Q) do {set_unsafely_optimized(P); set_optimize_op(P, Q);} while (0)
+
+#define is_symbol(p) (type(p) == T_SYMBOL)
+#define is_normal_symbol(p) ((is_symbol(p)) && (!is_keyword(p)))
+#define is_safe_symbol(p) ((is_symbol(p)) && (is_slot(s7_slot(sc, p))))
+#define symbol_name_cell(p) T_Str((T_Sym(p))->object.sym.name)
+#define symbol_set_name_cell(p, S) (T_Sym(p))->object.sym.name = T_Str(S)
+#define symbol_name(p) string_value(symbol_name_cell(p))
+#define symbol_name_length(p) string_length(symbol_name_cell(p))
+#define gensym_block(p) symbol_name_cell(p)->object.string.gensym_block
+#define pointer_map(p) (s7_int)((intptr_t)(p) >> 8)
+#define symbol_id(p) (T_Sym(p))->object.sym.id
+#define symbol_set_id_unchecked(p, X) (T_Sym(p))->object.sym.id = X
+#if S7_DEBUGGING
+static void symbol_set_id(s7_pointer p, s7_int id)
+{
+ if (id < symbol_id(p))
+ {
+ fprintf(stderr, "%s[%d]: id mismatch: sym: %s %" ld64 ", let: %" ld64 "\n", __func__, __LINE__, symbol_name(p), symbol_id(p), id);
+ abort();
+ }
+ (T_Sym(p))->object.sym.id = id;
+}
+#else
+#define symbol_set_id(p, X) (T_Sym(p))->object.sym.id = X
+#endif
+/* we need 64-bits here, since we don't want this thing to wrap around, and lets are created at a great rate
+ * callgrind says this is faster than a uint32_t!
+ */
+#define symbol_info(p) (symbol_name_cell(p))->object.string.block
+#define symbol_type(p) (block_size(symbol_info(p)) & 0xff) /* boolean function bool type */
+#define symbol_set_type(p, Type) block_size(symbol_info(p)) = ((block_size(symbol_info(p)) & ~0xff) | ((Type) & 0xff))
+#define symbol_clear_type(p) block_size(symbol_info(p)) = 0
+#define s7_starlet_symbol(p) ((uint8_t)((block_size(symbol_info(p)) >> 8) & 0xff)) /* *s7* id */
+#define s7_starlet_symbol_set(p, F) block_size(symbol_info(p)) = ((block_size(symbol_info(p)) & ~0xff00) | (((F) & 0xff) << 8))
+
+#define initial_slot(p) T_Sld(symbol_info(p)->ex.ex_ptr)
+#define set_initial_slot(p, Val) symbol_info(p)->ex.ex_ptr = T_Sld(Val)
+#define global_slot(p) T_Sld((T_Sym(p))->object.sym.global_slot)
+#define set_global_slot(p, Val) (T_Sym(p))->object.sym.global_slot = T_Sld(Val)
+#define local_slot(p) T_Sln((T_Sym(p))->object.sym.local_slot)
+#define set_local_slot(p, Val) (T_Sym(p))->object.sym.local_slot = T_Slt(Val)
+
+#define initial_value(p) slot_value(initial_slot(T_Sym(p)))
+#define local_value(p) slot_value(local_slot(T_Sym(p)))
+#define unchecked_local_value(p) local_slot(p)->object.slt.val
+#define global_value(p) slot_value(global_slot(T_Sym(p)))
+
+#define keyword_symbol(p) symbol_info(T_Key(p))->nx.ksym /* keyword only, so does not collide with documentation */
+#define keyword_symbol_unchecked(p) symbol_info(p)->nx.ksym
+#define keyword_set_symbol(p, Val) symbol_info(T_Key(p))->nx.ksym = T_Sym(Val)
+#define symbol_help(p) symbol_info(p)->nx.documentation
+#define symbol_set_help(p, Doc) symbol_info(p)->nx.documentation = Doc
+#define symbol_tag(p) (T_Sym(p))->object.sym.tag
+#define symbol_set_tag(p, Val) (T_Sym(p))->object.sym.tag = Val
+#define symbol_ctr(p) (T_Sym(p))->object.sym.ctr /* needs to be in the symbol object (not symbol_info) for speed */
+#define symbol_clear_ctr(p) (T_Sym(p))->object.sym.ctr = 0
+#define symbol_increment_ctr(p) (T_Sym(p))->object.sym.ctr++
+#define symbol_tag2(p) symbol_info(p)->ln.tag
+#define symbol_set_tag2(p, Val) symbol_info(p)->ln.tag = Val
+#define symbol_has_help(p) (is_documented(symbol_name_cell(p)))
+#define symbol_set_has_help(p) set_documented(symbol_name_cell(p))
+/* symbol_info->dx is free */
+
+#define symbol_set_local_slot_unchecked(Symbol, Id, Slot) \
+ do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id); symbol_increment_ctr(Symbol);} while (0)
+#define symbol_set_local_slot_unchecked_and_unincremented(Symbol, Id, Slot) \
+ do {(Symbol)->object.sym.local_slot = T_Sln(Slot); symbol_set_id_unchecked(Symbol, Id);} while (0)
+#define symbol_set_local_slot(Symbol, Id, Slot) \
+ do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id); symbol_increment_ctr(Symbol);} while (0)
+#define symbol_set_local_slot_unincremented(Symbol, Id, Slot) \
+ do {set_local_slot(Symbol, Slot); symbol_set_id(Symbol, Id);} while (0)
+/* set slot before id in case Slot is an expression that tries to find the current Symbol slot (using its old Id obviously) */
+
+#define is_slot(p) (type(p) == T_SLOT)
+#define slot_symbol(p) T_Sym((T_Slt(p))->object.slt.sym)
+#define slot_set_symbol(p, Sym) (T_Slt(p))->object.slt.sym = T_Sym(Sym)
+#define slot_value(p) T_Nmv((T_Slt(p))->object.slt.val)
+#if S7_DEBUGGING
+/* how to see an unheaped and un-GC-checked slot with a heap value? Can't do it here because unheap=most rootlet slots */
+#define slot_set_value(slot, value) \
+ do { \
+ if (is_immutable_slot(slot)) {fprintf(stderr, "%s[%d]: setting immutable slot %s\n", __func__, __LINE__, symbol_name(slot_symbol(slot))); if (cur_sc->stop_at_error) abort();} \
+ (T_Slt(slot))->object.slt.val = T_Nmv(value); \
+ } while (0)
+#else
+#define slot_set_value(p, Val) (T_Slt(p))->object.slt.val = T_Nmv(Val)
+#endif
+#define slot_set_symbol_and_value(Slot, Symbol, Value) do {slot_set_symbol(Slot, Symbol); slot_set_value(Slot, Value);} while (0)
+#define slot_set_value_with_hook(Slot, Value) \
+ do {if (hook_has_functions(sc->rootlet_redefinition_hook)) slot_set_value_with_hook_1(sc, Slot, T_Nmv(Value)); else slot_set_value(Slot, T_Nmv(Value));} while (0)
+#define next_slot(p) T_Sln((T_Slt(p))->object.slt.nxt)
+#define slot_set_next(p, Val) (T_Slt(p))->object.slt.nxt = T_Sln(Val)
+#define slot_set_pending_value(p, Val) do {(T_Slt(p))->object.slt.pending_value = T_Nmv(Val); slot_set_has_pending_value(p);} while (0)
+#define slot_simply_set_pending_value(p, Val) (T_Slt(p))->object.slt.pending_value = T_Nmv(Val)
+#if S7_DEBUGGING
+static s7_pointer slot_pending_value(s7_pointer p) \
+ {if (slot_has_pending_value(p)) return(p->object.slt.pending_value); fprintf(stderr, "%s[%d]: slot: no pending value\n", __func__, __LINE__); abort(); return(NULL);}
+static s7_pointer slot_expression(s7_pointer p) \
+ {if (slot_has_expression(p)) return(p->object.slt.expr); fprintf(stderr, "%s[%d]: slot: no expression\n", __func__, __LINE__); abort(); return(NULL);}
+#else
+#define slot_pending_value(p) (T_Slt(p))->object.slt.pending_value
+#define slot_expression(p) (T_Slt(p))->object.slt.expr
+#endif
+#define slot_pending_value_unchecked(p) (T_Slt(p))->object.slt.pending_value
+
+#define slot_set_expression(p, Val) do {(T_Slt(p))->object.slt.expr = T_Ext(Val); slot_set_has_expression(p);} while (0)
+#define slot_just_set_expression(p, Val) (T_Slt(p))->object.slt.expr = T_Ext(Val)
+#define slot_setter(p) T_Prc((T_Slt(p)->object.slt.pending_value))
+#define slot_set_setter_1(p, Val) (T_Slt(p))->object.slt.pending_value = T_Prc(Val)
+#if S7_DEBUGGING
+#define tis_slot(p) ((p) && (T_Slt(p)))
+#else
+#define tis_slot(p) (p) /* used for loop through let slots which end in null, not for general slot recognition */
+#endif
+#define slot_end NULL
+#define is_slot_end(p) (!(p))
+
+#define is_syntax(p) (type(p) == T_SYNTAX)
+#define syntax_symbol(p) T_Sym((T_Syn(p))->object.syn.symbol)
+#define syntax_set_symbol(p, Sym) (T_Syn(p))->object.syn.symbol = T_Sym(Sym)
+#define syntax_opcode(p) (T_Syn(p))->object.syn.op
+#define syntax_min_args(p) (T_Syn(p))->object.syn.min_args
+#define syntax_max_args(p) (T_Syn(p))->object.syn.max_args
+#define syntax_documentation(p) (T_Syn(p))->object.syn.documentation
+#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 let_id(p) (T_Let(p))->object.envr.id
+#define let_set_id(p, Id) (T_Let(p))->object.envr.id = Id
+#define is_let(p) (type(p) == T_LET)
+#define is_let_unchecked(p) (unchecked_type(p) == T_LET)
+#define let_slots(p) T_Sln((T_Let(p))->object.envr.slots)
+#define let_outlet(p) T_Out((T_Let(p))->object.envr.nxt)
+#define let_set_outlet(p, ol) (T_Let(p))->object.envr.nxt = T_Out(ol)
+#if S7_DEBUGGING
+ #define let_set_slots(p, Slot) check_let_set_slots(p, Slot, __func__, __LINE__)
+ #define C_Let(p, role) check_let_ref(p, role, __func__, __LINE__)
+ #define S_Let(p, role) check_let_set(p, role, __func__, __LINE__)
+#else
+ #define let_set_slots(p, Slot) (T_Let(p))->object.envr.slots = T_Sln(Slot)
+ #define C_Let(p, role) p
+ #define S_Let(p, role) p
+#endif
+#define funclet_function(p) T_Sym((C_Let(p, L_FUNC))->object.envr.edat.efnc.function)
+#define funclet_set_function(p, F) (S_Let(p, L_FUNC))->object.envr.edat.efnc.function = T_Sym(F)
+#define set_curlet(Sc, P) Sc->curlet = T_Let(P)
+
+#define let_baffle_key(p) (T_Let(p))->object.envr.edat.key
+#define set_let_baffle_key(p, K) (T_Let(p))->object.envr.edat.key = K
+
+#define let_line(p) (C_Let(p, L_FUNC))->object.envr.edat.efnc.line
+#define let_set_line(p, L) (S_Let(p, L_FUNC))->object.envr.edat.efnc.line = L
+#define let_file(p) (C_Let(p, L_FUNC))->object.envr.edat.efnc.file
+#define let_set_file(p, F) (S_Let(p, L_FUNC))->object.envr.edat.efnc.file = F
+
+#define let_dox_slot1(p) T_Slt((C_Let(p, L_DOX))->object.envr.edat.dox.dox1)
+#define let_set_dox_slot1(p, S) do {(S_Let(p, L_DOX))->object.envr.edat.dox.dox1 = T_Slt(S); set_has_dox_slot1(p);} while (0)
+#define let_dox_slot2(p) T_Sld((C_Let(p, L_DOX))->object.envr.edat.dox.dox2)
+#define let_set_dox_slot2(p, S) do {(S_Let(p, L_DOX))->object.envr.edat.dox.dox2 = T_Slt(S); set_has_dox_slot2(p);} while (0)
+#define let_dox_slot2_unchecked(p) T_Sld(C_Let(p, L_DOX)->object.envr.edat.dox.dox2)
+#define let_set_dox_slot2_unchecked(p, S) do {S_Let(p, L_DOX)->object.envr.edat.dox.dox2 = T_Sld(S); set_has_dox_slot2(p);} while (0)
+#define let_dox1_value(p) slot_value(let_dox_slot1(p))
+#define let_dox2_value(p) slot_value(let_dox_slot2(p))
+
+#define unique_name(p) (p)->object.unq.name /* not T_Uniq(p) here -- see make_unique */
+#define unique_name_length(p) (p)->object.unq.len
+#define is_unspecified(p) (type(p) == T_UNSPECIFIED)
+#define unique_car(p) (p)->object.unq.car
+#define unique_cdr(p) (p)->object.unq.cdr
+
+#define is_undefined(p) (type(p) == T_UNDEFINED)
+#define undefined_name(p) (T_Undf(p))->object.undef.name
+#define undefined_name_length(p) (T_Undf(p))->object.undef.len
+#define undefined_set_name_length(p, L) (T_Undf(p))->object.undef.len = L
+#define eof_name(p) (T_Eof(p))->object.eof.name
+#define eof_name_length(p) (T_Eof(p))->object.eof.len
+
+#define is_any_vector(p) t_vector_p[type(p)]
+#define is_t_vector(p) (type(p) == T_VECTOR)
+#define vector_length(p) (p)->object.vector.length
+#define unchecked_vector_elements(p) (p)->object.vector.elements.objects
+#define unchecked_vector_element(p, i) ((p)->object.vector.elements.objects[i])
+#define vector_element(p, i) ((T_Nvc(p))->object.vector.elements.objects[i])
+#define vector_elements(p) (T_Nvc(p))->object.vector.elements.objects
+#define any_vector_elements(p) (T_Vec(p))->object.vector.elements.objects
+#define vector_getter(p) (T_Vec(p))->object.vector.vget
+#define vector_setter(p) (T_Vec(p))->object.vector.setv.vset
+#define vector_block(p) (T_Vec(p))->object.vector.block
+#define unchecked_vector_block(p) p->object.vector.block
+
+#define typed_vector_typer(p) T_Prc((T_Nvc(p))->object.vector.setv.fset)
+#define typed_vector_set_typer(p, Fnc) (T_Nvc(p))->object.vector.setv.fset = T_Prc(Fnc)
+#define typed_vector_gc_mark(p) ((is_c_function(typed_vector_typer(p))) ? c_function_marker(typed_vector_typer(p)) : mark_typed_vector_1)
+#define typed_vector_typer_call(sc, p, Args) \
+ ((is_c_function(typed_vector_typer(p))) ? c_function_call(typed_vector_typer(p))(sc, Args) : s7_apply_function(sc, typed_vector_typer(p), Args))
+
+#define is_int_vector(p) (type(p) == T_INT_VECTOR)
+#define int_vector(p, i) ((T_Ivc(p))->object.vector.elements.ints[i])
+#define int_vector_ints(p) (T_Ivc(p))->object.vector.elements.ints
+
+#define is_float_vector(p) (type(p) == T_FLOAT_VECTOR)
+#define float_vector(p, i) ((T_Fvc(p))->object.vector.elements.floats[i])
+#define float_vector_floats(p) (T_Fvc(p))->object.vector.elements.floats
+
+#define is_byte_vector(p) (type(p) == T_BYTE_VECTOR)
+#define byte_vector_length(p) (T_BVc(p))->object.vector.length
+#define byte_vector_bytes(p) (T_BVc(p))->object.vector.elements.bytes
+#define byte_vector(p, i) ((T_BVc(p))->object.vector.elements.bytes[i])
+#define is_string_or_byte_vector(p) ((type(p) == T_STRING) || (type(p) == T_BYTE_VECTOR))
+
+#define vector_dimension_info(p) ((vdims_t *)(T_Vec(p))->object.vector.block->ex.ex_info)
+#define vector_set_dimension_info(p, d) (T_Vec(p))->object.vector.block->ex.ex_info = (void *)d
+#define vector_ndims(p) vdims_rank(vector_dimension_info(p))
+#define vector_dimension(p, i) vdims_dims(vector_dimension_info(p))[i]
+#define vector_dimensions(p) vdims_dims(vector_dimension_info(p))
+#define vector_offset(p, i) vdims_offsets(vector_dimension_info(p))[i]
+#define vector_offsets(p) vdims_offsets(vector_dimension_info(p))
+#define vector_rank(p) ((vector_dimension_info(p)) ? vector_ndims(p) : 1)
+#define vector_has_dimension_info(p) (vector_dimension_info(p))
+
+#define subvector_vector(p) T_Vec(((vector_dimension_info(T_SVec(p))) ? vdims_original(vector_dimension_info(p)) : (p)->object.vector.block->nx.ksym))
+#define subvector_set_vector(p, vect) (T_SVec(p))->object.vector.block->nx.ksym = T_Vec(vect)
+
+#define stack_element(p, i) unchecked_vector_element(T_Stk(p), i)
+#define stack_elements(p) unchecked_vector_elements(T_Stk(p))
+#define stack_block(p) unchecked_vector_block(T_Stk(p))
+#define stack_top(Sc) ((Sc)->stack_end - (Sc)->stack_start)
+#define temp_stack_top(p) (T_Stk(p))->object.stk.top
+/* #define stack_flags(p) (T_Stk(p))->object.stk.flags */
+#define stack_clear_flags(p) (T_Stk(p))->object.stk.flags = 0
+#define stack_has_pairs(p) (((T_Stk(p))->object.stk.flags & 1) != 0)
+#define stack_set_has_pairs(p) (T_Stk(p))->object.stk.flags |= 1
+#define stack_has_counters(p) (((T_Stk(p))->object.stk.flags & 2) != 0)
+#define stack_set_has_counters(p) (T_Stk(p))->object.stk.flags |= 2
+
+#define is_hash_table(p) (type(p) == T_HASH_TABLE)
+#define is_mutable_hash_table(p) ((full_type(T_Ext(p)) & (TYPE_MASK | T_IMMUTABLE)) == T_HASH_TABLE)
+#define hash_table_mask(p) (T_Hsh(p))->object.hasher.mask
+#define hash_table_size(p) ((T_Hsh(p))->object.hasher.mask + 1)
+#define hash_table_block(p) (T_Hsh(p))->object.hasher.block
+#define unchecked_hash_table_block(p) p->object.hasher.block
+#define hash_table_set_block(p, b) (T_Hsh(p))->object.hasher.block = b
+#define hash_table_element(p, i) (T_Hsh(p))->object.hasher.elements[i]
+#define hash_table_elements(p) (T_Hsh(p))->object.hasher.elements /* block data (dx) */
+#define hash_table_entries(p) hash_table_block(p)->nx.nx_int
+#define hash_table_checker(p) (T_Hsh(p))->object.hasher.hash_func
+#define hash_table_mapper(p) (T_Hsh(p))->object.hasher.loc
+#define hash_table_procedures(p) T_Lst(hash_table_block(p)->ex.ex_ptr)
+#define hash_table_set_procedures(p, Lst) hash_table_block(p)->ex.ex_ptr = T_Lst(Lst) /* both the checker/mapper: car/cdr, and the two typers (opt1/opt2) */
+#define hash_table_procedures_checker(p) T_Prc(car(hash_table_procedures(p)))
+#define hash_table_procedures_mapper(p) T_Prc(cdr(hash_table_procedures(p)))
+#define hash_table_set_procedures_checker(p, f) set_car(hash_table_procedures(p), T_Prc(f))
+#define hash_table_set_procedures_mapper(p, f) set_cdr(hash_table_procedures(p), T_Prc(f))
+#define hash_table_key_typer(p) T_Prc(opt1_any(hash_table_procedures(p)))
+#define hash_table_key_typer_unchecked(p) hash_table_block(p)->ex.ex_ptr->object.cons.opt1
+#define hash_table_set_key_typer(p, Fnc) set_opt1_any(hash_table_procedures(T_Hsh(p)), T_Prc(Fnc))
+#define hash_table_value_typer(p) T_Prc(opt2_any(hash_table_procedures(p)))
+#define hash_table_value_typer_unchecked(p) hash_table_block(p)->ex.ex_ptr->object.cons.o2.opt2
+#define hash_table_set_value_typer(p, Fnc) set_opt2_any(hash_table_procedures(T_Hsh(p)), T_Prc(Fnc))
+#define weak_hash_iters(p) hash_table_block(p)->ln.tag
+
+#if S7_DEBUGGING
+#define T_Itr_Pos(p) titr_pos(sc, T_Itr(p), __func__, __LINE__)
+#define T_Itr_Len(p) titr_len(sc, T_Itr(p), __func__, __LINE__)
+#define T_Itr_Hash(p) titr_hash(sc, T_Itr(p), __func__, __LINE__)
+#define T_Itr_Let(p) titr_let(sc, T_Itr(p), __func__, __LINE__)
+#define T_Itr_Pair(p) titr_pair(sc, T_Itr(p), __func__, __LINE__)
+#else
+#define T_Itr_Pos(p) p
+#define T_Itr_Len(p) p
+#define T_Itr_Hash(p) p
+#define T_Itr_Let(p) p
+#define T_Itr_Pair(p) p
+#endif
+
+#define is_iterator(p) (type(p) == T_ITERATOR)
+#define iterator_sequence(p) (T_Itr(p))->object.iter.obj
+#define iterator_position(p) (T_Itr_Pos(p))->object.iter.lc.loc
+#define iterator_length(p) (T_Itr_Len(p))->object.iter.lw.len
+#define iterator_next(p) (T_Itr(p))->object.iter.next
+#define iterator_is_at_end(p) (!iter_ok(p)) /* ((full_type(T_Itr(p)) & T_ITER_OK) == 0) */
+#define iterator_slow(p) T_Lst((T_Itr_Pair(p))->object.iter.lw.slow)
+#define iterator_set_slow(p, Val) (T_Itr_Pair(p))->object.iter.lw.slow = T_Lst(Val)
+#define iterator_hash_current(p) (T_Itr_Hash(p))->object.iter.lw.hcur
+#define iterator_current(p) (T_Itr(p))->object.iter.cur
+#define iterator_current_slot(p) T_Sln((T_Itr_Let(p))->object.iter.lc.lcur)
+#define iterator_set_current_slot(p, Val) (T_Itr_Let(p))->object.iter.lc.lcur = T_Sln(Val)
+#define iterator_let_cons(p) (T_Itr_Let(p))->object.iter.cur
+
+#define ITERATOR_END eof_object
+#define ITERATOR_END_NAME "#<eof>"
+
+#define is_input_port(p) (type(p) == T_INPUT_PORT)
+#define is_output_port(p) (type(p) == T_OUTPUT_PORT)
+#define port_port(p) (T_Prt(p))->object.prt.port
+#define is_string_port(p) (port_type(p) == STRING_PORT)
+#define is_file_port(p) (port_type(p) == FILE_PORT)
+#define is_function_port(p) (port_type(p) == FUNCTION_PORT)
+#define port_filename_block(p) port_port(p)->filename_block
+#define port_filename(p) port_port(p)->filename
+#define port_filename_length(p) port_port(p)->filename_length
+#define port_file(p) port_port(p)->file
+#define port_data_block(p) port_port(p)->block
+#define unchecked_port_data_block(p) p->object.prt.port->block
+#define port_line_number(p) port_port(p)->line_number
+#define port_file_number(p) port_port(p)->file_number
+#define port_data(p) (T_Prt(p))->object.prt.data
+#define port_data_size(p) (T_Prt(p))->object.prt.size
+#define port_position(p) (T_Prt(p))->object.prt.point
+#define port_block(p) (T_Prt(p))->object.prt.block
+#define port_type(p) port_port(p)->ptype
+#define port_is_closed(p) port_port(p)->is_closed
+#define port_set_closed(p, Val) port_port(p)->is_closed = Val
+#define port_needs_free(p) port_port(p)->needs_free
+#define port_next(p) port_block(p)->nx.next
+#define port_output_function(p) port_port(p)->output_function /* these two are for function ports */
+#define port_input_function(p) port_port(p)->input_function
+#define port_string_or_function(p) port_port(p)->orig_str
+#define port_set_string_or_function(p, S) port_port(p)->orig_str = S
+
+#define current_input_port(Sc) T_Pri(Sc->input_port)
+#define set_current_input_port(Sc, P) Sc->input_port = T_Pri(P)
+#define current_output_port(Sc) T_Pro(Sc->output_port)
+#define set_current_output_port(Sc, P) Sc->output_port = T_Pro(P)
+#define current_error_port(Sc) T_Pro(Sc->error_port)
+#define set_current_error_port(Sc, P) Sc->error_port = T_Pro(P)
+
+#define port_read_character(p) port_port(p)->pf->read_character
+#define port_read_line(p) port_port(p)->pf->read_line
+#define port_display(p) port_port(p)->pf->displayer
+#define port_write_character(p) port_port(p)->pf->write_character
+#define port_write_string(p) port_port(p)->pf->write_string
+#define port_read_semicolon(p) port_port(p)->pf->read_semicolon
+#define port_read_white_space(p) port_port(p)->pf->read_white_space
+#define port_read_name(p) port_port(p)->pf->read_name
+#define port_read_sharp(p) port_port(p)->pf->read_sharp
+#define port_close(p) port_port(p)->pf->close_port
+
+#define is_c_function(f) (type(f) >= T_C_FUNCTION) /* does not include T_C_FUNCTION_STAR */
+#define is_c_function_star(f) (type(f) == T_C_FUNCTION_STAR)
+#define is_any_c_function(f) (type(f) >= T_C_FUNCTION_STAR)
+#define is_safe_c_function(f) ((is_c_function(f)) && (is_safe_procedure(f)))
+#define c_function_data(f) (T_Fnc(f))->object.fnc.c_proc
+#define c_function_call(f) (T_Fnc(f))->object.fnc.ff
+#define c_function_min_args(f) (T_Fnc(f))->object.fnc.required_args
+#define c_function_optional_args(f) (T_Fnc(f))->object.fnc.optional_args
+#define c_function_max_args(f) (T_Fnc(f))->object.fnc.all_args
+#define c_function_is_aritable(f, N) ((c_function_min_args(f) <= N) && (c_function_max_args(f) >= N))
+#define c_function_name(f) c_function_data(f)->name
+#define c_function_name_length(f) c_function_data(f)->name_length
+#define c_function_documentation(f) c_function_data(f)->doc
+#define c_function_signature(f) c_function_data(f)->signature
+#define c_function_setter(f) T_Prc(c_function_data(f)->setter)
+#define c_function_set_setter(f, Val) c_function_data(f)->setter = T_Prc(Val)
+#define c_function_class(f) c_function_data(f)->id
+#define c_function_chooser(f) c_function_data(f)->chooser
+#define c_function_base(f) T_Fnc(c_function_data(f)->generic_ff)
+#define c_function_set_base(f, Val) c_function_data(f)->generic_ff = T_Fnc(Val)
+#define c_function_marker(f) c_function_data(f)->cam.marker /* the mark function for the vector (mark_vector_1 etc) */
+#define c_function_set_marker(f, Val) c_function_data(f)->cam.marker = Val
+#define c_function_symbol(f) c_function_data(f)->sam.c_sym
+
+#define c_function_bool_setter(f) c_function_data(f)->dam.bool_setter
+#define c_function_set_bool_setter(f, Val) c_function_data(f)->dam.bool_setter = T_Fnc(Val)
+
+#define c_function_arg_defaults(f) c_function_data(T_Fst(f))->dam.arg_defaults
+#define c_function_call_args(f) c_function_data(T_Fst(f))->cam.call_args
+#define c_function_arg_names(f) c_function_data(T_Fst(f))->sam.arg_names
+
+#define set_c_function(X, f) do {set_opt1_cfunc(X, f); set_fn_direct(X, c_function_call(f));} while (0)
+#define c_function_opt_data(f) c_function_data(f)->opt_data
+
+#define is_c_macro(p) (type(p) == T_C_MACRO)
+#define c_macro_data(f) (T_CMac(f))->object.fnc.c_proc
+#define c_macro_call(f) (T_CMac(f))->object.fnc.ff
+#define c_macro_name(f) c_macro_data(f)->name
+#define c_macro_name_length(f) c_macro_data(f)->name_length
+#define c_macro_min_args(f) (T_CMac(f))->object.fnc.required_args
+#define c_macro_max_args(f) (T_CMac(f))->object.fnc.all_args
+#define c_macro_setter(f) T_Prc(c_macro_data(f)->setter)
+#define c_macro_set_setter(f, Val) c_macro_data(f)->setter = T_Prc(Val)
+#define could_be_macro_setter(Obj) t_macro_setter_p[type(Obj)]
+
+#define is_random_state(p) (type(p) == T_RANDOM_STATE)
+#define random_gmp_state(p) (p)->object.rng.state /* sweep sees free cell in big_random_state gc_list and needs to call gmprandclear on its value */
+#define random_seed(p) (T_Ran(p))->object.rng.seed
+#define random_carry(p) (T_Ran(p))->object.rng.carry
+
+#define continuation_block(p) (T_Con(p))->object.cwcc.block
+#define continuation_stack(p) T_Stk(T_Con(p)->object.cwcc.stack)
+#define continuation_set_stack(p, Val) (T_Con(p))->object.cwcc.stack = T_Stk(Val)
+#define continuation_stack_end(p) (T_Con(p))->object.cwcc.stack_end
+#define continuation_stack_start(p) (T_Con(p))->object.cwcc.stack_start
+#define continuation_stack_top(p) (continuation_stack_end(p) - continuation_stack_start(p))
+#define continuation_op_stack(p) (T_Con(p))->object.cwcc.op_stack
+#define continuation_stack_size(p) continuation_block(p)->nx.ix.i1
+#define continuation_op_loc(p) continuation_block(p)->nx.ix.i2
+#define continuation_op_size(p) continuation_block(p)->ln.tag
+#define continuation_key(p) continuation_block(p)->ex.ckey
+/* this can overflow int32_t -- baffle_key is s7_int, so ckey should be also */
+#define continuation_name(p) continuation_block(p)->dx.d_ptr
+
+#define call_exit_goto_loc(p) (T_Got(p))->object.rexit.goto_loc
+#define call_exit_op_loc(p) (T_Got(p))->object.rexit.op_stack_loc
+#define call_exit_active(p) (T_Got(p))->object.rexit.active
+#define call_exit_name(p) (T_Got(p))->object.rexit.name
+
+#define is_continuation(p) (type(p) == T_CONTINUATION)
+#define is_goto(p) (type(p) == T_GOTO)
+#define is_macro(p) (type(p) == T_MACRO)
+#define is_macro_star(p) (type(p) == T_MACRO_STAR)
+#define is_bacro(p) (type(p) == T_BACRO)
+#define is_bacro_star(p) (type(p) == T_BACRO_STAR)
+#define is_either_macro(p) ((is_macro(p)) || (is_macro_star(p)))
+#define is_either_bacro(p) ((is_bacro(p)) || (is_bacro_star(p)))
+
+#define is_closure(p) (type(p) == T_CLOSURE)
+#define is_closure_star(p) (type(p) == T_CLOSURE_STAR)
+#define closure_args(p) T_Arg((T_Clo(p))->object.func.args)
+#define closure_set_args(p, Val) (T_Clo(p))->object.func.args = T_Arg(Val)
+#define closure_body(p) (T_Pair((T_Clo(p))->object.func.body))
+#define closure_set_body(p, Val) (T_Clo(p))->object.func.body = T_Pair(Val)
+#define closure_let(p) T_Let((T_Clo(p))->object.func.env)
+#define closure_set_let(p, L) (T_Clo(p))->object.func.env = T_Let(L)
+#define closure_arity(p) (T_Clo(p))->object.func.arity
+#define closure_set_arity(p, A) (T_Clo(p))->object.func.arity = A
+
+#define closure_setter(p) (T_Prc((T_Clo(p))->object.func.setter))
+#define closure_set_setter(p, Val) (T_Clo(p))->object.func.setter = T_Prc(Val)
+#define closure_map_list(p) (T_Pair((T_Clo(p))->object.func.setter))
+#define closure_set_map_list(p, Val) (T_Clo(p))->object.func.setter = T_Pair(Val)
+#define closure_setter_or_map_list(p) (T_Clo(p)->object.func.setter)
+/* closure_map_list refers to a cyclic list detector in map; since in this case map makes a new closure for its own use,
+ * closure_map_list doesn't collide with closure_setter.
+ */
+
+#define CLOSURE_ARITY_NOT_SET 0x40000000
+#define MAX_ARITY 0x20000000
+#define closure_arity_unknown(p) (closure_arity(p) == CLOSURE_ARITY_NOT_SET)
+#define is_thunk(Sc, Fnc) ((type(Fnc) >= T_GOTO) && (s7_is_aritable(Sc, Fnc, 0)))
+
+#define hook_has_functions(p) (is_pair(s7_hook_functions(sc, T_Clo(p))))
+
+#define catch_tag(p) (T_Cat(p))->object.rcatch.tag
+#define catch_goto_loc(p) (T_Cat(p))->object.rcatch.goto_loc
+#define catch_op_loc(p) (T_Cat(p))->object.rcatch.op_stack_loc
+#define catch_cstack(p) (T_Cat(p))->object.rcatch.cstack
+#define catch_handler(p) T_Ext((T_Cat(p))->object.rcatch.handler)
+#define catch_set_handler(p, val) (T_Cat(p))->object.rcatch.handler = T_Ext(val)
+
+#define dynamic_wind_state(p) (T_Dyn(p))->object.winder.state
+#define dynamic_wind_in(p) (T_Dyn(p))->object.winder.in
+#define dynamic_wind_out(p) (T_Dyn(p))->object.winder.out
+#define dynamic_wind_body(p) (T_Dyn(p))->object.winder.body
+
+#define is_c_object(p) (type(p) == T_C_OBJECT)
+#define c_object_value(p) (T_Obj(p))->object.c_obj.value
+#define c_object_type(p) (T_Obj(p))->object.c_obj.type
+#define c_object_let(p) T_Let((T_Obj(p))->object.c_obj.e)
+#define c_object_set_let(p, L) (T_Obj(p))->object.c_obj.e = T_Let(L)
+#define c_object_s7(p) (T_Obj(p))->object.c_obj.sc
+
+#define c_object_info(Sc, p) Sc->c_object_types[c_object_type(T_Obj(p))]
+#define c_object_free(Sc, p) c_object_info(Sc, p)->free
+#define c_object_mark(Sc, p) c_object_info(Sc, p)->mark
+#define c_object_gc_mark(Sc, p) c_object_info(Sc, p)->gc_mark
+#define c_object_gc_free(Sc, p) c_object_info(Sc, p)->gc_free
+#define c_object_ref(Sc, p) c_object_info(Sc, p)->ref
+#define c_object_getf(Sc, p) c_object_info(Sc, p)->getter
+#define c_object_set(Sc, p) c_object_info(Sc, p)->set
+#define c_object_setf(Sc, p) c_object_info(Sc, p)->setter
+#if (!DISABLE_DEPRECATED)
+ #define c_object_print(Sc, p) c_object_info(Sc, p)->print
+#endif
+#define c_object_len(Sc, p) c_object_info(Sc, p)->length
+#define c_object_eql(Sc, p) c_object_info(Sc, p)->eql
+#define c_object_equal(Sc, p) c_object_info(Sc, p)->equal
+#define c_object_equivalent(Sc, p) c_object_info(Sc, p)->equivalent
+#define c_object_fill(Sc, p) c_object_info(Sc, p)->fill
+#define c_object_copy(Sc, p) c_object_info(Sc, p)->copy
+#define c_object_reverse(Sc, p) c_object_info(Sc, p)->reverse
+#define c_object_to_list(Sc, p) c_object_info(Sc, p)->to_list
+#define c_object_to_string(Sc, p) c_object_info(Sc, p)->to_string
+#define c_object_scheme_name(Sc, p) T_Str(c_object_info(Sc, p)->scheme_name)
+
+#define c_pointer(p) (T_Ptr(p))->object.cptr.c_pointer
+#define c_pointer_type(p) (T_Ptr(p))->object.cptr.c_type
+#define c_pointer_info(p) (T_Ptr(p))->object.cptr.info
+#define c_pointer_weak1(p) (T_Ptr(p))->object.cptr.weak1
+#define c_pointer_weak2(p) (T_Ptr(p))->object.cptr.weak2
+#define c_pointer_set_weak1(p, q) (T_Ptr(p))->object.cptr.weak1 = T_Ext(q)
+#define c_pointer_set_weak2(p, q) (T_Ptr(p))->object.cptr.weak2 = T_Ext(q)
+#define is_c_pointer(p) (type(p) == T_C_POINTER)
+
+#define is_counter(p) (type(p) == T_COUNTER)
+#define counter_result(p) (T_Ctr(p))->object.ctr.result
+#define counter_set_result(p, Val) (T_Ctr(p))->object.ctr.result = T_Ext(Val)
+#define counter_list(p) (T_Ctr(p))->object.ctr.list
+#define counter_set_list(p, Val) (T_Ctr(p))->object.ctr.list = T_Ext(Val)
+#define counter_capture(p) (T_Ctr(p))->object.ctr.cap
+#define counter_set_capture(p, Val) (T_Ctr(p))->object.ctr.cap = Val
+#define counter_let(p) T_Let((T_Ctr(p))->object.ctr.env)
+#define counter_set_let(p, L) (T_Ctr(p))->object.ctr.env = T_Let(L)
+#define counter_slots(p) T_Sln(T_Ctr(p)->object.ctr.slots)
+#define counter_set_slots(p, Val) (T_Ctr(p))->object.ctr.slots = T_Sln(Val)
+
+#if S7_DEBUGGING
+#define init_temp(p, Val) do {if (p != sc->unused) fprintf(stderr, "%s[%d]: init_temp %s\n", __func__, __LINE__, display(p)); p = T_Ext(Val);} while (0)
+#else
+#define init_temp(p, Val) p = Val
+#endif
+
+#if __cplusplus && HAVE_COMPLEX_NUMBERS
+ using namespace std; /* the code has to work in C as well as C++, so we can't scatter std:: all over the place */
+ typedef complex<s7_double> s7_complex;
+ static s7_double Real(complex<s7_double> x) {return(real(x));} /* protect the C++ name */
+ static s7_double Imag(complex<s7_double> x) {return(imag(x));}
+#endif
+
+#define integer(p) (T_Int(p))->object.number.integer_value
+#define set_integer(p, x) integer(p) = x
+#define real(p) (T_Rel(p))->object.number.real_value
+#define set_real(p, x) real(p) = x
+#define numerator(p) (T_Frc(p))->object.number.fraction_value.numerator
+#define set_numerator(p, x) numerator(p) = x
+#define denominator(p) (T_Frc(p))->object.number.fraction_value.denominator
+#define set_denominator(p, x) denominator(p) = x
+#define fraction(p) (((long_double)numerator(p)) / ((long_double)denominator(p)))
+#define inverted_fraction(p) (((long_double)denominator(p)) / ((long_double)numerator(p)))
+#define real_part(p) (T_Cmp(p))->object.number.complex_value.rl
+#define set_real_part(p, x) real_part(p) = x
+#define imag_part(p) (T_Cmp(p))->object.number.complex_value.im
+#define set_imag_part(p, x) imag_part(p) = x
+#if HAVE_COMPLEX_NUMBERS
+ #define to_c_complex(p) CMPLX(real_part(p), imag_part(p))
+#endif
+
+#if WITH_GMP
+#define big_integer(p) ((T_Bgi(p))->object.number.bgi->n)
+#define big_integer_nxt(p) (p)->object.number.bgi->nxt
+#define big_integer_bgi(p) (p)->object.number.bgi
+#define big_ratio(p) ((T_Bgf(p))->object.number.bgr->q)
+#define big_ratio_nxt(p) (p)->object.number.bgr->nxt
+#define big_ratio_bgr(p) (p)->object.number.bgr
+#define big_real(p) ((T_Bgr(p))->object.number.bgf->x)
+#define big_real_nxt(p) (p)->object.number.bgf->nxt
+#define big_real_bgf(p) (p)->object.number.bgf
+#define big_complex(p) ((T_Bgz(p))->object.number.bgc->z)
+#define big_complex_nxt(p) (p)->object.number.bgc->nxt
+#define big_complex_bgc(p) (p)->object.number.bgc
+#endif
+
+#if S7_DEBUGGING
+const char *display(s7_pointer obj);
+const char *display(s7_pointer obj)
+{
+ const char *res;
+ if (!has_methods(obj))
+ return(string_value(s7_object_to_string(cur_sc, obj, false)));
+ clear_type_bit(obj, T_HAS_METHODS); /* clear_has_methods calls T_Met -> check_ref_met */
+ res = string_value(s7_object_to_string(cur_sc, obj, false));
+ set_type_bit(obj, T_HAS_METHODS); /* same for set_has_methods */
+ return(res);
+}
+#else
+#define display(Obj) string_value(s7_object_to_string(cur_sc, Obj, false))
+#endif
+#define display_truncated(Obj) string_value(object_to_string_truncated(cur_sc, Obj))
+
+#if S7_DEBUGGING
+static void set_type_1(s7_pointer p, uint64_t f, const char *func, int32_t line)
+{
+ p->alloc_line = line;
+ p->alloc_func = func;
+ p->alloc_type = f;
+ p->explicit_free_line = 0;
+ p->uses++;
+ if (((f) & TYPE_MASK) == T_FREE)
+ fprintf(stderr, "%d: set free, %p type to %" PRIx64 "\n", __LINE__, p, (int64_t)(f));
+ else
+ if (((f) & TYPE_MASK) >= NUM_TYPES)
+ 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__);
+ }
+ full_type(p) = f;
+}
+#endif
+
+#define number_name(p) (char *)((T_Num(p))->object.number_name.name + 1)
+#define number_name_length(p) (T_Num(p))->object.number_name.name[0]
+
+static void set_number_name(s7_pointer p, const char *name, int32_t len)
+{
+ /* if no number name: teq +110 tread +30 tform +90 */
+ if ((len >= 0) && (len < NUMBER_NAME_SIZE) && (!is_mutable_number(p)))
+ {
+ set_has_number_name(p);
+ number_name_length(p) = (uint8_t)len;
+ memcpy((void *)number_name(p), (const void *)name, len);
+ (number_name(p))[len] = 0;
+ }
+}
+
+static s7_int s7_int_min = 0;
+static int32_t s7_int_digits_by_radix[17];
+
+#define S7_INT_BITS 63
+
+#define S7_INT64_MAX 9223372036854775807LL
+#define S7_INT64_MIN (int64_t)(-S7_INT64_MAX - 1LL)
+
+#define S7_INT32_MAX 2147483647LL
+#define S7_INT32_MIN (-S7_INT32_MAX - 1LL)
+
+static void init_int_limits(void)
+{
+#if WITH_GMP
+ #define S7_LOG_INT64_MAX 36.736800
+#else
+ /* actually not safe = (log (- (expt 2 63) 1)) and (log (- (expt 2 31) 1)) (using 63 and 31 bits) */
+ #define S7_LOG_INT64_MAX 43.668274
+#endif
+ s7_int_min = S7_INT64_MIN; /* see comment in s7_make_ratio -- we're trying to hack around a gcc bug (9.2.1 Ubuntu) */
+ s7_int_digits_by_radix[0] = 0;
+ s7_int_digits_by_radix[1] = 0;
+ for (int32_t i = 2; i < 17; i++)
+ s7_int_digits_by_radix[i] = (int32_t)(floor(S7_LOG_INT64_MAX / log((double)i)));
+}
+
+static s7_pointer make_permanent_integer(s7_int i)
+{
+ s7_pointer p = (s7_pointer)Calloc(1, sizeof(s7_cell)); /* Calloc to clear name */
+ full_type(p) = T_IMMUTABLE | T_INTEGER | T_UNHEAP;
+ set_integer(p, i);
+ return(p);
+}
+
+#define NUM_CHARS 256
+#ifndef NUM_SMALL_INTS
+ #define NUM_SMALL_INTS 8192
+#else
+#if (NUM_SMALL_INTS < NUM_CHARS) /* g_char_to_integer assumes this is at least NUM_CHARS, as does the byte_vector stuff (256) */
+ #error NUM_SMALL_INTS is less than NUM_CHARS which will not work
+#endif
+#endif
+
+static bool t_number_separator_p[NUM_CHARS];
+static s7_pointer *small_ints = NULL;
+#define small_int(Val) small_ints[Val]
+#define is_small_int(n) ((n & ~(NUM_SMALL_INTS - 1)) == 0) /* ((n >= 0) && (n < NUM_SMALL_INTS)) is slower */
+
+static s7_pointer real_zero, real_NaN, complex_NaN, real_pi, real_one, arity_not_set, max_arity, real_infinity, real_minus_infinity;
+static s7_pointer int_zero, int_one, int_two, int_three, minus_one, minus_two, mostfix, leastfix;
+
+static void init_small_ints(void)
+{
+ const char *ones[10] = {"0", "1", "2", "3", "4", "5", "6", "7", "8", "9"};
+ s7_cell *cells = (s7_cell *)Malloc(NUM_SMALL_INTS * sizeof(s7_cell)); /* was calloc 14-Apr-22 */
+ small_ints = (s7_pointer *)Malloc(NUM_SMALL_INTS * sizeof(s7_pointer));
+ for (int32_t i = 0; i < NUM_SMALL_INTS; i++)
+ {
+ s7_pointer p;
+ small_ints[i] = &cells[i];
+ p = small_ints[i];
+ full_type(p) = T_IMMUTABLE | T_INTEGER | T_UNHEAP;
+ set_integer(p, i);
+ }
+ for (int32_t i = 0; i < 10; i++)
+ set_number_name(small_ints[i], ones[i], 1);
+
+ /* setup a few other numbers while we're here */
+ #define EXTRA_NUMBERS 11
+ cells = (s7_cell *)Calloc(EXTRA_NUMBERS, sizeof(s7_cell));
+
+ #define init_integer(Ptr, Num, Name, Name_Len) \
+ do {set_full_type(Ptr, T_INTEGER | T_IMMUTABLE | T_UNHEAP); set_integer(Ptr, Num); set_number_name(Ptr, Name, Name_Len);} while (0)
+ #define init_integer_no_name(Ptr, Num) \
+ do {set_full_type(Ptr, T_INTEGER | T_IMMUTABLE | T_UNHEAP); set_integer(Ptr, Num);} while (0)
+ #define init_real(Ptr, Num, Name, Name_Len) \
+ do {set_full_type(Ptr, T_REAL | T_IMMUTABLE | T_UNHEAP); set_real(Ptr, Num); set_number_name(Ptr, Name, Name_Len);} while (0)
+ #define init_complex(Ptr, Real, Imag, Name, Name_Len) \
+ do {set_full_type(Ptr, T_COMPLEX | T_IMMUTABLE | T_UNHEAP); set_real_part(Ptr, Real); set_imag_part(Ptr, Imag); set_number_name(Ptr, Name, Name_Len);} while (0)
+
+ real_zero = &cells[0]; init_real(real_zero, 0.0, "0.0", 3);
+ real_one = &cells[1]; init_real(real_one, 1.0, "1.0", 3);
+ real_NaN = &cells[2]; init_real(real_NaN, NAN, "+nan.0", 6);
+ complex_NaN = &cells[10]; init_complex(complex_NaN, NAN, NAN, "+nan.0+nan.0i", 13);
+ real_infinity = &cells[3]; init_real(real_infinity, INFINITY, "+inf.0", 6);
+ real_minus_infinity = &cells[4]; init_real(real_minus_infinity, -INFINITY, "-inf.0", 6);
+ real_pi = &cells[5]; init_real(real_pi, 3.1415926535897932384626433832795029L, "pi", 2);
+
+ arity_not_set = &cells[6]; init_integer_no_name(arity_not_set, CLOSURE_ARITY_NOT_SET);
+ max_arity = &cells[7]; init_integer_no_name(max_arity, MAX_ARITY);
+ minus_one = &cells[8]; init_integer(minus_one, -1, "-1", 2);
+ minus_two = &cells[9]; init_integer(minus_two, -2, "-2", 2);
+ int_zero = small_ints[0];
+ int_one = small_ints[1];
+ int_two = small_ints[2];
+ int_three = small_ints[3];
+
+ mostfix = make_permanent_integer(S7_INT64_MAX);
+ leastfix = make_permanent_integer(s7_int_min);
+ set_number_name(mostfix, "9223372036854775807", 19);
+ set_number_name(leastfix, "-9223372036854775808", 20);
+
+ for (int32_t i = 0; i < NUM_CHARS; i++) t_number_separator_p[i] = true;
+ t_number_separator_p[(uint8_t)'i'] = false;
+ t_number_separator_p[(uint8_t)'+'] = false;
+ t_number_separator_p[(uint8_t)'-'] = false;
+ t_number_separator_p[(uint8_t)'/'] = false;
+ t_number_separator_p[(uint8_t)'@'] = false;
+ t_number_separator_p[(uint8_t)'.'] = false;
+ t_number_separator_p[(uint8_t)'e'] = false;
+ t_number_separator_p[(uint8_t)'E'] = false;
+}
+
+#define clamp_length(NLen, Len) (((NLen) < (Len)) ? (NLen) : (Len))
+
+
+/* -------------------------------------------------------------------------------- */
+#if (defined(__FreeBSD__)) || ((defined(__linux__)) && (__GLIBC__ >= 2) && (__GLIBC_MINOR__ > 17)) || (defined(__OpenBSD__)) || (defined(__NetBSD__))
+ static inline s7_int my_clock(void)
+ {
+ struct timespec ts;
+ clock_gettime(CLOCK_MONOTONIC, &ts);
+ /* coarse: 0.057u 0.007s, monotonic: 0.083u 0.007s, clock(): 0.624u 0.372s -- coarse since Linux 2.6.32, glibc > 2.17
+ * FreeBSD has CLOCK_MONOTONIC_FAST in place of COARSE, OpenBSD and netBSD have neither
+ * clock_getres places 1 in tv_nsec in linux, so I assume I divide billion/tv_nsec
+ * MacOSX has clock_get_time, and after Sierra 10.12 has clock_gettime
+ * apparently we include /usr/include/AvailabilityMacros.h, then #if MAC_OS_X_VERSION_MIN_REQUIRED >= MAC_OS_X_VERSION_10_12
+ * Windows has QueryPerformanceCounter or something
+ * maybe just check for POSIX compatibility?
+ */
+ return(ts.tv_sec * 1000000000 + ts.tv_nsec); /* accumulated into s7_int so this should be ok: s7.h gives it 64 bits */
+ }
+
+ static s7_int ticks_per_second(void)
+ {
+ struct timespec ts;
+ clock_getres(CLOCK_MONOTONIC, &ts);
+ return((ts.tv_nsec == 0) ? 1000000000 : (1000000000 / ts.tv_nsec));
+ }
+#else
+ #define my_clock clock /* but this is cpu time? */
+ #define ticks_per_second() CLOCKS_PER_SEC
+#endif
+
+#ifndef GC_TRIGGER_SIZE
+ #define GC_TRIGGER_SIZE 64
+#endif
+
+#if S7_DEBUGGING
+static void try_to_call_gc_1(s7_scheme *sc, const char *func, int32_t line);
+#define try_to_call_gc(Sc) try_to_call_gc_1(Sc, __func__, __LINE__)
+#else
+static void try_to_call_gc(s7_scheme *sc);
+#endif
+
+#define GC_STATS 1
+#define HEAP_STATS 2
+#define STACK_STATS 4
+#define PROTECTED_OBJECTS_STATS 8
+
+#define show_gc_stats(Sc) ((Sc->gc_stats & GC_STATS) != 0)
+#define show_stack_stats(Sc) ((Sc->gc_stats & STACK_STATS) != 0)
+#define show_heap_stats(Sc) ((Sc->gc_stats & HEAP_STATS) != 0)
+#define show_protected_objects_stats(Sc) ((Sc->gc_stats & PROTECTED_OBJECTS_STATS) != 0)
+
+
+/* new_cell has to include the new cell's type. In the free list, it is 0 (T_FREE). If we remove it here,
+ * but then hit some error before setting the type, the GC sweep thinks it is a free cell already and
+ * does not return it to the free list: a memory leak.
+ */
+#if (!S7_DEBUGGING)
+#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); \
+ } while (0)
+
+#define new_cell_no_check(Sc, Obj, Type) do {Obj = (*(--(Sc->free_heap_top))); set_full_type(Obj, Type);} while (0)
+ /* since sc->free_heap_trigger is GC_TRIGGER_SIZE above the free heap base, we don't need
+ * to check it repeatedly after the first such check.
+ */
+#else
+
+#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); \
+ } while (0)
+
+#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); \
+ } while (0)
+#endif
+
+/* #define gc_if_at_trigger(Sc) if (Sc->free_heap_top <= Sc->free_heap_trigger) try_to_call_gc(Sc) */
+
+#if WITH_GCC
+#define make_integer(Sc, N) \
+ ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell(Sc, _I_, T_INTEGER); set_integer(_I_, _N_); _I_;}) ); })
+#define make_integer_unchecked(Sc, N) \
+ ({ s7_int _N_; _N_ = (N); (is_small_int(_N_) ? small_int(_N_) : ({ s7_pointer _I_; new_cell_no_check(Sc, _I_, T_INTEGER); set_integer(_I_, _N_); _I_;}) ); })
+
+#define make_real(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;})
+#define make_real_unchecked(Sc, X) ({ s7_pointer _R_; s7_double _N_ = (X); new_cell_no_check(Sc, _R_, T_REAL); set_real(_R_, _N_); _R_;})
+
+#if S7_DEBUGGING
+#define make_complex_not_0i(Sc, R, I) \
+ ({ s7_double _im_; _im_ = (I); if (_im_ == 0.0) fprintf(stderr, "%s[%d]: make_complex i: %f\n", __func__, __LINE__, _im_); \
+ ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, _im_); _C_;}); })
+#else
+#define make_complex_not_0i(Sc, R, I) ({ s7_pointer _C_; new_cell(Sc, _C_, T_COMPLEX); set_real_part(_C_, R); set_imag_part(_C_, I); _C_;})
+#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_;}) ); })
+
+#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_)); })
+
+#else
+
+#define make_integer(Sc, N) s7_make_integer(Sc, N)
+#define make_integer_unchecked(Sc, N) s7_make_integer(Sc, N)
+#define make_real(Sc, X) s7_make_real(Sc, X)
+#define make_real_unchecked(Sc, X) s7_make_real(Sc, X)
+#define make_complex(Sc, R, I) s7_make_complex(Sc, R, I)
+#define make_complex_not_0i(Sc, R, I) s7_make_complex(Sc, R, I)
+#define real_to_double(Sc, X, Caller) s7_number_to_real_with_caller(Sc, X, Caller)
+#define rational_to_double(Sc, X) s7_number_to_real(Sc, X)
+#endif
+
+#if S7_DEBUGGING
+ static char *describe_type_bits(s7_scheme *sc, s7_pointer obj);
+#endif
+
+static s7_pointer wrapped_integer(s7_scheme *sc) /* wrap_integer without small_int possibility -- usable as a mutable integer for example */
+{
+ s7_pointer p = car(sc->integer_wrappers);
+#if S7_DEBUGGING
+ if ((full_type(p) & (~T_GC_MARK)) != (T_INTEGER | T_IMMUTABLE | T_UNHEAP | T_MUTABLE)) fprintf(stderr, "%s\n", describe_type_bits(sc, p));
+#endif
+ sc->integer_wrappers = cdr(sc->integer_wrappers);
+ return(p);
+}
+
+static s7_pointer wrap_integer(s7_scheme *sc, s7_int x)
+{
+ s7_pointer p;
+ if (is_small_int(x)) return(small_int(x));
+ p = car(sc->integer_wrappers);
+#if S7_DEBUGGING
+ if ((full_type(p) & (~T_GC_MARK)) != (T_INTEGER | T_IMMUTABLE | T_UNHEAP | T_MUTABLE)) fprintf(stderr, "%s\n", describe_type_bits(sc, p));
+#endif
+ set_integer(p, x);
+ sc->integer_wrappers = cdr(sc->integer_wrappers);
+ return(p);
+}
+
+#define wrapped_real(Sc) wrap_real(Sc, 0.0) /* here (unlike above) we don't need to protect against getting a built-in real */
+
+static s7_pointer wrap_real(s7_scheme *sc, s7_double x)
+{
+ s7_pointer p = car(sc->real_wrappers);
+#if S7_DEBUGGING
+ if ((full_type(p) & (~T_GC_MARK)) != (T_REAL | T_IMMUTABLE | T_UNHEAP | T_MUTABLE)) fprintf(stderr, "%s\n", describe_type_bits(sc, p));
+#endif
+ set_real(p, x);
+ sc->real_wrappers = cdr(sc->real_wrappers);
+ return(p);
+}
+
+
+/* --------------------------------------------------------------------------------
+ * local versions of some standard C library functions
+ * timing tests involving these are very hard to interpret, local_memset is faster using int64_t than int32_t
+ */
+
+static void local_memset(void *s, uint8_t val, size_t n)
+{
+ uint8_t *s2;
+#if S7_ALIGNED
+ s2 = (uint8_t *)s;
+#else
+#if (defined(__x86_64__) || defined(__i386__))
+ if (n >= 8)
+ {
+ int64_t *s1 = (int64_t *)s;
+ size_t n8 = n >> 3;
+ 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;}
+ else do {*s1++ = ival;} while (--n8 > 0);
+ n &= 7;
+ s2 = (uint8_t *)s1;
+ }
+ else s2 = (uint8_t *)s;
+#else
+ s2 = (uint8_t *)s;
+#endif
+#endif
+ while (n > 0)
+ {
+ *s2++ = val;
+ n--;
+ }
+}
+
+static inline s7_int safe_strlen(const char *str) /* this is safer than strlen, and slightly faster */
+{
+ const char *tmp = str;
+ if ((!tmp) || (!(*tmp))) return(0);
+ for (; *tmp; ++tmp);
+ return(tmp - str);
+}
+
+static char *copy_string_with_length(const char *str, s7_int len)
+{
+ char *newstr;
+ if ((S7_DEBUGGING) && ((len <= 0) || (!str))) fprintf(stderr, "%s[%d]: len: %" ld64 ", str: %s\n", __func__, __LINE__, len, str);
+ if (len > (1LL << 48)) return(NULL); /* squelch an idiotic warning */
+ newstr = (char *)Malloc(len + 1);
+ memcpy((void *)newstr, (const void *)str, len); /* we check len != 0 above -- 24-Jan-22 */
+ newstr[len] = '\0';
+ return(newstr);
+}
+
+static char *copy_string(const char *str) {return(copy_string_with_length(str, safe_strlen(str)));}
+
+#define local_strcmp(S1, S2) (strcmp(S1, S2) == 0)
+#define c_strings_are_equal(Str1, Str2) (local_strcmp(Str1, Str2)) /* scheme strings can have embedded nulls */
+
+static bool safe_strcmp(const char *s1, const char *s2)
+{
+ if ((!s1) || (!s2)) return(s1 == s2);
+ return(local_strcmp(s1, s2));
+}
+
+static bool local_strncmp(const char *s1, const char *s2, size_t n) /* not strncmp because scheme strings can have embedded nulls */
+{
+#if ((!S7_ALIGNED) && (defined(__x86_64__) || defined(__i386__))) /* unaligned accesses are safe on i386 hardware, sez everyone */
+ if (n >= 8)
+ {
+ size_t n8 = n >> 3;
+ int64_t *is1 = (int64_t *)s1, *is2 = (int64_t *)s2;
+ do {if (*is1++ != *is2++) return(false);} while (--n8 > 0); /* in tbig LOOP_4 is slower? */
+ s1 = (const char *)is1;
+ s2 = (const char *)is2;
+ n &= 7;
+ }
+#endif
+ while (n > 0)
+ {
+ if (*s1++ != *s2++) return(false);
+ n--;
+ }
+ return(true);
+}
+
+#define strings_are_equal_with_length(Str1, Str2, Len) (local_strncmp(Str1, Str2, Len))
+
+static Sentinel size_t catstrs(char *dst, size_t len, ...) /* NULL-terminated arg list */
+{
+ const char *dend = (const char *)(dst + len - 1); /* -1 for null at end? */
+ char *d = dst;
+ va_list ap;
+ while ((*d) && (d < dend)) d++; /* stop at NULL or end-of-buffer */
+ va_start(ap, len);
+ for (const char *s = va_arg(ap, const char *); s != NULL; s = va_arg(ap, const char *))
+ while ((*s) && (d < dend)) {*d++ = *s++;}
+ *d = '\0';
+ va_end (ap);
+ return(d - dst);
+}
+
+static Sentinel size_t catstrs_direct(char *dst, const char *s1, ...)
+{ /* NULL-terminated arg list, dst is destination only (assumed empty), all args known to fit in dst */
+ char *d = dst;
+ va_list ap;
+ va_start(ap, s1);
+ for (const char *s = s1; s != NULL; s = va_arg(ap, const char *))
+ while (*s) {*d++ = *s++;}
+ *d = '\0';
+ va_end (ap);
+ return(d - dst);
+}
+
+static char *pos_int_to_str(s7_scheme *sc, s7_int num, s7_int *len, char endc)
+{
+ char *p = (char *)(sc->int_to_str3 + INT_TO_STR_SIZE - 1);
+ char *op = p;
+ *p-- = '\0';
+ if (endc != '\0') *p-- = endc;
+ do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num);
+ (*len) = op - p; /* this includes the trailing #\null */
+ return((char *)(p + 1));
+}
+
+static char *pos_int_to_str_direct(s7_scheme *sc, s7_int num)
+{
+ char *p = (char *)(sc->int_to_str4 + INT_TO_STR_SIZE - 1);
+ *p-- = '\0';
+ do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num);
+ return((char *)(p + 1));
+}
+
+static char *pos_int_to_str_direct_1(s7_scheme *sc, s7_int num)
+{
+ char *p = (char *)(sc->int_to_str5 + INT_TO_STR_SIZE - 1);
+ *p-- = '\0';
+ do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num);
+ return((char *)(p + 1));
+}
+
+#if WITH_GCC
+ #if S7_DEBUGGING
+ static s7_pointer lookup_1(s7_scheme *sc, const s7_pointer symbol);
+ #define lookup(Sc, Sym) check_null_sym(Sc, lookup_1(Sc, Sym), Sym, __LINE__, __func__)
+ static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, int32_t line, const char *func);
+ #define lookup_unexamined(Sc, Sym) lookup_1(Sc, Sym)
+ #define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup_1(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));})
+ #else
+ static inline s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol);
+ #define lookup_unexamined(Sc, Sym) lookup(Sc, Sym)
+ #define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup(Sc, Sym); ((_x_) ? _x_ : unbound_variable(Sc, Sym));})
+ #endif
+#else
+ static inline s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol);
+ #define lookup_unexamined(Sc, Sym) s7_symbol_value(Sc, Sym) /* changed 3-Nov-22 -- we're using lookup_unexamined below to avoid the unbound_variable check */
+ #define lookup_checked(Sc, Sym) lookup(Sc, Sym)
+#endif
+static s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer e);
+
+
+/* ---------------- evaluator ops ---------------- */
+/* C=constant, S=symbol, A=fx-callable, Q=quote, N=any number of next >= 1, FX=list of A's, P=parlous?, O=one form, M=multiform */
+enum {OP_UNOPT, OP_GC_PROTECT, /* must be an even number of ops here, op_gc_protect used below as lower boundary marker */
+
+ OP_SAFE_C_NC, HOP_SAFE_C_NC, OP_SAFE_C_S, HOP_SAFE_C_S,
+ OP_SAFE_C_SS, HOP_SAFE_C_SS, OP_SAFE_C_SC, HOP_SAFE_C_SC, OP_SAFE_C_CS, HOP_SAFE_C_CS, OP_SAFE_C_CQ, HOP_SAFE_C_CQ,
+ OP_SAFE_C_SSS, HOP_SAFE_C_SSS, OP_SAFE_C_SCS, HOP_SAFE_C_SCS, OP_SAFE_C_SSC, HOP_SAFE_C_SSC, OP_SAFE_C_CSS, HOP_SAFE_C_CSS,
+ OP_SAFE_C_SCC, HOP_SAFE_C_SCC, OP_SAFE_C_CSC, HOP_SAFE_C_CSC, OP_SAFE_C_CCS, HOP_SAFE_C_CCS,
+ OP_SAFE_C_NS, HOP_SAFE_C_NS, OP_SAFE_C_opNCq, HOP_SAFE_C_opNCq, OP_SAFE_C_opSq, HOP_SAFE_C_opSq,
+ OP_SAFE_C_opSSq, HOP_SAFE_C_opSSq, OP_SAFE_C_opSCq, HOP_SAFE_C_opSCq,
+ OP_SAFE_C_opCSq, HOP_SAFE_C_opCSq, OP_SAFE_C_S_opSq, HOP_SAFE_C_S_opSq,
+ OP_SAFE_C_C_opSCq, HOP_SAFE_C_C_opSCq, OP_SAFE_C_S_opSCq, HOP_SAFE_C_S_opSCq, OP_SAFE_C_S_opCSq, HOP_SAFE_C_S_opCSq,
+ OP_SAFE_C_opSq_S, HOP_SAFE_C_opSq_S, OP_SAFE_C_opSq_C, HOP_SAFE_C_opSq_C,
+ OP_SAFE_C_opSq_opSq, HOP_SAFE_C_opSq_opSq, OP_SAFE_C_S_opSSq, HOP_SAFE_C_S_opSSq, OP_SAFE_C_C_opSq, HOP_SAFE_C_C_opSq,
+ OP_SAFE_C_opCSq_C, HOP_SAFE_C_opCSq_C, OP_SAFE_C_opSSq_C, HOP_SAFE_C_opSSq_C, OP_SAFE_C_C_opSSq, HOP_SAFE_C_C_opSSq,
+ OP_SAFE_C_opSSq_opSSq, HOP_SAFE_C_opSSq_opSSq, OP_SAFE_C_opSSq_opSq, HOP_SAFE_C_opSSq_opSq, OP_SAFE_C_opSq_opSSq, HOP_SAFE_C_opSq_opSSq,
+ OP_SAFE_C_opSSq_S, HOP_SAFE_C_opSSq_S, OP_SAFE_C_opCSq_S, HOP_SAFE_C_opCSq_S, OP_SAFE_C_opSCq_C, HOP_SAFE_C_opSCq_C,
+ OP_SAFE_C_op_opSSqq_S, HOP_SAFE_C_op_opSSqq_S, OP_SAFE_C_op_opSqq, HOP_SAFE_C_op_opSqq,
+ OP_SAFE_C_op_S_opSqq, HOP_SAFE_C_op_S_opSqq, OP_SAFE_C_op_opSq_Sq, HOP_SAFE_C_op_opSq_Sq, OP_SAFE_C_opSq_CS, HOP_SAFE_C_opSq_CS,
+
+ OP_SAFE_C_A, HOP_SAFE_C_A, OP_SAFE_C_AA, HOP_SAFE_C_AA, OP_SAFE_C_SA, HOP_SAFE_C_SA, OP_SAFE_C_AS, HOP_SAFE_C_AS,
+ OP_SAFE_C_CA, HOP_SAFE_C_CA, OP_SAFE_C_AC, HOP_SAFE_C_AC, OP_SAFE_C_AAA, HOP_SAFE_C_AAA, OP_SAFE_C_4A, HOP_SAFE_C_4A,
+ OP_SAFE_C_NA, HOP_SAFE_C_NA, OP_SAFE_C_ALL_CA, HOP_SAFE_C_ALL_CA,
+ OP_SAFE_C_SSA, HOP_SAFE_C_SSA, OP_SAFE_C_SAS, HOP_SAFE_C_SAS, OP_SAFE_C_SAA, HOP_SAFE_C_SAA,
+ OP_SAFE_C_CSA, HOP_SAFE_C_CSA, OP_SAFE_C_SCA, HOP_SAFE_C_SCA, OP_SAFE_C_ASS, HOP_SAFE_C_ASS,
+ OP_SAFE_C_CAC, HOP_SAFE_C_CAC, OP_SAFE_C_AGG, HOP_SAFE_C_AGG,
+ OP_SAFE_C_opAq, HOP_SAFE_C_opAq, OP_SAFE_C_opAAq, HOP_SAFE_C_opAAq, OP_SAFE_C_opAAAq, HOP_SAFE_C_opAAAq,
+ OP_SAFE_C_S_opAq, HOP_SAFE_C_S_opAq, OP_SAFE_C_opAq_S, HOP_SAFE_C_opAq_S, OP_SAFE_C_S_opAAq, HOP_SAFE_C_S_opAAq,
+ OP_SAFE_C_STAR, HOP_SAFE_C_STAR, OP_SAFE_C_STAR_A, HOP_SAFE_C_STAR_A,
+ OP_SAFE_C_STAR_AA, HOP_SAFE_C_STAR_AA, OP_SAFE_C_STAR_NA, HOP_SAFE_C_STAR_NA,
+
+ OP_SAFE_C_P, HOP_SAFE_C_P, OP_SAFE_C_PP, HOP_SAFE_C_PP, OP_SAFE_C_FF, HOP_SAFE_C_FF, OP_SAFE_C_SP, HOP_SAFE_C_SP,
+ OP_SAFE_C_CP, HOP_SAFE_C_CP, OP_SAFE_C_AP, HOP_SAFE_C_AP, OP_SAFE_C_PA, HOP_SAFE_C_PA, OP_SAFE_C_PS, HOP_SAFE_C_PS,
+ OP_SAFE_C_PC, HOP_SAFE_C_PC, OP_SAFE_C_SSP, HOP_SAFE_C_SSP, OP_ANY_C_NP, HOP_ANY_C_NP, OP_SAFE_C_3P, HOP_SAFE_C_3P,
+
+ OP_THUNK, HOP_THUNK, OP_THUNK_O, HOP_THUNK_O, OP_THUNK_ANY, HOP_THUNK_ANY,
+ OP_SAFE_THUNK, HOP_SAFE_THUNK, OP_SAFE_THUNK_A, HOP_SAFE_THUNK_A, OP_SAFE_THUNK_ANY, HOP_SAFE_THUNK_ANY,
+
+ OP_CLOSURE_S, HOP_CLOSURE_S, OP_CLOSURE_S_O, HOP_CLOSURE_S_O,
+ OP_CLOSURE_A, HOP_CLOSURE_A, OP_CLOSURE_A_O, HOP_CLOSURE_A_O, OP_CLOSURE_P, HOP_CLOSURE_P,
+ OP_CLOSURE_AP, HOP_CLOSURE_AP, OP_CLOSURE_PA, HOP_CLOSURE_PA, OP_CLOSURE_PP, HOP_CLOSURE_PP,
+ OP_CLOSURE_FA, HOP_CLOSURE_FA, OP_CLOSURE_SS, HOP_CLOSURE_SS, OP_CLOSURE_SS_O, HOP_CLOSURE_SS_O,
+ OP_CLOSURE_SC, HOP_CLOSURE_SC, OP_CLOSURE_SC_O, HOP_CLOSURE_SC_O,
+ OP_CLOSURE_3S, HOP_CLOSURE_3S, OP_CLOSURE_3S_O, HOP_CLOSURE_3S_O, OP_CLOSURE_4S, HOP_CLOSURE_4S, OP_CLOSURE_4S_O, HOP_CLOSURE_4S_O, OP_CLOSURE_5S, HOP_CLOSURE_5S,
+ OP_CLOSURE_AA, HOP_CLOSURE_AA, OP_CLOSURE_AA_O, HOP_CLOSURE_AA_O, OP_CLOSURE_3A, HOP_CLOSURE_3A, OP_CLOSURE_4A, HOP_CLOSURE_4A,
+ OP_CLOSURE_NA, HOP_CLOSURE_NA, OP_CLOSURE_ASS, HOP_CLOSURE_ASS, OP_CLOSURE_SAS, HOP_CLOSURE_SAS ,OP_CLOSURE_AAS, HOP_CLOSURE_AAS,
+ OP_CLOSURE_SAA, HOP_CLOSURE_SAA, OP_CLOSURE_ASA, HOP_CLOSURE_ASA, OP_CLOSURE_NS, HOP_CLOSURE_NS,
+
+ OP_SAFE_CLOSURE_S, HOP_SAFE_CLOSURE_S, OP_SAFE_CLOSURE_S_O, HOP_SAFE_CLOSURE_S_O,
+ OP_SAFE_CLOSURE_S_A, HOP_SAFE_CLOSURE_S_A, OP_SAFE_CLOSURE_S_TO_S, HOP_SAFE_CLOSURE_S_TO_S, OP_SAFE_CLOSURE_S_TO_SC, HOP_SAFE_CLOSURE_S_TO_SC,
+ OP_SAFE_CLOSURE_P, HOP_SAFE_CLOSURE_P, OP_SAFE_CLOSURE_P_A, HOP_SAFE_CLOSURE_P_A,
+ OP_SAFE_CLOSURE_AP, HOP_SAFE_CLOSURE_AP, OP_SAFE_CLOSURE_PA, HOP_SAFE_CLOSURE_PA, OP_SAFE_CLOSURE_PP, HOP_SAFE_CLOSURE_PP,
+ OP_SAFE_CLOSURE_A, HOP_SAFE_CLOSURE_A, OP_SAFE_CLOSURE_A_O, HOP_SAFE_CLOSURE_A_O, OP_SAFE_CLOSURE_A_A, HOP_SAFE_CLOSURE_A_A,
+ OP_SAFE_CLOSURE_A_TO_SC, HOP_SAFE_CLOSURE_A_TO_SC,
+ OP_SAFE_CLOSURE_SS, HOP_SAFE_CLOSURE_SS, OP_SAFE_CLOSURE_SS_O, HOP_SAFE_CLOSURE_SS_O, OP_SAFE_CLOSURE_SS_A, HOP_SAFE_CLOSURE_SS_A,
+ OP_SAFE_CLOSURE_SC, HOP_SAFE_CLOSURE_SC, OP_SAFE_CLOSURE_SC_O, HOP_SAFE_CLOSURE_SC_O,
+ OP_SAFE_CLOSURE_AA, HOP_SAFE_CLOSURE_AA, OP_SAFE_CLOSURE_AA_O, HOP_SAFE_CLOSURE_AA_O, OP_SAFE_CLOSURE_AA_A, HOP_SAFE_CLOSURE_AA_A,
+ OP_SAFE_CLOSURE_SAA, HOP_SAFE_CLOSURE_SAA, OP_SAFE_CLOSURE_SSA, HOP_SAFE_CLOSURE_SSA,
+ OP_SAFE_CLOSURE_AGG, HOP_SAFE_CLOSURE_AGG, OP_SAFE_CLOSURE_3A, HOP_SAFE_CLOSURE_3A, OP_SAFE_CLOSURE_NA, HOP_SAFE_CLOSURE_NA,
+ OP_SAFE_CLOSURE_3S, HOP_SAFE_CLOSURE_3S, OP_SAFE_CLOSURE_NS, HOP_SAFE_CLOSURE_NS, /* safe_closure_4s gained very little */
+ OP_SAFE_CLOSURE_3S_A, HOP_SAFE_CLOSURE_3S_A,
+ /* ssa|saa|ns|na|3s|agg|3a|sc|ap|pa|pp_a ? thunk_o? op_closure_ns? */
+
+ OP_ANY_CLOSURE_3P, HOP_ANY_CLOSURE_3P, OP_ANY_CLOSURE_4P, HOP_ANY_CLOSURE_4P, OP_ANY_CLOSURE_NP, HOP_ANY_CLOSURE_NP,
+ OP_ANY_CLOSURE_SYM, HOP_ANY_CLOSURE_SYM, OP_ANY_CLOSURE_A_SYM, HOP_ANY_CLOSURE_A_SYM,
+
+ OP_CLOSURE_STAR_A, HOP_CLOSURE_STAR_A, OP_CLOSURE_STAR_NA, HOP_CLOSURE_STAR_NA,
+ OP_SAFE_CLOSURE_STAR_A, HOP_SAFE_CLOSURE_STAR_A, OP_SAFE_CLOSURE_STAR_AA, HOP_SAFE_CLOSURE_STAR_AA,
+ OP_SAFE_CLOSURE_STAR_AA_O, HOP_SAFE_CLOSURE_STAR_AA_O, OP_SAFE_CLOSURE_STAR_A1, HOP_SAFE_CLOSURE_STAR_A1,
+ OP_SAFE_CLOSURE_STAR_KA, HOP_SAFE_CLOSURE_STAR_KA, OP_CLOSURE_STAR_KA, HOP_CLOSURE_STAR_KA, OP_SAFE_CLOSURE_STAR_3A, HOP_SAFE_CLOSURE_STAR_3A,
+ OP_SAFE_CLOSURE_STAR_NA, HOP_SAFE_CLOSURE_STAR_NA, OP_SAFE_CLOSURE_STAR_NA_0, HOP_SAFE_CLOSURE_STAR_NA_0,
+ OP_SAFE_CLOSURE_STAR_NA_1, HOP_SAFE_CLOSURE_STAR_NA_1, OP_SAFE_CLOSURE_STAR_NA_2, HOP_SAFE_CLOSURE_STAR_NA_2,
+
+ OP_C_SS, HOP_C_SS, OP_C_S, HOP_C_S, OP_READ_S, HOP_READ_S, OP_C_P, HOP_C_P, OP_C_AP, HOP_C_AP,
+ OP_C_A, HOP_C_A, OP_C_AA, HOP_C_AA, OP_C, HOP_C, OP_C_NC, HOP_C_NC, OP_C_NA, HOP_C_NA,
+
+ OP_CL_S, HOP_CL_S, OP_CL_SS, HOP_CL_SS, OP_CL_A, HOP_CL_A, OP_CL_AA, HOP_CL_AA,
+ OP_CL_NA, HOP_CL_NA, OP_CL_FA, HOP_CL_FA, OP_CL_SAS, HOP_CL_SAS,
+ /* end of h_opts */
+
+ OP_APPLY_SS, OP_APPLY_SA, OP_APPLY_SL, OP_MACRO_D, OP_MACRO_STAR_D,
+ OP_WITH_IO, OP_WITH_IO_1, OP_WITH_OUTPUT_TO_STRING, OP_WITH_IO_C, OP_CALL_WITH_OUTPUT_STRING,
+ OP_S, OP_S_G, OP_S_A, OP_S_AA, OP_A_A, OP_A_AA, OP_A_SC, OP_P_S, OP_P_S_1, OP_MAP_FOR_EACH_FA, OP_MAP_FOR_EACH_FAA,
+ OP_F, OP_F_A, OP_F_AA, OP_F_NP, OP_F_NP_1,
+
+ OP_IMPLICIT_GOTO, OP_IMPLICIT_GOTO_A, OP_IMPLICIT_CONTINUATION_A, OP_IMPLICIT_ITERATE,
+ OP_IMPLICIT_VECTOR_REF_A, OP_IMPLICIT_VECTOR_REF_AA, OP_IMPLICIT_VECTOR_SET_3, OP_IMPLICIT_VECTOR_SET_4,
+ OP_IMPLICIT_STRING_REF_A, OP_IMPLICIT_C_OBJECT_REF_A, OP_IMPLICIT_PAIR_REF_A, OP_IMPLICIT_PAIR_REF_AA,
+ OP_IMPLICIT_HASH_TABLE_REF_A, OP_IMPLICIT_HASH_TABLE_REF_AA,
+ OP_IMPLICIT_LET_REF_C, OP_IMPLICIT_LET_REF_A, OP_IMPLICIT_S7_STARLET_REF_S, OP_IMPLICIT_S7_STARLET_SET,
+ OP_UNKNOWN, OP_UNKNOWN_NS, OP_UNKNOWN_NA, OP_UNKNOWN_S, OP_UNKNOWN_GG, OP_UNKNOWN_A, OP_UNKNOWN_AA, OP_UNKNOWN_NP,
+
+ OP_SYMBOL, OP_CONSTANT, OP_PAIR_SYM, OP_PAIR_PAIR, OP_PAIR_ANY, HOP_HASH_TABLE_INCREMENT, OP_CLEAR_OPTS,
+
+ OP_READ_INTERNAL, OP_EVAL, OP_EVAL_ARGS, OP_EVAL_ARGS1, OP_EVAL_ARGS2, OP_EVAL_ARGS3, OP_EVAL_ARGS4, OP_EVAL_ARGS5,
+ OP_EVAL_SET1_NO_MV, OP_EVAL_SET2, OP_EVAL_SET2_MV, OP_EVAL_SET2_NO_MV, OP_EVAL_SET3, OP_EVAL_SET3_MV, OP_EVAL_SET3_NO_MV,
+ OP_APPLY, OP_EVAL_MACRO, OP_LAMBDA, OP_QUOTE, OP_QUOTE_UNCHECKED, OP_MACROEXPAND, OP_CALL_CC, OP_CALL_WITH_EXIT, OP_CALL_WITH_EXIT_O,
+ OP_C_CATCH, OP_C_CATCH_ALL, OP_C_CATCH_ALL_O, OP_C_CATCH_ALL_A,
+
+ OP_DEFINE, OP_DEFINE1, OP_BEGIN, OP_BEGIN_HOOK, OP_BEGIN_NO_HOOK, OP_BEGIN_UNCHECKED, OP_BEGIN_2_UNCHECKED, OP_BEGIN_NA, OP_BEGIN_AA,
+ OP_IF, OP_IF1, OP_WHEN, OP_UNLESS, OP_SET, OP_SET1, OP_SET2,
+ OP_LET, OP_LET1, OP_LET_STAR, OP_LET_STAR1, OP_LET_STAR2, OP_LET_STAR_SHADOWED,
+ OP_LETREC, OP_LETREC1, OP_LETREC_STAR, OP_LETREC_STAR1,
+ OP_LET_TEMPORARILY, OP_LET_TEMP_UNCHECKED, OP_LET_TEMP_INIT1, OP_LET_TEMP_INIT2, OP_LET_TEMP_DONE, OP_LET_TEMP_DONE1,
+ OP_LET_TEMP_S7, OP_LET_TEMP_NA, OP_LET_TEMP_A, OP_LET_TEMP_SETTER, OP_LET_TEMP_UNWIND, OP_LET_TEMP_S7_UNWIND, OP_LET_TEMP_SETTER_UNWIND,
+ OP_LET_TEMP_A_A, OP_LET_TEMP_S7_DIRECT, OP_LET_TEMP_S7_DIRECT_UNWIND,
+ OP_COND, OP_COND1, OP_FEED_TO_1, OP_COND_SIMPLE, OP_COND1_SIMPLE, OP_COND_SIMPLE_O, OP_COND1_SIMPLE_O,
+ OP_AND, OP_OR,
+ OP_DEFINE_MACRO, OP_DEFINE_MACRO_STAR, OP_DEFINE_EXPANSION, OP_DEFINE_EXPANSION_STAR, OP_MACRO, OP_MACRO_STAR,
+ OP_CASE,
+ OP_READ_LIST, OP_READ_NEXT, OP_READ_DOT, OP_READ_QUOTE,
+ OP_READ_QUASIQUOTE, OP_READ_UNQUOTE, OP_READ_APPLY_VALUES,
+ OP_READ_VECTOR, OP_READ_BYTE_VECTOR, OP_READ_INT_VECTOR, OP_READ_FLOAT_VECTOR, OP_READ_DONE,
+ OP_LOAD_RETURN_IF_EOF, OP_LOAD_CLOSE_AND_POP_IF_EOF, OP_EVAL_DONE, OP_SPLICE_VALUES, OP_NO_VALUES,
+ OP_CATCH, OP_DYNAMIC_WIND, OP_DYNAMIC_UNWIND, OP_DYNAMIC_UNWIND_PROFILE, OP_PROFILE_IN,
+ OP_DEFINE_CONSTANT, OP_DEFINE_CONSTANT1,
+ OP_DO, OP_DO_END, OP_DO_END1, OP_DO_STEP, OP_DO_STEP2, OP_DO_INIT,
+ OP_DEFINE_STAR, OP_LAMBDA_STAR, OP_LAMBDA_STAR_DEFAULT, OP_ERROR_QUIT, OP_UNWIND_INPUT, OP_UNWIND_OUTPUT, OP_ERROR_HOOK_QUIT,
+ OP_WITH_LET, OP_WITH_LET1, OP_WITH_LET_UNCHECKED, OP_WITH_LET_S,
+ OP_WITH_BAFFLE, OP_WITH_BAFFLE_UNCHECKED, OP_EXPANSION,
+ OP_FOR_EACH, OP_FOR_EACH_1, OP_FOR_EACH_2, OP_FOR_EACH_3,
+ OP_MAP, OP_MAP_1, OP_MAP_2, OP_MAP_GATHER, OP_MAP_GATHER_1, OP_MAP_GATHER_2, OP_MAP_GATHER_3, OP_MAP_UNWIND,
+ OP_BARRIER, OP_DEACTIVATE_GOTO,
+ OP_DEFINE_BACRO, OP_DEFINE_BACRO_STAR, OP_BACRO, OP_BACRO_STAR,
+ OP_GET_OUTPUT_STRING,
+ OP_SORT, OP_SORT1, OP_SORT2, OP_SORT3, OP_SORT_PAIR_END, OP_SORT_VECTOR_END, OP_SORT_STRING_END,
+ OP_EVAL_STRING,
+ OP_MEMBER_IF, OP_ASSOC_IF, OP_MEMBER_IF1, OP_ASSOC_IF1,
+ OP_LAMBDA_UNCHECKED, OP_LET_UNCHECKED, OP_CATCH_1, OP_CATCH_2, OP_CATCH_ALL,
+
+ OP_SET_UNCHECKED, OP_SET_S_C, OP_SET_S_S, OP_SET_S_P, OP_SET_S_A,
+ OP_SET_NORMAL, OP_SET_opSq_A, OP_SET_opSAq_A, OP_SET_opSAq_P, OP_SET_opSAq_P_1, OP_SET_opSAAq_A, OP_SET_opSAAq_P, OP_SET_opSAAq_P_1,
+ OP_SET_FROM_SETTER, OP_SET_FROM_LET_TEMP, OP_SET_SAFE,
+ OP_INCREMENT_BY_1, OP_DECREMENT_BY_1, OP_INCREMENT_SA, OP_INCREMENT_SAA, OP_SET_CONS,
+
+ OP_LETREC_UNCHECKED, OP_LETREC_STAR_UNCHECKED, OP_COND_UNCHECKED,
+ OP_LAMBDA_STAR_UNCHECKED, OP_DO_UNCHECKED, OP_DEFINE_UNCHECKED, OP_DEFINE_STAR_UNCHECKED, OP_DEFINE_FUNCHECKED, OP_DEFINE_CONSTANT_UNCHECKED,
+ OP_DEFINE_WITH_SETTER,
+
+ OP_LET_NO_VARS, OP_NAMED_LET, OP_NAMED_LET_NO_VARS, OP_NAMED_LET_A, OP_NAMED_LET_AA, OP_NAMED_LET_NA, OP_NAMED_LET_STAR,
+ OP_LET_NA_OLD, OP_LET_NA_NEW, OP_LET_2A_OLD, OP_LET_2A_NEW, OP_LET_3A_OLD, OP_LET_3A_NEW,
+ OP_LET_opaSSq_OLD, OP_LET_opaSSq_NEW, OP_LET_ONE_OLD, OP_LET_ONE_NEW, OP_LET_ONE_P_OLD, OP_LET_ONE_P_NEW,
+ OP_LET_ONE_OLD_1, OP_LET_ONE_NEW_1, OP_LET_ONE_P_OLD_1, OP_LET_ONE_P_NEW_1,
+ OP_LET_A_OLD, OP_LET_A_NEW, OP_LET_A_P_OLD, OP_LET_A_P_NEW,
+ OP_LET_A_A_OLD, OP_LET_A_A_NEW, OP_LET_A_NA_OLD, OP_LET_A_NA_NEW, OP_LET_A_OLD_2, OP_LET_A_NEW_2,
+ OP_LET_STAR_NA, OP_LET_STAR_NA_A,
+
+ OP_CASE_A_E_S, OP_CASE_A_I_S, OP_CASE_A_G_S, OP_CASE_A_E_G, OP_CASE_A_G_G, OP_CASE_A_S_G,
+ OP_CASE_P_E_S, OP_CASE_P_I_S, OP_CASE_P_G_S, OP_CASE_P_E_G, OP_CASE_P_G_G,
+ OP_CASE_E_S, OP_CASE_I_S, OP_CASE_G_S, OP_CASE_E_G, OP_CASE_G_G,
+ OP_CASE_A_I_S_A, OP_CASE_A_E_S_A, OP_CASE_A_G_S_A, OP_CASE_A_S_G_A,
+
+ OP_IF_UNCHECKED, OP_AND_P, OP_AND_P1, OP_AND_AP, OP_AND_PAIR_P,
+ OP_AND_SAFE_P1, OP_AND_SAFE_P2, OP_AND_SAFE_P3, OP_AND_SAFE_P_REST, OP_AND_2A, OP_AND_3A, OP_AND_N, OP_AND_S_2,
+ OP_OR_P, OP_OR_P1, OP_OR_AP, OP_OR_2A, OP_OR_3A, OP_OR_N, OP_OR_S_2, OP_OR_S_TYPE_2,
+ OP_WHEN_S, OP_WHEN_A, OP_WHEN_P, OP_WHEN_AND_AP, OP_WHEN_AND_2A, OP_WHEN_AND_3A, OP_UNLESS_S, OP_UNLESS_A, OP_UNLESS_P,
+
+ OP_IF_A_C_C, OP_IF_A_A, OP_IF_A_A_A, OP_IF_S_A_A, OP_IF_AND2_S_A, OP_IF_NOT_A_A, OP_IF_NOT_A_A_A,
+ OP_IF_B_A, OP_IF_B_P, OP_IF_B_R, OP_IF_B_A_P, OP_IF_B_P_A, OP_IF_B_P_P, OP_IF_B_N_N,
+ OP_IF_A_A_P, OP_IF_A_P_A, OP_IF_S_P_A, OP_IF_S_A_P, OP_IF_S_P, OP_IF_S_P_P, OP_IF_S_R, OP_IF_S_N, OP_IF_S_N_N,
+ OP_IF_opSq_P, OP_IF_opSq_P_P, OP_IF_opSq_R, OP_IF_opSq_N, OP_IF_opSq_N_N,
+ OP_IF_IS_TYPE_S_P, OP_IF_IS_TYPE_S_P_P, OP_IF_IS_TYPE_S_R, OP_IF_IS_TYPE_S_N, OP_IF_IS_TYPE_S_N_N, OP_IF_IS_TYPE_S_P_A, OP_IF_IS_TYPE_S_A_A, OP_IF_IS_TYPE_S_A_P,
+ OP_IF_A_P, OP_IF_A_P_P, OP_IF_A_R, OP_IF_A_N, OP_IF_A_N_N,
+ OP_IF_AND2_P, OP_IF_AND2_P_P, OP_IF_AND2_R, OP_IF_AND2_N, OP_IF_AND2_N_N,
+ OP_IF_AND3_P, OP_IF_AND3_P_P, OP_IF_AND3_R, OP_IF_AND3_N, OP_IF_AND3_N_N, /* or3 got few hits */
+ OP_IF_P_P, OP_IF_P_P_P, OP_IF_P_R, OP_IF_P_N, OP_IF_P_N_N,
+ OP_IF_ANDP_P, OP_IF_ANDP_P_P, OP_IF_ANDP_R, OP_IF_ANDP_N, OP_IF_ANDP_N_N,
+ OP_IF_ORP_P, OP_IF_ORP_P_P, OP_IF_ORP_R, OP_IF_ORP_N, OP_IF_ORP_N_N,
+ OP_IF_OR2_P, OP_IF_OR2_P_P, OP_IF_OR2_R, OP_IF_OR2_N, OP_IF_OR2_N_N,
+ OP_IF_PP, OP_IF_PPP, OP_IF_PN, OP_IF_PR, OP_IF_PRR, OP_WHEN_PP, OP_UNLESS_PP,
+
+ OP_COND_NA_NA, OP_COND_NA_NP, OP_COND_NA_NP_1, OP_COND_NA_2E, OP_COND_NA_3E, OP_COND_NA_NP_O,
+ OP_COND_FEED, OP_COND_FEED_1,
+
+ OP_SIMPLE_DO, OP_SIMPLE_DO_STEP, OP_SAFE_DOTIMES, OP_SAFE_DOTIMES_STEP, OP_SAFE_DOTIMES_STEP_O,
+ OP_SAFE_DO, OP_SAFE_DO_STEP, OP_DOX, OP_DOX_STEP, OP_DOX_STEP_O, OP_DOX_NO_BODY, OP_DOX_PENDING_NO_BODY, OP_DOX_INIT,
+ OP_DOTIMES_P, OP_DOTIMES_STEP_O,
+ OP_DO_NO_VARS, OP_DO_NO_VARS_NO_OPT, OP_DO_NO_VARS_NO_OPT_1,
+ OP_DO_NO_BODY_NA_VARS, OP_DO_NO_BODY_NA_VARS_STEP, OP_DO_NO_BODY_NA_VARS_STEP_1,
+
+ OP_SAFE_C_P_1, OP_SAFE_C_PP_1, OP_SAFE_C_PP_3_MV, OP_SAFE_C_PP_5,
+ OP_SAFE_C_3P_1, OP_SAFE_C_3P_2, OP_SAFE_C_3P_3, OP_SAFE_C_3P_1_MV, OP_SAFE_C_3P_2_MV, OP_SAFE_C_3P_3_MV,
+ OP_SAFE_C_SP_1, OP_SAFE_CONS_SP_1, OP_SAFE_ADD_SP_1, OP_SAFE_MULTIPLY_SP_1, OP_SAFE_C_PS_1, OP_SAFE_C_PC_1,
+ OP_EVAL_MACRO_MV, OP_MACROEXPAND_1, OP_APPLY_LAMBDA,
+ OP_ANY_C_NP_1, OP_ANY_C_NP_MV, OP_SAFE_C_SSP_1, OP_C_P_1, OP_C_AP_1, OP_ANY_C_NP_2, OP_SAFE_C_PA_1,
+ OP_SET_WITH_LET_1, OP_SET_WITH_LET_2,
+
+ OP_CLOSURE_AP_1, OP_CLOSURE_PA_1, OP_CLOSURE_PP_1, OP_CLOSURE_P_1,
+ OP_SAFE_CLOSURE_P_1, OP_SAFE_CLOSURE_P_A_1, OP_SAFE_CLOSURE_AP_1, OP_SAFE_CLOSURE_PA_1, OP_SAFE_CLOSURE_PP_1,
+ OP_ANY_CLOSURE_3P_1, OP_ANY_CLOSURE_3P_2, OP_ANY_CLOSURE_3P_3, OP_ANY_CLOSURE_NP_1,
+ OP_ANY_CLOSURE_4P_1, OP_ANY_CLOSURE_4P_2, OP_ANY_CLOSURE_4P_3, OP_ANY_CLOSURE_4P_4, OP_ANY_CLOSURE_NP_2,
+
+ OP_TC_AND_A_OR_A_LA, OP_TC_OR_A_AND_A_LA, OP_TC_AND_A_OR_A_LAA, OP_TC_OR_A_AND_A_LAA, OP_TC_AND_A_OR_A_L3A, OP_TC_OR_A_AND_A_L3A,
+ OP_TC_OR_A_A_AND_A_A_LA, OP_TC_OR_A_AND_A_A_L3A, OP_TC_AND_A_OR_A_A_LA, OP_TC_OR_A_AND_A_A_LA,
+ OP_TC_WHEN_LA, OP_TC_WHEN_LAA, OP_TC_WHEN_L3A, OP_TC_LET_WHEN_LAA, OP_TC_LET_UNLESS_LAA,
+ OP_TC_COND_A_Z_A_Z_LAA, OP_TC_COND_A_Z_A_LAA_Z, OP_TC_COND_A_Z_A_LAA_LAA, OP_TC_LET_COND,
+ OP_TC_IF_A_Z_LA, OP_TC_IF_A_Z_LAA, OP_TC_IF_A_Z_L3A, OP_TC_IF_A_L3A_Z, OP_TC_IF_A_LA_Z, OP_TC_IF_A_LAA_Z,
+ OP_TC_IF_A_Z_IF_A_Z_LA, OP_TC_IF_A_Z_IF_A_LA_Z, OP_TC_IF_A_Z_IF_A_Z_LAA, OP_TC_IF_A_Z_IF_A_LAA_Z, OP_TC_IF_A_Z_IF_A_L3A_L3A,
+ OP_TC_COND_A_Z_A_Z_LA, OP_TC_COND_A_Z_A_LA_Z, OP_TC_COND_A_Z_LA, OP_TC_COND_A_LA_Z, OP_TC_COND_A_Z_LAA, OP_TC_COND_A_LAA_Z,
+ OP_TC_LET_IF_A_Z_LA, OP_TC_LET_IF_A_Z_LAA, OP_TC_IF_A_Z_LET_IF_A_Z_LAA,
+ OP_TC_CASE_LA, OP_TC_AND_A_IF_A_Z_LA, OP_TC_AND_A_IF_A_LA_Z,
+
+ OP_RECUR_IF_A_A_opA_LAq, OP_RECUR_IF_A_opA_LAq_A, OP_RECUR_IF_A_A_opLA_Aq, OP_RECUR_IF_A_opLA_Aq_A,
+ OP_RECUR_IF_A_A_opLA_LAq, OP_RECUR_IF_A_opLA_LAq_A,
+ OP_RECUR_IF_A_A_opA_LA_LAq, OP_RECUR_IF_A_opA_LA_LAq_A,
+ OP_RECUR_IF_A_A_opLA_LA_LAq, OP_RECUR_IF_A_A_IF_A_A_opLA_LAq, OP_RECUR_IF_A_A_IF_A_A_opLAA_LAAq,
+ OP_RECUR_IF_A_A_opA_LAAq, OP_RECUR_IF_A_opA_LAAq_A, OP_RECUR_IF_A_A_opA_L3Aq,
+ OP_RECUR_IF_A_A_LopL3A_L3A_L3Aq, OP_RECUR_IF_A_A_AND_A_LAA_LAA,
+ OP_RECUR_IF_A_A_IF_A_LAA_opA_LAAq, /* same as cond case below */
+ OP_RECUR_COND_A_A_opA_LAq, OP_RECUR_COND_A_A_opA_LAAq,
+ OP_RECUR_COND_A_A_A_A_opLA_LAq, OP_RECUR_COND_A_A_A_A_opLAA_LAAq, OP_RECUR_COND_A_A_A_A_opA_LAAq,
+ OP_RECUR_COND_A_A_A_LAA_LopA_LAAq, OP_RECUR_COND_A_A_A_LAA_opA_LAAq,
+ OP_RECUR_AND_A_OR_A_LAA_LAA,
+
+ NUM_OPS};
+
+#define is_tc_op(Op) ((Op >= OP_TC_AND_A_OR_A_LA) && (Op <= OP_TC_CASE_LA))
+
+typedef enum{E_C_P, E_C_PP, E_C_CP, E_C_SP, E_C_PC, E_C_PS} combine_op_t;
+
+static const char* op_names[NUM_OPS] =
+ {
+ "unopt", "gc_protect",
+
+ "safe_c_nc", "h_safe_c_nc", "safe_c_s", "h_safe_c_s",
+ "safe_c_ss", "h_safe_c_ss", "safe_c_sc", "h_safe_c_sc", "safe_c_cs", "h_safe_c_cs", "safe_c_cq", "h_safe_c_cq",
+ "safe_c_sss", "h_safe_c_sss", "safe_c_scs", "h_safe_c_scs", "safe_c_ssc", "h_safe_c_ssc", "safe_c_css", "h_safe_c_css",
+ "safe_c_scc", "h_safe_c_scc", "safe_c_csc", "h_safe_c_csc", "safe_c_ccs", "h_safe_c_ccs",
+ "safe_c_ns", "h_safe_c_ns", "safe_c_opncq", "h_safe_c_opncq", "safe_c_opsq", "h_safe_c_opsq",
+ "safe_c_opssq", "h_safe_c_opssq", "safe_c_opscq", "h_safe_c_opscq",
+ "safe_c_opcsq", "h_safe_c_opcsq", "safe_c_s_opsq", "h_safe_c_s_opsq",
+ "safe_c_c_opscq", "h_safe_c_c_opscq", "safe_c_s_opscq", "h_safe_c_s_opscq", "safe_c_s_opcsq", "h_safe_c_s_opcsq",
+ "safe_c_opsq_s", "h_safe_c_opsq_s", "safe_c_opsq_c", "h_safe_c_opsq_c",
+ "safe_c_opsq_opsq", "h_safe_c_opsq_opsq", "safe_c_s_opssq", "h_safe_c_s_opssq", "safe_c_c_opsq", "h_safe_c_c_opsq",
+ "safe_c_opcsq_c", "h_safe_c_opcsq_c", "safe_c_opssq_c", "h_safe_c_opssq_c", "safe_c_c_opssq", "h_safe_c_c_opssq",
+ "safe_c_opssq_opssq", "h_safe_c_opssq_opssq", "safe_c_opssq_opsq", "h_safe_c_opssq_opsq", "safe_c_opsq_opssq", "h_safe_c_opsq_opssq",
+ "safe_c_opssq_s", "h_safe_c_opssq_s", "safe_c_opcsq_s", "h_safe_c_opcsq_s", "safe_c_opscq_c", "h_safe_c_opscq_c",
+ "safe_c_op_opssqq_s", "h_safe_c_op_opssqq_s", "safe_c_op_opsqq", "h_safe_c_op_opsqq",
+ "safe_c_op_s_opsqq", "h_safe_c_op_s_opsqq", "safe_c_op_opsq_sq", "h_safe_c_op_opsq_sq", "safe_c_opsq_cs", "h_safe_c_opsq_cs",
+
+ "safe_c_a", "h_safe_c_a", "safe_c_aa", "h_safe_c_aa", "safe_c_sa", "h_safe_c_sa", "safe_c_as", "h_safe_c_as",
+ "safe_c_ca", "h_safe_c_ca", "safe_c_ac", "h_safe_c_ac", "safe_c_aaa", "h_safe_c_aaa", "safe_c_4a", "h_safe_c_4a",
+ "safe_c_na", "h_safe_c_na", "safe_c_all_ca", "h_safe_c_all_ca",
+ "safe_c_ssa", "h_safe_c_ssa", "safe_c_sas", "h_safe_c_sas", "safe_c_saa", "h_safe_c_saa",
+ "safe_c_csa", "h_safe_c_csa", "safe_c_sca", "h_safe_c_sca", "safe_c_ass", "h_safe_c_ass",
+ "safe_c_cac", "h_safe_c_cac", "safe_c_agg", "h_safe_c_agg",
+ "safe_c_opaq", "h_safe_c_opaq", "safe_c_opaaq", "h_safe_c_opaaq", "safe_c_opaaaq", "h_safe_c_opaaaq",
+ "safe_c_s_opaq", "h_safe_c_s_opaq", "safe_c_opaq_s", "h_safe_c_opaq_s", "safe_c_s_opaaq", "h_safe_c_s_opaaq",
+ "safe_c*", "h_safe_c*", "safe_c*_a", "h_safe_c*_a", "safe_c*_aa", "h_safe_c*_aa", "safe_c*_na", "h_safe_c*_na",
+
+ "safe_c_p", "h_safe_c_p", "safe_c_pp", "h_safe_c_pp", "safe_c_ff", "h_safe_c_ff", "safe_c_sp", "h_safe_c_sp",
+ "safe_c_cp", "h_safe_c_cp", "safe_c_ap", "h_safe_c_ap", "safe_c_pa", "h_safe_c_pa", "safe_c_ps", "h_safe_c_ps",
+ "safe_c_pc", "h_safe_c_pc", "safe_c_ssp", "h_safe_c_ssp", "any_c_np", "h_any_c_np", "safe_c_3p", "h_safe_c_3p",
+
+ "thunk", "h_thunk", "thunk_o", "h_thunk_o", "thunk_any", "h_thunk_any",
+ "safe_thunk", "h_safe_thunk", "safe_thunk_a", "h_safe_thunk_a", "safe_thunk_any", "h_safe_thunk_any",
+
+ "closure_s", "h_closure_s", "closure_s_o", "h_closure_s_o",
+ "closure_a", "h_closure_a", "closure_a_o", "h_closure_a_o", "closure_p", "h_closure_p",
+ "closure_ap", "h_closure_ap", "closure_pa", "h_closure_pa", "closure_pp", "h_closure_pp",
+ "closure_fa", "h_closure_fa", "closure_ss", "h_closure_ss", "closure_ss_o", "h_closure_ss_o",
+ "closure_sc", "h_closure_sc", "closure_sc_o", "h_closure_sc_o",
+ "closure_3s", "h_closure_3s", "closure_3s_o", "h_closure_3s_o", "closure_4s", "h_closure_4s", "closure_4s_o", "h_closure_4s_o", "closure_5s", "h_closure_5s",
+ "closure_aa", "h_closure_aa", "closure_aa_o", "h_closure_aa_o", "closure_3a", "h_closure_3a", "closure_4a", "h_closure_4a",
+ "closure_na", "h_closure_na", "closure_ass", "h_closure_ass", "closure_sas", "h_closure_sas ","closure_aas", "h_closure_aas",
+ "closure_saa", "h_closure_saa", "closure_asa", "h_closure_asa", "closure_ns", "h_closure_ns",
+
+ "safe_closure_s", "h_safe_closure_s", "safe_closure_s_o", "h_safe_closure_s_o",
+ "safe_closure_s_a", "h_safe_closure_s_a", "safe_closure_s_to_s", "h_safe_closure_s_to_s", "safe_closure_s_to_sc", "h_safe_closure_s_to_sc",
+ "safe_closure_p", "h_safe_closure_p", "safe_closure_p_a", "h_safe_closure_p_a",
+ "safe_closure_ap", "h_safe_closure_ap", "safe_closure_pa", "h_safe_closure_pa", "safe_closure_pp", "h_safe_closure_pp",
+ "safe_closure_a", "h_safe_closure_a", "safe_closure_a_o", "h_safe_closure_a_o", "safe_closure_a_a", "h_safe_closure_a_a",
+ "safe_closure_a_to_sc", "h_safe_closure_a_to_sc",
+ "safe_closure_ss", "h_safe_closure_ss", "safe_closure_ss_o", "h_safe_closure_ss_o", "safe_closure_ss_a", "h_safe_closure_ss_a",
+ "safe_closure_sc", "h_safe_closure_sc", "safe_closure_sc_o", "h_safe_closure_sc_o",
+ "safe_closure_aa", "h_safe_closure_aa", "safe_closure_aa_o", "h_safe_closure_aa_o", "safe_closure_aa_a", "h_safe_closure_aa_a",
+ "safe_closure_saa", "h_safe_closure_saa", "safe_closure_ssa", "h_safe_closure_ssa",
+ "safe_closure_agg", "h_safe_closure_agg", "safe_closure_3a", "h_safe_closure_3a", "safe_closure_na", "h_safe_closure_na",
+ "safe_closure_3s", "h_safe_closure_3s", "safe_closure_ns", "h_safe_closure_ns",
+ "safe_closure_3s_a", "h_safe_closure_3s_a",
+
+ "any_closure_3p", "h_any_closure_3p", "any_closure_4p", "h_any_closure_4p", "any_closure_np", "h_any_closure_np",
+ "any_closure_sym", "h_any_closure_sym", "any_closure_a_sym", "h_any_closure_a_sym",
+
+ "closure*_a", "h_closure*_a", "closure*_na", "h_closure*_na",
+ "safe_closure*_a", "h_safe_closure*_a", "safe_closure*_aa", "h_safe_closure*_aa",
+ "safe_closure*_aa_o", "h_safe_closure*_aa_o", "safe_closure*_a1", "h_safe_closure*_a1",
+ "safe_closure*_ka", "h_safe_closure*_ka", "closure*_ka", "h_closure*_ka", "safe_closure*_3a", "h_safe_closure*_3a",
+ "safe_closure*_na", "h_safe_closure*_na", "safe_closure*_na_0", "h_safe_closure*_na_0",
+ "safe_closure*_na_1", "h_safe_closure*_na_1", "safe_closure*_na_2", "h_safe_closure*_na_2",
+
+ "c_ss", "h_c_ss", "c_s", "h_c_s", "read_s", "h_read_s", "c_p", "h_c_p", "c_ap", "h_c_ap",
+ "c_a", "h_c_a", "c_aa", "h_c_aa", "c", "h_c", "c_nc", "h_c_nc", "c_na", "h_c_na",
+
+ "cl_s", "h_cl_s", "cl_ss", "h_cl_ss", "cl_a", "h_cl_a", "cl_aa", "h_cl_aa",
+ "cl_na", "h_cl_na", "cl_fa", "h_cl_fa", "cl_sas", "h_cl_sas",
+
+ "apply_ss", "apply_sa", "apply_sl", "macro_d", "macro*_d",
+ "with_input_from_string", "with_input_from_string_1", "with_output_to_string", "with_input_from_string_c", "call_with_output_string",
+ "s", "s_g", "s_a", "s_aa", "a_a", "a_aa", "a_sc", "p_s", "p_s_1", "map_for_each_fa", "map_for_each_faa",
+ "f", "f_a", "f_aa", "f_np", "f_np_1",
+
+ "implicit_goto", "implicit_goto_a", "implicit_continuation_a","implicit_iterate",
+ "implicit_vector_ref_a", "implicit_vector_ref_aa", "implicit_vector_set_3", "implicit_vector_set_4",
+ "implicit_string_ref_a", "implicit_c_object_ref_a", "implicit_pair_ref_a", "implicit_pair_ref_aa",
+ "implicit_hash_table_ref_a", "implicit_hash_table_ref_aa",
+ "implicit_let_ref_c", "implicit_let_ref_a", "implicit_*s7*_ref_s", "implicit_*s7*_set",
+ "unknown_thunk", "unknown_ns", "unknown_na", "unknown_s", "unknown_gg", "unknown_a", "unknown_aa", "unknown_np",
+
+ "symbol", "constant", "pair_sym", "pair_pair", "pair_any", "h_hash_table_increment", "clear_opts",
+
+ "read_internal", "eval", "eval_args", "eval_args1", "eval_args2", "eval_args3", "eval_args4", "eval_args5",
+ "eval_set1_no_mv", "eval_set2", "eval_set2_mv", "eval_set2_no_mv", "eval_set3", "eval_set3_mv", "eval_set3_no_mv",
+ "apply", "eval_macro", "lambda", "quote", "quote_unchecked", "macroexpand", "call/cc", "call_with_exit", "call_with_exit_o",
+ "c_catch", "c_catch_all", "c_catch_all_o", "c_catch_all_a",
+
+ "define", "define1", "begin", "begin_hook", "begin_no_hook", "begin_unchecked", "begin_2_unchecked", "begin_na", "begin_aa",
+ "if", "if1", "when", "unless", "set", "set1", "set2",
+ "let", "let1", "let*", "let*1", "let*2", "let*-shadowed",
+ "letrec", "letrec1", "letrec*", "letrec*1",
+ "let_temporarily", "let_temp_unchecked", "let_temp_init1", "let_temp_init2", "let_temp_done", "let_temp_done1",
+ "let_temp_s7", "let_temp_na", "let_temp_a", "let_temp_setter", "let_temp_unwind", "let_temp_s7_unwind", "let_temp_setter_unwind",
+ "let_temp_a_a", "let_temp_s7_direct", "let_temp_s7_direct_unwind",
+ "cond", "cond1", "feed_to_1", "cond_simple", "cond1_simple", "cond_simple_o", "cond1_simple_o",
+ "and", "or",
+ "define_macro", "define_macro*", "define_expansion", "define_expansion*", "macro", "macro*",
+ "case", "read_list", "read_next", "read_dot", "read_quote",
+ "read_quasiquote", "read_unquote", "read_apply_values",
+ "read_vector", "read_byte_vector", "read_int_vector", "read_float_vector", "read_done",
+ "load_return_if_eof", "load_close_and_pop_if_eof", "eval_done", "splice_values", "no_values",
+ "catch", "dynamic_wind", "dynamic_unwind", "dynamic_unwind_profile", "profile_in",
+ "define_constant", "define_constant1",
+ "do", "do_end", "do_end1", "do_step", "do_step2", "do_init",
+ "define*", "lambda*", "lambda*_default", "error_quit", "unwind_input", "unwind_output", "error_hook_quit",
+ "with_let", "with_let1", "with_let_unchecked", "with_let_s",
+ "with_baffle", "with_baffle_unchecked", "expansion",
+ "for_each", "for_each_1", "for_each_2", "for_each_3",
+ "map", "map_1", "map_2", "map_gather", "map_gather_1", "map_gather_2", "map_gather_3", "map_unwind",
+ "barrier", "deactivate_goto",
+ "define_bacro", "define_bacro*", "bacro", "bacro*",
+ "get_output_string",
+ "sort", "sort1", "sort2", "sort3", "sort_pair_end", "sort_vector_end", "sort_string_end",
+ "eval_string",
+ "member_if", "assoc_if", "member_if1", "assoc_if1",
+ "lambda_unchecked", "let_unchecked", "catch_1", "catch_2", "catch_all",
+ "set_unchecked", "set_s_c", "set_s_s", "set_s_p", "set_a",
+ "set_normal", "set_opsq_a", "set_opsaq_a", "set_opsaq_p", "set_opsaq_p_1", "set_opsaaq_a", "set_opsaaq_p", "set_opsaaq_p_1",
+ "set_from_setter", "set_from_let_temp", "set_safe",
+ "increment_1", "decrement_1", "increment_sa", "increment_saa", "set_cons",
+ "letrec_unchecked", "letrec*_unchecked", "cond_unchecked",
+ "lambda*_unchecked", "do_unchecked", "define_unchecked", "define*_unchecked", "define_funchecked", "define_constant_unchecked",
+ "define_with_setter",
+
+ "let_no_vars", "named_let", "named_let_no_vars", "named_let_a", "named_let_aa", "named_let_na", "named_let*",
+ "let_na_old", "let_na_new", "let_2a_old", "let_2a_new", "let_3a_old", "let_3a_new",
+ "let_opassq_old", "let_opassq_new", "let_one_old", "let_one_new", "let_one_p_old", "let_one_p_new",
+ "let_one_old_1", "let_one_new_1", "let_one_p_old_1", "let_one_p_new_1",
+ "let_a_old", "let_a_new", "let_a_p_old", "let_a_p_new",
+ "let_a_a_old", "let_a_a_new", "let_a_na_old", "let_a_na_new", "let_a_old_2", "let_a_new_2",
+ "let*_na", "let*_na_a",
+
+ "case_a_e_s", "case_a_i_s", "case_a_g_s", "case_a_e_g", "case_a_g_g", "case_a_s_g",
+ "case_p_e_s", "case_p_i_s", "case_p_g_s", "case_p_e_g", "case_p_g_g",
+ "case_e_s", "case_i_s", "case_g_s", "case_e_g", "case_g_g",
+ "case_a_i_s_a", "case_a_e_s_a", "case_a_g_s_a", "case_a_s_g_a",
+
+ "if_unchecked", "and_p", "and_p1", "and_ap", "and_pair_p",
+ "and_safe_p1", "op_and_safe_p2", "and_safe_p3", "and_safe_p_rest", "and_2a", "and_3a", "and_n", "and_s_2",
+ "or_p", "or_p1", "or_ap", "or_2a", "or_3a", "or_n", "or_s_2", "or_s_type_2",
+ "when_s", "when_a", "when_p", "when_and_ap", "when_and_2a", "when_and_3a", "unless_s", "unless_a", "unless_p",
+
+ "if_a_c_c", "if_a_a", "if_a_a_a", "if_s_a_a", "if_and2_s_a", "if_not_a_a", "if_not_a_a_a",
+ "if_b_a", "if_b_p", "if_b_r", "if_b_a_p", "if_b_p_a", "if_b_p_p", "if_b_n_n",
+ "if_a_a_p", "if_a_p_a", "if_s_p_a", "if_s_a_p", "if_s_p", "if_s_p_p", "if_s_r", "if_s_n", "if_s_n_n",
+ "if_opsq_p", "if_opsq_p_p", "if_opsq_r", "if_opsq_n", "if_opsq_n_n",
+ "if_is_type_s_p", "if_is_type_s_p_p", "if_is_type_s_r", "if_is_type_s_n", "if_is_type_s_n_n", "if_is_type_s_p_a", "if_is_type_s_a_a", "if_is_type_s_a_p",
+ "if_a_p", "if_a_p_p", "if_a_r", "if_a_n", "if_a_n_n",
+ "if_and2_p", "if_and2_p_p", "if_and2_r", "if_and2_n", "if_and2_n_n",
+ "if_and3_p", "if_and3_p_p", "if_and3_r", "if_and3_n", "if_and3_n_n",
+ "if_p_p", "if_p_p_p", "if_p_r", "if_p_n", "if_p_n_n",
+ "if_andp_p", "if_andp_p_p", "if_andp_r", "if_andp_n", "if_andp_n_n",
+ "if_orp_p", "if_orp_p_p", "if_orp_r", "if_orp_n", "if_orp_n_n",
+ "if_or2_p", "if_or2_p_p", "if_or2_r", "if_or2_n", "if_or2_n_n",
+ "if_pp", "if_ppp", "if_pn", "if_pr", "if_prr", "when_pp", "unless_pp",
+
+ "cond_na_na", "cond_na_np", "cond_na_np_1", "cond_na_2e", "cond_na_3e", "cond_na_np_o",
+ "cond_feed", "cond_feed_1",
+
+ "simple_do", "simple_do_step", "safe_dotimes", "safe_dotimes_step", "safe_dotimes_step_o",
+ "safe_do", "safe_do_step", "dox", "dox_step", "dox_step_o", "dox_no_body", "dox_pending_no_body", "dox_init",
+ "dotimes_p", "dotimes_step_o",
+ "do_no_vars", "do_no_vars_no_opt", "do_no_vars_no_opt_1",
+ "do_no_body_na_vars", "do_no_body_na_vars_step", "do_no_body_na_vars_step_1",
+
+ "safe_c_p_1", "safe_c_pp_1", "safe_c_pp_3_mv", "safe_c_pp_5",
+ "safe_c_3p_1", "safe_c_3p_2", "safe_c_3p_3", "safe_c_3p_1_mv", "safe_c_3p_2_mv", "safe_c_3p_3_mv",
+ "safe_c_sp_1", "safe_cons_sp_1", "safe_add_sp_1", "safe_multiply_sp_1", "safe_c_ps_1", "safe_c_pc_1",
+ "eval_macro_mv", "macroexpand_1", "apply_lambda",
+ "any_c_np_1", "any_c_np_mv", "safe_c_ssp_1", "c_p_1", "c_ap_1", "any_c_np_2", "safe_c_pa_1",
+ "set_with_let_1", "set_with_let_2",
+
+ "closure_ap_1", "closure_pa_1", "closure_pp_1", "closure_p_1",
+ "safe_closure_p_1", "safe_closure_p_a_1", "safe_closure_ap_1", "safe_closure_pa_1", "safe_closure_pp_1",
+ "any_closure_3p_1", "any_closure_3p_2", "any_closure_3p_3", "any_closure_np_1",
+ "any_closure_4p_1", "any_closure_4p_2", "any_closure_4p_3", "any_closure_4p_4", "any_closure_np_2",
+
+ "tc_and_a_or_a_la", "tc_or_a_and_a_la", "tc_and_a_or_a_laa", "tc_or_a_and_a_laa", "tc_and_a_or_a_l3a", "tc_or_a_and_a_l3a",
+ "tc_or_a_a_and_a_a_la", "tc_or_a_and_a_a_l3a", "tc_and_a_or_a_a_la", "tc_or_a_and_a_a_la",
+ "tc_when_la", "tc_when_laa", "tc_when_l3a", "tc_let_when_laa", "tc_let_unless_laa",
+ "tc_cond_a_z_a_z_laa", "tc_cond_a_z_a_laa_z", "tc_cond_a_z_a_laa_laa", "tc_let_cond",
+ "tc_if_a_z_la", "tc_if_a_z_laa", "tc_if_a_z_l3a", "tc_if_a_l3a_z", "tc_if_a_la_z", "tc_if_a_laa_z",
+ "tc_if_a_z_if_a_z_la", "tc_if_a_z_if_a_la_z", "tc_if_a_z_if_a_z_laa", "tc_if_a_z_if_a_laa_z", "tc_if_a_z_if_a_l3a_l3a",
+ "tc_cond_a_z_a_z_la", "tc_cond_a_z_a_la_z", "tc_cond_a_z_la", "tc_cond_a_la_z", "tc_cond_a_z_laa", "tc_cond_a_laa_z",
+ "tc_let_if_a_z_la", "tc_let_if_a_z_laa", "if_a_z_let_if_a_z_laa",
+ "tc_case_la", "tc_and_a_if_a_z_la", "tc_and_a_if_a_la_z",
+
+ "recur_if_a_a_opa_laq", "recur_if_a_opa_laq_a", "recur_if_a_a_opla_aq", "recur_if_a_opla_aq_a",
+ "recur_if_a_a_opla_laq", "recur_if_a_opla_laq_a",
+ "recur_if_a_a_opa_la_laq", "recur_if_a_opa_la_laq_a",
+ "recur_if_a_a_opla_la_laq", "recur_if_a_a_if_a_a_opla_laq", "recur_if_a_a_if_a_a_oplaa_laaq",
+ "recur_if_a_a_opa_laaq", "recur_if_a_opa_laaq_a", "recur_if_a_a_opa_l3aq",
+ "recur_if_a_a_lopl3a_l3a_l3aq", "recur_if_a_a_and_a_laa_laa",
+ "recur_if_a_a_if_a_laa_opa_laaq",
+ "recur_cond_a_a_op_a_laq", "recur_cond_a_a_op_a_laaq",
+ "recur_cond_a_a_a_a_opla_laq", "recur_cond_a_a_a_a_oplaa_laaq", "recur_cond_a_a_a_a_opa_laaq",
+ "recur_cond_a_a_a_laa_lopa_laaq", "recur_cond_a_a_a_laa_opa_laaq",
+ "recur_and_a_or_a_laa_laa",
+};
+
+#define is_safe_c_op(op) ((op >= OP_SAFE_C_NC) && (op < OP_THUNK))
+#define is_unknown_op(op) ((op >= OP_UNKNOWN) && (op <= OP_UNKNOWN_NP))
+#define is_h_safe_c_nc(P) (optimize_op(P) == HOP_SAFE_C_NC)
+#define is_safe_c_s(P) ((optimize_op(P) == OP_SAFE_C_S) || (optimize_op(P) == HOP_SAFE_C_S))
+#define is_h_safe_c_s(P) (optimize_op(P) == HOP_SAFE_C_S)
+#define FIRST_UNHOPPABLE_OP OP_APPLY_SS
+
+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));
+}
+
+/* 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;
+
+static const char *s7_starlet_names[SL_NUM_FIELDS] =
+ {"no-field", "stack-top", "stack-size", "stacktrace-defaults", "heap-size", "free-heap-size",
+ "gc-freed", "gc-protected-objects", "gc-total-freed", "gc-info", "file-names", "filenames", "rootlet-size", "c-types",
+ "safety", "undefined-identifier-warnings", "undefined-constant-warnings", "gc-stats", "max-heap-size",
+ "max-port-data-size", "max-stack-size", "cpu-time", "catches", "stack", "major-version", "minor-version",
+ "max-string-length", "max-format-length", "max-list-length", "max-vector-length", "max-vector-dimensions",
+ "default-hash-table-length", "initial-string-port-length", "default-rationalize-error",
+ "default-random-state", "equivalent-float-epsilon", "hash-table-float-epsilon", "print-length",
+ "bignum-precision", "memory-usage", "float-format-precision", "history", "history-enabled",
+ "history-size", "profile", "profile-info", "profile-prefix", "autoloading?", "accept-all-keyword-arguments",
+ "muffle-warnings?", "most-positive-fixnum", "most-negative-fixnum", "output-port-data-size", "debug", "version",
+ "gc-temps-size", "gc-resize-heap-fraction", "gc-resize-heap-by-4-fraction", "openlets", "expansions?",
+ "number-separator"};
+
+static s7_pointer object_to_string_truncated(s7_scheme *sc, s7_pointer p);
+static const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article);
+static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b);
+static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym);
+
+
+#define bold_text "\033[1m"
+#define unbold_text "\033[22m"
+#define red_text "\033[31m"
+#define green_text "\033[32m"
+#define blue_text "\033[34m"
+#define uncolor_text "\033[0m" /* yellow=33 */
+
+
+/* -------------------------------- internal debugging apparatus -------------------------------- */
+static int64_t heap_location(s7_scheme *sc, s7_pointer p)
+{
+ for (heap_block_t *hp = sc->heap_blocks; hp; hp = hp->next)
+ if (((intptr_t)p >= hp->start) && ((intptr_t)p < hp->end))
+ return(hp->offset + (((intptr_t)p - hp->start) / sizeof(s7_cell)));
+ return(((s7_big_pointer)p)->big_hloc);
+}
+
+#if TRAP_SEGFAULT
+#include <signal.h>
+static Jmp_Buf senv; /* global here is not a problem -- it is used only to protect s7_is_valid */
+static volatile sig_atomic_t can_jump = 0;
+static void segv(int32_t unused) {if (can_jump) LongJmp(senv, 1);}
+#endif
+
+bool s7_is_valid(s7_scheme *sc, s7_pointer arg)
+{
+ bool result = false;
+ if (!arg) return(false);
+ {
+ s7_pointer heap0 = *(sc->heap);
+ const s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size);
+ if ((arg >= heap0) && (arg < heap1)) return(true);
+ }
+#if TRAP_SEGFAULT
+ if (SetJmp(senv, 1) == 0)
+ {
+ void (*old_segv)(int32_t sig);
+ can_jump = 1;
+ 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);
+ }}
+#if TRAP_SEGFAULT
+ signal(SIGSEGV, old_segv);
+ }
+ else result = false;
+ can_jump = 0;
+#endif
+ return(result);
+}
+
+#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 = old_stop; \
+ sc->has_openlets = old_open; \
+ } while (0)
+
+void s7_show_history(s7_scheme *sc);
+void s7_show_history(s7_scheme *sc)
+{
+#if WITH_HISTORY
+ if (sc->cur_code == sc->history_sink)
+ fprintf(stderr, "history diabled\n");
+ else
+ {
+ int32_t size = sc->history_size;
+ 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))));
+ fprintf(stderr, "\n");
+ }
+#else
+ fprintf(stderr, "%s\n", display(sc->cur_code));
+#endif
+}
+
+#if S7_DEBUGGING
+#define UNUSED_BITS 0x400fc00000000c0 /* high 6 bits of optimizer code + high 2 bits of type + bit 58 (was gx) */
+
+static char *describe_type_bits(s7_scheme *sc, s7_pointer obj)
+{
+ uint64_t full_typ = full_type(obj);
+ uint8_t typ = unchecked_type(obj);
+ char *buf;
+ 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);
+
+ 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);
+ return(buf);
+}
+
+/* snprintf returns the number of bytes that would have been written: (display (c-pointer 123123123 (symbol (make-string 130 #\a)))) */
+
+static bool never_unheaped[NUM_TYPES];
+static void init_never_unheaped(void)
+{
+ for (int i = 0; i < NUM_TYPES; i++) never_unheaped[i] = false;
+ never_unheaped[T_BACRO] = true;
+ never_unheaped[T_BACRO_STAR] = true;
+ never_unheaped[T_CATCH] = true;
+ never_unheaped[T_CLOSURE] = true;
+ never_unheaped[T_CLOSURE_STAR] = true;
+ never_unheaped[T_CONTINUATION] = true;
+ never_unheaped[T_COUNTER] = true;
+ never_unheaped[T_C_OBJECT] = true;
+ never_unheaped[T_C_POINTER] = true;
+ never_unheaped[T_DYNAMIC_WIND] = true;
+ never_unheaped[T_FREE] = true;
+ never_unheaped[T_GOTO] = true;
+ never_unheaped[T_HASH_TABLE] = true;
+ never_unheaped[T_ITERATOR] = true;
+ never_unheaped[T_MACRO] = true;
+ never_unheaped[T_MACRO_STAR] = true;
+ never_unheaped[T_RANDOM_STATE] = true;
+ never_unheaped[T_SLOT] = true;
+ never_unheaped[T_STACK] = true;
+ never_unheaped[T_UNUSED] = true;
+ never_unheaped[T_VECTOR] = true;
+}
+
+static bool has_odd_bits(s7_pointer obj)
+{
+ uint64_t full_typ = full_type(obj);
+ if ((full_typ & UNUSED_BITS) != 0) return(true);
+ if (((full_typ & T_MULTIFORM) != 0) && (!is_any_closure(obj))) return(true);
+ if (((full_typ & T_KEYWORD) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true);
+ if (((full_typ & T_SYNTACTIC) != 0) && (!is_syntax(obj)) && (!is_pair(obj)) && (!is_normal_symbol(obj))) return(true);
+ if (((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) && (!is_pair(obj)) && (!is_any_closure(obj))) return(true);
+ if (((full_typ & T_OPTIMIZED) != 0) && (!is_c_function(obj)) && (!is_pair(obj))) return(true);
+ if (((full_typ & T_SAFE_CLOSURE) != 0) && (!is_any_closure(obj)) && (!is_pair(obj))) return(true);
+ if (((full_typ & T_SAFE_PROCEDURE) != 0) && (!is_applicable(obj))) return(true);
+ if (((full_typ & T_EXPANSION) != 0) && (!is_normal_symbol(obj)) && (!is_either_macro(obj))) return(true);
+ if (((full_typ & T_MULTIPLE_VALUE) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true);
+ if (((full_typ & T_GLOBAL) != 0) && (!is_pair(obj)) && (!is_symbol(obj)) && (!is_let(obj)) && (!is_syntax(obj))) return(true);
+ if (((full_typ & T_ITER_OK) != 0) && (!is_iterator(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_c_function(obj)) && (!is_symbol(obj))) return(true);
+ if (((full_typ & T_LOCAL) != 0) && (!is_normal_symbol(obj)) && (!is_pair(obj))) return(true);
+ if (((full_typ & T_UNSAFE) != 0) && (!is_symbol(obj)) && (!is_slot(obj)) && (!is_let(obj)) && (!is_pair(obj))) return(true);
+ if (((full_typ & T_VERY_SAFE_CLOSURE) != 0) && (!is_pair(obj)) && (!is_any_closure(obj)) && (!is_let(obj))) return(true);
+ if (((full_typ & T_FULL_CASE_KEY) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true);
+ if (((full_typ & T_FULL_UNKNOPT) != 0) && (!is_pair(obj))) return(true);
+ if (((full_typ & T_FULL_SAFETY_CHECKED) != 0) && (!is_pair(obj))) return(true);
+ if (((full_typ & T_DONT_EVAL_ARGS) != 0) && (!is_any_macro(obj)) && (!is_syntax(obj))) return(true);
+ if (((full_typ & T_CHECKED) != 0) && (!is_slot(obj)) && (!is_pair(obj)) && (!is_symbol(obj))) return(true);
+ if (((full_typ & T_SHARED) != 0) && (!t_sequence_p[type(obj)]) && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) return(true);
+ if (((full_typ & T_COPY_ARGS) != 0) && (!is_pair(obj)) &&
+ (!is_any_macro(obj)) && (!is_any_closure(obj)) && (!is_c_function(obj)) && (!is_syntax(obj)))
+ return(true);
+ if (((full_typ & T_FULL_SYMCONS) != 0) &&
+ (!is_symbol(obj)) && (!is_any_procedure(obj)) && (!is_hash_table(obj)) && (!is_pair(obj)) && (!is_let(obj)) && (!is_t_vector(obj)))
+ return(true);
+ if (((full_typ & T_FULL_BINDER) != 0) &&
+ (!is_pair(obj)) && (!is_hash_table(obj)) && (!is_normal_symbol(obj)) && (!is_c_function(obj)) && (!is_syntax(obj)))
+ return(true);
+ if (((full_typ & T_FULL_DEFINER) != 0) &&
+ (!is_normal_symbol(obj)) && (!is_c_function(obj)) && (!is_pair(obj)) && (!is_slot(obj)) && (!is_iterator(obj)) &&
+ (!is_hash_table(obj)) && (!is_let(obj)) && (!is_syntax(obj)))
+ return(true);
+ if (((full_typ & T_FULL_HAS_LET_FILE) != 0) &&
+ (!is_let(obj)) && (!is_t_vector(obj)) && (!is_hash_table(obj)) && (!is_c_function(obj)) &&
+ (!is_slot(obj)) && (!is_pair(obj)) && (!is_closure_star(obj)))
+ return(true);
+ if (((full_typ & T_SAFE_STEPPER) != 0) &&
+ (!is_let(obj)) && (!is_slot(obj)) && (!is_c_function(obj)) && (!is_number(obj)) &&
+ (!is_pair(obj)) && (!is_hash_table(obj)) && (!is_any_macro(obj)) && (!is_symbol(obj)))
+ return(true);
+ if (((full_typ & T_SETTER) != 0) &&
+ (!is_slot(obj)) && (!is_normal_symbol(obj)) && (!is_pair(obj)) && (!is_let(obj)) && (!is_c_function_star(obj)) && (!is_let(obj)))
+ return(true);
+ if (((full_typ & T_LOCATION) != 0) &&
+ (!is_pair(obj)) && (!is_input_port(obj)) && (!is_let(obj)) && (!is_any_procedure(obj)) && (!is_slot(obj)))
+ return(true);
+ if (((full_typ & T_MUTABLE) != 0) &&
+ (!is_number(obj)) && (!is_symbol(obj)) && (!is_let(obj)) && (!is_iterator(obj)) && (!is_slot(obj)) && (!is_let(obj)) && (!is_pair(obj)))
+ return(true);
+ if (((full_typ & T_GENSYM) != 0) && (!is_slot(obj)) && (!is_any_closure(obj)) &&
+ (!is_let(obj)) && (!is_symbol(obj)) && (!is_string(obj)) && (!is_hash_table(obj)) && (!is_pair(obj)) && (!is_any_vector(obj)))
+ return(true);
+ if (((full_typ & T_FULL_SIMPLE_ELEMENTS) != 0) &&
+ (!is_t_vector(obj)) && (!is_hash_table(obj)) && (!is_normal_symbol(obj)) && (!is_pair(obj)) && (unchecked_type(obj) < T_C_MACRO))
+ return(true);
+ if (((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)))
+ return(true);
+ if (((full_typ & T_CYCLIC) != 0) && (!is_simple_sequence(obj)) && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) return(true);
+ if (((full_typ & T_CYCLIC_SET) != 0) && (!is_simple_sequence(obj)) && (!t_structure_p[type(obj)]) && (!is_any_closure(obj))) return(true);
+ if (((full_typ & T_FULL_HAS_FN) != 0) && (!is_pair(obj))) return(true);
+ if (is_symbol(obj))
+ {
+ if ((uint8_t)(symbol_type(obj) & 0xff) >= NUM_TYPES)
+ return(true);
+ if ((symbol_type(obj) & ~0xffff) != 0) /* boolean function bool type and *s7*_let field id */
+ return(true);
+ }
+ if ((signed_type(obj) == 0) && ((full_typ & T_GC_MARK) != 0)) return(true);
+
+ if (!in_heap(obj))
+ {
+ uint8_t typ = unchecked_type(obj);
+ if (never_unheaped[typ]) {fprintf(stderr, "unheap %s?\n", s7_type_names[typ]); return(true);}
+ }
+ /* all the hash_table bits seem to be compatible, symbols? (all_float/all_integer only apply to sc->divide_symbol et al at init time) */
+ return(false);
+}
+
+void s7_show_let(s7_scheme *sc);
+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): ");
+ 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): ");
+ fprintf(stderr, "%s\n", display(olet));
+ }
+}
+
+static const char *checked_type_name(s7_scheme *sc, int32_t typ)
+{
+ if ((typ >= 0) && (typ < NUM_TYPES))
+ {
+ s7_pointer p = sc->type_names[typ];
+ if (is_string(p)) return(string_value(p));
+ }
+ return("unknown type!");
+}
+
+#if REPORT_ROOTLET_REDEF
+static void set_local_1(s7_scheme *sc, s7_pointer symbol, const char *func, int32_t line)
+{
+ if (is_global(symbol))
+ fprintf(stderr, "%s[%d]: %s%s%s in %s\n", func, line, bold_text, display(symbol), unbold_text, display_truncated(sc->cur_code));
+ full_type(symbol) = (full_type(symbol) & ~(T_DONT_EVAL_ARGS | T_GLOBAL | T_SYNTACTIC));
+}
+#endif
+
+static char *object_raw_type_to_string(s7_pointer p)
+{
+ char *buf = (char *)Malloc(128);
+ snprintf(buf, 128, "type: %d", unchecked_type(p));
+ return(buf);
+}
+
+static void complain(const char* complaint, s7_pointer p, const char *func, int32_t line, uint8_t typ)
+{
+ fprintf(stderr, complaint, bold_text, func, line, checked_type_name(cur_sc, typ), object_raw_type_to_string(p), unbold_text);
+ if (cur_sc->stop_at_error) abort();
+}
+
+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" : "");
+ return(bits_str);
+}
+
+static s7_pointer check_ref_one(s7_pointer p, uint8_t expected_type, const char *func, int32_t line, const char *func1, const char *func2)
+{
+ if (!p)
+ {
+ fprintf(stderr, "%s%s[%d]: null pointer passed to check_ref_one%s\n", bold_text, func, line, unbold_text);
+ if (cur_sc->stop_at_error) abort();
+ }
+ else
+ {
+ 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();
+ }}}
+ return(p);
+}
+
+static void check_let_set_slots(s7_pointer p, s7_pointer slot, const char *func, int32_t line)
+{
+ if ((!in_heap(p)) && (slot) && (in_heap(slot))) fprintf(stderr, "%s[%d]: let+slot mismatch\n", func, line);
+ if ((p == cur_sc->rootlet) && (slot != slot_end))
+ {
+ fprintf(stderr, "%s[%d]: setting rootlet slots!\n", func, line);
+ if (cur_sc->stop_at_error) abort();
+ }
+ T_Let(p)->object.envr.slots = T_Sln(slot);
+}
+
+static s7_pointer check_let_ref(s7_pointer p, uint64_t role, const char *func, int32_t line)
+{
+ check_ref_one(p, T_LET, func, line, NULL, NULL);
+ if ((p->debugger_bits & L_HIT) == 0) fprintf(stderr, "%s[%d]: let not set\n", func, line);
+ if ((p->debugger_bits & L_MASK) != role) fprintf(stderr, "%s[%d]: let bad role\n", func, line);
+ return(p);
+}
+
+static s7_pointer check_let_set(s7_pointer p, uint64_t role, const char *func, int32_t line)
+{
+ check_ref_one(p, T_LET, func, line, NULL, NULL);
+ p->debugger_bits &= (~L_MASK);
+ p->debugger_bits |= (L_HIT | role);
+ return(p);
+}
+
+static s7_pointer check_ref_two(s7_pointer p, uint8_t expected_type, int32_t other_type, const char *func, int32_t line, const char *func1, const char *func2)
+{
+ if (!p)
+ fprintf(stderr, "%s[%d]: null pointer passed to check_ref_two\n", func, line);
+ else
+ {
+ 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(p);
+}
+
+static s7_pointer check_ref_prt(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ if ((typ != T_INPUT_PORT) && (typ != T_OUTPUT_PORT) && (typ != T_FREE))
+ complain("%s%s[%d]: not a port, but %s (%s)%s\n", p, func, line, typ);
+ return(p);
+}
+
+static s7_pointer check_ref_pri(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ if ((typ != T_INPUT_PORT) && (p != cur_sc->F))
+ complain("%s%s[%d]: not an input port, but %s (%s)%s\n", p, func, line, typ);
+ return(p);
+}
+
+static s7_pointer check_ref_pro(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ if ((typ != T_OUTPUT_PORT) && (p != cur_sc->F))
+ complain("%s%s[%d]: not an output port, but %s (%s)%s\n", p, func, line, typ);
+ return(p);
+}
+
+static s7_pointer check_ref_vec(s7_pointer p, const char *func, int32_t line)
+{
+ if ((strcmp(func, "sweep") != 0) &&
+ (strcmp(func, "process_multivector") != 0))
+ {
+ uint8_t typ = unchecked_type(p);
+ if (!t_vector_p[typ]) complain("%s%s[%d]: not a vector, but %s (%s)%s\n", p, func, line, typ);
+ }
+ return(p);
+}
+
+static s7_pointer check_ref_clo(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ if (!t_has_closure_let[typ]) complain("%s%s[%d]: not a closure, but %s (%s)%s\n", p, func, line, typ);
+ return(p);
+}
+
+static s7_pointer check_ref_fnc(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ if (typ < T_C_MACRO) complain("%s%s[%d]: not a c function or macro (type < T_C_MACRO, from T_Fnc), but %s (%s)%s\n", p, func, line, typ);
+ return(p);
+}
+
+static s7_pointer check_ref_num(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ if ((typ < T_INTEGER) || (typ > T_COMPLEX))
+ complain("%s%s[%d]: not a number, but %s (%s)%s\n", p, func, line, typ);
+ return(p);
+}
+
+static s7_pointer check_ref_seq(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ if ((!t_sequence_p[typ]) && (!t_structure_p[typ]) && (!is_any_closure(p))) /* closure as iterator -- see s7test */
+ complain("%s%s[%d]: not a sequence or structure, but %s (%s)%s\n", p, func, line, typ);
+ return(p);
+}
+
+static s7_pointer check_ref_met(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ if ((typ != T_LET) && (typ != T_C_OBJECT) && (!is_any_closure(p)) && (!is_any_macro(p)) && (typ != T_C_POINTER))
+ complain("%s%s[%d]: not a possible method holder, but %s (%s)%s\n", p, func, line, typ);
+ return(p);
+}
+
+static s7_pointer check_ref_arg(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ if ((typ != T_PAIR) && (typ != T_NIL) && (typ != T_SYMBOL))
+ complain("%s%s[%d]: arglist is %s (%s)%s?\n", p, func, line, typ);
+ return(p);
+}
+
+static s7_pointer check_ref_app(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ if ((!t_applicable_p[typ]) && (p != cur_sc->F))
+ complain("%s%s[%d]: applicable object is %s (%s)%s?\n", p, func, line, typ);
+ return(p);
+}
+
+static s7_pointer check_ref_sln(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ;
+ if (is_slot_end(p)) return(p);
+ typ = unchecked_type(p);
+ if ((typ != T_SLOT) && (typ != T_NIL)) /* unset slots are nil */
+ complain("%s%s[%d]: slot is %s (%s)%s?\n", p, func, line, typ);
+ return(p);
+}
+
+static s7_pointer check_ref_out(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ;
+ if (!p) return(NULL);
+ typ = unchecked_type(p);
+ if (typ != T_LET)
+ complain("%s%s[%d]: outlet is %s (%s)%s?\n", p, func, line, typ);
+ return(p);
+}
+
+static s7_pointer check_ref_svec(s7_pointer p, const char *func, int32_t line)
+{
+ if (!is_any_vector(p)) complain("%s%s[%d]: subvector is %s (%s)%s?\n", p, func, line, unchecked_type(p));
+ if (!is_subvector(p)) complain("%s%s[%d]: subvector is %s (%s), but not a subvector?%s\n", p, func, line, unchecked_type(p));
+ return(p);
+}
+
+static s7_pointer check_ref_prc(s7_pointer p, const char *func, int32_t line)
+{
+ if ((!is_any_procedure(p)) && (!is_boolean(p)))
+ complain("%s%s[%d]: setter is %s (%s)%s?\n", p, func, line, unchecked_type(p));
+ return(p);
+}
+
+static void print_gc_info(s7_scheme *sc, s7_pointer obj, const char *func, int32_t line)
+{
+ if (!obj)
+ fprintf(stderr, "[%d]: obj is %p\n", line, obj);
+ else
+ if (unchecked_type(obj) != T_FREE)
+ 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);
+ }
+ if (sc->stop_at_error) abort();
+}
+
+static s7_pointer check_nref(s7_pointer p, const char *func, int32_t line)
+{
+ if (!p)
+ {
+ fprintf(stderr, "%s%s[%d]: null pointer!%s\n", bold_text, func, line, unbold_text);
+ if (cur_sc->stop_at_error) abort();
+ }
+ 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();
+ }
+ if (unchecked_type(p) == T_FREE)
+ {
+ fprintf(stderr, "%s%s[%d]: attempt to use free cell%s\n", bold_text, func, line, unbold_text);
+ print_gc_info(cur_sc, p, func, line);
+ if (cur_sc->stop_at_error) abort();
+ }
+ return(p);
+}
+
+static s7_pointer check_ref_nmv(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ check_nref(p, func, line);
+ if ((is_multiple_value(p)) &&
+ (!safe_strcmp(func, "mark_slot"))) /* match == multiple-values which causes false error messages */
+ complain("%s%s[%d]: slot value is a multiple-value, %s (%s)%s?\n", p, func, line, typ);
+ if (has_odd_bits(p))
+ {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(cur_sc, p)); free(s);}
+ if (t_exs_p[typ])
+ {
+ fprintf(stderr, "%s[%d]: slot_value is %s?\n", func, line, s7_type_names[typ]);
+ if (cur_sc->stop_at_error) abort();
+ }
+ return(p);
+}
+
+static s7_pointer check_ref_mac(s7_pointer p, const char *func, int32_t line)
+{
+ if ((!is_any_macro(p)) || (is_c_macro(p))) complain("%s%s[%d]: macro is %s (%s)%s?\n", p, func, line, unchecked_type(p));
+ return(p);
+}
+
+static s7_pointer check_ref_key(s7_pointer p, const char *func, int32_t line)
+{
+ if (!is_symbol_and_keyword(p)) complain("%s%s[%d]: not a keyword: %s (%s)%s?\n", p, func, line, unchecked_type(p));
+ 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();
+ }
+ 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);
+ if (has_odd_bits(p))
+ {char *s; fprintf(stderr, "odd bits: %s\n", s = describe_type_bits(cur_sc, p)); free(s);}
+ }
+ return(p);
+}
+
+static s7_pointer check_ref_ext(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ check_nref(p, func, line);
+ if (t_ext_p[typ])
+ {
+ fprintf(stderr, "%s%s[%d]: attempt to use (internal) %s cell%s\n", bold_text, func, line, s7_type_names[typ], unbold_text);
+ if (cur_sc->stop_at_error) abort();
+ }
+ return(p);
+}
+
+static s7_pointer check_ref_exs(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(p);
+ check_nref(p, func, line);
+ if (t_exs_p[typ])
+ {
+ fprintf(stderr, "%s%s[%d]: attempt to use (internal) %s cell%s\n", bold_text, func, line, s7_type_names[typ], unbold_text);
+ if (cur_sc->stop_at_error) abort();
+ }
+ return(p);
+}
+
+static s7_pointer check_opcode(s7_pointer p, const char *func, int32_t line)
+{
+ s7_int op = (s7_int)(intptr_t)p;
+ if ((op < 0) || (op >= NUM_OPS))
+ {
+ fprintf(stderr, "%s%s[%d]: opcode_t: %" ld64 " == %p?%s\n", bold_text, func, line, op, p, unbold_text);
+ if (cur_sc->stop_at_error) abort();
+ }
+ return(p);
+}
+
+static void check_set_cdr(s7_pointer p, s7_pointer Val, const char *func, int32_t line)
+{
+ if ((is_immutable(p)) && (!in_heap(p)))
+ fprintf(stderr, "%s[%d]: set_cdr target is immutable and not in the heap, %p\n", func, line, p);
+ if ((!in_heap(p)) && (in_heap(Val)))
+ fprintf(stderr, "%s[%d]: set_cdr target is not in the heap, but the new value is, %p %p\n", func, line, p, Val);
+ cdr(p) = Val;
+}
+
+static const char *opt1_role_name(uint64_t role)
+{
+ if (role == OPT1_FAST) return("opt1_fast");
+ if (role == OPT1_CFUNC) return("opt1_cfunc");
+ if (role == OPT1_LAMBDA) return("opt1_lambda");
+ if (role == OPT1_CLAUSE) return("opt1_clause");
+ if (role == OPT1_SYM) return("opt1_sym");
+ if (role == OPT1_PAIR) return("opt1_pair");
+ if (role == OPT1_CON) return("opt1_con");
+ if (role == OPT1_ANY) return("opt1_any");
+ return((role == OPT1_HASH) ? "opt1_hash" : "opt1_unknown");
+}
+
+static const char *opt2_role_name(uint64_t role)
+{
+ if (role == OPT2_FX) return("opt2_fx");
+ if (role == OPT2_FN) return("opt2_fn");
+ if (role == OPT2_KEY) return("opt2_any");
+ if (role == OPT2_SLOW) return("opt2_slow");
+ if (role == OPT2_SYM) return("opt2_sym");
+ if (role == OPT2_PAIR) return("opt2_pair");
+ if (role == OPT2_CON) return("opt2_con");
+ if (role == OPT2_LAMBDA) return("opt2_lambda");
+ if (role == OPT2_DIRECT) return("opt2_direct");
+ if (role == OPT2_INT) return("opt2_int");
+ return((role == OPT2_NAME) ? "opt2_raw_name" : "opt2_unknown");
+}
+
+static const char *opt3_role_name(uint64_t role)
+{
+ if (role == OPT3_ARGLEN) return("opt3_arglen");
+ if (role == OPT3_SYM) return("opt3_sym");
+ if (role == OPT3_CON) return("opt3_con");
+ if (role == OPT3_AND) return("opt3_pair");
+ if (role == OPT3_ANY) return("opt3_any");
+ if (role == OPT3_LET) return("opt3_let");
+ if (role == OPT3_BYTE) return("opt3_byte");
+ if (role == OPT3_DIRECT) return("direct_opt3");
+ if (role == OPT3_LEN) return("opt3_len");
+ if (role == OPT3_INT) return("opt3_int");
+ return((role == OPT3_LOCATION) ? "opt3_location" : "opt3_unknown");
+}
+
+static void show_opt1_bits(s7_pointer p, const char *func, int32_t line, uint64_t role)
+{
+ 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);
+ free(bits);
+}
+
+static s7_pointer opt1_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line)
+{
+ if ((!opt1_is_set(p)) ||
+ ((!opt1_role_matches(p, role)) &&
+ (role != OPT1_ANY)))
+ {
+ show_opt1_bits(p, func, line, role);
+ if (sc->stop_at_error) abort();
+ }
+ return(p->object.cons.opt1);
+}
+
+static void base_opt1(s7_pointer p, uint64_t role)
+{
+ set_opt1_role(p, role);
+ set_opt1_is_set(p);
+}
+
+static s7_pointer set_opt1_1(s7_pointer p, s7_pointer x, uint64_t role, const char *func, int32_t line)
+{
+ if (((p->debugger_bits & OPT1_MASK) != role) &&
+ ((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));
+ p->object.cons.opt1 = x;
+ base_opt1(p, role);
+ return(x);
+}
+
+static uint64_t opt1_hash_1(s7_scheme *sc, s7_pointer p, const char *func, int32_t line)
+{
+ if ((!opt1_is_set(p)) || (!opt1_role_matches(p, OPT1_HASH)))
+ {
+ show_opt1_bits(p, func, line, (uint64_t)OPT1_HASH);
+ if (sc->stop_at_error) abort();
+ }
+ return(p->object.sym_cons.hash);
+}
+
+static void set_opt1_hash_1(s7_pointer p, uint64_t x)
+{
+ p->object.sym_cons.hash = x;
+ base_opt1(p, OPT1_HASH);
+}
+
+static void show_opt2_bits(s7_pointer p, const char *func, int32_t line, uint64_t role)
+{
+ 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));
+ 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")));
+}
+
+static void check_opt2_bits(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line)
+{
+ if (!p)
+ {
+ fprintf(stderr, "%s%s[%d]: opt2 null!\n%s", bold_text, func, line, unbold_text);
+ if (sc->stop_at_error) abort();
+ }
+ if ((!opt2_is_set(p)) ||
+ (!opt2_role_matches(p, role)))
+ {
+ show_opt2_bits(p, func, line, role);
+ if (sc->stop_at_error) abort();
+ }
+}
+
+static s7_pointer opt2_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line)
+{
+ check_opt2_bits(sc, p, role, func, line);
+ return(p->object.cons.o2.opt2);
+}
+
+static s7_int opt2_n_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line)
+{
+ check_opt2_bits(sc, p, role, func, line);
+ return(p->object.cons.o2.n);
+}
+
+static void base_opt2(s7_pointer p, uint64_t role)
+{
+ set_opt2_role(p, role);
+ set_opt2_is_set(p);
+}
+
+static void set_opt2_1(s7_scheme *sc, s7_pointer p, s7_pointer x, uint64_t role, const char *func, int32_t line)
+{
+ if ((role == OPT2_FX) &&
+ (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 : "");
+ 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));
+ if (sc->stop_at_error) abort();
+ }
+ p->object.cons.o2.opt2 = x;
+ base_opt2(p, role);
+}
+
+static void set_opt2_n_1(s7_scheme *unused_sc, s7_pointer p, s7_int x, uint64_t role, const char *unused_func, int32_t unused_line)
+{
+ p->object.cons.o2.n = x;
+ base_opt2(p, role);
+}
+
+static const char *opt2_name_1(s7_scheme *sc, s7_pointer p, const char *func, int32_t line)
+{
+ if ((!opt2_is_set(p)) ||
+ (!opt2_role_matches(p, OPT2_NAME)))
+ {
+ show_opt2_bits(p, func, line, (uint64_t)OPT2_NAME);
+ if (sc->stop_at_error) abort();
+ }
+ return(p->object.sym_cons.fstr);
+}
+
+static void set_opt2_name_1(s7_pointer p, const char *str)
+{
+ p->object.sym_cons.fstr = str;
+ base_opt2(p, OPT2_NAME);
+}
+
+static void show_opt3_bits(s7_pointer p, const char *func, int32_t line, uint64_t role)
+{
+ char *bits = show_debugger_bits(p);
+ fprintf(stderr, "%s%s[%d]%s: opt3: %s %" PRIx64 "%s", bold_text, func, line, unbold_text, opt3_role_name(role), p->debugger_bits, bits);
+ free(bits);
+}
+
+static void check_opt3_bits(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line)
+{
+ if (!p)
+ {
+ fprintf(stderr, "%s%s[%d]: opt3 null!\n%s", bold_text, func, line, unbold_text);
+ if (sc->stop_at_error) abort();
+ }
+ if ((!opt3_is_set(p)) ||
+ (!opt3_role_matches(p, role)))
+ {
+ show_opt3_bits(p, func, line, role);
+ if (sc->stop_at_error) abort();
+ }
+}
+
+static s7_pointer opt3_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line)
+{
+ check_opt3_bits(sc, p, role, func, line);
+ return(p->object.cons.o3.opt3);
+}
+
+static s7_int opt3_n_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line)
+{
+ check_opt3_bits(sc, p, role, func, line);
+ return(p->object.cons.o3.n);
+}
+
+static void base_opt3(s7_pointer p, uint64_t role)
+{
+ set_opt3_role(p, role);
+ set_opt3_is_set(p);
+}
+
+static void set_opt3_1(s7_pointer p, s7_pointer x, uint64_t role)
+{
+ clear_type_bit(p, T_LOCATION);
+ p->object.cons.o3.opt3 = x;
+ base_opt3(p, role);
+}
+
+static void set_opt3_n_1(s7_pointer p, s7_int x, uint64_t role)
+{
+ clear_type_bit(p, T_LOCATION);
+ p->object.cons.o3.n = x;
+ base_opt3(p, role);
+}
+
+static uint8_t opt3_byte_1(s7_scheme *sc, s7_pointer p, uint64_t role, const char *func, int32_t line)
+{
+ check_opt3_bits(sc, p, role, func, line);
+ return(p->object.cons.o3.opt_type);
+}
+
+static void set_opt3_byte_1(s7_pointer p, uint8_t x, uint64_t role, const char *unused_func, int32_t unused_line)
+{
+ clear_type_bit(p, T_LOCATION);
+ p->object.cons.o3.opt_type = x;
+ base_opt3(p, role);
+}
+
+static uint64_t opt3_location_1(s7_scheme *sc, s7_pointer p, const char *func, int32_t line)
+{
+ if ((!opt3_is_set(p)) ||
+ ((p->debugger_bits & OPT3_LOCATION) == 0) ||
+ (!has_location(p)))
+ {
+ show_opt3_bits(p, func, line, (uint64_t)OPT3_LOCATION);
+ if (sc->stop_at_error) abort();
+ }
+ return(p->object.sym_cons.location); /* don't use pair_location macro here or below (infinite recursion if S7_DEBUGGING via opt3_location_1) */
+}
+
+static void set_opt3_location_1(s7_pointer p, uint64_t x)
+{
+ p->object.sym_cons.location = x;
+ (p)->debugger_bits = (OPT3_LOCATION | (p->debugger_bits & ~OPT3_LEN)); /* turn on line, cancel len */
+ set_opt3_is_set(p);
+}
+
+static uint64_t opt3_len_1(s7_scheme *sc, s7_pointer p, const char *func, int32_t line)
+{
+ if ((!opt3_is_set(p)) ||
+ ((p->debugger_bits & OPT3_LEN) == 0) ||
+ (has_location(p)))
+ {
+ show_opt3_bits(p, func, line, (uint64_t)OPT3_LEN);
+ if (sc->stop_at_error) abort();
+ }
+ return(p->object.sym_cons.location);
+}
+
+static void set_opt3_len_1(s7_pointer p, uint64_t x)
+{
+ clear_type_bit(p, T_LOCATION);
+ p->object.sym_cons.location = x;
+ (p)->debugger_bits = (OPT3_LEN | (p->debugger_bits & ~(OPT3_LOCATION)));
+ set_opt3_is_set(p);
+}
+
+static void print_debugging_state(s7_scheme *sc, s7_pointer obj, s7_pointer port)
+{
+ /* show current state, current allocated state */
+ char *allocated_bits, *str;
+ int64_t save_full_type = full_type(obj);
+ s7_int len, nlen;
+ const char *excl_name = (is_free(obj)) ? "free cell!" : "unknown object!";
+ block_t *b;
+ char *current_bits = describe_type_bits(sc, obj);
+
+ set_full_type(obj, obj->alloc_type);
+ allocated_bits = describe_type_bits(sc, obj);
+ set_full_type(obj, save_full_type);
+
+ len = safe_strlen(excl_name) + safe_strlen(current_bits) + safe_strlen(allocated_bits) + safe_strlen(obj->alloc_func) + 512;
+ 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);
+ free(current_bits);
+ free(allocated_bits);
+ if (is_null(port))
+ fprintf(stderr, "%p: %s\n", obj, str);
+ else port_write_string(port)(sc, str, clamp_length(nlen, len), port);
+ liberate(sc, b);
+}
+
+static s7_pointer check_null_sym(s7_scheme *sc, s7_pointer p, s7_pointer sym, int32_t line, const char *func)
+{
+ if (!p)
+ {
+ s7_pointer slot = symbol_to_local_slot(sc, sym, sc->curlet);
+ char *s = describe_type_bits(sc, sym);
+ fprintf(stderr, "%s%s[%d]: %s unbound%s\n", bold_text, func, line, symbol_name(sym), unbold_text);
+ fprintf(stderr, " symbol_id: %" ld64 ", let_id: %" ld64 ", bits: %s", symbol_id(sym), let_id(sc->curlet), s);
+ free(s);
+ if (is_slot(slot)) fprintf(stderr, ", slot: %s", display(slot));
+ fprintf(stderr, "\n");
+ if (sc->stop_at_error) abort();
+ }
+ return(p);
+}
+#endif /* S7_DEBUGGING */
+/* -------------------------------- end internal debugging apparatus -------------------------------- */
+
+
+static s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1)
+{
+ set_car(sc->elist_1, x1);
+ return(sc->elist_1);
+}
+
+static s7_pointer set_elist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2)
+{
+ set_car(sc->elist_2, x1);
+ set_cadr(sc->elist_2, x2);
+ return(sc->elist_2);
+}
+
+static s7_pointer set_elist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3)
+{
+ s7_pointer p = sc->elist_3;
+ set_car(p, x1); p = cdr(p);
+ set_car(p, x2); p = cdr(p);
+ set_car(p, x3);
+ return(sc->elist_3);
+}
+
+static s7_pointer set_elist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4)
+{
+ s7_pointer p = sc->elist_4;
+ set_car(p, x1); p = cdr(p);
+ set_car(p, x2); p = cdr(p);
+ set_car(p, x3); p = cdr(p);
+ set_car(p, x4);
+ return(sc->elist_4);
+}
+
+static s7_pointer set_elist_5(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5)
+{
+ set_car(sc->elist_5, x1);
+ set_elist_4(sc, x2, x3, x4, x5);
+ return(sc->elist_5);
+}
+
+static s7_pointer set_elist_6(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5, s7_pointer x6)
+{
+ set_car(sc->elist_6, x1);
+ set_elist_5(sc, x2, x3, x4, x5, x6);
+ return(sc->elist_6);
+}
+
+static s7_pointer set_elist_7(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5, s7_pointer x6, s7_pointer x7)
+{
+ set_car(sc->elist_7, x1);
+ set_elist_6(sc, x2, x3, x4, x5, x6, x7);
+ return(sc->elist_7);
+}
+
+static s7_pointer set_wlist_3(s7_pointer lst, s7_pointer x1, s7_pointer x2, s7_pointer x3)
+{
+ s7_pointer p = lst;
+ set_car(p, x1); p = cdr(p);
+ set_car(p, x2); p = cdr(p);
+ set_car(p, x3);
+ return(lst);
+}
+
+static s7_pointer set_wlist_4(s7_pointer lst, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4)
+{
+ s7_pointer p = lst;
+ set_car(p, x1); p = cdr(p);
+ set_car(p, x2); p = cdr(p);
+ set_car(p, x3); p = cdr(p);
+ set_car(p, x4);
+ return(lst);
+}
+
+static s7_pointer set_mlist_1(s7_scheme *sc, s7_pointer x1)
+{
+ set_car(sc->mlist_1, x1);
+ return(sc->mlist_1);
+}
+
+static s7_pointer set_mlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* mlist_3 saves 3 in tmock -- see ~/old/s7-mlist_3.c */
+{
+ set_car(sc->mlist_2, x1);
+ set_cadr(sc->mlist_2, x2);
+ return(sc->mlist_2);
+}
+
+static s7_pointer set_plist_1(s7_scheme *sc, s7_pointer x1)
+{
+ set_car(sc->plist_1, x1);
+ return(sc->plist_1);
+}
+
+static s7_pointer set_plist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2)
+{
+ set_car(sc->plist_2, x1);
+ set_car(sc->plist_2_2, x2);
+ return(sc->plist_2);
+}
+
+static s7_pointer set_plist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3)
+{
+ return(set_wlist_3(sc->plist_3, x1, x2, x3));
+}
+
+static s7_pointer set_plist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4)
+{
+ return(set_wlist_4(sc->plist_4, x1, x2, x3, x4));
+}
+
+static s7_pointer set_qlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* let_ref_fallback */
+{
+ set_car(sc->qlist_2, x1);
+ set_cadr(sc->qlist_2, x2);
+ return(sc->qlist_2);
+}
+
+static s7_pointer set_qlist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) /* let_set_fallback */
+{
+ return(set_wlist_3(sc->qlist_3, x1, x2, x3));
+}
+
+static s7_pointer set_clist_1(s7_scheme *sc, s7_pointer x1) /* for c_object length method etc, a "weak" list */
+{
+ set_car(sc->clist_1, x1);
+ return(sc->clist_1);
+}
+
+static s7_pointer set_clist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* for c_object equal method etc, a "weak" list */
+{
+ set_car(sc->clist_2, x1);
+ set_cadr(sc->clist_2, x2);
+ return(sc->clist_2);
+}
+
+static s7_pointer set_dlist_1(s7_scheme *sc, s7_pointer x1) /* another like clist: temp usage, "weak" (not gc_marked), but semipermanent list */
+{
+ set_car(sc->dlist_1, x1);
+ return(sc->dlist_1);
+}
+
+static s7_pointer set_ulist_1(s7_scheme *sc, s7_pointer x1, s7_pointer x2)
+{
+ set_car(sc->u1_1, x1);
+ unchecked_set_cdr(sc->u1_1, x2);
+ return(sc->u1_1);
+}
+
+
+/* ---------------- error handlers ---------------- */
+static const char *make_type_name(s7_scheme *sc, const char *name, article_t article)
+{
+ s7_int i, slen = safe_strlen(name);
+ s7_int len = slen + 8;
+ if (len > sc->typnam_len)
+ {
+ if (sc->typnam) free(sc->typnam);
+ sc->typnam = (char *)Malloc(len);
+ sc->typnam_len = len;
+ }
+ if (article == INDEFINITE_ARTICLE)
+ {
+ 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++] = ' ';
+ }
+ else i = 0;
+ memcpy((void *)(sc->typnam + i), (const void *)name, slen);
+ sc->typnam[i + slen] = '\0';
+ return(sc->typnam);
+}
+
+static const char *type_name_from_type(int32_t typ, article_t article)
+{
+ /* if the type enum never changed, this could just be an array lookup, but it doesn't matter -- this function isn't called much */
+ switch (typ)
+ {
+ case T_FREE: return((article == NO_ARTICLE) ? "free-cell" : "a free cell");
+ case T_NIL: return("nil");
+ case T_UNUSED: return((article == NO_ARTICLE) ? "#<unused>" : "the unused object");
+ case T_EOF: return((article == NO_ARTICLE) ? "#<eof>" : "the end-of-file object");
+ case T_UNSPECIFIED: return((article == NO_ARTICLE) ? "#<unspecified>" : "the unspecified object");
+ case T_UNDEFINED: return((article == NO_ARTICLE) ? "undefined" : "an undefined object");
+ case T_BOOLEAN: return("boolean");
+ case T_STRING: return((article == NO_ARTICLE) ? "string" : "a string");
+ case T_BYTE_VECTOR: return((article == NO_ARTICLE) ? "byte-vector" : "a byte-vector");
+ case T_SYMBOL: return((article == NO_ARTICLE) ? "symbol" : "a symbol");
+ case T_SYNTAX: return((article == NO_ARTICLE) ? "syntax" : "syntactic");
+ case T_PAIR: return((article == NO_ARTICLE) ? "pair" : "a pair");
+ case T_GOTO: return((article == NO_ARTICLE) ? "goto" : "a goto (from call-with-exit)");
+ case T_CONTINUATION: return((article == NO_ARTICLE) ? "continuation" : "a continuation");
+ case T_C_RST_NO_REQ_FUNCTION:
+ case T_C_FUNCTION: return((article == NO_ARTICLE) ? "c-function" : "a c-function");
+ case T_C_FUNCTION_STAR: return((article == NO_ARTICLE) ? "c-function*" : "a c-function*");
+ case T_CLOSURE: return((article == NO_ARTICLE) ? "function" : "a function");
+ case T_CLOSURE_STAR: return((article == NO_ARTICLE) ? "function*" : "a function*");
+ case T_C_MACRO: return((article == NO_ARTICLE) ? "c-macro" : "a c-macro");
+ case T_C_POINTER: return((article == NO_ARTICLE) ? "c-pointer" : "a c-pointer");
+ case T_CHARACTER: return((article == NO_ARTICLE) ? "character" : "a character");
+ case T_VECTOR: return((article == NO_ARTICLE) ? "vector" : "a vector");
+ case T_INT_VECTOR: return((article == NO_ARTICLE) ? "int-vector" : "an int-vector");
+ case T_FLOAT_VECTOR: return((article == NO_ARTICLE) ? "float-vector" : "a float-vector");
+ case T_MACRO_STAR: return((article == NO_ARTICLE) ? "macro*" : "a macro*");
+ case T_MACRO: return((article == NO_ARTICLE) ? "macro" : "a macro");
+ case T_BACRO_STAR: return((article == NO_ARTICLE) ? "bacro*" : "a bacro*");
+ case T_BACRO: return((article == NO_ARTICLE) ? "bacro" : "a bacro");
+ case T_CATCH: return((article == NO_ARTICLE) ? "catch" : "a catch");
+ case T_STACK: return((article == NO_ARTICLE) ? "stack" : "a stack");
+ case T_DYNAMIC_WIND: return((article == NO_ARTICLE) ? "dynamic-wind" : "a dynamic-wind");
+ case T_HASH_TABLE: return((article == NO_ARTICLE) ? "hash-table" : "a hash-table");
+ case T_ITERATOR: return((article == NO_ARTICLE) ? "iterator" : "an iterator");
+ case T_LET: return((article == NO_ARTICLE) ? "let" : "a let");
+ case T_COUNTER: return((article == NO_ARTICLE) ? "internal-counter" : "an internal counter");
+ case T_RANDOM_STATE: return((article == NO_ARTICLE) ? "random-state" : "a random-state");
+ case T_SLOT: return((article == NO_ARTICLE) ? "slot" : "a slot (variable binding)");
+ case T_INTEGER: return((article == NO_ARTICLE) ? "integer" : "an integer");
+ case T_RATIO: return((article == NO_ARTICLE) ? "ratio" : "a ratio");
+ case T_REAL: return((article == NO_ARTICLE) ? "real" : "a real");
+ case T_COMPLEX: return((article == NO_ARTICLE) ? "complex-number" : "a complex number");
+ case T_BIG_INTEGER: return((article == NO_ARTICLE) ? "big-integer" : "a big integer");
+ case T_BIG_RATIO: return((article == NO_ARTICLE) ? "big-ratio" : "a big ratio");
+ case T_BIG_REAL: return((article == NO_ARTICLE) ? "big-real" : "a big real");
+ case T_BIG_COMPLEX: return((article == NO_ARTICLE) ? "big-complex-number": "a big complex number");
+ case T_INPUT_PORT: return((article == NO_ARTICLE) ? "input-port" : "an input port");
+ case T_OUTPUT_PORT: return((article == NO_ARTICLE) ? "output-port" : "an output port");
+ case T_C_OBJECT: return((article == NO_ARTICLE) ? "c-object" : "a c_object");
+ }
+ return(NULL);
+}
+
+static s7_pointer find_let(s7_scheme *sc, s7_pointer obj)
+{
+ if (is_let(obj)) return(obj);
+ switch (type(obj))
+ {
+ case T_MACRO: case T_MACRO_STAR:
+ case T_BACRO: case T_BACRO_STAR:
+ case T_CLOSURE: case T_CLOSURE_STAR:
+ return(closure_let(obj));
+ case T_C_OBJECT:
+ 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));
+ 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);
+ /* what about cload into local? there's no way for a c-func to get its definition env? (s7_define sets global from local_slot if env==shadow_rootlet)
+ * (*libc* 'memcpy): memcpy, ((rootlet) 'memcpy): #<undefined>, (with-let (rootlet) memcpy): error (undefined), (with-let *libc* memcpy): memcpy
+ * but how to get *libc* from (funclet (*libc* 'memcpy))
+ * currently (*libc* 'sqrt) is #_sqrt (i.e. s7's) whereas (*libm* 'sqrt) is libm's (i.e. s7__sqrt in libm_s7.c) -- confusing
+ * perhaps add a funclet field to c_proc_t?
+ */
+ }
+ return(sc->nil);
+}
+
+static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e);
+
+static s7_pointer find_method(s7_scheme *sc, s7_pointer let, s7_pointer symbol)
+{
+ s7_pointer slot;
+ if (symbol_id(symbol) == 0) /* this means the symbol has never been used locally, so how can it be a method? */
+ return(sc->undefined);
+ slot = lookup_slot_from(symbol, let);
+ if (slot != global_slot(symbol))
+ return(slot_value(slot));
+ return(sc->undefined);
+}
+
+static s7_pointer find_method_with_let(s7_scheme *sc, s7_pointer let, s7_pointer symbol)
+{
+ return(find_method(sc, find_let(sc, let), symbol));
+}
+
+static const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article)
+{
+ switch (unchecked_type(arg))
+ {
+ case T_C_OBJECT: return(make_type_name(sc, string_value(c_object_scheme_name(sc, arg)), article));
+ case T_INPUT_PORT: return(make_type_name(sc, (is_file_port(arg)) ? "input file port" : ((is_string_port(arg)) ? "input string port" : "input port"), 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));
+ }
+ default:
+ {
+ const char *str = type_name_from_type(unchecked_type(arg), article);
+ if (str) return(str);
+ }}
+ return("messed up object");
+}
+
+static s7_pointer object_type_name(s7_scheme *sc, s7_pointer x)
+{
+ uint8_t typ;
+ 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));
+ }
+ typ = type(x);
+ if (typ < NUM_TYPES)
+ {
+ if (typ == T_C_OBJECT) return(c_object_scheme_name(sc, x));
+ return(sc->type_names[typ]);
+ }
+ return(wrap_string(sc, "unknown type!", 13));
+}
+
+static s7_pointer type_name_string(s7_scheme *sc, s7_pointer arg)
+{
+ if (type(arg) < NUM_TYPES)
+ {
+ s7_pointer p = sc->type_names[type(arg)]; /* these use INDEFINITE_ARTICLE */
+ if (is_string(p)) return(p);
+ }
+ return(s7_make_string_wrapper(sc, type_name(sc, arg, INDEFINITE_ARTICLE)));
+}
+
+
+static noreturn void sole_arg_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer typ)
+{
+ set_wlist_4(cdr(sc->sole_arg_wrong_type_info), caller, arg, object_type_name(sc, arg), typ);
+ error_nr(sc, sc->wrong_type_arg_symbol, sc->sole_arg_wrong_type_info);
+}
+
+static /* Inline */ noreturn void wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int arg_num, s7_pointer arg, s7_pointer typ)
+{
+ s7_pointer p = cdr(sc->wrong_type_arg_info); /* info list is '(format_string caller arg_n arg type_name descr) */
+ set_car(p, caller); p = cdr(p);
+ set_car(p, (is_small_int(arg_num)) ? small_int(arg_num) : wrap_integer(sc, arg_num)); p = cdr(p);
+ set_car(p, arg); p = cdr(p);
+ set_car(p, object_type_name(sc, arg)); p = cdr(p);
+ set_car(p, typ);
+ error_nr(sc, sc->wrong_type_arg_symbol, sc->wrong_type_arg_info);
+}
+
+s7_pointer s7_wrong_type_arg_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr)
+{
+ if (arg_n > 0)
+ wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), arg_n, arg, wrap_string(sc, descr, safe_strlen(descr)));
+ sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), arg, wrap_string(sc, descr, safe_strlen(descr)));
+ return(sc->wrong_type_arg_symbol);
+}
+
+s7_pointer s7_wrong_type_error(s7_scheme *sc, s7_pointer caller, s7_int arg_n, s7_pointer arg, s7_pointer descr)
+{
+ if (arg_n > 0) wrong_type_error_nr(sc, caller, arg_n, arg, descr);
+ sole_arg_wrong_type_error_nr(sc, caller, arg, descr);
+ return(sc->wrong_type_arg_symbol); /* never happens */
+}
+
+static noreturn void sole_arg_out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg, s7_pointer descr)
+{
+ set_wlist_3(cdr(sc->sole_arg_out_of_range_info), caller, arg, descr);
+ error_nr(sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info);
+}
+
+static noreturn void out_of_range_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer arg_n, s7_pointer arg, s7_pointer descr)
+{
+ set_wlist_4(cdr(sc->out_of_range_info), caller, arg_n, arg, descr);
+ error_nr(sc, sc->out_of_range_symbol, sc->out_of_range_info);
+}
+
+s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr)
+{
+ 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)));
+ 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)));
+ error_nr(sc, sc->out_of_range_symbol, sc->sole_arg_out_of_range_info);
+ return(sc->out_of_range_symbol);
+}
+
+static noreturn void wrong_number_of_arguments_error_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer args)
+{
+ error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_2(sc, wrap_string(sc, errmsg, len), args));
+}
+
+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 */
+ return(sc->wrong_number_of_args_symbol);
+}
+
+
+static noreturn void syntax_error_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer obj)
+{
+ error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, errmsg, len), obj));
+}
+
+static noreturn void syntax_error_with_caller_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer caller, s7_pointer obj)
+{
+ error_nr(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, errmsg, len), caller, obj));
+}
+
+static noreturn void syntax_error_with_caller2_nr(s7_scheme *sc, const char *errmsg, s7_int len, s7_pointer caller, s7_pointer name, s7_pointer obj)
+{
+ error_nr(sc, sc->syntax_error_symbol, set_elist_4(sc, wrap_string(sc, errmsg, len), caller, name, obj));
+}
+
+static s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len); /* calls new_symbol */
+#define make_symbol_with_strlen(Sc, Name) make_symbol(Sc, Name, safe_strlen(Name))
+
+static s7_pointer missing_method_class_name(s7_scheme *sc, s7_pointer obj)
+{
+ s7_pointer class_name = find_method(sc, obj, sc->class_name_symbol);
+ if (is_symbol(class_name)) return(class_name);
+ return(sc->is_openlet_symbol);
+}
+
+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) :
+ (((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)));
+}
+
+static noreturn void immutable_object_error_nr(s7_scheme *sc, s7_pointer info) {error_nr(sc, sc->immutable_error_symbol, info);}
+
+
+/* -------- method handlers -------- */
+s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method)
+{
+ if (has_active_methods(sc, obj)) return(find_method_with_let(sc, obj, method));
+ return(sc->undefined);
+}
+
+/* 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)) \
+ return(s7_apply_function(Sc, func, Args)); \
+ }
+
+static s7_pointer apply_boolean_method(s7_scheme *sc, s7_pointer obj, s7_pointer method)
+{
+ s7_pointer func = find_method_with_let(sc, obj, method);
+ if (func == sc->undefined) return(sc->F);
+ return(s7_apply_function(sc, func, set_mlist_1(sc, obj))); /* plist here and below will probably not work (_pp case known bad) */
+}
+
+/* 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)); \
+ }
+
+static s7_pointer apply_method_closure(s7_scheme *sc, s7_pointer func, s7_pointer args);
+
+static s7_pointer find_and_apply_method(s7_scheme *sc, s7_pointer obj, s7_pointer sym, s7_pointer args) /* slower if inline */
+{
+ s7_pointer func = find_method_with_let(sc, obj, sym);
+ if (is_closure(func)) return(apply_method_closure(sc, func, args));
+ if (func == sc->undefined) missing_method_error_nr(sc, sym, obj);
+ if ((S7_DEBUGGING) && (func == global_value(sym))) fprintf(stderr, "loop in %s?\n", __func__);
+ return(s7_apply_function(sc, func, args));
+}
+
+static s7_pointer method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, 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, args));
+}
+
+static s7_pointer mutable_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ, int32_t num)
+{
+ if (has_active_methods(sc, obj)) return(find_and_apply_method(sc, obj, method, args));
+ if (sc->type_names[type(obj)] != typ) wrong_type_error_nr(sc, method, num, obj, typ);
+ if (!is_immutable(obj)) wrong_type_error_nr(sc, method, num, obj, typ);
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, method, obj));
+ return(NULL);
+}
+
+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)
+{
+ return(mutable_method_or_bust(sc, obj, method, set_qlist_3(sc, x1, x2, x3), typ, num)); /* was list_3, plist_3 not safe */
+}
+
+static s7_pointer method_or_bust_p(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer typ)
+{
+ if (!has_active_methods(sc, obj)) sole_arg_wrong_type_error_nr(sc, method, obj, typ);
+ return(find_and_apply_method(sc, obj, method, set_mlist_1(sc, obj)));
+}
+
+static s7_pointer method_or_bust_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer x1, s7_pointer 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, x2)));
+}
+
+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)
+{
+ 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)
+{
+ int32_t loc = sc->error_argnum + num;
+ sc->error_argnum = 0;
+ if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method, loc, obj, typ);
+ return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, x2)));
+}
+
+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)
+{
+ 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)
+{
+ 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))));
+}
+
+static s7_pointer sole_arg_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer args, s7_pointer typ)
+{
+ if (!has_active_methods(sc, obj)) sole_arg_wrong_type_error_nr(sc, method, obj, typ);
+ return(find_and_apply_method(sc, obj, method, args));
+}
+
+
+/* -------------------------------- constants -------------------------------- */
+/* #f and #t */
+s7_pointer s7_f(s7_scheme *sc) {return(sc->F);}
+s7_pointer s7_t(s7_scheme *sc) {return(sc->T);}
+
+
+/* () */
+s7_pointer s7_nil(s7_scheme *sc) {return(sc->nil);} /* should this be "s7_null" ? */
+bool s7_is_null(s7_scheme *sc, s7_pointer p) {return(is_null(p));}
+static bool is_null_b_p(s7_pointer p) {return(type(p) == T_NIL);} /* faster than b_7p because opt_b_p is faster */
+
+static s7_pointer g_is_null(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_null "(null? obj) returns #t if obj is the empty list"
+ #define Q_is_null sc->pl_bt
+ check_boolean_method(sc, is_null, sc->is_null_symbol, args);
+}
+
+
+/* #<undefined> and #<unspecified> */
+s7_pointer s7_undefined(s7_scheme *sc) {return(sc->undefined);}
+s7_pointer s7_unspecified(s7_scheme *sc) {return(sc->unspecified);}
+
+bool s7_is_unspecified(s7_scheme *sc, s7_pointer val) {return(is_unspecified(val));}
+
+static s7_pointer g_is_undefined(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_undefined "(undefined? val) returns #t if val is #<undefined> or some other #... value that s7 does not recognize; (undefined? #asdf): #t.\
+This is not the same as (not (defined? val)) which refers to whether a symbol has a binding: (undefined? 'asdf): #f, but (not (defined? 'asdf)): #t"
+ #define Q_is_undefined sc->pl_bt
+ check_boolean_method(sc, is_undefined, sc->is_undefined_symbol, args);
+}
+
+static s7_pointer g_is_unspecified(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_unspecified "(unspecified? val) returns #t if val is #<unspecified>"
+ #define Q_is_unspecified sc->pl_bt
+ check_boolean_method(sc, is_unspecified, sc->is_unspecified_symbol, args);
+}
+
+
+/* -------------------------------- eof-object? -------------------------------- */
+s7_pointer eof_object = NULL; /* #<eof> is an entry in the chars array, so it's not a part of sc */
+
+s7_pointer s7_eof_object(s7_scheme *sc) {return(eof_object);}
+
+static s7_pointer g_is_eof_object(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_eof_object "(eof-object? val) returns #t if val is the end-of-file object, #<eof>. It is the same as (eq? val #<eof>)"
+ #define Q_is_eof_object sc->pl_bt
+ check_boolean_method(sc, is_eof, sc->is_eof_object_symbol, args);
+}
+
+static bool is_eof_object_b_p(s7_pointer p) {return(p == eof_object);}
+
+
+/* -------------------------------- not -------------------------------- */
+static bool not_b_7p(s7_scheme *sc, s7_pointer p) {return(p == sc->F);}
+
+static s7_pointer g_not(s7_scheme *sc, s7_pointer args)
+{
+ #define H_not "(not obj) returns #t if obj is #f, otherwise #f: (not ()) -> #f"
+ #define Q_not sc->pl_bt
+ return((car(args) == sc->F) ? sc->T : sc->F);
+}
+
+
+/* -------------------------------- boolean? -------------------------------- */
+bool s7_boolean(s7_scheme *sc, s7_pointer x) {return(x != sc->F);}
+s7_pointer s7_make_boolean(s7_scheme *sc, bool x) {return(make_boolean(sc, x));}
+
+bool s7_is_boolean(s7_pointer x) {return(type(x) == T_BOOLEAN);}
+
+static s7_pointer g_is_boolean(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_boolean "(boolean? obj) returns #t if obj is #f or #t: (boolean? ()) -> #f"
+ #define Q_is_boolean sc->pl_bt
+ check_boolean_method(sc, is_boolean, sc->is_boolean_symbol, args);
+}
+
+
+/* -------------------------------- constant? -------------------------------- */
+static inline bool is_constant_symbol(s7_scheme *sc, s7_pointer sym) /* inline: 7 in cb, 5 in tgen */
+{
+ if (is_immutable_symbol(sym)) /* for keywords */
+ return(true);
+ if (is_possibly_constant(sym))
+ {
+ s7_pointer slot = s7_slot(sc, sym);
+ return((is_slot(slot)) && (is_immutable_slot(slot)));
+ }
+ return(false);
+}
+
+#define is_constant(sc, p) ((type(p) != T_SYMBOL) || (is_constant_symbol(sc, p)))
+
+static s7_pointer g_is_constant(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_constant "(constant? obj) returns #t if obj either evaluates to itself, or is a symbol whose binding is constant"
+ #define Q_is_constant sc->pl_bt
+ return(make_boolean(sc, is_constant(sc, car(args))));
+}
+
+static bool is_constant_b_7p(s7_scheme *sc, s7_pointer p) {return(is_constant(sc, p));}
+static s7_pointer is_constant_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_constant(sc, p)));}
+
+
+/* -------------------------------- immutable? -------------------------------- */
+
+bool s7_is_immutable(s7_pointer p) {return(is_immutable(p));}
+
+static s7_pointer g_is_immutable(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_immutable "(immutable? obj (env (curlet))) returns #t if obj (or obj in the environment env) is immutable"
+ #define Q_is_immutable s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->is_let_symbol)
+ s7_pointer p = car(args), slot;
+ if (is_symbol(p))
+ {
+ 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);
+ }
+ else slot = s7_slot(sc, p);
+ if (is_slot(slot)) /* might be #<undefined> */
+ return(make_boolean(sc, is_immutable_slot(slot)));
+ }
+ else
+ if ((is_pair(cdr(args))) && (!is_let(cadr(args)))) /* (immutable? 1 2) */
+ wrong_type_error_nr(sc, sc->is_immutable_symbol, 2, cadr(args), a_let_string);
+ return(make_boolean(sc, (is_immutable(p)) || (t_immutable_p[type(p)]) || ((is_any_vector(p)) && (vector_length(p) == 0))));
+}
+
+
+/* -------------------------------- immutable! -------------------------------- */
+s7_pointer s7_immutable(s7_pointer p)
+{
+ if (is_symbol(p)) /* trying to mimic g_immutable */
+ {
+ s7_pointer slot;
+ 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);
+ /* symbol is not set immutable (as below) */
+ }
+ else set_immutable(p);
+ return(p);
+}
+
+static s7_pointer g_immutable(s7_scheme *sc, s7_pointer args)
+{
+ #define H_immutable "(immutable! obj (env (curlet))) declares that the object obj (or obj in the environment env) can't be changed. obj is returned."
+ #define Q_immutable s7_make_signature(sc, 3, sc->T, sc->T, sc->is_let_symbol)
+ s7_pointer p = car(args), slot;
+ 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? */
+ }
+ else
+ {
+ if (is_keyword(p)) return(p);
+ slot = s7_slot(sc, p);
+ }
+ if (is_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) */
+ wrong_type_error_nr(sc, sc->immutable_symbol, 2, cadr(args), a_let_string);
+ /* perhaps if safety on and p already immutable, warn about useless call? This for (immutable! sum) where caller meant (immutable! 'sum) */
+ set_immutable(p); /* could set_immutable save the current file/line? Then the immutable error checks for define-constant and this setting */
+ /* T_LOCATION -> T_IMMUTABLE_LOCATION but can't do this for a pair */
+ return(p);
+}
+
+/* there's no way to make a slot setter (as setter) immutable (t_multiform as bit) */
+
+
+/* -------------------------------- GC -------------------------------- */
+/* in most code, pairs, lets, and slots dominate the heap -- each about 25% to 40% of the
+ * total cell allocations. In snd-test, reals are 50%. slots need not be in the heap,
+ * but moving them out to their own free list was slower because we need (in that
+ * case) to manage them in the sweep process by tracking lets.
+ */
+
+#if S7_DEBUGGING
+static s7_int gc_protect_2(s7_scheme *sc, s7_pointer x, int32_t line)
+{
+ static bool already_warned = false;
+ s7_int loc = s7_gc_protect(sc, x);
+ if ((sc->safety > NO_SAFETY) && (!already_warned) && (loc > 8192))
+ {
+ 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);
+ if ((S7_DEBUGGING) && (sc->stop_at_error)) abort();
+ }
+ return(loc);
+}
+#define gc_protect_1(Sc, X) gc_protect_2(Sc, X, __LINE__)
+#else
+#define gc_protect_1(Sc, X) s7_gc_protect(Sc, X)
+#endif
+
+static void resize_gc_protect(s7_scheme *sc)
+{
+ s7_int size = sc->protected_objects_size;
+ block_t *ob = vector_block(sc->protected_objects);
+ s7_int new_size = 2 * size;
+ block_t *nb = reallocate(sc, ob, new_size * sizeof(s7_pointer));
+ block_info(nb) = NULL;
+ vector_block(sc->protected_objects) = nb;
+ vector_elements(sc->protected_objects) = (s7_pointer *)block_data(nb);
+ vector_length(sc->protected_objects) = new_size;
+ sc->protected_objects_size = new_size;
+ sc->protected_objects_free_list = (s7_int *)Realloc(sc->protected_objects_free_list, new_size * sizeof(s7_int));
+ for (s7_int i = size; i < new_size; i++)
+ {
+ vector_element(sc->protected_objects, i) = sc->unused;
+ sc->protected_objects_free_list[++sc->protected_objects_free_list_loc] = i;
+ }
+}
+
+s7_int s7_gc_protect(s7_scheme *sc, s7_pointer x)
+{
+ s7_int loc;
+ if (sc->protected_objects_free_list_loc < 0)
+ resize_gc_protect(sc);
+ loc = sc->protected_objects_free_list[sc->protected_objects_free_list_loc--];
+ vector_element(sc->protected_objects, loc) = x;
+ return(loc);
+}
+
+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;
+ else if (S7_DEBUGGING) fprintf(stderr, "redundant gc_unprotect_at location %" ld64 "\n", loc);
+ vector_element(sc->protected_objects, loc) = sc->unused;
+ }
+}
+
+s7_pointer s7_gc_protected_at(s7_scheme *sc, s7_int loc)
+{
+ s7_pointer obj = sc->unspecified;
+ if (loc < sc->protected_objects_size)
+ obj = vector_element(sc->protected_objects, loc);
+ if (obj == sc->unused)
+ return(sc->unspecified);
+ return(obj);
+}
+
+#define gc_protected_at(Sc, Loc) vector_element(Sc->protected_objects, Loc)
+
+s7_pointer s7_gc_protect_via_location(s7_scheme *sc, s7_pointer x, s7_int loc)
+{
+ vector_element(sc->protected_objects, loc) = x;
+ return(x);
+}
+
+s7_pointer s7_gc_unprotect_via_location(s7_scheme *sc, s7_int loc)
+{
+ vector_element(sc->protected_objects, loc) = sc->F;
+ return(sc->F);
+}
+
+
+/* these 3 are needed by sweep */
+static void (*mark_function[NUM_TYPES])(s7_pointer p);
+void s7_mark(s7_pointer p) {if (!is_marked(p)) (*mark_function[unchecked_type(p)])(p);}
+static void mark_noop(s7_pointer unused_p) {}
+
+static void process_iterator(s7_scheme *unused_sc, s7_pointer s1)
+{
+ if (is_weak_hash_iterator(s1))
+ {
+ s7_pointer h = iterator_sequence(s1);
+ clear_weak_hash_iterator(s1);
+ if (unchecked_type(h) == T_HASH_TABLE)
+ weak_hash_iters(h)--;
+ }
+}
+
+static void process_multivector(s7_scheme *sc, s7_pointer s1)
+{
+ vdims_t *info = vector_dimension_info(s1); /* a multidimensional empty vector can have dimension info, wrapped vectors always have dimension info */
+ if ((info) &&
+ (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;
+ }
+ liberate(sc, info);
+ vector_set_dimension_info(s1, NULL);
+ }
+ liberate(sc, vector_block(s1));
+}
+
+static void process_input_string_port(s7_scheme *sc, s7_pointer s1)
+{
+#if S7_DEBUGGING
+ /* this set of ports is a subset of the ports that respond true to is_string_port --
+ * the latter include file ports fully read into local memory; see read_file which uses add_input_port, not add_input_string_port
+ */
+ if (port_filename(s1))
+ fprintf(stderr, "string input port has a filename: %s\n", port_filename(s1));
+ if (port_needs_free(s1))
+ fprintf(stderr, "string input port needs data release\n");
+#endif
+ liberate(sc, port_block(s1));
+}
+
+static void free_port_data(s7_scheme *sc, s7_pointer s1)
+{
+ if (port_data(s1))
+ {
+ liberate(sc, port_data_block(s1));
+ port_data_block(s1) = NULL;
+ port_data(s1) = NULL;
+ port_data_size(s1) = 0;
+ }
+ port_needs_free(s1) = false;
+}
+
+static void close_input_function(s7_scheme *sc, s7_pointer p);
+
+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;
+ }}
+ else
+ if (is_function_port(s1))
+ close_input_function(sc, s1);
+ }
+ if (port_needs_free(s1))
+ free_port_data(sc, s1);
+
+ if (port_filename(s1))
+ {
+ liberate(sc, port_filename_block(s1));
+ port_filename(s1) = NULL;
+ }
+ liberate(sc, port_block(s1));
+}
+
+static void close_output_port(s7_scheme *sc, s7_pointer p);
+
+static void process_output_port(s7_scheme *sc, s7_pointer s1)
+{
+ close_output_port(sc, s1); /* needed for free filename, etc */
+ liberate(sc, port_block(s1));
+ if (port_needs_free(s1))
+ {
+ port_needs_free(s1) = false;
+ if (port_data_block(s1))
+ {
+ liberate(sc, port_data_block(s1));
+ port_data_block(s1) = NULL;
+ }}
+}
+
+static void process_continuation(s7_scheme *sc, s7_pointer s1)
+{
+ continuation_op_stack(s1) = NULL;
+ liberate_block(sc, continuation_block(s1)); /* from mallocate_block (s7_make_continuation) */
+}
+
+
+#if WITH_GMP
+#if ((__GNU_MP_VERSION < 6) || ((__GNU_MP_VERSION == 6) && (__GNU_MP_VERSION_MINOR == 0)))
+static int32_t mpq_cmp_z(const mpq_t op1, const mpz_t op2)
+{
+ mpq_t z1;
+ int32_t result;
+ mpq_init(z1);
+ mpq_set_z(z1, op2);
+ result = mpq_cmp(op1, z1);
+ mpq_clear(z1);
+ return(result);
+}
+#endif
+
+static s7_int big_integer_to_s7_int(s7_scheme *sc, mpz_t n);
+
+static s7_int s7_integer_clamped_if_gmp(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_integer(p))
+ return(integer(p));
+ if (is_t_big_integer(p))
+ return(big_integer_to_s7_int(sc, big_integer(p)));
+ return(0);
+}
+
+static void free_big_integer(s7_scheme *sc, s7_pointer p)
+{
+ big_integer_nxt(p) = sc->bigints;
+ sc->bigints = big_integer_bgi(p);
+ big_integer_bgi(p) = NULL;
+}
+
+static void free_big_ratio(s7_scheme *sc, s7_pointer p)
+{
+ big_ratio_nxt(p) = sc->bigrats;
+ sc->bigrats = big_ratio_bgr(p);
+ big_ratio_bgr(p) = NULL;
+}
+
+static void free_big_real(s7_scheme *sc, s7_pointer p)
+{
+ big_real_nxt(p) = sc->bigflts;
+ sc->bigflts = big_real_bgf(p);
+ big_real_bgf(p) = NULL;
+}
+
+static void free_big_complex(s7_scheme *sc, s7_pointer p)
+{
+ big_complex_nxt(p) = sc->bigcmps;
+ sc->bigcmps = big_complex_bgc(p);
+ big_complex_bgc(p) = NULL;
+}
+#else
+#define s7_integer_clamped_if_gmp(Sc, P) integer(P)
+#endif
+
+
+static void free_hash_table(s7_scheme *sc, s7_pointer table);
+static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym);
+static void cull_weak_hash_table(s7_scheme *sc, s7_pointer table);
+
+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; \
+ } \
+
+ gp = sc->strings;
+ process_gc_list(liberate(sc, string_block(s1)))
+
+ gp = sc->gensyms;
+ process_gc_list(remove_gensym_from_symbol_table(sc, s1); liberate(sc, gensym_block(s1)))
+ if (gp->loc == 0) mark_function[T_SYMBOL] = mark_noop;
+
+ gp = sc->undefineds;
+ process_gc_list(free(undefined_name(s1)))
+
+ gp = sc->c_objects;
+ process_gc_list((c_object_gc_free(sc, s1)) ? (void)(*(c_object_gc_free(sc, s1)))(sc, s1) : (void)(*(c_object_free(sc, s1)))(c_object_value(s1)))
+
+ gp = sc->vectors;
+ process_gc_list(liberate(sc, vector_block(s1)))
+
+ gp = sc->multivectors;
+ process_gc_list(process_multivector(sc, s1));
+
+ gp = sc->hash_tables;
+ 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;
+ }}
+ gp->loc = j;
+ }
+
+ gp = sc->weak_hash_iterators;
+ process_gc_list(process_iterator(sc, s1));
+
+ gp = sc->opt1_funcs;
+ 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;
+ }
+ gp->loc = j;
+ }
+
+ gp = sc->input_ports;
+ process_gc_list(process_input_port(sc, s1));
+
+ gp = sc->input_string_ports;
+ process_gc_list(process_input_string_port(sc, s1));
+
+ gp = sc->output_ports;
+ process_gc_list(process_output_port(sc, s1));
+
+ gp = sc->continuations;
+ process_gc_list(process_continuation(sc, s1));
+
+ gp = sc->weak_refs;
+ 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;
+ }}
+ gp->loc = j;
+ }
+
+#if WITH_GMP
+ gp = sc->big_integers;
+ process_gc_list(free_big_integer(sc, s1))
+
+ gp = sc->big_ratios;
+ process_gc_list(free_big_ratio(sc ,s1))
+
+ gp = sc->big_reals;
+ process_gc_list(free_big_real(sc, s1))
+
+ gp = sc->big_complexes;
+ process_gc_list(free_big_complex(sc, s1))
+
+ gp = sc->big_random_states;
+ process_gc_list(gmp_randclear(random_gmp_state(s1)))
+#endif
+}
+
+static /* inline */ void add_to_gc_list(gc_list_t *gp, s7_pointer p)
+{
+#if S7_DEBUGGING
+ if ((!in_heap(p)) && (gp != cur_sc->opt1_funcs))
+ {
+ char *s = describe_type_bits(cur_sc, p);
+ fprintf(stderr, "%s[%d]: %s not in heap, %s\n", __func__, __LINE__, display(p), s);
+ free(s);
+ if (cur_sc->stop_at_error) abort();
+ }
+#endif
+ if (gp->loc == gp->size)
+ {
+ gp->size *= 2;
+ gp->list = (s7_pointer *)Realloc(gp->list, gp->size * sizeof(s7_pointer));
+ }
+ gp->list[gp->loc++] = p;
+}
+
+static gc_list_t *make_gc_list(void)
+{
+ gc_list_t *gp = (gc_list_t *)Malloc(sizeof(gc_list_t));
+ #define INIT_GC_CACHE_SIZE 4
+ gp->size = INIT_GC_CACHE_SIZE;
+ gp->loc = 0;
+ gp->list = (s7_pointer *)Malloc(gp->size * sizeof(s7_pointer));
+ return(gp);
+}
+
+static void just_mark(s7_pointer p) {set_mark(p);}
+
+static void add_gensym(s7_scheme *sc, s7_pointer p)
+{
+ add_to_gc_list(sc->gensyms, p);
+ mark_function[T_SYMBOL] = just_mark;
+}
+
+#define add_c_object(sc, p) add_to_gc_list(sc->c_objects, p)
+#define add_hash_table(sc, p) add_to_gc_list(sc->hash_tables, p)
+#define add_string(sc, p) add_to_gc_list(sc->strings, p)
+#define add_input_port(sc, p) add_to_gc_list(sc->input_ports, p)
+#define add_input_string_port(sc, p) add_to_gc_list(sc->input_string_ports, p)
+#define add_output_port(sc, p) add_to_gc_list(sc->output_ports, p)
+#define add_continuation(sc, p) add_to_gc_list(sc->continuations, p)
+#define add_undefined(sc, p) add_to_gc_list(sc->undefineds, p)
+#define add_vector(sc, p) add_to_gc_list(sc->vectors, p)
+#define add_multivector(sc, p) add_to_gc_list(sc->multivectors, p)
+#define add_weak_ref(sc, p) add_to_gc_list(sc->weak_refs, p)
+#define add_weak_hash_iterator(sc, p) add_to_gc_list(sc->weak_hash_iterators, p)
+#define add_opt1_func(sc, p) do {if (!opt1_func_listed(p)) add_to_gc_list(sc->opt1_funcs, p); set_opt1_func_listed(p);} while (0)
+
+#if WITH_GMP
+#define add_big_integer(sc, p) add_to_gc_list(sc->big_integers, p)
+#define add_big_ratio(sc, p) add_to_gc_list(sc->big_ratios, p)
+#define add_big_real(sc, p) add_to_gc_list(sc->big_reals, p)
+#define add_big_complex(sc, p) add_to_gc_list(sc->big_complexes, p)
+#define add_big_random_state(sc, p) add_to_gc_list(sc->big_random_states, p)
+#endif
+
+static void init_gc_caches(s7_scheme *sc)
+{
+ sc->strings = make_gc_list();
+ sc->gensyms = make_gc_list();
+ sc->undefineds = make_gc_list();
+ sc->vectors = make_gc_list();
+ sc->multivectors = make_gc_list();
+ sc->hash_tables = make_gc_list();
+ sc->input_ports = make_gc_list();
+ sc->input_string_ports = make_gc_list();
+ sc->output_ports = make_gc_list();
+ sc->continuations = make_gc_list();
+ sc->c_objects = make_gc_list();
+ sc->weak_refs = make_gc_list();
+ sc->weak_hash_iterators = make_gc_list();
+ sc->opt1_funcs = make_gc_list();
+#if WITH_GMP
+ sc->big_integers = make_gc_list();
+ sc->big_ratios = make_gc_list();
+ sc->big_reals = make_gc_list();
+ sc->big_complexes = make_gc_list();
+ sc->big_random_states = make_gc_list();
+ sc->ratloc = NULL;
+#endif
+ /* slightly unrelated... */
+ sc->setters_size = 4;
+ sc->setters_loc = 0;
+ sc->setters = (s7_pointer *)Malloc(sc->setters_size * sizeof(s7_pointer));
+}
+
+static s7_pointer semipermanent_cons(s7_scheme *sc, s7_pointer a, s7_pointer b, uint64_t type);
+
+static void add_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter)
+{
+ /* setters GC-protected. The c_function_setter field can't be used because the built-in functions
+ * are often removed from the heap and never thereafter marked. Only closures and macros are protected here.
+ */
+ for (s7_int i = 0; i < sc->setters_loc; i++)
+ {
+ s7_pointer x = sc->setters[i];
+ if (car(x) == p)
+ {
+ unchecked_set_cdr(x, setter);
+ return;
+ }}
+ if (sc->setters_loc == sc->setters_size)
+ {
+ sc->setters_size *= 2;
+ sc->setters = (s7_pointer *)Realloc(sc->setters, sc->setters_size * sizeof(s7_pointer));
+ }
+ sc->setters[sc->setters_loc++] = semipermanent_cons(sc, p, setter, T_PAIR | T_IMMUTABLE);
+}
+
+
+static inline void gc_mark(s7_pointer p) {if (!is_marked(p)) (*mark_function[unchecked_type(p)])(p);}
+
+static void mark_symbol_vector(s7_pointer p, s7_int len)
+{
+ set_mark(p);
+ if (mark_function[T_SYMBOL] != mark_noop) /* else no gensyms */
+ {
+ 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]);
+ }
+}
+
+static void mark_simple_vector(s7_pointer p, s7_int len)
+{
+ s7_pointer *e = vector_elements(p);
+ set_mark(p);
+ for (s7_int i = 0; i < len; i++)
+ set_mark(e[i]);
+}
+
+static void just_mark_vector(s7_pointer p, s7_int unused_len) {set_mark(p);}
+
+static void mark_vector_1(s7_pointer p, s7_int top)
+{
+ s7_pointer *tp = (s7_pointer *)(vector_elements(p));
+ s7_pointer *tend, *tend4;
+ set_mark(p);
+ if (!tp) return;
+ tend = (s7_pointer *)(tp + top);
+ tend4 = (s7_pointer *)(tend - 16);
+ while (tp <= tend4) {LOOP_8(gc_mark(*tp++)); LOOP_8(gc_mark(*tp++));} /* faster if large vectors in use, maybe slower otherwise? */
+ while (tp < tend)
+ gc_mark(*tp++);
+}
+
+static void mark_typed_vector_1(s7_pointer p, s7_int top) /* for typed vectors with closure setters */
+{
+ gc_mark(typed_vector_typer(p));
+ mark_vector_1(p, top);
+}
+
+static inline void mark_slot(s7_pointer p)
+{
+ set_mark(T_Slt(p));
+ gc_mark(slot_value(p));
+ if (slot_has_setter_or_pending_value(p))
+ gc_mark(slot_pending_value_unchecked(p)); /* setter field == pending_value */
+ set_mark(slot_symbol(p));
+}
+
+static void mark_let(s7_pointer let)
+{
+ for (s7_pointer x = let; (x) && (!is_marked(x)); x = let_outlet(x))
+ {
+ set_mark(x);
+ if (has_dox_slot1(x)) mark_slot(let_dox_slot1(x));
+ 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 WITH_HISTORY
+static void gc_owlet_mark(s7_pointer tp)
+{
+ /* gc_mark but if tp is a pair ignore the marked bit on unheaped entries */
+ if (is_pair(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);
+ } 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);
+ }
+ else
+ if (!is_marked(tp))
+ (*mark_function[unchecked_type(tp)])(tp);
+}
+#endif
+
+static void mark_owlet(s7_scheme *sc)
+{
+#if WITH_HISTORY
+ {
+ 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 */
+ }}
+#endif
+ /* sc->error_type and friends are slots in owlet */
+ mark_slot(sc->error_type);
+ slot_set_value(sc->error_data, sc->F); /* or maybe mark_tree(slot_value(sc->error_data)) ? */
+ mark_slot(sc->error_data);
+ mark_slot(sc->error_code);
+ mark_slot(sc->error_line);
+ mark_slot(sc->error_file);
+ mark_slot(sc->error_position);
+#if WITH_HISTORY
+ mark_slot(sc->error_history);
+#endif
+ set_mark(sc->owlet);
+ mark_let(let_outlet(sc->owlet));
+}
+
+static void mark_c_pointer(s7_pointer p)
+{
+ set_mark(p);
+ gc_mark(c_pointer_type(p));
+ gc_mark(c_pointer_info(p));
+}
+
+static void mark_c_proc_star(s7_pointer p)
+{
+ set_mark(p);
+ if ((!c_func_has_simple_defaults(p)) &&
+ (c_function_call_args(p))) /* NULL if not a safe function */
+ for (s7_pointer arg = c_function_call_args(p); is_pair(arg); arg = cdr(arg))
+ gc_mark(car(arg));
+}
+
+static void mark_pair(s7_pointer p)
+{
+ do {
+ set_mark(p);
+ gc_mark(car(p)); /* expanding this to avoid recursion is slower */
+ p = cdr(p);
+ } while ((is_pair(p)) && (!is_marked(p))); /* ((full_type(p) & (TYPE_MASK | T_GC_MARK)) == T_PAIR) is much slower */
+ gc_mark(p);
+}
+
+static void mark_counter(s7_pointer p)
+{
+ set_mark(p);
+ gc_mark(counter_result(p));
+ gc_mark(counter_list(p));
+ gc_mark(counter_let(p));
+}
+
+static void mark_closure(s7_pointer p)
+{
+ set_mark(p);
+ gc_mark(closure_args(p));
+ gc_mark(closure_body(p));
+ mark_let(closure_let(p));
+ gc_mark(closure_setter_or_map_list(p));
+}
+
+static void mark_stack_1(s7_pointer p, s7_int top)
+{
+ s7_pointer *tp = (s7_pointer *)(stack_elements(p)), *tend;
+ set_mark(p);
+ if (!tp) return;
+ tend = (s7_pointer *)(tp + top);
+ while (tp < tend)
+ {
+ gc_mark(*tp++); /* sc->code */
+ gc_mark(*tp++); /* sc->curlet */
+ gc_mark(*tp++); /* sc->args */
+ tp++; /* sc->cur_op */
+ }
+}
+
+static void mark_stack(s7_pointer p)
+{
+ /* we can have a bare stack waiting for a continuation to hold it if the new_cell for the continuation triggers the GC! But we need a top-of-stack?? */
+ mark_stack_1(p, temp_stack_top(p));
+}
+
+static void mark_continuation(s7_pointer p)
+{
+ set_mark(p);
+ if (!is_marked(continuation_stack(p))) /* can these be cyclic? */
+ mark_stack_1(continuation_stack(p), continuation_stack_top(p));
+ gc_mark(continuation_op_stack(p));
+}
+
+static void mark_vector(s7_pointer p)
+{
+ if (is_typed_vector(p))
+ typed_vector_gc_mark(p)(p, vector_length(p));
+ else mark_vector_1(p, vector_length(p));
+}
+
+static void mark_vector_possibly_shared(s7_pointer p)
+{
+ /* If a subvector (an inner dimension) of a vector is the only remaining reference
+ * to the main vector, we want to make sure the main vector is not GC'd until
+ * the subvector is also GC-able. The subvector field either points to the
+ * parent vector, or it is sc->F, so we need to check for a vector parent if
+ * the current is multidimensional (this will include 1-dim slices). We need
+ * to keep the parent case separate (i.e. sc->F means the current is the original)
+ * so that we only free once (or remove_from_heap once).
+ *
+ * If we have a subvector of a subvector, and the middle and original are not otherwise
+ * in use, we mark the middle one, but (since it itself is not in use anywhere else)
+ * we don't mark the original! So we need to follow the share-vector chain marking every one.
+ *
+ * To remove a cell from the heap, we need its current heap location so that we can replace it.
+ * The heap is allocated as needed in monolithic blocks of (say) 1/2M s7_cells. When a cell
+ * is replaced, the new cell (at heap[x] say) is no longer from the original block. Since the
+ * GC clears all type bits when it frees a cell, we can't use a type bit to distinguish the
+ * replacements from the originals, but we need that info because in the base case, we use
+ * the distance of the cell from the base cell to get "x", its location. In the replacement
+ * case, we add the location at the end of the s7_cell (s7_big_cell). We track the current
+ * heap blocks via the sc->heap_blocks list. To get the location of "p" above, we run through
+ * that list looking for a block it fits in. If none is found, we assume it is an s7_big_cell
+ * and use the saved location.
+ */
+ if (is_subvector(p))
+ mark_vector_possibly_shared(subvector_vector(p));
+
+ /* mark_vector_1 does not check the marked bit, so if subvector below is in a cycle involving
+ * the calling vector, we get infinite recursion unless we check the mark bit here.
+ */
+ if (!is_marked(p))
+ mark_vector_1(p, vector_length(p));
+}
+
+static void mark_int_or_float_vector(s7_pointer p) {set_mark(p);}
+
+static void mark_int_or_float_vector_possibly_shared(s7_pointer p)
+{
+ if (is_subvector(p))
+ mark_int_or_float_vector_possibly_shared(subvector_vector(p));
+ set_mark(p);
+}
+
+static void mark_c_object(s7_pointer p)
+{
+ set_mark(p);
+ if (c_object_gc_mark(c_object_s7(p), p))
+ (*(c_object_gc_mark(c_object_s7(p), p)))(c_object_s7(p), p);
+ else (*(c_object_mark(c_object_s7(p), p)))(c_object_value(p));
+}
+
+static void mark_catch(s7_pointer p)
+{
+ set_mark(p);
+ gc_mark(catch_tag(p));
+ gc_mark(catch_handler(p));
+}
+
+static void mark_dynamic_wind(s7_pointer p)
+{
+ set_mark(p);
+ gc_mark(dynamic_wind_in(p));
+ gc_mark(dynamic_wind_out(p));
+ gc_mark(dynamic_wind_body(p));
+}
+
+static void mark_hash_table(s7_pointer p)
+{
+ set_mark(p);
+ gc_mark(hash_table_procedures(p));
+ if (is_pair(hash_table_procedures(p)))
+ {
+ gc_mark(hash_table_key_typer_unchecked(p)); /* unchecked to avoid s7-debugger's reference to sc */
+ gc_mark(hash_table_value_typer_unchecked(p));
+ }
+ 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)
+ {
+ 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));
+ }}}
+}
+
+static void mark_iterator(s7_pointer p)
+{
+ set_mark(p);
+ gc_mark(iterator_sequence(p));
+ if (is_mark_seq(p))
+ gc_mark(iterator_current(p));
+}
+
+static void mark_input_port(s7_pointer p)
+{
+ set_mark(p);
+ gc_mark(port_string_or_function(p));
+}
+
+static void mark_output_port(s7_pointer p)
+{
+ set_mark(p);
+ if (is_function_port(p))
+ gc_mark(port_string_or_function(p));
+}
+
+static void mark_free(s7_pointer p)
+{
+#if S7_DEBUGGING
+ /* this can happen in make_room_for_cc_stack */
+ /* fprintf(stderr, "%smark free: %p%s\n", bold_text, p, unbold_text); */
+ /* if (cur_sc->stop_at_error) abort(); */
+#endif
+}
+
+
+static void init_mark_functions(void)
+{
+ mark_function[T_FREE] = mark_free;
+ mark_function[T_UNDEFINED] = just_mark;
+ mark_function[T_EOF] = mark_noop;
+ mark_function[T_UNSPECIFIED] = mark_noop;
+ mark_function[T_NIL] = mark_noop;
+ mark_function[T_UNUSED] = mark_noop;
+ mark_function[T_BOOLEAN] = mark_noop;
+ mark_function[T_SYNTAX] = mark_noop;
+ mark_function[T_CHARACTER] = mark_noop;
+ mark_function[T_SYMBOL] = mark_noop; /* this changes to just_mark when gensyms are in the heap */
+ mark_function[T_STRING] = just_mark;
+ mark_function[T_INTEGER] = just_mark;
+ mark_function[T_RATIO] = just_mark;
+ mark_function[T_REAL] = just_mark;
+ mark_function[T_COMPLEX] = just_mark;
+ mark_function[T_BIG_INTEGER] = just_mark;
+ mark_function[T_BIG_RATIO] = just_mark;
+ mark_function[T_BIG_REAL] = just_mark;
+ mark_function[T_BIG_COMPLEX] = just_mark;
+ mark_function[T_RANDOM_STATE] = just_mark;
+ mark_function[T_GOTO] = just_mark;
+ mark_function[T_OUTPUT_PORT] = just_mark; /* changed to mark_output_port if output function ports are active */
+ mark_function[T_C_MACRO] = just_mark;
+ mark_function[T_C_POINTER] = mark_c_pointer;
+ mark_function[T_C_FUNCTION] = just_mark;
+ mark_function[T_C_FUNCTION_STAR] = just_mark; /* changes to mark_c_proc_star if defaults involve an expression */
+ mark_function[T_C_RST_NO_REQ_FUNCTION] = just_mark;
+ mark_function[T_PAIR] = mark_pair;
+ mark_function[T_CLOSURE] = mark_closure;
+ mark_function[T_CLOSURE_STAR] = mark_closure;
+ mark_function[T_CONTINUATION] = mark_continuation;
+ mark_function[T_INPUT_PORT] = mark_input_port;
+ mark_function[T_VECTOR] = mark_vector; /* this changes if subvector created (similarly below) */
+ mark_function[T_INT_VECTOR] = mark_int_or_float_vector;
+ mark_function[T_FLOAT_VECTOR] = mark_int_or_float_vector;
+ mark_function[T_BYTE_VECTOR] = just_mark;
+ mark_function[T_MACRO] = mark_closure;
+ mark_function[T_BACRO] = mark_closure;
+ mark_function[T_MACRO_STAR] = mark_closure;
+ mark_function[T_BACRO_STAR] = mark_closure;
+ mark_function[T_C_OBJECT] = mark_c_object;
+ mark_function[T_CATCH] = mark_catch;
+ mark_function[T_DYNAMIC_WIND] = mark_dynamic_wind;
+ mark_function[T_HASH_TABLE] = mark_hash_table;
+ mark_function[T_ITERATOR] = mark_iterator;
+ mark_function[T_LET] = mark_let;
+ mark_function[T_STACK] = mark_stack;
+ mark_function[T_COUNTER] = mark_counter;
+ mark_function[T_SLOT] = mark_slot;
+}
+
+static void mark_op_stack(s7_scheme *sc)
+{
+ s7_pointer *p = sc->op_stack;
+ s7_pointer *tp = sc->op_stack_now;
+ while (p < tp)
+ gc_mark(*p++);
+}
+
+static void mark_input_port_stack(s7_scheme *sc)
+{
+ s7_pointer *tp = (s7_pointer *)(sc->input_port_stack + sc->input_port_stack_loc);
+ for (s7_pointer *p = sc->input_port_stack; p < tp; p++)
+ gc_mark(*p);
+}
+
+static void mark_rootlet(s7_scheme *sc)
+{
+ for (s7_pointer y = sc->rootlet_slots; tis_slot(y); y = next_slot(y))
+ gc_mark(slot_value(y)); /* slot is semipermanent? does this assume slot_value is not rootlet? or that rootlet is marked? */
+ /* slot_setter is handled below with an explicit list -- more code than its worth probably */
+ /* we're not marking slot_symbol above which makes me worry that a top-level gensym won't be protected
+ * (apply define (gensym) '(32)), then try to get the GC to clobber {gensym}-0,
+ * but I can't get it to break, so they must be protected somehow; apparently they are
+ * removed from the heap! At least: (define-macro (defit) (let ((n (gensym))) `(define (,n) (format #t "fun")))) (defit)
+ * removes the function from the heap (protecting the gensym).
+ */
+}
+
+/* mark_closure calls mark_let on closure_let(func) which marks slot values.
+ * if we move rootlet to end, unmarked closures at that point could mark let/slot but not slot value?
+ * or save safe-closure lets to handle all at end? or a gc_list of safe closure lets and only mark let if not safe?
+ */
+
+static void mark_semipermanent_objects(s7_scheme *sc)
+{
+ for (gc_obj_t *g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt))
+ gc_mark(g->p);
+ /* semipermanent_objects also has lets (removed from heap) -- should they be handled like semipermanent_lets?
+ * if unmarked should either be removed from the list and perhaps placed on a free list?
+ * if outlet is free can the let potentially be in use?
+ * there are many more semipermanent_lets(slots) than semipermanent objects
+ */
+}
+/* do we mark funclet slot values from the function as root? Maybe treat them like semipermanent_lets here? */
+
+static void unmark_semipermanent_objects(s7_scheme *sc)
+{
+ gc_obj_t *g;
+ for (g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt))
+ clear_mark(g->p);
+ for (g = sc->semipermanent_lets; g; g = (gc_obj_t *)(g->nxt)) /* there are lets and slots in this list */
+ clear_mark(g->p);
+}
+
+#if (!MS_WINDOWS)
+ #include <time.h>
+ #include <sys/time.h>
+#endif
+
+#if WITH_GCC
+static __attribute__ ((format (printf, 3, 4))) void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...);
+#else
+static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...);
+#endif
+
+#if S7_DEBUGGING
+static int64_t gc(s7_scheme *sc, const char *func, int32_t line)
+#else
+static int64_t gc(s7_scheme *sc)
+#endif
+{
+ s7_cell **old_free_heap_top;
+ s7_int i;
+
+ if (sc->gc_in_progress)
+ error_nr(sc, sc->error_symbol, set_elist_1(sc, wrap_string(sc, "GC called recursively", 21)));
+ sc->gc_in_progress = true;
+ sc->gc_start = my_clock();
+ sc->gc_calls++;
+ sc->continuation_counter = 0;
+
+ mark_rootlet(sc);
+ mark_owlet(sc);
+
+ gc_mark(sc->code);
+ if ((S7_DEBUGGING) && (!(sc->args))) {fprintf(stderr, "%d: sc->args is NULL\n", __LINE__); if (sc->stop_at_error) abort();}
+ /* if (sc->args) */ gc_mark(sc->args);
+ gc_mark(sc->curlet); /* not mark_let because op_any_closure_3p uses sc->curlet as a temp!! */
+ mark_current_code(sc); /* probably redundant if with_history */
+ gc_mark(sc->value);
+
+ mark_stack_1(sc->stack, stack_top(sc));
+ set_mark(current_input_port(sc));
+ mark_input_port_stack(sc);
+ set_mark(current_output_port(sc));
+ set_mark(current_error_port(sc));
+ mark_pair(sc->stacktrace_defaults);
+ gc_mark(sc->autoload_table); /* () or a hash-table */
+ set_mark(sc->default_random_state); /* always a random_state object */
+ if ((S7_DEBUGGING) && (!(sc->let_temp_hook))) {fprintf(stderr, "%d: sc->let_temp_hook is NULL\n", __LINE__); if (sc->stop_at_error) abort();}
+ /* if (sc->let_temp_hook) */ gc_mark(sc->let_temp_hook);
+
+ gc_mark(sc->w);
+ gc_mark(sc->x);
+ gc_mark(sc->y);
+ gc_mark(sc->z);
+ gc_mark(sc->temp1);
+ gc_mark(sc->temp2);
+ gc_mark(sc->temp3);
+ gc_mark(sc->temp4);
+ gc_mark(sc->temp5);
+ gc_mark(sc->temp6);
+ gc_mark(sc->temp7);
+ gc_mark(sc->temp8);
+ gc_mark(sc->temp9);
+ gc_mark(sc->temp10);
+
+ gc_mark(car(sc->t1_1));
+ gc_mark(car(sc->t2_1)); gc_mark(car(sc->t2_2));
+ gc_mark(car(sc->t3_1)); gc_mark(car(sc->t3_2)); gc_mark(car(sc->t3_3));
+ gc_mark(car(sc->t4_1));
+ gc_mark(car(sc->mlist_1));
+ gc_mark(car(sc->mlist_2)); gc_mark(cadr(sc->mlist_2));
+ gc_mark(car(sc->plist_1));
+ gc_mark(car(sc->plist_2)); gc_mark(car(sc->plist_2_2));
+ gc_mark(car(sc->plist_3)); gc_mark(cadr(sc->plist_3)); gc_mark(caddr(sc->plist_3)); gc_mark(car(sc->plist_4));
+ gc_mark(car(sc->qlist_2)); gc_mark(cadr(sc->qlist_2));
+ gc_mark(car(sc->qlist_3));
+ gc_mark(car(sc->u1_1));
+
+ gc_mark(sc->rec_p1);
+ gc_mark(sc->rec_p2);
+
+ /* these do need to be marked, at least protecting "info" for the duration of the error handler procedure */
+ for (s7_pointer p = cdr(sc->wrong_type_arg_info); is_pair(p); p = cdr(p)) gc_mark(car(p));
+ for (s7_pointer p = cdr(sc->sole_arg_wrong_type_info); is_pair(p); p = cdr(p)) gc_mark(car(p));
+ for (s7_pointer p = cdr(sc->out_of_range_info); is_pair(p); p = cdr(p)) gc_mark(car(p));
+ for (s7_pointer p = cdr(sc->sole_arg_out_of_range_info); is_pair(p); p = cdr(p)) gc_mark(car(p));
+
+ gc_mark(car(sc->elist_1));
+ gc_mark(car(sc->elist_2)); gc_mark(cadr(sc->elist_2));
+ gc_mark(car(sc->elist_3)); gc_mark(cadr(sc->elist_3)); gc_mark(caddr(sc->elist_3));
+ gc_mark(car(sc->elist_4));
+ gc_mark(car(sc->elist_5));
+ gc_mark(car(sc->elist_6));
+ gc_mark(car(sc->elist_7));
+
+ 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 */
+ for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p))
+ gc_mark(car(p));
+
+ for (i = 0; i < sc->setters_loc; i++)
+ gc_mark(cdr(sc->setters[i]));
+
+ for (i = 0; i <= sc->format_depth; i++) /* sc->num_fdats is size of array */
+ if (sc->fdats[i])
+ gc_mark(sc->fdats[i]->curly_arg);
+
+ if (sc->rec_stack)
+ {
+ set_mark(sc->rec_stack);
+ for (i = 0; i < sc->rec_loc; i++)
+ gc_mark(sc->rec_els[i]);
+ }
+ mark_vector(sc->protected_objects);
+ mark_vector(sc->protected_setters);
+ set_mark(sc->protected_setter_symbols);
+ if ((is_symbol(sc->profile_prefix)) && (is_gensym(sc->profile_prefix))) set_mark(sc->profile_prefix);
+
+ /* protect recent allocations using the free_heap cells above the current free_heap_top (if any).
+ * cells above sc->free_heap_top might be malloc'd garbage (after heap reallocation), so we keep track of
+ * where the last actually freed cells were after the previous GC call. We're trying to
+ * GC protect the previous GC_TEMPS_SIZE allocated pointers so that the caller doesn't have
+ * to gc-protect every temporary cell.
+ */
+ {
+ s7_pointer *tmps = sc->free_heap_top;
+ s7_pointer *tmps_top = tmps + sc->gc_temps_size;
+ if (tmps_top > sc->previous_free_heap_top)
+ tmps_top = sc->previous_free_heap_top;
+ while (tmps < tmps_top)
+ gc_mark(*tmps++);
+ }
+ mark_op_stack(sc);
+ mark_semipermanent_objects(sc);
+
+ if (sc->profiling_gensyms)
+ {
+ 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]);
+ }
+
+ {
+ 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 */
+ }}
+
+ /* free up all unmarked objects */
+ old_free_heap_top = sc->free_heap_top;
+ {
+ s7_pointer *fp = sc->free_heap_top;
+ s7_pointer *tp = sc->heap;
+ 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; \
+ 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; \
+ } \
+ 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);
+ /* this appears to be about 10% faster than the previous form
+ * if the sign bit is on, but no other bits, this version will take no action (it thinks the cell is on the free list), but
+ * it means we've marked a free cell as in-use: since types are set as soon as removed from the free list, this has to be a bug
+ * (this case is caught by has_odd_bits). If ignored, the type will be set, and later the bit cleared, so no problem?
+ * An alternate form that simply calls clear_mark (no check for < 0) appears to be the same speed even in cases with lots
+ * of long-lived objects.
+ */
+#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));
+ }
+ /* 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.
+ * If NUM_THREADS=2, and all thread variables are local, surely there's no "false sharing"?
+ */
+ sc->free_heap_top = fp;
+ sweep(sc);
+ }
+
+ unmark_semipermanent_objects(sc);
+ sc->gc_freed = (int64_t)(sc->free_heap_top - old_free_heap_top);
+ sc->gc_total_freed += sc->gc_freed;
+ sc->gc_end = my_clock();
+ sc->gc_total_time += (sc->gc_end - sc->gc_start);
+
+ if (show_gc_stats(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());
+#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());
+#endif
+#else
+ s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 "\n", sc->gc_freed, sc->heap_size);
+#endif
+ }
+ if (show_protected_objects_stats(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++;
+ s7_warn(sc, 256, "gc-protected-objects: %" ld64 " in use of %" ld64 "\n", num, len);
+ }
+ sc->previous_free_heap_top = sc->free_heap_top;
+ sc->gc_in_progress = false;
+ return(sc->gc_freed);
+}
+
+
+#ifndef GC_RESIZE_HEAP_FRACTION
+ #define GC_RESIZE_HEAP_FRACTION 0.8
+/* 1/2 is ok, 3/4 speeds up some GC benchmarks, 7/8 is a bit faster, 95/100 comes to a halt (giant heap)
+ * in my tests, only tvect.scm ends up larger if 3/4 used
+ */
+#endif
+
+#define GC_RESIZE_HEAP_BY_4_FRACTION 0.67
+/* .5+.1: test -3?, dup +86, tmap +45, tsort -3, thash +305. .85+.7: dup -5 */
+
+#if S7_DEBUGGING
+#define resize_heap_to(Sc, Size) resize_heap_to_1(Sc, Size, __func__, __LINE__)
+static void resize_heap_to_1(s7_scheme *sc, int64_t size, const char *func, int line)
+#else
+static void resize_heap_to(s7_scheme *sc, int64_t size)
+#endif
+{
+ int64_t old_size = sc->heap_size;
+ int64_t old_free = sc->free_heap_top - sc->free_heap;
+ s7_cell *cells;
+ s7_cell **cp;
+ heap_block_t *hp;
+
+#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)));
+#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 */
+ else sc->heap_size *= 2;
+ if (sc->gc_resize_heap_fraction > .4)
+ sc->gc_resize_heap_fraction *= .95;
+ }
+ else
+ if (size > sc->heap_size)
+ while (sc->heap_size < size) sc->heap_size *= 2;
+ else return;
+ /* do not call new_cell here! */
+#if POINTER_32
+ 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 = old_size + 64000;
+ }
+#endif
+ cp = (s7_cell **)Realloc(sc->heap, sc->heap_size * sizeof(s7_cell *));
+ if (cp)
+ sc->heap = cp;
+ 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 *)));
+ sc->heap_size = old_size + 64000;
+ sc->heap = (s7_cell **)Realloc(sc->heap, sc->heap_size * sizeof(s7_cell *));
+ }
+ sc->free_heap = (s7_cell **)Realloc(sc->free_heap, sc->heap_size * sizeof(s7_cell *));
+ sc->free_heap_trigger = (s7_cell **)(sc->free_heap + GC_TRIGGER_SIZE);
+ sc->free_heap_top = sc->free_heap + old_free; /* incremented below, added old_free 21-Aug-12?!? */
+
+ cells = (s7_cell *)Calloc(sc->heap_size - old_size, sizeof(s7_cell)); /* Malloc + clear_type below is much slower?! */
+ add_saved_pointer(sc, (void *)cells);
+ {
+ 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++);
+ }}
+ hp = (heap_block_t *)Malloc(sizeof(heap_block_t));
+ hp->start = (intptr_t)cells;
+ hp->end = (intptr_t)cells + ((sc->heap_size - old_size) * sizeof(s7_cell));
+ hp->offset = old_size;
+ hp->next = sc->heap_blocks;
+ sc->heap_blocks = hp;
+ sc->previous_free_heap_top = sc->free_heap_top;
+
+ 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);
+ 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);
+ }
+ 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)));
+}
+
+
+#define resize_heap(Sc) resize_heap_to(Sc, 0)
+
+#if S7_DEBUGGING
+#define call_gc(Sc) gc(Sc, __func__, __LINE__)
+static void try_to_call_gc_1(s7_scheme *sc, const char *func, int32_t line)
+#else
+#define call_gc(Sc) gc(Sc)
+static void try_to_call_gc(s7_scheme *sc)
+#endif
+{
+ /* called only from new_cell */
+ if (sc->gc_off) /* we can't just return here! Someone needs a new cell, and once the heap free list is exhausted, segfault */
+ resize_heap(sc);
+ else
+ {
+ if ((sc->gc_resize_heap_fraction > 0.5) && (sc->heap_size >= 4194304))
+ 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);
+ }
+}
+ /* originally I tried to mark each temporary value until I was done with it, but that way madness lies... By delaying
+ * GC of _every_ %$^#%@ pointer, I can dispense with hundreds of individual protections. So the free_heap's last
+ * GC_TEMPS_SIZE allocated pointers are protected during the mark sweep.
+ */
+
+static s7_pointer g_gc(s7_scheme *sc, s7_pointer args)
+{
+ #define H_gc "(gc (on #t)) runs the garbage collector. If 'on' (a boolean) is supplied, it turns the GC on or off. \
+Evaluation produces a surprising amount of garbage, so don't leave the GC off for very long!"
+ #define Q_gc s7_make_signature(sc, 2, sc->T, sc->is_boolean_symbol)
+
+ /* g_gc can't be called in a situation where these lists matter -- oops, gc called in scheme can be using these! and maybe elist... */
+#if 0
+ set_mlist_1(sc, sc->unused);
+ set_mlist_2(sc, sc->unused, sc->unused);
+ set_plist_1(sc, sc->unused);
+ set_plist_2(sc, sc->unused, sc->unused);
+ set_plist_3(sc, sc->unused, sc->unused, sc->unused);
+ set_car(sc->plist_4, sc->unused);
+ set_qlist_2(sc, sc->unused, sc->unused);
+ set_car(sc->qlist_3, sc->unused);
+ set_ulist_1(sc, sc->unused, sc->unused);
+#endif
+ set_elist_1(sc, sc->unused);
+ set_elist_2(sc, sc->unused, sc->unused);
+ set_elist_3(sc, sc->unused, sc->unused, sc->unused);
+ set_car(sc->elist_4, sc->unused);
+ set_car(sc->elist_5, sc->unused);
+ set_car(sc->elist_6, sc->unused);
+ set_car(sc->elist_7, sc->unused); /* clist and dlist are weak references */
+ 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]));
+ sc->gc_off = (car(args) == sc->F);
+ if (sc->gc_off)
+ return(sc->F);
+ }
+ call_gc(sc);
+ return(sc->unspecified);
+}
+
+s7_pointer s7_gc_on(s7_scheme *sc, bool on)
+{
+ sc->gc_off = !on;
+ return(make_boolean(sc, on));
+}
+
+#if S7_DEBUGGING
+static void check_free_heap_size_1(s7_scheme *sc, s7_int size, const char *func, int32_t line)
+#define check_free_heap_size(Sc, Size) check_free_heap_size_1(Sc, Size, __func__, __LINE__)
+#else
+static void check_free_heap_size(s7_scheme *sc, s7_int size)
+#endif
+{
+ s7_int free_cells = sc->free_heap_top - sc->free_heap;
+ if (free_cells < size)
+ {
+#if S7_DEBUGGING
+ gc(sc, func, line);
+#else
+ gc(sc);
+#endif
+ while ((sc->free_heap_top - sc->free_heap) < (s7_int)(size * 1.5))
+ resize_heap(sc);
+ }
+}
+
+#define ALLOC_POINTER_SIZE 256
+static s7_cell *alloc_pointer(s7_scheme *sc)
+{
+ if (sc->alloc_pointer_k == ALLOC_POINTER_SIZE) /* if either no current block or the block is used up, make a new block */
+ {
+ sc->semipermanent_cells += ALLOC_POINTER_SIZE;
+ sc->alloc_pointer_cells = (s7_cell *)Calloc(ALLOC_POINTER_SIZE, sizeof(s7_cell)); /* not Malloc here or below (maybe set full type to 0 if Malloc) */
+ add_saved_pointer(sc, sc->alloc_pointer_cells);
+ sc->alloc_pointer_k = 0;
+ }
+ return(&(sc->alloc_pointer_cells[sc->alloc_pointer_k++]));
+}
+
+#define ALLOC_BIG_POINTER_SIZE 256
+static s7_big_cell *alloc_big_pointer(s7_scheme *sc, int64_t loc)
+{
+ s7_big_pointer p;
+ if (sc->alloc_big_pointer_k == ALLOC_BIG_POINTER_SIZE)
+ {
+ sc->semipermanent_cells += ALLOC_BIG_POINTER_SIZE;
+ sc->alloc_big_pointer_cells = (s7_big_cell *)Calloc(ALLOC_BIG_POINTER_SIZE, sizeof(s7_big_cell));
+ add_saved_pointer(sc, sc->alloc_big_pointer_cells);
+ sc->alloc_big_pointer_k = 0;
+ }
+ p = (&(sc->alloc_big_pointer_cells[sc->alloc_big_pointer_k++]));
+ p->big_hloc = loc;
+ /* needed if this new pointer is itself petrified later -- it's not from one of the heap blocks,
+ * but it's in the heap, and we'll need to know where it is in the heap to replace it
+ */
+ return(p);
+}
+
+static void add_semipermanent_object(s7_scheme *sc, s7_pointer obj) /* called by remove_from_heap */
+{
+ gc_obj_t *g = (gc_obj_t *)Malloc(sizeof(gc_obj_t));
+ g->p = obj;
+ g->nxt = sc->semipermanent_objects;
+ sc->semipermanent_objects = g;
+}
+
+static void add_semipermanent_let_or_slot(s7_scheme *sc, s7_pointer obj)
+{
+ gc_obj_t *g = (gc_obj_t *)Malloc(sizeof(gc_obj_t));
+ g->p = obj;
+ g->nxt = sc->semipermanent_lets;
+ sc->semipermanent_lets = g;
+}
+
+#if S7_DEBUGGING
+static const char *type_name_from_type(int32_t typ, article_t article);
+
+#define free_cell(Sc, P) free_cell_1(Sc, P, __LINE__)
+static void free_cell_1(s7_scheme *sc, s7_pointer p, int32_t line)
+#else
+static void free_cell(s7_scheme *sc, s7_pointer p)
+#endif
+{ /* this can make a big difference: 474 in snd-test! */
+#if S7_DEBUGGING
+ /* anything that needs gc_list attention should not be freed here */
+ uint8_t typ = unchecked_type(p);
+ gc_list_t *gp = sc->opt1_funcs;
+
+ if ((t_freeze_p[typ]) || ((typ == T_SYMBOL) && (is_gensym(p))))
+ fprintf(stderr, "free_cell of %s?\n", type_name_from_type(typ, NO_ARTICLE));
+ 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));
+ 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));
+
+ p->debugger_bits = 0;
+ p->explicit_free_line = line;
+#endif
+ clear_type(p);
+ (*(sc->free_heap_top++)) = p;
+}
+
+static inline s7_pointer petrify(s7_scheme *sc, s7_pointer x)
+{
+ int64_t loc = heap_location(sc, x);
+ s7_pointer p = (s7_pointer)alloc_big_pointer(sc, loc);
+ sc->heap[loc] = p;
+ free_cell(sc, p);
+ unheap(sc, x); /* set_immutable(x); */ /* if there are GC troubles, this might catch them? */
+ return(x);
+}
+
+#if S7_DEBUGGING
+#define remove_gensym_from_heap(Sc, Gensym) remove_gensym_from_heap_1(Sc, Gensym, __func__, __LINE__)
+static void remove_gensym_from_heap_1(s7_scheme *sc, s7_pointer x, const char *func, int line)
+#else
+static void remove_gensym_from_heap(s7_scheme *sc, s7_pointer x) /* x known to be a symbol and in the heap */
+#endif
+{
+ int64_t loc = heap_location(sc, x);
+ sc->heap[loc] = (s7_pointer)alloc_big_pointer(sc, loc);
+ free_cell(sc, sc->heap[loc]);
+#if S7_DEBUGGING
+ x->gc_func = func; /* main culprit in s7test/t725 is (essentially) (symbol->keyword (gensym)) */
+ x->gc_line = line;
+#endif
+ unheap(sc, x); /* set UNHEAP bit in type(x) */
+ {
+ 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;
+ }}
+}
+
+static inline void remove_from_heap(s7_scheme *sc, s7_pointer x)
+{
+ /* global functions are very rarely redefined, so we can remove the function body from the heap when it is defined */
+ if (!in_heap(x)) return;
+ if (is_pair(x)) /* all the compute time is here, might be faster to go down a level explicitly */
+ {
+ s7_pointer p = x;
+ do {
+ 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;
+ }
+ switch (type(x))
+ {
+ case T_LET: /* very rare */
+ if (is_funclet(x)) set_immutable_let(x);
+ case T_HASH_TABLE:
+ case T_VECTOR:
+ /* not int|float_vector or string because none of their elements are GC-able (so unheap below is ok)
+ * but hash-table and let seem like they need protection? And let does happen via define-class.
+ */
+ add_semipermanent_object(sc, x);
+ return;
+ case T_SYMBOL:
+ if (is_gensym(x))
+ remove_gensym_from_heap(sc, x);
+ return;
+ case T_CLOSURE: case T_CLOSURE_STAR:
+ case T_MACRO: case T_MACRO_STAR:
+ case T_BACRO: case T_BACRO_STAR:
+ /* these need to be GC-protected! */
+ add_semipermanent_object(sc, x);
+ return;
+ default: break;
+ }
+ petrify(sc, x);
+}
+
+
+/* -------------------------------- stacks -------------------------------- */
+
+/* -------- op stack -------- */
+#define OP_STACK_INITIAL_SIZE 64
+
+#define op_stack_entry(Sc) (*(Sc->op_stack_now - 1))
+
+#if S7_DEBUGGING
+static void push_op_stack(s7_scheme *sc, s7_pointer op)
+{
+ (*sc->op_stack_now++) = T_Ext(op); /* not T_App etc -- args can be pushed */
+ if (sc->op_stack_now > (sc->op_stack + sc->op_stack_size))
+ {
+ fprintf(stderr, "%sop_stack overflow%s\n", bold_text, unbold_text);
+ if (sc->stop_at_error) abort();
+ }
+}
+
+static s7_pointer pop_op_stack(s7_scheme *sc)
+{
+ s7_pointer op = T_Ext(*(--(sc->op_stack_now)));
+ if (sc->op_stack_now < sc->op_stack)
+ {
+ fprintf(stderr, "%sop_stack underflow%s\n", bold_text, unbold_text);
+ if (sc->stop_at_error) abort();
+ }
+ return(T_Ext(op));
+}
+#else
+#define push_op_stack(Sc, Op) (*Sc->op_stack_now++) = Op
+#define pop_op_stack(Sc) (*(--(Sc->op_stack_now)))
+#endif
+
+static void initialize_op_stack(s7_scheme *sc)
+{
+ sc->op_stack = (s7_pointer *)Malloc(OP_STACK_INITIAL_SIZE * sizeof(s7_pointer));
+ sc->op_stack_size = OP_STACK_INITIAL_SIZE;
+ sc->op_stack_now = sc->op_stack;
+ sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size);
+ for (int32_t i = 0; i < OP_STACK_INITIAL_SIZE; i++) sc->op_stack[i] = sc->unused;
+}
+
+static void resize_op_stack(s7_scheme *sc)
+{
+ int32_t new_size = sc->op_stack_size * 2;
+ int32_t loc = (int32_t)(sc->op_stack_now - sc->op_stack);
+ sc->op_stack = (s7_pointer *)Realloc((void *)(sc->op_stack), new_size * sizeof(s7_pointer));
+ for (int32_t i = sc->op_stack_size; i < new_size; i++) sc->op_stack[i] = sc->unused;
+ sc->op_stack_size = (uint32_t)new_size;
+ sc->op_stack_now = (s7_pointer *)(sc->op_stack + loc);
+ sc->op_stack_end = (s7_pointer *)(sc->op_stack + sc->op_stack_size);
+}
+
+
+/* -------- main stack -------- */
+/* stack_top_code changes. If a function has a tail-call, the stack_top_code that form sees
+ * if stack_top_op==op-begin1 can change from call to call -- the begin actually refers
+ * to the caller, which is dependent on where the current function was called, so we can't hard-wire
+ * any optimizations based on that sequence.
+ */
+
+#define stack_op(Stack, Loc) ((opcode_t)T_Op(stack_element(Stack, Loc)))
+#define stack_args(Stack, Loc) stack_element(Stack, Loc - 1)
+#define stack_let(Stack, Loc) stack_element(Stack, Loc - 2)
+#define stack_code(Stack, Loc) stack_element(Stack, Loc - 3)
+#define set_stack_op(Stack, Loc, Op) stack_element(Stack, Loc) = (s7_pointer)(opcode_t)(Op)
+
+#define stack_top_op(Sc) ((opcode_t)T_Op(Sc->stack_end[-1]))
+#define unchecked_stack_top_op(Sc) ((opcode_t)(Sc->stack_end[-1]))
+#define stack_top_args(Sc) (Sc->stack_end[-2])
+#define stack_top_let(Sc) (Sc->stack_end[-3])
+#define stack_top_code(Sc) (Sc->stack_end[-4])
+#define set_stack_top_op(Sc, Op) Sc->stack_end[-1] = (s7_pointer)(opcode_t)(Op)
+#define set_stack_top_args(Sc, Args) Sc->stack_end[-2] = Args
+#define set_stack_top_code(Sc, Code) Sc->stack_end[-4] = Code
+
+#define stack_end_code(Sc) Sc->stack_end[0]
+#define stack_end_let(Sc) Sc->stack_end[1]
+#define stack_end_args(Sc) Sc->stack_end[2]
+#define stack_end_op(Sc) Sc->stack_end[3]
+
+void s7_show_stack(s7_scheme *sc);
+
+#if S7_DEBUGGING
+#define pop_stack(Sc) pop_stack_1(Sc, __func__, __LINE__)
+static void pop_stack_1(s7_scheme *sc, const char *func, int32_t line)
+{
+ sc->stack_end -= 4;
+ if (sc->stack_end < sc->stack_start)
+ {
+ fprintf(stderr, "%s%s[%d]: stack underflow%s\n", bold_text, func, line, unbold_text);
+ if (sc->stop_at_error) abort();
+ }
+ /* here and in push_stack, both code and args might be non-free only because they've been retyped
+ * inline (as in named let) -- they actually don't make sense in these cases, but are ignored,
+ * and are carried around as GC protection in other cases.
+ */
+ sc->code = T_Pos(stack_end_code(sc));
+ sc->curlet = stack_end_let(sc); /* not T_Let|Pos, see op_any_closure_3p_end et al (stack used to pass args, not curlet) */
+ sc->args = stack_end_args(sc);
+ sc->cur_op = (opcode_t)T_Op(stack_end_op(sc));
+ if ((sc->cur_op != OP_GC_PROTECT) &&
+ (!is_let(stack_end_let(sc))) && (!is_null(stack_end_let(sc))) &&
+ (sc->cur_op != OP_ANY_CLOSURE_3P_3)) /* used as third GC protection field */
+ fprintf(stderr, "%s[%d]: curlet not a let: %s\n", func, line, op_names[sc->cur_op]);
+}
+
+#define pop_stack_no_op(Sc) pop_stack_no_op_1(Sc, __func__, __LINE__)
+static void pop_stack_no_op_1(s7_scheme *sc, const char *func, int32_t line)
+{
+ sc->stack_end -= 4;
+ if (sc->stack_end < sc->stack_start)
+ {
+ fprintf(stderr, "%s%s[%d]: stack underflow%s\n", bold_text, func, line, unbold_text);
+ if (sc->stop_at_error) abort();
+ }
+ sc->code = T_Pos(stack_end_code(sc));
+ if ((sc->cur_op != OP_GC_PROTECT) && (!is_let(stack_end_let(sc))))
+ fprintf(stderr, "%s[%d]: curlet not a let\n", func, line);
+ sc->curlet = stack_end_let(sc); /* not T_Let|Pos: gc_protect can set this directly (not through push_stack) to anything */
+ sc->args = stack_end_args(sc);
+}
+
+static void push_stack_1(s7_scheme *sc, opcode_t op, s7_pointer args, s7_pointer code, s7_pointer *end, const char *func, int32_t line)
+{
+ if ((SHOW_EVAL_OPS) && (op == OP_EVAL_DONE)) fprintf(stderr, " %s[%d]: push eval_done\n", func, line);
+ 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);
+ 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);
+ if (sc->stack_end != end)
+ fprintf(stderr, "%s[%d]: stack changed in push_stack\n", func, line);
+ if (op >= NUM_OPS)
+ {
+ fprintf(stderr, "%s%s[%d]: push_stack invalid opcode: %" p64 " %s\n", bold_text, func, line, sc->cur_op, unbold_text);
+ if (sc->stop_at_error) abort();
+ }
+ if (code) stack_end_code(sc) = T_Pos(code);
+ stack_end_let(sc) = T_Let(sc->curlet);
+ if ((args) && (unchecked_type(args) != T_FREE)) stack_end_args(sc) = T_Pos(args);
+ stack_end_op(sc) = (s7_pointer)op;
+ sc->stack_end += 4;
+}
+
+#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)
+#define push_stack_no_let_no_code(Sc, Op, Args) push_stack(Sc, Op, Args, Sc->unused)
+#define push_stack_no_args(Sc, Op, Code) push_stack(Sc, Op, Sc->unused, Code)
+#define push_stack_no_let(Sc, Op, Args, Code) push_stack(Sc, Op, Args, Code)
+#define push_stack_op(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->unused)
+#define push_stack_op_let(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->unused)
+#define push_stack_direct(Sc, Op) push_stack(Sc, Op, Sc->args, Sc->code)
+#define push_stack_no_args_direct(Sc, Op) push_stack(Sc, Op, Sc->unused, Sc->code)
+/* in the non-debugging case, the sc->unused's here are not set, so we can (later) pop free cells */
+
+#else
+
+#define pop_stack(Sc) do {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 4 * sizeof(s7_pointer));} while (0)
+#define pop_stack_no_op(Sc) {Sc->stack_end -= 4; memcpy((void *)Sc, (void *)(Sc->stack_end), 3 * sizeof(s7_pointer));} while (0)
+
+#define push_stack(Sc, Op, Args, Code) \
+ do { \
+ stack_end_code(sc) = Code; \
+ stack_end_let(sc) = Sc->curlet; \
+ stack_end_args(sc) = Args; \
+ stack_end_op(sc) = (s7_pointer)(opcode_t)(Op); \
+ Sc->stack_end += 4; \
+ } while (0)
+
+#define push_stack_direct(Sc, Op) \
+ do { \
+ Sc->cur_op = Op; \
+ memcpy((void *)(Sc->stack_end), (void *)Sc, 4 * sizeof(s7_pointer)); \
+ /* stack_end_op(sc) = (s7_pointer)(opcode_t)(Op); */ \
+ Sc->stack_end += 4; \
+ } while (0)
+/* is this faster with cur_op because of the cast to s7_pointer, or is callgrind messing up memcpy stats?
+ * time's output is all over the map. I think the cur_op form should be slower, but callgrind disagrees.
+ */
+
+#define push_stack_no_code(Sc, Op, Args) \
+ do { \
+ stack_end_let(sc) = Sc->curlet; \
+ stack_end_args(sc) = Args; \
+ stack_end_op(sc) = (s7_pointer)(opcode_t)(Op); \
+ Sc->stack_end += 4; \
+ } while (0)
+
+#define push_stack_no_let_no_code(Sc, Op, Args) \
+ do { \
+ stack_end_args(sc) = Args; \
+ stack_end_op(sc) = (s7_pointer)(opcode_t)(Op); \
+ Sc->stack_end += 4; \
+ } while (0)
+
+#define push_stack_no_args(Sc, Op, Code) \
+ do { \
+ stack_end_code(sc) = Code; \
+ stack_end_let(sc) = Sc->curlet; \
+ stack_end_op(sc) = (s7_pointer)(opcode_t)(Op); \
+ Sc->stack_end += 4; \
+ } while (0)
+
+#define push_stack_no_args_direct(Sc, Op) \
+ do { \
+ 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)
+
+#define push_stack_no_let(Sc, Op, Args, Code) \
+ do { \
+ stack_end_code(sc) = Code; \
+ stack_end_args(sc) = Args; \
+ stack_end_op(sc) = (s7_pointer)(opcode_t)(Op); \
+ Sc->stack_end += 4; \
+ } while (0)
+
+#define push_stack_op(Sc, Op) \
+ do { \
+ stack_end_op(sc) = (s7_pointer)(opcode_t)(Op); \
+ Sc->stack_end += 4; \
+ } while (0)
+
+#define push_stack_op_let(Sc, Op) \
+ do { \
+ stack_end_let(sc) = Sc->curlet; \
+ stack_end_op(sc) = (s7_pointer)(opcode_t)(Op); \
+ Sc->stack_end += 4; \
+ } while (0)
+#endif
+/* since we don't GC mark the stack past the stack_top, push_stack_no_args and friends can cause pop_stack to set
+ * sc->code and sc->args to currently free objects.
+ */
+
+#if S7_DEBUGGING
+#define unstack_with(Sc, Op) unstack_1(Sc, Op, __func__, __LINE__)
+static void unstack_1(s7_scheme *sc, opcode_t op, const char *func, int32_t line)
+{
+ sc->stack_end -= 4;
+ if ((opcode_t)T_Op(stack_end_op(sc)) != op)
+ {
+ fprintf(stderr, "%s%s[%d]: popped %s? (expected %s)%s\n", bold_text, func, line, op_names[(opcode_t)T_Op(stack_end_op(sc))], op_names[op], unbold_text);
+ /* "popped apply" means we called something that went to eval+apply when we thought it was a safe function */
+ fprintf(stderr, " code: %s\n args: %s\n", display(sc->code), display(sc->args));
+ fprintf(stderr, " cur_code: %s\n estr: %s\n", display(current_code(sc)), display(s7_name_to_value(sc, "estr")));
+ s7_show_stack(sc);
+ if (sc->stop_at_error) abort();
+ }
+}
+#define unstack_gc_protect(Sc) unstack_with(Sc, OP_GC_PROTECT)
+#else
+#define unstack_gc_protect(Sc) Sc->stack_end -= 4
+#define unstack_with(Sc, op) Sc->stack_end -= 4
+#endif
+
+static void stack_reset(s7_scheme *sc)
+{
+ sc->stack_end = sc->stack_start;
+ push_stack_op(sc, OP_EVAL_DONE);
+}
+
+static uint32_t resize_stack_unchecked(s7_scheme *sc)
+{
+ uint64_t loc = stack_top(sc);
+ uint32_t new_size = sc->stack_size * 2;
+ block_t *ob = stack_block(sc->stack);
+ block_t *nb = reallocate(sc, ob, new_size * sizeof(s7_pointer));
+ block_info(nb) = NULL;
+ stack_block(sc->stack) = nb;
+ /* if (block_index(nb) == TOP_BLOCK_LIST) fprintf(stderr, "top %u\n", new_size); */
+ stack_elements(sc->stack) = (s7_pointer *)block_data(nb);
+ {
+ s7_pointer *orig = stack_elements(sc->stack);
+ s7_int i = sc->stack_size;
+ s7_int left = new_size - i - 8;
+ while (i <= left)
+ LOOP_8(orig[i++] = sc->unused);
+ for (; i < new_size; i++)
+ orig[i] = sc->unused;
+ }
+ vector_length(sc->stack) = new_size;
+ sc->stack_size = new_size;
+ sc->stack_start = stack_elements(sc->stack);
+ sc->stack_end = (s7_pointer *)(sc->stack_start + loc);
+ sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (new_size - STACK_RESIZE_TRIGGER));
+ return(new_size);
+}
+
+void s7_show_stack(s7_scheme *sc)
+{
+ if (sc->stack_end >= sc->stack_resize_trigger)
+ resize_stack_unchecked(sc);
+ fprintf(stderr, "stack:\n");
+ for (s7_int i = stack_top(sc) - 1, j = 0; (i >= 3) && (j < sc->show_stack_limit); i -= 4, j++) /* s7_int (or uint64_t?) is correct -- not uint32_t */
+ fprintf(stderr, " %s\n", op_names[stack_op(sc->stack, i)]);
+}
+
+#if S7_DEBUGGING
+#define resize_stack(Sc) resize_stack_1(Sc, __func__, __LINE__)
+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);
+ s7_show_stack(sc);
+ if (sc->stop_at_error) abort();
+ }
+ resize_stack_unchecked(sc);
+}
+#else
+static void resize_stack(s7_scheme *sc)
+{
+ uint32_t new_size = resize_stack_unchecked(sc);
+ if (show_stack_stats(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)));
+ /* error needs to follow realloc, else error -> catchers in error_nr -> let_temp* -> eval_done -> stack_resize -> infinite loop */
+}
+#endif
+
+#define check_stack_size(Sc) do {if (Sc->stack_end >= Sc->stack_resize_trigger) resize_stack(Sc);} while (0)
+
+s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x)
+{
+ check_stack_size(sc); /* this can be called externally, so we need to be careful about this */
+ push_stack_no_code(sc, OP_GC_PROTECT, x);
+ return(x);
+}
+
+s7_pointer s7_gc_protect_2_via_stack(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ check_stack_size(sc);
+ push_stack(sc, OP_GC_PROTECT, x, y);
+ return(x);
+}
+
+s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x)
+{
+ unstack_gc_protect(sc); /* this might not be related to 'x' -- something got unprotected */
+ return(x);
+}
+
+#define stack_protected1(Sc) stack_top_args(Sc) /* it's easier to remember these aliases in this context (GC protection so code/args business is irrelevant) */
+#define stack_protected2(Sc) stack_top_code(Sc)
+#define stack_protected3(Sc) stack_top_let(Sc)
+
+#if S7_DEBUGGING
+ #define set_stack_protected1(Sc, Val) do {if (stack_top_op(Sc) != OP_GC_PROTECT) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_protected1(Sc) = Val;} while (0)
+ #define set_stack_protected2(Sc, Val) do {if (stack_top_op(Sc) != OP_GC_PROTECT) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_protected2(Sc) = Val;} while (0)
+ #define set_stack_protected3(Sc, Val) do {if (stack_top_op(Sc) != OP_GC_PROTECT) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_protected3(Sc) = Val;} while (0)
+
+ #define set_stack_protected1_with(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_protected1(Sc) = Val;} while (0)
+ #define set_stack_protected2_with(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_protected2(Sc) = Val;} while (0)
+ #define set_stack_protected3_with(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: stack_protected %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_protected3(Sc) = Val;} while (0)
+#else
+ #define set_stack_protected1(Sc, Val) stack_protected1(Sc) = Val
+ #define set_stack_protected2(Sc, Val) stack_protected2(Sc) = Val
+ #define set_stack_protected3(Sc, Val) stack_protected3(Sc) = Val
+
+ #define set_stack_protected1_with(Sc, Val, Op) stack_protected1(Sc) = Val
+ #define set_stack_protected2_with(Sc, Val, Op) stack_protected2(Sc) = Val
+ #define set_stack_protected3_with(Sc, Val, Op) stack_protected3(Sc) = Val
+#endif
+
+#define gc_protect_via_stack(Sc, Obj) push_stack_no_code(Sc, OP_GC_PROTECT, Obj)
+#define gc_protect_via_stack_no_let(Sc, Obj) push_stack_no_let_no_code(Sc, OP_GC_PROTECT, Obj)
+#define gc_protect_2_via_stack(Sc, X, Y) do {gc_protect_via_stack(Sc, X); set_stack_protected2(Sc, Y);} while (0) /* often X and Y are fx_calls, so push X, then set Y */
+#define gc_protect_2_via_stack_no_let(Sc, X, Y) do {push_stack_no_let_no_code(Sc, OP_GC_PROTECT, X); set_stack_protected2(Sc, Y);} while (0)
+
+
+/* -------------------------------- symbols -------------------------------- */
+static inline uint64_t raw_string_hash(const uint8_t *key, s7_int len) /* used in symbols, hash-tables */
+{
+ if (len <= 8)
+ {
+ uint64_t xs[1] = {0};
+ memcpy((void *)xs, (const void *)key, len);
+ return(xs[0]);
+ }
+ else
+ {
+ uint64_t xs[2] = {0, 0};
+ memcpy((void *)xs, (const void *)key, (len > 16) ? 16 : len); /* compiler complaint here is bogus */
+ return(xs[0] + xs[1]);
+ }
+}
+
+static uint8_t *alloc_symbol(s7_scheme *sc)
+{
+ #define SYMBOL_SIZE (3 * sizeof(s7_cell) + sizeof(block_t))
+ #define ALLOC_SYMBOL_SIZE (64 * SYMBOL_SIZE)
+ uint8_t *result;
+ if (sc->alloc_symbol_k == ALLOC_SYMBOL_SIZE)
+ {
+ sc->alloc_symbol_cells = (uint8_t *)Malloc(ALLOC_SYMBOL_SIZE);
+ add_saved_pointer(sc, sc->alloc_symbol_cells);
+ sc->alloc_symbol_k = 0;
+ }
+ result = &(sc->alloc_symbol_cells[sc->alloc_symbol_k]);
+ sc->alloc_symbol_k += SYMBOL_SIZE;
+ return(result);
+}
+
+static s7_pointer make_semipermanent_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer value)
+{
+ s7_pointer slot = alloc_pointer(sc);
+ set_full_type(slot, T_SLOT | T_UNHEAP);
+ slot_set_symbol_and_value(slot, symbol, value);
+ return(slot);
+}
+
+static /* inline */ s7_pointer new_symbol(s7_scheme *sc, const char *name, s7_int len, uint64_t hash, uint32_t location) /* inline useless here 20-Oct-22 */
+{
+ /* name might not be null-terminated, these are semipermanent symbols even in s7_gensym; g_gensym handles everything separately */
+ uint8_t *base = alloc_symbol(sc);
+ s7_pointer x = (s7_pointer)base;
+ s7_pointer str = (s7_pointer)(base + sizeof(s7_cell));
+ s7_pointer p = (s7_pointer)(base + 2 * sizeof(s7_cell));
+ uint8_t *val = (uint8_t *)permalloc(sc, len + 1);
+ memcpy((void *)val, (const void *)name, len);
+ val[len] = '\0';
+
+ full_type(str) = T_STRING | T_IMMUTABLE | T_UNHEAP; /* avoid debugging confusion involving set_type (also below) */
+ string_length(str) = len;
+ string_value(str) = (char *)val;
+ string_hash(str) = hash;
+
+ full_type(x) = T_SYMBOL | T_UNHEAP;
+ symbol_set_name_cell(x, str);
+ set_global_slot(x, sc->undefined); /* was sc->nil */
+ symbol_info(x) = (block_t *)(base + 3 * sizeof(s7_cell));
+ set_initial_slot(x, sc->undefined);
+ symbol_set_local_slot_unchecked_and_unincremented(x, 0LL, sc->nil);
+ symbol_set_tag(x, 0);
+ symbol_set_tag2(x, 0);
+ symbol_clear_ctr(x); /* alloc_symbol uses malloc */
+ symbol_clear_type(x);
+
+ if ((len > 1) && /* not 0, otherwise : is a keyword */
+ ((name[0] == ':') || (name[len - 1] == ':'))) /* see s7test under keyword? for troubles if both colons are present */
+ {
+ s7_pointer slot, ksym;
+ set_type_bit(x, T_IMMUTABLE | T_KEYWORD | T_GLOBAL);
+ set_optimize_op(str, OP_CONSTANT);
+ ksym = make_symbol(sc, (name[0] == ':') ? (const char *)(name + 1) : name, len - 1);
+ keyword_set_symbol(x, ksym);
+ 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);
+ slot = make_semipermanent_slot(sc, x, x);
+ set_global_slot(x, slot);
+ set_local_slot(x, slot);
+ set_immutable_slot(slot);
+ }
+ full_type(p) = T_PAIR | T_IMMUTABLE | T_UNHEAP; /* add x to the symbol table */
+ set_car(p, x);
+ unchecked_set_cdr(p, vector_element(sc->symbol_table, location));
+ vector_element(sc->symbol_table, location) = p;
+ pair_set_raw_hash(p, hash);
+ pair_set_raw_len(p, (uint64_t)len); /* symbol name length, so it ought to fit! */
+ pair_set_raw_name(p, string_value(str));
+ return(x);
+}
+
+static Inline s7_pointer inline_make_symbol(s7_scheme *sc, const char *name, s7_int len) /* inline out: ca 40=2% in tload */
+{ /* name here might not be null-terminated */
+ uint64_t hash = raw_string_hash((const uint8_t *)name, len);
+ uint32_t location = hash % SYMBOL_TABLE_SIZE;
+
+ 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));
+ }
+ 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));
+ return(new_symbol(sc, name, len, hash, location));
+}
+
+static s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len) {return(inline_make_symbol(sc, name, len));}
+
+s7_pointer s7_make_symbol(s7_scheme *sc, const char *name) {return(inline_make_symbol(sc, name, safe_strlen(name)));}
+
+static s7_pointer symbol_table_find_by_name(s7_scheme *sc, const char *name, uint64_t hash, uint32_t location, s7_int len)
+{
+ 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)))
+ return(car(x));
+ return(sc->nil);
+}
+
+s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name)
+{
+ s7_int len = safe_strlen(name);
+ uint64_t hash = raw_string_hash((const uint8_t *)name, len);
+ s7_pointer result = symbol_table_find_by_name(sc, name, hash, hash % SYMBOL_TABLE_SIZE, len);
+ return((is_null(result)) ? NULL : result);
+}
+
+
+/* -------------------------------- symbol-table -------------------------------- */
+static inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len);
+
+static s7_pointer g_symbol_table(s7_scheme *sc, s7_pointer unused_args)
+{
+ #define H_symbol_table "(symbol-table) returns a vector containing the current contents (symbols) of s7's symbol-table"
+ #define Q_symbol_table s7_make_signature(sc, 1, sc->is_vector_symbol)
+
+ s7_pointer *els, *entries = vector_elements(sc->symbol_table);
+ int32_t syms = 0;
+ s7_pointer vec;
+ /* this can't be optimized by returning the actual symbol-table (a vector of lists), because
+ * gensyms can cause the table's lists and symbols to change at any time. This wreaks havoc
+ * on traversals like for-each. So, symbol-table returns a snap-shot of the table contents
+ * at the time it is called.
+ * (define (for-each-symbol func num) (for-each (lambda (sym) (if (> num 0) (for-each-symbol func (- num 1)) (func sym))) (symbol-table)))
+ * (for-each-symbol (lambda (sym) (gensym) 1))
+ * can be called in gdb: p display(s7_eval_c_string(sc, "(for-each (lambda (x) (when (gensym? x) (format *stderr* \"~A \" x))) (symbol-table))"))
+ */
+ for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++)
+ for (s7_pointer x = entries[i]; is_not_null(x); x = cdr(x))
+ 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)));
+ sc->w = make_simple_vector(sc, syms);
+ set_is_symbol_table(sc->w);
+ els = vector_elements(sc->w);
+ for (int32_t i = 0, j = 0; i < SYMBOL_TABLE_SIZE; i++)
+ for (s7_pointer x = entries[i]; is_not_null(x); x = cdr(x))
+ els[j++] = car(x);
+ vec = sc->w;
+ sc->w = sc->unused;
+ return(vec);
+}
+
+bool s7_for_each_symbol_name(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data)
+{
+ /* this includes the special constants #<unspecified> and so on for simplicity -- are there any others? */
+ 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((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)));
+}
+
+bool s7_for_each_symbol(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data)
+{
+ 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(false);
+}
+
+
+/* -------------------------------- gensym -------------------------------- */
+static void remove_gensym_from_symbol_table(s7_scheme *sc, s7_pointer sym)
+{
+ /* sym is a free cell at this point (we're called after the GC), but the name_cell is still intact */
+ s7_pointer name = symbol_name_cell(sym);
+ uint32_t location = string_hash(name) % SYMBOL_TABLE_SIZE;
+ s7_pointer x = vector_element(sc->symbol_table, location);
+ if (car(x) == sym)
+ vector_element(sc->symbol_table, location) = cdr(x);
+ 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;
+ }
+}
+
+s7_pointer s7_gensym(s7_scheme *sc, const char *prefix)
+{
+ s7_int len = safe_strlen(prefix) + 32;
+ block_t *b = mallocate(sc, len);
+ char *name = (char *)block_data(b);
+ /* there's no point in heroic efforts here to avoid name collisions -- the user can screw up no matter what we do */
+ name[0] = '\0';
+ {
+ s7_int slen = catstrs(name, len, "{", (prefix) ? prefix : "", "}-", pos_int_to_str_direct(sc, sc->gensym_counter++), (char *)NULL);
+ uint64_t hash = raw_string_hash((const uint8_t *)name, slen);
+ int32_t location = hash % SYMBOL_TABLE_SIZE;
+ s7_pointer x = new_symbol(sc, name, slen, hash, location); /* not T_GENSYM -- might be called from outside -- what?? (2-Oct-23) */
+ liberate(sc, b);
+ return(x);
+ }
+}
+
+static bool is_gensym_b_p(s7_pointer g) {return((is_symbol(g)) && (is_gensym(g)));}
+
+static s7_pointer g_is_gensym(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_gensym "(gensym? sym) returns #t if sym is a gensym"
+ #define Q_is_gensym sc->pl_bt
+ check_boolean_method(sc, is_gensym_b_p, sc->is_gensym_symbol, args);
+}
+
+static s7_pointer g_gensym(s7_scheme *sc, s7_pointer args)
+{
+ #define H_gensym "(gensym (prefix \"gensym\")) returns a new, unused symbol"
+ #define Q_gensym s7_make_signature(sc, 2, sc->is_gensym_symbol, sc->is_string_symbol)
+
+ const char *prefix;
+ char *name, *base;
+ s7_int len, plen, nlen;
+ uint32_t location;
+ uint64_t hash;
+ s7_pointer x, str, stc;
+ block_t *b, *ib;
+
+ /* get symbol name */
+ if (is_not_null(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]));
+ prefix = string_value(gname);
+ plen = string_length(gname); /* was safe_strlen(prefix): were we stopping at #\null deliberately? */
+ }
+ else
+ {
+ prefix = "gensym";
+ plen = 6;
+ }
+ len = plen + 32; /* why 32 -- we need room for the gensym_counter integer, but (length "9223372036854775807") = 19, see gensym name collision loop below */
+
+ b = mallocate(sc, len + sizeof(block_t) + 2 * sizeof(s7_cell));
+ base = (char *)block_data(b);
+ str = (s7_cell *)base;
+ stc = (s7_cell *)(base + sizeof(s7_cell));
+ ib = (block_t *)(base + 2 * sizeof(s7_cell));
+ name = (char *)(base + sizeof(block_t) + 2 * sizeof(s7_cell));
+
+ name[0] = '{';
+ memcpy((void *)(name + 1), prefix, plen); /* memcpy is ok with plen==0, I think */
+ name[plen + 1] = '}';
+ name[plen + 2] = '-'; /* {gensym}-nnn */
+
+ while (true)
+ {
+ char *p = pos_int_to_str(sc, sc->gensym_counter++, &len, '\0');
+ memcpy((void *)(name + plen + 3), (void *)p, len);
+ nlen = len + plen + 2;
+ name[nlen] = '\0';
+ hash = raw_string_hash((const uint8_t *)name, nlen);
+ 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);
+ }
+
+ /* make-string for symbol name */
+ if (S7_DEBUGGING) full_type(str) = 0; /* here and below, this is needed to avoid set_type check errors (mallocate above) */
+ set_full_type(str, T_STRING | T_IMMUTABLE | T_UNHEAP);
+ string_length(str) = nlen;
+ string_value(str) = name;
+ string_hash(str) = hash;
+
+ /* allocate the symbol in the heap so GC'd when inaccessible */
+ new_cell(sc, x, T_SYMBOL | T_GENSYM);
+ symbol_set_name_cell(x, str);
+ symbol_info(x) = ib;
+ set_global_slot(x, sc->undefined); /* set_initial_slot(x, sc->undefined); */
+ symbol_set_local_slot_unchecked(x, 0LL, sc->nil);
+ symbol_clear_ctr(x);
+ symbol_set_tag(x, 0);
+ symbol_set_tag2(x, 0);
+ symbol_clear_type(x);
+ gensym_block(x) = b;
+
+ /* place new symbol in symbol-table */
+ if (S7_DEBUGGING) full_type(stc) = 0;
+ set_full_type(stc, T_PAIR | T_IMMUTABLE | T_UNHEAP);
+ set_car(stc, x);
+ unchecked_set_cdr(stc, vector_element(sc->symbol_table, location));
+ vector_element(sc->symbol_table, location) = stc;
+ pair_set_raw_hash(stc, hash);
+ pair_set_raw_len(stc, (uint64_t)string_length(str));
+ pair_set_raw_name(stc, string_value(str));
+
+ add_gensym(sc, x);
+ return(x);
+}
+
+
+/* -------------------------------- syntax? -------------------------------- */
+bool s7_is_syntax(s7_pointer p) {return(is_syntax(p));}
+
+static s7_pointer g_is_syntax(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_syntax "(syntax? obj) returns #t if obj is a syntactic value (e.g. lambda)"
+ #define Q_is_syntax sc->pl_bt
+ check_boolean_method(sc, is_syntax, sc->is_syntax_symbol, args);
+}
+
+
+/* -------------------------------- symbol? -------------------------------- */
+bool s7_is_symbol(s7_pointer p) {return(is_symbol(p));}
+
+static s7_pointer g_is_symbol(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_symbol "(symbol? obj) returns #t if obj is a symbol"
+ #define Q_is_symbol sc->pl_bt
+ check_boolean_method(sc, is_symbol, sc->is_symbol_symbol, args);
+}
+
+const char *s7_symbol_name(s7_pointer p) {return(symbol_name(p));}
+
+s7_pointer s7_name_to_value(s7_scheme *sc, const char *name) {return(s7_symbol_value(sc, make_symbol_with_strlen(sc, name)));}
+/* should this also handle non-symbols such as "+nan.0"? */
+
+
+/* -------------------------------- symbol->string -------------------------------- */
+static Inline s7_pointer inline_make_string_with_length(s7_scheme *sc, const char *str, s7_int len)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_STRING | T_SAFE_PROCEDURE);
+ string_block(x) = inline_mallocate(sc, len + 1);
+ string_value(x) = (char *)block_data(string_block(x));
+ memcpy((void *)string_value(x), (const void *)str, len);
+ string_value(x)[len] = 0;
+ string_length(x) = len;
+ string_hash(x) = 0;
+ add_string(sc, x);
+ return(x);
+}
+
+static s7_pointer make_string_with_length(s7_scheme *sc, const char *str, s7_int len)
+{
+ return(inline_make_string_with_length(sc, str, len)); /* packaged to avoid inlining everywhere */
+}
+
+static s7_pointer g_symbol_to_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_symbol_to_string "(symbol->string sym) returns the symbol sym converted to a string"
+ #define Q_symbol_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_symbol_symbol)
+
+ s7_pointer sym = car(args);
+ if (!is_symbol(sym))
+ return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, args, sc->type_names[T_SYMBOL]));
+ /* 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)));
+ return(inline_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); /* return a copy */
+}
+
+static s7_pointer g_symbol_to_string_uncopied(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer sym = car(args);
+ if (!is_symbol(sym))
+ return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, args, sc->type_names[T_SYMBOL]));
+ if (is_gensym(sym))
+ return(make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym))); /* return a copy of gensym name (which will be freed) */
+ return(symbol_name_cell(sym));
+}
+
+static s7_pointer symbol_to_string_p_p(s7_scheme *sc, s7_pointer sym)
+{
+ if (!is_symbol(sym))
+ return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, set_plist_1(sc, sym), sc->type_names[T_SYMBOL]));
+ return(inline_make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym)));
+}
+
+static s7_pointer symbol_to_string_uncopied_p(s7_scheme *sc, s7_pointer sym)
+{
+ if (!is_symbol(sym))
+ return(sole_arg_method_or_bust(sc, sym, sc->symbol_to_string_symbol, set_plist_1(sc, sym), sc->type_names[T_SYMBOL]));
+ if (is_gensym(sym))
+ return(make_string_with_length(sc, symbol_name(sym), symbol_name_length(sym)));
+ return(symbol_name_cell(sym));
+}
+
+
+/* -------------------------------- string->symbol -------------------------------- */
+static inline s7_pointer g_string_to_symbol_1(s7_scheme *sc, s7_pointer str, s7_pointer caller)
+{
+ if (!is_string(str))
+ return(method_or_bust_p(sc, str, caller, sc->type_names[T_STRING]));
+ if (string_length(str) <= 0)
+ sole_arg_wrong_type_error_nr(sc, caller, str, wrap_string(sc, "a non-null string", 17));
+ return(make_symbol(sc, string_value(str), string_length(str)));
+}
+
+static s7_pointer g_string_to_symbol(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_to_symbol "(string->symbol str) returns the string str converted to a symbol"
+ #define Q_string_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_string_symbol)
+ return(g_string_to_symbol_1(sc, car(args), sc->string_to_symbol_symbol));
+}
+
+static s7_pointer string_to_symbol_p_p(s7_scheme *sc, s7_pointer p) {return(g_string_to_symbol_1(sc, p, sc->string_to_symbol_symbol));}
+
+
+/* -------------------------------- symbol -------------------------------- */
+static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer caller);
+
+static s7_pointer mark_as_symbol_from_symbol(s7_pointer sym)
+{
+ set_is_symbol_from_symbol(sym);
+ return(sym);
+}
+
+static s7_pointer g_symbol(s7_scheme *sc, s7_pointer args)
+{
+ #define H_symbol "(symbol str ...) returns its string arguments concatenated and converted to a symbol"
+ #define Q_symbol s7_make_circular_signature(sc, 1, 2, sc->is_symbol_symbol, sc->is_string_symbol)
+
+ /* (let ((x 0)) (set! (symbol "x") 12)) ;symbol (a c-function) does not have a setter: (set! (symbol "x") 12)
+ * (let (((symbol "x") 3)) x) ; bad variable ((symbol "x")
+ * (let ((x 2)) (+ (symbol "x") 1)) ;+ first argument, x, is a symbol but should be a number
+ * maybe document this: (symbol...) just returns the symbol
+ * (let ((x 3)) (+ (symbol->value (symbol "x")) 1)) -> 4, (let ((x 0)) (apply set! (symbol "x") (list 32)) x) -> 32
+ */
+
+ s7_int len = 0, cur_len;
+ s7_pointer p, sym;
+ block_t *b;
+ char *name;
+
+ for (p = args; is_pair(p); p = cdr(p))
+ if (is_string(car(p)))
+ len += string_length(car(p));
+ else break;
+ 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, g_string_append_1(sc, args, sc->symbol_symbol), sc->symbol_symbol)));
+ }
+ if (len == 0)
+ sole_arg_wrong_type_error_nr(sc, sc->symbol_symbol, car(args), wrap_string(sc, "a non-null string", 17));
+
+ b = mallocate(sc, len + 1);
+ name = (char *)block_data(b);
+ /* can't use catstrs_direct here because it stops at embedded null */
+ for (cur_len = 0, p = args; is_pair(p); p = cdr(p))
+ {
+ 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);
+ }}
+ name[len] = '\0';
+ sym = mark_as_symbol_from_symbol(inline_make_symbol(sc, name, len));
+ liberate(sc, b);
+ return(sym);
+}
+
+static s7_pointer symbol_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ char buf[256];
+ s7_int len;
+ if ((!is_string(p1)) || (!is_string(p2))) return(g_symbol(sc, set_plist_2(sc, p1, p2)));
+ len = string_length(p1) + string_length(p2);
+ if ((len == 0) || (len >= 256)) return(g_symbol(sc, set_plist_2(sc, p1, p2)));
+ memcpy((void *)buf, (void *)string_value(p1), string_length(p1));
+ memcpy((void *)(buf + string_length(p1)), (void *)string_value(p2), string_length(p2));
+ return(mark_as_symbol_from_symbol(inline_make_symbol(sc, buf, len)));
+}
+
+
+/* -------- symbol sets -------- */
+static inline s7_pointer add_symbol_to_list(s7_scheme *sc, s7_pointer sym)
+{
+ symbol_set_tag(sym, sc->syms_tag);
+ symbol_set_tag2(sym, sc->syms_tag2);
+ return(sym);
+}
+
+static inline void clear_symbol_list(s7_scheme *sc)
+{
+ sc->syms_tag++;
+ if (sc->syms_tag == 0)
+ {
+ sc->syms_tag = 1; /* we're assuming (in let_equal) that this tag is not 0 */
+ sc->syms_tag2++;
+ }
+}
+
+#define symbol_is_in_list(Sc, Sym) ((symbol_tag(Sym) == Sc->syms_tag) && (symbol_tag2(Sym) == Sc->syms_tag2))
+
+
+/* -------------------------------- lets/slots -------------------------------- */
+static Inline s7_pointer inline_make_let(s7_scheme *sc, s7_pointer old_let)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_LET | T_SAFE_PROCEDURE);
+ let_set_id(x, ++sc->let_number);
+ let_set_slots(x, slot_end);
+ let_set_outlet(x, old_let);
+ return(x);
+}
+
+static inline s7_pointer make_let(s7_scheme *sc, s7_pointer old_let) {return(inline_make_let(sc, old_let));}
+
+static Inline s7_pointer inline_make_let_with_slot(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol, s7_pointer value)
+{
+ s7_pointer new_let, slot;
+ sc->value = value;
+ new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE);
+ let_set_id(new_let, ++sc->let_number);
+ let_set_outlet(new_let, old_let);
+ new_cell_no_check(sc, slot, T_SLOT);
+ slot_set_symbol_and_value(slot, symbol, value);
+ symbol_set_local_slot(symbol, sc->let_number, slot);
+ slot_set_next(slot, slot_end);
+ let_set_slots(new_let, slot);
+ return(new_let);
+}
+
+static s7_pointer make_let_with_slot(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol, s7_pointer value)
+{
+ return(inline_make_let_with_slot(sc, old_let, symbol, value));
+}
+
+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)
+{
+ /* 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*.
+ */
+ s7_pointer new_let, slot1, slot2;
+ new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE);
+ let_set_id(new_let, ++sc->let_number);
+ let_set_outlet(new_let, old_let);
+
+ new_cell_no_check(sc, slot1, T_SLOT);
+ slot_set_symbol_and_value(slot1, symbol1, value1);
+ symbol_set_local_slot(symbol1, sc->let_number, slot1);
+ let_set_slots(new_let, slot1);
+
+ new_cell_no_check(sc, slot2, T_SLOT);
+ slot_set_symbol_and_value(slot2, symbol2, value2);
+ symbol_set_local_slot(symbol2, sc->let_number, slot2);
+ slot_set_next(slot2, slot_end);
+ slot_set_next(slot1, slot2);
+ return(new_let);
+}
+
+static s7_pointer make_let_with_two_slots(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol1, s7_pointer value1, s7_pointer symbol2, s7_pointer value2)
+{
+ return(inline_make_let_with_two_slots(sc, old_let, symbol1, value1, symbol2, value2));
+}
+
+/* in all these functions, symbol_set_local_slot should follow slot_set_value so that we can evaluate the slot's value in its old state */
+static inline void add_slot_unchecked(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value, uint64_t id)
+{
+ s7_pointer slot;
+ new_cell_no_check(sc, slot, T_SLOT);
+ slot_set_symbol_and_value(slot, symbol, value);
+ slot_set_next(slot, let_slots(let));
+ let_set_slots(let, slot);
+ set_local(symbol);
+ symbol_set_local_slot(symbol, id, slot);
+}
+
+static void add_slot_unchecked_no_local(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
+{
+ s7_pointer slot;
+ new_cell_no_check(sc, slot, T_SLOT);
+ slot_set_symbol_and_value(slot, symbol, value);
+ slot_set_next(slot, let_slots(let));
+ let_set_slots(let, slot);
+ set_local(symbol);
+}
+
+#define add_slot(Sc, Let, Symbol, Value) add_slot_unchecked(Sc, Let, Symbol, Value, let_id(Let))
+
+static inline s7_pointer add_slot_checked(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
+{
+ s7_pointer slot;
+ new_cell(sc, slot, T_SLOT);
+ slot_set_symbol_and_value(slot, symbol, value);
+ symbol_set_local_slot(symbol, let_id(let), slot);
+ slot_set_next(slot, let_slots(let));
+ let_set_slots(let, slot);
+ return(slot);
+}
+
+static inline s7_pointer add_slot_checked_with_id(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
+{
+ s7_pointer slot;
+ new_cell(sc, slot, T_SLOT);
+ slot_set_symbol_and_value(slot, symbol, value);
+ set_local(symbol);
+ if (let_id(let) >= symbol_id(symbol))
+ symbol_set_local_slot(symbol, let_id(let), slot);
+ slot_set_next(slot, let_slots(let));
+ let_set_slots(let, slot);
+ return(slot);
+}
+
+static s7_pointer add_slot_unchecked_with_id(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
+{
+ s7_pointer slot;
+ new_cell_no_check(sc, slot, T_SLOT);
+ slot_set_symbol_and_value(slot, symbol, value);
+ set_local(symbol);
+ if (let_id(let) >= symbol_id(symbol))
+ symbol_set_local_slot(symbol, let_id(let), slot);
+ slot_set_next(slot, let_slots(let));
+ let_set_slots(let, slot);
+ return(slot);
+}
+
+static Inline s7_pointer inline_add_slot_at_end(s7_scheme *sc, uint64_t id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value)
+{
+ s7_pointer slot;
+ new_cell_no_check(sc, slot, T_SLOT);
+ slot_set_symbol_and_value(slot, symbol, value);
+ slot_set_next(slot, slot_end);
+ symbol_set_local_slot(symbol, id, slot);
+ slot_set_next(last_slot, slot);
+ return(slot);
+}
+
+static s7_pointer add_slot_at_end(s7_scheme *sc, uint64_t id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value)
+{
+ return(inline_add_slot_at_end(sc, id, last_slot, symbol, value));
+}
+
+static s7_pointer add_slot_at_end_no_local(s7_scheme *sc, s7_pointer last_slot, s7_pointer symbol, s7_pointer value)
+{
+ s7_pointer slot;
+ new_cell_no_check(sc, slot, T_SLOT);
+ slot_set_symbol_and_value(slot, symbol, value);
+ slot_set_next(slot, slot_end);
+ slot_set_next(last_slot, slot);
+ return(slot);
+}
+
+static inline void make_let_with_three_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3)
+{
+ s7_pointer last_slot, cargs = closure_args(func);
+ set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(cargs), val1, cadr(cargs), val2));
+ last_slot = next_slot(let_slots(sc->curlet));
+ inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, caddr(cargs), val3);
+}
+
+static inline void make_let_with_four_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4)
+{
+ s7_pointer last_slot, cargs = closure_args(func);
+ set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(cargs), val1, cadr(cargs), val2));
+ cargs = cddr(cargs);
+ last_slot = next_slot(let_slots(sc->curlet));
+ last_slot = inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(cargs), val3);
+ inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadr(cargs), val4);
+}
+
+static inline void make_let_with_five_slots(s7_scheme *sc, s7_pointer func, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4, s7_pointer val5)
+{
+ s7_pointer last_slot, cargs = closure_args(func);
+ set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(cargs), val1, cadr(cargs), val2));
+ cargs = cddr(cargs);
+ last_slot = next_slot(let_slots(sc->curlet));
+ last_slot = inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(cargs), val3);
+ cargs = cdr(cargs);
+ last_slot = inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(cargs), val4);
+ inline_add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadr(cargs), val5);
+}
+
+static s7_pointer reuse_as_let(s7_scheme *sc, s7_pointer let, s7_pointer next_let)
+{
+#if S7_DEBUGGING
+ let->debugger_bits = 0;
+ if (!in_heap(let)) {fprintf(stderr, "reusing an unheaped %s as a let?\n", s7_type_names[type(let)]); abort();}
+#endif
+ set_full_type(T_Pair(let), T_LET | T_SAFE_PROCEDURE); /* we're reusing let here as a let -- it was a pair */
+ let_set_slots(let, slot_end);
+ let_set_outlet(let, next_let);
+ let_set_id(let, ++sc->let_number);
+ return(let);
+}
+
+static s7_pointer reuse_as_slot(s7_pointer slot, s7_pointer symbol, s7_pointer value)
+{
+#if S7_DEBUGGING
+ slot->debugger_bits = 0;
+ if (!in_heap(slot)) {fprintf(stderr, "reusing an unheaped %s as a slot?\n", s7_type_names[type(slot)]); abort();}
+#endif
+ set_full_type(T_Pair(slot), T_SLOT);
+ slot_set_symbol_and_value(slot, symbol, value);
+ return(slot);
+}
+
+#define update_slot(Slot, Val, Id) do {s7_pointer sym; slot_set_value(Slot, Val); sym = slot_symbol(Slot); symbol_set_local_slot_unincremented(sym, Id, Slot);} while (0)
+
+static s7_pointer update_let_with_slot(s7_scheme *sc, s7_pointer let, s7_pointer val)
+{
+ s7_pointer slot = let_slots(let);
+ uint64_t id = ++sc->let_number;
+ let_set_id(let, id);
+ update_slot(slot, val, id);
+ return(let);
+}
+
+static s7_pointer update_let_with_two_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2)
+{
+ s7_pointer slot = let_slots(let);
+ uint64_t id = ++sc->let_number;
+ let_set_id(let, id);
+ update_slot(slot, val1, id); slot = next_slot(slot);
+ update_slot(slot, val2, id);
+ return(let);
+}
+
+static s7_pointer update_let_with_three_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2, s7_pointer val3)
+{
+ s7_pointer slot = let_slots(let);
+ uint64_t id = ++sc->let_number;
+ let_set_id(let, id);
+ update_slot(slot, val1, id); slot = next_slot(slot);
+ update_slot(slot, val2, id); slot = next_slot(slot);
+ update_slot(slot, val3, id);
+ return(let);
+}
+
+static s7_pointer update_let_with_four_slots(s7_scheme *sc, s7_pointer let, s7_pointer val1, s7_pointer val2, s7_pointer val3, s7_pointer val4)
+{
+ s7_pointer slot = let_slots(let);
+ uint64_t id = ++sc->let_number;
+ let_set_id(let, id);
+ update_slot(slot, val1, id); slot = next_slot(slot);
+ update_slot(slot, val2, id); slot = next_slot(slot);
+ update_slot(slot, val3, id); slot = next_slot(slot);
+ update_slot(slot, val4, id);
+ return(let);
+}
+
+static s7_pointer make_semipermanent_let(s7_scheme *sc, s7_pointer vars)
+{
+ s7_pointer slot, let = alloc_pointer(sc);
+ set_full_type(let, T_LET | T_SAFE_PROCEDURE | T_UNHEAP);
+ let_set_id(let, ++sc->let_number);
+ let_set_outlet(let, sc->curlet);
+ slot = make_semipermanent_slot(sc, caar(vars), sc->F);
+ add_semipermanent_let_or_slot(sc, slot);
+ symbol_set_local_slot(caar(vars), sc->let_number, slot);
+ let_set_slots(let, slot);
+ for (s7_pointer var = cdr(vars); is_pair(var); var = cdr(var))
+ {
+ s7_pointer last_slot = slot;
+ slot = make_semipermanent_slot(sc, caar(var), sc->F);
+ add_semipermanent_let_or_slot(sc, slot);
+ symbol_set_local_slot(caar(var), sc->let_number, slot);
+ slot_set_next(last_slot, slot);
+ }
+ slot_set_next(slot, slot_end);
+ add_semipermanent_let_or_slot(sc, let); /* need to mark outlet and maybe slot values */
+ return(let);
+}
+
+static s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer old_value);
+
+static inline s7_pointer checked_slot_set_value(s7_scheme *sc, s7_pointer y, s7_pointer value)
+{
+ if (slot_has_setter(y))
+ slot_set_value(y, call_setter(sc, y, value));
+ 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)));
+ slot_set_value(y, value);
+ }
+ return(slot_value(y));
+}
+
+static s7_pointer let_fill(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer e = car(args), val;
+ if (e == sc->rootlet)
+ out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! rootlet", 19));
+ if (e == sc->s7_starlet)
+ out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! *s7*", 16));
+ if (e == sc->owlet) /* (owlet) copies sc->owlet, so this probably can't happen */
+ out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! owlet", 17));
+ if (is_funclet(e))
+ out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! a funclet", 21));
+ val = cadr(args);
+ for (s7_pointer p = let_slots(e); tis_slot(p); p = next_slot(p))
+ checked_slot_set_value(sc, p, val);
+ return(val);
+}
+
+static s7_int s7_starlet_length(void);
+
+static s7_int let_length(s7_scheme *sc, s7_pointer e)
+{
+ /* used by length, applicable_length, copy, and some length optimizations */
+ s7_int i;
+ s7_pointer p;
+
+ if (e == sc->rootlet)
+ {
+ for (i = 0, p = sc->rootlet_slots; tis_slot(p); i++, p = next_slot(p));
+ return(i);
+ }
+ if (e == sc->s7_starlet)
+ return(s7_starlet_length());
+ if (has_active_methods(sc, 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); /* ?? */
+ }}
+ for (i = 0, p = let_slots(e); tis_slot(p); i++, p = next_slot(p));
+ return(i);
+}
+
+static void slot_set_setter(s7_pointer p, s7_pointer val)
+{
+ if ((type(val) == T_C_FUNCTION) &&
+ (c_function_has_bool_setter(val)))
+ slot_set_setter_1(p, c_function_bool_setter(val));
+ else slot_set_setter_1(p, val);
+}
+
+static void slot_set_value_with_hook_1(s7_scheme *sc, s7_pointer slot, s7_pointer value)
+{
+ /* (set! (hook-functions *rootlet-redefinition-hook*) (list (lambda (hook) (format *stderr* "~A ~A~%" (hook 'name) (hook 'value))))) */
+ s7_pointer symbol = slot_symbol(slot);
+ if ((global_slot(symbol) == slot) &&
+ (value != slot_value(slot)))
+ s7_call(sc, sc->rootlet_redefinition_hook, set_plist_2(sc, symbol, value));
+ slot_set_value(slot, value);
+}
+
+static void remove_function_from_heap(s7_scheme *sc, s7_pointer value); /* calls remove_let_from_heap */
+
+static void remove_let_from_heap(s7_scheme *sc, s7_pointer lt)
+{
+ for (s7_pointer p = let_slots(lt); tis_slot(p); p = next_slot(p))
+ {
+ s7_pointer val = slot_value(p);
+ if ((has_closure_let(val)) &&
+ (in_heap(closure_args(val))))
+ remove_function_from_heap(sc, val);
+ }
+ let_set_removed(lt);
+}
+
+static void add_slot_to_rootlet(s7_scheme *sc, s7_pointer slot)
+{
+ set_in_rootlet(slot);
+ slot_set_next(slot, sc->rootlet_slots);
+ sc->rootlet_slots = slot;
+}
+
+static void remove_function_from_heap(s7_scheme *sc, s7_pointer value)
+{
+ s7_pointer lt;
+ remove_from_heap(sc, closure_args(value));
+ remove_from_heap(sc, closure_body(value));
+ /* remove closure if it's local to current func (meaning (define f (let ...) (lambda ...)) removes the enclosing let) */
+ lt = closure_let(value);
+ if ((is_let(lt)) && (!let_removed(lt)) && (lt != sc->shadow_rootlet))
+ {
+ 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);
+ }}
+}
+
+s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
+{
+ if ((!is_let(let)) ||
+ (let == sc->rootlet))
+ {
+ 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));
+ 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 */
+
+ /* 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 = 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);
+ }
+ symbol_increment_ctr(symbol);
+ if (is_gensym(symbol))
+ remove_gensym_from_heap(sc, symbol);
+ return(slot);
+ }
+ return(add_slot_checked_with_id(sc, let, symbol, value));
+ /* there are about as many lets as local variables -- this strikes me as surprising, but it holds up across a lot of code */
+}
+
+static s7_pointer make_slot(s7_scheme *sc, s7_pointer variable, s7_pointer value)
+{
+ s7_pointer y;
+ new_cell(sc, y, T_SLOT);
+ slot_set_symbol_and_value(y, variable, value);
+ return(y);
+}
+
+
+/* -------------------------------- let? -------------------------------- */
+bool s7_is_let(s7_pointer e) {return(is_let(e));}
+
+static s7_pointer g_is_let(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_let "(let? obj) returns #t if obj is a let."
+ #define Q_is_let sc->pl_bt
+ check_boolean_method(sc, is_let, sc->is_let_symbol, args);
+}
+
+
+/* -------------------------------- funclet? -------------------------------- */
+static s7_pointer g_is_funclet(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_funclet "(funclet? obj) returns #t if obj is a funclet (a function's environment)."
+ #define Q_is_funclet sc->pl_bt
+
+ s7_pointer lt = car(args);
+ if (lt == sc->rootlet) return(sc->F);
+ if ((is_let(lt)) && ((is_funclet(lt)) || (is_maclet(lt))))
+ return(sc->T);
+ if (!has_active_methods(sc, lt))
+ return(sc->F);
+ return(apply_boolean_method(sc, lt, sc->is_funclet_symbol));
+}
+
+
+/* -------------------------------- unlet -------------------------------- */
+static s7_pointer g_unlet(s7_scheme *sc, s7_pointer unused_args)
+{
+ /* add sc->unlet bindings to the current environment */
+ #define H_unlet "(unlet) returns a let that establishes the original bindings of all the predefined functions"
+ #define Q_unlet s7_make_signature(sc, 1, sc->is_let_symbol)
+
+ s7_pointer res;
+ sc->w = make_let(sc, sc->curlet);
+ set_is_unlet(sc->w);
+ if (global_value(sc->else_symbol) != sc->else_symbol)
+ add_slot_checked_with_id(sc, sc->w, sc->else_symbol, initial_value(sc->else_symbol));
+ for (s7_pointer p = sc->unlet_slots; tis_slot(p); p = next_slot(p))
+ {
+ 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);
+ }
+ res = sc->w;
+ sc->w = sc->unused;
+ return(res);
+}
+
+
+/* -------------------------------- openlet? -------------------------------- */
+bool s7_is_openlet(s7_pointer e) {return(has_methods(e));}
+
+static s7_pointer g_is_openlet(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_openlet "(openlet? obj) returns #t is 'obj' has methods."
+ #define Q_is_openlet sc->pl_bt
+
+ s7_pointer e = car(args); /* if e is not a let, should this raise an error? -- no, easier to use this way in cond */
+ check_method(sc, e, sc->is_openlet_symbol, args);
+ return(make_boolean(sc, has_methods(e)));
+}
+
+
+/* -------------------------------- openlet -------------------------------- */
+s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e)
+{
+ set_has_methods(e);
+ return(e);
+}
+
+static s7_pointer g_openlet(s7_scheme *sc, s7_pointer args)
+{
+ #define H_openlet "(openlet e) tells the built-in functions that the let 'e might have an over-riding method."
+ #define Q_openlet sc->pcl_e
+
+ s7_pointer e = car(args), elet, func;
+ if (e == sc->nil)
+ error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't openlet nil", 17)));
+ elet = find_let(sc, e); /* returns nil if no let found, so has to follow error check above */
+ if (!is_let(elet))
+ sole_arg_wrong_type_error_nr(sc, sc->openlet_symbol, e, a_let_string);
+ if (elet == sc->rootlet)
+ error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't openlet rootlet", 21)));
+ if (is_unlet(elet)) /* protect against infinite loop: (let () (define + -) (with-let (unlet) (+ (openlet (unlet)) 2))) */
+ error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't openlet unlet", 19)));
+ if ((has_active_methods(sc, e)) &&
+ ((func = find_method(sc, elet, sc->openlet_symbol)) != sc->undefined))
+ return(s7_apply_function(sc, func, args));
+ set_has_methods(e);
+ return(e);
+}
+
+/* -------------------------------- coverlet -------------------------------- */
+static s7_pointer g_coverlet(s7_scheme *sc, s7_pointer args)
+{
+ #define H_coverlet "(coverlet e) undoes an earlier openlet."
+ #define Q_coverlet sc->pcl_e
+
+ s7_pointer e = car(args);
+ check_method(sc, e, sc->coverlet_symbol, set_plist_1(sc, e));
+ if ((e == sc->rootlet) || (e == sc->s7_starlet))
+ error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't coverlet ~S", 17), e));
+ if ((is_let(e)) && (is_unlet(e)))
+ error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't coverlet unlet", 20)));
+ if ((is_let(e)) || (has_closure_let(e)) ||
+ ((is_c_object(e)) && (c_object_let(e) != sc->nil)) ||
+ ((is_c_pointer(e)) && (is_let(c_pointer_info(e)))))
+ {
+ clear_has_methods(e);
+ return(e);
+ }
+ sole_arg_wrong_type_error_nr(sc, sc->coverlet_symbol, e, a_let_string);
+ return(NULL);
+}
+
+
+/* -------------------------------- varlet -------------------------------- */
+static void check_let_fallback(s7_scheme *sc, const s7_pointer symbol, s7_pointer let)
+{
+ if (symbol == sc->let_ref_fallback_symbol)
+ set_has_let_ref_fallback(let);
+ else
+ if (symbol == sc->let_set_fallback_symbol)
+ set_has_let_set_fallback(let);
+}
+
+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);
+ }
+ 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);
+ }
+ 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 */
+}
+
+static s7_pointer check_c_object_let(s7_scheme *sc, s7_pointer old_e, s7_pointer caller)
+{
+ if (is_c_object(old_e))
+ old_e = c_object_let(old_e);
+ if (!is_let(old_e))
+ sole_arg_wrong_type_error_nr(sc, caller, old_e, a_let_string);
+ return(old_e);
+}
+
+s7_pointer s7_varlet(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
+{
+ if (!is_let(let))
+ wrong_type_error_nr(sc, sc->varlet_symbol, 1, let, a_let_string);
+ if (!is_symbol(symbol))
+ wrong_type_error_nr(sc, sc->varlet_symbol, 2, symbol, a_symbol_string);
+
+ if ((is_slot(global_slot(symbol))) &&
+ (is_syntax(global_value(symbol))))
+ wrong_type_error_nr(sc, sc->varlet_symbol, 2, symbol, wrap_string(sc, "a non-syntactic symbol", 22));
+
+ if (let == sc->rootlet)
+ {
+ if (is_slot(global_slot(symbol)))
+ slot_set_value(global_slot(symbol), value);
+ else s7_make_slot(sc, sc->rootlet, symbol, value);
+ }
+ else
+ {
+ add_slot_checked_with_id(sc, let, symbol, value);
+ check_let_fallback(sc, symbol, let);
+ }
+ return(value);
+}
+
+static int32_t position_of(const s7_pointer p, s7_pointer args)
+{
+ int32_t i;
+ for (i = 1; p != args; i++, args = cdr(args));
+ return(i);
+}
+
+static s7_pointer g_varlet(s7_scheme *sc, s7_pointer args) /* varlet = with-let + define */
+{
+ #define H_varlet "(varlet target-let ...) adds its arguments (a let, a cons: symbol . value, or two arguments, the symbol and its value) \
+to the let target-let, and returns target-let. (varlet (curlet) 'a 1) adds 'a to the current environment with the value 1."
+ #define Q_varlet s7_make_circular_signature(sc, 2, 4, sc->is_let_symbol, \
+ s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol), \
+ s7_make_signature(sc, 3, sc->is_pair_symbol, sc->is_symbol_symbol, sc->is_let_symbol), \
+ sc->T)
+
+ s7_pointer e = car(args);
+ if (is_null(e)) /* PERHAPS: this is a leftover from the days when () -> rootlet -- remove? */
+ e = sc->rootlet;
+ else
+ {
+ 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);
+ 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));
+ }
+ 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);
+ }
+ 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);
+ }
+ else
+ {
+ 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!.
+ */
+ return(e);
+}
+
+
+/* -------------------------------- cutlet -------------------------------- */
+static s7_pointer g_cutlet(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cutlet "(cutlet e symbol ...) removes symbols from the let e."
+ #define Q_cutlet s7_make_circular_signature(sc, 2, 3, sc->is_let_symbol, sc->is_let_symbol, sc->is_symbol_symbol)
+
+ s7_pointer e = car(args);
+ s7_int the_un_id;
+ if (is_null(e))
+ e = sc->rootlet; /* PERHAPS: this is a leftover from the days when () -> rootlet -- remove? */
+ else
+ {
+ 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);
+ 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));
+ }
+ /* 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?
+ * (let ((b 1)) (let ((b 2)) (cutlet (curlet) 'b)) b)
+ */
+ the_un_id = ++sc->let_number;
+
+ for (s7_pointer syms = cdr(args); is_pair(syms); syms = cdr(syms))
+ {
+ 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);
+ if (is_keyword(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 */
+ }
+ 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;
+ }}}}}
+ return(e);
+}
+
+
+/* -------------------------------- sublet -------------------------------- */
+static s7_pointer sublet_1(s7_scheme *sc, s7_pointer e, s7_pointer bindings, s7_pointer caller)
+{
+ s7_pointer new_e;
+ if (e == sc->nil) e = sc->rootlet; /* PERHAPS: this is a leftover from the days when () -> rootlet -- remove? */
+ new_e = make_let(sc, e);
+ set_all_methods(new_e, e);
+
+ if (!is_null(bindings))
+ {
+ 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);
+#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);
+ }
+ sc->temp3 = sc->unused;
+ }
+ return(new_e);
+}
+
+s7_pointer s7_sublet(s7_scheme *sc, s7_pointer e, s7_pointer bindings) {return(sublet_1(sc, e, bindings, sc->sublet_symbol));}
+
+static s7_pointer g_sublet(s7_scheme *sc, s7_pointer args)
+{
+ #define H_sublet "(sublet lt ...) makes a new let (environment) within the environment 'lt', initializing it with the bindings"
+ #define Q_sublet Q_varlet
+
+ s7_pointer e = car(args);
+ if (is_null(e)) /* is this a good idea anymore? () no longer stands for rootlet elsewhere(?) */
+ e = sc->rootlet; /* PERHAPS: this is a leftover from the days when () -> rootlet -- remove? */
+ 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);
+ }
+ return(sublet_1(sc, e, cdr(args), sc->sublet_symbol));
+}
+
+static s7_pointer g_sublet_curlet(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer sym = cadr(args), new_e;
+ check_method(sc, sc->curlet, sc->sublet_symbol, args);
+ new_e = inline_make_let_with_slot(sc, sc->curlet, sym, caddr(args));
+ set_all_methods(new_e, sc->curlet);
+ check_let_fallback(sc, sym, new_e);
+ return(new_e);
+}
+
+static s7_pointer sublet_chooser(s7_scheme *sc, s7_pointer f, int32_t num_args, s7_pointer expr)
+{
+ if (num_args == 3)
+ {
+ 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);
+ }
+ return(f);
+}
+
+
+/* -------------------------------- inlet -------------------------------- */
+s7_pointer s7_inlet(s7_scheme *sc, s7_pointer args)
+{
+ #define H_inlet "(inlet ...) adds its arguments, each a let, a cons: '(symbol . value), or a symbol/value pair, \
+to a new let, and returns the new let. (inlet :a 1 :b 2) or (inlet 'a 1 'b 2)"
+ #define Q_inlet s7_make_circular_signature(sc, 1, 2, sc->is_let_symbol, sc->T)
+ return(sublet_1(sc, sc->rootlet, args, sc->inlet_symbol));
+}
+
+#define g_inlet s7_inlet
+
+static s7_pointer g_simple_inlet(s7_scheme *sc, s7_pointer args)
+{
+ /* here all args are paired with normal symbol/value, no fallbacks, no immutable symbols, no syntax, etc */
+ s7_pointer new_e = make_let(sc, sc->rootlet);
+ int64_t id = let_id(new_e);
+ s7_pointer sp = NULL;
+
+ sc->temp3 = new_e;
+ for (s7_pointer x = args; is_pair(x); x = cddr(x))
+ {
+ s7_pointer symbol = car(x);
+ if (is_keyword(symbol)) /* (inlet ':allow-other-keys 3) */
+ symbol = keyword_symbol(symbol);
+ if (is_constant_symbol(sc, symbol)) /* (inlet 'pi 1) */
+ 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);
+ }
+ else sp = inline_add_slot_at_end(sc, id, sp, symbol, cadr(x));
+ }
+ sc->temp3 = sc->unused;
+ return(new_e);
+}
+
+static s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value)
+{
+ s7_pointer x;
+
+ if (!is_symbol(symbol))
+ return(sublet_1(sc, sc->rootlet, set_plist_2(sc, symbol, value), sc->inlet_symbol));
+ if (is_keyword(symbol))
+ symbol = keyword_symbol(symbol);
+ if (is_constant_symbol(sc, symbol))
+ wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, a_non_constant_symbol_string);
+ if ((is_global(symbol)) &&
+ (is_syntax_or_qq(global_value(symbol))))
+ wrong_type_error_nr(sc, sc->inlet_symbol, 1, symbol, wrap_string(sc, "a non-syntactic symbol", 22));
+
+ new_cell(sc, x, T_LET | T_SAFE_PROCEDURE);
+ sc->temp3 = x;
+ let_set_id(x, ++sc->let_number);
+ let_set_outlet(x, sc->rootlet);
+ let_set_slots(x, slot_end);
+ add_slot_unchecked(sc, x, symbol, value, let_id(x));
+ sc->temp3 = sc->unused;
+ return(x);
+}
+
+static s7_pointer internal_inlet(s7_scheme *sc, s7_int num_args, ...)
+{
+ va_list ap;
+ s7_pointer new_e = make_let(sc, sc->rootlet);
+ int64_t id = let_id(new_e);
+ s7_pointer sp = NULL;
+
+ sc->temp3 = new_e;
+ va_start(ap, num_args);
+ for (s7_int i = 0; i < num_args; i += 2)
+ {
+ 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);
+ }
+ else sp = inline_add_slot_at_end(sc, id, sp, symbol, value);
+ }
+ va_end(ap);
+ sc->temp3 = sc->unused;
+ return(new_e);
+}
+
+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))));
+}
+
+static s7_pointer inlet_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if ((args > 0) &&
+ ((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);
+ }
+ return(sc->simple_inlet);
+ }
+ return(f);
+}
+
+
+/* -------------------------------- let->list -------------------------------- */
+static s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list);
+
+static s7_pointer abbreviate_let(s7_scheme *sc, s7_pointer val)
+{
+ if (is_let(val))
+ return(make_symbol(sc, "<inlet...>", 11));
+ return(val);
+}
+
+s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let)
+{
+ s7_pointer x;
+ sc->temp3 = sc->w;
+ sc->w = sc->nil;
+
+ 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, 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);
+ sc->w = proper_list_reverse_in_place(sc, sc->w);
+ }
+ else
+ {
+ s7_pointer iter, func;
+ s7_int gc_loc = -1;
+ /* 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));
+ 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 (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);
+ 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);
+ }
+ sc->w = proper_list_reverse_in_place(sc, sc->w);
+ if (gc_loc != -1)
+ s7_gc_unprotect_at(sc, gc_loc);
+ }
+ x = sc->w;
+ sc->w = sc->temp3;
+ sc->temp3 = sc->unused;
+ return(x);
+}
+
+#if (!WITH_PURE_S7)
+static s7_pointer g_let_to_list(s7_scheme *sc, s7_pointer args)
+{
+ #define H_let_to_list "(let->list let) returns let's bindings as a list of cons's: '(symbol . value)."
+ #define Q_let_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_let_symbol)
+
+ s7_pointer let = car(args);
+ check_method(sc, let, sc->let_to_list_symbol, args);
+ if (!is_let(let))
+ {
+ if (is_c_object(let))
+ let = c_object_let(let);
+ else
+ 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));
+ if (!is_let(let))
+ sole_arg_wrong_type_error_nr(sc, sc->let_to_list_symbol, let, a_let_string);
+ }
+ return(s7_let_to_list(sc, let));
+}
+#endif
+
+
+/* -------------------------------- let-ref -------------------------------- */
+static s7_pointer call_let_ref_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol)
+{
+ s7_pointer p;
+ push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code);
+ /* (let ((x #f)) (let begin ((x 1234)) (begin 1) 2)) -> stack overflow eventually, but should we try to catch it? */
+ p = s7_apply_function(sc, find_method(sc, let, sc->let_ref_fallback_symbol), set_qlist_2(sc, let, symbol));
+ unstack_gc_protect(sc);
+ sc->code = T_Pos(stack_end_code(sc)); /* can be #<unused> */
+ sc->value = T_Ext(stack_end_args(sc));
+ return(p);
+}
+
+static s7_pointer call_let_set_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
+{
+ s7_pointer p;
+ push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code);
+ p = s7_apply_function(sc, find_method(sc, let, sc->let_set_fallback_symbol), set_qlist_3(sc, let, symbol, value));
+ unstack_gc_protect(sc);
+ sc->code = T_Pos(stack_end_code(sc));
+ sc->value = T_Ext(stack_end_args(sc));
+ return(p);
+}
+
+static /* inline */ s7_pointer let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol)
+{
+ /* (let ((a 1)) ((curlet) 'a)) or ((rootlet) 'abs) */
+ if (!is_let(let))
+ {
+ let = find_let(sc, let);
+ if (!is_let(let))
+ 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));
+ 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:
+ * any reference to the let will probably call let-ref somewhere, calling us again, and looping.
+ * This is not a problem in c-objects and funclets because c-object-ref and funclet-ref don't exist.
+ * After much wasted debugging, I decided to make let-ref and let-set! immutable.
+ */
+
+ if (is_keyword(symbol))
+ symbol = keyword_symbol(symbol);
+
+ if (let == sc->rootlet)
+ return((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined);
+
+ if (let_id(let) == symbol_id(symbol))
+ return(local_value(symbol)); /* this has to follow the rootlet check(?) */
+
+ 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));
+
+ if (is_openlet(let))
+ {
+ /* If a let is a mock-hash-table (for example), implicit indexing of the hash-table collides with the same thing for the let (field names
+ * 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((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined); /* (let () ((curlet) 'pi)) */
+}
+
+s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol) {return(let_ref(sc, let, symbol));}
+
+static s7_pointer g_let_ref(s7_scheme *sc, s7_pointer args)
+{
+ #define H_let_ref "(let-ref let sym) returns the value of the symbol sym in the let"
+ #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)));
+ return(let_ref(sc, car(args), cadr(args)));
+}
+
+static s7_pointer slot_in_let(s7_scheme *sc, s7_pointer e, const s7_pointer sym)
+{
+ for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(y))
+ if (slot_symbol(y) == sym)
+ return(y);
+ return(sc->undefined);
+}
+
+static s7_pointer let_ref_p_pp(s7_scheme *sc, s7_pointer lt, s7_pointer sym)
+{
+ if (lt == sc->rootlet) /* op_implicit_let_ref_c can pass rootlet */
+ return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined);
+ if (let_id(lt) == symbol_id(sym))
+ return(local_value(sym)); /* see add in tlet! */
+ 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));
+ 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);
+}
+
+static inline s7_pointer g_simple_let_ref(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer lt = car(args), sym = cadr(args);
+ if (!is_let(lt))
+ wrong_type_error_nr(sc, sc->let_ref_symbol, 1, lt, a_let_string);
+ if (lt == sc->rootlet)
+ return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined);
+ if (let_id(lt) == symbol_id(sym))
+ return(local_value(sym));
+ for (s7_pointer y = let_slots(lt); tis_slot(y); y = next_slot(y))
+ if (slot_symbol(y) == sym)
+ return(slot_value(y));
+ return(let_ref_p_pp(sc, let_outlet(lt), sym));
+}
+
+static s7_pointer let_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr)
+{
+ if (optimize_op(expr) == HOP_SAFE_C_opSq_C)
+ {
+ 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);
+ }}
+ return(f);
+}
+
+static bool op_implicit_let_ref_c(s7_scheme *sc)
+{
+ s7_pointer let = lookup_checked(sc, car(sc->code));
+ if (!is_let(let)) {sc->last_function = let; return(false);}
+ sc->value = let_ref_p_pp(sc, let, opt3_con(sc->code));
+ return(true);
+}
+
+static bool op_implicit_let_ref_a(s7_scheme *sc)
+{
+ s7_pointer sym, let = lookup_checked(sc, car(sc->code));
+ if (!is_let(let)) {sc->last_function = let; return(false);}
+ sym = fx_call(sc, cdr(sc->code));
+ if (is_symbol(sym))
+ sc->value = let_ref_p_pp(sc, let, (is_keyword(sym)) ? keyword_symbol(sym) : sym);
+ else sc->value = let_ref(sc, let, sym);
+ return(true);
+}
+
+static s7_pointer fx_implicit_let_ref_c(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer let = lookup_checked(sc, car(arg)); /* the let */
+ if (!is_let(let))
+ return(s7_apply_function(sc, let, list_1(sc, opt3_con(arg))));
+ return(let_ref_p_pp(sc, let, opt3_con(arg)));
+}
+
+
+/* -------------------------------- let-set! -------------------------------- */
+static s7_pointer let_set_1(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
+{
+ if (is_keyword(symbol))
+ symbol = keyword_symbol(symbol);
+
+ if (let == sc->rootlet)
+ {
+ 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);
+ /* 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));
+ 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));
+ 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...)...) */
+ symbol_increment_ctr(symbol);
+ slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, value) : value);
+ return(slot_value(slot));
+ }
+ if (is_unlet(let))
+ immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "unlet is immutable: (set! ((unlet) '~S) ~S)", 43), symbol, value));
+ if (let_id(let) == symbol_id(symbol))
+ {
+ s7_pointer slot = local_slot(symbol);
+ if (is_slot(slot))
+ {
+ 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));
+ }
+
+ 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));
+ /* not sure about this -- what's the most useful choice? */
+ return(call_let_set_fallback(sc, let, symbol, value));
+}
+
+static s7_pointer let_set_2(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
+{
+ if (!is_let(let))
+ wrong_type_error_nr(sc, sc->let_set_symbol, 1, let, a_let_string);
+ if (!is_symbol(symbol))
+ {
+ if ((let != sc->rootlet) && (has_let_set_fallback(let)))
+ 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) */
+ return(let_set_1(sc, let, symbol, value));
+}
+
+s7_pointer s7_let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) {return(let_set_2(sc, let, symbol, value));}
+
+static s7_pointer g_let_set(s7_scheme *sc, s7_pointer args)
+{
+ /* (let ((a 1)) (set! ((curlet) 'a) 32) a) */
+ #define H_let_set "(let-set! let sym val) sets the symbol sym's value in the let to val"
+ #define Q_let_set s7_make_signature(sc, 4, sc->T, sc->is_let_symbol, sc->is_symbol_symbol, sc->T)
+
+ 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));
+
+ return(let_set_2(sc, car(args), cadr(args), caddr(args)));
+}
+
+static s7_pointer let_set_p_ppp_2(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3)
+{
+ if (!is_symbol(p2))
+ wrong_type_error_nr(sc, sc->let_set_symbol, 2, p2, a_symbol_string);
+ return(let_set_1(sc, p1, p2, p3));
+}
+
+static s7_pointer g_simple_let_set(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer y, lt = car(args), sym = cadr(args), val = caddr(args);
+
+ if (!is_let(lt))
+ wrong_type_error_nr(sc, sc->let_set_symbol, 1, lt, a_let_string);
+ 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));
+ }
+ if ((lt != sc->rootlet) && (has_let_set_fallback(lt)))
+ return(call_let_set_fallback(sc, lt, sym, val));
+ }
+ y = global_slot(sym);
+ if (!is_slot(y))
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "let-set!: ~A is not defined in ~A", 33), sym, lt));
+ slot_set_value(y, (slot_has_setter(y)) ? call_setter(sc, y, val) : val);
+ return(slot_value(y));
+}
+
+static s7_pointer let_set_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr)
+{
+ if (optimize_op(expr) == HOP_SAFE_C_opSq_CS)
+ {
+ 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);
+ }
+ return(f);
+}
+
+
+static s7_pointer reverse_slots(s7_pointer list)
+{
+ s7_pointer p = list, result = slot_end;
+ while (tis_slot(p))
+ {
+ s7_pointer q = next_slot(p);
+ slot_set_next(p, result);
+ result = p;
+ p = q;
+ }
+ return(result);
+}
+
+static s7_pointer let_copy(s7_scheme *sc, s7_pointer let)
+{
+ s7_pointer new_e;
+
+ if (T_Let(let) == sc->rootlet) /* (copy (rootlet)) or (copy (funclet abs)) etc */
+ return(sc->rootlet);
+ /* we can't make copy handle lets-as-objects specially because the make-object function in define-class uses copy to make a new object!
+ * So if it is present, we get it here, and then there's almost surely trouble.
+ */
+ new_e = make_let(sc, let_outlet(let));
+ set_all_methods(new_e, let);
+ sc->temp3 = new_e;
+ if (tis_slot(let_slots(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;
+ }}
+ /* 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)))))
+ */
+ sc->temp3 = sc->unused;
+ return(new_e);
+}
+
+
+/* -------------------------------- rootlet -------------------------------- */
+static s7_pointer g_rootlet(s7_scheme *sc, s7_pointer unused)
+{
+ #define H_rootlet "(rootlet) returns the current top-level definitions (symbol bindings)."
+ #define Q_rootlet s7_make_signature(sc, 1, sc->is_let_symbol)
+ return(sc->rootlet);
+}
+/* as with the symbol-table, this function can lead to disaster -- user could
+ * clobber the let etc. But we want it to be editable and augmentable,
+ * so I guess I'll leave it alone. (See curlet|funclet as well).
+ */
+
+s7_pointer s7_rootlet(s7_scheme *sc) {return(sc->rootlet);}
+
+/* shadow_rootlet is a convenience for foreign function writers -- the C code can act as if it were loading everything into rootlet,
+ * but when actually loaded, everything can be shunted into a separate namespace (*motif* for example).
+ */
+s7_pointer s7_shadow_rootlet(s7_scheme *sc) {return(sc->shadow_rootlet);}
+
+s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let)
+{
+ s7_pointer old_let = sc->shadow_rootlet;
+ sc->shadow_rootlet = let;
+ return(old_let); /* like s7_set_curlet below */
+}
+
+
+/* -------------------------------- curlet -------------------------------- */
+s7_pointer s7_curlet(s7_scheme *sc) /* see also fx_curlet */
+{
+ sc->capture_let_counter++;
+ return(sc->curlet);
+}
+
+static s7_pointer g_curlet(s7_scheme *sc, s7_pointer unused_args)
+{
+ #define H_curlet "(curlet) returns the current definitions (symbol bindings)"
+ #define Q_curlet s7_make_signature(sc, 1, sc->is_let_symbol)
+ sc->capture_let_counter++;
+ return(sc->curlet);
+}
+
+static void update_symbol_ids(s7_scheme *sc, s7_pointer e)
+{
+ for (s7_pointer p = let_slots(e); tis_slot(p); p = next_slot(p))
+ {
+ s7_pointer sym = slot_symbol(p);
+ if (symbol_id(sym) != sc->let_number)
+ symbol_set_local_slot_unincremented(sym, sc->let_number, p);
+ }
+}
+
+s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e)
+{
+ s7_pointer old_e = sc->curlet;
+ set_curlet(sc, e);
+ if ((is_let(e)) && (let_id(e) > 0))
+ {
+ let_set_id(e, ++sc->let_number);
+ update_symbol_ids(sc, e);
+ }
+ return(old_e);
+}
+
+
+/* -------------------------------- outlet -------------------------------- */
+s7_pointer s7_outlet(s7_scheme *sc, s7_pointer let)
+{
+ return(let_outlet(let));
+}
+
+static s7_pointer outlet_p_p(s7_scheme *sc, s7_pointer let)
+{
+ if (!is_let(let))
+ sole_arg_wrong_type_error_nr(sc, sc->outlet_symbol, let, a_let_string); /* not a method call here! */
+ return((let == sc->rootlet) ? sc->rootlet : let_outlet(let));
+}
+
+static s7_pointer g_outlet(s7_scheme *sc, s7_pointer args)
+{
+ #define H_outlet "(outlet let) is the environment that contains let."
+ #define Q_outlet s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_let_symbol)
+ return(outlet_p_p(sc, car(args)));
+}
+
+
+static s7_pointer g_set_outlet(s7_scheme *sc, s7_pointer args)
+{
+ /* (let ((a 1)) (let ((b 2)) (set! (outlet (curlet)) (rootlet)) ((curlet) 'a))) */
+ s7_pointer let = car(args), new_outer;
+
+ if (!is_let(let))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! outlet", 11), 1, let, sc->type_names[T_LET]);
+ if (let == sc->s7_starlet)
+ error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't set! (outlet *s7*)", 24)));
+ if (is_immutable_let(let))
+ immutable_object_error_nr(sc, set_elist_4(sc, wrap_string(sc, "can't (set! (outlet ~S) ~S), ~S is immutable", 44), let, cadr(args), let));
+ new_outer = cadr(args);
+ if (!is_let(new_outer))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! outlet", 11), 2, new_outer, sc->type_names[T_LET]);
+ if (let != sc->rootlet)
+ {
+ /* 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));
+ let_set_outlet(let, new_outer);
+ }
+ return(new_outer);
+}
+
+/* -------------------------------- symbol lookup -------------------------------- */
+static Inline s7_pointer inline_lookup_from(s7_scheme *sc, const s7_pointer symbol, s7_pointer e)
+{ /* splitting out the no-sc WITH_GCC case made no difference in speed, same if using s7_int id = symbol_id(symbol) */
+ if (let_id(e) == symbol_id(symbol))
+ return(local_value(symbol));
+ if (let_id(e) > symbol_id(symbol)) /* let is newer so look back in the outlet chain */
+ {
+ do {e = let_outlet(e);} while (let_id(e) > symbol_id(symbol));
+ if (let_id(e) == symbol_id(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));
+
+ if (is_slot(global_slot(symbol)))
+ return(global_value(symbol));
+#if WITH_GCC
+ return(NULL); /* much faster than various alternatives */
+#else
+ return(unbound_variable(sc, symbol)); /* only use of sc */
+#endif
+}
+
+#if WITH_GCC && S7_DEBUGGING
+static s7_pointer lookup_1(s7_scheme *sc, const s7_pointer symbol)
+#else
+static inline s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol) /* lookup_checked includes the unbound_variable call */
+#endif
+{
+ return(inline_lookup_from(sc, symbol, sc->curlet));
+}
+
+static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer e)
+{
+ if (let_id(e) == symbol_id(symbol))
+ return(local_slot(symbol));
+ if (let_id(e) > symbol_id(symbol))
+ {
+ do {e = let_outlet(e);} while (let_id(e) > symbol_id(symbol));
+ if (let_id(e) == symbol_id(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(global_slot(symbol));
+}
+
+s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol) {return(lookup_slot_from(symbol, sc->curlet));}
+static s7_pointer lookup_slot_with_let(s7_scheme *sc, s7_pointer symbol, s7_pointer let) {return(lookup_slot_from(symbol, let));}
+
+s7_pointer s7_slot_value(s7_pointer slot) {return(slot_value(slot));}
+
+s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value) {slot_set_value(slot, value); return(value);}
+
+void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value) {set_real(slot_value(slot), value);}
+
+static s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer e)
+{
+ if ((!is_let(e)) || (e == sc->rootlet)) /* e is () if from s7_define */
+ return(global_slot(symbol));
+ 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(sc->undefined);
+}
+
+s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym)
+{
+ s7_pointer x = s7_slot(sc, sym);
+ return((is_slot(x)) ? slot_value(x) : sc->undefined);
+}
+
+s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer let)
+{
+ if (let_id(let) == symbol_id(sym))
+ return(local_value(sym));
+ if (let_id(let) > symbol_id(sym))
+ {
+ do {let = let_outlet(let);} while (let_id(let) > symbol_id(sym));
+ if (let_id(let) == symbol_id(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));
+
+ /* maybe let is local but sym is global but previously shadowed */
+ if (is_slot(global_slot(sym)))
+ return(global_value(sym));
+
+ /* (let ((e (curlet))) (let ((a 1)) (symbol->value 'a e))) -> #<undefined> not 1 */
+ return(sc->undefined); /* 29-Nov-17 */
+}
+
+
+/* -------------------------------- symbol->value -------------------------------- */
+#define lookup_global(Sc, Sym) ((is_global(Sym)) ? global_value(Sym) : lookup_checked(Sc, Sym))
+
+static s7_pointer s7_starlet(s7_scheme *sc, s7_int choice);
+
+static s7_pointer g_symbol_to_value(s7_scheme *sc, s7_pointer args)
+{
+ #define H_symbol_to_value "(symbol->value sym (let (curlet))) returns the binding of (the value associated with) the \
+symbol sym in the given let: (let ((x 32)) (symbol->value 'x)) -> 32"
+ #define Q_symbol_to_value s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, \
+ s7_make_signature(sc, 6, sc->is_let_symbol, sc->is_procedure_symbol, sc->is_c_pointer_symbol, \
+ sc->is_continuation_symbol, sc->is_goto_symbol, sc->is_macro_symbol)) /* kinda ridiculous */
+ /* (symbol->value 'x e) => (e 'x). But let? in sig is not quite right -- we accept closure -> closure-let etc */
+
+ s7_pointer sym = car(args);
+ if (!is_symbol(sym))
+ return(method_or_bust(sc, sym, sc->symbol_to_value_symbol, args, sc->type_names[T_SYMBOL], 1));
+ 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]);
+ 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);
+
+ 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 */
+ }
+ if (local_let == sc->s7_starlet)
+ return(s7_starlet(sc, s7_starlet_symbol(sym)));
+
+ return(s7_symbol_local_value(sc, sym, local_let));
+ }
+ if (is_global(sym))
+ return(global_value(sym));
+ return(s7_symbol_value(sc, sym));
+}
+
+s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val)
+{
+ s7_pointer x = s7_slot(sc, sym); /* if immutable should this return an error? */
+ if (is_slot(x))
+ slot_set_value(x, val); /* with_hook? */
+ return(val);
+}
+
+
+/* -------------------------------- symbol->dynamic-value -------------------------------- */
+static s7_pointer find_dynamic_value(s7_scheme *sc, s7_pointer x, s7_pointer sym, int64_t *id)
+{
+ for (; let_id(x) > symbol_id(sym); x = let_outlet(x));
+ if (let_id(x) == symbol_id(sym))
+ {
+ (*id) = let_id(x);
+ return(local_value(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));
+ }
+ return(sc->unused);
+}
+
+static s7_pointer g_symbol_to_dynamic_value(s7_scheme *sc, s7_pointer args)
+{
+ #define H_symbol_to_dynamic_value "(symbol->dynamic-value sym) returns the dynamic binding of the symbol sym"
+ #define Q_symbol_to_dynamic_value s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol)
+
+ s7_pointer sym = car(args), val;
+ int64_t top_id = -1;
+
+ if (!is_symbol(sym))
+ return(method_or_bust(sc, sym, sc->symbol_to_dynamic_value_symbol, args, sc->type_names[T_SYMBOL], 1));
+
+ if (is_global(sym))
+ return(global_value(sym));
+
+ if (let_id(sc->curlet) == symbol_id(sym))
+ return(local_value(sym));
+
+ val = find_dynamic_value(sc, sc->curlet, sym, &top_id);
+ if (top_id == symbol_id(sym))
+ return(val);
+
+ 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);
+ }
+ return((val == sc->unused) ? s7_symbol_value(sc, sym) : val);
+}
+
+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(false);
+}
+
+static bool direct_assq(const s7_pointer symbol, s7_pointer symbols)
+{ /* used only below in do_symbol_is_safe */
+ for (s7_pointer x = symbols; is_pair(x); x = cdr(x))
+ if (caar(x) == symbol)
+ return(true);
+ return(false);
+}
+
+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))));
+}
+
+static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e)
+{
+ if (is_slot(global_slot(sym)))
+ return(true);
+ if (e == sc->rootlet)
+ return(false);
+ return((!is_with_let_let(e)) && (is_slot(s7_slot(sc, sym))));
+}
+
+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)));
+}
+
+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)))));
+}
+
+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)));
+}
+
+static s7_pointer collect_variables(s7_scheme *sc, s7_pointer lst, s7_pointer e)
+{
+ /* collect local variable names from let/do (pre-error-check), 20 overhead in tgen -> 14 if cons_unchecked below */
+ sc->w = e;
+ for (s7_pointer p = lst; is_pair(p); p = cdr(p))
+ sc->w = cons(sc, add_symbol_to_list(sc, caar(p)), sc->w);
+ return(sc->w);
+}
+
+static s7_pointer collect_parameters(s7_scheme *sc, s7_pointer lst, s7_pointer e)
+{
+ /* collect local variable names from lambda arglists (pre-error-check) */
+ s7_pointer p;
+ s7_int the_un_id = ++sc->let_number;
+ if (is_symbol(lst))
+ {
+ symbol_set_id(lst, the_un_id);
+ return(cons(sc, add_symbol_to_list(sc, lst), e));
+ }
+ sc->w = e;
+ for (p = lst; is_pair(p); p = cdr(p))
+ {
+ s7_pointer car_p = car(p);
+ if (is_pair(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);
+ }}
+ if (is_symbol(p)) /* rest arg */
+ {
+ symbol_set_id(p, the_un_id);
+ sc->w = cons(sc, add_symbol_to_list(sc, p), sc->w);
+ }
+ return(sc->w);
+}
+
+typedef enum {OPT_F, OPT_T, OPT_OOPS} opt_t;
+static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e);
+
+static void clear_all_optimizations(s7_scheme *sc, s7_pointer p)
+{
+ /* I believe that we would not have been optimized to begin with if the tree were circular,
+ * and this tree is supposed to be a function call + args -- a circular list here is a bug.
+ */
+ 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);
+ }
+ clear_all_optimizations(sc, cdr(p));
+ clear_all_optimizations(sc, car(p));
+ }
+}
+
+static s7_pointer add_trace(s7_scheme *sc, s7_pointer code)
+{
+ if ((is_pair(car(code))) && (caar(code) == sc->trace_in_symbol))
+ return(code);
+ return(cons_unchecked(sc, list_2(sc, sc->trace_in_symbol, list_1(sc, sc->curlet_symbol)), code));
+}
+
+static s7_pointer add_profile(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer p;
+ if ((is_pair(car(code))) && (caar(code) == sc->profile_in_symbol))
+ return(code);
+ p = cons_unchecked(sc, list_3(sc, sc->profile_in_symbol, make_integer_unchecked(sc, sc->profile_position), list_1(sc, sc->curlet_symbol)), code);
+ sc->profile_position++;
+ set_unsafe_optimize_op(car(p), OP_PROFILE_IN);
+ return(p);
+}
+
+static bool tree_has_definers(s7_scheme *sc, s7_pointer tree)
+{
+ for (s7_pointer p = tree; is_pair(p); p = cdr(p))
+ if (tree_has_definers(sc, car(p)))
+ return(true);
+ return((is_symbol(tree)) && (is_definer(tree)));
+}
+
+static s7_pointer cur_op_to_caller(s7_scheme *sc, opcode_t op)
+{
+ switch (op)
+ {
+ case OP_DEFINE_MACRO: return(sc->define_macro_symbol);
+ case OP_DEFINE_MACRO_STAR: return(sc->define_macro_star_symbol);
+ case OP_DEFINE_BACRO: return(sc->define_bacro_symbol);
+ case OP_DEFINE_BACRO_STAR: return(sc->define_bacro_star_symbol);
+ case OP_DEFINE_EXPANSION: return(sc->define_expansion_symbol);
+ case OP_DEFINE_EXPANSION_STAR: return(sc->define_expansion_star_symbol);
+ case OP_MACRO: return(sc->macro_symbol);
+ case OP_MACRO_STAR: return(sc->macro_star_symbol);
+ case OP_BACRO: return(sc->bacro_symbol);
+ case OP_BACRO_STAR: return(sc->bacro_star_symbol);
+ }
+ if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: %s?\n", __func__, __LINE__, op_names[op]);
+ return(NULL);
+}
+
+static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named)
+{
+ s7_pointer mac, body, mac_name = NULL;
+ uint64_t typ;
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_truncated(sc->code));
+ switch (op)
+ {
+ case OP_DEFINE_MACRO: case OP_MACRO: typ = T_MACRO; break;
+ case OP_DEFINE_MACRO_STAR: case OP_MACRO_STAR: typ = T_MACRO_STAR; break;
+ case OP_DEFINE_BACRO: case OP_BACRO: typ = T_BACRO; break;
+ case OP_DEFINE_BACRO_STAR: case OP_BACRO_STAR: typ = T_BACRO_STAR; break;
+ case OP_DEFINE_EXPANSION: typ = T_MACRO | ((sc->curlet != sc->rootlet) ? 0 : T_EXPANSION); break; /* local expansions are just normal macros */
+ case OP_DEFINE_EXPANSION_STAR: typ = T_MACRO_STAR | ((sc->curlet != sc->rootlet) ? 0 : T_EXPANSION); break;
+ default:
+ if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: got %s\n", __func__, __LINE__, op_names[op]);
+ typ = T_MACRO;
+ break;
+ }
+ new_cell(sc, mac, typ | T_DONT_EVAL_ARGS);
+ closure_set_args(mac, (named) ? cdar(sc->code) : car(sc->code));
+ body = cdr(sc->code);
+ closure_set_body(mac, body);
+ closure_set_setter(mac, sc->F);
+ closure_set_let(mac, sc->curlet);
+ closure_set_arity(mac, CLOSURE_ARITY_NOT_SET);
+ sc->capture_let_counter++;
+ gc_protect_via_stack(sc, mac);
+
+ if (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));
+
+ /* 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);
+ }
+ 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 */
+ }
+
+ if ((!is_either_bacro(mac)) &&
+ (optimize(sc, body, 1, collect_parameters(sc, closure_args(mac), sc->nil)) == OPT_OOPS))
+ clear_all_optimizations(sc, body);
+
+ if (sc->debug > 1) /* no profile here */
+ closure_set_body(mac, add_trace(sc, body));
+
+ unstack_gc_protect(sc);
+ if (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));
+ }}
+ /* passed to maclet in apply_macro et al, copied in copy_closure */
+ return(mac);
+}
+
+static s7_pointer make_closure_unchecked(s7_scheme *sc, s7_pointer args, s7_pointer code, uint64_t type, int32_t arity)
+{
+ s7_pointer x;
+ new_cell_no_check(sc, x, (type | closure_bits(code)));
+ closure_set_args(x, args);
+ closure_set_let(x, sc->curlet);
+ closure_set_setter(x, sc->F);
+ closure_set_arity(x, arity);
+ closure_set_body(x, code);
+ if (is_pair(cdr(code))) set_closure_has_multiform(x); else set_closure_has_one_form(x);
+ sc->capture_let_counter++;
+ return(x);
+}
+
+static inline s7_pointer make_closure_gc_checked(s7_scheme *sc, s7_pointer args, s7_pointer code, uint64_t type, int32_t arity) /* inline 100=1% tgc, 35=2% texit */
+{
+ s7_pointer x;
+ new_cell(sc, x, (type | closure_bits(code)));
+ closure_set_args(x, args);
+ closure_set_let(x, sc->curlet);
+ closure_set_setter(x, sc->F);
+ closure_set_arity(x, arity);
+ closure_set_body(x, code);
+ if (is_pair(cdr(code))) set_closure_has_multiform(x); else set_closure_has_one_form(x);
+ sc->capture_let_counter++;
+ return(x);
+}
+
+static s7_pointer make_closure(s7_scheme *sc, s7_pointer args, s7_pointer code, uint64_t type, int32_t arity)
+{
+ /* this is called (almost?) every time a lambda form is evaluated, or during letrec, etc */
+ s7_pointer x;
+ new_cell(sc, x, (type | closure_bits(code)));
+ closure_set_args(x, args);
+ closure_set_let(x, sc->curlet);
+ closure_set_setter(x, sc->F);
+ closure_set_arity(x, arity);
+ closure_set_body(x, code); /* in case add_trace triggers GC, new func (x) needs some legit body for mark_closure */
+ if (sc->debug_or_profile)
+ {
+ gc_protect_via_stack(sc, x); /* GC protect func during add_trace */
+ closure_set_body(x, (sc->debug > 1) ? add_trace(sc, code) : add_profile(sc, code));
+ set_closure_has_multiform(x);
+ unstack_gc_protect(sc);
+ }
+ else
+ if (is_pair(cdr(code)))
+ set_closure_has_multiform(x);
+ else set_closure_has_one_form(x);
+ sc->capture_let_counter++;
+ return(x);
+}
+
+static int32_t closure_length(s7_scheme *sc, s7_pointer e)
+{
+ /* we can't use let_length(sc, closure_let(e)) because the closure_let(closure)
+ * changes. So the open bit is not always on. Besides, the fallbacks need to be for closures, not lets.
+ */
+ s7_pointer length_func = find_method(sc, closure_let(e), sc->length_symbol);
+ if (length_func != sc->undefined)
+ return((int32_t)s7_integer(s7_apply_function(sc, length_func, set_plist_1(sc, e))));
+ /* there are cases where this should raise a wrong-type-arg error, but for now... */
+ return(-1);
+}
+
+static s7_pointer cons_unchecked_with_type(s7_scheme *sc, s7_pointer p, s7_pointer a, s7_pointer b) /* (used only in copy_tree_with_type) */
+{
+ s7_pointer x;
+ new_cell_no_check(sc, x, full_type(p) & (TYPE_MASK | T_IMMUTABLE | T_SAFE_PROCEDURE));
+ set_car(x, a);
+ set_cdr(x, b);
+ return(x);
+}
+
+static s7_pointer copy_tree_with_type(s7_scheme *sc, s7_pointer tree)
+{
+ /* if sc->safety > NO_SAFETY, '(1 2) is set immutable by the reader, but eval (in that safety case) calls
+ * copy_body on the incoming tree, so we have to preserve T_IMMUTABLE in that case.
+ * if tree is something like (+ 1 (car '#1=(2 . #1#))), we have to see the quoted list and not copy it.
+ * Before getting here, we have checked that there is room for the entire tree (in copy_body), or 8192 cells (in list_values) in the free heap.
+ */
+#if WITH_GCC
+ #define COPY_TREE_WITH_TYPE(P) ({s7_pointer _p; _p = P; \
+ cons_unchecked_with_type(sc, _p, (is_unquoted_pair(car(_p))) ? copy_tree_with_type(sc, car(_p)) : car(_p), \
+ (is_unquoted_pair(cdr(_p))) ? copy_tree_with_type(sc, cdr(_p)) : cdr(_p));})
+#else
+ #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)));
+}
+
+static inline s7_pointer copy_tree(s7_scheme *sc, s7_pointer tree)
+{
+#if WITH_GCC
+ #define COPY_TREE(P) ({s7_pointer _p; _p = P; \
+ cons_unchecked(sc, (is_unquoted_pair(car(_p))) ? copy_tree(sc, car(_p)) : car(_p), \
+ (is_pair(cdr(_p))) ? copy_tree(sc, cdr(_p)) : cdr(_p));})
+#else
+ #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)));
+}
+
+
+/* -------------------------------- tree-cyclic? -------------------------------- */
+#define TREE_NOT_CYCLIC 0
+#define TREE_CYCLIC 1
+#define TREE_HAS_PAIRS 2
+
+static int32_t tree_is_cyclic_or_has_pairs(s7_scheme *sc, s7_pointer tree)
+{
+ s7_pointer fast = tree, slow = tree; /* we assume tree is a pair */
+ bool has_pairs = false;
+ while (true)
+ {
+ if (tree_is_collected(fast)) return(TREE_CYCLIC);
+ if ((!has_pairs) && (is_unquoted_pair(car(fast))))
+ has_pairs = true;
+ fast = cdr(fast);
+ if (!is_pair(fast))
+ {
+ 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;
+ fast = cdr(fast);
+ if (!is_pair(fast))
+ {
+ if (!has_pairs) return(TREE_NOT_CYCLIC);
+ break;
+ }
+ slow = cdr(slow);
+ if (fast == slow) return(TREE_CYCLIC);
+ }
+ return(TREE_HAS_PAIRS);
+}
+
+/* we can't use shared_info here because tree_is_cyclic may be called in the midst of output that depends on sc->circle_info */
+
+static bool tree_is_cyclic_1(s7_scheme *sc, s7_pointer tree)
+{
+ for (s7_pointer p = tree; is_pair(p); p = cdr(p))
+ {
+ 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));
+ }}
+ 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;
+ }}
+ return(false);
+}
+
+static bool tree_is_cyclic(s7_scheme *sc, s7_pointer tree)
+{
+ int32_t result;
+ if (!is_pair(tree)) return(false);
+ result = tree_is_cyclic_or_has_pairs(sc, tree);
+ if (result == TREE_NOT_CYCLIC) return(false);
+ if (result == TREE_CYCLIC) return(true);
+ result = tree_is_cyclic_1(sc, tree);
+ for (int32_t i = 0; i < sc->tree_pointers_top; i++)
+ tree_clear_collected(sc->tree_pointers[i]);
+ sc->tree_pointers_top = 0;
+ return(result);
+}
+
+static s7_pointer g_tree_is_cyclic(s7_scheme *sc, s7_pointer args)
+{
+ #define H_tree_is_cyclic "(tree-cyclic? tree) returns #t if the tree has a cycle."
+ #define Q_tree_is_cyclic sc->pl_bt
+ return(make_boolean(sc, tree_is_cyclic(sc, car(args))));
+}
+
+static inline s7_int tree_len(s7_scheme *sc, s7_pointer p);
+
+static s7_pointer copy_body(s7_scheme *sc, s7_pointer p)
+{
+ sc->w = p;
+ if (tree_is_cyclic(sc, p)) /* don't wrap this in is_safety_checked */
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "copy: tree is cyclic: ~S", 24), p));
+ check_free_heap_size(sc, tree_len(sc, p) * 2);
+ return((sc->safety > NO_SAFETY) ? copy_tree_with_type(sc, p) : copy_tree(sc, p));
+}
+
+static s7_pointer copy_closure(s7_scheme *sc, s7_pointer fnc)
+{
+ /* copy the source tree annotating (for eventual optimization), return a thing of the same type as fnc */
+ s7_pointer x, body = copy_body(sc, closure_body(fnc));
+ if ((is_any_macro(fnc)) && (has_pair_macro(fnc)))
+ {
+ set_pair_macro(body, pair_macro(closure_body(fnc)));
+ set_has_pair_macro(fnc);
+ }
+ new_cell(sc, x, full_type(fnc) & (~T_COLLECTED)); /* I'm paranoid about that is_collected bit */
+ closure_set_args(x, closure_args(fnc));
+ closure_set_body(x, body);
+ closure_set_setter(x, closure_setter(fnc));
+ closure_set_arity(x, closure_arity(fnc));
+ closure_set_let(x, closure_let(fnc));
+ return(x);
+}
+
+
+/* -------------------------------- defined? -------------------------------- */
+static s7_pointer g_is_defined(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_defined "(defined? symbol (let (curlet)) ignore-globals) returns #t if symbol has a binding (a value) in the let. \
+Only the let is searched if ignore-globals is not #f."
+ #define Q_is_defined s7_make_signature(sc, 4, sc->is_boolean_symbol, sc->is_symbol_symbol, \
+ s7_make_signature(sc, 5, sc->is_let_symbol, sc->is_procedure_symbol, sc->is_macro_symbol, \
+ sc->is_c_object_symbol, sc->is_c_pointer_symbol), sc->is_boolean_symbol)
+ /* if the symbol has a global slot and e is unset or rootlet, this returns #t */
+ s7_pointer sym = car(args);
+ if (!is_symbol(sym))
+ return(method_or_bust(sc, sym, sc->is_defined_symbol, args, sc->type_names[T_SYMBOL], 1));
+
+ if (is_pair(cdr(args)))
+ {
+ 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 */
+ }
+ 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*) */
+ }
+ if (e == sc->s7_starlet)
+ 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));
+ }
+ 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);
+ }
+ x = symbol_to_local_slot(sc, sym, e);
+ if (is_slot(x))
+ 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))));
+}
+
+static s7_pointer g_is_defined_in_rootlet(s7_scheme *sc, s7_pointer args) /* aimed at lint.scm */
+{
+ /* called because is_defined_chooser below noticed arg2=(rootlet) and no arg3 and arg1 is a normal symbol (not a keyword).
+ * since the chooser sets this up to be called via safe_c_nc, the args are unevalled when we get here.
+ * This is aimed at lint.scm which has stuff like (defined? head (rootlet)) a lot.
+ */
+ s7_pointer sym = lookup_checked(sc, car(args)); /* ok because we know car(args) is an unquoted symbol, lookup_checked for (defined? ... (rootlet)) */
+ if (!is_symbol(sym)) /* if sym is openlet with defined? perhaps it makes sense to call it, but we need to include the rootlet arg */
+ return(method_or_bust_pp(sc, sym, sc->is_defined_symbol, sym, sc->rootlet, sc->type_names[T_SYMBOL], 1));
+ return(make_boolean(sc, (is_keyword(sym)) || (is_slot(global_slot(sym)))));
+}
+
+static s7_pointer is_defined_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if ((args == 2) && (is_normal_symbol(cadr(expr)))) /* i.e. not a keyword */
+ {
+ 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);
+ }}
+ return(f);
+}
+
+bool s7_is_defined(s7_scheme *sc, const char *name)
+{
+ s7_pointer x = s7_symbol_table_find_name(sc, name);
+ if (!x) return(false);
+ return(is_slot(s7_slot(sc, x)));
+}
+
+static bool is_defined_b_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_symbol(p)) return(method_or_bust(sc, p, sc->is_defined_symbol, set_plist_1(sc, p), sc->type_names[T_SYMBOL], 1) != sc->F);
+ return(is_slot(s7_slot(sc, p)));
+}
+
+static bool is_defined_b_7pp(s7_scheme *sc, s7_pointer p, s7_pointer e) {return(g_is_defined(sc, set_plist_2(sc, p, e)) != sc->F);}
+
+
+void s7_define(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value)
+{
+ s7_pointer x;
+ if (let == sc->rootlet) let = sc->shadow_rootlet;
+ x = symbol_to_local_slot(sc, symbol, let); /* x can be #<undefined> */
+ if (is_slot(x))
+ slot_set_value_with_hook(x, value);
+ else
+ {
+ 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));
+ }}
+}
+
+s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value)
+{
+ s7_pointer sym = make_symbol_with_strlen(sc, name);
+ s7_define(sc, sc->rootlet, sym, value);
+ return(sym);
+}
+
+s7_pointer s7_define_variable_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help)
+{
+ s7_pointer sym = s7_define_variable(sc, name, value);
+ symbol_set_has_help(sym);
+ symbol_set_help(sym, copy_string(help));
+ add_saved_pointer(sc, symbol_help(sym));
+ return(sym);
+}
+
+s7_pointer s7_define_constant_with_environment(s7_scheme *sc, s7_pointer envir, const char *name, s7_pointer value)
+{
+ s7_pointer sym = make_symbol_with_strlen(sc, name);
+ s7_define(sc, envir, sym, value);
+ set_immutable(sym);
+ set_possibly_constant(sym);
+ set_immutable(global_slot(sym));
+ set_immutable(local_slot(sym));
+ return(sym);
+}
+
+s7_pointer s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value)
+{
+ return(s7_define_constant_with_environment(sc, sc->nil, name, value));
+}
+
+/* (define (func a) (let ((cvar (+ a 1))) cvar)) (define-constant cvar 23) (func 1) -> ;can't bind an immutable object: cvar
+ * (let ((aaa 1)) (define-constant aaa 32) (set! aaa 3)) -> set!: can't alter immutable object: aaa
+ */
+
+s7_pointer s7_define_constant_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help)
+{
+ s7_pointer sym = s7_define_constant(sc, name, value);
+ symbol_set_has_help(sym);
+ symbol_set_help(sym, copy_string(help));
+ add_saved_pointer(sc, symbol_help(sym));
+ return(value); /* inconsistent with variable above, but consistent with define_function? */
+}
+
+
+/* -------------------------------- keyword? -------------------------------- */
+bool s7_is_keyword(s7_pointer obj) {return(is_symbol_and_keyword(obj));}
+
+static s7_pointer g_is_keyword(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_keyword "(keyword? obj) returns #t if obj is a keyword, (keyword? :rest) -> #t"
+ #define Q_is_keyword sc->pl_bt
+ check_boolean_method(sc, is_symbol_and_keyword, sc->is_keyword_symbol, args);
+}
+
+
+/* -------------------------------- string->keyword -------------------------------- */
+s7_pointer s7_make_keyword(s7_scheme *sc, const char *key)
+{
+ s7_pointer sym;
+ size_t slen = (size_t)safe_strlen(key);
+ block_t *b = inline_mallocate(sc, slen + 2);
+ char *name = (char *)block_data(b);
+ name[0] = ':';
+ memcpy((void *)(name + 1), (const void *)key, slen);
+ name[slen + 1] = '\0';
+ sym = inline_make_symbol(sc, name, slen + 1); /* keyword slot etc taken care of here (in new_symbol actually) */
+ liberate(sc, b);
+ return(sym);
+}
+
+static s7_pointer g_string_to_keyword(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_to_keyword "(string->keyword str) prepends ':' to str and defines that as a keyword"
+ #define Q_string_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_string_symbol)
+
+ s7_pointer str = car(args);
+ if (!is_string(str))
+ return(sole_arg_method_or_bust(sc, str, sc->string_to_keyword_symbol, args, sc->type_names[T_STRING]));
+ if ((string_length(str) == 0) ||
+ (string_value(str)[0] == '\0'))
+ error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "string->keyword wants a non-null string: ~S", 43), str));
+ return(s7_make_keyword(sc, string_value(str)));
+}
+
+
+/* -------------------------------- keyword->symbol -------------------------------- */
+static s7_pointer g_keyword_to_symbol(s7_scheme *sc, s7_pointer args)
+{
+ #define H_keyword_to_symbol "(keyword->symbol key) returns a symbol with the same name as key but no prepended colon"
+ #define Q_keyword_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_keyword_symbol)
+
+ s7_pointer sym = car(args);
+ if (!is_symbol_and_keyword(sym))
+ return(method_or_bust_p(sc, sym, sc->keyword_to_symbol_symbol, wrap_string(sc, "a keyword", 9)));
+ return(keyword_symbol(sym));
+}
+
+s7_pointer s7_keyword_to_symbol(s7_scheme *sc, s7_pointer key) {return(keyword_symbol(key));}
+
+
+/* -------------------------------- symbol->keyword -------------------------------- */
+#define symbol_to_keyword(Sc, Sym) s7_make_keyword(Sc, symbol_name(Sym))
+
+static s7_pointer g_symbol_to_keyword(s7_scheme *sc, s7_pointer args)
+{
+ #define H_symbol_to_keyword "(symbol->keyword sym) returns a keyword with the same name as sym, but with a colon prepended"
+ #define Q_symbol_to_keyword s7_make_signature(sc, 2, sc->is_keyword_symbol, sc->is_symbol_symbol)
+
+ if (!is_symbol(car(args)))
+ return(sole_arg_method_or_bust(sc, car(args), sc->symbol_to_keyword_symbol, args, sc->type_names[T_SYMBOL]));
+ return(symbol_to_keyword(sc, car(args)));
+}
+
+
+/* -------------------------------- c-pointer? -------------------------------- */
+bool s7_is_c_pointer(s7_pointer arg) {return(is_c_pointer(arg));}
+
+bool s7_is_c_pointer_of_type(s7_pointer arg, s7_pointer type) {return((is_c_pointer(arg)) && (c_pointer_type(arg) == type));}
+
+static s7_pointer g_is_c_pointer(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_c_pointer "(c-pointer? obj type) returns #t if obj is a C pointer being held in s7. \
+If type is given, the c_pointer's type is also checked."
+ #define Q_is_c_pointer s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->T)
+
+ s7_pointer p = car(args);
+ if (is_c_pointer(p))
+ return((is_pair(cdr(args))) ? make_boolean(sc, c_pointer_type(p) == cadr(args)) : sc->T);
+ if (!has_active_methods(sc, p)) return(sc->F);
+ return(apply_boolean_method(sc, p, sc->is_c_pointer_symbol));
+}
+
+
+/* -------------------------------- c-pointer -------------------------------- */
+void *s7_c_pointer(s7_pointer p) {return(c_pointer(p));}
+
+void *s7_c_pointer_with_type(s7_scheme *sc, s7_pointer p, s7_pointer expected_type, const char *caller, s7_int argnum)
+{
+ if (!is_c_pointer(p))
+ wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), argnum, p, sc->type_names[T_C_POINTER]);
+ 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));
+ return(c_pointer(p));
+}
+
+s7_pointer s7_make_c_pointer_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_C_POINTER);
+ c_pointer(x) = ptr;
+ c_pointer_type(x) = type;
+ c_pointer_info(x) = info;
+ c_pointer_weak1(x) = sc->F;
+ c_pointer_weak2(x) = sc->F;
+ return(x);
+}
+
+s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr) {return(s7_make_c_pointer_with_type(sc, ptr, sc->F, sc->F));}
+
+#define NUM_C_POINTER_WRAPPERS 16 /* need at least 9 for gsl */
+
+s7_pointer s7_make_c_pointer_wrapper_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info)
+{
+ s7_pointer x = car(sc->c_pointer_wrappers);
+#if S7_DEBUGGING
+ if ((full_type(x) & (~T_GC_MARK)) != (T_C_POINTER | T_IMMUTABLE | T_UNHEAP)) fprintf(stderr, "%s\n", describe_type_bits(sc, x));
+#endif
+ sc->c_pointer_wrappers = cdr(sc->c_pointer_wrappers);
+ c_pointer(x) = ptr;
+ c_pointer_type(x) = type;
+ c_pointer_info(x) = info;
+ c_pointer_weak1(x) = sc->F;
+ c_pointer_weak2(x) = sc->F;
+ return(x);
+}
+
+static s7_pointer g_c_pointer(s7_scheme *sc, s7_pointer args)
+{
+ #define H_c_pointer "(c-pointer int type info weak1 weak2) returns a c-pointer object. The type and info args are optional, defaulting to #f."
+ #define Q_c_pointer s7_make_circular_signature(sc, 2, 3, sc->is_c_pointer_symbol, sc->is_integer_symbol, sc->T)
+
+ s7_pointer arg = car(args), type = sc->F, info = sc->F, weak1 = sc->F, weak2 = sc->F, cp;
+ intptr_t p;
+
+ if (!s7_is_integer(arg))
+ return(method_or_bust(sc, arg, sc->c_pointer_symbol, args, sc->type_names[T_INTEGER], 1));
+ p = (intptr_t)s7_integer_clamped_if_gmp(sc, arg); /* (c-pointer (bignum "1234")) */
+ args = cdr(args);
+ if (is_pair(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);
+ }}}
+ cp = s7_make_c_pointer_with_type(sc, (void *)p, type, info);
+ c_pointer_set_weak1(cp, weak1);
+ c_pointer_set_weak2(cp, weak2);
+ if ((weak1 != sc->F) || (weak2 != sc->F))
+ add_weak_ref(sc, cp);
+ return(cp);
+}
+
+
+/* -------------------------------- c-pointer-info -------------------------------- */
+static s7_pointer c_pointer_info_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_c_pointer(p))
+ return(method_or_bust_p(sc, p, sc->c_pointer_info_symbol, sc->type_names[T_C_POINTER]));
+ return(c_pointer_info(p));
+}
+
+static s7_pointer g_c_pointer_info(s7_scheme *sc, s7_pointer args)
+{
+ #define H_c_pointer_info "(c-pointer-info obj) returns the c-pointer info field"
+ #define Q_c_pointer_info s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol)
+ return(c_pointer_info_p_p(sc, car(args)));
+}
+
+
+/* -------------------------------- c-pointer-type -------------------------------- */
+static s7_pointer method_or_bust_lp(s7_scheme *sc, s7_pointer obj, s7_pointer method, uint8_t typ)
+{ /* weird -- overhead goes berserk in callgrind if using the simpler method_or_bust_p! */
+ if (!has_active_methods(sc, obj))
+ wrong_type_error_nr(sc, method, 1, obj, sc->type_names[typ]);
+ return(find_and_apply_method(sc, obj, method, set_plist_1(sc, obj)));
+}
+
+s7_pointer s7_c_pointer_type(s7_pointer p) {return((is_c_pointer(p)) ? c_pointer_type(p) : NULL);}
+
+static s7_pointer c_pointer_type_p_p(s7_scheme *sc, s7_pointer p)
+{
+ return((is_c_pointer(p)) ? c_pointer_type(p) : method_or_bust_lp(sc, p, sc->c_pointer_type_symbol, T_C_POINTER));
+}
+
+static s7_pointer g_c_pointer_type(s7_scheme *sc, s7_pointer args)
+{
+ #define H_c_pointer_type "(c-pointer-type obj) returns the c-pointer type field"
+ #define Q_c_pointer_type s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol)
+ return(c_pointer_type_p_p(sc, car(args)));
+}
+
+
+/* -------------------------------- c-pointer-weak1/2 -------------------------------- */
+static s7_pointer c_pointer_weak1_p_p(s7_scheme *sc, s7_pointer p)
+{
+ return((is_c_pointer(p)) ? c_pointer_weak1(p) : method_or_bust_lp(sc, p, sc->c_pointer_weak1_symbol, T_C_POINTER));
+}
+
+static s7_pointer g_c_pointer_weak1(s7_scheme *sc, s7_pointer args)
+{
+ #define H_c_pointer_weak1 "(c-pointer-weak1 obj) returns the c-pointer weak1 field"
+ #define Q_c_pointer_weak1 s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol)
+ return(c_pointer_weak1_p_p(sc, car(args)));
+}
+
+static s7_pointer c_pointer_weak2_p_p(s7_scheme *sc, s7_pointer p)
+{
+ return((is_c_pointer(p)) ? c_pointer_weak2(p) : method_or_bust_lp(sc, p, sc->c_pointer_weak2_symbol, T_C_POINTER));
+}
+
+static s7_pointer g_c_pointer_weak2(s7_scheme *sc, s7_pointer args)
+{
+ #define H_c_pointer_weak2 "(c-pointer-weak2 obj) returns the c-pointer weak2 field"
+ #define Q_c_pointer_weak2 s7_make_signature(sc, 2, sc->T, sc->is_c_pointer_symbol)
+ return(c_pointer_weak2_p_p(sc, car(args)));
+}
+
+
+/* -------------------------------- c-pointer->list -------------------------------- */
+static s7_pointer g_c_pointer_to_list(s7_scheme *sc, s7_pointer args)
+{
+ #define H_c_pointer_to_list "(c-pointer->list obj) returns the c-pointer data as (list pointer-as-int type info)"
+ #define Q_c_pointer_to_list s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_c_pointer_symbol)
+
+ s7_pointer p = car(args);
+ if (!is_c_pointer(p))
+ return(method_or_bust(sc, p, sc->c_pointer_to_list_symbol, args, sc->type_names[T_C_POINTER], 1));
+ return(list_3(sc, make_integer(sc, (s7_int)((intptr_t)c_pointer(p))), c_pointer_type(p), c_pointer_info(p)));
+}
+
+
+/* -------------------------------- continuations and gotos -------------------------------- */
+
+/* ----------------------- continuation? -------------------------------- */
+static s7_pointer g_is_continuation(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_continuation "(continuation? obj) returns #t if obj is a continuation"
+ #define Q_is_continuation sc->pl_bt
+ check_boolean_method(sc, is_continuation, sc->is_continuation_symbol, args);
+ /* is this the right thing? It returns #f for call-with-exit ("goto") because
+ * that form of continuation can't continue (via a jump back to its context).
+ */
+}
+
+static bool is_continuation_b_p(s7_pointer p) {return(is_continuation(p));}
+
+#if S7_DEBUGGING
+static s7_pointer check_wrap_return(s7_pointer lst)
+{
+ for (s7_pointer fast = lst, slow = lst; is_pair(fast); slow = cdr(slow), fast = cdr(fast))
+ {
+ if (is_matched_pair(fast)) fprintf(stderr, "matched_pair not cleared\n");
+ fast = cdr(fast);
+ if (!is_pair(fast)) return(lst);
+ if (fast == slow) return(lst);
+ if (is_matched_pair(fast)) fprintf(stderr, "matched_pair not cleared\n");
+ }
+ return(lst);
+}
+#endif
+
+static s7_pointer copy_any_list(s7_scheme *sc, s7_pointer a)
+{
+ s7_pointer slow = cdr(a);
+ s7_pointer fast = slow;
+ s7_pointer p;
+#if S7_DEBUGGING
+ #define wrap_return(W) do {fast = W; W = sc->unused; sc->y = sc->unused; return(check_wrap_return(fast));} while (0)
+#else
+ #define wrap_return(W) do {fast = W; W = sc->unused; sc->y = sc->unused; return(fast);} while (0)
+#endif
+ init_temp(sc->y, a); /* gc_protect_via_stack doesn't work here because we're called in copy_stack, I think (trouble is in call/cc stuff) */
+ sc->w = list_1(sc, car(a));
+ p = sc->w;
+ while (true)
+ {
+ if (!is_pair(fast))
+ {
+ 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 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);
+ }}
+ wrap_return(sc->w);
+}
+
+static s7_pointer copy_counter(s7_scheme *sc, s7_pointer obj)
+{
+ s7_pointer nobj;
+ new_cell(sc, nobj, T_COUNTER);
+ counter_set_result(nobj, counter_result(obj));
+ counter_set_list(nobj, counter_list(obj));
+ counter_set_capture(nobj, counter_capture(obj));
+ counter_set_let(nobj, counter_let(obj));
+ counter_set_slots(nobj, counter_slots(obj));
+ return(nobj);
+}
+
+static void copy_stack_list_set_immutable(s7_pointer pold, s7_pointer pnew)
+{
+ for (s7_pointer p1 = pold, p2 = pnew, slow = pold; is_pair(p2); p1 = cdr(p1), p2 = cdr(p2))
+ {
+ 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);
+ }}
+}
+
+static s7_pointer copy_stack(s7_scheme *sc, s7_pointer new_v, s7_pointer old_v, int64_t top)
+{
+ bool has_pairs = false;
+ s7_pointer *nv = stack_elements(new_v);
+ s7_pointer *ov = stack_elements(old_v);
+ memcpy((void *)nv, (void *)ov, top * sizeof(s7_pointer));
+ stack_clear_flags(new_v);
+
+ s7_gc_on(sc, false);
+ 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);
+ }}}
+ 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]);
+ }
+ if (has_pairs) stack_set_has_pairs(new_v);
+ s7_gc_on(sc, true);
+ return(new_v);
+}
+
+static s7_pointer copy_op_stack(s7_scheme *sc)
+{
+ int32_t len = (int32_t)(sc->op_stack_now - sc->op_stack);
+ s7_pointer nv = make_simple_vector(sc, len); /* not sc->op_stack_size */
+ if (len > 0)
+ {
+ s7_pointer *src = sc->op_stack;
+ s7_pointer *dst = (s7_pointer *)vector_elements(nv);
+ for (int32_t i = len; i > 0; i--) *dst++ = *src++;
+ }
+ return(nv);
+}
+
+/* -------------------------------- with-baffle -------------------------------- */
+/* (with-baffle . body) calls body guaranteeing that there can be no jumps into the
+ * middle of it from outside -- no outer evaluation of a continuation can jump across this
+ * barrier: The flip-side of call-with-exit.
+ */
+
+static bool find_baffle(s7_scheme *sc, s7_int key)
+{
+ /* search backwards through sc->curlet for baffle_let with (continuation_)key as its baffle_key value */
+ 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);
+ return(false);
+}
+
+#define NOT_BAFFLED -1
+
+static s7_int find_any_baffle(s7_scheme *sc)
+{
+ /* search backwards through sc->curlet for any sc->baffle_symbol -- called by s7_make_continuation to set continuation_key */
+ 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(NOT_BAFFLED);
+}
+
+static void check_with_baffle(s7_scheme *sc)
+{
+ if (!s7_is_proper_list(sc, sc->code))
+ syntax_error_nr(sc, "with-baffle: unexpected dot? ~A", 31, sc->code);
+ pair_set_syntax_op(sc->code, OP_WITH_BAFFLE_UNCHECKED);
+}
+
+static bool op_with_baffle_unchecked(s7_scheme *sc)
+{
+ sc->code = cdr(sc->code);
+ if (is_null(sc->code))
+ {
+ sc->value = sc->nil;
+ return(true);
+ }
+ set_curlet(sc, make_let(sc, sc->curlet));
+ set_baffle_let(sc->curlet);
+ set_let_baffle_key(sc->curlet, sc->baffle_ctr++);
+ return(false);
+}
+
+
+/* -------------------------------- call/cc -------------------------------- */
+static void make_room_for_cc_stack(s7_scheme *sc)
+{
+ if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 8)) /* we probably never need this much space */
+ {
+ call_gc(sc);
+ if ((int64_t)(sc->free_heap_top - sc->free_heap) < (int64_t)(sc->heap_size / 8))
+ resize_heap(sc);
+ }
+}
+
+s7_pointer s7_make_continuation(s7_scheme *sc)
+{
+ s7_pointer x, stack;
+ int64_t loc;
+ block_t *block;
+
+ sc->continuation_counter++;
+ make_room_for_cc_stack(sc);
+ if (sc->continuation_counter > 2000) call_gc(sc); /* call_gc zeros cc counter, gc time up, but run time down -- try big cache */
+
+ loc = stack_top(sc);
+ stack = make_simple_vector(sc, loc);
+ set_full_type(stack, T_STACK);
+ temp_stack_top(stack) = loc;
+ sc->temp7 = stack;
+ copy_stack(sc, stack, sc->stack, loc);
+
+ new_cell(sc, x, T_CONTINUATION);
+ block = mallocate_block(sc);
+ continuation_block(x) = block;
+ continuation_set_stack(x, stack);
+ continuation_stack_size(x) = vector_length(continuation_stack(x));
+ continuation_stack_start(x) = stack_elements(continuation_stack(x));
+ continuation_stack_end(x) = (s7_pointer *)(continuation_stack_start(x) + loc);
+ continuation_op_stack(x) = copy_op_stack(sc);
+ continuation_op_loc(x) = (int32_t)(sc->op_stack_now - sc->op_stack);
+ continuation_op_size(x) = sc->op_stack_size;
+ continuation_key(x) = find_any_baffle(sc);
+ continuation_name(x) = sc->F;
+ sc->temp7 = sc->unused;
+
+ add_continuation(sc, x);
+ return(x);
+}
+
+static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer let);
+static void let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value);
+static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val);
+
+static bool check_for_dynamic_winds(s7_scheme *sc, s7_pointer c)
+{
+ /* called only from call_with_current_continuation.
+ * if call/cc jumps into a dynamic-wind, the init/finish funcs are wrapped in with-baffle
+ * so they'll complain. Otherwise we're supposed to re-run the init func before diving
+ * into the body. Similarly for let-temporarily. If a call/cc jumps out of a dynamic-wind
+ * body-func, we're supposed to call the finish-func. The continuation is called at
+ * stack_top(sc); the continuation form is at continuation_stack_top(c).
+ *
+ * check sc->stack for dynamic-winds we're jumping out of
+ * we need to check from the current stack top down to where the continuation stack matches the current stack??
+ * this was (i > 0), but that goes too far back; perhaps s7 should save the position of the call/cc invocation.
+ * also the two stacks can be different sizes (either can be larger)
+ */
+ int64_t top1 = stack_top(sc), top2 = continuation_stack_top(c);
+ for (int64_t i = top1 - 1; (i > 0) && ((i >= top2) || (stack_code(sc->stack, i) != stack_code(continuation_stack(c), i))); i -= 4)
+ {
+ 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;
+ }}
+
+ /* 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;
+ }
+ else
+ 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
+ * on re-entry; that strikes me as incoherently complex -- they've wrapped a hidden dynamic-wind around the
+ * call/cc to restore all let-temp vars! I think let-temp here should be the same as let -- if you jump back
+ * in, nothing hidden happens. So,
+ * (let ((x #f) (cc #f))
+ * (let-temporarily ((x 1))
+ * (set! x 2) (call/cc (lambda (r) (set! cc r))) (display x) (unless (= x 2) (newline) (exit)) (set! x 3) (cc)))
+ * behaves the same (in this regard) if let-temp is replaced with let.
+ */
+ }
+ return(true);
+}
+
+static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args);
+
+static void call_with_current_continuation(s7_scheme *sc)
+{
+ s7_pointer c = sc->code; /* sc->args are the returned values */
+
+ /* check for (baffle ...) blocking the current attempt to continue */
+ 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)));
+
+ 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));
+ }
+ 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));
+ }
+ /* 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];
+ }
+ sc->value = (is_null(sc->args)) ? sc->nil : ((is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc, sc->args));
+ }
+}
+
+static s7_pointer g_call_cc(s7_scheme *sc, s7_pointer args)
+{
+ #define H_call_cc "(call-with-current-continuation (lambda (continuer)...)) is always a mistake!"
+ #define Q_call_cc s7_make_signature(sc, 2, sc->T, sc->is_procedure_symbol)
+
+ s7_pointer p = car(args); /* this is the procedure passed to call/cc */
+ if (!is_t_procedure(p)) /* this includes continuations */
+ {
+ check_method(sc, p, sc->call_cc_symbol, args);
+ check_method(sc, p, sc->call_with_current_continuation_symbol, args);
+ sole_arg_wrong_type_error_nr(sc, sc->call_cc_symbol, p, a_procedure_string);
+ }
+ if (((!is_closure(p)) ||
+ (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));
+
+ sc->w = s7_make_continuation(sc);
+ if ((is_any_closure(p)) && (is_pair(closure_args(p))) && (is_symbol(car(closure_args(p)))))
+ continuation_name(sc->w) = car(closure_args(p));
+ push_stack(sc, OP_APPLY, list_1_unchecked(sc, sc->w), p); /* apply function p to continuation sc->w */
+ sc->w = sc->unused;
+ return(sc->nil);
+}
+
+/* we can't naively optimize call/cc to call-with-exit if the continuation is only
+ * used as a function in the call/cc body because it might (for example) be wrapped
+ * in a lambda form that is being exported. See b-func in s7test for an example.
+ */
+
+static void op_call_cc(s7_scheme *sc)
+{
+ sc->w = s7_make_continuation(sc);
+ continuation_name(sc->w) = caar(opt2_pair(sc->code)); /* caadadr(sc->code) */
+ set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, continuation_name(sc->w), sc->w));
+ sc->w = sc->unused;
+ sc->code = cdr(opt2_pair(sc->code)); /* cddadr(sc->code) */
+}
+
+static bool op_implicit_continuation_a(s7_scheme *sc)
+{
+ s7_pointer code = sc->code; /* dumb-looking code, but it's faster than the pretty version, according to callgrind */
+ s7_pointer s = lookup_checked(sc, car(code));
+ if (!is_continuation(s)) {sc->last_function = s; return(false);}
+ sc->code = s;
+ sc->args = set_plist_1(sc, fx_call(sc, cdr(code)));
+ call_with_current_continuation(sc);
+ return(true);
+}
+
+
+/* -------------------------------- call-with-exit -------------------------------- */
+static void pop_input_port(s7_scheme *sc);
+static s7_pointer dynamic_unwind(s7_scheme *sc, s7_pointer func, s7_pointer e);
+
+static void call_with_exit(s7_scheme *sc)
+{
+ int64_t i, new_stack_top, quit = 0;
+
+ 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)));
+
+ call_exit_active(sc->code) = false;
+ new_stack_top = call_exit_goto_loc(sc->code);
+ sc->op_stack_now = (s7_pointer *)(sc->op_stack + call_exit_op_loc(sc->code));
+
+ /* look for dynamic-wind in the stack section that we are jumping out of */
+ i = stack_top(sc) - 1;
+ do {
+ 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;
+
+ 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;
+
+ case OP_EVAL_STRING:
+ 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;
+
+ 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;
+
+ 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;
+
+ 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;
+
+ /* 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;
+
+ 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;
+
+ case OP_EVAL_DONE: /* goto called in a method -- put off the inner eval return(s) until we clean up the stack */
+ 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;
+ }
+ i -= 4;
+ } while (i > new_stack_top);
+
+ SET_VALUE:
+ sc->stack_end = (s7_pointer *)(sc->stack_start + new_stack_top);
+
+ /* the return value should have an implicit values call, just as in call/cc */
+ sc->value = (is_null(sc->args)) ? sc->nil : ((is_null(cdr(sc->args))) ? car(sc->args) : splice_in_values(sc, sc->args));
+ if (quit > 0)
+ {
+ if (sc->longjmp_ok)
+ {
+ 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);
+ }
+}
+
+static s7_pointer g_is_goto(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_goto "(goto? obj) returns #t if obj is a call-with-exit exit function"
+ #define Q_is_goto sc->pl_bt
+ return(make_boolean(sc, is_goto(car(args))));
+}
+
+static inline s7_pointer make_goto(s7_scheme *sc, s7_pointer name) /* inline for 73=1% in tgc */
+{
+ s7_pointer x;
+ new_cell(sc, x, T_GOTO);
+ call_exit_goto_loc(x) = stack_top(sc);
+ call_exit_op_loc(x) = (int32_t)(sc->op_stack_now - sc->op_stack);
+ call_exit_active(x) = true;
+ call_exit_name(x) = name;
+ return(x);
+}
+
+static s7_pointer g_call_with_exit(s7_scheme *sc, s7_pointer args) /* (call-with-exit (lambda (return) ...)) */
+{
+ #define H_call_with_exit "(call-with-exit (lambda (exiter) ...)) is call/cc without the ability to jump back into a previous computation."
+ #define Q_call_with_exit s7_make_signature(sc, 2, sc->values_symbol, sc->is_procedure_symbol)
+
+ s7_pointer p = car(args), x;
+ if (is_any_closure(p)) /* lambda or lambda* */
+ {
+ x = make_goto(sc, ((is_pair(closure_args(p))) && (is_symbol(car(closure_args(p))))) ? car(closure_args(p)) : sc->F);
+ push_stack(sc, OP_DEACTIVATE_GOTO, x, p); /* this means call-with-exit is not tail-recursive */
+ push_stack(sc, OP_APPLY, cons_unchecked(sc, x, sc->nil), p);
+ return(sc->nil);
+ }
+ /* maybe just return an error here -- these gotos as args are stupid; also an error above if closure not aritable 1 */
+ if (!is_t_procedure(p))
+ 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));
+ 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));
+ 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)));
+}
+
+static inline void op_call_with_exit(s7_scheme *sc)
+{
+ s7_pointer args = opt2_pair(sc->code);
+ s7_pointer go = make_goto(sc, caar(args));
+ push_stack_no_let_no_code(sc, OP_DEACTIVATE_GOTO, go); /* was also pushing code */
+ set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caar(args), go));
+ sc->code = T_Pair(cdr(args));
+}
+
+static void op_call_with_exit_o(s7_scheme *sc)
+{
+ op_call_with_exit(sc);
+ sc->code = car(sc->code);
+}
+
+static bool op_implicit_goto(s7_scheme *sc)
+{
+ s7_pointer g = lookup_checked(sc, car(sc->code));
+ if (!is_goto(g)) {sc->last_function = g; return(false);}
+ sc->args = sc->nil;
+ sc->code = g;
+ call_with_exit(sc);
+ return(true);
+}
+
+static bool op_implicit_goto_a(s7_scheme *sc)
+{
+ s7_pointer g = lookup_checked(sc, car(sc->code));
+ if (!is_goto(g)) {sc->last_function = g; return(false);}
+ sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code)));
+ sc->code = g;
+ call_with_exit(sc);
+ return(true);
+}
+
+
+/* -------------------------------- numbers -------------------------------- */
+static block_t *string_to_block(s7_scheme *sc, const char *p, s7_int len)
+{
+ block_t *b = inline_mallocate(sc, len + 1);
+ char *bp = (char *)block_data(b);
+ memcpy((void *)bp, (const void *)p, len);
+ bp[len] = '\0';
+ return(b);
+}
+
+static Inline s7_pointer inline_block_to_string(s7_scheme *sc, block_t *block, s7_int len)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_STRING | T_SAFE_PROCEDURE);
+ string_block(x) = block;
+ string_value(x) = (char *)block_data(block);
+ string_length(x) = len;
+ string_value(x)[len] = '\0';
+ string_hash(x) = 0;
+ add_string(sc, x);
+ return(x);
+}
+
+static s7_pointer block_to_string(s7_scheme *sc, block_t *block, s7_int len) {return(inline_block_to_string(sc, block, len));}
+
+static inline s7_pointer make_simple_ratio(s7_scheme *sc, s7_int num, s7_int den)
+{
+ s7_pointer x;
+ if (den == 1)
+ return(make_integer(sc, num));
+ if (den == -1)
+ return(make_integer(sc, -num));
+ if ((den == S7_INT64_MIN) && ((num & 1) != 0))
+ return(make_real(sc, (long_double)num / (long_double)den));
+ new_cell(sc, x, T_RATIO);
+ if (den < 0) /* this is noticeably faster in callgrind than using (den < 0) ? ... twice */
+ {
+ set_numerator(x, -num);
+ set_denominator(x, -den);
+ }
+ else
+ {
+ set_numerator(x, num);
+ set_denominator(x, den);
+ }
+ return(x);
+}
+
+static bool is_zero(s7_pointer x);
+static bool is_positive(s7_scheme *sc, s7_pointer x);
+static bool is_negative(s7_scheme *sc, s7_pointer x);
+static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b);
+
+static bool is_NaN(s7_double x) {return(x != x);}
+/* callgrind says this is faster than isnan, I think (very confusing data...) */
+
+#if defined(__sun) && defined(__SVR4)
+ static bool is_inf(s7_double x) {return((x == x) && (is_NaN(x - x)));} /* there's no isinf in Solaris */
+#else
+#if (!MS_WINDOWS)
+ #if __cplusplus
+ #define is_inf(x) std::isinf(x)
+ #else
+ #define is_inf(x) isinf(x)
+ #endif
+#else
+ static bool is_inf(s7_double x) {return((x == x) && (is_NaN(x - x)));} /* Another possibility: (x * 0) != 0 */
+
+#if (_MSC_VER < 1700)
+ /* in MS C, we need to provide inverse hyperbolic trig funcs and cbrt */
+ static double asinh(double x) {return(log(x + sqrt(1.0 + x * x)));}
+ static double acosh(double x) {return(log(x + sqrt(x * x - 1.0)));}
+ /* perhaps less prone to numerical troubles (untested): 2.0 * log(sqrt(0.5 * (x + 1.0)) + sqrt(0.5 * (x - 1.0))) */
+ static double atanh(double x) {return(log((1.0 + x) / (1.0 - x)) / 2.0);}
+ static double cbrt(double x) {if (x >= 0.0) return(pow(x, 1.0 / 3.0)); return(-pow(-x, 1.0 / 3.0));}
+#endif
+#endif /* windows */
+#endif /* not sun */
+
+
+/* -------------------------------- NaN payloads -------------------------------- */
+typedef union {int64_t ix; double fx;} decode_float_t;
+
+static double nan_with_payload(int64_t payload)
+{
+ decode_float_t num;
+ if (payload <= 0) return(NAN);
+ num.fx = NAN;
+ num.ix = num.ix | payload;
+ return(num.fx);
+}
+
+static s7_pointer make_nan_with_payload(s7_scheme *sc, s7_int payload)
+{
+ s7_pointer x = make_real(sc, nan_with_payload(payload));
+ char buf[32];
+ s7_int nlen = 0;
+ nlen = snprintf(buf, 32, "+nan.%" ld64, payload);
+ set_number_name(x, buf, nlen);
+ return(x);
+}
+
+static s7_pointer g_nan(s7_scheme *sc, s7_pointer args)
+{
+ #define H_nan "(nan int) returns a NaN with payload int"
+ #define Q_nan s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_integer_symbol)
+ #define NAN_PAYLOAD_LIMIT (1LL << 51LL) /* 53 is probably ok, (nan (- (ash 1 53) 1)): +nan.9007199254740991 -- 52 bits available? */
+ s7_pointer x;
+ if (is_null(args)) return(real_NaN);
+ x = car(args);
+ if (!is_t_integer(x))
+ sole_arg_wrong_type_error_nr(sc, sc->nan_symbol, x, sc->type_names[T_INTEGER]);
+ if (integer(x) < 0)
+ sole_arg_out_of_range_error_nr(sc, sc->nan_symbol, set_elist_1(sc, x), it_is_negative_string);
+ if (integer(x) >= NAN_PAYLOAD_LIMIT)
+ sole_arg_out_of_range_error_nr(sc, sc->nan_symbol, set_elist_1(sc, x), it_is_too_large_string);
+ return(make_nan_with_payload(sc, integer(x)));
+}
+
+static s7_int nan_payload(double x)
+{
+ decode_float_t num;
+ num.fx = x;
+ return(num.ix & 0xffffffffffff);
+}
+
+static s7_pointer g_nan_payload(s7_scheme *sc, s7_pointer args)
+{
+ #define H_nan_payload "(nan-payload x) returns the payload associated with the NaN x"
+ #define Q_nan_payload s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
+ s7_pointer x = car(args);
+ if ((!is_t_real(x)) || (!is_NaN(real(x)))) /* for complex case, use real-part etc (see s7test.scm) */
+ sole_arg_wrong_type_error_nr(sc, sc->nan_payload_symbol, x, wrap_string(sc, "a NaN", 5));
+ return(make_integer(sc, nan_payload(real(x))));
+}
+
+/* no similar support for +inf.0 because inf is just a single bit pattern in ieee754 */
+
+
+/* -------- gmp stuff -------- */
+#if WITH_GMP
+static mp_prec_t mpc_precision = DEFAULT_BIGNUM_PRECISION;
+static mp_prec_t mpc_set_default_precision(mp_prec_t prec) {mpc_precision = prec; return(prec);}
+#define mpc_init(Z) mpc_init2(Z, mpc_precision)
+
+static bigint *alloc_bigint(s7_scheme *sc)
+{
+ bigint *p;
+ if (sc->bigints)
+ {
+ p = sc->bigints;
+ sc->bigints = p->nxt;
+ }
+ else
+ {
+ p = (bigint *)Malloc(sizeof(bigint));
+ /* not permalloc here: gmp must be playing tricky games with realloc or something. permalloc can lead
+ * to mpz_set_si overwriting adjacent memory (valgrind does not catch this), clobbering at least the
+ * bigint nxt field. Someday I need to look at the source.
+ */
+ mpz_init(p->n);
+ }
+ return(p);
+}
+
+static bigrat *alloc_bigrat(s7_scheme *sc)
+{
+ bigrat *p;
+ if (sc->bigrats)
+ {
+ p = sc->bigrats;
+ sc->bigrats = p->nxt;
+ }
+ else
+ {
+ p = (bigrat *)Malloc(sizeof(bigrat));
+ mpq_init(p->q);
+ }
+ return(p);
+}
+
+static bigflt *alloc_bigflt(s7_scheme *sc)
+{
+ bigflt *p;
+ if (sc->bigflts)
+ {
+ p = sc->bigflts;
+ sc->bigflts = p->nxt;
+ mpfr_set_prec(p->x, sc->bignum_precision);
+ }
+ else
+ {
+ p = (bigflt *)Malloc(sizeof(bigflt));
+ mpfr_init2(p->x, sc->bignum_precision);
+ }
+ return(p);
+}
+
+static bigcmp *alloc_bigcmp(s7_scheme *sc)
+{
+ bigcmp *p;
+ if (sc->bigcmps)
+ {
+ p = sc->bigcmps;
+ sc->bigcmps = p->nxt;
+ mpc_set_prec(p->z, sc->bignum_precision);
+ }
+ else
+ {
+ p = (bigcmp *)Malloc(sizeof(bigcmp));
+ mpc_init(p->z);
+ }
+ return(p);
+}
+
+static s7_pointer mpz_to_big_integer(s7_scheme *sc, mpz_t val)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_INTEGER);
+ big_integer_bgi(x) = alloc_bigint(sc);
+ mpz_set(big_integer(x), val);
+ add_big_integer(sc, x);
+ return(x);
+}
+
+static s7_pointer mpz_to_integer(s7_scheme *sc, mpz_t val)
+{
+ if (mpz_fits_slong_p(val))
+ return(make_integer(sc, mpz_get_si(val)));
+ return(mpz_to_big_integer(sc, val));
+}
+
+#if (!WITH_PURE_S7)
+static s7_pointer mpz_to_big_real(s7_scheme *sc, mpz_t val)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_REAL);
+ big_real_bgf(x) = alloc_bigflt(sc);
+ add_big_real(sc, x);
+ mpfr_set_z(big_real(x), val, MPFR_RNDN);
+ return(x);
+}
+#endif
+
+static s7_pointer mpq_to_big_ratio(s7_scheme *sc, mpq_t val)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_RATIO);
+ big_ratio_bgr(x) = alloc_bigrat(sc);
+ add_big_ratio(sc, x);
+ mpq_set(big_ratio(x), val);
+ return(x);
+}
+
+static s7_pointer mpq_to_rational(s7_scheme *sc, mpq_t val)
+{
+ if (mpz_cmp_ui(mpq_denref(val), 1) == 0)
+ return(mpz_to_integer(sc, mpq_numref(val)));
+#if S7_DEBUGGING
+ mpq_canonicalize(val);
+ if (mpz_cmp_ui(mpq_denref(val), 1) == 0)
+ {
+ fprintf(stderr, "mpq_to_rational: missing canonicalize\n");
+ return(mpz_to_integer(sc, mpq_numref(val)));
+ }
+#endif
+ if ((mpz_fits_slong_p(mpq_numref(val))) && (mpz_fits_slong_p(mpq_denref(val))))
+ return(make_simple_ratio(sc, mpz_get_si(mpq_numref(val)), mpz_get_si(mpq_denref(val))));
+ return(mpq_to_big_ratio(sc, val));
+}
+
+static s7_pointer mpq_to_canonicalized_rational(s7_scheme *sc, mpq_t mpq)
+{
+ mpq_canonicalize(mpq);
+ return(mpq_to_rational(sc, mpq));
+}
+
+static s7_pointer mpz_to_rational(s7_scheme *sc, mpz_t n, mpz_t d) /* mpz_3 and mpz_4 */
+{
+ if (mpz_cmp_ui(d, 1) == 0)
+ return(mpz_to_integer(sc, n));
+ mpq_set_num(sc->mpq_1, n);
+ mpq_set_den(sc->mpq_1, d);
+ return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
+}
+
+#if (!WITH_PURE_S7)
+static s7_pointer mpq_to_big_real(s7_scheme *sc, mpq_t val)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_REAL);
+ big_real_bgf(x) = alloc_bigflt(sc);
+ add_big_real(sc, x);
+ mpfr_set_q(big_real(x), val, MPFR_RNDN);
+ return(x);
+}
+#endif
+
+static s7_pointer any_rational_to_mpq(s7_scheme *sc, s7_pointer z, mpq_t bigq)
+{
+ switch (type(z))
+ {
+ case T_INTEGER: mpq_set_si(bigq, integer(z), 1); break;
+ case T_BIG_INTEGER: mpq_set_z(bigq, big_integer(z)); break;
+ case T_RATIO: mpq_set_si(bigq, numerator(z), denominator(z)); break;
+ case T_BIG_RATIO: mpq_set(bigq, big_ratio(z)); break;
+ }
+ return(z);
+}
+
+static s7_pointer mpfr_to_integer(s7_scheme *sc, mpfr_t val)
+{
+ mpfr_get_z(sc->mpz_4, val, MPFR_RNDN);
+ return(mpz_to_integer(sc, sc->mpz_4));
+}
+
+static s7_pointer mpfr_to_big_real(s7_scheme *sc, mpfr_t val)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_REAL);
+ add_big_real(sc, x);
+ big_real_bgf(x) = alloc_bigflt(sc);
+ mpfr_set(big_real(x), val, MPFR_RNDN);
+ return(x);
+}
+
+static s7_pointer mpc_to_number(s7_scheme *sc, mpc_t val)
+{
+ s7_pointer x;
+ if (mpfr_zero_p(mpc_imagref(val)))
+ return(mpfr_to_big_real(sc, mpc_realref(val)));
+ new_cell(sc, x, T_BIG_COMPLEX);
+ big_complex_bgc(x) = alloc_bigcmp(sc);
+ add_big_complex(sc, x);
+ mpc_set(big_complex(x), val, MPC_RNDNN);
+ return(x);
+}
+
+/* s7.h */
+mpz_t *s7_big_integer(s7_pointer x) {return(&big_integer(x));}
+mpq_t *s7_big_ratio(s7_pointer x) {return(&big_ratio(x));}
+mpfr_t *s7_big_real(s7_pointer x) {return(&big_real(x));}
+mpc_t *s7_big_complex(s7_pointer x) {return(&big_complex(x));}
+
+bool s7_is_big_integer(s7_pointer x) {return(is_t_big_integer(x));}
+bool s7_is_big_ratio(s7_pointer x) {return(is_t_big_ratio(x));}
+bool s7_is_big_real(s7_pointer x) {return(is_t_big_real(x));}
+bool s7_is_big_complex(s7_pointer x) {return(is_t_big_complex(x));}
+
+s7_pointer s7_make_big_integer(s7_scheme *sc, mpz_t *val) {return(mpz_to_integer(sc, *val));}
+s7_pointer s7_make_big_ratio(s7_scheme *sc, mpq_t *val) {return(mpq_to_rational(sc, *val));}
+s7_pointer s7_make_big_real(s7_scheme *sc, mpfr_t *val) {return(mpfr_to_big_real(sc, *val));}
+s7_pointer s7_make_big_complex(s7_scheme *sc, mpc_t *val) {return(mpc_to_number(sc, *val));}
+
+#if (!WITH_PURE_S7)
+static s7_pointer big_integer_to_big_real(s7_scheme *sc, s7_pointer x) {return(mpz_to_big_real(sc, big_integer(x)));}
+static s7_pointer big_ratio_to_big_real(s7_scheme *sc, s7_pointer x) {return(mpq_to_big_real(sc, big_ratio(x)));}
+#endif
+
+static s7_pointer s7_int_to_big_integer(s7_scheme *sc, s7_int val)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_INTEGER);
+ big_integer_bgi(x) = alloc_bigint(sc);
+ mpz_set_si(big_integer(x), val);
+ add_big_integer(sc, x);
+ return(x);
+}
+
+static s7_pointer s7_int_to_big_ratio(s7_scheme *sc, s7_int num, s7_int den)
+{
+ /* (called only in g_bignum), den here always comes from denominator(x) or some positive constant so it is not negative */
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_RATIO);
+ big_ratio_bgr(x) = alloc_bigrat(sc);
+ add_big_ratio(sc, x);
+ mpq_set_si(big_ratio(x), num, den);
+ return(x);
+}
+
+static s7_pointer s7_double_to_big_real(s7_scheme *sc, s7_double rl)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_REAL);
+ big_real_bgf(x) = alloc_bigflt(sc);
+ add_big_real(sc, x);
+ mpfr_set_d(big_real(x), rl, MPFR_RNDN);
+ return(x);
+}
+
+static s7_pointer s7_double_to_big_complex(s7_scheme *sc, s7_double rl, s7_double im)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_COMPLEX);
+ add_big_complex(sc, x);
+ big_complex_bgc(x) = alloc_bigcmp(sc);
+ mpc_set_d_d(big_complex(x), rl, im, MPC_RNDNN);
+ return(x);
+}
+
+static s7_pointer big_pi(s7_scheme *sc)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_REAL | T_IMMUTABLE);
+ big_real_bgf(x) = alloc_bigflt(sc);
+ add_big_real(sc, x);
+ mpfr_const_pi(big_real(x), MPFR_RNDN);
+ return(x);
+}
+
+static bool is_integer_via_method(s7_scheme *sc, s7_pointer p)
+{
+ if (s7_is_integer(p))
+ return(true);
+ if (has_active_methods(sc, 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(false);
+}
+
+#if (!WITH_PURE_S7)
+static s7_pointer s7_number_to_big_real(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_REAL);
+ big_real_bgf(x) = alloc_bigflt(sc);
+ add_big_real(sc, x);
+
+ switch (type(p))
+ {
+ case T_INTEGER:
+ mpfr_set_si(big_real(x), integer(p), MPFR_RNDN);
+ break;
+ case T_RATIO:
+ /* here we can't use fraction(number(p)) even though that uses long_double division because
+ * there are lots of int64_t ratios that will still look the same.
+ * We have to do the actual bignum divide by hand.
+ */
+ mpq_set_si(sc->mpq_1, numerator(p), denominator(p));
+ mpfr_set_q(big_real(x), sc->mpq_1, MPFR_RNDN);
+ break;
+ default:
+ mpfr_set_d(big_real(x), s7_real(p), MPFR_RNDN);
+ break;
+ }
+ return(x);
+}
+#endif
+
+static s7_pointer s7_number_to_big_complex(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_COMPLEX);
+ big_complex_bgc(x) = alloc_bigcmp(sc);
+ add_big_complex(sc, x);
+
+ switch (type(p))
+ {
+ case T_INTEGER:
+ mpc_set_si(big_complex(x), integer(p), MPC_RNDNN);
+ break;
+ case T_RATIO:
+ /* can't use fraction here */
+ mpq_set_si(sc->mpq_1, numerator(p), denominator(p));
+ mpfr_set_q(sc->mpfr_1, sc->mpq_1, MPFR_RNDN);
+ mpc_set_fr(big_complex(x), sc->mpfr_1, MPC_RNDNN);
+ break;
+ case T_REAL:
+ mpc_set_d(big_complex(x), s7_real(p), MPC_RNDNN);
+ break;
+ default:
+ mpc_set_d_d(big_complex(x), real_part(p), imag_part(p), MPC_RNDNN);
+ break;
+ }
+ return(x);
+}
+
+static s7_pointer any_real_to_mpfr(s7_scheme *sc, s7_pointer p, mpfr_t bigx)
+{
+ switch (type(p))
+ {
+ case T_INTEGER:
+ mpfr_set_si(bigx, integer(p), MPFR_RNDN);
+ break;
+ case T_RATIO:
+ mpq_set_si(sc->mpq_1, numerator(p), denominator(p));
+ mpfr_set_q(bigx, sc->mpq_1, MPFR_RNDN);
+ break;
+ case T_REAL:
+ mpfr_set_d(bigx, real(p), MPFR_RNDN);
+ if (is_NaN(real(p))) return(real_NaN);
+ if (is_inf(real(p))) return(real_infinity);
+ break;
+ case T_BIG_INTEGER:
+ mpfr_set_z(bigx, big_integer(p), MPFR_RNDN);
+ break;
+ case T_BIG_RATIO:
+ mpfr_set_q(bigx, big_ratio(p), MPFR_RNDN);
+ break;
+ case T_BIG_REAL:
+ mpfr_set(bigx, big_real(p), MPFR_RNDN);
+ if (mpfr_nan_p(big_real(p))) return(real_NaN);
+ if (mpfr_inf_p(big_real(p))) return(real_infinity);
+ break;
+ }
+ return(NULL);
+}
+
+#define mpc_zero_p(z) ((mpfr_zero_p(mpc_realref(z))) && (mpfr_zero_p(mpc_imagref(z))))
+
+static s7_pointer any_number_to_mpc(s7_scheme *sc, s7_pointer p, mpc_t bigz)
+{
+ switch (type(p))
+ {
+ case T_INTEGER:
+ mpc_set_si(bigz, integer(p), MPC_RNDNN);
+ break;
+ case T_RATIO:
+ mpq_set_si(sc->mpq_1, numerator(p), denominator(p));
+ mpc_set_q(bigz, sc->mpq_1, MPC_RNDNN);
+ break;
+ case T_REAL:
+ if (is_NaN(real(p))) return(real_NaN);
+ if (is_inf(real(p))) return(real_infinity);
+ mpc_set_d(bigz, real(p), MPC_RNDNN);
+ break;
+ case T_COMPLEX:
+ if (is_NaN(imag_part(p))) return(complex_NaN);
+ if (is_NaN(real_part(p))) return(real_NaN);
+ mpc_set_d_d(bigz, real_part(p), imag_part(p), MPC_RNDNN);
+ break;
+ case T_BIG_INTEGER:
+ mpc_set_z(bigz, big_integer(p), MPC_RNDNN);
+ break;
+ case T_BIG_RATIO:
+ mpc_set_q(bigz, big_ratio(p), MPC_RNDNN);
+ break;
+ case T_BIG_REAL:
+ mpc_set_fr(bigz, big_real(p), MPC_RNDNN);
+ if (mpfr_nan_p(big_real(p))) return(real_NaN);
+ if (mpfr_inf_p(big_real(p))) return(real_infinity);
+ break;
+ case T_BIG_COMPLEX:
+ if (mpfr_nan_p(mpc_imagref(big_complex(p)))) return(complex_NaN);
+ if (mpfr_nan_p(mpc_realref(big_complex(p)))) return(real_NaN);
+ mpc_set(bigz, big_complex(p), MPC_RNDNN);
+ break;
+ }
+ return(NULL);
+}
+
+static s7_pointer make_big_complex(s7_scheme *sc, mpfr_t rl, mpfr_t im)
+{
+ /* there is no mpc_get_str equivalent, so we need to split up str, use make_big_real to get the 2 halves, then mpc_init, then mpc_set_fr_fr */
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_COMPLEX);
+ big_complex_bgc(x) = alloc_bigcmp(sc);
+ add_big_complex(sc, x);
+ mpc_set_fr_fr(big_complex(x), rl ,im, MPC_RNDNN);
+ return(x);
+}
+
+static block_t *mpfr_to_string(s7_scheme *sc, mpfr_t val, int32_t radix)
+{
+ char *str;
+ mp_exp_t expptr;
+ int32_t ep;
+ s7_int i, len;
+ block_t *b, *btmp;
+
+ if (mpfr_zero_p(val))
+ return(string_to_block(sc, "0.0", 3));
+ if (mpfr_nan_p(val))
+ return(string_to_block(sc, "+nan.0", 6));
+ if (mpfr_inf_p(val))
+ return((mpfr_signbit(val) == 0) ? string_to_block(sc, "+inf.0", 6) : string_to_block(sc, "-inf.0", 6));
+
+ b = callocate(sc, sc->bignum_precision + 32);
+ str = mpfr_get_str((char *)block_data(b), &expptr, radix, 0, val, MPFR_RNDN);
+ ep = (int32_t)expptr;
+ len = safe_strlen(str);
+
+ /* remove trailing 0's */
+ for (i = len - 1; i > 3; i--)
+ if (str[i] != '0')
+ break;
+ if (i < len - 1)
+ str[i + 1] = '\0';
+
+ btmp = mallocate(sc, len + 64);
+ if (str[0] == '-')
+ snprintf((char *)block_data(btmp), len + 64, "-%c.%s%c%d", str[1], (char *)(str + 2), (radix <= 10) ? 'E' : '@', ep - 1);
+ else snprintf((char *)block_data(btmp), len + 64, "%c.%s%c%d", str[0], (char *)(str + 1), (radix <= 10) ? 'E' : '@', ep - 1);
+
+ liberate(sc, b);
+ return(btmp);
+}
+
+static block_t *mpc_to_string(s7_scheme *sc, mpc_t val, int32_t radix, use_write_t use_write)
+{
+ block_t *rl, *im, *tmp;
+ s7_int len;
+
+ mpc_real(sc->mpfr_1, val, MPFR_RNDN);
+ rl = mpfr_to_string(sc, sc->mpfr_1, radix);
+ mpc_imag(sc->mpfr_2, val, MPFR_RNDN);
+ im = mpfr_to_string(sc, sc->mpfr_2, radix);
+
+ 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));
+
+ liberate(sc, rl);
+ liberate(sc, im);
+ return(tmp);
+}
+
+static block_t *big_number_to_string_with_radix(s7_scheme *sc, s7_pointer p, int32_t radix, s7_int width, s7_int *nlen, use_write_t use_write)
+{
+ block_t *str;
+ switch (type(p))
+ {
+ case T_BIG_INTEGER:
+ str = callocate(sc, mpz_sizeinbase(big_integer(p), radix) + 64);
+ mpz_get_str((char *)block_data(str), radix, big_integer(p));
+ break;
+ case T_BIG_RATIO:
+ mpz_set(sc->mpz_1, mpq_numref(big_ratio(p)));
+ mpz_set(sc->mpz_2, mpq_denref(big_ratio(p)));
+ str = callocate(sc, mpz_sizeinbase(sc->mpz_1, radix) + mpz_sizeinbase(sc->mpz_2, radix) + 64);
+ mpq_get_str((char *)block_data(str), radix, big_ratio(p));
+ break;
+ case T_BIG_REAL:
+ str = mpfr_to_string(sc, big_real(p), radix);
+ break;
+ default:
+ str = mpc_to_string(sc, big_complex(p), radix, use_write);
+ break;
+ }
+ if (width > 0)
+ {
+ 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);
+ }
+ (*nlen) = len;
+ }
+ else (*nlen) = safe_strlen((char *)block_data(str));
+ return(str);
+}
+
+static s7_pointer string_to_big_integer(s7_scheme *sc, const char *str, int32_t radix)
+{
+ mpz_set_str(sc->mpz_4, (str[0] == '+') ? (const char *)(str + 1) : str, radix);
+ return(mpz_to_integer(sc, sc->mpz_4));
+}
+
+static s7_pointer string_to_big_ratio(s7_scheme *sc, const char *str, int32_t radix)
+{
+ s7_pointer x;
+ mpq_set_str(sc->mpq_1, str, radix);
+ 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)));
+ new_cell(sc, x, T_BIG_RATIO);
+ big_ratio_bgr(x) = alloc_bigrat(sc);
+ add_big_ratio(sc, x);
+ mpq_set(big_ratio(x), sc->mpq_1);
+ return(x);
+}
+
+static s7_pointer string_to_big_real(s7_scheme *sc, const char *str, int32_t radix)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_BIG_REAL);
+ big_real_bgf(x) = alloc_bigflt(sc);
+ add_big_real(sc, x);
+ mpfr_set_str(big_real(x), str, radix, MPFR_RNDN);
+ return(x);
+}
+
+static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow);
+
+static s7_pointer string_to_either_integer(s7_scheme *sc, const char *str, int32_t radix)
+{
+ bool overflow = false;
+ s7_int val = string_to_integer(str, radix, &overflow);
+ if (!overflow)
+ return(make_integer(sc, val));
+ return(string_to_big_integer(sc, str, radix));
+}
+
+static s7_pointer string_to_either_ratio(s7_scheme *sc, const char *nstr, const char *dstr, int32_t radix)
+{
+ bool overflow = false;
+ /* gmp segfaults if passed a bignum/0 so this needs to check first that the denominator is not 0 before letting gmp screw up.
+ * Also, if the first character is '+', gmp returns 0!
+ */
+ s7_int d = string_to_integer(dstr, radix, &overflow);
+ if (!overflow)
+ {
+ s7_int n;
+ if (d == 0) return(real_NaN);
+ n = string_to_integer(nstr, radix, &overflow);
+ if (!overflow)
+ return(make_ratio(sc, n, d));
+ }
+ if (nstr[0] == '+')
+ return(string_to_big_ratio(sc, (const char *)(nstr + 1), radix));
+ return(string_to_big_ratio(sc, nstr, radix));
+}
+
+static s7_double string_to_double_with_radix(const char *ur_str, int32_t radix, bool *overflow);
+
+static s7_pointer string_to_either_real(s7_scheme *sc, const char *str, int32_t radix)
+{
+ bool overflow = false;
+ s7_double val = string_to_double_with_radix((char *)str, radix, &overflow);
+ if (!overflow) return(make_real(sc, val));
+ return(string_to_big_real(sc, str, radix));
+}
+
+static s7_pointer string_to_either_complex_1(s7_scheme *sc, char *q, char *slash1, char *ex1, bool has_dec_point1, int32_t radix, s7_double *d_rl)
+{
+ bool overflow = false;
+ /* there's a real problem here -- we don't want to promote s7_double .1 to a bignum because
+ * its low order digits are garbage, causing (rationalize .1 0) to return 3602879701896397/36028797018963968
+ * no matter what the bignum-precision. But we can't just fallback on gmp's reader because (for example)
+ * it reads 1/2+i or 1+0/0i as 1.0. Also format gets screwed up. And string->number signals an error
+ * where it should return #f. I wonder what to do.
+ */
+ if ((has_dec_point1) ||
+ (ex1))
+ {
+ (*d_rl) = string_to_double_with_radix(q, radix, &overflow);
+ if (overflow) return(string_to_big_real(sc, q, radix));
+ }
+ 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;
+ }
+ 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;
+ }}
+ 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)
+{
+ /* 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;
+ s7_pointer p_rl = string_to_either_complex_1(sc, q, slash1, ex1, has_dec_point1, radix, &d_rl);
+ s7_pointer p_im = string_to_either_complex_1(sc, plus, slash2, ex2, has_dec_point2, radix, &d_im);
+
+ if ((d_im == 0.0) && /* 1.0+0.0000000000000000000000000000i */
+ ((!p_im) || (is_zero(p_im))))
+ return((p_rl) ? p_rl : make_real(sc, d_rl));
+
+ if ((!p_rl) && (!p_im))
+ return(make_complex_not_0i(sc, d_rl, (has_plus_or_minus == -1) ? (-d_im) : d_im));
+
+ if (p_rl)
+ any_real_to_mpfr(sc, p_rl, sc->mpfr_1);
+ else mpfr_set_d(sc->mpfr_1, d_rl, MPFR_RNDN);
+
+ if (p_im)
+ any_real_to_mpfr(sc, p_im, sc->mpfr_2);
+ else mpfr_set_d(sc->mpfr_2, d_im, MPFR_RNDN);
+
+ if (has_plus_or_minus == -1)
+ mpfr_neg(sc->mpfr_2, sc->mpfr_2, MPFR_RNDN);
+ return(make_big_complex(sc, sc->mpfr_1, sc->mpfr_2));
+}
+
+static bool big_numbers_are_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b)
+{
+ /* either or both can be big here, but not neither, and types might not match at all */
+ switch (type(a))
+ {
+ case T_INTEGER:
+ return((is_t_big_integer(b)) && (mpz_cmp_si(big_integer(b), integer(a)) == 0));
+ case T_BIG_INTEGER:
+ if (is_t_big_integer(b)) return(mpz_cmp(big_integer(a), big_integer(b)) == 0);
+ return((is_t_integer(b)) && (mpz_cmp_si(big_integer(a), integer(b)) == 0));
+ case T_RATIO:
+ if (!is_t_big_ratio(b)) return(false);
+ mpq_set_si(sc->mpq_1, numerator(a), denominator(a));
+ return(mpq_equal(sc->mpq_1, big_ratio(b)));
+ case T_BIG_RATIO:
+ if (is_t_big_ratio(b)) return(mpq_equal(big_ratio(a), big_ratio(b)));
+ if (!is_t_ratio(b)) return(false);
+ mpq_set_si(sc->mpq_1, numerator(b), denominator(b));
+ return(mpq_equal(sc->mpq_1, big_ratio(a)));
+ case T_REAL:
+ if (is_NaN(real(a))) return(false);
+ return((is_t_big_real(b)) && (!mpfr_nan_p(big_real(b))) && (mpfr_cmp_d(big_real(b), real(a)) == 0));
+ case T_BIG_REAL:
+ if (mpfr_nan_p(big_real(a))) return(false);
+ if (is_t_big_real(b)) return((!mpfr_nan_p(big_real(b))) && (mpfr_equal_p(big_real(a), big_real(b))));
+ return((is_t_real(b)) && (!is_NaN(real(b))) && (mpfr_cmp_d(big_real(a), real(b)) == 0));
+ case T_COMPLEX:
+ 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);
+ 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);
+ 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 (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);
+ }}
+ return(false);
+}
+
+static s7_int big_integer_to_s7_int(s7_scheme *sc, mpz_t n)
+{
+ if (!mpz_fits_slong_p(n))
+ error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "bigint does not fit in s7_int: ~S", 33), mpz_to_big_integer(sc, n)));
+ return(mpz_get_si(n));
+}
+#endif
+
+#ifndef HAVE_OVERFLOW_CHECKS
+ #if ((defined(__clang__) && (!POINTER_32) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4))) || (defined(__GNUC__) && __GNUC__ >= 5))
+ #define HAVE_OVERFLOW_CHECKS 1
+ #else
+ #define HAVE_OVERFLOW_CHECKS 0
+ #pragma message("no arithmetic overflow checks in this version of s7")
+ /* these are untested */
+ static bool add_overflow(s7_int A, s7_int B, s7_int *C) {*C = A + B; return(false);} /* #define add_overflow(A, B, C) 0 */
+ static bool subtract_overflow(s7_int A, s7_int B, s7_int *C) {*C = A - B; return(false);} /* #define subtract_overflow(A, B, C) 0 */
+ static bool multiply_overflow(s7_int A, s7_int B, s7_int *C) {*C = A * B; return(false);} /* #define multiply_overflow(A, B, C) 0 */
+ #endif
+#endif
+
+#if (defined(__clang__) && (!POINTER_32) && ((__clang_major__ > 3) || (__clang_major__ == 3 && __clang_minor__ >= 4)))
+ #define subtract_overflow(A, B, C) __builtin_ssubll_overflow((long long)A, (long long)B, (long long *)C)
+ #define add_overflow(A, B, C) __builtin_saddll_overflow((long long)A, (long long)B, (long long *)C)
+ #define multiply_overflow(A, B, C) __builtin_smulll_overflow((long long)A, (long long)B, (long long *)C)
+ #define int32_add_overflow(A, B, C) __builtin_sadd_overflow(A, B, C)
+ #define int32_multiply_overflow(A, B, C) __builtin_smul_overflow(A, B, C)
+#else
+#if (defined(__GNUC__) && __GNUC__ >= 5)
+ #define subtract_overflow(A, B, C) __builtin_sub_overflow(A, B, C)
+ #define add_overflow(A, B, C) __builtin_add_overflow(A, B, C)
+ #define multiply_overflow(A, B, C) __builtin_mul_overflow(A, B, C)
+ #define int32_add_overflow(A, B, C) __builtin_add_overflow(A, B, C)
+ #define int32_multiply_overflow(A, B, C) __builtin_mul_overflow(A, B, C)
+#endif
+#endif
+
+#if WITH_GCC
+#define s7_int_abs(x) ({s7_int _X_; _X_ = x; _X_ >= 0 ? _X_ : -_X_;})
+#else
+#define s7_int_abs(x) ((x) >= 0 ? (x) : -(x))
+#endif
+/* can't use abs even in gcc -- it doesn't work with int64_ts! */
+
+#if (!__NetBSD__)
+ #define s7_fabsl(X) fabsl(X)
+#else
+ static double s7_fabsl(long_double x) {return((signbit(x)) ? -x : x);}
+#endif
+
+/* for g_log, we also need round. this version is from stackoverflow, see also r5rs_round below */
+static double s7_round(double number) {return((number < 0.0) ? ceil(number - 0.5) : floor(number + 0.5));}
+
+#if HAVE_COMPLEX_NUMBERS
+#if __cplusplus
+ #define _Complex_I (complex<s7_double>(0.0, 1.0))
+ #define creal(x) Real(x)
+ #define cimag(x) Imag(x)
+ #define carg(x) arg(x)
+ #define cabs(x) abs(x)
+ #define csqrt(x) sqrt(x)
+ #define cpow(x, y) pow(x, y)
+ #define clog(x) log(x)
+ #define cexp(x) exp(x)
+ #define csin(x) sin(x)
+ #define ccos(x) cos(x)
+ #define ctan(x) tan(x)
+ #define csinh(x) sinh(x)
+ #define ccosh(x) cosh(x)
+ #define ctanh(x) tanh(x)
+ #define casin(x) asin(x)
+ #define cacos(x) acos(x)
+ #define catan(x) atan(x)
+ #define casinh(x) asinh(x)
+ #define cacosh(x) acosh(x)
+ #define catanh(x) atanh(x)
+#else
+ typedef double complex s7_complex;
+#endif
+
+
+#if (!HAVE_COMPLEX_TRIG)
+#if (__cplusplus)
+
+ static s7_complex ctan(s7_complex z) {return(csin(z) / ccos(z));}
+ static s7_complex ctanh(s7_complex z) {return(csinh(z) / ccosh(z));}
+ static s7_complex casin(s7_complex z) {return(-s7_complex_i * clog(s7_complex_i * z + csqrt(1.0 - z * z)));}
+ static s7_complex cacos(s7_complex z) {return(-s7_complex_i * clog(z + s7_complex_i * csqrt(1.0 - z * z)));}
+ static s7_complex catan(s7_complex z) {return(s7_complex_i * clog((s7_complex_i + z) / (s7_complex_i - z)) / 2.0);}
+ static s7_complex casinh(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));}
+ static s7_complex cacosh(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));}
+ static s7_complex catanh(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);}
+#else
+
+#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 12)
+static s7_complex clog(s7_complex z) {return(log(fabs(cabs(z))) + carg(z) * s7_complex_i);}
+static s7_complex cpow(s7_complex x, s7_complex y)
+{
+ s7_double r = cabs(x);
+ s7_double theta = carg(x);
+ s7_double yre = creal(y);
+ s7_double yim = cimag(y);
+ s7_double nr = exp(yre * log(r) - yim * theta);
+ s7_double ntheta = yre * theta + yim * log(r);
+ return(nr * cos(ntheta) + (nr * sin(ntheta)) * s7_complex_i);
+}
+#endif
+#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 9) /* untested -- this orignally looked at __FreeBSD_version which apparently no longer exists */
+ static s7_complex cexp(s7_complex z) {return(exp(creal(z)) * cos(cimag(z)) + (exp(creal(z)) * sin(cimag(z))) * s7_complex_i);}
+#endif
+
+#if (!defined(__FreeBSD__)) || (__FreeBSD__ < 10)
+ static s7_complex csin(s7_complex z) {return(sin(creal(z)) * cosh(cimag(z)) + (cos(creal(z)) * sinh(cimag(z))) * s7_complex_i);}
+ static s7_complex ccos(s7_complex z) {return(cos(creal(z)) * cosh(cimag(z)) + (-sin(creal(z)) * sinh(cimag(z))) * s7_complex_i);}
+ static s7_complex csinh(s7_complex z) {return(sinh(creal(z)) * cos(cimag(z)) + (cosh(creal(z)) * sin(cimag(z))) * s7_complex_i);}
+ static s7_complex ccosh(s7_complex z) {return(cosh(creal(z)) * cos(cimag(z)) + (sinh(creal(z)) * sin(cimag(z))) * s7_complex_i);}
+ static s7_complex ctan(s7_complex z) {return(csin(z) / ccos(z));}
+ static s7_complex ctanh(s7_complex z) {return(csinh(z) / ccosh(z));}
+ static s7_complex casin(s7_complex z) {return(-s7_complex_i * clog(s7_complex_i * z + csqrt(1.0 - z * z)));}
+ static s7_complex cacos(s7_complex z) {return(-s7_complex_i * clog(z + s7_complex_i * csqrt(1.0 - z * z)));}
+ static s7_complex catan(s7_complex z) {return(s7_complex_i * clog((s7_complex_i + z) / (s7_complex_i - z)) / 2.0);}
+ static s7_complex catanh(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);}
+ static s7_complex casinh(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));}
+ static s7_complex cacosh(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));}
+#endif /* not FreeBSD 10 */
+#endif /* not c++ */
+#endif /* not HAVE_COMPLEX_TRIG */
+
+#else /* not HAVE_COMPLEX_NUMBERS */
+ typedef double s7_complex;
+ #define _Complex_I 1.0
+ #define creal(x) x
+ #define cimag(x) x
+ #define csin(x) sin(x)
+ #define casin(x) x
+ #define ccos(x) cos(x)
+ #define cacos(x) x
+ #define ctan(x) x
+ #define catan(x) x
+ #define csinh(x) x
+ #define casinh(x) x
+ #define ccosh(x) x
+ #define cacosh(x) x
+ #define ctanh(x) x
+ #define catanh(x) x
+ #define cexp(x) exp(x)
+ #define cpow(x, y) pow(x, y)
+ #define clog(x) log(x)
+ #define csqrt(x) sqrt(x)
+ #define conj(x) x
+#endif
+
+#ifdef __OpenBSD__
+ /* openbsd's builtin versions of these functions are not usable */
+ static s7_complex catanh_1(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);}
+ static s7_complex casinh_1(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));}
+ static s7_complex cacosh_1(s7_complex z) {return(clog(z + csqrt(z * z - 1.0)));}
+#endif
+#ifdef __NetBSD__
+ static s7_complex catanh_1(s7_complex z) {return(clog((1.0 + z) / (1.0 - z)) / 2.0);}
+ static s7_complex casinh_1(s7_complex z) {return(clog(z + csqrt(1.0 + z * z)));}
+#endif
+
+
+bool s7_is_number(s7_pointer p) {return(is_number(p));}
+bool s7_is_complex(s7_pointer p) {return(is_number(p));}
+bool s7_is_real(s7_pointer p) {return(is_real(p));}
+bool s7_is_rational(s7_pointer p) {return(is_rational(p));}
+
+bool s7_is_integer(s7_pointer p)
+{
+#if WITH_GMP
+ return((is_t_integer(p)) || (is_t_big_integer(p)));
+#else
+ return(is_t_integer(p));
+#endif
+}
+
+bool s7_is_ratio(s7_pointer p)
+{
+#if WITH_GMP
+ return((is_t_ratio(p)) || (is_t_big_ratio(p)));
+#else
+ return(is_t_ratio(p));
+#endif
+}
+
+static s7_int c_gcd(s7_int u, s7_int v)
+{
+ /* #if __cplusplus\n return std::gcd(u, v);\n #else... but this requires #include <algorithm> (else gcd is not defined in std::)
+ * and C++'s gcd returns negative results sometimes -- isn't gcd defined to be positive? std::gcd is ca 25% faster than the code below.
+ */
+ s7_int a, b;
+ if ((u == s7_int_min) || (v == s7_int_min))
+ {
+ /* can't take abs of these (below) so do it by hand */
+ s7_int divisor = 1;
+ if (u == v) return(u);
+ while (((u & 1) == 0) && ((v & 1) == 0))
+ {
+ u /= 2;
+ v /= 2;
+ divisor *= 2;
+ }
+ return(divisor);
+ }
+ a = s7_int_abs(u);
+ b = s7_int_abs(v);
+ /* there are faster gcd algorithms but does it ever matter? */
+ while (b != 0)
+ {
+ s7_int temp = a % b;
+ a = b;
+ b = temp;
+ }
+ return(a);
+}
+
+#define RATIONALIZE_LIMIT 1.0e12
+
+static bool c_rationalize(s7_double ux, s7_double error, s7_int *numer, s7_int *denom)
+{
+ /* from CL code in Canny, Donald, Ressler, "A Rational Rotation Method for Robust Geometric Algorithms" */
+ double x0, x1;
+ s7_int i, p0, q0 = 1, p1, q1 = 1;
+ double e0, e1, e0p, e1p;
+ int32_t tries = 0;
+ /* don't use long_double: the loop below will hang */
+
+ /* #e1e19 is a killer -- it's bigger than most-positive-fixnum, but if we ceil(ux) below
+ * it turns into most-negative-fixnum. 1e19 is trouble in many places.
+ */
+ if (fabs(ux) > RATIONALIZE_LIMIT)
+ {
+ /* (rationalize most-positive-fixnum) should not return most-negative-fixnum
+ * but any number > 1e14 here is so inaccurate that rationalize is useless
+ * for example,
+ * default: (rationalize (/ (*s7* 'most-positive-fixnum) 31111.0)) -> 1185866354261165/4
+ * gmp: (rationalize (/ (*s7* 'most-positive-fixnum) 31111.0)) -> 9223372036854775807/31111
+ * can't return false here because that confuses some of the callers!
+ */
+ (*numer) = (s7_int)ux;
+ (*denom) = 1;
+ return(true);
+ }
+
+ if (error < 0.0) error = -error;
+ x0 = ux - error;
+ x1 = ux + error;
+ i = (s7_int)ceil(x0);
+
+ if (error >= 1.0) /* aw good grief! */
+ {
+ if (x0 < 0.0)
+ (*numer) = (x1 < 0.0) ? (s7_int)floor(x1) : 0;
+ else (*numer) = i;
+ (*denom) = 1;
+ return(true);
+ }
+ if (x1 >= i)
+ {
+ (*numer) = (i >= 0) ? i : (s7_int)floor(x1);
+ (*denom) = 1;
+ return(true);
+ }
+
+ p0 = (s7_int)floor(x0);
+ p1 = (s7_int)ceil(x1);
+ e0 = p1 - x0;
+ e1 = x0 - p0;
+ e0p = p1 - x1;
+ e1p = x1 - p0;
+ while (true)
+ {
+ s7_int old_p1, old_q1;
+ double old_e0, old_e1, old_e0p, r, r1;
+ 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);
+ }
+ tries++;
+ r = (s7_int)floor(e0 / e1);
+ r1 = (s7_int)ceil(e0p / e1p);
+ if (r1 < r) r = r1;
+ /* do handles all step vars in parallel */
+ old_p1 = p1;
+ p1 = p0;
+ old_q1 = q1;
+ q1 = q0;
+ old_e0 = e0;
+ e0 = e1p;
+ old_e0p = e0p;
+ e0p = e1;
+ old_e1 = e1;
+ p0 = old_p1 + r * p0;
+ q0 = old_q1 + r * q0;
+ e1 = old_e0p - r * e1p; /* if the error is set too low, we can get e1 = 0 here: (rationalize (/ pi) 1e-17) */
+ e1p = old_e0 - r * old_e1;
+ }
+ return(false);
+}
+
+s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error)
+{
+ s7_int numer = 0, denom = 1;
+ if (c_rationalize(x, error, &numer, &denom))
+ return(make_ratio(sc, numer, denom));
+ return(make_real(sc, x));
+}
+
+s7_pointer s7_make_integer(s7_scheme *sc, s7_int n)
+{
+ s7_pointer x;
+ if (is_small_int(n))
+ return(small_int(n));
+ new_cell(sc, x, T_INTEGER);
+ set_integer(x, n);
+ return(x);
+}
+
+static s7_pointer make_mutable_integer(s7_scheme *sc, s7_int n)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_INTEGER | T_MUTABLE | T_IMMUTABLE);
+ set_integer(x, n);
+ return(x);
+}
+
+s7_pointer s7_make_real(s7_scheme *sc, s7_double n)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_REAL);
+ set_real(x, n);
+ return(x);
+}
+
+s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_REAL | T_MUTABLE | T_IMMUTABLE);
+ set_real(x, n);
+ return(x);
+}
+
+#define make_mutable_real(Sc, X) s7_make_mutable_real(Sc, X)
+
+s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b)
+{
+ s7_pointer x;
+ if (b == 0.0)
+ {
+ new_cell(sc, x, T_REAL);
+ set_real(x, a);
+ }
+ else
+ {
+ new_cell(sc, x, T_COMPLEX);
+ set_real_part(x, a);
+ set_imag_part(x, b);
+ }
+ return(x);
+}
+
+static s7_complex s7_to_c_complex(s7_pointer p)
+{
+#if HAVE_COMPLEX_NUMBERS
+ return(CMPLX(s7_real_part(p), s7_imag_part(p)));
+#else
+ return(0.0);
+#endif
+}
+
+static inline s7_pointer c_complex_to_s7(s7_scheme *sc, s7_complex z) {return(make_complex(sc, creal(z), cimag(z)));}
+
+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));
+}
+
+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));
+}
+
+static s7_pointer make_ratio(s7_scheme *sc, s7_int a, s7_int b)
+{
+ s7_pointer x;
+ if (b == s7_int_min)
+ {
+ /* This should not trigger an error during reading -- we might have the
+ * 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));
+ a /= 2;
+ b /= 2;
+ }
+ if (b < 0)
+ {
+ a = -a;
+ b = -b;
+ }
+ if (a == s7_int_min)
+ {
+ while (((a & 1) == 0) && ((b & 1) == 0))
+ {
+ a /= 2;
+ b /= 2;
+ }}
+ else
+ {
+ s7_int b1 = b, divisor = s7_int_abs(a);
+ do {
+ s7_int temp = divisor % b1;
+ divisor = b1;
+ b1 = temp;
+ } while (b1 != 0);
+ if (divisor != 1)
+ {
+ a /= divisor;
+ b /= divisor;
+ }}
+ if (b == 1)
+ return(make_integer(sc, a));
+
+ new_cell(sc, x, T_RATIO);
+ set_numerator(x, a);
+ set_denominator(x, b);
+ return(x);
+}
+
+/* using "make-ratio" here is a desperate kludge trying to maintain backwards compatibility; internally we use make_ratio_with_div_check below */
+s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b)
+{
+ if (b == 0)
+ division_by_zero_error_2_nr(sc, wrap_string(sc, "make-ratio", 10), wrap_integer(sc, a), int_zero);
+ return(make_ratio(sc, a, b));
+}
+
+static s7_pointer make_ratio_with_div_check(s7_scheme *sc, s7_pointer caller, s7_int a, s7_int b)
+{
+ if (b == 0)
+ division_by_zero_error_2_nr(sc, caller, wrap_integer(sc, a), int_zero);
+ return(make_ratio(sc, a, b));
+}
+
+
+#define WITH_OVERFLOW_ERROR true
+#define WITHOUT_OVERFLOW_ERROR false
+
+#define INT64_TO_DOUBLE_LIMIT (1LL << 53)
+#define DOUBLE_TO_INT64_LIMIT (1LL << 53)
+
+/* 9007199254740991LL is where a truncated double starts to skip integers (expt 2 53) = ca 1e16
+ * (ceiling (+ 1e16 1)) -> 10000000000000000
+ * (> 9007199254740993.0 9007199254740992.0) -> #f ; in non-gmp 64-bit doubles
+ * but we can't fix this except in the gmp case because:
+ * (integer-decode-float (+ (expt 2.0 62) 100)) -> (4503599627370496 10 1)
+ * (integer-decode-float (+ (expt 2.0 62) 500)) -> (4503599627370496 10 1)
+ * (> (+ (expt 2.0 62) 500) (+ (expt 2.0 62) 100)) -> #f ; non-gmp again
+ * i.e. the bits are identical. We can't even detect when it has happened (without tedious effort), so should
+ * we just give an error for any floor (or whatever) of an arg>1e16? (sin has a similar problem)?
+ * I think in the non-gmp case I'll throw an error in these cases because the results are bogus:
+ * (floor (+ (expt 2.0 62) 512)) -> 4611686018427387904
+ * (floor (+ (expt 2.0 62) 513)) -> 4611686018427388928
+ * another case at the edge: (round 9007199254740992.51) -> 9007199254740992
+ * This spells trouble for normal arithmetic in this range. If no gmp,
+ * (- (+ (expt 2.0 62) 512) (+ (expt 2.0 62) 513)) = -1024.0 (should be -1.0)
+ * but we don't currently give an error in this case -- not sure what the right thing is.
+ */
+
+s7_double s7_number_to_real_with_caller(s7_scheme *sc, s7_pointer x, const char *caller)
+{
+ if (is_t_real(x)) return(real(x));
+ switch (type(x))
+ {
+ case T_INTEGER: return((s7_double)integer(x));
+ case T_RATIO: return(fraction(x));
+#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)))));
+ case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN));
+#endif
+ default:
+ sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, sc->type_names[T_REAL]);
+ }
+ return(0.0);
+}
+
+s7_double s7_number_to_real_with_location(s7_scheme *sc, s7_pointer x, s7_pointer caller)
+{
+ if (is_t_real(x)) return(real(x));
+ switch (type(x))
+ {
+ case T_INTEGER: return((s7_double)integer(x));
+ case T_RATIO: return(fraction(x));
+#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)))));
+ case T_BIG_REAL: return((s7_double)mpfr_get_d(big_real(x), MPFR_RNDN));
+#endif
+ default:
+ sole_arg_wrong_type_error_nr(sc, caller, x, sc->type_names[T_REAL]);
+ }
+ return(0.0);
+}
+
+s7_double s7_number_to_real(s7_scheme *sc, s7_pointer x) {return(s7_number_to_real_with_location(sc, x, sc->number_to_real_symbol));}
+
+s7_int s7_number_to_integer_with_caller(s7_scheme *sc, s7_pointer x, const char *caller)
+{
+ if (is_t_integer(x)) return(integer(x));
+#if WITH_GMP
+ if (is_t_big_integer(x)) return(big_integer_to_s7_int(sc, big_integer(x)));
+#endif
+ sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, sc->type_names[T_INTEGER]);
+ return(0);
+}
+
+s7_int s7_number_to_integer(s7_scheme *sc, s7_pointer x) {return(s7_number_to_integer_with_caller(sc, x, "s7_number_to_integer"));}
+
+s7_int s7_numerator(s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER: return(integer(x));
+ case T_RATIO: return(numerator(x));
+#if WITH_GMP
+ case T_BIG_INTEGER: return(mpz_get_si(big_integer(x))); /* big_integer_to_s7_int but no sc -- no error if out of range */
+ case T_BIG_RATIO: return(mpz_get_si(mpq_numref(big_ratio(x))));
+#endif
+ }
+ return(0);
+}
+
+s7_int s7_denominator(s7_pointer x)
+{
+ if (is_t_ratio(x)) return(denominator(x));
+#if WITH_GMP
+ if (is_t_big_ratio(x)) return(mpz_get_si(mpq_denref(big_ratio(x))));
+#endif
+ return(1);
+}
+
+s7_int s7_integer(s7_pointer p)
+{
+ if (is_t_integer(p)) return(integer(p));
+#if WITH_GMP
+ if (is_t_big_integer(p)) return(mpz_get_si(big_integer(p)));
+#endif
+ return(0);
+}
+
+s7_double s7_real(s7_pointer x)
+{
+ if (is_t_real(x)) return(real(x));
+ switch (type(x))
+ {
+ case T_RATIO: return(fraction(x));
+ case T_INTEGER: return((s7_double)integer(x));
+#if WITH_GMP
+ case T_BIG_INTEGER: return((s7_double)mpz_get_si(big_integer(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);
+ }
+#endif
+ }
+ return(0.0);
+}
+
+static bool is_one(s7_pointer x)
+{
+ return(((is_t_integer(x)) && (integer(x) == 1)) ||
+ ((is_t_real(x)) && (real(x) == 1.0)));
+}
+
+
+/* -------- optimize exponents -------- */
+
+#define MAX_POW 64
+static double **pepow = NULL; /* [17][MAX_POW * 2]; */
+
+static void init_pows(void)
+{
+ pepow = (double **)Malloc(17 * sizeof(double *));
+ pepow[0] = NULL;
+ pepow[1] = NULL;
+ for (int32_t i = 2; i < 17; i++) pepow[i] = (double *)Malloc((MAX_POW * 2) * sizeof(double));
+ for (int32_t i = 2; i < 17; i++) /* radix between 2 and 16 */
+ for (int32_t j = -MAX_POW; j < MAX_POW; j++) /* saved exponent between 0 and +/- MAX_POW */
+ pepow[i][j + MAX_POW] = pow((double)i, (double)j);
+}
+
+static inline double dpow(int32_t x, int32_t y)
+{
+ if ((y >= MAX_POW) || (y < -MAX_POW)) /* this can happen (once in a blue moon) */
+ return(pow((double)x, (double)y));
+ return(pepow[x][y + MAX_POW]);
+}
+
+
+/* -------------------------------- number->string -------------------------------- */
+#ifndef WITH_DTOA
+ #define WITH_DTOA 1
+#endif
+/* there was a time when libc was so slow that this code was all but mandatory, but now (Aug-2023) the difference is smaller (ca. factor of 2) */
+
+#if WITH_DTOA
+/* fpconv, revised to fit the local coding style
+
+ The MIT License
+
+Copyright (c) 2013 Andreas Samoljuk
+
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of this software and associated documentation files (the
+"Software"), to deal in the Software without restriction, including
+without limitation the rights to use, copy, modify, merge, publish,
+distribute, sublicense, and/or sell copies of the Software, and to
+permit persons to whom the Software is furnished to do so, subject to
+the following conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+*/
+
+#define dtoa_npowers 87
+#define dtoa_steppowers 8
+#define dtoa_firstpower -348 /* 10 ^ -348 */
+#define dtoa_expmax -32
+#define dtoa_expmin -60
+
+typedef struct dtoa_np {uint64_t frac; int32_t exp;} dtoa_np;
+
+static const dtoa_np dtoa_powers_ten[] = {
+ { 18054884314459144840U, -1220 }, { 13451937075301367670U, -1193 }, { 10022474136428063862U, -1166 }, { 14934650266808366570U, -1140 },
+ { 11127181549972568877U, -1113 }, { 16580792590934885855U, -1087 }, { 12353653155963782858U, -1060 }, { 18408377700990114895U, -1034 },
+ { 13715310171984221708U, -1007 }, { 10218702384817765436U, -980 }, { 15227053142812498563U, -954 }, { 11345038669416679861U, -927 },
+ { 16905424996341287883U, -901 }, { 12595523146049147757U, -874 }, { 9384396036005875287U, -847 }, { 13983839803942852151U, -821 },
+ { 10418772551374772303U, -794 }, { 15525180923007089351U, -768 }, { 11567161174868858868U, -741 }, { 17236413322193710309U, -715 },
+ { 12842128665889583758U, -688 }, { 9568131466127621947U, -661 }, { 14257626930069360058U, -635 }, { 10622759856335341974U, -608 },
+ { 15829145694278690180U, -582 }, { 11793632577567316726U, -555 }, { 17573882009934360870U, -529 }, { 13093562431584567480U, -502 },
+ { 9755464219737475723U, -475 }, { 14536774485912137811U, -449 }, { 10830740992659433045U, -422 }, { 16139061738043178685U, -396 },
+ { 12024538023802026127U, -369 }, { 17917957937422433684U, -343 }, { 13349918974505688015U, -316 }, { 9946464728195732843U, -289 },
+ { 14821387422376473014U, -263 }, { 11042794154864902060U, -236 }, { 16455045573212060422U, -210 }, { 12259964326927110867U, -183 },
+ { 18268770466636286478U, -157 }, { 13611294676837538539U, -130 }, { 10141204801825835212U, -103 }, { 15111572745182864684U, -77 },
+ { 11258999068426240000U, -50 }, { 16777216000000000000U, -24 }, { 12500000000000000000U, 3 }, { 9313225746154785156U, 30 },
+ { 13877787807814456755U, 56 }, { 10339757656912845936U, 83 }, { 15407439555097886824U, 109 }, { 11479437019748901445U, 136 },
+ { 17105694144590052135U, 162 }, { 12744735289059618216U, 189 }, { 9495567745759798747U, 216 }, { 14149498560666738074U, 242 },
+ { 10542197943230523224U, 269 }, { 15709099088952724970U, 295 }, { 11704190886730495818U, 322 }, { 17440603504673385349U, 348 },
+ { 12994262207056124023U, 375 }, { 9681479787123295682U, 402 }, { 14426529090290212157U, 428 }, { 10748601772107342003U, 455 },
+ { 16016664761464807395U, 481 }, { 11933345169920330789U, 508 }, { 17782069995880619868U, 534 }, { 13248674568444952270U, 561 },
+ { 9871031767461413346U, 588 }, { 14708983551653345445U, 614 }, { 10959046745042015199U, 641 }, { 16330252207878254650U, 667 },
+ { 12166986024289022870U, 694 }, { 18130221999122236476U, 720 }, { 13508068024458167312U, 747 }, { 10064294952495520794U, 774 },
+ { 14996968138956309548U, 800 }, { 11173611982879273257U, 827 }, { 16649979327439178909U, 853 }, { 12405201291620119593U, 880 },
+ { 9242595204427927429U, 907 }, { 13772540099066387757U, 933 }, { 10261342003245940623U, 960 }, { 15290591125556738113U, 986 },
+ { 11392378155556871081U, 1013 }, { 16975966327722178521U, 1039 },
+ { 12648080533535911531U, 1066 }};
+
+static dtoa_np dtoa_find_cachedpow10(int exp, int* k)
+{
+ const double one_log_ten = 0.30102999566398114;
+ int32_t approx = -(exp + dtoa_npowers) * one_log_ten;
+ int32_t idx = (approx - dtoa_firstpower) / dtoa_steppowers;
+ while (true)
+ {
+ int32_t current = exp + dtoa_powers_ten[idx].exp + 64;
+ if (current < dtoa_expmin)
+ {
+ idx++;
+ continue;
+ }
+ if (current > dtoa_expmax)
+ {
+ idx--;
+ continue;
+ }
+ *k = (dtoa_firstpower + idx * dtoa_steppowers);
+ return(dtoa_powers_ten[idx]);
+ }
+}
+
+#define dtoa_fracmask 0x000FFFFFFFFFFFFFU
+#define dtoa_expmask 0x7FF0000000000000U
+#define dtoa_hiddenbit 0x0010000000000000U
+#define dtoa_signmask 0x8000000000000000U
+#define dtoa_expbias (1023 + 52)
+#define dtoa_absv(n) ((n) < 0 ? -(n) : (n))
+#define dtoa_minv(a, b) ((a) < (b) ? (a) : (b))
+
+static uint64_t dtoa_tens[] =
+ { 10000000000000000000U, 1000000000000000000U, 100000000000000000U,
+ 10000000000000000U, 1000000000000000U, 100000000000000U,
+ 10000000000000U, 1000000000000U, 100000000000U,
+ 10000000000U, 1000000000U, 100000000U,
+ 10000000U, 1000000U, 100000U,
+ 10000U, 1000U, 100U,
+ 10U, 1U};
+
+static uint64_t dtoa_get_dbits(double d)
+{
+ union {double dbl; uint64_t i;} dbl_bits = {d};
+ return(dbl_bits.i);
+}
+
+static dtoa_np dtoa_build_np(double d)
+{
+ uint64_t bits = dtoa_get_dbits(d);
+ dtoa_np fp;
+ fp.frac = bits & dtoa_fracmask;
+ fp.exp = (bits & dtoa_expmask) >> 52;
+ if (fp.exp)
+ {
+ fp.frac += dtoa_hiddenbit;
+ fp.exp -= dtoa_expbias;
+ }
+ else fp.exp = -dtoa_expbias + 1;
+ return(fp);
+}
+
+static void dtoa_normalize(dtoa_np* fp)
+{
+ int32_t shift = 64 - 52 - 1;
+ while ((fp->frac & dtoa_hiddenbit) == 0)
+ {
+ fp->frac <<= 1;
+ fp->exp--;
+ }
+ fp->frac <<= shift;
+ fp->exp -= shift;
+}
+
+static void dtoa_get_normalized_boundaries(const dtoa_np* fp, dtoa_np* lower, dtoa_np* upper)
+{
+ int32_t u_shift, l_shift;
+ upper->frac = (fp->frac << 1) + 1;
+ upper->exp = fp->exp - 1;
+ while ((upper->frac & (dtoa_hiddenbit << 1)) == 0)
+ {
+ upper->frac <<= 1;
+ upper->exp--;
+ }
+ u_shift = 64 - 52 - 2;
+ upper->frac <<= u_shift;
+ upper->exp = upper->exp - u_shift;
+ l_shift = fp->frac == dtoa_hiddenbit ? 2 : 1;
+ lower->frac = (fp->frac << l_shift) - 1;
+ lower->exp = fp->exp - l_shift;
+ lower->frac <<= lower->exp - upper->exp;
+ lower->exp = upper->exp;
+}
+
+static dtoa_np dtoa_multiply(dtoa_np* a, dtoa_np* b)
+{
+ dtoa_np fp;
+ const uint64_t lomask = 0x00000000FFFFFFFF;
+ uint64_t ah_bl = (a->frac >> 32) * (b->frac & lomask);
+ uint64_t al_bh = (a->frac & lomask) * (b->frac >> 32);
+ uint64_t al_bl = (a->frac & lomask) * (b->frac & lomask);
+ uint64_t ah_bh = (a->frac >> 32) * (b->frac >> 32);
+ uint64_t tmp = (ah_bl & lomask) + (al_bh & lomask) + (al_bl >> 32);
+ /* round up */
+ tmp += 1U << 31;
+ fp.frac = ah_bh + (ah_bl >> 32) + (al_bh >> 32) + (tmp >> 32);
+ fp.exp = a->exp + b->exp + 64;
+ return(fp);
+}
+
+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)))
+ {
+ digits[ndigits - 1]--;
+ rem += kappa;
+ }
+}
+
+static int32_t dtoa_generate_digits(dtoa_np* fp, dtoa_np* upper, dtoa_np* lower, char* digits, int* K)
+{
+ uint64_t part1, part2, wfrac = upper->frac - fp->frac, delta = upper->frac - lower->frac;
+ uint64_t *unit;
+ int32_t idx = 0, kappa = 10;
+ dtoa_np one;
+
+ one.frac = 1ULL << -upper->exp;
+ one.exp = upper->exp;
+ part1 = upper->frac >> -one.exp;
+ part2 = upper->frac & (one.frac - 1);
+
+ /* 1000000000 */
+ for (uint64_t *divp = dtoa_tens + 10; kappa > 0; divp++)
+ {
+ uint64_t tmp, div = *divp;
+ unsigned digit = part1 / div;
+ if (digit || idx)
+ 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);
+ }}
+
+ /* 10 */
+ unit = dtoa_tens + 18;
+ while(true)
+ {
+ unsigned digit;
+ part2 *= 10;
+ delta *= 10;
+ kappa--;
+ digit = part2 >> -one.exp;
+ if (digit || idx)
+ 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);
+ }
+ unit--;
+ }
+}
+
+static int32_t dtoa_grisu2(double d, char* digits, int* K)
+{
+ int32_t k;
+ dtoa_np cp, lower, upper;
+ dtoa_np w = dtoa_build_np(d);
+ dtoa_get_normalized_boundaries(&w, &lower, &upper);
+ dtoa_normalize(&w);
+ cp = dtoa_find_cachedpow10(upper.exp, &k);
+ w = dtoa_multiply(&w, &cp);
+ upper = dtoa_multiply(&upper, &cp);
+ lower = dtoa_multiply(&lower, &cp);
+ lower.frac++;
+ upper.frac--;
+ *K = -k;
+ return(dtoa_generate_digits(&w, &upper, &lower, digits, K));
+}
+
+static int32_t dtoa_emit_digits(char* digits, int32_t ndigits, char* dest, int32_t K, bool neg)
+{
+ int32_t idx, cent;
+ char sign;
+ int32_t exp = dtoa_absv(K + ndigits - 1);
+
+ /* write plain integer */
+ if ((K >= 0) && (exp < (ndigits + 7)))
+ {
+ memcpy(dest, digits, ndigits);
+ local_memset(dest + ndigits, '0', K);
+ dest[ndigits + K] = '.';
+ dest[ndigits + K + 1] = '0';
+ return(ndigits + K + 2);
+ }
+
+ /* write decimal w/o scientific notation */
+ if ((K < 0) && (K > -7 || exp < 4))
+ {
+ 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 */
+ }
+ else
+ {
+ 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);
+ idx = 0;
+ dest[idx++] = digits[0];
+ if (ndigits > 1)
+ {
+ dest[idx++] = '.';
+ memcpy(dest + idx, digits + 1, ndigits - 1);
+ idx += ndigits - 1;
+ }
+ dest[idx++] = 'e';
+ sign = K + ndigits - 1 < 0 ? '-' : '+';
+ dest[idx++] = sign;
+ cent = 0;
+ if (exp > 99)
+ {
+ cent = exp / 100;
+ dest[idx++] = cent + '0';
+ exp -= cent * 100;
+ }
+ if (exp > 9)
+ {
+ int32_t dec = exp / 10;
+ dest[idx++] = dec + '0';
+ exp -= dec * 10;
+ }
+ else
+ if (cent)
+ dest[idx++] = '0';
+
+ dest[idx++] = exp % 10 + '0';
+ return(idx);
+}
+
+static int32_t dtoa_filter_special(double fp, char* dest, bool neg)
+{
+ uint64_t bits;
+ bool nan;
+ if (fp == 0.0)
+ {
+ dest[0] = '0'; dest[1] = '.'; dest[2] = '0';
+ return(3);
+ }
+ bits = dtoa_get_dbits(fp);
+ nan = (bits & dtoa_expmask) == dtoa_expmask;
+ if (!nan) return(0);
+
+ if (!neg)
+ {
+ dest[0] = '+'; /* else 1.0-nan...? */
+ dest++;
+ }
+ if (bits & dtoa_fracmask)
+ {
+ s7_int payload = nan_payload(fp);
+ int32_t len;
+ len = (int32_t)snprintf(dest, 22, "nan.%" ld64, payload);
+ return((neg) ? len : len + 1);
+ }
+ dest[0] = 'i'; dest[1] = 'n'; dest[2] = 'f'; dest[3] = '.'; dest[4] = '0';
+ return((neg) ? 5 : 6);
+}
+
+static inline int32_t fpconv_dtoa(double d, char dest[24])
+{
+ char digit[23];
+ int32_t str_len = 0, spec, K, ndigits;
+ bool neg = false;
+
+ if (dtoa_get_dbits(d) & dtoa_signmask)
+ {
+ dest[0] = '-';
+ str_len++;
+ neg = true;
+ }
+ spec = dtoa_filter_special(d, dest + str_len, neg);
+ if (spec) return(str_len + spec);
+ K = 0;
+ ndigits = dtoa_grisu2(d, digit, &K);
+ str_len += dtoa_emit_digits(digit, ndigits, dest + str_len, K, neg);
+ return(str_len);
+}
+#endif
+
+
+/* -------------------------------- number->string -------------------------------- */
+static const char dignum[] = "0123456789abcdef";
+
+static size_t integer_to_string_any_base(char *p, s7_int n, int32_t radix) /* called by number_to_string_with_radix */
+{
+ s7_int i, len, end;
+ bool sign;
+ s7_int pown;
+
+ if ((radix < 2) || (radix > 16))
+ return(0);
+
+ 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"};
+
+ len = safe_strlen(mnfs[radix]);
+ memcpy((void *)p, (const void *)mnfs[radix], len);
+ p[len] = '\0';
+ return(len);
+ }
+
+ sign = (n < 0);
+ if (sign) n = -n;
+
+ /* the previous version that counted up to n, rather than dividing down below n, as here,
+ * could be confused by large ints on 64 bit machines
+ */
+ pown = n;
+ for (i = 1; i < 100; i++)
+ {
+ if (pown < radix)
+ break;
+ pown /= (s7_int)radix;
+ }
+ len = i - 1;
+ if (sign) len++;
+ end = 0;
+ if (sign)
+ {
+ p[0] = '-';
+ end++;
+ }
+ for (i = len; i >= end; i--)
+ {
+ p[i] = dignum[n % radix];
+ n /= radix;
+ }
+ p[len + 1] = '\0';
+ return(len + 1);
+}
+
+static const char *integer_to_string(s7_scheme *sc, s7_int num, s7_int *nlen) /* do not free the returned string */
+{
+ char *p, *op;
+ bool sign;
+
+ if (num == S7_INT64_MIN)
+ {
+ (*nlen) = 20;
+ return((const char *)"-9223372036854775808");
+ }
+ p = (char *)(sc->int_to_str1 + INT_TO_STR_SIZE - 1);
+ op = p;
+ *p-- = '\0';
+
+ sign = (num < 0);
+ if (sign) num = -num; /* we need a positive index below */
+ do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num);
+ if (sign)
+ {
+ *p = '-';
+ (*nlen) = op - p;
+ return(p);
+ }
+ (*nlen) = op - p - 1;
+ return(++p);
+}
+
+static char *integer_to_string_no_length(s7_scheme *sc, s7_int num) /* do not free the returned string */
+{
+ char *p;
+ bool sign;
+
+ if (num == S7_INT64_MIN)
+ return(number_name(leastfix)); /* "-9223372036854775808" but avoids a compiler complaint */
+ p = (char *)(sc->int_to_str2 + INT_TO_STR_SIZE - 1);
+ *p-- = '\0';
+ sign = (num < 0);
+ if (sign) num = -num;
+ do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num);
+ if (sign)
+ {
+ *p = '-';
+ return(p);
+ }
+ return(++p);
+}
+
+static char *floatify(char *str, s7_int *nlen)
+{
+ if ((!strchr(str, '.')) && (!strchr(str, 'e'))) /* faster than (strcspn(str, ".e") >= (size_t)(*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;
+ }}
+ str[len]='.';
+ str[len + 1]='0';
+ str[len + 2]='\0';
+ (*nlen) = len + 2;
+ }
+ return(str);
+}
+
+static void insert_spaces(s7_scheme *sc, const char *src, s7_int width, s7_int len)
+{
+ s7_int spaces = width - len;
+ if (width >= sc->num_to_str_size)
+ {
+ sc->num_to_str_size = width + 1;
+ sc->num_to_str = (char *)Realloc(sc->num_to_str, sc->num_to_str_size);
+ }
+ sc->num_to_str[width] = '\0';
+ memmove((void *)(sc->num_to_str + spaces), (const void *)src, len);
+ local_memset((void *)(sc->num_to_str), (int)' ', spaces);
+}
+
+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 */
+{
+ /* 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
+ * a tricky case: (format #f "~f" 1e308) -- tries to print 308 digits! so 256 as default len is too small.
+ * but then even worse: (format #f "~F" 1e308+1e308i)!
+ */
+ s7_int len = width + precision;
+ len = (len > 512) ? (512 + 2 * len) : 1024;
+ if (len > sc->num_to_str_size)
+ {
+ sc->num_to_str = (sc->num_to_str) ? (char *)Realloc(sc->num_to_str, len) : (char *)Malloc(len);
+ sc->num_to_str_size = len;
+ }
+
+ /* bignums can't happen here */
+ if (is_t_integer(obj))
+ {
+ 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));
+ }
+ 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);
+ }
+ (*nlen) = len;
+ return((char *)p);
+ }
+
+ 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 */
+ }
+ 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 */
+ (*nlen) = len;
+ floatify(sc->num_to_str, nlen);
+ return(sc->num_to_str);
+ }
+
+ if (is_t_complex(obj))
+ {
+ char *imag;
+ sc->num_to_str[0] = '\0';
+ imag = copy_string(number_to_string_base_10(sc, wrap_real(sc, imag_part(obj)), 0, precision, float_choice, &len, choice));
+
+ sc->num_to_str[0] = '\0';
+ number_to_string_base_10(sc, wrap_real(sc, real_part(obj)), 0, precision, float_choice, &len, choice);
+
+ sc->num_to_str[len] = '\0';
+ len = catstrs(sc->num_to_str, sc->num_to_str_size, ((imag[0] == '+') || (imag[0] == '-')) ? "" : "+", imag, "i", (char *)NULL);
+ 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;
+ }
+ else (*nlen) = len;
+ return(sc->num_to_str);
+ }
+
+ /* ratio */
+ len = catstrs_direct(sc->num_to_str, integer_to_string_no_length(sc, numerator(obj)), "/", pos_int_to_str_direct(sc, denominator(obj)), (const char *)NULL);
+ if (width > len)
+ {
+ insert_spaces(sc, sc->num_to_str, width, len);
+ (*nlen) = width;
+ }
+ else (*nlen) = len;
+ return(sc->num_to_str);
+}
+
+static block_t *number_to_string_with_radix(s7_scheme *sc, s7_pointer obj, int32_t radix, s7_int width, s7_int precision, char float_choice, s7_int *nlen)
+{
+ /* called by s7_number_to_string (char*), g_number_to_string (strp), number_to_string_p_pp (strp), format_number (strp basically) */
+ /* the rest of s7 assumes nlen is set to the correct length */
+ block_t *b;
+ char *p;
+ s7_int len, str_len;
+
+#if WITH_GMP
+ if (s7_is_bignum(obj))
+ return(big_number_to_string_with_radix(sc, obj, radix, width, nlen, P_WRITE));
+ /* this ignores precision because it's way too hard to get the mpfr string to look like
+ * C's output -- we either have to call mpfr_get_str twice (the first time just to
+ * find out what the exponent is and how long the string actually is), or we have
+ * to do messy string manipulations. So (format #f "",3F" pi) ignores the "3" and
+ * prints the full string. And don't even think about mpfr_snprintf!
+ */
+#endif
+ if (radix == 10)
+ {
+ p = number_to_string_base_10(sc, obj, width, precision, float_choice, nlen, P_WRITE);
+ return(string_to_block(sc, p, *nlen));
+ }
+
+ switch (type(obj))
+ {
+ 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);
+ }
+
+ 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);
+ len = len1 + 1 + len2;
+ p[len] = '\0';
+ }
+ break;
+
+ 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);
+ 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;
+ }
+ 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);
+ }
+ break;
+ }
+
+ if (width > len)
+ {
+ s7_int spaces;
+ if (width >= str_len)
+ {
+ 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);
+ local_memset((void *)p, (int)' ', spaces);
+ (*nlen) = width;
+ }
+ else (*nlen) = len;
+ return(b);
+}
+
+char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, s7_int radix)
+{
+ s7_int nlen = 0;
+ block_t *b = number_to_string_with_radix(sc, obj, radix, 0, 20, 'g', &nlen); /* (log top 10) so we get all the digits in base 10 (??) */
+ char *str = copy_string_with_length((char *)block_data(b), nlen);
+ liberate(sc, b);
+ return(str);
+}
+
+static s7_pointer g_number_to_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_number_to_string "(number->string num (radix 10)) converts the number num into a string."
+ #define Q_number_to_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_number_symbol, sc->is_integer_symbol)
+
+ s7_int nlen = 0, radix; /* ignore cppcheck complaint about radix! */
+ const char *res;
+ s7_pointer x = car(args);
+
+ if (!is_number(x))
+ return(method_or_bust(sc, x, sc->number_to_string_symbol, args, a_number_string, 1));
+
+ if (is_pair(cdr(args)))
+ {
+ s7_pointer y = cadr(args);
+ if (s7_is_integer(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);
+#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));
+ }}
+#if WITH_GMP
+ else radix = 10;
+ if (s7_is_bignum(x))
+ {
+ block_t *b = big_number_to_string_with_radix(sc, x, radix, 0, &nlen, P_WRITE);
+ return(block_to_string(sc, b, nlen));
+ }
+ res = number_to_string_base_10(sc, x, 0, sc->float_format_precision, 'g', &nlen, P_WRITE);
+#else
+ if (is_t_integer(x))
+ {
+ if (has_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);
+#endif
+ return(inline_make_string_with_length(sc, res, nlen));
+}
+
+static s7_pointer number_to_string_p_p(s7_scheme *sc, s7_pointer p)
+{
+#if WITH_GMP
+ return(g_number_to_string(sc, set_plist_1(sc, p)));
+#else
+ s7_int nlen = 0;
+ char *res;
+ if (!is_number(p))
+ return(method_or_bust_p(sc, p, sc->number_to_string_symbol, a_number_string));
+ res = number_to_string_base_10(sc, p, 0, sc->float_format_precision, 'g', &nlen, P_WRITE);
+ return(inline_make_string_with_length(sc, res, nlen));
+#endif
+}
+
+static s7_pointer number_to_string_p_i(s7_scheme *sc, s7_int p)
+{
+ s7_int nlen = 0;
+ const char *res = integer_to_string(sc, p, &nlen);
+ return(inline_make_string_with_length(sc, res, nlen));
+}
+/* not number_to_string_p_d! */
+
+static s7_pointer number_to_string_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+#if WITH_GMP
+ return(g_number_to_string(sc, set_plist_2(sc, p1, p2)));
+#else
+ s7_int nlen = 0, radix;
+ block_t *b;
+
+ if (!is_number(p1))
+ wrong_type_error_nr(sc, sc->number_to_string_symbol, 1, p1, a_number_string);
+ if (!is_t_integer(p2))
+ wrong_type_error_nr(sc, sc->number_to_string_symbol, 2, p2, sc->type_names[T_INTEGER]);
+ radix = integer(p2);
+ if ((radix < 2) || (radix > 16))
+ out_of_range_error_nr(sc, sc->number_to_string_symbol, int_two, p2, a_valid_radix_string);
+
+ b = number_to_string_with_radix(sc, p1, radix, 0, sc->float_format_precision, 'g', &nlen);
+ return(block_to_string(sc, b, nlen));
+#endif
+}
+
+
+/* -------------------------------------------------------------------------------- */
+#define CTABLE_SIZE 256
+static bool *exponent_table, *slashify_table, *char_ok_in_a_name, *white_space, *number_table, *symbol_slashify_table;
+static int32_t *digits;
+
+static void init_ctables(void)
+{
+ exponent_table = (bool *)Calloc(CTABLE_SIZE, sizeof(bool));
+ slashify_table = (bool *)Calloc(CTABLE_SIZE, sizeof(bool));
+ symbol_slashify_table = (bool *)Calloc(CTABLE_SIZE, sizeof(bool));
+ char_ok_in_a_name = (bool *)Calloc(CTABLE_SIZE, sizeof(bool));
+ white_space = (bool *)Calloc(CTABLE_SIZE + 1, sizeof(bool));
+ white_space++; /* leave white_space[-1] false for white_space[EOF] */
+ number_table = (bool *)Calloc(CTABLE_SIZE, sizeof(bool));
+ digits = (int32_t *)Calloc(CTABLE_SIZE, sizeof(int32_t));
+
+ for (int32_t i = 0; i < CTABLE_SIZE; i++)
+ {
+ char_ok_in_a_name[i] = true;
+ white_space[i] = false;
+ digits[i] = 256;
+ number_table[i] = false;
+ }
+
+ char_ok_in_a_name[0] = false;
+ char_ok_in_a_name[(uint8_t)'('] = false; /* cast for C++ */
+ char_ok_in_a_name[(uint8_t)')'] = false;
+ char_ok_in_a_name[(uint8_t)';'] = false;
+ char_ok_in_a_name[(uint8_t)'\t'] = false;
+ char_ok_in_a_name[(uint8_t)'\n'] = false;
+ char_ok_in_a_name[(uint8_t)'\r'] = false;
+ char_ok_in_a_name[(uint8_t)' '] = false;
+ char_ok_in_a_name[(uint8_t)'"'] = false;
+
+ white_space[(uint8_t)'\t'] = true;
+ white_space[(uint8_t)'\n'] = true;
+ white_space[(uint8_t)'\r'] = true;
+ white_space[(uint8_t)'\f'] = true;
+ white_space[(uint8_t)'\v'] = true;
+ white_space[(uint8_t)' '] = true;
+ white_space[(uint8_t)'\205'] = true; /* 133 */
+ white_space[(uint8_t)'\240'] = true; /* 160 */
+
+ /* surely only 'e' is needed... */
+ exponent_table[(uint8_t)'e'] = true; exponent_table[(uint8_t)'E'] = true;
+ exponent_table[(uint8_t)'@'] = true;
+#if WITH_EXTRA_EXPONENT_MARKERS
+ exponent_table[(uint8_t)'s'] = true; exponent_table[(uint8_t)'S'] = true;
+ exponent_table[(uint8_t)'f'] = true; exponent_table[(uint8_t)'F'] = true;
+ exponent_table[(uint8_t)'d'] = true; exponent_table[(uint8_t)'D'] = true;
+ exponent_table[(uint8_t)'l'] = true; exponent_table[(uint8_t)'L'] = true;
+#endif
+ for (int32_t i = 0; i < 32; i++) slashify_table[i] = true;
+ /* for (int32_t i = 127; i < 160; i++) slashify_table[i] = true; */ /* 6-Apr-24 for utf-8, but this has no effect on s7test?? */
+ slashify_table[(uint8_t)'\\'] = true;
+ slashify_table[(uint8_t)'"'] = true;
+ slashify_table[(uint8_t)'\n'] = false;
+
+ for (int32_t i = 0; i < CTABLE_SIZE; i++)
+ symbol_slashify_table[i] = ((slashify_table[i]) || (!char_ok_in_a_name[i])); /* force use of (symbol ...) for cases like '(ab) as symbol */
+
+ digits[(uint8_t)'0'] = 0; digits[(uint8_t)'1'] = 1; digits[(uint8_t)'2'] = 2; digits[(uint8_t)'3'] = 3; digits[(uint8_t)'4'] = 4;
+ digits[(uint8_t)'5'] = 5; digits[(uint8_t)'6'] = 6; digits[(uint8_t)'7'] = 7; digits[(uint8_t)'8'] = 8; digits[(uint8_t)'9'] = 9;
+ digits[(uint8_t)'a'] = 10; digits[(uint8_t)'A'] = 10;
+ digits[(uint8_t)'b'] = 11; digits[(uint8_t)'B'] = 11;
+ digits[(uint8_t)'c'] = 12; digits[(uint8_t)'C'] = 12;
+ digits[(uint8_t)'d'] = 13; digits[(uint8_t)'D'] = 13;
+ digits[(uint8_t)'e'] = 14; digits[(uint8_t)'E'] = 14;
+ digits[(uint8_t)'f'] = 15; digits[(uint8_t)'F'] = 15;
+
+ number_table[(uint8_t)'0'] = true; number_table[(uint8_t)'1'] = true; number_table[(uint8_t)'2'] = true; number_table[(uint8_t)'3'] = true;
+ number_table[(uint8_t)'4'] = true; number_table[(uint8_t)'5'] = true; number_table[(uint8_t)'6'] = true; number_table[(uint8_t)'7'] = true;
+ number_table[(uint8_t)'8'] = true; number_table[(uint8_t)'9'] = true; number_table[(uint8_t)'.'] = true;
+ number_table[(uint8_t)'+'] = true;
+ number_table[(uint8_t)'-'] = true;
+ number_table[(uint8_t)'#'] = true;
+}
+
+#define is_white_space(C) white_space[C]
+ /* this is much faster than C's isspace, and does not depend on the current locale.
+ * if c == EOF (-1), it indexes into the empty (0) slot we preallocated below white_space
+ */
+
+/* -------------------------------- *#readers* -------------------------------- */
+static s7_pointer check_sharp_readers(s7_scheme *sc, const char *name)
+{
+ s7_pointer value = sc->F, args = sc->F;
+ bool need_loader_port = is_loader_port(current_input_port(sc));
+
+ /* *#reader* is assumed to be an alist of (char . proc)
+ * where each proc takes one argument, the string from just beyond the "#" to the next delimiter.
+ * The procedure can call read-char to read ahead in the current-input-port.
+ * If it returns anything other than #f, that is the value of the sharp expression.
+ * Since #f means "nothing found", it is tricky to handle #F:
+ * (cons #\F (lambda (str) (and (string=? str "F") (list 'not #t)))) ; or ''#f used in lint.scm
+ * This search happens after #|, #t, and #f (and #nD for multivectors?). #! has a fallback. Added #_ later)
+ */
+ if (need_loader_port)
+ clear_loader_port(current_input_port(sc));
+
+ /* normally read* can't read from current_input_port(sc) if it is in use by the loader, but here we are deliberately making that possible */
+ 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 (need_loader_port)
+ set_loader_port(current_input_port(sc));
+ return(value);
+}
+
+static s7_pointer g_sharp_readers_set(s7_scheme *sc, s7_pointer args)
+{
+ /* new value must be either () or a proper list of conses (char . func) */
+ s7_pointer x;
+ if (is_null(cadr(args))) return(cadr(args));
+ if (!is_pair(cadr(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))))
+ error_nr(sc, sc->wrong_type_arg_symbol,
+ 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));
+}
+
+static s7_pointer make_undefined(s7_scheme *sc, const char* name)
+{
+ s7_int len = safe_strlen(name);
+ char *newstr = (char *)Malloc(len + 2);
+ s7_pointer p;
+ new_cell(sc, p, T_UNDEFINED | T_IMMUTABLE);
+ newstr[0] = '#';
+ memcpy((void *)(newstr + 1), (const void *)name, len);
+ newstr[len + 1] = '\0';
+ if (sc->undefined_constant_warnings) s7_warn(sc, len + 32, "%s is undefined\n", newstr);
+ undefined_set_name_length(p, len + 1);
+ undefined_name(p) = newstr;
+ add_undefined(sc, p);
+ return(p);
+}
+
+static int32_t inchar(s7_pointer pt)
+{
+ int32_t c;
+ if (is_file_port(pt))
+ c = fgetc(port_file(pt)); /* not uint8_t! -- could be EOF */
+ else
+ {
+ if (port_data_size(pt) <= port_position(pt))
+ return(EOF);
+ c = (uint8_t)port_data(pt)[port_position(pt)++];
+ }
+ if (c == '\n')
+ port_line_number(pt)++;
+ return(c);
+}
+
+static void backchar(char c, s7_pointer pt)
+{
+ if (c == '\n')
+ port_line_number(pt)--;
+
+ if (is_file_port(pt))
+ ungetc(c, port_file(pt));
+ else
+ if (port_position(pt) > 0)
+ port_position(pt)--;
+}
+
+static void resize_strbuf(s7_scheme *sc, s7_int needed_size)
+{
+ s7_int old_size = sc->strbuf_size;
+ while (sc->strbuf_size <= needed_size) sc->strbuf_size *= 2;
+ sc->strbuf = (char *)Realloc(sc->strbuf, sc->strbuf_size);
+ for (s7_int i = old_size; i < sc->strbuf_size; i++) sc->strbuf[i] = '\0';
+}
+
+static s7_pointer *chars;
+
+static s7_pointer unknown_sharp_constant(s7_scheme *sc, const char *name, s7_pointer pt)
+{
+ /* if name[len - 1] != '>' there's no > delimiter at the end */
+
+ if (hook_has_functions(sc->read_error_hook)) /* check *read-error-hook* */
+ {
+ bool old_history_enabled = s7_set_history_enabled(sc, false); /* see sc->error_hook for a more robust way to handle this */
+ 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);
+ }
+ 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);
+ }}}
+ return(make_undefined(sc, name));
+}
+
+static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_symbol, bool with_error);
+#define SYMBOL_OK true
+#define NO_SYMBOLS false
+
+static s7_pointer make_sharp_constant(s7_scheme *sc, const char *name, bool with_error, s7_pointer pt, bool error_if_bad_number)
+{
+ /* name is the stuff after the '#', return sc->nil if not a recognized #... entity */
+ if ((!name) || (!*name)) /* (string->number "#") for example */
+ return(make_undefined(sc, name));
+
+ /* stupid r7rs special cases */
+ if ((name[0] == 't') &&
+ ((name[1] == '\0') || (c_strings_are_equal(name, "true"))))
+ return(sc->T);
+
+ if ((name[0] == 'f') &&
+ ((name[1] == '\0') || (c_strings_are_equal(name, "false"))))
+ return(sc->F);
+
+ if (name[0] == '_')
+ {
+ /* this needs to be unsettable via *#readers*:
+ * (set! *#readers* (list (cons #\_ (lambda (str) (string->symbol (substring str 1))))))
+ * (let ((+ -)) (#_+ 1 2)): -1
+ */
+ s7_pointer sym = make_symbol_with_strlen(sc, (const char *)(name + 1));
+ if ((!is_gensym(sym)) && (is_slot(initial_slot(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.
+ */
+ return(make_undefined(sc, name)); /* (define x (with-input-from-string "(#_asdf 1 2)" read)) (type-of (car x)) -> undefined? */
+ }
+
+ if (is_not_null(slot_value(sc->sharp_readers)))
+ {
+ s7_pointer x = check_sharp_readers(sc, name);
+ if (x != sc->F)
+ return(x);
+ }
+
+ if ((name[0] == '\0') || name[1] == '\0')
+ return(unknown_sharp_constant(sc, name, pt)); /* pt here because #<"..."> comes here as "<" so name[1] is '\0'! */
+
+ switch (name[0])
+ {
+ /* -------- #< ... > -------- */
+ case '<':
+ if (c_strings_are_equal(name, "<unspecified>")) return(sc->unspecified);
+ if (c_strings_are_equal(name, "<undefined>")) return(sc->undefined);
+ if (c_strings_are_equal(name, "<eof>")) return(eof_object);
+ return(unknown_sharp_constant(sc, name, pt));
+
+ /* -------- #o #x #b -------- */
+ case 'o': /* #o (octal) */
+ 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);
+ }
+
+ /* -------- #\... -------- */
+ case '\\':
+ if (name[2] == 0) /* the most common case: #\a */
+ 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;
+ }}
+ return(unknown_sharp_constant(sc, name, NULL));
+}
+
+static s7_int string_to_integer(const char *str, int32_t radix, bool *overflow)
+{
+ bool negative = false;
+ s7_int lval = 0;
+ int32_t dig;
+ const char *tmp = (const char *)str;
+#if WITH_GMP
+ const char *tmp1;
+#endif
+ if (str[0] == '+')
+ tmp++;
+ else
+ if (str[0] == '-')
+ {
+ negative = true;
+ tmp++;
+ }
+ while (*tmp == '0') {tmp++;};
+#if WITH_GMP
+ tmp1 = tmp;
+#endif
+ if (radix == 10)
+ {
+ while (true)
+ {
+ 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);
+ }
+#else
+ 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;
+#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;
+ }}
+#else
+ 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]));
+ /* 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);
+}
+
+/* 9223372036854775807 9223372036854775807
+ * -9223372036854775808 -9223372036854775808
+ * 0000000000000000000000000001.0 1.0
+ * 1.0000000000000000000000000000 1.0
+ * 1000000000000000000000000000.0e-40 1.0e-12
+ * 0.0000000000000000000000000001e40 1.0e12
+ * 1.0e00000000000000000001 10.0
+ */
+
+#if WITH_GMP
+static s7_double string_to_double_with_radix(const char *ur_str, int32_t radix, bool *overflow)
+#else
+#define string_to_double_with_radix(Str, Rad, Over) string_to_double_with_radix_1(Str, Rad)
+static s7_double string_to_double_with_radix_1(const char *ur_str, int32_t radix)
+#endif
+{
+ /* strtod follows LANG which is not what we want (only "." is decimal point in Scheme).
+ * To overcome LANG in strtod would require screwing around with setlocale which never works.
+ * So we use our own code -- according to valgrind, this function is much faster than strtod.
+ * comma as decimal point causes ambiguities: `(+ ,1 2) etc
+ */
+ int32_t i, sign = 1, frac_len, int_len, dig, exponent = 0;
+ int32_t max_len = s7_int_digits_by_radix[radix];
+ int64_t int_part = 0, frac_part = 0;
+ const char *str = ur_str;
+ const char *ipart, *fpart;
+ s7_double dval = 0.0;
+
+ /* there's an ambiguity in number notation here if we allow "1e1" or "1.e1" in base 16 (or 15) -- is e a digit or an exponent marker?
+ * but 1e+1, for example disambiguates it -- kind of messy! -- the scheme spec says "e" can only occur in base 10.
+ * '@' can now be used as the exponent marker (26-Mar-12).
+ * Another slight ambiguity: 1+1/2i is parsed as 1 + 0.5i, not 1+1/(2i), or (1+1)/(2i) or (1+1/2)i etc
+ */
+ if (*str == '-')
+ {
+ str++;
+ sign = -1;
+ }
+ else
+ if (*str == '+')
+ str++;
+ while (*str == '0') {str++;};
+
+ ipart = str;
+ while (digits[(int32_t)(*str)] < radix) str++;
+ int_len = str - ipart;
+
+ if (*str == '.') str++;
+ fpart = str;
+ while (digits[(int32_t)(*str)] < radix) str++;
+ frac_len = str - fpart;
+
+ if ((*str) && (exponent_table[(uint8_t)(*str)]))
+ {
+ bool exp_negative = false;
+ str++;
+ if (*str == '+')
+ str++;
+ else
+ 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;
+ }
+#else
+ 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 */
+#endif
+ if (exp_negative)
+ exponent = -exponent;
+
+ /* 2e12341234123123123123213123123123 -> 0.0
+ * but exp len is not the decider: 2e00000000000000000000000000000000000000001 -> 20.0
+ * first zero: 2e123412341231231231231
+ * then: 2e12341234123123123123123123 -> inf
+ * then: 2e123412341231231231231231231231231231 -> 0.0
+ * 2e-123412341231231231231 -> inf
+ * but: 0e123412341231231231231231231231231231
+ */
+ }
+
+#if WITH_GMP
+ /* 9007199254740995.0 */
+ if (int_len + frac_len >= max_len)
+ {
+ (*overflow) = true;
+ return(0.0);
+ }
+#endif
+ str = ipart;
+ if ((int_len + exponent) > max_len)
+ {
+ /* 12341234.56789e12 12341234567889999872.0 1.234123456789e+19
+ * -1234567890123456789.0 -1234567890123456768.0 -1.2345678901235e+18
+ * 12345678901234567890.0 12345678901234567168.0 1.2345678901235e+19
+ * 123.456e30 123456000000000012741097792995328.0 1.23456e+32
+ * 12345678901234567890.0e12 12345678901234569054409354903552.0 1.2345678901235e+31
+ * 1.234567890123456789012e30 1234567890123456849145940148224.0 1.2345678901235e+30
+ * 1e20 100000000000000000000.0 1e+20
+ * 1234567890123456789.0 1234567890123456768.0 1.2345678901235e+18
+ * 123.456e16 1234560000000000000.0 1.23456e+18
+ * 98765432101234567890987654321.0e-5 987654321012345728401408.0 9.8765432101235e+23
+ * 98765432101234567890987654321.0e-10 9876543210123456512.0 9.8765432101235e+18
+ * 0.00000000000000001234e20 1234.0
+ * 0.000000000000000000000000001234e30 1234.0
+ * 0.0000000000000000000000000000000000001234e40 1234.0
+ * 0.000000000012345678909876543210e15 12345.678909877
+ * 0e1000 0.0
+ */
+
+ for (i = 0; i < max_len; i++)
+ {
+ 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);
+#if WITH_GMP
+ (*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);
+ }
+ 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);
+ }}
+ 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);
+ }
+ return(sign * dval);
+ }
+
+ /* int_len + exponent <= max_len */
+ if (int_len <= max_len)
+ {
+ int32_t int_exponent = exponent;
+ /* a better algorithm (since the inaccuracies are in the radix^exponent portion):
+ * strip off leading zeros and possible sign,
+ * strip off digits beyond max_len, then remove any trailing zeros.
+ * (maybe fiddle with the lowest order digit here for rounding, but I doubt it matters)
+ * read digits until end of number or max_len reached, ignoring the decimal point
+ * get exponent and use it and decimal point location to position the current result integer
+ * 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);
+ }
+ dval = (int_exponent == 0) ? (s7_double)int_part : int_part * dpow(radix, int_exponent);
+ }
+ else
+ {
+ int32_t flen, len = int_len + exponent;
+ int64_t frpart = 0;
+
+ /* 98765432101234567890987654321.0e-20 987654321.012346
+ * 98765432101234567890987654321.0e-29 0.98765432101235
+ * 98765432101234567890987654321.0e-30 0.098765432101235
+ * 98765432101234567890987654321.0e-28 9.8765432101235
+ */
+ for (i = 0; i < len; i++)
+ int_part = digits[(int32_t)(*str++)] + (int_part * radix);
+ flen = -exponent;
+ if (flen > max_len)
+ flen = max_len;
+ for (i = 0; i < flen; i++)
+ frpart = digits[(int32_t)(*str++)] + (frpart * radix);
+ if (len <= 0)
+ dval = int_part + frpart * dpow(radix, len - flen);
+ else dval = int_part + frpart * dpow(radix, -flen);
+ }
+
+ if (frac_len > 0)
+ {
+ 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.
+ */
+ }
+ 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 WITH_GMP
+ if ((int_part == 0) &&
+ (frac_part == 0))
+ return(0.0);
+ (*overflow) = ((frac_len - exponent) > max_len);
+#endif
+ return(sign * dval);
+}
+
+#if (!WITH_GMP)
+static s7_pointer make_undefined_bignum(s7_scheme *sc, const char *name)
+{
+ s7_int len = safe_strlen(name) + 16;
+ block_t *b = mallocate(sc, len);
+ char *buf = (char *)block_data(b);
+ s7_pointer res;
+ snprintf(buf, len, "<bignum: %s>", name);
+ res = make_undefined(sc, (const char *)buf); /* 123123123123123123123123123123 -> +inf.0 originally, but now #<bignum: 123123...> */
+ liberate(sc, b);
+ return(res);
+}
+#endif
+
+static s7_pointer nan1_or_bust(s7_scheme *sc, s7_double x, const char *p, const char *q, int32_t radix, bool want_symbol, int32_t offset)
+{
+ s7_int len = safe_strlen(p);
+ 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));
+ 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 */
+ }}
+ return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
+}
+
+static s7_pointer nan2_or_bust(s7_scheme *sc, s7_double x, const char *q, int32_t radix, bool want_symbol, int64_t rl_len)
+{
+ s7_int len = safe_strlen(q);
+ if ((len > rl_len) && (len < 1024)) /* make compiler happy */
+ {
+ char *ip = copy_string_with_length(q, rl_len);
+ 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((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
+}
+
+#if WITH_NUMBER_SEPARATOR
+static s7_pointer string_to_number(s7_scheme *sc, char *str, int32_t radix);
+
+static s7_pointer make_symbol_or_number(s7_scheme *sc, const char *name, int32_t radix, bool want_symbol)
+{
+ block_t *b;
+ char *new_name;
+ char sep = sc->number_separator;
+ s7_int len, i, j;
+ s7_pointer res;
+
+ if (name[0] == sep)
+ return((want_symbol) ? make_symbol_with_strlen(sc, name) : sc->F);
+ len = safe_strlen(name);
+ b = mallocate(sc, len + 1);
+ new_name = (char *)block_data(b);
+ memcpy((void *)new_name, (const void *)name, len);
+ new_name[len] = 0;
+
+ 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);
+ }}
+ 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);
+ }
+
+ new_name[j] = '\0';
+ res = string_to_number(sc, new_name, radix);
+ liberate(sc, b);
+ return(res);
+}
+#endif
+
+static s7_pointer make_atom(s7_scheme *sc, char *q, int32_t radix, bool want_symbol, bool with_error)
+{
+ /* make symbol or number from string, a number starts with + - . or digit, but so does 1+ for example */
+#if WITH_NUMBER_SEPARATOR
+ #define is_digit(Chr, Rad) ((digits[(uint8_t)Chr] < Rad) || ((Chr == sc->number_separator) && (sc->number_separator != '\0')))
+#else
+ #define is_digit(Chr, Rad) (digits[(uint8_t)Chr] < Rad)
+#endif
+ char c, *p = q;
+ bool has_dec_point1 = false;
+
+ c = *p++;
+ switch (c)
+ {
+ case '#':
+ /* from string->number, (string->number #xc) */
+ return(make_sharp_constant(sc, p, with_error, NULL, false)); /* make_sharp_constant expects the '#' to be removed */
+
+ case '+':
+ case '-':
+ c = *p++;
+ if (c == '.')
+ {
+ has_dec_point1 = true;
+ c = *p++;
+ }
+ if (!c)
+ 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);
+ }
+ 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);
+ break;
+
+ case 'n':
+ return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
+
+ case 'i':
+ return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
+
+ case '0': /* these two are always digits */
+ case '1':
+ break;
+
+ default:
+ if (!is_digit(c, radix))
+ return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
+ break;
+ }
+
+ /* now it's possibly a number -- the first character(s) could be part of a number in the current radix */
+ {
+ char *slash1 = NULL, *slash2 = NULL, *plus = NULL, *ex1 = NULL, *ex2 = NULL;
+ bool has_i = false, has_dec_point2 = false;
+ int32_t has_plus_or_minus = 0, current_radix;
+#if (!WITH_GMP)
+ bool overflow = false; /* for string_to_integer */
+#endif
+ current_radix = radix; /* current_radix is 10 for the exponent portions, but radix for all the rest */
+
+ 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 -------- */
+#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);
+ }}
+
+ if ((has_plus_or_minus != 0) && /* that is, we have an internal + or - */
+ (!has_i)) /* but no i for the imaginary part */
+ return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F);
+
+#if WITH_NUMBER_SEPARATOR
+ if ((sc->number_separator != '\0') && (strchr(q, (int)(sc->number_separator))))
+ return(make_symbol_or_number(sc, q, radix, want_symbol));
+#endif
+
+ if (has_i)
+ {
+#if (!WITH_GMP)
+ s7_double rl = 0.0, im = 0.0;
+#else
+ char e1 = 0, e2 = 0;
+#endif
+ 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);
+
+ /* 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) = '@';}
+#endif
+ /* look for cases like 1+i */
+ q[len - 1] = ((q[len - 2] == '+') || (q[len - 2] == '-')) ? '1' : '\0'; /* remove 'i' */
+
+ (*((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);
+#else
+ 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;
+#if WITH_GMP
+ if (ex1) (*ex1) = e1;
+ if (ex2) (*ex2) = e2;
+#endif
+ return(result);
+ }
+
+ /* not complex */
+ if ((has_dec_point1) ||
+ (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);
+
+#if (!WITH_GMP)
+ 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);
+ }
+
+ /* 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));
+ }
+#else
+ return(string_to_either_ratio(sc, q, slash1, radix));
+#endif
+ /* integer */
+#if (!WITH_GMP)
+ {
+ s7_int x = string_to_integer(q, radix, &overflow);
+ if (overflow) return(make_undefined_bignum(sc, q));
+ return(make_integer(sc, x));
+ }
+#else
+ return(string_to_either_integer(sc, q, radix));
+#endif
+ }
+}
+
+
+/* -------------------------------- string->number -------------------------------- */
+static s7_pointer string_to_number(s7_scheme *sc, char *str, int32_t radix)
+{
+ s7_pointer x = make_atom(sc, str, radix, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR);
+ return((is_number(x)) ? x : sc->F); /* only needed because str might start with '#' and not be a number (#t for example) */
+}
+
+static s7_pointer string_to_number_p_p(s7_scheme *sc, s7_pointer str1)
+{
+ char *str;
+ if (!is_string(str1))
+ wrong_type_error_nr(sc, sc->string_to_number_symbol, 1, str1, sc->type_names[T_STRING]);
+ str = (char *)string_value(str1);
+ return(((!str) || (!(*str))) ? sc->F : string_to_number(sc, str, 10));
+}
+
+static s7_pointer string_to_number_p_pp(s7_scheme *sc, s7_pointer str1, s7_pointer radix1)
+{
+ s7_int radix;
+ char *str;
+ if (!is_string(str1))
+ wrong_type_error_nr(sc, sc->string_to_number_symbol, 1, str1, sc->type_names[T_STRING]);
+
+ if (!is_t_integer(radix1))
+ wrong_type_error_nr(sc, sc->string_to_number_symbol, 2, radix1, sc->type_names[T_INTEGER]);
+ radix = integer(radix1);
+ if ((radix < 2) || (radix > 16))
+ out_of_range_error_nr(sc, sc->string_to_number_symbol, int_two, radix1, a_valid_radix_string);
+
+ str = (char *)string_value(str1);
+ if ((!str) || (!(*str)))
+ return(sc->F);
+ return(string_to_number(sc, str, radix));
+}
+
+static s7_pointer g_string_to_number_1(s7_scheme *sc, s7_pointer args, s7_pointer caller)
+{
+ s7_int radix;
+ char *str;
+ if (!is_string(car(args)))
+ return(method_or_bust(sc, car(args), caller, args, sc->type_names[T_STRING], 1));
+
+ if (is_pair(cdr(args)))
+ {
+ s7_pointer rad = cadr(args);
+ if (!s7_is_integer(rad))
+ 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);
+ }
+ else radix = 10;
+ str = (char *)string_value(car(args));
+ if ((!str) || (!(*str)))
+ return(sc->F);
+ return(string_to_number(sc, str, radix));
+}
+
+static s7_pointer g_string_to_number(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_to_number "(string->number str (radix 10)) converts str into a number. \
+If str does not represent a number, string->number returns #f. If 'str' has an embedded radix, \
+the optional 'radix' argument is ignored: (string->number \"#x11\" 2) -> 17 not 3."
+ #define Q_string_to_number s7_make_signature(sc, 3, \
+ s7_make_signature(sc, 2, sc->is_number_symbol, sc->not_symbol), \
+ sc->is_string_symbol, sc->is_integer_symbol)
+ return(g_string_to_number_1(sc, args, sc->string_to_number_symbol));
+}
+
+
+/* -------------------------------- abs -------------------------------- */
+static inline s7_pointer abs_p_p(s7_scheme *sc, s7_pointer x)
+{
+#if (!WITH_GMP)
+ if (is_t_integer(x))
+ {
+ if (integer(x) >= 0) return(x);
+ if (integer(x) > S7_INT64_MIN) return(make_integer(sc, -integer(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((signbit(real(x))) ? make_real(sc, -real(x)) : x);
+ }
+#endif
+ switch (type(x))
+ {
+ case T_INTEGER:
+ 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);
+ }
+#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);
+#endif
+ return(make_integer(sc, -integer(x)));
+
+ case T_RATIO:
+ 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);
+ }
+#else
+ if (numerator(x) == S7_INT64_MIN)
+ 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((signbit(real(x))) ? make_real(sc, -real(x)) : x); /* (abs -0.0) returns -0.0 -- Shiro Kawai */
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpz_abs(sc->mpz_1, big_integer(x));
+ return(mpz_to_integer(sc, sc->mpz_1));
+ case T_BIG_RATIO:
+ mpq_abs(sc->mpq_1, big_ratio(x));
+ return(mpq_to_rational(sc, sc->mpq_1));
+ case T_BIG_REAL:
+ mpfr_abs(sc->mpfr_1, big_real(x), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, x, sc->abs_symbol, sc->type_names[T_REAL]));
+ }
+}
+
+static s7_pointer g_abs(s7_scheme *sc, s7_pointer args)
+{
+ #define H_abs "(abs x) returns the absolute value of the real number x"
+ #define Q_abs s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)
+ return(abs_p_p(sc, car(args)));
+}
+
+static s7_double abs_d_d(s7_double x) {return((signbit(x)) ? (-x) : x);}
+static s7_int abs_i_i(s7_int x) {return((x < 0) ? (-x) : x);}
+
+
+/* -------------------------------- magnitude -------------------------------- */
+static double my_hypot(double x, double y)
+{
+ /* according to callgrind, this is much faster than libc's hypot */
+ if (x == 0.0) return(fabs(y));
+ if (y == 0.0) return(fabs(x));
+ if (x == y) return(1.414213562373095 * fabs(x));
+ if (is_NaN(x)) return(x);
+ if (is_NaN(y)) return(y);
+ return(sqrt(x * x + y * y));
+}
+
+static s7_pointer magnitude_p_p(s7_scheme *sc, s7_pointer x)
+{
+ if (is_t_complex(x))
+ return(make_real(sc, my_hypot(real_part(x), imag_part(x)))); /* was reversed? 8-Nov-22 */
+
+ switch (type(x))
+ {
+ case T_INTEGER:
+ if (integer(x) == S7_INT64_MIN) return(mostfix);
+ /* (magnitude -9223372036854775808) -> -9223372036854775808
+ * same thing happens in abs, lcm and gcd: (gcd -9223372036854775808) -> -9223372036854775808
+ */
+ return((integer(x) < 0) ? make_integer(sc, -integer(x)) : x);
+ case T_RATIO:
+ 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((signbit(real(x))) ? make_real(sc, -real(x)) : x);
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ case T_BIG_RATIO:
+ case T_BIG_REAL:
+ return(abs_p_p(sc, x));
+ case T_BIG_COMPLEX:
+ mpc_abs(sc->mpfr_1, big_complex(x), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, x, sc->magnitude_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_magnitude(s7_scheme *sc, s7_pointer args)
+{
+ #define H_magnitude "(magnitude z) returns the magnitude of z"
+ #define Q_magnitude s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
+ return(magnitude_p_p(sc, car(args)));
+}
+
+static s7_int magnitude_i_i(s7_int x) {return((x < 0) ? (-x) : x);}
+static s7_double magnitude_d_d(s7_double x) {return((signbit(x)) ? (-x) : x);}
+
+
+/* -------------------------------- rationalize -------------------------------- */
+#if WITH_GMP
+
+static rat_locals_t *init_rat_locals_t(s7_scheme *sc)
+{
+ rat_locals_t *r = (rat_locals_t *)Malloc(sizeof(rat_locals_t));
+ sc->ratloc = r;
+ mpz_inits(r->i, r->i0, r->i1, r->n, r->p0, r->q0, r->r, r->r1, r->p1, r->q1, r->old_p1, r->old_q1, NULL);
+ mpq_init(r->q);
+ mpfr_inits2(sc->bignum_precision, r->error, r->ux, r->x0, r->x1, r->val, r->e0, r->e1, r->e0p, r->e1p, r->old_e0, r->old_e1, r->old_e0p, NULL);
+ return(r);
+}
+
+static void free_rat_locals(s7_scheme *sc)
+{
+ rat_locals_t *r = sc->ratloc;
+ mpz_clears(r->i, r->i0, r->i1, r->n, r->p0, r->q0, r->r, r->r1, r->p1, r->q1, r->old_p1, r->old_q1, NULL);
+ mpq_clear(r->q);
+ mpfr_clears(r->error, r->ux, r->x0, r->x1, r->val, r->e0, r->e1, r->e0p, r->e1p, r->old_e0, r->old_e1, r->old_e0p, NULL);
+ free(r);
+}
+
+static s7_pointer big_rationalize(s7_scheme *sc, s7_pointer args)
+{
+ /* can return be non-rational? */
+ /* currently (rationalize 1/0 1e18) -> 0
+ * remember to pad with many trailing zeros:
+ * (rationalize 0.1 0) -> 3602879701896397/36028797018963968
+ * (rationalize 0.1000000000000000 0) -> 1/10
+ * perhaps gmp number reader used if gmp -- could this be the trailing zeros problem? (why is the non-gmp case ok?)
+ * also the bignum function is faking it.
+ * (rationalize (real-part (bignum "0.1+i")) 0) -> 3602879701896397/36028797018963968
+ * a confusing case:
+ * (rationalize 5925563891587147521650777143.74135805596e05) should be 148139097289678688041269428593533951399/250000
+ * but that requires more than 128 bits of bignum-precision.
+ */
+
+ s7_pointer pp0 = car(args);
+ rat_locals_t *r = (sc->ratloc) ? sc->ratloc : init_rat_locals_t(sc);
+
+ switch (type(pp0))
+ {
+ case T_INTEGER:
+ mpfr_set_si(r->ux, integer(pp0), MPFR_RNDN);
+ break;
+ case T_RATIO:
+ mpq_set_si(sc->mpq_1, numerator(pp0), denominator(pp0));
+ mpfr_set_q(r->ux, sc->mpq_1, MPFR_RNDN);
+ 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);
+ if (is_inf(real(pp0)))
+ 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:
+ mpfr_set_z(r->ux, big_integer(pp0), MPFR_RNDN);
+ break;
+ case T_BIG_RATIO:
+ mpfr_set_q(r->ux, big_ratio(pp0), MPFR_RNDN);
+ 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);
+ if (mpfr_inf_p(big_real(pp0)))
+ 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:
+ case T_BIG_COMPLEX:
+ wrong_type_error_nr(sc, sc->rationalize_symbol, 1, pp0, sc->type_names[T_REAL]);
+ default:
+ return(method_or_bust(sc, pp0, sc->rationalize_symbol, args, sc->type_names[T_REAL], 1));
+ }
+
+ if (is_null(cdr(args)))
+ mpfr_set_d(r->error, sc->default_rationalize_error, MPFR_RNDN);
+ else
+ {
+ 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));
+ }
+ mpfr_abs(r->error, r->error, MPFR_RNDN);
+ }
+
+ mpfr_set(r->x0, r->ux, MPFR_RNDN); /* x0 = ux - error */
+ mpfr_sub(r->x0, r->x0, r->error, MPFR_RNDN);
+ mpfr_set(r->x1, r->ux, MPFR_RNDN); /* x1 = ux + error */
+ mpfr_add(r->x1, r->x1, r->error, MPFR_RNDN);
+ mpfr_get_z(r->i, r->x0, MPFR_RNDU); /* i = ceil(x0) */
+
+ 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 */
+ }
+ else mpz_set(r->n, r->i); /* else num = i */
+ return(mpz_to_integer(sc, r->n));
+ }
+
+ 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 */
+ else mpfr_get_z(r->n, r->x1, MPFR_RNDD); /* else num = floor(x1) */
+ return(mpz_to_integer(sc, r->n));
+ }
+
+ mpfr_get_z(r->i0, r->x0, MPFR_RNDD); /* i0 = floor(x0) */
+ mpfr_get_z(r->i1, r->x1, MPFR_RNDU); /* i1 = ceil(x1) */
+
+ mpz_set(r->p0, r->i0); /* p0 = i0 */
+ mpz_set_ui(r->q0, 1); /* q0 = 1 */
+ mpz_set(r->p1, r->i1); /* p1 = i1 */
+ mpz_set_ui(r->q1, 1); /* q1 = 1 */
+ mpfr_sub_z(r->e0, r->x0, r->i1, MPFR_RNDN); /* e0 = i1 - x0 */
+ mpfr_neg(r->e0, r->e0, MPFR_RNDN);
+ mpfr_sub_z(r->e1, r->x0, r->i0, MPFR_RNDN); /* e1 = x0 - i0 */
+ mpfr_sub_z(r->e0p, r->x1, r->i1, MPFR_RNDN); /* e0p = i1 - x1 */
+ mpfr_neg(r->e0p, r->e0p, MPFR_RNDN);
+ mpfr_sub_z(r->e1p, r->x1, r->i0, MPFR_RNDN); /* e1p = x1 - i0 */
+
+ while (true)
+ {
+ mpfr_set_z(r->val, r->p0, MPFR_RNDN);
+ 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_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->old_p1, r->p1); /* old_p1 = p1 */
+ mpz_set(r->p1, r->p0); /* p1 = p0 */
+ mpz_set(r->old_q1, r->q1); /* old_q1 = q1 */
+ mpz_set(r->q1, r->q0); /* q1 = q0 */
+
+ mpfr_set(r->old_e0, r->e0, MPFR_RNDN); /* old_e0 = e0 */
+ mpfr_set(r->e0, r->e1p, MPFR_RNDN); /* e0 = e1p */
+ mpfr_set(r->old_e0p, r->e0p, MPFR_RNDN); /* old_e0p = e0p */
+ mpfr_set(r->e0p, r->e1, MPFR_RNDN); /* e0p = e1 */
+ mpfr_set(r->old_e1, r->e1, MPFR_RNDN); /* old_e1 = e1 */
+
+ mpz_mul(r->p0, r->p0, r->r); /* p0 = old_p1 + r * p0 */
+ mpz_add(r->p0, r->p0, r->old_p1);
+
+ mpz_mul(r->q0, r->q0, r->r); /* q0 = old_q1 + r * q0 */
+ mpz_add(r->q0, r->q0, r->old_q1);
+
+ mpfr_mul_z(r->e1, r->e1p, r->r, MPFR_RNDN); /* e1 = old_e0p - r * e1p */
+ mpfr_sub(r->e1, r->old_e0p, r->e1, MPFR_RNDN);
+
+ mpfr_mul_z(r->e1p, r->old_e1, r->r, MPFR_RNDN);/* e1p = old_e0 - r * old_e1 */
+ mpfr_sub(r->e1p, r->old_e0, r->e1p, MPFR_RNDN);
+ }
+}
+#endif
+
+static s7_pointer g_rationalize(s7_scheme *sc, s7_pointer args)
+{
+ #define H_rationalize "(rationalize x err) returns the ratio with smallest denominator within err of x"
+ #define Q_rationalize s7_make_signature(sc, 3, sc->is_rational_symbol, sc->is_real_symbol, sc->is_real_symbol)
+ /* I can't find a case where this returns a non-rational result */
+
+ s7_double err;
+ s7_pointer x = car(args);
+
+#if WITH_GMP
+ if (is_big_number(x))
+ return(big_rationalize(sc, args));
+#endif
+ if (!is_real(x))
+ return(method_or_bust(sc, x, sc->rationalize_symbol, args, sc->type_names[T_REAL], 1));
+
+ if (is_null(cdr(args)))
+ err = sc->default_rationalize_error;
+ else
+ {
+ s7_pointer ex = cadr(args);
+#if WITH_GMP
+ if (is_big_number(ex))
+ 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));
+ 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);
+ if (err < 0.0) err = -err;
+ }
+
+ switch (type(x))
+ {
+ 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));
+ }
+
+ case T_RATIO:
+ if (err == 0.0)
+ return(x);
+
+ case T_REAL:
+ {
+ 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 (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))));
+#else
+ 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))
+ return(int_zero);
+
+ return((c_rationalize(rat, err, &numer, &denom)) ? make_ratio(sc, numer, denom) : sc->F);
+ }}
+ return(sc->F); /* make compiler happy */
+}
+
+static s7_int rationalize_i_i(s7_int x) {return(x);}
+static s7_pointer rationalize_p_i(s7_scheme *sc, s7_int x) {return(make_integer(sc, x));}
+static s7_pointer rationalize_p_d(s7_scheme *sc, s7_double x)
+{
+ if ((is_NaN(x)) || (is_inf(x)))
+ out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, wrap_real(sc, x), a_normal_real_string); /* was make_real, also below */
+ if (fabs(x) > RATIONALIZE_LIMIT)
+#if WITH_GMP
+ return(big_rationalize(sc, set_plist_1(sc, wrap_real(sc, x))));
+#else
+ out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, wrap_real(sc, x), it_is_too_large_string);
+#endif
+ return(s7_rationalize(sc, x, sc->default_rationalize_error));
+}
+
+
+/* -------------------------------- angle -------------------------------- */
+static s7_pointer g_angle(s7_scheme *sc, s7_pointer args)
+{
+ #define H_angle "(angle z) returns the angle of z"
+ #define Q_angle s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
+
+ s7_pointer x = car(args); /* (angle inf+infi) -> 0.78539816339745 ? I think this should be -pi < ang <= pi */
+ switch (type(x))
+ {
+ case T_INTEGER: return((integer(x) < 0) ? real_pi : int_zero);
+ case T_RATIO: return((numerator(x) < 0) ? real_pi : int_zero);
+ case T_COMPLEX: return(make_real(sc, atan2(imag_part(x), real_part(x))));
+
+ case T_REAL:
+ if (is_NaN(real(x))) return(x);
+ return((real(x) < 0.0) ? real_pi : real_zero);
+#if WITH_GMP
+ case T_BIG_INTEGER: return((mpz_cmp_ui(big_integer(x), 0) >= 0) ? int_zero : big_pi(sc));
+ case T_BIG_RATIO: return((mpq_cmp_ui(big_ratio(x), 0, 1) >= 0) ? int_zero : big_pi(sc));
+ case T_BIG_REAL:
+ if (mpfr_nan_p(big_real(x))) return(x);
+ 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);
+ }
+#endif
+ default:
+ return(method_or_bust_p(sc, x, sc->angle_symbol, a_number_string));
+ }
+}
+
+
+/* -------------------------------- complex -------------------------------- */
+
+static s7_pointer complex_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+#if WITH_GMP
+ if ((is_big_number(x)) || (is_big_number(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));
+ 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));
+
+ 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;
+ }
+ 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;
+ }
+ add_big_complex(sc, p);
+ return(p);
+ }
+#endif
+ if ((is_t_real(x)) && (is_t_real(y))) return((real(y) == 0.0) ? x : make_complex_not_0i(sc, real(x), real(y)));
+ switch (type(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_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_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));
+ }
+ 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));
+ }
+}
+
+static s7_pointer g_complex(s7_scheme *sc, s7_pointer args)
+{
+ #define H_complex "(complex x1 x2) returns a complex number with real-part x1 and imaginary-part x2"
+ #define Q_complex s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)
+ return(complex_p_pp(sc, car(args), cadr(args)));
+}
+
+static s7_pointer complex_p_ii(s7_scheme *sc, s7_int x, s7_int y)
+{
+ return((y == 0.0) ? make_integer(sc, x) : make_complex_not_0i(sc, (s7_double)x, (s7_double)y));
+}
+
+static s7_pointer complex_p_dd(s7_scheme *sc, s7_double x, s7_double y)
+{
+ return((y == 0.0) ? make_real(sc, x) : make_complex_not_0i(sc, x, y));
+}
+
+
+/* -------------------------------- bignum -------------------------------- */
+static s7_pointer g_bignum(s7_scheme *sc, s7_pointer args)
+{
+ #define H_bignum "(bignum val (radix 10)) returns a multiprecision version of the string 'val'. If the argument is a number \
+bignum returns that number as a bignum"
+#if WITH_GMP
+ #define Q_bignum s7_make_signature(sc, 3, sc->is_bignum_symbol, s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_string_symbol), sc->is_integer_symbol)
+#else
+ #define Q_bignum s7_make_signature(sc, 3, \
+ s7_make_signature(sc, 2, sc->is_number_symbol, sc->not_symbol), \
+ s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_string_symbol), \
+ sc->is_integer_symbol)
+#endif
+
+ s7_pointer p = car(args);
+ 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));
+#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);
+ }
+#else
+ return(p);
+#endif
+ }
+ 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)));
+#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_COMPLEX: return(s7_number_to_big_complex(sc, p));
+ case T_REAL:
+ if (is_NaN(real(p))) return(p);
+ return(s7_double_to_big_real(sc, real(p)));
+ /* 9Sep21: this was return(string_to_big_real(sc, string_value(car(args)), (is_pair(cdr(args))) ? s7_integer_clamped_if_gmp(sc, cadr(args)) : 10)); */
+ default:
+ return(p);
+ }
+#else
+ return(p);
+#endif
+}
+
+
+/* -------------------------------- exp -------------------------------- */
+#if (!HAVE_COMPLEX_NUMBERS)
+ static s7_pointer no_complex_numbers_string;
+#endif
+
+#define EXP_LIMIT 100.0
+
+#if WITH_GMP
+static s7_pointer exp_1(s7_scheme *sc, s7_double x)
+{
+ mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN);
+ mpfr_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+}
+
+static s7_pointer exp_2(s7_scheme *sc, s7_double x, s7_double y)
+{
+ mpc_set_d_d(sc->mpc_1, x, y, MPC_RNDNN);
+ mpc_exp(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
+ return(mpc_to_number(sc, sc->mpc_1));
+}
+#endif
+
+static s7_pointer exp_p_p(s7_scheme *sc, s7_pointer x)
+{
+ s7_double z;
+ switch (type(x))
+ {
+ case T_INTEGER:
+ if (integer(x) == 0) return(int_one); /* (exp 0) -> 1 */
+ z = (s7_double)integer(x);
+#if WITH_GMP
+ if (fabs(z) > EXP_LIMIT)
+ return(exp_1(sc, z));
+#endif
+ return(make_real(sc, exp(z)));
+
+ case T_RATIO:
+ z = (s7_double)fraction(x);
+#if WITH_GMP
+ if (fabs(z) > EXP_LIMIT)
+ 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)));
+#endif
+ return(make_real(sc, exp(real(x))));
+
+ case T_COMPLEX:
+#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)));
+#endif
+ return(c_complex_to_s7(sc, cexp(to_c_complex(x))));
+ /* this is inaccurate for large arguments:
+ * (exp 0+1e20i) -> -0.66491178990701-0.74692189125949i, not 7.639704044417283004001468027378811228331E-1-6.45251285265780844205811711312523007406E-1i
+ */
+#else
+ out_of_range_error_nr(sc, sc->exp_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_exp(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_exp(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ case T_BIG_REAL:
+ mpfr_exp(sc->mpfr_1, big_real(x), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ 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(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, x, sc->exp_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_exp(s7_scheme *sc, s7_pointer args)
+{
+ #define H_exp "(exp z) returns e^z, (exp 1) is 2.718281828459"
+ #define Q_exp sc->pl_nn
+ return(exp_p_p(sc, car(args)));
+}
+
+static s7_double exp_d_d(s7_double x) {return(exp(x));}
+static s7_pointer exp_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, exp(x)));}
+
+
+/* -------------------------------- log -------------------------------- */
+#if __cplusplus
+#define LOG_2 1.4426950408889634074
+#else
+#define LOG_2 1.4426950408889634073599246810018921L /* (/ (log 2.0)) */
+#endif
+
+#if WITH_GMP
+static s7_pointer big_log(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p0 = car(args), p1 = NULL, res;
+
+ if (!is_number(p0))
+ return(method_or_bust(sc, p0, sc->log_symbol, args, a_number_string, 1));
+
+ if (is_pair(cdr(args)))
+ {
+ p1 = cadr(args);
+ if (!is_number(p1))
+ return(method_or_bust(sc, p1, sc->log_symbol, args, a_number_string, 2));
+ }
+
+ if (is_real(p0))
+ {
+ 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));
+ }}
+ if (p1)
+ {
+ res = any_number_to_mpc(sc, p1, sc->mpc_2);
+ if (res)
+ 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));
+ }
+ 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((res == real_NaN) ? complex_NaN : res);
+ }
+ mpc_log(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
+ if (p1)
+ {
+ mpc_log(sc->mpc_2, sc->mpc_2, MPC_RNDNN);
+ mpc_div(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
+ }
+ if (mpfr_zero_p(mpc_imagref(sc->mpc_1)))
+ return(mpfr_to_big_real(sc, mpc_realref(sc->mpc_1)));
+ return(mpc_to_number(sc, sc->mpc_1));
+}
+#endif
+
+static s7_pointer g_int_log2(s7_scheme *sc, s7_pointer args)
+{
+ s7_int ix = integer(car(args));
+ s7_double fx = log2((double)ix);
+ return(((ix & (ix - 1)) == 0) ? make_integer(sc, (s7_int)s7_round(fx)) : make_real(sc, fx));
+}
+
+static s7_pointer g_log(s7_scheme *sc, s7_pointer args)
+{
+ #define H_log "(log z1 (z2 e)) returns log(z1) / log(z2) where z2 (the base) defaults to e: (log 8 2) = 3"
+ #define Q_log sc->pcl_n
+
+ s7_pointer x = car(args);
+
+#if WITH_GMP
+ if (is_big_number(x)) return(big_log(sc, args));
+#endif
+
+ if (!is_number(x))
+ return(method_or_bust(sc, x, sc->log_symbol, args, a_number_string, 1));
+
+ if (is_pair(cdr(args)))
+ {
+ s7_pointer y = cadr(args);
+ if (!(is_number(y)))
+ 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;
+#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;
+#else
+ fx = log2((double)ix);
+#endif
+ /* (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));
+#else
+ 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_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);
+
+ /* (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_real(x)) && (is_NaN(real(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? */
+
+ 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))));
+ }
+ if ((is_t_real(x)) && (is_NaN(real(x))))
+ return(x);
+ if ((is_t_complex(y)) && ((is_NaN(real_part(y))) || (is_NaN(imag_part(y)))))
+ return(y);
+ return(c_complex_to_s7(sc, clog(s7_to_c_complex(x)) / clog(s7_to_c_complex(y))));
+ }
+
+ if (!is_real(x))
+ return(c_complex_to_s7(sc, clog(s7_to_c_complex(x))));
+ if (is_positive(sc, x))
+ return(make_real(sc, log(s7_real(x))));
+ return(make_complex_not_0i(sc, log(-s7_real(x)), M_PI));
+}
+
+static s7_pointer log_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+#if (!WITH_GMP)
+ if (args == 2)
+ {
+ 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);
+ }
+#endif
+ return(f);
+}
+
+/* -------------------------------- sin -------------------------------- */
+#define SIN_LIMIT 1.0e16
+#define SINH_LIMIT 20.0
+/* (- (sinh (bignum 30.0)) (sinh 30.0)): -3.718172657214174140191915872003397016115E-4
+ * (- (sinh (bignum 20.0)) (sinh 20.0)): -7.865629467297586346406367346575835463792E-10, slightly worse (e-8) if imag-part
+ */
+
+static s7_pointer sin_p_p(s7_scheme *sc, s7_pointer x)
+{
+#if (!WITH_GMP)
+ if (is_t_real(x)) return(make_real(sc, sin(real(x)))); /* range check in gmp case */
+#endif
+ switch (type(x))
+ {
+ case T_INTEGER:
+ 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));
+ }
+#endif
+ return(make_real(sc, sin((s7_double)(integer(x))))); /* bogus for very large integers, but so is the equivalent real (see SIN_LIMIT) */
+
+ case T_RATIO:
+ return(make_real(sc, sin((s7_double)(fraction(x)))));
+
+ case T_REAL:
+ {
+ 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)));
+ }
+
+ 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));
+ }
+#endif
+#if HAVE_COMPLEX_NUMBERS
+ return(c_complex_to_s7(sc, csin(to_c_complex(x))));
+#else
+ out_of_range_error_nr(sc, sc->sin_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_sin(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_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ case T_BIG_REAL:
+ mpfr_sin(sc->mpfr_1, big_real(x), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ 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(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, x, sc->sin_symbol, a_number_string));
+ }
+ /* sin is inaccurate over about 1e30. There's a way to get true results, but it involves fancy "range reduction" techniques.
+ * (sin 1e32): 0.5852334864823946
+ * but it should be 3.901970254333630491697613212893425767786E-1
+ * (remainder 1e22 (* 2 pi)) -> 1.0057952155665e+22 !! (it's now a range error)
+ * it should be 5.263007914620499494429139986095833592117E0
+ * before comparing imag-part to 0, we need to look for NaN and inf, else:
+ * (sinh 0+0/0i) -> 0.0 and (sinh (log 0.0)) -> inf.0
+ */
+}
+
+static s7_pointer g_sin(s7_scheme *sc, s7_pointer args)
+{
+ #define H_sin "(sin z) returns sin(z)"
+ #define Q_sin sc->pl_nn
+ return(sin_p_p(sc, car(args)));
+}
+
+#if WITH_GMP
+static s7_pointer sin_p_d(s7_scheme *sc, s7_double x)
+{
+ if (fabs(x) <= SIN_LIMIT)
+ return(make_real(sc, sin(x)));
+ mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN);
+ mpfr_sin(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+}
+#else
+static s7_pointer sin_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, sin(x)));}
+#endif
+
+static s7_double sin_d_d(s7_double x) {return(sin(x));}
+
+
+/* -------------------------------- cos -------------------------------- */
+static s7_pointer cos_p_p(s7_scheme *sc, s7_pointer x)
+{
+#if (!WITH_GMP)
+ if (is_t_real(x)) return(make_real(sc, cos(real(x)))); /* range check in gmp case */
+#endif
+ switch (type(x))
+ {
+ case T_INTEGER:
+ 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));
+ }
+#endif
+ return(make_real(sc, cos((s7_double)(integer(x)))));
+
+ case T_RATIO:
+ return(make_real(sc, cos((s7_double)(fraction(x)))));
+
+ case T_REAL: /* if with_gmp */
+ {
+ 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)));
+ }
+
+ 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));
+ }
+#endif
+#if HAVE_COMPLEX_NUMBERS
+ return(c_complex_to_s7(sc, ccos(to_c_complex(x))));
+#else
+ out_of_range_error_nr(sc, sc->cos_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_cos(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_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ case T_BIG_REAL:
+ mpfr_cos(sc->mpfr_1, big_real(x), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ 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(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, x, sc->cos_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_cos(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cos "(cos z) returns cos(z)"
+ #define Q_cos sc->pl_nn
+ return(cos_p_p(sc, car(args)));
+}
+
+#if WITH_GMP
+static s7_pointer cos_p_d(s7_scheme *sc, s7_double x)
+{
+ if (fabs(x) <= SIN_LIMIT)
+ return(make_real(sc, cos(x)));
+ mpfr_set_d(sc->mpfr_1, x, MPFR_RNDN);
+ mpfr_cos(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+}
+#else
+static s7_pointer cos_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, cos(x)));}
+#endif
+
+static s7_double cos_d_d(s7_double x) {return(cos(x));}
+
+
+/* -------------------------------- tan -------------------------------- */
+#define TAN_LIMIT 1.0e18
+
+static s7_pointer tan_p_p(s7_scheme *sc, s7_pointer x)
+{
+#if (!WITH_GMP)
+ if (is_t_real(x)) return(make_real(sc, tan(real(x))));
+#endif
+ switch (type(x))
+ {
+ case T_INTEGER:
+ 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));
+ }
+#endif
+ return(make_real(sc, tan((s7_double)(integer(x)))));
+
+ case T_RATIO:
+ return(make_real(sc, tan((s7_double)(fraction(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));
+ }
+#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((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);
+#endif
+
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
+ mpfr_tan(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_tan(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ case T_BIG_REAL:
+ mpfr_tan(sc->mpfr_1, big_real(x), MPFR_RNDN);
+ 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));
+ if ((MPC_INEX_IM(mpc_cmp_si_si(big_complex(x), 1, -350))) < 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(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, x, sc->tan_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_tan(s7_scheme *sc, s7_pointer args)
+{
+ #define H_tan "(tan z) returns tan(z)"
+ #define Q_tan sc->pl_nn
+ return(tan_p_p(sc, car(args)));
+}
+
+static s7_double tan_d_d(s7_double x) {return(tan(x));}
+
+
+/* -------------------------------- asin -------------------------------- */
+static s7_pointer c_asin(s7_scheme *sc, s7_double x)
+{
+ s7_double absx = fabs(x), recip;
+ s7_complex result;
+
+ if (absx <= 1.0) return(make_real(sc, asin(x)));
+
+ /* otherwise use maxima code: */
+ recip = 1.0 / absx;
+ result = (M_PI / 2.0) - (s7_complex_i * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip)))));
+ return((x < 0.0) ? c_complex_to_s7(sc, -result) : c_complex_to_s7(sc, result));
+}
+
+static s7_pointer asin_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_real(p)) return(c_asin(sc, real(p)));
+ switch (type(p))
+ {
+ case T_INTEGER:
+ if (integer(p) == 0) return(int_zero); /* (asin 0) -> 0 */
+ /* in netBSD, (asin 2) returns 0.25383842987008+0.25383842987008i according to Peter Bex */
+ return(c_asin(sc, (s7_double)integer(p)));
+
+ case T_RATIO:
+ return(c_asin(sc, fraction(p)));
+
+ case T_COMPLEX:
+#if HAVE_COMPLEX_NUMBERS
+ /* 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)))));
+ }
+ 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);
+#endif
+
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN);
+ goto ASIN_BIG_REAL;
+ case T_BIG_RATIO:
+ mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN);
+ 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));
+ }
+ 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));
+ }
+ 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));
+ case T_BIG_COMPLEX:
+ mpc_asin(sc->mpc_1, big_complex(p), MPC_RNDNN);
+ return(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, p, sc->asin_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_asin(s7_scheme *sc, s7_pointer args)
+{
+ #define H_asin "(asin z) returns asin(z); (sin (asin x)) = x"
+ #define Q_asin sc->pl_nn
+ return(asin_p_p(sc, car(args)));
+}
+
+
+/* -------------------------------- acos -------------------------------- */
+static s7_pointer c_acos(s7_scheme *sc, s7_double x)
+{
+ s7_double absx = fabs(x), recip;
+ s7_complex result;
+
+ if (absx <= 1.0)
+ return(make_real(sc, acos(x)));
+
+ /* else follow maxima again: */
+ recip = 1.0 / absx;
+ if (x > 0.0)
+ result = s7_complex_i * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip))));
+ else result = M_PI - s7_complex_i * clog(absx * (1.0 + (sqrt(1.0 + recip) * csqrt(1.0 - recip))));
+ return(c_complex_to_s7(sc, result));
+}
+
+static s7_pointer acos_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_real(p)) return(c_acos(sc, real(p)));
+ switch (type(p))
+ {
+ case T_INTEGER:
+ return((integer(p) == 1) ? int_zero : c_acos(sc, (s7_double)integer(p)));
+
+ case T_RATIO:
+ return(c_acos(sc, fraction(p)));
+
+ case T_COMPLEX:
+#if HAVE_COMPLEX_NUMBERS
+ /* if either real or imag part is very large, use explicit formula, not cacos */
+ /* 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)))));
+ }
+ 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);
+#endif
+
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpfr_set_z(sc->mpfr_1, big_integer(p), MPFR_RNDN);
+ goto ACOS_BIG_REAL;
+ case T_BIG_RATIO:
+ mpfr_set_q(sc->mpfr_1, big_ratio(p), MPFR_RNDN);
+ 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));
+ }
+ 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));
+ }
+ 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));
+ case T_BIG_COMPLEX:
+ mpc_acos(sc->mpc_1, big_complex(p), MPC_RNDNN);
+ return(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, p, sc->acos_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_acos(s7_scheme *sc, s7_pointer args)
+{
+ #define H_acos "(acos z) returns acos(z); (cos (acos 1)) = 1"
+ #define Q_acos sc->pl_nn
+ return(acos_p_p(sc, car(args)));
+}
+
+
+/* -------------------------------- atan -------------------------------- */
+static s7_pointer g_atan(s7_scheme *sc, s7_pointer args)
+{
+ #define H_atan "(atan z) returns atan(z), (atan y x) returns atan(y/x)"
+ #define Q_atan s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_real_symbol)
+ /* actually if there are two args, both should be real, but how to express that in the signature? */
+
+ s7_pointer x = car(args), y;
+ /* currently (atan inf.0 inf.0) -> 0.78539816339745, and (atan inf.0 -inf.0) -> 2.3561944901923 (etc) */
+
+ 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_COMPLEX:
+#if HAVE_COMPLEX_NUMBERS
+ 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);
+#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));
+ }}
+
+ 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))));
+#if WITH_GMP
+ if (!is_real(y))
+ 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:
+ mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
+ goto ATAN2_BIG_REAL;
+ case T_BIG_RATIO:
+ mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
+ goto ATAN2_BIG_REAL;
+ case T_BIG_REAL:
+ mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN);
+ goto ATAN2_BIG_REAL;
+#endif
+ default:
+ return(method_or_bust(sc, x, sc->atan_symbol, args, sc->type_names[T_REAL], 1));
+ }
+#if WITH_GMP
+ ATAN2_BIG_REAL:
+ if (is_small_real(y))
+ mpfr_set_d(sc->mpfr_2, s7_real(y), MPFR_RNDN);
+ else
+ if (is_t_big_real(y))
+ 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);
+ 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));
+ mpfr_atan2(sc->mpfr_1, sc->mpfr_1, sc->mpfr_2, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+#endif
+}
+
+static s7_double atan_d_dd(s7_double x, s7_double y) {return(atan2(x, y));}
+
+
+/* -------------------------------- sinh -------------------------------- */
+static s7_pointer sinh_p_p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER:
+ if (integer(x) == 0) return(int_zero); /* (sinh 0) -> 0 */
+
+ case T_REAL:
+ case T_RATIO:
+ {
+ 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)));
+ }
+
+ 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));
+ }
+#endif
+#if HAVE_COMPLEX_NUMBERS
+ return(c_complex_to_s7(sc, csinh(to_c_complex(x))));
+#else
+ out_of_range_error_nr(sc, sc->sinh_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_sinh(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_sinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ case T_BIG_REAL:
+ mpfr_sinh(sc->mpfr_1, big_real(x), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ 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(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, x, sc->sinh_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_sinh(s7_scheme *sc, s7_pointer args)
+{
+ #define H_sinh "(sinh z) returns sinh(z)"
+ #define Q_sinh sc->pl_nn
+ return(sinh_p_p(sc, car(args)));
+}
+
+static s7_double sinh_d_d(s7_double x) {return(sinh(x));}
+static s7_pointer sinh_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, sinh(x)));}
+ /* so sinh in a do-loop with 0 arg may return 0.0 because sinh_p_d does not check if x=0 */
+
+
+/* -------------------------------- cosh -------------------------------- */
+static s7_pointer cosh_p_p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER:
+ if (integer(x) == 0) return(int_one); /* (cosh 0) -> 1 */
+
+ case T_REAL:
+ case T_RATIO:
+ {
+ 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)));
+ }
+
+ 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));
+ }
+#endif
+#if HAVE_COMPLEX_NUMBERS
+ return(c_complex_to_s7(sc, ccosh(to_c_complex(x))));
+#else
+ out_of_range_error_nr(sc, sc->cosh_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_cosh(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_cosh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ case T_BIG_REAL:
+ mpfr_cosh(sc->mpfr_1, big_real(x), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ 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(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, x, sc->cosh_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_cosh(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cosh "(cosh z) returns cosh(z)"
+ #define Q_cosh sc->pl_nn
+ return(cosh_p_p(sc, car(args)));
+}
+
+static s7_double cosh_d_d(s7_double x) {return(cosh(x));}
+static s7_pointer cosh_p_d(s7_scheme *sc, s7_double x) {return(make_real(sc, cosh(x)));}
+
+
+/* -------------------------------- tanh -------------------------------- */
+#define TANH_LIMIT 350.0
+static s7_pointer tanh_p_p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER: return((integer(x) == 0) ? int_zero : make_real(sc, tanh((s7_double)integer(x))));
+ case T_RATIO: return(make_real(sc, tanh(fraction(x))));
+ case T_REAL: return(make_real(sc, tanh(real(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! */
+ if (real_part(x) < -TANH_LIMIT)
+ 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);
+#endif
+
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
+ goto BIG_REAL_TANH;
+ case T_BIG_RATIO:
+ mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
+ goto BIG_REAL_TANH;
+ case T_BIG_REAL:
+ if (mpfr_nan_p(big_real(x))) return(x);
+ mpfr_set(sc->mpfr_1, big_real(x), MPFR_RNDN);
+ BIG_REAL_TANH:
+ if (mpfr_cmp_d(sc->mpfr_1, TANH_LIMIT) > 0) return(real_one);
+ if (mpfr_cmp_d(sc->mpfr_1, -TANH_LIMIT) < 0) return(make_real(sc, -1.0));
+ mpfr_tanh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
+ 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);
+ if ((MPC_INEX_RE(mpc_cmp_si_si(big_complex(x), -TANH_LIMIT, 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);
+ }
+ 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(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, x, sc->tanh_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_tanh(s7_scheme *sc, s7_pointer args)
+{
+ #define H_tanh "(tanh z) returns tanh(z)"
+ #define Q_tanh sc->pl_nn
+ return(tanh_p_p(sc, car(args)));
+}
+
+static s7_double tanh_d_d(s7_double x) {return(tanh(x));}
+
+
+/* -------------------------------- asinh -------------------------------- */
+static s7_pointer asinh_p_p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER: return((integer(x) == 0) ? int_zero : make_real(sc, asinh((s7_double)integer(x))));
+ case T_RATIO: return(make_real(sc, asinh(fraction(x))));
+ case T_REAL: return(make_real(sc, asinh(real(x))));
+ case T_COMPLEX:
+#if HAVE_COMPLEX_NUMBERS
+ #if (defined(__OpenBSD__)) || (defined(__NetBSD__))
+ return(c_complex_to_s7(sc, casinh_1(to_c_complex(x))));
+ #else
+ return(c_complex_to_s7(sc, casinh(to_c_complex(x))));
+ #endif
+#else
+ out_of_range_error_nr(sc, sc->asinh_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_asinh(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_asinh(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ case T_BIG_REAL:
+ mpfr_asinh(sc->mpfr_1, big_real(x), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ case T_BIG_COMPLEX:
+ mpc_asinh(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->asinh_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_asinh(s7_scheme *sc, s7_pointer args)
+{
+ #define H_asinh "(asinh z) returns asinh(z)"
+ #define Q_asinh sc->pl_nn
+ return(asinh_p_p(sc, car(args)));
+}
+
+
+/* -------------------------------- acosh -------------------------------- */
+static s7_pointer acosh_p_p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER:
+ if (integer(x) == 1) return(int_zero);
+ case T_REAL:
+ case T_RATIO:
+ {
+ s7_double x1 = s7_real(x);
+ if (x1 >= 1.0)
+ return(make_real(sc, acosh(x1)));
+ }
+ case T_COMPLEX:
+#if HAVE_COMPLEX_NUMBERS
+ #ifdef __OpenBSD__
+ return(c_complex_to_s7(sc, cacosh_1(s7_to_c_complex(x))));
+ #else
+ return(c_complex_to_s7(sc, cacosh(s7_to_c_complex(x)))); /* not to_c_complex because x might not be complex */
+ #endif
+#else
+ /* since we can fall through to this branch, we need a better error message than "must be a number, not 0.0" */
+ out_of_range_error_nr(sc, sc->acosh_symbol, int_one, x, no_complex_numbers_string);
+#endif
+
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpc_set_z(sc->mpc_1, big_integer(x), MPC_RNDNN);
+ mpc_acosh(sc->mpc_1, 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(x), MPC_RNDNN);
+ mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
+ return(mpc_to_number(sc, sc->mpc_1));
+ case T_BIG_REAL:
+ mpc_set_fr(sc->mpc_1, big_real(x), MPC_RNDNN);
+ mpc_acosh(sc->mpc_1, sc->mpc_1, MPC_RNDNN);
+ return(mpc_to_number(sc, sc->mpc_1));
+ case T_BIG_COMPLEX:
+ mpc_acosh(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->acosh_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_acosh(s7_scheme *sc, s7_pointer args)
+{
+ #define H_acosh "(acosh z) returns acosh(z)"
+ #define Q_acosh sc->pl_nn
+ return(acosh_p_p(sc, car(args)));
+}
+
+
+/* -------------------------------- atanh -------------------------------- */
+static s7_pointer atanh_p_p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER:
+ if (integer(x) == 0) return(int_zero); /* (atanh 0) -> 0 */
+ case T_REAL:
+ case T_RATIO:
+ {
+ 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
+ * (atanh 92233720368547758/92233720368547757) -> inf.0
+ * (atanh (bignum 92233720368547758/92233720368547757)) -> 1.987812468492420421418925013176932317086E1+1.570796326794896619231321691639751442098E0i
+ * but the imaginary part is unnecessary
+ */
+ case T_COMPLEX:
+#if HAVE_COMPLEX_NUMBERS
+ #if (defined(__OpenBSD__)) || (defined(__NetBSD__))
+ return(c_complex_to_s7(sc, catanh_1(s7_to_c_complex(x))));
+ #else
+ return(c_complex_to_s7(sc, catanh(s7_to_c_complex(x))));
+ #endif
+#else
+ out_of_range_error_nr(sc, sc->atanh_symbol, int_one, x, no_complex_numbers_string);
+#endif
+
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpfr_set_z(sc->mpfr_2, big_integer(x), MPFR_RNDN);
+ goto ATANH_BIG_REAL;
+ case T_BIG_RATIO:
+ mpfr_set_q(sc->mpfr_2, big_ratio(x), MPFR_RNDN);
+ goto ATANH_BIG_REAL;
+ case T_BIG_REAL:
+ mpfr_set(sc->mpfr_2, big_real(x), MPFR_RNDN);
+ 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));
+ }
+ 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));
+ case T_BIG_COMPLEX:
+ mpc_atanh(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->atanh_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_atanh(s7_scheme *sc, s7_pointer args)
+{
+ #define H_atanh "(atanh z) returns atanh(z)"
+ #define Q_atanh sc->pl_nn
+ return(atanh_p_p(sc, car(args)));
+}
+
+
+/* -------------------------------- sqrt -------------------------------- */
+static s7_pointer sqrt_p_p(s7_scheme *sc, s7_pointer p)
+{
+ switch (type(p))
+ {
+ case T_INTEGER:
+ {
+ 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
+ */
+ }
+#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));
+#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))));
+#else
+ 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))));
+ }
+#if HAVE_COMPLEX_NUMBERS
+ return(make_complex(sc, 0.0, sqrt((s7_double)(-fraction(p)))));
+#else
+ out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, p, no_complex_numbers_string);
+#endif
+
+ case T_REAL:
+ if (is_NaN(real(p))) return(p);
+ if (real(p) >= 0.0)
+ 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 */
+#if HAVE_COMPLEX_NUMBERS
+ return(c_complex_to_s7(sc, csqrt(to_c_complex(p)))); /* sqrt(+inf.0+1.0i) -> +inf.0 */
+#else
+ out_of_range_error_nr(sc, sc->sqrt_symbol, int_one, p, no_complex_numbers_string);
+#endif
+
+#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));
+ }
+ 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));
+ }
+ 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));
+ }}
+ 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));
+ }
+ mpfr_sqrt(sc->mpfr_1, big_real(p), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+
+ case T_BIG_COMPLEX:
+ mpc_sqrt(sc->mpc_1, big_complex(p), MPC_RNDNN);
+ return(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, p, sc->sqrt_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_sqrt(s7_scheme *sc, s7_pointer args)
+{
+ #define H_sqrt "(sqrt z) returns the square root of z"
+ #define Q_sqrt sc->pl_nn
+ return(sqrt_p_p(sc, car(args)));
+}
+
+
+/* -------------------------------- expt -------------------------------- */
+static s7_int int_to_int(s7_int x, s7_int n)
+{
+ /* from GSL */
+ s7_int value = 1;
+ do {
+ if (n & 1) value *= x;
+ n >>= 1;
+#if HAVE_OVERFLOW_CHECKS
+ if (multiply_overflow(x, x, &x))
+ break;
+#else
+ x *= x;
+#endif
+ } while (n);
+ return(value);
+}
+
+static const int64_t nth_roots[63] = {
+ S7_INT64_MAX, S7_INT64_MAX, 3037000499LL, 2097151, 55108, 6208, 1448, 511, 234, 127, 78, 52, 38, 28, 22,
+ 18, 15, 13, 11, 9, 8, 7, 7, 6, 6, 5, 5, 5, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2,
+ 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2, 2};
+
+static bool int_pow_ok(s7_int x, s7_int y)
+{
+ return((y < S7_INT_BITS) && (nth_roots[y] >= s7_int_abs(x)));
+}
+
+#if WITH_GMP
+static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer p);
+static bool lt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2);
+
+static s7_pointer big_expt(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer x = car(args), y = cadr(args), res;
+ if (!is_number(x))
+ return(method_or_bust(sc, x, sc->expt_symbol, args, a_number_string, 1));
+ if (!is_number(y))
+ return(method_or_bust(sc, y, sc->expt_symbol, args, a_number_string, 2));
+
+ if (is_zero(x))
+ {
+ if ((s7_is_integer(x)) && (s7_is_integer(y)) && (is_zero(y)))
+ return(int_one);
+
+ if (is_real(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 ((is_rational(x)) && (is_rational(y)))
+ return(int_zero);
+ return(real_zero);
+ }
+
+ if (s7_is_integer(y))
+ {
+ s7_int yval = s7_integer_clamped_if_gmp(sc, y);
+ if (yval == 0)
+ return((is_rational(x)) ? int_one : real_one);
+
+ if (yval == 1)
+ return(x);
+
+ if ((!is_big_number(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));
+ }}}
+
+ 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));
+
+ 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));
+ }}
+
+ res = any_number_to_mpc(sc, y, sc->mpc_2);
+ if (res == real_infinity)
+ {
+ 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 (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_zero : real_infinity);
+ return((is_positive(sc, y)) ? real_infinity : real_zero);
+ }
+ if (res) return(complex_NaN);
+
+ if ((is_real(x)) &&
+ (is_real(y)) &&
+ (is_positive(sc, x)))
+ {
+ 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);
+ }
+ mpfr_pow(sc->mpfr_1, sc->mpfr_1, mpc_realref(sc->mpc_2), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ }
+
+ res = any_number_to_mpc(sc, x, sc->mpc_1);
+ 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);
+ }
+ return(complex_NaN);
+ }
+ if (mpc_cmp_si_si(sc->mpc_1, 0, 0) == 0)
+ return(int_zero);
+ if (mpc_cmp_si_si(sc->mpc_1, 1, 0) == 0)
+ return(int_one);
+
+ mpc_pow(sc->mpc_1, sc->mpc_1, sc->mpc_2, MPC_RNDNN);
+
+ 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));
+ }}
+ mpfr_set(sc->mpfr_1, mpc_realref(sc->mpc_1), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ }
+ return(mpc_to_number(sc, sc->mpc_1));
+}
+#endif
+
+static s7_pointer expt_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer pw)
+{
+ if (!is_number(n))
+ return(method_or_bust_pp(sc, n, sc->expt_symbol, n, pw, a_number_string, 1));
+ if (!is_number(pw))
+ return(method_or_bust_pp(sc, pw, sc->expt_symbol, n, pw, a_number_string, 2));
+
+ 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 (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);
+ }
+ 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);
+ }
+ if ((s7_is_integer(n)) && (s7_is_integer(pw))) /* pw != 0, (expt 0 2312) */
+ return(int_zero);
+ return(real_zero); /* (expt 0.0 123123) */
+ }
+
+ if (is_one(pw))
+ {
+ if (s7_is_integer(pw)) /* (expt x 1) */
+ return(n);
+ if (is_rational(n)) /* (expt ratio 1.0) */
+ 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) */
+ }
+ 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:
+#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));
+ }}
+#else
+ out_of_range_error_nr(sc, sc->expt_symbol, int_two, n, no_complex_numbers_string);
+#endif
+ break;
+ }}
+
+ if ((is_real(n)) &&
+ (is_real(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? */
+ }
+
+ x = s7_real(n);
+ y = s7_real(pw);
+ if (is_NaN(x)) return(n);
+ if (is_NaN(y)) return(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) */
+ }
+
+ /* (expt 0+i 1e+16) = 0.98156860153485-0.19111012657867i ?
+ * (expt 0+i 1+1/0i) = 0.0 ??
+ */
+ return(c_complex_to_s7(sc, cpow(s7_to_c_complex(n), s7_to_c_complex(pw))));
+}
+
+static s7_pointer g_expt(s7_scheme *sc, s7_pointer args)
+{
+ #define H_expt "(expt z1 z2) returns z1^z2"
+ #define Q_expt sc->pcl_n
+#if WITH_GMP
+ return(big_expt(sc, args));
+ /* big_expt sometimes chooses a different value: g_expt (expt -1 1/3) is -1, but big_expt (expt -1 (bignum 1/3)) is (complex 1/2 (/ (sqrt 3) 2)) */
+#endif
+ return(expt_p_pp(sc, car(args), cadr(args)));
+}
+
+
+/* -------------------------------- lcm -------------------------------- */
+#if WITH_GMP
+static s7_pointer big_lcm(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args)
+{
+ mpz_set_si(sc->mpz_3, num);
+ mpz_set_si(sc->mpz_4, den);
+
+ for (s7_pointer x = args; is_pair(x); x = cdr(x))
+ {
+ 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)));
+ }}
+ return(mpz_to_rational(sc, sc->mpz_3, sc->mpz_4));
+}
+#endif
+
+static s7_pointer g_lcm(s7_scheme *sc, s7_pointer args)
+{
+ /* (/ (* m n) (gcd m n)), (lcm a b c) -> (lcm a (lcm b c)) */
+ #define H_lcm "(lcm ...) returns the least common multiple of its rational arguments"
+ #define Q_lcm sc->pcl_f
+
+ s7_int n = 1, d = 0;
+
+ if (!is_pair(args))
+ return(int_one);
+
+ 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(g_abs(sc, args));
+ }
+
+ for (s7_pointer p = args; is_pair(p); p = cdr(p))
+ {
+ s7_pointer x = car(p);
+ s7_int b;
+#if HAVE_OVERFLOW_CHECKS
+ 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)
+#if WITH_GMP
+ 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);
+#endif
+ b = -b;
+ }
+#if HAVE_OVERFLOW_CHECKS
+ if (multiply_overflow(n / c_gcd(n, b), b, &n1))
+#if WITH_GMP
+ 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);
+#endif
+ n = n1;
+#else
+ n = (n / c_gcd(n, b)) * b;
+#endif
+ break;
+
+ case T_RATIO:
+ b = numerator(x);
+ if (b < 0)
+ {
+ if (b == S7_INT64_MIN)
+#if WITH_GMP
+ 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);
+#endif
+ b = -b;
+ }
+#if HAVE_OVERFLOW_CHECKS
+ 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));
+#else
+ 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;
+#endif
+ 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)));
+ }}
+ return((d <= 1) ? make_integer(sc, n) : make_simple_ratio(sc, n, d));
+}
+
+
+/* -------------------------------- gcd -------------------------------- */
+#if WITH_GMP
+static s7_pointer big_gcd(s7_scheme *sc, s7_int num, s7_int den, s7_pointer args)
+{
+ mpz_set_si(sc->mpz_3, num);
+ mpz_set_si(sc->mpz_4, den);
+
+ for (s7_pointer x = args; is_pair(x); x = cdr(x))
+ {
+ 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)));
+ }}
+ return(mpz_to_rational(sc, sc->mpz_3, sc->mpz_4));
+}
+#endif
+
+static s7_pointer g_gcd(s7_scheme *sc, s7_pointer args)
+{
+ #define H_gcd "(gcd ...) returns the greatest common divisor of its rational arguments"
+ #define Q_gcd sc->pcl_f
+
+ s7_int n = 0, d = 1;
+
+ if (!is_pair(args)) /* (gcd) */
+ return(int_zero);
+
+ 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(abs_p_p(sc, car(args)));
+ }
+
+ for (s7_pointer p = args; is_pair(p); p = cdr(p))
+ {
+ s7_pointer x = car(p);
+ switch (type(x))
+ {
+ case T_INTEGER:
+ if (integer(x) == S7_INT64_MIN)
+#if WITH_GMP
+ 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);
+#endif
+ n = c_gcd(n, integer(x));
+ break;
+
+ 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);
+#if HAVE_OVERFLOW_CHECKS
+ 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));
+#else
+ sole_arg_out_of_range_error_nr(sc, sc->gcd_symbol, args, intermediate_too_large_string);
+#endif
+ d = dn;
+#else
+ d = (d / c_gcd(d, b)) * b;
+#endif
+ }}
+ break;
+
+#if WITH_GMP
+ 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);
+
+ 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));
+}
+
+
+/* -------------------------------- floor -------------------------------- */
+static s7_pointer floor_p_p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER:
+ 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 */
+ }
+ 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);
+#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));
+ }
+#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);
+#endif
+ 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:
+ return(x);
+ case T_BIG_RATIO:
+ mpz_fdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(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);
+ if (mpfr_inf_p(big_real(x)))
+ 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:
+#endif
+ case T_COMPLEX:
+ sole_arg_wrong_type_error_nr(sc, sc->floor_symbol, x, sc->type_names[T_REAL]);
+ default:
+ return(method_or_bust_p(sc, x, sc->floor_symbol, sc->type_names[T_REAL]));
+ }
+}
+
+static s7_pointer g_floor(s7_scheme *sc, s7_pointer args)
+{
+ #define H_floor "(floor x) returns the integer closest to x toward -inf"
+ #define Q_floor s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
+ return(floor_p_p(sc, car(args)));
+}
+
+static s7_int floor_i_i(s7_int i) {return(i);}
+
+#if (!WITH_GMP)
+static s7_int floor_i_7d(s7_scheme *sc, s7_double x)
+{
+ if (is_NaN(x))
+ sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, real_NaN, it_is_nan_string);
+ if (fabs(x) > DOUBLE_TO_INT64_LIMIT)
+ sole_arg_out_of_range_error_nr(sc, sc->floor_symbol, wrap_real(sc, x), it_is_too_large_string);
+ return((s7_int)floor(x));
+}
+
+static s7_int floor_i_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_integer(p)) return(integer(p));
+ if (is_t_real(p)) return(floor_i_7d(sc, real(p)));
+ if (is_t_ratio(p)) /* for consistency with floor_p_p, don't use floor(fraction(p)) */
+ {
+ s7_int val = numerator(p) / denominator(p);
+ return((numerator(p) < 0) ? val - 1 : val);
+ }
+ return(s7_integer(method_or_bust_p(sc, p, sc->floor_symbol, sc->type_names[T_REAL])));
+}
+
+static s7_pointer floor_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc,floor_i_7d(sc, x)));}
+#endif
+
+
+/* -------------------------------- ceiling -------------------------------- */
+static s7_pointer ceiling_p_p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER:
+ return(x);
+ case T_RATIO:
+ {
+ 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);
+#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));
+ }
+#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);
+#endif
+ return(make_integer(sc, (s7_int)ceil(real(x))));
+ }
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ return(x);
+ case T_BIG_RATIO:
+ mpz_cdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(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);
+ if (mpfr_inf_p(big_real(x)))
+ 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:
+#endif
+ case T_COMPLEX:
+ sole_arg_wrong_type_error_nr(sc, sc->ceiling_symbol, x, sc->type_names[T_REAL]);
+ default:
+ return(method_or_bust_p(sc, x, sc->ceiling_symbol, sc->type_names[T_REAL]));
+ }
+}
+
+static s7_pointer g_ceiling(s7_scheme *sc, s7_pointer args)
+{
+ #define H_ceiling "(ceiling x) returns the integer closest to x toward inf"
+ #define Q_ceiling s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
+ return(ceiling_p_p(sc, car(args)));
+}
+
+static s7_int ceiling_i_i(s7_int i) {return(i);}
+
+#if (!WITH_GMP)
+static s7_int ceiling_i_7d(s7_scheme *sc, s7_double x)
+{
+ if (is_NaN(x))
+ sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, real_NaN, it_is_nan_string);
+ if ((is_inf(x)) ||
+ (x > DOUBLE_TO_INT64_LIMIT) || (x < -DOUBLE_TO_INT64_LIMIT))
+ sole_arg_out_of_range_error_nr(sc, sc->ceiling_symbol, wrap_real(sc, x), it_is_too_large_string);
+ return((s7_int)ceil(x));
+}
+
+static s7_int ceiling_i_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_integer(p)) return(integer(p));
+ if (is_t_real(p)) return(ceiling_i_7d(sc, real(p)));
+ if (is_t_ratio(p)) return((s7_int)(ceil(fraction(p))));
+ return(s7_integer(method_or_bust_p(sc, p, sc->ceiling_symbol, sc->type_names[T_REAL])));
+}
+
+static s7_pointer ceiling_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc, ceiling_i_7d(sc, x)));}
+#endif
+
+
+/* -------------------------------- truncate -------------------------------- */
+static s7_pointer truncate_p_p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER:
+ return(x);
+ case T_RATIO:
+ 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);
+#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));
+ }
+#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);
+#endif
+ return(make_integer(sc, (z > 0.0) ? (s7_int)floor(z) : (s7_int)ceil(z)));
+ }
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ return(x);
+ case T_BIG_RATIO:
+ mpz_tdiv_q(sc->mpz_1, mpq_numref(big_ratio(x)), mpq_denref(big_ratio(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);
+ if (mpfr_inf_p(big_real(x)))
+ 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:
+#endif
+ case T_COMPLEX:
+ sole_arg_wrong_type_error_nr(sc, sc->truncate_symbol, x, sc->type_names[T_REAL]);
+ default:
+ return(method_or_bust_p(sc, x, sc->truncate_symbol, sc->type_names[T_REAL]));
+ }
+}
+
+static s7_pointer g_truncate(s7_scheme *sc, s7_pointer args)
+{
+ #define H_truncate "(truncate x) returns the integer closest to x toward 0"
+ #define Q_truncate s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
+ return(truncate_p_p(sc, car(args)));
+}
+
+static s7_int truncate_i_i(s7_int i) {return(i);}
+
+#if (!WITH_GMP)
+static s7_int truncate_i_7d(s7_scheme *sc, s7_double x)
+{
+ if (is_NaN(x))
+ sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, real_NaN, it_is_nan_string);
+ if (is_inf(x))
+ sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, wrap_real(sc, x), it_is_infinite_string);
+ if (fabs(x) > DOUBLE_TO_INT64_LIMIT)
+ sole_arg_out_of_range_error_nr(sc, sc->truncate_symbol, wrap_real(sc, x), it_is_too_large_string);
+ return((x > 0.0) ? (s7_int)floor(x) : (s7_int)ceil(x));
+}
+
+static s7_pointer truncate_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc, truncate_i_7d(sc, x)));}
+#endif
+
+
+/* -------------------------------- round -------------------------------- */
+static s7_double r5rs_round(s7_double x)
+{
+ s7_double fl = floor(x), ce = ceil(x);
+ s7_double dfl = x - fl;
+ s7_double dce = ce - x;
+ if (dfl > dce) return(ce);
+ if (dfl < dce) return(fl);
+ return((fmod(fl, 2.0) == 0.0) ? fl : ce);
+}
+
+static s7_pointer round_p_p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER:
+ 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));
+ }
+ 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);
+#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));
+ }
+#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);
+#endif
+ return(make_integer(sc, (s7_int)r5rs_round(z)));
+ }
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ 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));
+ }
+ 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);
+ if (mpfr_inf_p(big_real(x)))
+ 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);
+ return(mpz_to_integer(sc, sc->mpz_3));
+ case T_BIG_COMPLEX:
+#endif
+ case T_COMPLEX:
+ sole_arg_wrong_type_error_nr(sc, sc->round_symbol, x, sc->type_names[T_REAL]);
+ default:
+ return(method_or_bust_p(sc, x, sc->round_symbol, sc->type_names[T_REAL]));
+ }
+}
+
+static s7_pointer g_round(s7_scheme *sc, s7_pointer args)
+{
+ #define H_round "(round x) returns the integer closest to x"
+ #define Q_round s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)
+ return(round_p_p(sc, car(args)));
+}
+
+static s7_int round_i_i(s7_int i) {return(i);}
+
+#if (!WITH_GMP)
+static s7_int round_i_7d(s7_scheme *sc, s7_double z)
+{
+ if (is_NaN(z))
+ sole_arg_out_of_range_error_nr(sc, sc->round_symbol, real_NaN, it_is_nan_string);
+ if ((is_inf(z)) ||
+ (z > DOUBLE_TO_INT64_LIMIT) || (z < -DOUBLE_TO_INT64_LIMIT))
+ sole_arg_out_of_range_error_nr(sc, sc->round_symbol, wrap_real(sc, z), it_is_too_large_string);
+ return((s7_int)r5rs_round(z));
+}
+
+static s7_pointer round_p_d(s7_scheme *sc, s7_double x) {return(make_integer(sc,round_i_7d(sc, x)));}
+#endif
+
+
+/* ---------------------------------------- add ---------------------------------------- */
+static inline s7_pointer add_if_overflow_to_real_or_big_integer(s7_scheme *sc, s7_int x, s7_int y)
+{
+#if HAVE_OVERFLOW_CHECKS
+ s7_int val;
+ if (add_overflow(x, y, &val))
+#if WITH_GMP
+ {
+ mpz_set_si(sc->mpz_1, x);
+ mpz_set_si(sc->mpz_2, y);
+ mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
+ return(mpz_to_big_integer(sc, sc->mpz_1));
+ }
+#else
+ {
+ if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, y);
+ return(make_real(sc, (long_double)x + (long_double)y));
+ }
+#endif
+ return(make_integer(sc, val));
+#else
+ return(make_integer(sc, x + y));
+#endif
+}
+
+static s7_pointer integer_ratio_add_if_overflow_to_real_or_rational(s7_scheme *sc, s7_pointer x, s7_pointer y) /* x: int, y:ratio */
+{
+#if HAVE_OVERFLOW_CHECKS
+ s7_int z;
+ if ((multiply_overflow(integer(x), denominator(y), &z)) ||
+ (add_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_add(mpq_numref(sc->mpq_1), sc->mpz_2, sc->mpz_1);
+ 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)));
+ }
+#endif
+ return(make_ratio(sc, z, denominator(y)));
+#else
+ return(make_ratio(sc, integer(x) * denominator(y) + numerator(y), denominator(y)));
+#endif
+}
+
+#define parcel_out_fractions(X, Y) do {d1 = denominator(x); n1 = numerator(x); d2 = denominator(y); n2 = numerator(y);} while (0)
+/* add_out_x|y here (as in lt_out_x|y) gives a small speed-up, say 3-7 callgrind units, about 2% */
+
+static s7_pointer add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ /* an experiment: try to avoid the switch statement */
+ /* this wins in most s7 cases, not so much elsewhere? parallel subtract/multiply code is slower */
+ if (is_t_integer(x))
+ {
+ if (is_t_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)));
+ }
+ 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)));
+
+ 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:
+#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 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_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)
+ {
+#if HAVE_OVERFLOW_CHECKS
+ 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));
+ }
+#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));
+ }
+#endif
+ 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));
+#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)))
+#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));
+ }
+#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)));
+ }
+#endif
+ 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));
+#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)));
+#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_REAL:
+ switch (type(y))
+ {
+ 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 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_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)));
+#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));
+ }
+
+#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_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_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_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));
+ }
+#endif
+ default:
+ return(method_or_bust_pp(sc, x, sc->add_symbol, x, y, a_number_string, 1));
+ }
+}
+
+static s7_pointer add_p_ppp(s7_scheme *sc, s7_pointer p0, s7_pointer p1, s7_pointer p2)
+{
+ if ((is_t_integer(p0)) && (is_t_integer(p1)) && (is_t_integer(p2)))
+ {
+#if HAVE_OVERFLOW_CHECKS
+ s7_int val;
+ if ((!add_overflow(integer(p0), integer(p1), &val)) &&
+ (!add_overflow(val, integer(p2), &val)))
+ return(make_integer(sc, val));
+#if WITH_GMP
+ mpz_set_si(sc->mpz_1, integer(p0));
+ mpz_set_si(sc->mpz_2, integer(p1));
+ mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
+ mpz_set_si(sc->mpz_2, integer(p2));
+ mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2);
+ return(mpz_to_integer(sc, sc->mpz_1));
+#else
+ if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 " %" ld64 ")\n", integer(p0), integer(p1), integer(p2));
+ return(make_real(sc, (long_double)integer(p0) + (long_double)integer(p1) + (long_double)integer(p2)));
+#endif
+#else
+ return(make_integer(sc, integer(p0) + integer(p1) + integer(p2)));
+#endif
+ }
+ if ((is_t_real(p0)) && (is_t_real(p1)) && (is_t_real(p2)))
+ return(make_real(sc, real(p0) + real(p1) + real(p2)));
+ {
+ s7_pointer p = add_p_pp(sc, p0, p1);
+ sc->error_argnum = 1;
+ p = add_p_pp(sc, p, p2);
+ sc->error_argnum = 0;
+ return(p);
+ }
+}
+
+static s7_pointer g_add(s7_scheme *sc, s7_pointer args)
+{
+ #define H_add "(+ ...) adds its arguments"
+ #define Q_add sc->pcl_n
+
+ s7_pointer x, p;
+ if (is_null(args))
+ return(int_zero);
+ x = car(args);
+ p = cdr(args);
+ if (is_null(p))
+ {
+ if (!is_number(x))
+ return(method_or_bust_p(sc, x, sc->add_symbol, a_number_string));
+ return(x);
+ }
+ if (is_null(cdr(p)))
+ return(add_p_pp(sc, x, car(p)));
+ for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++)
+ x = add_p_pp(sc, x, car(p));
+ sc->error_argnum = 0;
+ return(x);
+}
+
+static s7_pointer g_add_2(s7_scheme *sc, s7_pointer args) {return(add_p_pp(sc, car(args), cadr(args)));}
+static s7_pointer g_add_3(s7_scheme *sc, s7_pointer args) {return(add_p_ppp(sc, car(args), cadr(args), caddr(args)));}
+
+static s7_pointer g_add_x1_1(s7_scheme *sc, s7_pointer x, int32_t pos)
+{
+ if (is_t_integer(x))
+ return(add_if_overflow_to_real_or_big_integer(sc, integer(x), 1));
+
+ switch (type(x))
+ {
+ case T_RATIO: return(integer_ratio_add_if_overflow_to_real_or_rational(sc, int_one, x)); /* return(add_p_pp(sc, x, int_one)) */
+ case T_REAL: return(make_real(sc, real(x) + 1.0));
+ case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x)));
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpz_set_si(sc->mpz_1, 1);
+ mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1);
+ return(mpz_to_integer(sc, sc->mpz_1));
+ case T_BIG_RATIO:
+ case T_BIG_REAL:
+ case T_BIG_COMPLEX:
+ return(add_p_pp(sc, x, int_one));
+#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));
+ }
+ return(x);
+}
+
+#if WITH_GMP
+static s7_pointer g_add_x1(s7_scheme *sc, s7_pointer args) {return(g_add_x1_1(sc, car(args), 1));}
+#else
+static s7_pointer g_add_x1(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer x = car(args);
+ if (is_t_integer(x)) return(add_if_overflow_to_real_or_big_integer(sc, integer(x), 1)); /* return(make_integer(sc, integer(x) + 1)); */
+ if (is_t_real(x)) return(make_real(sc, real(x) + 1.0));
+ if (is_t_complex(x)) return(make_complex_not_0i(sc, real_part(x) + 1.0, imag_part(x)));
+ return(add_p_pp(sc, x, int_one));
+}
+#endif
+static s7_pointer g_add_1x(s7_scheme *sc, s7_pointer args) {return(g_add_x1_1(sc, cadr(args), 2));}
+
+static s7_pointer g_add_xi(s7_scheme *sc, s7_pointer x, s7_int y, int32_t loc)
+{
+ if (is_t_integer(x))
+ return(add_if_overflow_to_real_or_big_integer(sc, integer(x), y));
+
+ switch (type(x))
+ {
+ case T_RATIO: return(add_p_pp(sc, x, wrap_integer(sc, y)));
+ case T_REAL: return(make_real(sc, real(x) + y));
+ case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + y, imag_part(x)));
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpz_set_si(sc->mpz_1, y);
+ mpz_add(sc->mpz_1, big_integer(x), sc->mpz_1);
+ return(mpz_to_integer(sc, sc->mpz_1));
+ case T_BIG_RATIO:
+ case T_BIG_REAL:
+ case T_BIG_COMPLEX:
+ return(add_p_pp(sc, x, wrap_integer(sc, y)));
+#endif
+ default: return(method_or_bust_with_type_pi(sc, x, sc->add_symbol, x, y, a_number_string, loc));
+ }
+ return(x);
+}
+
+static s7_pointer add_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) {return(g_add_xi(sc, p1, i1, 1));}
+
+static s7_pointer g_add_xf(s7_scheme *sc, s7_pointer x, s7_double y, int32_t loc)
+{
+ if (is_t_real(x)) return(make_real(sc, real(x) + y));
+ switch (type(x))
+ {
+ case T_INTEGER: return(make_real(sc, integer(x) + y));
+ case T_RATIO: return(make_real(sc, fraction(x) + y));
+ case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) + y, imag_part(x)));
+#if WITH_GMP
+ case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
+ return(add_p_pp(sc, x, wrap_real(sc, y)));
+#endif
+ default: return(method_or_bust_with_type_pf(sc, x, sc->add_symbol, x, y, a_number_string, loc));
+ }
+ return(x);
+}
+
+static s7_pointer g_add_2_ff(s7_scheme *sc, s7_pointer args)
+{
+#if WITH_GMP
+ if ((is_t_real(car(args))) && (is_t_real(cadr(args))))
+ return(make_real(sc, real(car(args)) + real(cadr(args))));
+ return(add_p_pp(sc, car(args), cadr(args)));
+#else
+ return(make_real(sc, real(car(args)) + real(cadr(args))));
+#endif
+}
+
+static s7_pointer g_add_2_ii(s7_scheme *sc, s7_pointer args)
+{
+#if WITH_GMP
+ if ((is_t_integer(car(args))) && (is_t_integer(cadr(args))))
+#endif
+ return(add_if_overflow_to_real_or_big_integer(sc, integer(car(args)), integer(cadr(args))));
+#if WITH_GMP
+ return(g_add(sc, args)); /* possibly bigint? */
+#endif
+}
+
+#if WITH_GMP
+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));
+ }
+ return(make_real(sc, integer(x) + real(y)));
+ }
+ return(add_p_pp(sc, x, y));
+}
+
+static s7_pointer g_add_2_if(s7_scheme *sc, s7_pointer args) {return(add_2_if(sc, car(args), cadr(args)));}
+static s7_pointer g_add_2_fi(s7_scheme *sc, s7_pointer args) {return(add_2_if(sc, cadr(args), car(args)));}
+
+static s7_pointer g_add_2_xi(s7_scheme *sc, s7_pointer args) {if (is_t_integer(cadr(args))) return(g_add_xi(sc, car(args), integer(cadr(args)), 1)); return(g_add(sc, args));}
+static s7_pointer g_add_2_ix(s7_scheme *sc, s7_pointer args) {if (is_t_integer(car(args))) return(g_add_xi(sc, cadr(args), integer(car(args)), 2)); return(g_add(sc, args));}
+static s7_pointer g_add_2_xf(s7_scheme *sc, s7_pointer args) {if (is_t_real(cadr(args))) return(g_add_xf(sc, car(args), real(cadr(args)), 1)); return(g_add(sc, args));}
+static s7_pointer g_add_2_fx(s7_scheme *sc, s7_pointer args) {if (is_t_real(car(args))) return(g_add_xf(sc, cadr(args), real(car(args)), 2)); return(g_add(sc, args));}
+
+#else
+
+static s7_pointer g_add_2_if(s7_scheme *sc, s7_pointer args) {return(make_real(sc, integer(car(args)) + real(cadr(args))));}
+static s7_pointer g_add_2_fi(s7_scheme *sc, s7_pointer args) {return(make_real(sc, real(car(args)) + integer(cadr(args))));}
+static s7_pointer g_add_2_xi(s7_scheme *sc, s7_pointer args) {return(g_add_xi(sc, car(args), integer(cadr(args)), 1));}
+static s7_pointer g_add_2_ix(s7_scheme *sc, s7_pointer args) {return(g_add_xi(sc, cadr(args), integer(car(args)), 2));}
+static s7_pointer g_add_2_xf(s7_scheme *sc, s7_pointer args) {return(g_add_xf(sc, car(args), real(cadr(args)), 1));}
+static s7_pointer g_add_2_fx(s7_scheme *sc, s7_pointer args) {return(g_add_xf(sc, cadr(args), real(car(args)), 2));}
+#endif
+
+static s7_pointer add_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 + x2));}
+static s7_pointer add_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_integer(sc, x1 + x2));}
+
+static s7_double add_d_d(s7_double x) {return(x);}
+static s7_double add_d_dd(s7_double x1, s7_double x2) {return(x1 + x2);}
+static s7_double add_d_id(s7_int x1, s7_double x2) {return(x1 + x2);}
+static s7_double add_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(x1 + x2 + x3);}
+static s7_double add_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 + x2 + x3 + x4);}
+
+static s7_int add_i_ii(s7_int i1, s7_int i2) {return(i1 + i2);}
+static s7_int add_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 + i2 + i3);}
+
+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) */
+
+ 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));
+ }
+ /* perhaps add closure sig if we can depend on it (immutable func etc) */
+ }
+ else
+ if (!is_symbol(arg1))
+ return(s7_type_of(sc, arg1));
+ return(NULL);
+}
+
+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)
+{
+ 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 (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_xf);
+ if (arg2_type == sc->is_integer_symbol)
+ return(f_2_xi);
+ }
+ return(fallback);
+}
+
+static s7_pointer g_random_i(s7_scheme *sc, s7_pointer args);
+
+static s7_pointer add_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ /* (+ s f) (+ (* s s) s) (+ s s) (+ s (* s s)) */
+ if (args != 2) return((args == 3) ? sc->add_3 : f);
+ {
+ s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
+ if (arg2 == int_one) /* (+ ... 1) */
+ 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);
+ }
+ if (arg1 == int_one)
+ 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));
+ }
+ return(sc->add_2);
+}
+
+/* ---------------------------------------- subtract ---------------------------------------- */
+static s7_pointer negate_p_p(s7_scheme *sc, s7_pointer p) /* can't use "negate" because it confuses C++! */
+{
+ switch (type(p))
+ {
+ 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));
+ }
+#else
+ 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)));
+
+ case T_RATIO: return(make_simple_ratio(sc, -numerator(p), denominator(p)));
+ case T_REAL: return(make_real(sc, -real(p)));
+ case T_COMPLEX: return(make_complex_not_0i(sc, -real_part(p), -imag_part(p)));
+
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpz_neg(sc->mpz_1, big_integer(p));
+ return(mpz_to_integer(sc, sc->mpz_1));
+ case T_BIG_RATIO:
+ mpq_neg(sc->mpq_1, big_ratio(p));
+ return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
+ case T_BIG_REAL:
+ mpfr_neg(sc->mpfr_1, big_real(p), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ case T_BIG_COMPLEX:
+ mpc_neg(sc->mpc_1, big_complex(p), MPC_RNDNN);
+ return(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust_p(sc, p, sc->subtract_symbol, a_number_string));
+ }
+}
+
+static inline s7_pointer subtract_if_overflow_to_real_or_big_integer(s7_scheme *sc, s7_int x, s7_int y)
+{
+#if HAVE_OVERFLOW_CHECKS
+ s7_int val;
+ if (subtract_overflow(x, y, &val))
+#if WITH_GMP
+ {
+ mpz_set_si(sc->mpz_1, x);
+ mpz_set_si(sc->mpz_2, y);
+ mpz_sub(sc->mpz_1, sc->mpz_1, sc->mpz_2);
+ return(mpz_to_big_integer(sc, sc->mpz_1));
+ }
+#else
+ {
+ if (WITH_WARNINGS) s7_warn(sc, 128, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", x, y);
+ return(make_real(sc, (long_double)x - (long_double)y));
+ }
+#endif
+ return(make_integer(sc, val));
+#else
+ return(make_integer(sc, x - y));
+#endif
+}
+
+static s7_pointer subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ switch (type(x))
+ {
+ case T_INTEGER:
+ if (integer(x) == 0)
+ 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_RATIO:
+ {
+#if HAVE_OVERFLOW_CHECKS
+ 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));
+ }
+#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)));
+ }
+#endif
+ return(make_ratio(sc, z, denominator(y)));
+#else
+ return(make_ratio(sc, integer(x) * denominator(y) - numerator(y), denominator(y)));
+#endif
+ }
+ 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 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_RATIO:
+ switch (type(y))
+ {
+ case T_INTEGER:
+ {
+#if HAVE_OVERFLOW_CHECKS
+ 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));
+ }
+#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)));
+ }
+#endif
+ 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)
+ {
+#if HAVE_OVERFLOW_CHECKS
+ 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));
+ }
+#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));
+ }
+#endif
+ return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1));
+#else
+ 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)))
+#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));
+ }
+#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)));
+ }
+#endif
+ 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));
+#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)));
+#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_REAL:
+ switch (type(y))
+ {
+ 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 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_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)));
+#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));
+ }
+
+#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_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_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_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));
+ }
+#endif
+ default:
+ return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, y, a_number_string, 1));
+ }
+}
+
+static s7_pointer g_subtract(s7_scheme *sc, s7_pointer args)
+{
+ #define H_subtract "(- x1 ...) subtracts its trailing arguments from the first, or negates the first if only one it is given"
+ #define Q_subtract sc->pcl_n
+
+ s7_pointer x = car(args), p = cdr(args);
+ if (is_null(p))
+ return(negate_p_p(sc, x));
+ for (sc->error_argnum = 0; is_pair(p); p = cdr(p), sc->error_argnum++)
+ x = subtract_p_pp(sc, x, car(p));
+ sc->error_argnum = 0;
+ return(x);
+}
+
+static s7_pointer g_subtract_1(s7_scheme *sc, s7_pointer args) {return(negate_p_p(sc, car(args)));}
+static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args) {return(subtract_p_pp(sc, car(args), cadr(args)));}
+
+static s7_pointer g_subtract_3(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer x = car(args);
+ x = subtract_p_pp(sc, x, cadr(args));
+ sc->error_argnum = 1;
+ x = subtract_p_pp(sc, x, caddr(args));
+ sc->error_argnum = 0;
+ return(x);
+}
+
+static s7_pointer minus_c1(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER: return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), 1));
+ case T_RATIO: return(subtract_p_pp(sc, x, int_one));
+ case T_REAL: return(make_real(sc, real(x) - 1.0));
+ case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - 1.0, imag_part(x)));
+#if WITH_GMP
+ case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
+ return(subtract_p_pp(sc, x, int_one));
+#endif
+ default:
+ return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, int_one, a_number_string, 1));
+ }
+ return(x);
+}
+
+static s7_pointer g_subtract_x1(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p = car(args);
+#if WITH_GMP
+ return(subtract_p_pp(sc, p, int_one));
+#endif
+ /* return((is_t_integer(p)) ? make_integer(sc, integer(p) - 1) : minus_c1(sc, p)); */
+ return((is_t_integer(p)) ? subtract_if_overflow_to_real_or_big_integer(sc, integer(p), 1) : minus_c1(sc, p));
+}
+
+static s7_pointer g_subtract_2f(s7_scheme *sc, s7_pointer args) /* (- x f) */
+{
+ s7_pointer x = car(args);
+ s7_double n = real(cadr(args)); /* checked below is_t_real */
+ if (is_t_real(x)) return(make_real(sc, real(x) - n));
+ switch (type(x))
+ {
+ case T_INTEGER: return(make_real(sc, integer(x) - n));
+ case T_RATIO: return(make_real(sc, fraction(x) - n));
+ case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - n, imag_part(x)));
+#if WITH_GMP
+ case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
+ return(subtract_p_pp(sc, x, cadr(args)));
+#endif
+ default:
+ return(method_or_bust(sc, x, sc->subtract_symbol, args, a_number_string, 1));
+ }
+ return(x);
+}
+
+static s7_pointer g_subtract_f2(s7_scheme *sc, s7_pointer args) /* (- f x) */
+{
+ s7_pointer x = cadr(args);
+ s7_double n = real(car(args)); /* checked below is_t_real */
+
+ if (is_t_real(x)) return(make_real(sc, n - real(x)));
+ switch (type(x))
+ {
+ case T_INTEGER: return(make_real(sc, n - integer(x)));
+ case T_RATIO: return(make_real(sc, n - fraction(x)));
+ case T_COMPLEX: return(make_complex_not_0i(sc, n - real_part(x), -imag_part(x)));
+#if WITH_GMP
+ case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
+ return(subtract_p_pp(sc, car(args), x));
+#endif
+ default:
+ return(method_or_bust(sc, x, sc->subtract_symbol, args, a_number_string, 1));
+ }
+ return(x);
+}
+
+static s7_int subtract_i_ii(s7_int i1, s7_int i2) {return(i1 - i2);}
+static s7_int subtract_i_i(s7_int x) {return(-x);}
+static s7_int subtract_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 - i2 - i3);}
+
+static s7_double subtract_d_d(s7_double x) {return(-x);}
+static s7_double subtract_d_dd(s7_double x1, s7_double x2) {return(x1 - x2);}
+static s7_double subtract_d_id(s7_int x1, s7_double x2) {return(x1 - x2);}
+static s7_double subtract_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(x1 - x2 - x3);}
+static s7_double subtract_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 - x2 - x3 - x4);}
+
+static s7_pointer subtract_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 - x2));}
+static s7_pointer subtract_p_ii(s7_scheme *sc, s7_int i1, s7_int i2) {return(make_integer(sc, i1 - i2));}
+
+static s7_pointer g_sub_xi(s7_scheme *sc, s7_pointer x, s7_int y)
+{
+ if (is_t_integer(x))
+ return(subtract_if_overflow_to_real_or_big_integer(sc, integer(x), y));
+
+ switch (type(x))
+ {
+ case T_RATIO: return(make_ratio(sc, numerator(x) - (y * denominator(x)), denominator(x)));
+ case T_REAL: return(make_real(sc, real(x) - y));
+ case T_COMPLEX: return(make_complex_not_0i(sc, real_part(x) - y, imag_part(x)));
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpz_set_si(sc->mpz_1, y);
+ mpz_sub(sc->mpz_1, big_integer(x), sc->mpz_1);
+ return(mpz_to_integer(sc, sc->mpz_1));
+ case T_BIG_RATIO:
+ case T_BIG_REAL:
+ case T_BIG_COMPLEX:
+ return(subtract_p_pp(sc, x, wrap_integer(sc, y)));
+#endif
+ default: return(method_or_bust_with_type_pi(sc, x, sc->subtract_symbol, x, y, a_number_string, 1));
+ }
+ return(x);
+}
+
+static s7_pointer subtract_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ s7_pointer arg1, arg2;
+ if (args == 1) return(sc->subtract_1);
+ if (args != 2) return((args == 3) ? sc->subtract_3 : f);
+ arg1 = cadr(expr);
+ arg2 = caddr(expr);
+ if (arg2 == int_one) return(sc->subtract_x1);
+ if (is_t_real(arg1)) return(sc->subtract_f2);
+ if (is_t_real(arg2)) return(sc->subtract_2f);
+ return(sc->subtract_2);
+}
+
+
+/* ---------------------------------------- multiply ---------------------------------------- */
+#define QUOTIENT_FLOAT_LIMIT 1e13
+#define QUOTIENT_INT_LIMIT 10000000000000
+/* fraction(x) is not accurate enough if it involves numbers over e18 even when done with long_doubles */
+
+static inline s7_pointer multiply_if_overflow_to_real_or_big_integer(s7_scheme *sc, s7_int x, s7_int y)
+{
+#if HAVE_OVERFLOW_CHECKS
+ s7_int val;
+ if (multiply_overflow(x, y, &val))
+#if WITH_GMP
+ {
+ mpz_set_si(sc->mpz_1, x);
+ mpz_mul_si(sc->mpz_1, sc->mpz_1, y);
+ return(mpz_to_big_integer(sc, sc->mpz_1));
+ }
+#else
+ {
+ if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y);
+ return(make_real(sc, (s7_double)x * (s7_double)y));
+ }
+#endif
+ return(make_integer(sc, val));
+#else
+ return(make_integer(sc, x * y));
+#endif
+}
+
+static s7_pointer integer_ratio_multiply_if_overflow_to_real_or_ratio(s7_scheme *sc, s7_int x, s7_pointer y)
+{
+#if HAVE_OVERFLOW_CHECKS
+ s7_int z;
+ if (multiply_overflow(x, numerator(y), &z))
+#if WITH_GMP
+ {
+ mpz_set_si(sc->mpz_1, x);
+ mpz_mul_si(sc->mpz_1, sc->mpz_1, numerator(y));
+ mpq_set_si(sc->mpq_1, 1, denominator(y));
+ mpq_set_num(sc->mpq_1, sc->mpz_1);
+ return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
+ }
+#else
+ {
+ if (WITH_WARNINGS) s7_warn(sc, 128, "integer * ratio overflow: (* %" ld64 " %" ld64 "/%" ld64 ")\n", x, numerator(y), denominator(y));
+ return(make_real(sc, (s7_double)x * fraction(y)));
+ }
+#endif
+ return(make_ratio(sc, z, denominator(y)));
+#else
+ return(make_ratio(sc, x * numerator(y), denominator(y)));
+#endif
+}
+
+static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ switch (type(x))
+ {
+ 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:
+#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 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_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);
+#if HAVE_OVERFLOW_CHECKS
+ {
+ 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));
+ }
+#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)));
+ }
+#endif
+ 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));
+#endif
+ }
+ 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 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_REAL:
+ switch (type(y))
+ {
+ 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 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 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_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));
+ }
+#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));
+ }
+
+#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_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_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_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));
+ }
+#endif
+ default:
+ return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, y, a_number_string, 1));
+ }
+}
+
+static s7_pointer multiply_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z)
+{
+ /* no hits for reals in tnum */
+ /* if ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z))) return(make_real(sc, real(x) * real(y) * real(z))); */
+ x = multiply_p_pp(sc, x, y);
+ sc->error_argnum = 1;
+ x = multiply_p_pp(sc, x, z);
+ sc->error_argnum = 0;
+ return(x);
+}
+
+static s7_pointer multiply_method_or_bust(s7_scheme *sc, s7_pointer obj, s7_pointer args, s7_pointer typ, int32_t num)
+{
+ if (has_active_methods(sc, obj))
+ return(find_and_apply_method(sc, obj, sc->multiply_symbol, args));
+ if (num == 0)
+ sole_arg_wrong_type_error_nr(sc, sc->multiply_symbol, obj, typ);
+ wrong_type_error_nr(sc, sc->multiply_symbol, num, obj, typ);
+ return(NULL);
+}
+
+static s7_pointer g_multiply(s7_scheme *sc, s7_pointer args)
+{
+ #define H_multiply "(* ...) multiplies its arguments"
+ #define Q_multiply sc->pcl_n
+
+ s7_pointer x, p;
+ if (is_null(args))
+ return(int_one);
+ x = car(args);
+ p = cdr(args);
+ if (is_null(p))
+ {
+ if (!is_number(x))
+ 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++)
+ x = multiply_p_pp(sc, x, car(p));
+ sc->error_argnum = 0;
+ return(x);
+}
+
+static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args) {return(multiply_p_pp(sc, car(args), cadr(args)));}
+
+static s7_pointer g_mul_xi(s7_scheme *sc, s7_pointer x, s7_int n, int32_t loc)
+{
+ switch (type(x))
+ {
+ case T_INTEGER: return(multiply_if_overflow_to_real_or_big_integer(sc, integer(x), n));
+ case T_RATIO: return(integer_ratio_multiply_if_overflow_to_real_or_ratio(sc, n, x));
+ case T_REAL: return(make_real(sc, real(x) * n));
+ case T_COMPLEX: return(make_complex(sc, real_part(x) * n, imag_part(x) * n));
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpz_mul_si(sc->mpz_1, big_integer(x), n);
+ return(mpz_to_integer(sc, sc->mpz_1));
+ case T_BIG_RATIO:
+ case T_BIG_REAL:
+ case T_BIG_COMPLEX:
+ return(multiply_p_pp(sc, x, wrap_integer(sc, n)));
+#endif
+ default:
+ /* we can get here from mul_2_xi for example so the non-integer argument might not be a symbol */
+ return(method_or_bust_with_type_pi(sc, x, sc->multiply_symbol, x, n, a_number_string, loc));
+ }
+ return(x);
+}
+
+static s7_pointer multiply_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) {return(g_mul_xi(sc, p1, i1, 1));}
+
+static s7_pointer g_mul_xf(s7_scheme *sc, s7_pointer x, s7_double y, int32_t num)
+{
+ /* it's possible to return different argument NaNs depending on the expression or how it is wrapped:
+ * (* (bignum +nan.0) +nan.123) -> nan.123
+ * (let () (define (func) (* (bignum +nan.0) +nan.123)) (func) (func)) -> nan.0
+ * latter call is fx_c_aaa->fx_c_ac->g_mul_xf (if +nan.122 instead of +nan.0, we get +nan.122 so we always get one of the NaNs)
+ */
+ switch (type(x))
+ {
+ case T_INTEGER: return(make_real(sc, integer(x) * y));
+ case T_RATIO: return(make_real(sc, numerator(x) * y / denominator(x)));
+ case T_REAL: return(make_real(sc, real(x) * y));
+ case T_COMPLEX: return(make_complex(sc, real_part(x) * y, imag_part(x) * y));
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpfr_set_d(sc->mpfr_1, 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_BIG_RATIO:
+ mpfr_set_d(sc->mpfr_1, 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_BIG_REAL:
+ mpfr_mul_d(sc->mpfr_1, big_real(x), y, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ case T_BIG_COMPLEX:
+ mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
+ mpc_mul_fr(sc->mpc_1, big_complex(x), sc->mpfr_1, MPC_RNDNN);
+ return(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default: return(method_or_bust_with_type_pf(sc, x, sc->multiply_symbol, x, y, a_number_string, num));
+ }
+ return(x);
+}
+
+#if WITH_GMP
+static s7_pointer g_mul_2_if(s7_scheme *sc, s7_pointer args) {
+ if ((is_t_integer(car(args))) && (is_t_real(cadr(args))))
+ return(make_real(sc, integer(car(args)) * real(cadr(args))));
+ return(multiply_p_pp(sc, car(args), cadr(args)));
+}
+
+static s7_pointer g_mul_2_fi(s7_scheme *sc, s7_pointer args)
+{
+ if ((is_t_integer(cadr(args))) && (is_t_real(car(args))))
+ return(make_real(sc, real(car(args)) * integer(cadr(args))));
+ return(multiply_p_pp(sc, car(args), cadr(args)));
+}
+
+static s7_pointer g_mul_2_xi(s7_scheme *sc, s7_pointer args) {if (is_t_integer(cadr(args))) return(g_mul_xi(sc, car(args), integer(cadr(args)), 1)); return(g_multiply(sc, args));}
+static s7_pointer g_mul_2_ix(s7_scheme *sc, s7_pointer args) {if (is_t_integer(car(args))) return(g_mul_xi(sc, cadr(args), integer(car(args)), 2)); return(g_multiply(sc, args));}
+static s7_pointer g_mul_2_xf(s7_scheme *sc, s7_pointer args) {if (is_t_real(cadr(args))) return(g_mul_xf(sc, car(args), real(cadr(args)), 1)); return(g_multiply(sc, args));}
+static s7_pointer g_mul_2_fx(s7_scheme *sc, s7_pointer args) {if (is_t_real(car(args))) return(g_mul_xf(sc, cadr(args), real(car(args)), 2)); return(g_multiply(sc, args));}
+static s7_pointer g_mul_2_ff(s7_scheme *sc, s7_pointer args) {return(multiply_p_pp(sc, car(args), cadr(args)));}
+static s7_pointer g_mul_2_ii(s7_scheme *sc, s7_pointer args) {return(multiply_p_pp(sc, car(args), cadr(args)));}
+#else
+static s7_pointer g_mul_2_if(s7_scheme *sc, s7_pointer args) {return(make_real(sc, integer(car(args)) * real(cadr(args))));}
+static s7_pointer g_mul_2_fi(s7_scheme *sc, s7_pointer args) {return(make_real(sc, real(car(args)) * integer(cadr(args))));}
+static s7_pointer g_mul_2_xi(s7_scheme *sc, s7_pointer args) {return(g_mul_xi(sc, car(args), integer(cadr(args)), 1));}
+static s7_pointer g_mul_2_ix(s7_scheme *sc, s7_pointer args) {return(g_mul_xi(sc, cadr(args), integer(car(args)), 2));}
+static s7_pointer g_mul_2_xf(s7_scheme *sc, s7_pointer args) {return(g_mul_xf(sc, car(args), real(cadr(args)), 1));} /* split out t_real is slower */
+static s7_pointer g_mul_2_fx(s7_scheme *sc, s7_pointer args) {return(g_mul_xf(sc, cadr(args), real(car(args)), 2));}
+static s7_pointer g_mul_2_ff(s7_scheme *sc, s7_pointer args) {return(make_real(sc, real(car(args)) * real(cadr(args))));}
+
+static s7_pointer g_mul_2_ii(s7_scheme *sc, s7_pointer args)
+{
+#if HAVE_OVERFLOW_CHECKS
+ s7_int val, x = integer(car(args)), y = integer(cadr(args));
+ if (multiply_overflow(x, y, &val))
+ {
+ if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y);
+ return(make_real(sc, (s7_double)x * (s7_double)y));
+ }
+ return(make_integer(sc, val));
+#else
+ return(make_integer(sc, integer(car(args)) * integer(cadr(args))));
+#endif
+}
+#endif
+
+static s7_int multiply_i_ii(s7_int i1, s7_int i2)
+{
+#if HAVE_OVERFLOW_CHECKS
+ s7_int val;
+ if (multiply_overflow(i1, i2, &val))
+ {
+#if WITH_WARNINGS
+ s7_warn(cur_sc, 64, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", i1, i2);
+#endif
+ return(S7_INT64_MAX); /* this is inconsistent with other unopt cases where an overflow -> double result */
+ }
+ /* (let () (define (func) (do ((i 0 (+ i 1))) ((= i 1)) (do ((j 0 (+ j 1))) ((= j 1)) (even? (* (ash 1 43) (ash 1 43)))))) (define (hi) (func)) (hi)) */
+ return(val);
+#else
+ return(i1 * i2);
+#endif
+}
+
+static s7_int multiply_i_iii(s7_int i1, s7_int i2, s7_int i3)
+{
+#if HAVE_OVERFLOW_CHECKS
+ s7_int val1, val2;
+ if ((multiply_overflow(i1, i2, &val1)) ||
+ (multiply_overflow(val1, i3, &val2)))
+ {
+#if WITH_WARNINGS
+ s7_warn(cur_sc, 64, "integer multiply overflow: (* %" ld64 " %" ld64 " %" ld64 ")\n", i1, i2, i3);
+#endif
+ return(S7_INT64_MAX);
+ }
+ return(val2);
+#else
+ return(i1 * i2 * i3);
+#endif
+}
+
+static s7_double multiply_d_d(s7_double x) {return(x);}
+static s7_double multiply_d_dd(s7_double x1, s7_double x2) {return(x1 * x2);}
+static s7_double multiply_d_id(s7_int x1, s7_double x2) {return(x1 * x2);}
+static s7_double multiply_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(x1 * x2 * x3);}
+static s7_double multiply_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(x1 * x2 * x3 * x4);}
+static s7_pointer mul_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 * x2));}
+
+static s7_pointer multiply_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ 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));
+}
+
+
+/* ---------------------------------------- divide ---------------------------------------- */
+static s7_pointer complex_invert(s7_scheme *sc, s7_pointer p)
+{
+ s7_double r2 = real_part(p), i2 = imag_part(p);
+ s7_double den = (r2 * r2 + i2 * i2);
+ /* here if p is, for example, -inf.0+i, den is +inf.0 so -i2/den is -0.0 (in gcc anyway), so the imag part is 0.0 */
+ return(make_complex(sc, r2 / den, -i2 / den));
+}
+
+static s7_pointer invert_p_p(s7_scheme *sc, s7_pointer p)
+{
+#if WITH_GMP
+ s7_pointer x;
+#endif
+ switch (type(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);
+ }
+#endif
+ if (integer(p) == 0)
+ 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);
+ return(make_real(sc, 1.0 / real(p)));
+ case T_COMPLEX:
+ return(complex_invert(sc, 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);
+ if ((mpz_cmp_ui(big_integer(p), 1) == 0) || (mpz_cmp_si(big_integer(p), -1) == 0))
+ return(p);
+ new_cell(sc, x, T_BIG_RATIO);
+ big_ratio_bgr(x) = alloc_bigrat(sc);
+ add_big_ratio(sc, x);
+ mpq_set_si(big_ratio(x), 1, 1);
+ mpq_set_den(big_ratio(x), big_integer(p));
+ mpq_canonicalize(big_ratio(x));
+ return(x);
+
+ 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))));
+ 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));
+ }
+ new_cell(sc, x, T_BIG_RATIO);
+ big_ratio_bgr(x) = alloc_bigrat(sc);
+ add_big_ratio(sc, x);
+ mpq_inv(big_ratio(x), big_ratio(p));
+ mpq_canonicalize(big_ratio(x));
+ return(x);
+
+ case T_BIG_REAL:
+ if (mpfr_zero_p(big_real(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);
+ 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
+ default:
+ check_method(sc, p, sc->divide_symbol, set_plist_1(sc, p));
+ wrong_type_error_nr(sc, sc->divide_symbol, 1, p, a_number_string);
+ }
+ return(NULL);
+}
+
+static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ /* splitting out real/real here saves very little */
+ switch (type(x))
+ {
+ 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:
+#if HAVE_OVERFLOW_CHECKS
+ {
+ 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));
+ }
+#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)));
+ }
+#endif
+ 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)));
+#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);
+#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 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));
+ }
+ 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);
+#if HAVE_OVERFLOW_CHECKS
+ {
+ 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));
+ }
+#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))));
+ }
+#endif
+ 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)));
+#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));
+#if HAVE_OVERFLOW_CHECKS
+ 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));
+#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));
+#else
+ 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_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));
+ }
+
+ /* -------- 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));
+ }
+
+#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));
+ }
+
+ /* -------- 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));
+ }
+
+#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));
+ }
+
+#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_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_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_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));
+ }
+#endif
+
+ default: /* x is not a built-in number */
+ return(method_or_bust_pp(sc, x, sc->divide_symbol, x, y, a_number_string, 1)); /* not args here! y = apply * to cdr(args) */
+ }
+ return(NULL); /* make the compiler happy */
+}
+
+static s7_pointer g_divide(s7_scheme *sc, s7_pointer args)
+{
+ #define H_divide "(/ x1 ...) divides its first argument by the rest, or inverts the first if there is only one argument"
+ #define Q_divide sc->pcl_n
+
+ s7_pointer x = car(args), p = cdr(args);
+ if (is_null(p)) /* (/ x) */
+ {
+ if (!is_number(x))
+ 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++)
+ x = divide_p_pp(sc, x, car(p));
+ sc->error_argnum = 0;
+ return(x);
+}
+
+static s7_pointer g_invert_1(s7_scheme *sc, s7_pointer args) {return(invert_p_p(sc, car(args)));}
+static s7_pointer g_divide_2(s7_scheme *sc, s7_pointer args) {return(divide_p_pp(sc, car(args), cadr(args)));}
+
+static s7_pointer g_divide_by_2(s7_scheme *sc, s7_pointer args)
+{
+ /* (/ x 2) */
+ s7_pointer num = car(args);
+ if (is_t_integer(num))
+ {
+ 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);
+ }
+ return(make_integer(sc, i >> 1));
+ }
+ switch (type(num))
+ {
+ case T_RATIO:
+#if HAVE_OVERFLOW_CHECKS
+ {
+ 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));
+ }
+#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));
+ }
+#else
+ return(make_ratio(sc, numerator(num), denominator(num) * 2));
+#endif
+
+ case T_REAL: return(make_real(sc, real(num) * 0.5));
+ case T_COMPLEX: return(make_complex_not_0i(sc, real_part(num) * 0.5, imag_part(num) * 0.5));
+
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpq_set_z(sc->mpq_1, big_integer(num));
+ mpz_mul_ui(mpq_denref(sc->mpq_1), mpq_denref(sc->mpq_1), 2);
+ return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
+ case T_BIG_RATIO:
+ mpq_set_si(sc->mpq_1, 2, 1);
+ mpq_div(sc->mpq_1, big_ratio(num), sc->mpq_1);
+ return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
+ case T_BIG_REAL:
+ mpfr_div_si(sc->mpfr_1, big_real(num), 2, MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ case T_BIG_COMPLEX:
+ mpc_set_si(sc->mpc_1, 2, MPC_RNDNN);
+ mpc_div(sc->mpc_1, big_complex(num), sc->mpc_1, MPC_RNDNN);
+ return(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust_pp(sc, num, sc->divide_symbol, num, int_two, a_number_string, 1));
+ }
+}
+
+static s7_pointer g_invert_x(s7_scheme *sc, s7_pointer args)
+{
+ /* (/ 1.0 x) */
+ s7_pointer x = cadr(args);
+ if (is_t_real(x))
+ {
+ s7_double rl = real(x);
+ if (rl == 0.0)
+ 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));
+}
+
+static s7_double divide_d_7d(s7_scheme *sc, s7_double x)
+{
+ if (x == 0.0) division_by_zero_error_1_nr(sc, sc->divide_symbol, real_zero);
+ return(1.0 / x);
+}
+
+static s7_double divide_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2)
+{
+ if (x2 == 0.0) division_by_zero_error_1_nr(sc, sc->divide_symbol, real_zero);
+ return(x1 / x2);
+}
+
+static s7_pointer divide_p_ii(s7_scheme *sc, s7_int x, s7_int y) {return(make_ratio_with_div_check(sc, sc->divide_symbol, x, y));}
+static s7_pointer divide_p_i(s7_scheme *sc, s7_int x) {return(make_ratio_with_div_check(sc, sc->divide_symbol, 1, x));}
+
+static s7_pointer divide_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if (args == 1)
+ return(sc->invert_1);
+ if (args == 2)
+ {
+ s7_pointer arg1 = cadr(expr);
+ if ((is_t_real(arg1)) && (real(arg1) == 1.0))
+ return(sc->invert_x);
+ return(((is_t_integer(caddr(expr))) && (integer(caddr(expr)) == 2)) ? sc->divide_by_2 : sc->divide_2);
+ }
+ return(f);
+}
+
+
+/* -------------------------------- quotient -------------------------------- */
+static inline s7_int quotient_i_7ii(s7_scheme *sc, s7_int x, s7_int y)
+{
+ if ((y > 0) || (y < -1)) return(x / y);
+ if (y == 0)
+ division_by_zero_error_2_nr(sc, sc->quotient_symbol, wrap_integer(sc, x), int_zero);
+ if (x == S7_INT64_MIN) /* (quotient most-negative-fixnum -1) */
+ sole_arg_out_of_range_error_nr(sc, sc->quotient_symbol, set_elist_2(sc, leastfix, minus_one), it_is_too_large_string);
+ return(-x); /* (quotient x -1) */
+}
+
+#if (!WITH_GMP)
+static s7_pointer s7_truncate(s7_scheme *sc, s7_pointer caller, s7_double xf) /* can't use "truncate" -- it's in unistd.h */
+{
+ if (fabs(xf) > QUOTIENT_FLOAT_LIMIT)
+ sole_arg_out_of_range_error_nr(sc, caller, wrap_real(sc, xf), it_is_too_large_string);
+ return(make_integer(sc, (xf > 0.0) ? (s7_int)floor(xf) : (s7_int)ceil(xf)));
+}
+
+static s7_int c_quo_dbl(s7_scheme *sc, s7_double x, s7_double y)
+{
+ s7_double xf;
+ if (y == 0.0)
+ division_by_zero_error_2_nr(sc, sc->quotient_symbol, wrap_real(sc, x), real_zero);
+ if ((is_inf(y)) || (is_NaN(y))) /* here we can't return NAN so I guess we should signal an error */
+ wrong_type_error_nr(sc, sc->quotient_symbol, 2, wrap_real(sc, y), a_normal_real_string);
+ xf = x / y;
+ if (fabs(xf) > QUOTIENT_FLOAT_LIMIT)
+ sole_arg_out_of_range_error_nr(sc, sc->quotient_symbol, wrap_real(sc, xf), it_is_too_large_string);
+ return((xf > 0.0) ? (s7_int)floor(xf) : (s7_int)ceil(xf));
+}
+#endif
+
+static s7_int quotient_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 / i2);} /* i2 > 0 */
+
+static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+#if WITH_GMP
+ if ((is_real(x)) && (is_real(y)))
+ {
+ if (is_zero(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);
+ }
+ 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));
+ }
+ 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));
+#else
+
+ s7_int d1, d2, n1, n2;
+ if ((is_t_integer(x)) && (is_t_integer(y)))
+ return(make_integer(sc, quotient_i_7ii(sc, integer(x), integer(y))));
+
+ switch (type(x))
+ {
+ 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_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) */
+#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));
+ }
+#else
+ 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)));
+
+ 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);
+ /* 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));
+ }
+
+ default:
+ return(method_or_bust_pp(sc, x, sc->quotient_symbol, x, y, sc->type_names[T_REAL], 2));
+ }
+#endif
+}
+
+static s7_pointer quotient_p_pi(s7_scheme *sc, s7_pointer x, s7_int y)
+{
+ if ((is_t_integer(x)) && ((y > 0) || (y < -1))) return(make_integer(sc, integer(x) / y));
+ return(quotient_p_pp(sc, x, wrap_integer(sc, y)));
+}
+
+static s7_pointer g_quotient(s7_scheme *sc, s7_pointer args)
+{
+ #define H_quotient "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 3) = 1"
+ #define Q_quotient sc->pcl_r
+ /* sig was '(integer? ...) but quotient can return NaN */
+ /* (define (quo x1 x2) (truncate (/ x1 x2))) ; slib */
+ return(quotient_p_pp(sc, car(args), cadr(args)));
+}
+
+
+/* -------------------------------- remainder -------------------------------- */
+#if WITH_GMP
+static s7_pointer big_mod_or_rem(s7_scheme *sc, s7_pointer x, s7_pointer y, bool use_floor)
+{
+ 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_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_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));
+ 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);
+ return(mpq_to_canonicalized_rational(sc, sc->mpq_1));
+ }
+ return(method_or_bust_pp(sc, (is_real(x)) ? y : x, (use_floor) ? sc->modulo_symbol : sc->remainder_symbol, x, y, sc->type_names[T_REAL], (is_real(x)) ? 2 : 1));
+}
+#endif
+
+#define REMAINDER_FLOAT_LIMIT 1e13
+
+static inline s7_int remainder_i_7ii(s7_scheme *sc, s7_int x, s7_int y)
+{
+ if ((y > 1) || (y < -1)) return(x % y); /* avoid floating exception if (remainder -9223372036854775808 -1)! */
+ if (y == 0)
+ division_by_zero_error_2_nr(sc, sc->remainder_symbol, wrap_integer(sc, x), int_zero);
+ return(0);
+}
+
+static s7_double c_rem_dbl(s7_scheme *sc, s7_double x, s7_double y)
+{
+ s7_int quo;
+ s7_double pre_quo;
+ if ((is_inf(y)) || (is_NaN(y)))
+ return(NAN);
+ pre_quo = x / y;
+ if (fabs(pre_quo) > REMAINDER_FLOAT_LIMIT)
+ sole_arg_out_of_range_error_nr(sc, sc->remainder_symbol, set_elist_2(sc, wrap_real(sc, x), wrap_real(sc, y)), it_is_too_large_string);
+ quo = (pre_quo > 0.0) ? (s7_int)floor(pre_quo) : (s7_int)ceil(pre_quo);
+ return(x - (y * quo));
+}
+
+static s7_int remainder_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 % i2);} /* i2 > 1 */
+static s7_double remainder_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2)
+{
+ if (x2 == 0.0)
+ division_by_zero_error_2_nr(sc, sc->remainder_symbol, wrap_real(sc, x1), real_zero);
+ if ((is_inf(x1)) || (is_NaN(x1))) /* match remainder_p_pp */
+ return(NAN);
+ return(c_rem_dbl(sc, x1, x2));
+}
+
+static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+#if WITH_GMP
+ if (is_zero(y))
+ division_by_zero_error_2_nr(sc, sc->remainder_symbol, x, y);
+ return(big_mod_or_rem(sc, x, y, false));
+#else
+ s7_int quo, d1, d2, n1, n2;
+ s7_double pre_quo;
+
+ if ((is_t_integer(x)) && (is_t_integer(y)))
+ return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y))));
+
+ switch (type(x))
+ {
+ 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_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
+ {
+#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;
+#else
+ quo = (n1 * d2) / (n2 * d1);
+#endif
+ }}
+ 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));
+ }}
+#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));
+ }
+
+ 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);
+ }
+ 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));
+ }
+
+ default:
+ return(method_or_bust_pp(sc, x, sc->remainder_symbol, x, y, sc->type_names[T_REAL], 1));
+ }
+#endif
+}
+
+static s7_pointer remainder_p_pi(s7_scheme *sc, s7_pointer x, s7_int y)
+{
+ if ((is_t_integer(x)) && ((y > 1) || (y < -1))) return(make_integer(sc, integer(x) % y));
+ return(remainder_p_pp(sc, x, wrap_integer(sc, y)));
+}
+
+static s7_pointer g_remainder(s7_scheme *sc, s7_pointer args)
+{
+ #define H_remainder "(remainder x1 x2) returns the remainder of x1/x2; (remainder 10 3) = 1"
+ #define Q_remainder sc->pcl_r
+ /* (define (rem x1 x2) (- x1 (* x2 (quo x1 x2)))) ; slib, if x2 is an integer (- x1 (truncate x1 x2)), fractional part: (remainder x 1) */
+
+ s7_pointer x = car(args), y = cadr(args);
+ if ((is_t_integer(x)) && (is_t_integer(y)))
+ return(make_integer(sc, remainder_i_7ii(sc, integer(x), integer(y))));
+ return(remainder_p_pp(sc, x, y));
+}
+
+
+/* -------------------------------- modulo -------------------------------- */
+static s7_int modulo_i_ii(s7_int x, s7_int y)
+{
+ s7_int z;
+ if (y > 1)
+ {
+ z = x % y;
+ return((z >= 0) ? z : z + y);
+ }
+ if (y < -1)
+ {
+ z = x % y;
+ return((z > 0) ? z + y : z);
+ }
+ if (y == 0) return(x); /* else arithmetic exception */
+ return(0);
+}
+
+static s7_int modulo_i_ii_unchecked(s7_int i1, s7_int i2) /* here we know i2 > 1 */
+{
+ s7_int z = i1 % i2;
+ return((z < 0) ? (z + i2) : z);
+}
+
+static s7_double modulo_d_7dd(s7_scheme *sc, s7_double x1, s7_double x2)
+{
+ s7_double c;
+ if ((is_NaN(x1)) || (is_NaN(x2)) || (is_inf(x1)) || (is_inf(x2))) return(NAN);
+ if (x2 == 0.0) return(x1);
+ if (fabs(x1) > 1e17)
+ out_of_range_error_nr(sc, sc->modulo_symbol, int_one, wrap_real(sc, x1), it_is_too_large_string);
+ 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);
+ return(x1 - x2 * (s7_int)floor(c));
+}
+
+static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+#if WITH_GMP
+ /* as tricky as expt, so just use bignums; mpz_mod|_ui = mpz_fdiv_r_ui, but sign ignored -- probably not worth the code
+ * originally subtract_p_pp(sc, x, multiply_p_pp(sc, y, floor_p_p(sc, divide_p_pp(sc, x, y))))
+ * quotient is truncate_p_p(sc, divide_p_pp(sc, x, y))
+ * remainder is subtract_p_pp(sc, x, multiply_p_pp(sc, y, quotient_p_pp(sc, x, y)))
+ */
+ if (!is_zero(y)) return(big_mod_or_rem(sc, x, y, true));
+ if (is_real(x)) return(x);
+ return(method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 1));
+#else
+ s7_double a, b;
+ s7_int n1, n2, d1, d2;
+
+ switch (type(x))
+ {
+ 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_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:
+#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));
+ }}}
+#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));
+ }
+
+ 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));
+ }}
+
+ default:
+ return(method_or_bust_pp(sc, x, sc->modulo_symbol, x, y, sc->type_names[T_REAL], 1));
+ }
+#endif
+}
+
+static s7_pointer modulo_p_pi(s7_scheme *sc, s7_pointer x, s7_int y)
+{
+ if (is_t_integer(x)) return(make_integer(sc, modulo_i_ii(integer(x), y)));
+ return(modulo_p_pp(sc, x, wrap_integer(sc, y)));
+}
+
+static s7_pointer g_modulo(s7_scheme *sc, s7_pointer args)
+{
+ #define H_modulo "(modulo x1 x2) returns x1 mod x2; (modulo 4 3) = 1. The arguments can be real numbers."
+ #define Q_modulo sc->pcl_r
+ /* (define (mod x1 x2) (- x1 (* x2 (floor (/ x1 x2))))) from slib
+ * (mod x 0) = x according to "Concrete Mathematics"
+ */
+ return(modulo_p_pp(sc, car(args), cadr(args)));
+}
+
+
+/* ---------------------------------------- max ---------------------------------------- */
+static bool is_real_via_method_1(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer f = find_method_with_let(sc, p, sc->is_real_symbol);
+ if (f != sc->undefined)
+ return(is_true(sc, s7_apply_function(sc, f, set_plist_1(sc, p))));
+ return(false);
+}
+
+#define is_real_via_method(sc, p) ((is_real(p)) || ((has_active_methods(sc, p)) && (is_real_via_method_1(sc, p))))
+
+#define max_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->max_symbol, X, Y, sc->type_names[T_REAL], 1)
+#define max_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->max_symbol, X, Y, sc->type_names[T_REAL], 2)
+
+static s7_pointer max_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ /* same basic code as lt_b_7_pp (or any relop) but max returns NaN if NaN encountered, and methods for < and max return
+ * different results, so it seems simpler to repeat the other code.
+ */
+ if (type(x) == type(y))
+ {
+ if (is_t_integer(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);
+ if (is_t_ratio(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);
+ if (is_t_big_ratio(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); /* ?? */
+#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);
+#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));
+ }
+ 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);
+#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_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);
+#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));
+ }
+ 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_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_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));
+ }
+#endif
+ default:
+ return(max_out_x(sc, x, y));
+ }
+ return(x);
+}
+
+static s7_pointer g_max(s7_scheme *sc, s7_pointer args)
+{
+ #define H_max "(max ...) returns the maximum of its arguments"
+ #define Q_max sc->pcl_r
+
+ s7_pointer x = car(args);
+ if (is_null(cdr(args)))
+ {
+ if (is_real(x)) return(x);
+ return(method_or_bust_p(sc, x, sc->max_symbol, sc->type_names[T_REAL]));
+ }
+ for (s7_pointer p = cdr(args); is_pair(p); p = cdr(p))
+ x = max_p_pp(sc, x, car(p));
+ return(x);
+}
+
+static s7_pointer g_max_2(s7_scheme *sc, s7_pointer args) {return(max_p_pp(sc, car(args), cadr(args)));}
+static s7_pointer g_max_3(s7_scheme *sc, s7_pointer args) {return(max_p_pp(sc, max_p_pp(sc, car(args), cadr(args)), caddr(args)));}
+
+static s7_pointer max_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ return((args == 2) ? sc->max_2 : ((args == 3) ? sc->max_3 : f));
+}
+
+static s7_int max_i_ii(s7_int i1, s7_int i2) {return((i1 > i2) ? i1 : i2);}
+static s7_int max_i_iii(s7_int i1, s7_int i2, s7_int i3) {return((i1 > i2) ? ((i1 > i3) ? i1 : i3) : ((i2 > i3) ? i2 : i3));}
+static s7_double max_d_dd(s7_double x1, s7_double x2) {return(((x1 > x2) || (is_NaN(x1))) ? x1 : x2);}
+static s7_double max_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(max_d_dd(x1, max_d_dd(x2, x3)));}
+static s7_double max_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(max_d_dd(x1, max_d_ddd(x2, x3, x4)));}
+
+
+/* ---------------------------------------- min ---------------------------------------- */
+#define min_out_x(Sc, X, Y) method_or_bust_pp(Sc, X, Sc->min_symbol, X, Y, sc->type_names[T_REAL], 1)
+#define min_out_y(Sc, X, Y) method_or_bust_pp(Sc, Y, Sc->min_symbol, X, Y, sc->type_names[T_REAL], 2)
+
+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);
+ 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);
+ if (is_t_ratio(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);
+ if (is_t_big_ratio(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); /* ?? */
+#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);
+#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));
+ }
+ 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);
+#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_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);
+#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));
+ }
+ 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_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_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));
+ }
+#endif
+ default:
+ return(min_out_x(sc, x, y));
+ }
+ return(x);
+}
+
+static s7_pointer g_min(s7_scheme *sc, s7_pointer args)
+{
+ #define H_min "(min ...) returns the minimum of its arguments"
+ #define Q_min sc->pcl_r
+
+ s7_pointer x = car(args);
+ if (is_null(cdr(args)))
+ {
+ if (is_real(x)) return(x);
+ return(method_or_bust_p(sc, x, sc->min_symbol, sc->type_names[T_REAL]));
+ }
+ for (s7_pointer p = cdr(args); is_pair(p); p = cdr(p))
+ x = min_p_pp(sc, x, car(p));
+ return(x);
+}
+
+static s7_pointer g_min_2(s7_scheme *sc, s7_pointer args) {return(min_p_pp(sc, car(args), cadr(args)));}
+static s7_pointer g_min_3(s7_scheme *sc, s7_pointer args) {return(min_p_pp(sc, min_p_pp(sc, car(args), cadr(args)), caddr(args)));}
+
+static s7_pointer min_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ return((args == 2) ? sc->min_2 : ((args == 3) ? sc->min_3 : f));
+}
+
+static s7_int min_i_ii(s7_int i1, s7_int i2) {return((i1 < i2) ? i1 : i2);}
+static s7_int min_i_iii(s7_int i1, s7_int i2, s7_int i3) {return((i1 < i2) ? ((i1 < i3) ? i1 : i3) : ((i2 < i3) ? i2 : i3));}
+static s7_double min_d_dd(s7_double x1, s7_double x2) {return(((x1 < x2) || (is_NaN(x1))) ? x1 : x2);}
+static s7_double min_d_ddd(s7_double x1, s7_double x2, s7_double x3) {return(min_d_dd(x1, min_d_dd(x2, x3)));}
+static s7_double min_d_dddd(s7_double x1, s7_double x2, s7_double x3, s7_double x4) {return(min_d_dd(x1, min_d_ddd(x2, x3, x4)));}
+
+
+/* ---------------------------------------- = ---------------------------------------- */
+static bool eq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ if (has_active_methods(sc, x))
+ return(find_and_apply_method(sc, x, sc->num_eq_symbol, set_plist_2(sc, x, y)) != sc->F);
+ wrong_type_error_nr(sc, sc->num_eq_symbol, 1, x, a_number_string);
+ return(false);
+}
+
+static bool eq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ if (has_active_methods(sc, y))
+ return(find_and_apply_method(sc, y, sc->num_eq_symbol, set_plist_2(sc, x, y)) != sc->F);
+ wrong_type_error_nr(sc, sc->num_eq_symbol, 2, y, a_number_string);
+ return(false);
+}
+
+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));
+ if (is_t_real(x))
+ return(real(x) == real(y));
+ if (is_t_complex(x))
+ 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)));
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ 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)));
+ if (is_t_big_real(x))
+ 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);
+ }
+#endif
+ }
+
+ switch (type(x))
+ {
+ case T_INTEGER:
+ switch (type(y))
+ {
+ 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 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));
+ }
+ 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);
+#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));
+ }
+ 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);
+#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));
+ }
+ 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);
+ }
+#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_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_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_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));
+ }
+#endif
+ default: return(eq_out_x(sc, x, y));
+ }
+ return(false);
+}
+
+static bool is_number_via_method(s7_scheme *sc, s7_pointer p)
+{
+ if (is_number(p))
+ return(true);
+ if (has_active_methods(sc, 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(false);
+}
+
+static s7_pointer g_num_eq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_num_eq "(= z1 ...) returns #t if all its arguments are equal"
+ #define Q_num_eq s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_number_symbol)
+
+ s7_pointer x = car(args), p = cdr(args);
+ if (is_null(cdr(p)))
+ return(make_boolean(sc, num_eq_b_7pp(sc, x, car(p))));
+
+ 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);
+ }
+ return(sc->T);
+}
+
+static bool num_eq_b_ii(s7_int i1, s7_int i2) {return(i1 == i2);}
+static bool num_eq_b_dd(s7_double i1, s7_double i2) {return(i1 == i2);}
+
+static s7_pointer num_eq_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 == x2));}
+static s7_pointer num_eq_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 == x2));}
+static s7_pointer num_eq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, num_eq_b_7pp(sc, x, y)));}
+
+static s7_pointer num_eq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2)
+{
+ if (is_t_integer(p1))
+ return(make_boolean(sc, integer(p1) == p2));
+ if (is_t_real(p1))
+ return(make_boolean(sc, real(p1) == p2));
+#if WITH_GMP
+ if (is_t_big_integer(p1))
+ return(make_boolean(sc, (mpz_fits_slong_p(big_integer(p1))) && (p2 == mpz_get_si(big_integer(p1)))));
+ if (is_t_big_real(p1))
+ return(make_boolean(sc, mpfr_cmp_si(big_real(p1), p2) == 0));
+#endif
+ if (is_number(p1))
+ return(sc->F); /* complex/ratio can't == int */
+ if (has_active_methods(sc, p1))
+ return(find_and_apply_method(sc, p1, sc->num_eq_symbol, set_plist_2(sc, p1, make_integer(sc, p2))));
+ wrong_type_error_nr(sc, sc->num_eq_symbol, 1, p1, a_number_string);
+#ifdef __TINYC__
+ return(sc->F);
+#endif
+}
+
+static bool num_eq_b_pi(s7_scheme *sc, s7_pointer x, s7_int y)
+{
+ if (is_t_integer(x))
+ return(integer(x) == y);
+ if (is_t_real(x))
+ return(real(x) == y);
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ return((mpz_fits_slong_p(big_integer(x))) && (y == mpz_get_si(big_integer(x))));
+ if (is_t_big_real(x))
+ return(mpfr_cmp_si(big_real(x), y) == 0);
+#endif
+ if (!is_number(x)) /* complex/ratio can't == int */
+ wrong_type_error_nr(sc, sc->num_eq_symbol, 1, x, a_number_string);
+ return(false);
+}
+
+static s7_pointer g_num_eq_2(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer x = car(args), y = cadr(args);
+ if ((is_t_integer(x)) && (is_t_integer(y))) /* this is by far the most common case (ratios aren't used much, and = with floats is frowned upon) */
+ return(make_boolean(sc, integer(x) == integer(y)));
+ return(make_boolean(sc, num_eq_b_7pp(sc, x, y)));
+}
+
+static inline s7_pointer num_eq_xx(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ if (is_t_integer(x))
+ return(make_boolean(sc, integer(x) == integer(y)));
+ if (is_t_real(x))
+ return(make_boolean(sc, real(x) == integer(y)));
+ if (!is_number(x))
+ return(make_boolean(sc, eq_out_x(sc, x, y)));
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ return(make_boolean(sc, mpz_cmp_si(big_integer(x), integer(y)) == 0));
+ if (is_t_big_real(x))
+ {
+ if (mpfr_nan_p(big_real(x))) return(sc->F);
+ return(make_boolean(sc, mpfr_cmp_si(big_real(x), integer(y)) == 0));
+ }
+ if (is_t_big_ratio(x))
+ return(make_boolean(sc, mpq_cmp_si(big_ratio(x), integer(y), 1) == 0));
+#endif
+ return(sc->F);
+}
+
+static s7_pointer g_num_eq_xi(s7_scheme *sc, s7_pointer args) {return(num_eq_xx(sc, car(args), cadr(args)));}
+static s7_pointer g_num_eq_ix(s7_scheme *sc, s7_pointer args) {return(num_eq_xx(sc, cadr(args), car(args)));}
+
+static s7_pointer num_eq_chooser(s7_scheme *sc, s7_pointer ur_f, int32_t args, s7_pointer expr)
+{
+ if (args != 2) return(ur_f);
+ if (is_t_integer(caddr(expr)))
+ return(sc->num_eq_xi);
+ return((is_t_integer(cadr(expr))) ? sc->num_eq_ix : sc->num_eq_2);
+}
+
+
+/* ---------------------------------------- < ---------------------------------------- */
+static bool lt_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ if (has_active_methods(sc, x))
+ return(find_and_apply_method(sc, x, sc->lt_symbol, list_2(sc, x, y)) != sc->F); /* not plist */
+ wrong_type_error_nr(sc, sc->lt_symbol, 1, x, sc->type_names[T_REAL]);
+ return(false);
+}
+
+static bool lt_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ if (has_active_methods(sc, y))
+ return(find_and_apply_method(sc, y, sc->lt_symbol, list_2(sc, x, y)) != sc->F);
+ wrong_type_error_nr(sc, sc->lt_symbol, 2, y, sc->type_names[T_REAL]);
+ return(false);
+}
+
+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));
+ if (is_t_real(x))
+ return(real(x) < real(y));
+ if (is_t_ratio(x))
+ return(fraction(x) < fraction(y));
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ 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);
+ if (is_t_big_real(x))
+ 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));
+#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);
+#endif
+ 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));
+#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_REAL:
+ switch (type(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));
+ }
+ 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_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_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));
+ }
+#endif
+ default: return(lt_out_x(sc, x, y));
+ }
+ return(true);
+}
+
+static s7_pointer g_less(s7_scheme *sc, s7_pointer args)
+{
+ #define H_less "(< x1 ...) returns #t if its arguments are in increasing order"
+ #define Q_less s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
+
+ s7_pointer x = car(args), p = cdr(args);
+ if (is_null(cdr(p)))
+ return(make_boolean(sc, lt_b_7pp(sc, x, car(p))));
+
+ 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);
+ }
+ x = car(p);
+ }
+ return(sc->T);
+}
+
+static bool ratio_lt_pi(s7_pointer x, s7_int y)
+{
+ if ((y >= 0) && (numerator(x) < 0))
+ return(true);
+ if ((y <= 0) && (numerator(x) > 0))
+ return(false);
+ if (denominator(x) < S7_INT32_MAX)
+ return(numerator(x) < (y * denominator(x)));
+ return(fraction(x) < y);
+}
+
+static s7_pointer g_less_x0(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer x = car(args);
+ if (is_t_integer(x))
+ return(make_boolean(sc, integer(x) < 0));
+ if (is_small_real(x))
+ return(make_boolean(sc, is_negative(sc, x)));
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ return(make_boolean(sc, mpz_cmp_si(big_integer(x), 0) < 0));
+ if (is_t_big_real(x))
+ return(make_boolean(sc, mpfr_cmp_si(big_real(x), 0) < 0));
+ if (is_t_big_ratio(x))
+ return(make_boolean(sc, mpq_cmp_si(big_ratio(x), 0, 1) < 0));
+#endif
+ return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1));
+}
+
+static s7_pointer g_less_xi(s7_scheme *sc, s7_pointer args)
+{
+ s7_int y = integer(cadr(args));
+ s7_pointer x = car(args);
+
+ if (is_t_integer(x))
+ return(make_boolean(sc, integer(x) < y));
+ if (is_t_real(x))
+ return(make_boolean(sc, real(x) < y));
+ if (is_t_ratio(x))
+ return(make_boolean(sc, ratio_lt_pi(x, y)));
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) < 0));
+ if (is_t_big_real(x))
+ return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) < 0));
+ if (is_t_big_ratio(x))
+ return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) < 0));
+#endif
+ return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1));
+}
+
+static s7_pointer g_less_xf(s7_scheme *sc, s7_pointer args)
+{
+ s7_double y = real(cadr(args)); /* chooser below checks is_t_real(y) */
+ s7_pointer x = car(args);
+
+ if (is_t_real(x))
+ return(make_boolean(sc, real(x) < y));
+ if (is_t_integer(x))
+ return(make_boolean(sc, integer(x) < y));
+ if (is_t_ratio(x))
+ return(make_boolean(sc, fraction(x) < y));
+#if WITH_GMP
+ if (is_t_big_real(x))
+ return(make_boolean(sc, mpfr_cmp_d(big_real(x), y) < 0));
+ if (is_t_big_integer(x))
+ {
+ mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
+ return(make_boolean(sc, mpfr_cmp_z(sc->mpfr_1, big_integer(x)) > 0));
+ }
+ if (is_t_big_ratio(x))
+ {
+ mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
+ return(make_boolean(sc, mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) > 0));
+ }
+#endif
+ return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1));
+}
+
+static inline s7_pointer lt_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(make_boolean(sc, lt_b_7pp(sc, p1, p2)));}
+static bool lt_b_ii(s7_int i1, s7_int i2) {return(i1 < i2);}
+static bool lt_b_dd(s7_double i1, s7_double i2) {return(i1 < i2);}
+static s7_pointer lt_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 < x2));}
+static s7_pointer lt_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 < x2));}
+
+static bool lt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2)
+{
+ if (is_t_integer(p1)) return(integer(p1) < p2);
+ if (is_t_real(p1)) return(real(p1) < p2);
+ if (is_t_ratio(p1)) return(ratio_lt_pi(p1, p2));
+#if WITH_GMP
+ if (is_t_big_integer(p1))
+ return(mpz_cmp_si(big_integer(p1), p2) < 0);
+ if (is_t_big_real(p1))
+ return(mpfr_cmp_si(big_real(p1), p2) < 0);
+ if (is_t_big_ratio(p1))
+ return(mpq_cmp_si(big_ratio(p1), p2, 1) < 0);
+#endif
+ return(lt_out_x(sc, p1, make_integer(sc, p2)));
+}
+
+static s7_pointer g_less_2(s7_scheme *sc, s7_pointer args) {return(lt_p_pp(sc, car(args), cadr(args)));}
+static s7_pointer lt_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, lt_b_pi(sc, p1, p2)));}
+
+static s7_pointer less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ s7_pointer arg2;
+ if (args != 2) return(f);
+ arg2 = caddr(expr);
+ if (is_t_integer(arg2))
+ {
+ if (integer(arg2) == 0)
+ return(sc->less_x0);
+ if ((integer(arg2) < S7_INT32_MAX) && (integer(arg2) > S7_INT32_MIN))
+ return(sc->less_xi);
+ }
+ if (is_t_real(arg2))
+ return(sc->less_xf);
+ return(sc->less_2);
+}
+
+
+/* ---------------------------------------- <= ---------------------------------------- */
+static bool leq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ if (has_active_methods(sc, x))
+ return(find_and_apply_method(sc, x, sc->leq_symbol, list_2(sc, x, y)) != sc->F); /* not plist */
+ wrong_type_error_nr(sc, sc->leq_symbol, 1, x, sc->type_names[T_REAL]);
+ return(false);
+}
+
+static bool leq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ if (has_active_methods(sc, y))
+ return(find_and_apply_method(sc, y, sc->leq_symbol, list_2(sc, x, y)) != sc->F);
+ wrong_type_error_nr(sc, sc->leq_symbol, 2, y, sc->type_names[T_REAL]);
+ return(false);
+}
+
+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));
+ if (is_t_real(x))
+ return(real(x) <= real(y));
+ if (is_t_ratio(x))
+ return(fraction(x) <= fraction(y));
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ 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);
+ if (is_t_big_real(x))
+ 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));
+#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));
+#endif
+ 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));
+#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_REAL:
+ switch (type(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));
+ }
+ 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_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_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));
+ }
+#endif
+ default: return(leq_out_x(sc, x, y));
+ }
+ return(true);
+}
+
+static s7_pointer g_less_or_equal(s7_scheme *sc, s7_pointer args)
+{
+ #define H_less_or_equal "(<= x1 ...) returns #t if its arguments are in non-decreasing order"
+ #define Q_less_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
+
+ s7_pointer x = car(args), p = cdr(args);
+
+ if (is_null(cdr(p)))
+ return(make_boolean(sc, leq_b_7pp(sc, x, car(p))));
+
+ 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);
+ }
+ return(sc->T);
+}
+
+static inline s7_pointer leq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(make_boolean(sc, leq_b_7pp(sc, p1, p2)));}
+static bool leq_b_ii(s7_int i1, s7_int i2) {return(i1 <= i2);}
+static bool leq_b_dd(s7_double i1, s7_double i2) {return(i1 <= i2);}
+static s7_pointer leq_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 <= x2));}
+static s7_pointer leq_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 <= x2));}
+
+static bool ratio_leq_pi(s7_pointer x, s7_int y)
+{
+ if ((y >= 0) && (numerator(x) <= 0))
+ return(true);
+ if ((y <= 0) && (numerator(x) > 0))
+ return(false);
+ if (denominator(x) < S7_INT32_MAX)
+ return(numerator(x) <= (y * denominator(x)));
+ return(fraction(x) <= y);
+}
+
+static s7_pointer g_leq_xi(s7_scheme *sc, s7_pointer args)
+{
+ s7_int y = integer(cadr(args));
+ s7_pointer x = car(args);
+
+ if (is_t_integer(x))
+ return(make_boolean(sc, integer(x) <= y));
+ if (is_t_real(x))
+ return(make_boolean(sc, real(x) <= y));
+ if (is_t_ratio(x))
+ return(make_boolean(sc, ratio_leq_pi(x, y)));
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) <= 0));
+ if (is_t_big_real(x))
+ {
+ if (mpfr_nan_p(big_real(x))) return(sc->F);
+ return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) <= 0));
+ }
+ if (is_t_big_ratio(x))
+ return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) <= 0));
+#endif
+ return(method_or_bust(sc, x, sc->leq_symbol, args, sc->type_names[T_REAL], 1));
+}
+
+static bool leq_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2)
+{
+ if (is_t_integer(p1)) return(integer(p1) <= p2);
+ if (is_t_real(p1)) return(real(p1) <= p2);
+ if (is_t_ratio(p1)) return(ratio_leq_pi(p1, p2));
+#if WITH_GMP
+ if (is_t_big_integer(p1))
+ return(mpz_cmp_si(big_integer(p1), p2) <= 0);
+ if (is_t_big_real(p1))
+ return(mpfr_cmp_si(big_real(p1), p2) <= 0);
+ if (is_t_big_ratio(p1))
+ return(mpq_cmp_si(big_ratio(p1), p2, 1) <= 0);
+#endif
+ if (has_active_methods(sc, p1))
+ return(find_and_apply_method(sc, p1, sc->leq_symbol, list_2(sc, p1, make_integer(sc, p2)))); /* not plist */
+ wrong_type_error_nr(sc, sc->leq_symbol, 1, p1, sc->type_names[T_REAL]);
+#ifdef __TINYC__
+ return(false);
+#endif
+}
+
+static s7_pointer leq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, leq_b_pi(sc, p1, p2)));}
+static s7_pointer g_leq_2(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, leq_b_7pp(sc, car(args), cadr(args))));}
+static s7_pointer g_leq_ixx(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p = cdr(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_t_integer(cadr(p)))
+ return((integer(car(p)) > integer(cadr(p))) ? sc->F : sc->T);
+ }
+ return(g_less_or_equal(sc, args));
+}
+
+static s7_pointer leq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ s7_pointer arg2;
+ if (args == 2)
+ {
+ 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_2);
+ }
+ if ((args == 3) && (is_t_integer(cadr(expr))))
+ return(sc->leq_ixx);
+ return(f);
+}
+
+
+/* ---------------------------------------- > ---------------------------------------- */
+static bool gt_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ if (has_active_methods(sc, x))
+ return(find_and_apply_method(sc, x, sc->gt_symbol, list_2(sc, x, y)) != sc->F); /* not plist */
+ wrong_type_error_nr(sc, sc->gt_symbol, 1, x, sc->type_names[T_REAL]);
+ return(false);
+}
+
+static bool gt_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ if (has_active_methods(sc, y))
+ return(find_and_apply_method(sc, y, sc->gt_symbol, list_2(sc, x, y)) != sc->F);
+ wrong_type_error_nr(sc, sc->gt_symbol, 2, y, sc->type_names[T_REAL]);
+ return(false);
+}
+
+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));
+ if (is_t_real(x))
+ return(real(x) > real(y));
+ if (is_t_ratio(x))
+ return(fraction(x) > fraction(y));
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ 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);
+ if (is_t_big_real(x))
+ 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));
+#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);
+#endif
+ 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));
+#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_REAL:
+ switch (type(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));
+ }
+ 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_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_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));
+ }
+#endif
+ default: return(gt_out_x(sc, x, y));
+ }
+ return(true);
+}
+
+static s7_pointer g_greater(s7_scheme *sc, s7_pointer args)
+{
+ #define H_greater "(> x1 ...) returns #t if its arguments are in decreasing order"
+ #define Q_greater s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
+
+ s7_pointer x = car(args), p = cdr(args);
+
+ if (is_null(cdr(p)))
+ return(make_boolean(sc, gt_b_7pp(sc, x, car(p))));
+
+ 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);
+ }
+ return(sc->T);
+}
+
+static s7_pointer g_greater_xi(s7_scheme *sc, s7_pointer args)
+{
+ s7_int y = integer(cadr(args));
+ s7_pointer x = car(args);
+
+ if (is_t_integer(x))
+ return(make_boolean(sc, integer(x) > y));
+ if (is_t_real(x))
+ return(make_boolean(sc, real(x) > y));
+ if (is_t_ratio(x))
+ return(make_boolean(sc, !ratio_leq_pi(x, y)));
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) > 0));
+ if (is_t_big_real(x))
+ return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) > 0));
+ if (is_t_big_ratio(x))
+ return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) > 0));
+#endif
+ return(method_or_bust(sc, x, sc->gt_symbol, args, a_number_string, 1));
+}
+
+static s7_pointer g_greater_xf(s7_scheme *sc, s7_pointer args)
+{
+ s7_double y = real(cadr(args));
+ s7_pointer x = car(args);
+
+ if (is_t_real(x))
+ return(make_boolean(sc, real(x) > y));
+
+ switch (type(x))
+ {
+ case T_INTEGER: return(make_boolean(sc, integer(x) > y));
+
+ 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, fraction(x) > y));
+
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
+ return(make_boolean(sc, mpfr_cmp_z(sc->mpfr_1, big_integer(x)) < 0));
+ case T_BIG_RATIO:
+ mpfr_set_d(sc->mpfr_1, y, MPFR_RNDN);
+ return(make_boolean(sc, mpfr_cmp_q(sc->mpfr_1, big_ratio(x)) < 0));
+ case T_BIG_REAL:
+ return(make_boolean(sc, mpfr_cmp_d(big_real(x), y) > 0));
+#endif
+ default:
+ return(method_or_bust(sc, x, sc->gt_symbol, args, a_number_string, 1));
+ }
+ return(sc->T);
+}
+
+static inline s7_pointer gt_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(make_boolean(sc, gt_b_7pp(sc, p1, p2)));}
+static bool gt_b_ii(s7_int i1, s7_int i2) {return(i1 > i2);}
+static bool gt_b_dd(s7_double i1, s7_double i2) {return(i1 > i2);}
+static s7_pointer gt_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 > x2));}
+static s7_pointer gt_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 > x2));}
+
+static bool gt_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2)
+{
+ if (is_t_integer(p1)) return(integer(p1) > p2);
+ if (is_t_real(p1)) return(real(p1) > p2);
+ if (is_t_ratio(p1)) return(!ratio_leq_pi(p1, p2));
+#if WITH_GMP
+ if (is_t_big_integer(p1))
+ return(mpz_cmp_si(big_integer(p1), p2) > 0);
+ if (is_t_big_real(p1))
+ return(mpfr_cmp_si(big_real(p1), p2) > 0);
+ if (is_t_big_ratio(p1))
+ return(mpq_cmp_si(big_ratio(p1), p2, 1) > 0);
+#endif
+ return(gt_out_x(sc, p1, make_integer(sc, p2)));
+}
+
+static s7_pointer gt_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, gt_b_pi(sc, p1, p2)));}
+
+static s7_pointer g_greater_2(s7_scheme *sc, s7_pointer args)
+{
+ /* ridiculous repetition, but overheads are killing this poor thing */
+ s7_pointer x = car(args), y = cadr(args);
+ if (type(x) == type(y))
+ {
+ if (is_t_integer(x)) return(make_boolean(sc, integer(x) > integer(y)));
+ if (is_t_real(x)) return(make_boolean(sc, real(x) > real(y)));
+ if (is_t_ratio(x)) return(make_boolean(sc, fraction(x) > fraction(y)));
+ }
+ switch (type(x))
+ {
+ 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)));
+#if WITH_GMP
+ 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)));
+ }
+ 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)));
+#if WITH_GMP
+ 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)));
+ }
+ break;
+#if WITH_GMP
+ 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_x(sc, x, y)));
+ }
+ return(sc->T);
+}
+
+static s7_pointer greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ s7_pointer arg2;
+ if (args != 2) return(f);
+ arg2 = caddr(expr);
+ if ((is_t_integer(arg2)) && (integer(arg2) < S7_INT32_MAX) && (integer(arg2) > S7_INT32_MIN))
+ return(sc->greater_xi);
+ if ((is_t_real(arg2)) && (real(arg2) < S7_INT32_MAX) && (real(arg2) > S7_INT32_MIN))
+ return(sc->greater_xf);
+ return(sc->greater_2);
+}
+
+
+/* ---------------------------------------- >= ---------------------------------------- */
+static bool geq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ if (!has_active_methods(sc, x))
+ wrong_type_error_nr(sc, sc->geq_symbol, 1, x, sc->type_names[T_REAL]);
+ return(find_and_apply_method(sc, x, sc->geq_symbol, list_2(sc, x, y)) != sc->F); /* not plist */
+}
+
+static bool geq_out_y(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ if (!has_active_methods(sc, y))
+ wrong_type_error_nr(sc, sc->geq_symbol, 2, y, sc->type_names[T_REAL]);
+ return(find_and_apply_method(sc, y, sc->geq_symbol, list_2(sc, x, y)) != sc->F); /* not plist */
+}
+
+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));
+ if (is_t_real(x))
+ return(real(x) >= real(y));
+ if (is_t_ratio(x))
+ return(fraction(x) >= fraction(y));
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ 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);
+ if (is_t_big_real(x))
+ 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));
+#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));
+#endif
+ 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));
+#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_REAL:
+ switch (type(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));
+ }
+ 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_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_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));
+ }
+#endif
+ default: return(geq_out_x(sc, x, y));
+ }
+ return(true);
+}
+
+static s7_pointer g_greater_or_equal(s7_scheme *sc, s7_pointer args)
+{
+ #define H_greater_or_equal "(>= x1 ...) returns #t if its arguments are in non-increasing order"
+ #define Q_greater_or_equal s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_real_symbol)
+
+ s7_pointer x = car(args), p = cdr(args);
+ if (is_null(cdr(p)))
+ return(make_boolean(sc, geq_b_7pp(sc, x, car(p))));
+
+ 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);
+ }
+ return(sc->T);
+}
+
+static inline s7_pointer geq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(make_boolean(sc, geq_b_7pp(sc, p1, p2)));}
+static bool geq_b_ii(s7_int i1, s7_int i2) {return(i1 >= i2);}
+static bool geq_b_dd(s7_double i1, s7_double i2) {return(i1 >= i2);}
+static s7_pointer geq_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_boolean(sc, x1 >= x2));}
+static s7_pointer geq_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_boolean(sc, x1 >= x2));}
+
+static s7_pointer g_geq_2(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, geq_b_7pp(sc, car(args), cadr(args))));}
+
+static s7_pointer g_geq_xf(s7_scheme *sc, s7_pointer args)
+{
+ s7_double y = real(cadr(args));
+ s7_pointer x = car(args);
+ return(make_boolean(sc, ((is_t_real(x)) ? (real(x) >= y) : geq_b_7pp(sc, car(args), cadr(args)))));
+}
+
+static s7_pointer g_geq_xi(s7_scheme *sc, s7_pointer args)
+{
+ s7_int y = integer(cadr(args));
+ s7_pointer x = car(args);
+
+ if (is_t_integer(x))
+ return(make_boolean(sc, integer(x) >= y));
+ if (is_t_real(x))
+ return(make_boolean(sc, real(x) >= y));
+ if (is_t_ratio(x))
+ return(make_boolean(sc, !ratio_lt_pi(x, y)));
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ return(make_boolean(sc, mpz_cmp_si(big_integer(x), y) >= 0));
+ if (is_t_big_real(x))
+ {
+ if (mpfr_nan_p(big_real(x))) return(sc->F);
+ return(make_boolean(sc, mpfr_cmp_si(big_real(x), y) >= 0));
+ }
+ if (is_t_big_ratio(x))
+ return(make_boolean(sc, mpq_cmp_si(big_ratio(x), y, 1) >= 0));
+#endif
+ return(method_or_bust(sc, x, sc->geq_symbol, args, sc->type_names[T_REAL], 1));
+}
+
+static bool geq_b_pi(s7_scheme *sc, s7_pointer p1, s7_int p2)
+{
+ if (is_t_integer(p1)) return(integer(p1) >= p2);
+ if (is_t_real(p1)) return(real(p1) >= p2);
+ if (is_t_ratio(p1)) return(!ratio_lt_pi(p1, p2));
+#if WITH_GMP
+ if (is_t_big_integer(p1))
+ return(mpz_cmp_si(big_integer(p1), p2) >= 0);
+ if (is_t_big_real(p1))
+ return((!mpfr_nan_p(big_real(p1))) && (mpfr_cmp_si(big_real(p1), p2) >= 0));
+ if (is_t_big_ratio(p1))
+ return(mpq_cmp_si(big_ratio(p1), p2, 1) >= 0);
+#endif
+ if (!has_active_methods(sc, p1))
+ wrong_type_error_nr(sc, sc->geq_symbol, 1, p1, sc->type_names[T_REAL]);
+ return(find_and_apply_method(sc, p1, sc->geq_symbol, list_2(sc, p1, make_integer(sc, p2)))); /* not plist */
+}
+
+static s7_pointer geq_p_pi(s7_scheme *sc, s7_pointer p1, s7_int p2) {return(make_boolean(sc, geq_b_pi(sc, p1, p2)));}
+
+static s7_pointer geq_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ s7_pointer arg2;
+ if (args != 2) return(f);
+ arg2 = caddr(expr);
+ if ((is_t_integer(arg2)) && (integer(arg2) < S7_INT32_MAX) && (integer(arg2) > S7_INT32_MIN))
+ return(sc->geq_xi);
+ if ((is_t_real(arg2)) && (real(arg2) < S7_INT32_MAX) && (real(arg2) > S7_INT32_MIN))
+ return(sc->geq_xf);
+ return(sc->geq_2);
+}
+
+
+/* ---------------------------------------- real-part ---------------------------------------- */
+s7_double s7_real_part(s7_pointer x)
+{
+ switch(type(x))
+ {
+ case T_INTEGER: return((s7_double)integer(x));
+ case T_RATIO: return(fraction(x));
+ case T_REAL: return(real(x));
+ case T_COMPLEX: return(real_part(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)))));
+ 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
+ }
+ return(0.0);
+}
+
+static s7_double real_part_d_p(s7_pointer x)
+{
+ if (is_number(x)) return(s7_real_part(x));
+ sole_arg_wrong_type_error_nr(cur_sc, cur_sc->real_part_symbol, x, a_number_string);
+#ifdef __TINYC__
+ return(0.0);
+#endif
+}
+
+static s7_pointer real_part_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_complex(p)) return(make_real(sc, real_part(p)));
+ switch (type(p))
+ {
+ case T_INTEGER: case T_RATIO: case T_REAL:
+ return(p);
+#if WITH_GMP
+ case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL:
+ 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);
+ }
+#endif
+ default:
+ return(method_or_bust_p(sc, p, sc->real_part_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_real_part(s7_scheme *sc, s7_pointer args)
+{
+ #define H_real_part "(real-part num) returns the real part of num"
+ #define Q_real_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
+ return(real_part_p_p(sc, car(args)));
+}
+
+
+/* ---------------------------------------- imag-part ---------------------------------------- */
+s7_double s7_imag_part(s7_pointer x)
+{
+ if (is_t_complex(x))
+ return(imag_part(x));
+#if WITH_GMP
+ if (is_t_big_complex(x))
+ return((s7_double)mpfr_get_d(mpc_imagref(big_complex(x)), MPFR_RNDN));
+#endif
+ return(0.0);
+}
+
+static s7_double imag_part_d_p(s7_pointer x)
+{
+ if (is_number(x)) return(s7_imag_part(x));
+ sole_arg_wrong_type_error_nr(cur_sc, cur_sc->imag_part_symbol, x, a_number_string);
+#ifdef __TINYC__
+ return(0.0);
+#endif
+}
+
+static s7_pointer imag_part_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_complex(p)) return(make_real(sc, imag_part(p)));
+ switch (type(p))
+ {
+ case T_INTEGER: case T_RATIO:
+ return(int_zero);
+ case T_REAL:
+ return(real_zero);
+#if WITH_GMP
+ case T_BIG_INTEGER: case T_BIG_RATIO:
+ return(int_zero);
+ case T_BIG_REAL:
+ 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);
+ }
+#endif
+ default:
+ return(method_or_bust_p(sc, p, sc->imag_part_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_imag_part(s7_scheme *sc, s7_pointer args)
+{
+ #define H_imag_part "(imag-part num) returns the imaginary part of num"
+ #define Q_imag_part s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)
+ /* currently (imag-part +nan.0) -> 0.0 ? it's true but maybe confusing */
+ return(imag_part_p_p(sc, car(args)));
+}
+
+
+/* ---------------------------------------- numerator denominator ---------------------------------------- */
+static s7_int numerator_i_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_ratio(p)) return(numerator(p));
+ if (is_t_integer(p)) return(integer(p));
+#if WITH_GMP
+ if (is_t_big_ratio(p)) return(mpz_get_si(mpq_numref(big_ratio(p))));
+ if (is_t_big_integer(p)) return(mpz_get_si(big_integer(p)));
+#endif
+ return(integer(method_or_bust_p(sc, p, sc->numerator_symbol, a_rational_string)));
+}
+
+static s7_pointer g_numerator(s7_scheme *sc, s7_pointer args)
+{
+ #define H_numerator "(numerator rat) returns the numerator of the rational number rat"
+ #define Q_numerator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol)
+
+ s7_pointer x = car(args);
+ switch (type(x))
+ {
+ case T_RATIO: return(make_integer(sc, numerator(x)));
+ case T_INTEGER: return(x);
+#if WITH_GMP
+ case T_BIG_INTEGER: return(x);
+ case T_BIG_RATIO: return(mpz_to_integer(sc, mpq_numref(big_ratio(x))));
+#endif
+ default: return(method_or_bust_p(sc, x, sc->numerator_symbol, a_rational_string));
+ }
+}
+
+
+static s7_pointer g_denominator(s7_scheme *sc, s7_pointer args)
+{
+ #define H_denominator "(denominator rat) returns the denominator of the rational number rat"
+ #define Q_denominator s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_rational_symbol)
+
+ s7_pointer x = car(args);
+ switch (type(x))
+ {
+ case T_RATIO: return(make_integer(sc, denominator(x)));
+ case T_INTEGER: return(int_one);
+#if WITH_GMP
+ case T_BIG_INTEGER: return(int_one);
+ case T_BIG_RATIO: return(mpz_to_integer(sc, mpq_denref(big_ratio(x))));
+#endif
+ default: return(method_or_bust_p(sc, x, sc->denominator_symbol, a_rational_string));
+ }
+}
+
+static s7_int denominator_i_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_ratio(p)) return(denominator(p));
+ if (is_t_integer(p)) return(1);
+#if WITH_GMP
+ if (is_t_big_ratio(p)) return(mpz_get_si(mpq_denref(big_ratio(p))));
+ if (is_t_big_integer(p)) return(1);
+#endif
+ return(integer(method_or_bust_p(sc, p, sc->denominator_symbol, a_rational_string)));
+}
+
+
+/* ---------------------------------------- number? bignum? complex? integer? byte? rational? real? ---------------------------------------- */
+static s7_pointer g_is_number(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_number "(number? obj) returns #t if obj is a number"
+ #define Q_is_number sc->pl_bt
+ check_boolean_method(sc, is_number, sc->is_number_symbol, args);
+}
+
+bool s7_is_bignum(s7_pointer obj) {return(is_big_number(obj));}
+
+static s7_pointer g_is_bignum(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_bignum "(bignum? obj) returns #t if obj is a multiprecision number."
+ #define Q_is_bignum sc->pl_bt
+ return(make_boolean(sc, is_big_number(car(args))));
+}
+
+static s7_pointer g_is_integer(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_integer "(integer? obj) returns #t if obj is an integer"
+ #define Q_is_integer sc->pl_bt
+ check_boolean_method(sc, s7_is_integer, sc->is_integer_symbol, args);
+}
+
+static bool is_byte(s7_pointer p) {return((s7_is_integer(p)) && (s7_integer(p) >= 0) && (s7_integer(p) < 256));}
+static s7_pointer g_is_byte(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_byte "(byte? obj) returns #t if obj is a byte (an integer between 0 and 255)"
+ #define Q_is_byte sc->pl_bt
+ check_boolean_method(sc, is_byte, sc->is_byte_symbol, args);
+}
+
+static s7_pointer g_is_real(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_real "(real? obj) returns #t if obj is a real number"
+ #define Q_is_real sc->pl_bt
+ check_boolean_method(sc, is_real, sc->is_real_symbol, args);
+}
+
+static s7_pointer g_is_complex(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_complex "(complex? obj) returns #t if obj is a number"
+ #define Q_is_complex sc->pl_bt
+ check_boolean_method(sc, is_number, sc->is_complex_symbol, args);
+}
+
+static s7_pointer g_is_rational(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_rational "(rational? obj) returns #t if obj is a rational number (either an integer or a ratio)"
+ #define Q_is_rational sc->pl_bt
+ check_boolean_method(sc, is_rational, sc->is_rational_symbol, args);
+ /* in the non-gmp case, (rational? 455702434782048082459/86885567283849955830) -> #f, not #t, and similarly for exact? etc */
+}
+
+static s7_pointer g_is_float(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_float "(float? x) returns #t is x is real and not rational."
+ #define Q_is_float sc->pl_bt
+ s7_pointer p = car(args);
+#if WITH_GMP
+ return(make_boolean(sc, (is_t_real(p)) || (is_t_big_real(p)))); /* (float? pi) */
+#else
+ return(make_boolean(sc, is_t_real(p)));
+#endif
+}
+
+#if WITH_GMP
+static bool is_float_b(s7_pointer p) {return((is_t_real(p)) || (is_t_big_real(p)));}
+#else
+static bool is_float_b(s7_pointer p) {return(is_t_real(p));}
+#endif
+
+
+/* ---------------------------------------- nan? ---------------------------------------- */
+static bool is_nan_b_7p(s7_scheme *sc, s7_pointer x)
+{
+ if (is_t_real(x)) return(is_NaN(real(x)));
+ switch (type(x))
+ {
+ case T_INTEGER:
+ case T_RATIO: return(false);
+ /* case T_REAL: return(is_NaN(real(x))); */
+ case T_COMPLEX: return((is_NaN(real_part(x))) || (is_NaN(imag_part(x))));
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ case T_BIG_RATIO: return(false);
+ case T_BIG_REAL: return(mpfr_nan_p(big_real(x)) != 0);
+ case T_BIG_COMPLEX: return((mpfr_nan_p(mpc_realref(big_complex(x))) != 0) || (mpfr_nan_p(mpc_imagref(big_complex(x))) != 0));
+#endif
+ default:
+ if (is_number(x))
+ return(method_or_bust_p(sc, x, sc->is_nan_symbol, a_number_string) != sc->F);
+ }
+ return(false);
+}
+
+static s7_pointer g_is_nan(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_nan "(nan? obj) returns #t if obj is a NaN"
+ #define Q_is_nan sc->pl_bt
+ return(make_boolean(sc, is_nan_b_7p(sc, car(args))));
+}
+
+
+/* ---------------------------------------- infinite? ---------------------------------------- */
+static bool is_infinite_b_7p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER:
+ case T_RATIO: return(false);
+ case T_REAL: return(is_inf(real(x)));
+ case T_COMPLEX: return((is_inf(real_part(x))) || (is_inf(imag_part(x))));
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ case T_BIG_RATIO: return(false);
+ 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));
+#endif
+ default:
+ if (is_number(x))
+ return(method_or_bust_p(sc, x, sc->is_infinite_symbol, a_number_string) != sc->F);
+ }
+ return(false);
+}
+
+static s7_pointer g_is_infinite(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_infinite "(infinite? obj) returns #t if obj is an infinite real"
+ #define Q_is_infinite sc->pl_bt
+ return(make_boolean(sc, is_infinite_b_7p(sc, car(args))));
+}
+
+
+/* ---------------------------------------- even? odd?---------------------------------------- */
+static bool is_even_b_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_integer(p))
+ return((integer(p) & 1) == 0);
+#if WITH_GMP
+ if (is_t_big_integer(p))
+ return(mpz_even_p(big_integer(p)));
+#endif
+ return(method_or_bust_p(sc, p, sc->is_even_symbol, sc->type_names[T_INTEGER]) != sc->F);
+}
+
+static s7_pointer is_even_p_p(s7_scheme *sc, s7_pointer x)
+{
+ if (is_t_integer(x))
+ return(make_boolean(sc, (integer(x) & 1) == 0));
+ return(make_boolean(sc, is_even_b_7p(sc, x)));
+}
+
+static bool is_even_i(s7_int i1) {return((i1 & 1) == 0);}
+
+static s7_pointer g_is_even(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_even "(even? int) returns #t if the integer int32_t is even"
+ #define Q_is_even s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)
+ return(make_boolean(sc, is_even_b_7p(sc, car(args))));
+}
+
+
+static bool is_odd_b_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_integer(p))
+ return((integer(p) & 1) == 1);
+#if WITH_GMP
+ if (is_t_big_integer(p))
+ return(mpz_odd_p(big_integer(p)));
+#endif
+ return(method_or_bust_p(sc, p, sc->is_odd_symbol, sc->type_names[T_INTEGER]) != sc->F);
+}
+
+static s7_pointer is_odd_p_p(s7_scheme *sc, s7_pointer x)
+{
+ if (is_t_integer(x))
+ return(make_boolean(sc, (integer(x) & 1) == 1));
+ return(make_boolean(sc, is_odd_b_7p(sc, x)));
+}
+
+static bool is_odd_i(s7_int i1) {return((i1 & 1) == 1);}
+
+static s7_pointer g_is_odd(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_odd "(odd? int) returns #t if the integer int32_t is odd"
+ #define Q_is_odd s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)
+ return(make_boolean(sc, is_odd_b_7p(sc, car(args))));
+}
+
+
+/* ---------------------------------------- zero? ---------------------------------------- */
+static bool is_zero(s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER: return(integer(x) == 0);
+ case T_REAL: return(real(x) == 0.0);
+#if WITH_GMP
+ case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) == 0);
+ case T_BIG_REAL: return(mpfr_zero_p(big_real(x)));
+#endif
+ default:
+ return(false); /* ratios and complex numbers here are already collapsed into integers and reals */
+ }
+}
+
+static bool is_zero_b_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_integer(p)) return(integer(p) == 0);
+ if (is_t_real(p)) return(real(p) == 0.0);
+#if WITH_GMP
+ if (is_number(p)) return(is_zero(p));
+#else
+ if (is_number(p)) return(false);
+#endif
+ return(method_or_bust_p(sc, p, sc->is_zero_symbol, a_number_string) != sc->F);
+}
+
+static s7_pointer g_is_zero(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_zero "(zero? num) returns #t if the number num is zero"
+ #define Q_is_zero sc->pl_bn
+ return(make_boolean(sc, is_zero_b_7p(sc, car(args))));
+}
+
+static s7_pointer is_zero_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_zero_b_7p(sc, p)));}
+static bool is_zero_i(s7_int p) {return(p == 0);}
+static bool is_zero_d(s7_double p) {return(p == 0.0);}
+
+
+/* -------------------------------- positive? -------------------------------- */
+static bool is_positive(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER: return(integer(x) > 0);
+ case T_RATIO: return(numerator(x) > 0);
+ case T_REAL: return(real(x) > 0.0);
+#if WITH_GMP
+ case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) > 0);
+ case T_BIG_RATIO: return(mpq_cmp_ui(big_ratio(x), 0, 1) > 0);
+ case T_BIG_REAL: return(mpfr_cmp_ui(big_real(x), 0) > 0);
+#endif
+ default:
+ sole_arg_wrong_type_error_nr(sc, sc->is_positive_symbol, x, sc->type_names[T_REAL]);
+ }
+ return(false);
+}
+
+static bool is_positive_b_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_integer(p)) return(integer(p) > 0);
+ if (is_t_real(p)) return(real(p) > 0.0);
+#if WITH_GMP
+ if (is_number(p)) return(is_positive(sc, p));
+#else
+ if (is_t_ratio(p)) return(numerator(p) > 0);
+#endif
+ return(method_or_bust_p(sc, p, sc->is_positive_symbol, sc->type_names[T_REAL]) != sc->F);
+}
+
+static s7_pointer g_is_positive(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_positive "(positive? num) returns #t if the real number num is positive (greater than 0)"
+ #define Q_is_positive s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)
+ return(make_boolean(sc, is_positive_b_7p(sc, car(args))));
+}
+
+static s7_pointer is_positive_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_positive_b_7p(sc, p)));}
+static bool is_positive_i(s7_int p) {return(p > 0);}
+static bool is_positive_d(s7_double p) {return(p > 0.0);}
+
+
+/* -------------------------------- negative? -------------------------------- */
+static bool is_negative(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER: return(integer(x) < 0);
+ case T_RATIO: return(numerator(x) < 0);
+ case T_REAL: return(real(x) < 0.0);
+#if WITH_GMP
+ case T_BIG_INTEGER: return(mpz_cmp_ui(big_integer(x), 0) < 0);
+ case T_BIG_RATIO: return(mpq_cmp_ui(big_ratio(x), 0, 1) < 0);
+ case T_BIG_REAL: return(mpfr_cmp_ui(big_real(x), 0) < 0);
+#endif
+ default:
+ sole_arg_wrong_type_error_nr(sc, sc->is_negative_symbol, x, sc->type_names[T_REAL]);
+ }
+ return(false);
+}
+
+static bool is_negative_b_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_t_integer(p)) return(integer(p) < 0);
+ if (is_t_real(p)) return(real(p) < 0.0);
+#if WITH_GMP
+ if (is_number(p)) return(is_negative(sc, p));
+#else
+ if (is_t_ratio(p)) return(numerator(p) < 0);
+#endif
+ return(method_or_bust_p(sc, p, sc->is_negative_symbol, sc->type_names[T_REAL]) != sc->F);
+}
+
+static s7_pointer g_is_negative(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_negative "(negative? num) returns #t if the real number num is negative (less than 0)"
+ #define Q_is_negative s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)
+ return(make_boolean(sc, is_negative_b_7p(sc, car(args))));
+}
+
+static s7_pointer is_negative_p_p(s7_scheme *sc, s7_pointer p) {return(make_boolean(sc, is_negative_b_7p(sc, p)));}
+static bool is_negative_i(s7_int p) {return(p < 0);}
+static bool is_negative_d(s7_double p) {return(p < 0.0);}
+
+
+#if (!WITH_PURE_S7)
+/* ---------------------------------------- exact<->inexact exact? inexact? ---------------------------------------- */
+static s7_pointer exact_to_inexact_p_p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(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));
+#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));
+#endif
+ return(make_real(sc, (s7_double)(fraction(x))));
+
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ return(big_integer_to_big_real(sc, x));
+ case T_BIG_RATIO:
+ return(big_ratio_to_big_real(sc, x));
+#endif
+ case T_REAL: case T_BIG_REAL:
+ case T_COMPLEX: case T_BIG_COMPLEX:
+ return(x); /* apparently (exact->inexact 1+i) is not an error */
+ default:
+ return(method_or_bust_p(sc, x, sc->exact_to_inexact_symbol, a_number_string));
+ }
+}
+
+static s7_pointer g_exact_to_inexact(s7_scheme *sc, s7_pointer args)
+{
+ #define H_exact_to_inexact "(exact->inexact num) converts num to an inexact number; (exact->inexact 3/2) = 1.5"
+ #define Q_exact_to_inexact s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_number_symbol)
+ /* arg can be complex -> itself! */
+ return(exact_to_inexact_p_p(sc, car(args)));
+}
+
+static s7_pointer inexact_to_exact_p_p(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_INTEGER: case T_BIG_INTEGER:
+ case T_RATIO: case T_BIG_RATIO:
+ return(x);
+
+#if WITH_GMP
+ case T_BIG_REAL:
+ return(big_rationalize(sc, set_plist_1(sc, x)));
+#endif
+
+ 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);
+
+ 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 */
+#else
+ 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));
+ }
+
+ default:
+ return(method_or_bust_p(sc, x, sc->inexact_to_exact_symbol, sc->type_names[T_REAL]));
+ }
+ return(x);
+}
+
+static s7_pointer g_inexact_to_exact(s7_scheme *sc, s7_pointer args)
+{
+ #define H_inexact_to_exact "(inexact->exact num) converts num to an exact number; (inexact->exact 1.5) = 3/2"
+ #define Q_inexact_to_exact s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)
+ return(inexact_to_exact_p_p(sc, car(args)));
+}
+
+static s7_pointer g_is_exact(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_exact "(exact? num) returns #t if num is exact (an integer or a ratio)"
+ #define Q_is_exact sc->pl_bn
+
+ s7_pointer x = car(args);
+ switch (type(x))
+ {
+ case T_INTEGER: case T_BIG_INTEGER:
+ case T_RATIO: case T_BIG_RATIO:
+ return(sc->T);
+ case T_REAL: case T_BIG_REAL:
+ case T_COMPLEX: case T_BIG_COMPLEX:
+ return(sc->F);
+ default:
+ return(method_or_bust_p(sc, x, sc->is_exact_symbol, a_number_string));
+ }
+}
+
+static bool is_exact_b_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_number(p))
+ return(method_or_bust_p(sc, p, sc->is_exact_symbol, a_number_string) != sc->F);
+ return(is_rational(p));
+}
+
+
+static s7_pointer g_is_inexact(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_inexact "(inexact? num) returns #t if num is inexact (neither an integer nor a ratio)"
+ #define Q_is_inexact sc->pl_bn
+
+ s7_pointer x = car(args);
+ switch (type(x))
+ {
+ case T_INTEGER: case T_BIG_INTEGER:
+ case T_RATIO: case T_BIG_RATIO:
+ return(sc->F);
+ case T_REAL: case T_BIG_REAL:
+ case T_COMPLEX: case T_BIG_COMPLEX:
+ return(sc->T);
+ default:
+ return(method_or_bust_p(sc, x, sc->is_inexact_symbol, a_number_string));
+ }
+}
+
+static bool is_inexact_b_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_number(p))
+ return(method_or_bust_p(sc, p, sc->is_inexact_symbol, a_number_string) != sc->F);
+ return(!is_rational(p));
+}
+
+
+/* ---------------------------------------- integer-length ---------------------------------------- */
+static int32_t integer_length(s7_int a)
+{
+ if (a < 0)
+ {
+ if (a == S7_INT64_MIN) return(63);
+ a = -a;
+ }
+ if (a < 256LL) return(intlen_bits[a]); /* in gmp, sbcl and clisp (integer-length 0) is 0 */
+ if (a < 65536LL) return(8 + intlen_bits[a >> 8]);
+ if (a < 16777216LL) return(16 + intlen_bits[a >> 16]);
+ if (a < 4294967296LL) return(24 + intlen_bits[a >> 24]);
+ if (a < 1099511627776LL) return(32 + intlen_bits[a >> 32]);
+ if (a < 281474976710656LL) return(40 + intlen_bits[a >> 40]);
+ if (a < 72057594037927936LL) return(48 + intlen_bits[a >> 48]);
+ return(56 + intlen_bits[a >> 56]);
+}
+
+static s7_pointer g_integer_length(s7_scheme *sc, s7_pointer args)
+{
+ #define H_integer_length "(integer-length arg) returns the number of bits required to represent the integer 'arg': \
+(ceiling (log (if (< arg 0) (- arg) (+ arg 1)) 2))"
+ #define Q_integer_length sc->pcl_i
+
+ s7_pointer p = car(args);
+ if (is_t_integer(p))
+ {
+ s7_int x = integer(p);
+ return((x < 0) ? small_int(integer_length(-(x + 1))) : small_int(integer_length(x)));
+ }
+#if WITH_GMP
+ if (is_t_big_integer(p))
+ return(make_integer(sc, mpz_sizeinbase(big_integer(p), 2)));
+#endif
+ return(sole_arg_method_or_bust(sc, p, sc->integer_length_symbol, args, sc->type_names[T_INTEGER]));
+}
+
+static s7_int integer_length_i_i(s7_int x) {return((x < 0) ? integer_length(-(x + 1)) : integer_length(x));}
+#endif /* !pure s7 */
+
+
+/* ---------------------------------------- integer-decode-float ---------------------------------------- */
+static s7_pointer g_integer_decode_float(s7_scheme *sc, s7_pointer args)
+{
+ #define H_integer_decode_float "(integer-decode-float x) returns a list containing the significand, exponent, and \
+sign of 'x' (1 = positive, -1 = negative). (integer-decode-float 0.0): (0 0 1)"
+ #define Q_integer_decode_float s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_float_symbol)
+
+ decode_float_t num;
+ s7_pointer x = car(args);
+ if (is_t_real(x))
+ {
+ if (real(x) == 0.0)
+ 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));
+ }
+#if WITH_GMP
+ if (is_t_big_real(x))
+ {
+ mp_exp_t exp_n;
+ bool neg;
+ exp_n = mpfr_get_z_exp(sc->mpz_1, big_real(x));
+ neg = (mpz_cmp_ui(sc->mpz_1, 0) < 0);
+ if (neg) mpz_abs(sc->mpz_1, sc->mpz_1);
+ return(list_3(sc, mpz_to_integer(sc, sc->mpz_1), make_integer(sc, exp_n), (neg) ? minus_one : int_one));
+ /* not gmp: (integer-decode-float +nan.0): (6755399441055744 972 1), gmp: (integer-decode-float (bignum +nan.0)): (0 -1073741823 1) */
+ }
+#endif
+ return(method_or_bust_p(sc, x, sc->integer_decode_float_symbol, wrap_string(sc, "a non-rational real", 19)));
+}
+
+
+/* -------------------------------- logior -------------------------------- */
+#if WITH_GMP
+static s7_pointer big_logior(s7_scheme *sc, s7_int start, s7_pointer args)
+{
+ mpz_set_si(sc->mpz_1, start);
+ for (s7_pointer x = args; is_not_null(x); x = cdr(x))
+ {
+ 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)));
+ }}
+ return(mpz_to_integer(sc, sc->mpz_1));
+}
+#endif
+
+static s7_pointer g_logior(s7_scheme *sc, s7_pointer args)
+{
+ #define H_logior "(logior int32_t ...) returns the OR of its integer arguments (the bits that are on in any of the arguments)"
+ #define Q_logior sc->pcl_i
+
+ s7_int result = 0;
+ for (s7_pointer x = args; is_not_null(x); x = cdr(x))
+ {
+#if WITH_GMP
+ if (is_t_big_integer(car(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)));
+ result |= integer(car(x));
+ }
+ return(make_integer(sc, result));
+}
+
+static s7_int logior_i_ii(s7_int i1, s7_int i2) {return(i1 | i2);}
+static s7_int logior_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 | i2 | i3);}
+
+
+/* -------------------------------- logxor -------------------------------- */
+#if WITH_GMP
+static s7_pointer big_logxor(s7_scheme *sc, s7_int start, s7_pointer args)
+{
+ mpz_set_si(sc->mpz_1, start);
+ for (s7_pointer x = args; is_not_null(x); x = cdr(x))
+ {
+ 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)));
+ }}
+ return(mpz_to_integer(sc, sc->mpz_1));
+}
+#endif
+
+static s7_pointer g_logxor(s7_scheme *sc, s7_pointer args)
+{
+ #define H_logxor "(logxor int32_t ...) returns the XOR of its integer arguments (the bits that are on in an odd number of the arguments)"
+ #define Q_logxor sc->pcl_i
+
+ s7_int result = 0;
+ for (s7_pointer x = args; is_not_null(x); x = cdr(x))
+ {
+#if WITH_GMP
+ if (is_t_big_integer(car(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)));
+ result ^= integer(car(x));
+ }
+ return(make_integer(sc, result));
+}
+
+static s7_int logxor_i_ii(s7_int i1, s7_int i2) {return(i1 ^ i2);}
+static s7_int logxor_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 ^ i2 ^ i3);}
+
+
+/* -------------------------------- logand -------------------------------- */
+#if WITH_GMP
+static s7_pointer big_logand(s7_scheme *sc, s7_int start, s7_pointer args)
+{
+ mpz_set_si(sc->mpz_1, start);
+ for (s7_pointer x = args; is_not_null(x); x = cdr(x))
+ {
+ 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)));
+ }}
+ return(mpz_to_integer(sc, sc->mpz_1));
+}
+#endif
+
+static s7_pointer g_logand(s7_scheme *sc, s7_pointer args)
+{
+ #define H_logand "(logand int32_t ...) returns the AND of its integer arguments (the bits that are on in every argument)"
+ #define Q_logand sc->pcl_i
+
+ s7_int result = -1;
+ for (s7_pointer x = args; is_not_null(x); x = cdr(x))
+ {
+#if WITH_GMP
+ if (is_t_big_integer(car(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)));
+ result &= integer(car(x));
+ }
+ return(make_integer(sc, result));
+}
+
+static s7_int logand_i_ii(s7_int i1, s7_int i2) {return(i1 & i2);}
+static s7_int logand_i_iii(s7_int i1, s7_int i2, s7_int i3) {return(i1 & i2 & i3);}
+
+
+/* -------------------------------- lognot -------------------------------- */
+static s7_pointer g_lognot(s7_scheme *sc, s7_pointer args)
+{
+ #define H_lognot "(lognot num) returns the negation of num (its complement, the bits that are not on): (lognot 0) -> -1"
+ #define Q_lognot sc->pcl_i
+
+ s7_pointer x = car(args);
+ if (is_t_integer(x))
+ return(make_integer(sc, ~integer(x)));
+
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ {
+ mpz_com(sc->mpz_1, big_integer(x));
+ return(mpz_to_integer(sc, sc->mpz_1));
+ }
+#endif
+ return(sole_arg_method_or_bust(sc, x, sc->lognot_symbol, args, sc->type_names[T_INTEGER]));
+}
+
+static s7_int lognot_i_i(s7_int i1) {return(~i1);}
+
+
+/* -------------------------------- logbit? -------------------------------- */
+/* logbit? CL is (logbitp index int) using 2^index, but that order strikes me as backwards
+ * at least gmp got the arg order right!
+ */
+
+static s7_pointer g_logbit(s7_scheme *sc, s7_pointer args)
+{
+ #define H_logbit "(logbit? int index) returns #t if the index-th bit is on in int, otherwise #f. The argument \
+order here follows gmp, and is the opposite of the CL convention. (logbit? int bit) is the same as (not (zero? (logand int (ash 1 bit))))."
+ #define Q_logbit s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_integer_symbol)
+
+ s7_pointer x = car(args), y = cadr(args);
+ s7_int index; /* index in gmp is mp_bitcnt which is an unsigned long int */
+
+ if (!s7_is_integer(x))
+ return(method_or_bust(sc, x, sc->logbit_symbol, args, sc->type_names[T_INTEGER], 1));
+ if (!s7_is_integer(y))
+ return(method_or_bust(sc, y, sc->logbit_symbol, args, sc->type_names[T_INTEGER], 2));
+
+ index = s7_integer_clamped_if_gmp(sc, y);
+ if (index < 0)
+ out_of_range_error_nr(sc, sc->logbit_symbol, int_two, y, it_is_negative_string);
+
+#if WITH_GMP
+ if (is_t_big_integer(x))
+ return(make_boolean(sc, (mpz_tstbit(big_integer(x), index) != 0)));
+#endif
+
+ if (index >= S7_INT_BITS) /* not sure about the >: (logbit? -1 64) ?? */
+ return(make_boolean(sc, integer(x) < 0));
+ /* (zero? (logand most-positive-fixnum (ash 1 63))) -> ash argument 2, 63, is out of range (shift is too large)
+ * so logbit? has a wider range than the logand/ash shuffle above.
+ */
+
+ /* all these int64_ts are necessary, else C turns it into an int, gets confused about signs etc */
+ return(make_boolean(sc, ((((int64_t)(1LL << (int64_t)index)) & (int64_t)integer(x)) != 0)));
+}
+
+static bool logbit_b_7ii(s7_scheme *sc, s7_int i1, s7_int i2)
+{
+ if (i2 < 0)
+ {
+ out_of_range_error_nr(sc, sc->logbit_symbol, int_two, wrap_integer(sc, i1), it_is_negative_string);
+ return(false);
+ }
+ if (i2 >= S7_INT_BITS) return(i1 < 0);
+ return((((int64_t)(1LL << (int64_t)i2)) & (int64_t)i1) != 0);
+}
+
+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(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
+ return(g_logbit(sc, set_plist_2(sc, p1, p2)));
+#else
+ return(method_or_bust(sc, p1, sc->logbit_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_INTEGER], 1) != sc->F);
+#endif
+}
+
+
+/* -------------------------------- ash -------------------------------- */
+static s7_int c_ash(s7_scheme *sc, s7_int arg1, s7_int arg2)
+{
+ if (arg1 == 0) return(0);
+ if (arg2 >= S7_INT_BITS)
+ {
+ if ((arg1 == -1) && (arg2 == 63)) /* (ash -1 63): most-negative-fixnum */
+ 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)
+ return((arg1 < 0) ? -1 : 0); /* (ash -31 -100) */
+
+ /* I can't see any point in protecting this: (ash 9223372036854775807 1) -> -2, but anyone using ash must know something about bits */
+ if (arg2 < 0)
+ return(arg1 >> -arg2);
+ if (arg1 < 0)
+ {
+ uint64_t z = (uint64_t)arg1;
+ return((s7_int)(z << arg2));
+ }
+ return(arg1 << arg2);
+}
+
+static s7_pointer g_ash(s7_scheme *sc, s7_pointer args)
+{
+ #define H_ash "(ash i1 i2) returns i1 shifted right or left i2 times, i1 << i2, (ash 1 3) -> 8, (ash 8 -3) -> 1"
+ #define Q_ash sc->pcl_i
+
+#if WITH_GMP
+ /* here, as in expt, there are cases like (ash 1 63) which need to be handled as bignums */
+ s7_pointer p0 = car(args), p1 = cadr(args);
+
+ /* here, as in expt, there are cases like (ash 1 63) which need to be bignums so there's no easy way to tell when it's safe to drop into g_ash instead */
+ if ((s7_is_integer(p0)) && /* this includes bignum ints... */
+ (s7_is_integer(p1)))
+ {
+ s7_int shift;
+ bool p0_is_big = is_big_number(p0);
+ int32_t p0_compared_to_zero = 0;
+
+ if (p0_is_big)
+ 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 (p0_compared_to_zero == 0)
+ 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));
+ }
+ else
+ {
+ 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 */
+
+ if (is_t_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);
+ else
+ 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));
+ }
+ /* else fall through */
+#endif
+ s7_pointer x = car(args), y = cadr(args);
+
+ if (!s7_is_integer(x))
+ return(method_or_bust(sc, x, sc->ash_symbol, args, sc->type_names[T_INTEGER], 1));
+ if (!s7_is_integer(y))
+ return(method_or_bust(sc, y, sc->ash_symbol, args, sc->type_names[T_INTEGER], 2));
+ return(make_integer(sc, c_ash(sc, s7_integer_clamped_if_gmp(sc, x), s7_integer_clamped_if_gmp(sc, y))));
+}
+
+#if (!WITH_GMP)
+ static s7_int ash_i_7ii(s7_scheme *sc, s7_int i1, s7_int i2) {return(c_ash(sc, i1, i2));}
+#endif
+static s7_int lsh_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 << i2);} /* this may need gmp special handling, and out-of-range as in c_ash */
+static s7_int rsh_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 >> (-i2));}
+static s7_int rsh_i_i2_direct(s7_int i1, s7_int unused_i2) {return(i1 >> 1);}
+
+
+/* -------------------------------- random-state -------------------------------- */
+/* random numbers. The simple version used in clm.c is probably adequate, but here I'll use Marsaglia's MWC algorithm.
+ * (random num) -> a number (0..num), if num == 0 return 0, use global default state
+ * (random num state) -> same but use this state
+ * (random-state seed) -> make a new state
+ * to save the current seed, use copy, to save it across load, random-state->list and list->random-state.
+ * random-state? returns #t if its arg is one of these guys
+ */
+
+static s7_pointer random_state_copy(s7_scheme *sc, s7_pointer args)
+{
+#if WITH_GMP
+ return(sc->F); /* I can't find a way to copy a gmp random generator */
+#else
+ s7_pointer new_r, obj = car(args);
+ if (!is_random_state(obj)) return(sc->F);
+ new_cell(sc, new_r, T_RANDOM_STATE);
+ random_seed(new_r) = random_seed(obj);
+ random_carry(new_r) = random_carry(obj);
+ return(new_r);
+#endif
+}
+
+s7_pointer s7_random_state(s7_scheme *sc, s7_pointer args)
+{
+ #define H_random_state "(random-state seed (carry plausible-default)) returns a new random number state initialized with 'seed'. \
+Pass this as the second argument to 'random' to get a repeatable random number sequence:\n\
+ (let ((seed (random-state 1234))) (random 1.0 seed))"
+ #define Q_random_state s7_make_circular_signature(sc, 1, 2, sc->is_random_state_symbol, sc->is_integer_symbol)
+
+#if WITH_GMP
+ s7_pointer r, seed;
+ if (is_null(args))
+ return(sc->F); /* how to find current state, if any? */
+
+ seed = car(args);
+ if (!s7_is_integer(seed))
+ return(sole_arg_method_or_bust(sc, seed, sc->random_state_symbol, args, sc->type_names[T_INTEGER]));
+
+ if (is_t_integer(seed))
+ seed = s7_int_to_big_integer(sc, integer(seed));
+
+ new_cell(sc, r, T_RANDOM_STATE);
+ gmp_randinit_default(random_gmp_state(r)); /* Mersenne twister */
+ gmp_randseed(random_gmp_state(r), big_integer(seed)); /* this is ridiculously slow! */
+ add_big_random_state(sc, r);
+ return(r);
+#else
+ s7_pointer r1, r2, p;
+ s7_int i1, i2;
+ if (is_null(args))
+ return(sc->default_random_state);
+
+ r1 = car(args);
+ if (!s7_is_integer(r1))
+ return(method_or_bust(sc, r1, sc->random_state_symbol, args, sc->type_names[T_INTEGER], 1));
+ i1 = integer(r1);
+ if (i1 < 0)
+ out_of_range_error_nr(sc, sc->random_state_symbol, int_one, r1, it_is_negative_string);
+ if (is_null(cdr(args)))
+ {
+ new_cell(sc, p, T_RANDOM_STATE);
+ random_seed(p) = (uint64_t)i1;
+ random_carry(p) = 1675393560; /* should this be dependent on the seed? */
+ return(p);
+ }
+
+ r2 = cadr(args);
+ if (!s7_is_integer(r2))
+ return(method_or_bust(sc, r2, sc->random_state_symbol, args, sc->type_names[T_INTEGER], 2));
+ i2 = integer(r2);
+ if (i2 < 0)
+ out_of_range_error_nr(sc, sc->random_state_symbol, int_two, r2, it_is_negative_string);
+
+ new_cell(sc, p, T_RANDOM_STATE);
+ random_seed(p) = (uint64_t)i1;
+ random_carry(p) = (uint64_t)i2;
+ return(p);
+#endif
+}
+
+#define g_random_state s7_random_state
+
+static s7_pointer random_state_getter(s7_scheme *sc, s7_pointer r, s7_int loc)
+{
+#if (!WITH_GMP)
+ if (loc == 0) return(make_integer(sc, random_seed(r)));
+ if (loc == 1) return(make_integer(sc, random_carry(r)));
+#endif
+ return(sc->F);
+}
+
+static s7_pointer random_state_setter(s7_scheme *sc, s7_pointer r, s7_int loc, s7_pointer val)
+{
+#if (!WITH_GMP)
+ if (is_t_integer(val))
+ {
+ s7_int i = s7_integer_clamped_if_gmp(sc, val);
+ if (loc == 0) random_seed(r) = i;
+ if (loc == 1) random_carry(r) = i;
+ }
+#endif
+ return(sc->F);
+}
+
+
+/* -------------------------------- random-state? -------------------------------- */
+static s7_pointer g_is_random_state(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_random_state "(random-state? obj) returns #t if obj is a random-state object (from random-state)."
+ #define Q_is_random_state sc->pl_bt
+ check_boolean_method(sc, is_random_state, sc->is_random_state_symbol, args);
+}
+
+bool s7_is_random_state(s7_pointer p) {return(type(p) == T_RANDOM_STATE);}
+
+
+/* -------------------------------- random-state->list -------------------------------- */
+s7_pointer s7_random_state_to_list(s7_scheme *sc, s7_pointer args)
+{
+ #define H_random_state_to_list "(random-state->list r) returns the random state object as a list.\
+You can later apply random-state to this list to continue a random number sequence from any point."
+ #define Q_random_state_to_list s7_make_signature(sc, 2, (WITH_GMP) ? sc->is_list_symbol : sc->is_pair_symbol, sc->is_random_state_symbol)
+
+#if WITH_GMP
+ if ((is_pair(args)) &&
+ (!is_random_state(car(args))))
+ return(method_or_bust(sc, car(args), sc->random_state_to_list_symbol, args, a_random_state_object_string, 1));
+ return(sc->nil);
+#else
+ s7_pointer r = (is_null(args)) ? sc->default_random_state : car(args);
+ if (!is_random_state(r))
+ return(method_or_bust(sc, r, sc->random_state_to_list_symbol, args, a_random_state_object_string, 1));
+ return(list_2(sc, make_integer(sc, random_seed(r)), make_integer_unchecked(sc, random_carry(r))));
+#endif
+}
+
+#define g_random_state_to_list s7_random_state_to_list
+
+void s7_set_default_random_state(s7_scheme *sc, s7_int seed, s7_int carry)
+{
+#if (!WITH_GMP)
+ s7_pointer p;
+ new_cell(sc, p, T_RANDOM_STATE);
+ random_seed(p) = (uint64_t)seed;
+ random_carry(p) = (uint64_t)carry;
+ sc->default_random_state = p;
+#endif
+}
+
+
+/* -------------------------------- random -------------------------------- */
+#if WITH_GMP
+static double next_random(s7_scheme *sc)
+#else
+static double next_random(s7_pointer r)
+#endif
+{
+#if (!WITH_GMP)
+ /* The multiply-with-carry generator for 32-bit integers:
+ * x(n)=a*x(n-1) + carry mod 2^32
+ * Choose multiplier a from this list:
+ * 1791398085 1929682203 1683268614 1965537969 1675393560 1967773755 1517746329 1447497129 1655692410 1606218150
+ * 2051013963 1075433238 1557985959 1781943330 1893513180 1631296680 2131995753 2083801278 1873196400 1554115554
+ * ( or any 'a' for which both a*2^32-1 and a*2^31-1 are prime)
+ */
+ #define RAN_MULT 2131995753UL
+
+ double result;
+ uint64_t temp = random_seed(r) * RAN_MULT + random_carry(r);
+ random_seed(r) = (temp & 0xffffffffUL);
+ random_carry(r) = (temp >> 32);
+ result = (double)((uint32_t)(random_seed(r))) / 4294967295.5;
+ /* divisor was 2^32-1 = 4294967295.0, but somehow this can round up once in a billion tries?
+ * do we want the double just less than 2^32?
+ * can the multiply-add+logand above return 0? I'm getting 0's from (random (expt 2 62))
+ */
+
+ /* (let ((mx 0) (mn 1000)) (do ((i 0 (+ i 1))) ((= i 10000)) (let ((val (random 123))) (set! mx (max mx val)) (set! mn (min mn val)))) (list mn mx)) */
+ return(result);
+#else
+ mpfr_urandomb(sc->mpfr_1, random_gmp_state(sc->default_random_state));
+ return(mpfr_get_d(sc->mpfr_1, MPFR_RNDN));
+#endif
+}
+
+static s7_pointer g_random(s7_scheme *sc, s7_pointer args)
+{
+ #define H_random "(random num (state #f)) returns a random number of the same type as num between zero and num, equalling num only if num is zero"
+ #define Q_random s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_random_state_symbol)
+ s7_pointer r, num;
+
+ /* if we disallow (random 0) the programmer has to protect every call on random with (if (eqv? x 0) 0 (random x)). If
+ * we claim we're using a half-open interval, then we should also disallow (random 0.0); otherwise the following
+ * must be true: (let* ((x 0.0) (y (random x))) (and (>= y 0.0) (< y x))). The definition above is consistent
+ * with (random 0) -> 0, simpler to use in practice, and certainly no worse than (/ 0 0) -> 1.
+ */
+ if (is_null(cdr(args)))
+ r = sc->default_random_state;
+ else
+ {
+ r = cadr(args);
+ if (!is_random_state(r))
+ return(method_or_bust(sc, r, sc->random_symbol, args, a_random_state_object_string, 2));
+ }
+ num = car(args);
+ switch (type(num))
+ {
+#if (!WITH_GMP)
+ case T_INTEGER:
+ 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));
+ }
+ case T_REAL:
+ return(make_real(sc, real(num) * next_random(r)));
+ case T_COMPLEX:
+ return(make_complex(sc, real_part(num) * next_random(r), imag_part(num) * next_random(r)));
+#else
+ case T_INTEGER:
+ if (integer(num) == 0) return(int_zero);
+ mpz_set_si(sc->mpz_1, integer(num));
+ mpz_urandomm(sc->mpz_1, random_gmp_state(r), sc->mpz_1);
+ if (integer(num) < 0) mpz_neg(sc->mpz_1, sc->mpz_1);
+ return(make_integer(sc, mpz_get_si(sc->mpz_1)));
+ case T_BIG_INTEGER:
+ if (mpz_cmp_si(big_integer(num), 0) == 0) return(int_zero);
+ 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);
+ return(mpz_to_integer(sc, sc->mpz_1));
+ case T_RATIO:
+ mpfr_urandomb(sc->mpfr_1, random_gmp_state(r));
+ mpq_set_si(sc->mpq_1, numerator(num), denominator(num));
+ mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, sc->mpq_1, MPFR_RNDN);
+ mpfr_mul_d(sc->mpfr_2, sc->mpfr_1, sc->default_rationalize_error, MPFR_RNDN);
+ return(big_rationalize(sc, set_plist_2(sc, mpfr_to_big_real(sc, sc->mpfr_1), mpfr_to_big_real(sc, sc->mpfr_2))));
+ case T_BIG_RATIO:
+ mpfr_urandomb(sc->mpfr_1, random_gmp_state(r));
+ mpfr_mul_q(sc->mpfr_1, sc->mpfr_1, big_ratio(num), MPFR_RNDN);
+ mpfr_mul_d(sc->mpfr_2, sc->mpfr_1, sc->default_rationalize_error, MPFR_RNDN);
+ return(big_rationalize(sc, set_plist_2(sc, mpfr_to_big_real(sc, sc->mpfr_1), mpfr_to_big_real(sc, sc->mpfr_2))));
+ case T_REAL:
+ mpfr_urandomb(sc->mpfr_1, random_gmp_state(r));
+ mpfr_mul_d(sc->mpfr_1, sc->mpfr_1, real(num), MPFR_RNDN);
+ return(make_real(sc, mpfr_get_d(sc->mpfr_1, MPFR_RNDN)));
+ case T_BIG_REAL:
+ mpfr_urandomb(sc->mpfr_1, random_gmp_state(r));
+ mpfr_mul(sc->mpfr_1, sc->mpfr_1, big_real(num), MPFR_RNDN);
+ return(mpfr_to_big_real(sc, sc->mpfr_1));
+ case T_COMPLEX:
+ mpc_urandom(sc->mpc_1, random_gmp_state(r));
+ mpfr_mul_d(mpc_realref(sc->mpc_1), mpc_realref(sc->mpc_1), real_part(num), MPFR_RNDN);
+ mpfr_mul_d(mpc_imagref(sc->mpc_1), mpc_imagref(sc->mpc_1), imag_part(num), MPFR_RNDN);
+ return(make_complex(sc, mpfr_get_d(mpc_realref(sc->mpc_1), MPFR_RNDN), mpfr_get_d(mpc_imagref(sc->mpc_1), MPFR_RNDN)));
+ case T_BIG_COMPLEX:
+ mpc_urandom(sc->mpc_1, random_gmp_state(r));
+ mpfr_mul(mpc_realref(sc->mpc_1), mpc_realref(sc->mpc_1), mpc_realref(big_complex(num)), MPFR_RNDN);
+ mpfr_mul(mpc_imagref(sc->mpc_1), mpc_imagref(sc->mpc_1), mpc_imagref(big_complex(num)), MPFR_RNDN);
+ return(mpc_to_number(sc, sc->mpc_1));
+#endif
+ default:
+ return(method_or_bust(sc, num, sc->random_symbol, args, a_number_string, 1));
+ }
+ return(sc->F);
+}
+
+s7_double s7_random(s7_scheme *sc, s7_pointer state)
+{
+#if WITH_GMP
+ mpfr_set_ui(sc->mpfr_1, 1, MPFR_RNDN);
+ mpfr_urandomb(sc->mpfr_1, random_gmp_state((state) ? state : sc->default_random_state));
+ return((s7_double)mpfr_get_d(sc->mpfr_1, MPFR_RNDN));
+#else
+ return(next_random((state) ? state : sc->default_random_state));
+#endif
+}
+
+static s7_double random_d_7d(s7_scheme *sc, s7_double x)
+{
+#if WITH_GMP
+ return(real(g_random(sc, set_plist_1(sc, wrap_real(sc, x)))));
+#else
+ return(x * next_random(sc->default_random_state));
+#endif
+}
+
+static s7_int random_i_7i(s7_scheme *sc, s7_int i)
+{
+#if WITH_GMP
+ return(integer(g_random(sc, set_plist_1(sc, wrap_integer(sc, i)))));
+#else
+ return((s7_int)(i * next_random(sc->default_random_state)));
+#endif
+}
+
+static s7_pointer g_random_i(s7_scheme *sc, s7_pointer args)
+{
+#if WITH_GMP
+ return(g_random(sc, args));
+#else
+ return(make_integer(sc, (s7_int)(integer(car(args)) * next_random(sc->default_random_state))));
+#endif
+}
+
+static s7_pointer g_random_f(s7_scheme *sc, s7_pointer args)
+{
+#if WITH_GMP
+ return(g_random(sc, args));
+#else
+ return(make_real(sc, real(car(args)) * next_random(sc->default_random_state)));
+#endif
+}
+
+static s7_pointer g_random_1(s7_scheme *sc, s7_pointer args)
+{
+#if (!WITH_GMP)
+ s7_pointer num = car(args), r = sc->default_random_state;
+ if (is_t_integer(num))
+ return(make_integer(sc, (s7_int)(integer(num) * next_random(r))));
+ if (is_t_real(num))
+ return(make_real(sc, real(num) * next_random(r)));
+#endif
+ return(g_random(sc, args));
+}
+
+static s7_pointer random_p_p(s7_scheme *sc, s7_pointer num)
+{
+#if (!WITH_GMP)
+ if (is_t_integer(num))
+ return(make_integer(sc, (s7_int)(integer(num) * next_random(sc->default_random_state))));
+ if (is_t_real(num))
+ return(make_real(sc, real(num) * next_random(sc->default_random_state)));
+#endif
+ return(g_random(sc, set_plist_1(sc, num)));
+}
+
+static s7_pointer random_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if (args == 1)
+ {
+ s7_pointer arg1 = cadr(expr);
+ if (is_t_integer(arg1))
+ return(sc->random_i);
+ return((is_t_real(arg1)) ? sc->random_f : sc->random_1);
+ }
+ return(f);
+}
+
+static s7_pointer g_add_i_random(s7_scheme *sc, s7_pointer args)
+{
+#if WITH_GMP
+ return(add_p_pp(sc, car(args), random_p_p(sc, cadadr(args))));
+#else
+ s7_int x = integer(car(args)), y = opt3_int(args); /* cadadr */
+ return(make_integer(sc, x + (s7_int)(y * next_random(sc->default_random_state)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */
+#endif
+}
+
+
+/* -------------------------------- char<->integer -------------------------------- */
+static s7_pointer g_char_to_integer(s7_scheme *sc, s7_pointer args)
+{
+ #define H_char_to_integer "(char->integer c) converts the character c to an integer"
+ #define Q_char_to_integer s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_char_symbol)
+
+ if (!is_character(car(args)))
+ return(sole_arg_method_or_bust(sc, car(args), sc->char_to_integer_symbol, args, sc->type_names[T_CHARACTER]));
+ return(small_int(character(car(args))));
+}
+
+static s7_int char_to_integer_i_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_character(p))
+ return(integer(method_or_bust_p(sc, p, sc->char_to_integer_symbol, sc->type_names[T_CHARACTER])));
+ return(character(p));
+}
+
+static s7_pointer char_to_integer_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_character(p))
+ return(method_or_bust_p(sc, p, sc->char_to_integer_symbol, sc->type_names[T_CHARACTER]));
+ return(make_integer(sc, character(p)));
+}
+
+static s7_pointer integer_to_char_p_p(s7_scheme *sc, s7_pointer x)
+{
+ s7_int ind;
+ if (!s7_is_integer(x))
+ return(method_or_bust_p(sc, x, sc->integer_to_char_symbol, sc->type_names[T_INTEGER]));
+ ind = s7_integer_clamped_if_gmp(sc, x);
+ if ((ind < 0) || (ind >= NUM_CHARS))
+ sole_arg_out_of_range_error_nr(sc, sc->integer_to_char_symbol, x, wrap_string(sc, "it doen't fit in an unsigned byte", 33));
+ return(chars[(uint8_t)ind]);
+}
+
+static s7_pointer g_integer_to_char(s7_scheme *sc, s7_pointer args)
+{
+ #define H_integer_to_char "(integer->char i) converts the non-negative integer i to a character"
+ #define Q_integer_to_char s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol)
+ return(integer_to_char_p_p(sc, car(args)));
+}
+
+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 */
+ return(chars[(uint8_t)ind]);
+}
+
+
+static uint8_t uppers[256], lowers[256];
+static void init_uppers(void)
+{
+ for (int32_t i = 0; i < 256; i++)
+ {
+ uppers[i] = (uint8_t)toupper(i);
+ lowers[i] = (uint8_t)tolower(i);
+ }
+}
+
+static void init_chars(void)
+{
+ s7_cell *cells = (s7_cell *)Calloc(NUM_CHARS + 1, sizeof(s7_cell));
+
+ chars = (s7_pointer *)Malloc((NUM_CHARS + 1) * sizeof(s7_pointer)); /* chars is declared far above */
+ chars[0] = &cells[0];
+ eof_object = chars[0];
+ set_full_type(eof_object, T_EOF | T_IMMUTABLE | T_UNHEAP);
+ eof_name_length(eof_object) = 6;
+ eof_name(eof_object) = "#<eof>";
+ chars++; /* now chars[EOF] == chars[-1] == #<eof> */
+ cells++;
+
+ for (int32_t i = 0; i < NUM_CHARS; i++)
+ {
+ s7_pointer cp = &cells[i];
+ uint8_t c = (uint8_t)i;
+
+ set_type_bit(cp, T_IMMUTABLE | T_CHARACTER | T_UNHEAP);
+ set_optimize_op(cp, OP_CONSTANT);
+ character(cp) = c;
+ upper_character(cp) = (uint8_t)toupper(i);
+ is_char_alphabetic(cp) = (bool)isalpha(i);
+ is_char_numeric(cp) = (bool)isdigit(i);
+ is_char_whitespace(cp) = white_space[i];
+ is_char_uppercase(cp) = (((bool)isupper(i)) || ((i >= 192) && (i < 208)));
+ is_char_lowercase(cp) = (bool)islower(i);
+ chars[i] = cp;
+
+ #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:
+ #define P_SIZE 12
+ character_name_length(cp) = snprintf((char *)(&(character_name(cp))), P_SIZE, ((c < 32) || (c >= 127)) ? "#\\x%x" : "#\\%c", c);
+ break;
+ }}
+}
+
+
+/* -------------------------------- char-upcase, char-downcase ----------------------- */
+static s7_pointer char_upcase_p_p(s7_scheme *sc, s7_pointer c)
+{
+ if (!is_character(c))
+ return(method_or_bust_p(sc, c, sc->char_upcase_symbol, sc->type_names[T_CHARACTER]));
+ return(chars[upper_character(c)]);
+}
+
+static s7_pointer char_upcase_p_p_unchecked(s7_scheme *unused_sc, s7_pointer c) {return(chars[upper_character(c)]);}
+
+static s7_pointer g_char_upcase(s7_scheme *sc, s7_pointer args)
+{
+ #define H_char_upcase "(char-upcase c) converts the character c to upper case"
+ #define Q_char_upcase sc->pcl_c
+ return(char_upcase_p_p(sc, car(args)));
+}
+
+static s7_pointer g_char_downcase(s7_scheme *sc, s7_pointer args)
+{
+ #define H_char_downcase "(char-downcase c) converts the character c to lower case"
+ #define Q_char_downcase sc->pcl_c
+ if (!is_character(car(args)))
+ return(sole_arg_method_or_bust(sc, car(args), sc->char_downcase_symbol, args, sc->type_names[T_CHARACTER]));
+ return(chars[lowers[character(car(args))]]);
+}
+
+
+/* -------------------------------- char-alphabetic? char-numeric? char-whitespace? -------------------------------- */
+static s7_pointer g_is_char_alphabetic(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_char_alphabetic "(char-alphabetic? c) returns #t if the character c is alphabetic"
+ #define Q_is_char_alphabetic sc->pl_bc
+ if (!is_character(car(args)))
+ return(sole_arg_method_or_bust(sc, car(args), sc->is_char_alphabetic_symbol, args, sc->type_names[T_CHARACTER]));
+ return(make_boolean(sc, is_char_alphabetic(car(args))));
+ /* isalpha returns #t for (integer->char 226) and others in that range */
+}
+
+static bool is_char_alphabetic_b_7p(s7_scheme *sc, s7_pointer c)
+{
+ if (!is_character(c))
+ sole_arg_wrong_type_error_nr(sc, sc->is_char_alphabetic_symbol, c, sc->type_names[T_CHARACTER]);
+ /* return(sole_arg_method_or_bust(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F); */ /* slower? see tmisc */
+ return(is_char_alphabetic(c));
+}
+
+static s7_pointer is_char_alphabetic_p_p(s7_scheme *sc, s7_pointer c)
+{
+ if (!is_character(c))
+ return(sole_arg_method_or_bust(sc, c, sc->is_char_alphabetic_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]));
+ return(make_boolean(sc, is_char_alphabetic(c)));
+}
+
+static s7_pointer g_is_char_numeric(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_char_numeric "(char-numeric? c) returns #t if the character c is a digit"
+ #define Q_is_char_numeric sc->pl_bc
+
+ s7_pointer arg = car(args);
+ if (!is_character(arg))
+ return(sole_arg_method_or_bust(sc, arg, sc->is_char_numeric_symbol, args, sc->type_names[T_CHARACTER]));
+ return(make_boolean(sc, is_char_numeric(arg)));
+}
+
+static bool is_char_numeric_b_7p(s7_scheme *sc, s7_pointer c)
+{
+ if (!is_character(c))
+ sole_arg_wrong_type_error_nr(sc, sc->is_char_numeric_symbol, c, sc->type_names[T_CHARACTER]);
+ /* return(sole_arg_method_or_bust(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F); */ /* as above */
+ return(is_char_numeric(c));
+}
+
+static s7_pointer is_char_numeric_p_p(s7_scheme *sc, s7_pointer c)
+{
+ if (!is_character(c))
+ return(sole_arg_method_or_bust(sc, c, sc->is_char_numeric_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]));
+ return(make_boolean(sc, is_char_numeric(c)));
+}
+
+
+static s7_pointer g_is_char_whitespace(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_char_whitespace "(char-whitespace? c) returns #t if the character c is non-printing character"
+ #define Q_is_char_whitespace sc->pl_bc
+
+ s7_pointer arg = car(args);
+ if (!is_character(arg))
+ return(sole_arg_method_or_bust(sc, arg, sc->is_char_whitespace_symbol, args, sc->type_names[T_CHARACTER]));
+ return(make_boolean(sc, is_char_whitespace(arg)));
+}
+
+static bool is_char_whitespace_b_7p(s7_scheme *sc, s7_pointer c)
+{
+ if (!is_character(c))
+ sole_arg_wrong_type_error_nr(sc, sc->is_char_whitespace_symbol, c, sc->type_names[T_CHARACTER]);
+ return(is_char_whitespace(c));
+}
+
+static s7_pointer is_char_whitespace_p_p(s7_scheme *sc, s7_pointer c)
+{
+ if (!is_character(c))
+ return(sole_arg_method_or_bust(sc, c, sc->is_char_whitespace_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]));
+ return(make_boolean(sc, is_char_whitespace(c)));
+}
+
+static s7_pointer is_char_whitespace_p_p_unchecked(s7_scheme *sc, s7_pointer c) {return(make_boolean(sc, is_char_whitespace(c)));}
+
+
+/* -------------------------------- char-upper-case? char-lower-case? -------------------------------- */
+static s7_pointer g_is_char_upper_case(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_char_upper_case "(char-upper-case? c) returns #t if the character c is in upper case"
+ #define Q_is_char_upper_case sc->pl_bc
+
+ s7_pointer arg = car(args);
+ if (!is_character(arg))
+ return(sole_arg_method_or_bust(sc, arg, sc->is_char_upper_case_symbol, args, sc->type_names[T_CHARACTER]));
+ return(make_boolean(sc, is_char_uppercase(arg)));
+}
+
+static bool is_char_upper_case_b_7p(s7_scheme *sc, s7_pointer c)
+{
+ if (!is_character(c))
+ return(sole_arg_method_or_bust(sc, c, sc->is_char_upper_case_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F);
+ return(is_char_uppercase(c));
+}
+
+static s7_pointer g_is_char_lower_case(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_char_lower_case "(char-lower-case? c) returns #t if the character c is in lower case"
+ #define Q_is_char_lower_case sc->pl_bc
+
+ s7_pointer arg = car(args);
+ if (!is_character(arg))
+ return(sole_arg_method_or_bust(sc, arg, sc->is_char_lower_case_symbol, args, sc->type_names[T_CHARACTER]));
+ return(make_boolean(sc, is_char_lowercase(arg)));
+}
+
+static bool is_char_lower_case_b_7p(s7_scheme *sc, s7_pointer c)
+{
+ if (!is_character(c))
+ return(sole_arg_method_or_bust(sc, c, sc->is_char_lower_case_symbol, set_plist_1(sc, c), sc->type_names[T_CHARACTER]) != sc->F);
+ return(is_char_lowercase(c));
+}
+
+
+/* -------------------------------- char? -------------------------------- */
+static s7_pointer g_is_char(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_char "(char? obj) returns #t if obj is a character"
+ #define Q_is_char sc->pl_bt
+ check_boolean_method(sc, is_character, sc->is_char_symbol, args);
+}
+
+static s7_pointer is_char_p_p(s7_scheme *sc, s7_pointer p) {return((is_character(p)) ? sc->T : sc->F);}
+
+s7_pointer s7_make_character(s7_scheme *sc, uint8_t c) {return(chars[c]);}
+
+bool s7_is_character(s7_pointer p) {return(is_character(p));}
+
+uint8_t s7_character(s7_pointer p) {return(character(p));}
+
+
+/* -------------------------------- char<? char<=? char>? char>=? char=? -------------------------------- */
+static int32_t charcmp(uint8_t c1, uint8_t c2)
+{
+ return((c1 == c2) ? 0 : (c1 < c2) ? -1 : 1);
+ /* not tolower here -- the single case is apparently supposed to be upper case
+ * this matters in a case like (char-ci<? #\_ #\e) which Guile and Gauche say is #f
+ * although (char<? #\_ #\e) is #t -- the spec does not say how to interpret this!
+ */
+}
+
+static bool is_character_via_method(s7_scheme *sc, s7_pointer p)
+{
+ if (is_character(p))
+ return(true);
+ if (has_active_methods(sc, 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(false);
+}
+
+static s7_pointer char_with_error_check(s7_scheme *sc, s7_pointer x, s7_pointer args, s7_pointer caller)
+{
+ for (s7_pointer y = cdr(x); is_pair(y); y = cdr(y)) /* before returning #f, check for bad trailing arguments */
+ if (!is_character_via_method(sc, car(y)))
+ wrong_type_error_nr(sc, caller, position_of(y, args), car(y), sc->type_names[T_CHARACTER]);
+ return(sc->F);
+}
+
+static s7_pointer g_char_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
+{
+ s7_pointer y = car(args);
+ if (!is_character(y))
+ return(method_or_bust(sc, y, sym, args, sc->type_names[T_CHARACTER], 1));
+ 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)));
+ if (charcmp(character(y), character(car(x))) != val)
+ return(char_with_error_check(sc, x, args, sym));
+ }
+ return(sc->T);
+}
+
+static s7_pointer g_char_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
+{
+ s7_pointer y = car(args);
+ if (!is_character(y))
+ return(method_or_bust(sc, y, sym, args, sc->type_names[T_CHARACTER], 1));
+ 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)));
+ if (charcmp(character(y), character(car(x))) == val)
+ return(char_with_error_check(sc, x, args, sym));
+ }
+ return(sc->T);
+}
+
+static s7_pointer g_chars_are_equal(s7_scheme *sc, s7_pointer args)
+{
+ #define H_chars_are_equal "(char=? char ...) returns #t if all the character arguments are equal"
+ #define Q_chars_are_equal sc->pcl_bc
+
+ s7_pointer y = car(args);
+ if (!is_character(y))
+ return(method_or_bust(sc, y, sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 1));
+ 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)));
+ if (car(x) != y)
+ return(char_with_error_check(sc, x, args, sc->char_eq_symbol));
+ }
+ return(sc->T);
+}
+
+
+static s7_pointer g_chars_are_less(s7_scheme *sc, s7_pointer args)
+{
+ #define H_chars_are_less "(char<? char ...) returns #t if all the character arguments are increasing"
+ #define Q_chars_are_less sc->pcl_bc
+ return(g_char_cmp(sc, args, -1, sc->char_lt_symbol));
+}
+
+static s7_pointer g_chars_are_greater(s7_scheme *sc, s7_pointer args)
+{
+ #define H_chars_are_greater "(char>? char ...) returns #t if all the character arguments are decreasing"
+ #define Q_chars_are_greater sc->pcl_bc
+ return(g_char_cmp(sc, args, 1, sc->char_gt_symbol));
+}
+
+static s7_pointer g_chars_are_geq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_chars_are_geq "(char>=? char ...) returns #t if all the character arguments are equal or decreasing"
+ #define Q_chars_are_geq sc->pcl_bc
+ return(g_char_cmp_not(sc, args, -1, sc->char_geq_symbol));
+}
+
+static s7_pointer g_chars_are_leq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_chars_are_leq "(char<=? char ...) returns #t if all the character arguments are equal or increasing"
+ #define Q_chars_are_leq sc->pcl_bc
+ return(g_char_cmp_not(sc, args, 1, sc->char_leq_symbol));
+}
+
+static s7_pointer g_simple_char_eq(s7_scheme *sc, s7_pointer args) {return(make_boolean(sc, car(args) == cadr(args)));} /* chooser checks types */
+
+#define check_char2_args(Sc, Caller, P1, P2) \
+ do { \
+ if (!is_character(P1)) return(method_or_bust(Sc, P1, Caller, set_plist_2(Sc, P1, P2), sc->type_names[T_CHARACTER], 1) != sc->F); \
+ if (!is_character(P2)) return(method_or_bust(Sc, P2, Caller, set_plist_2(Sc, P1, P2), sc->type_names[T_CHARACTER], 2) != sc->F); \
+ } while (0)
+
+static bool char_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 < p2);}
+static bool char_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_char2_args(sc, sc->char_lt_symbol, p1, p2);
+ return(p1 < p2);
+}
+
+static bool char_leq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 <= p2);}
+static bool char_leq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_char2_args(sc, sc->char_leq_symbol, p1, p2);
+ return(p1 <= p2);
+}
+
+static bool char_gt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 > p2);}
+static bool char_gt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_char2_args(sc, sc->char_gt_symbol, p1, p2);
+ return(p1 > p2);
+}
+
+static bool char_geq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 >= p2);}
+static bool char_geq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_char2_args(sc, sc->char_geq_symbol, p1, p2);
+ return(p1 >= p2);
+}
+
+static bool char_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(p1 == p2);}
+
+static bool char_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ if (!is_character(p1)) return(method_or_bust(sc, p1, sc->char_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_CHARACTER], 1) != sc->F);
+ if (p1 == p2) return(true);
+ if (!is_character(p2)) return(method_or_bust(sc, p2, sc->char_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_CHARACTER], 2) != sc->F);
+ return(false);
+}
+
+static s7_pointer char_eq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ if (!is_character(p1)) return(method_or_bust(sc, p1, sc->char_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_CHARACTER], 1));
+ if (p1 == p2) return(sc->T);
+ if (!is_character(p2)) return(method_or_bust(sc, p2, sc->char_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_CHARACTER], 2));
+ return(sc->F);
+}
+
+static s7_pointer g_char_equal_2(s7_scheme *sc, s7_pointer args)
+{
+ if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 1));
+ if (car(args) == cadr(args))
+ return(sc->T);
+ if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 2));
+ return(sc->F);
+}
+
+static s7_pointer g_char_less_2(s7_scheme *sc, s7_pointer args)
+{
+ if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_lt_symbol, args, sc->type_names[T_CHARACTER], 1));
+ if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_lt_symbol, args, sc->type_names[T_CHARACTER], 2));
+ return(make_boolean(sc, character(car(args)) < character(cadr(args))));
+}
+
+static s7_pointer g_char_greater_2(s7_scheme *sc, s7_pointer args)
+{
+ if (!is_character(car(args))) return(method_or_bust(sc, car(args), sc->char_gt_symbol, args, sc->type_names[T_CHARACTER], 1));
+ if (!is_character(cadr(args))) return(method_or_bust(sc, cadr(args), sc->char_gt_symbol, args, sc->type_names[T_CHARACTER], 2));
+ return(make_boolean(sc, character(car(args)) > character(cadr(args))));
+}
+
+static bool returns_char(s7_scheme *sc, s7_pointer arg) {return(argument_type(sc, arg) == sc->is_char_symbol);}
+
+static s7_pointer char_equal_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if (args != 2) return(f);
+ {
+ s7_pointer arg1 = cadr(expr), arg2 = caddr(expr);
+ if ((returns_char(sc, arg1)) && (returns_char(sc, arg2)))
+ return(sc->simple_char_eq);
+ }
+ return(sc->char_equal_2);
+}
+
+static s7_pointer char_less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ return((args == 2) ? sc->char_less_2 : f);
+}
+
+static s7_pointer char_greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ return((args == 2) ? sc->char_greater_2 : f);
+}
+
+
+/* -------------------------------- char-ci<? char-ci<=? char-ci>? char-ci>=? char-ci=? -------------------------------- */
+#if (!WITH_PURE_S7)
+static s7_pointer g_char_cmp_ci(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
+{
+ s7_pointer y = car(args);
+ if (!is_character(y))
+ return(method_or_bust(sc, y, sym, args, sc->type_names[T_CHARACTER], 1));
+
+ 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)));
+ if (charcmp(upper_character(y), upper_character(car(x))) != val)
+ return(char_with_error_check(sc, x, args, sym));
+ }
+ return(sc->T);
+}
+
+static s7_pointer g_char_cmp_ci_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
+{
+ s7_pointer y = car(args);
+ if (!is_character(y))
+ return(method_or_bust(sc, y, sym, args, sc->type_names[T_CHARACTER], 1));
+ 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)));
+ if (charcmp(upper_character(y), upper_character(car(x))) == val)
+ return(char_with_error_check(sc, x, args, sym));
+ }
+ return(sc->T);
+}
+
+static s7_pointer g_chars_are_ci_equal(s7_scheme *sc, s7_pointer args)
+{
+ #define H_chars_are_ci_equal "(char-ci=? char ...) returns #t if all the character arguments are equal, ignoring case"
+ #define Q_chars_are_ci_equal sc->pcl_bc
+ return(g_char_cmp_ci(sc, args, 0, sc->char_ci_eq_symbol));
+}
+
+static s7_pointer g_chars_are_ci_less(s7_scheme *sc, s7_pointer args)
+{
+ #define H_chars_are_ci_less "(char-ci<? char ...) returns #t if all the character arguments are increasing, ignoring case"
+ #define Q_chars_are_ci_less sc->pcl_bc
+ return(g_char_cmp_ci(sc, args, -1, sc->char_ci_lt_symbol));
+}
+
+static s7_pointer g_chars_are_ci_greater(s7_scheme *sc, s7_pointer args)
+{
+ #define H_chars_are_ci_greater "(char-ci>? char ...) returns #t if all the character arguments are decreasing, ignoring case"
+ #define Q_chars_are_ci_greater sc->pcl_bc
+ return(g_char_cmp_ci(sc, args, 1, sc->char_ci_gt_symbol));
+}
+
+static s7_pointer g_chars_are_ci_geq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_chars_are_ci_geq "(char-ci>=? char ...) returns #t if all the character arguments are equal or decreasing, ignoring case"
+ #define Q_chars_are_ci_geq sc->pcl_bc
+ return(g_char_cmp_ci_not(sc, args, -1, sc->char_ci_geq_symbol));
+}
+
+static s7_pointer g_chars_are_ci_leq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_chars_are_ci_leq "(char-ci<=? char ...) returns #t if all the character arguments are equal or increasing, ignoring case"
+ #define Q_chars_are_ci_leq sc->pcl_bc
+ return(g_char_cmp_ci_not(sc, args, 1, sc->char_ci_leq_symbol));
+}
+
+
+static bool char_ci_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) < upper_character(p2));}
+static bool char_ci_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_char2_args(sc, sc->char_ci_lt_symbol, p1, p2);
+ return(upper_character(p1) < upper_character(p2));
+}
+
+static bool char_ci_leq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) <= upper_character(p2));}
+static bool char_ci_leq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_char2_args(sc, sc->char_ci_leq_symbol, p1, p2);
+ return(upper_character(p1) <= upper_character(p2));
+}
+
+static bool char_ci_gt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) > upper_character(p2));}
+static bool char_ci_gt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_char2_args(sc, sc->char_ci_gt_symbol, p1, p2);
+ return(upper_character(p1) > upper_character(p2));
+}
+
+static bool char_ci_geq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) >= upper_character(p2));}
+static bool char_ci_geq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_char2_args(sc, sc->char_ci_geq_symbol, p1, p2);
+ return(upper_character(p1) >= upper_character(p2));
+}
+
+static bool char_ci_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(upper_character(p1) == upper_character(p2));}
+static bool char_ci_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_char2_args(sc, sc->char_ci_eq_symbol, p1, p2);
+ return(upper_character(p1) == upper_character(p2));
+}
+
+#endif /* not pure s7 */
+
+
+/* -------------------------------- char-position -------------------------------- */
+static s7_pointer g_char_position(s7_scheme *sc, s7_pointer args)
+{
+ #define H_char_position "(char-position char-or-str str (start 0)) returns the position of the first occurrence of char in str, or #f"
+ #define Q_char_position s7_make_signature(sc, 4, \
+ s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), \
+ s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_string_symbol), \
+ sc->is_string_symbol, sc->is_integer_symbol)
+ const char *porig, *pset;
+ s7_int start, pos, len; /* not "int" because start arg might be most-negative-fixnum */
+ s7_pointer arg1 = car(args), arg2;
+
+ if ((!is_character(arg1)) &&
+ (!is_string(arg1)))
+ return(method_or_bust(sc, arg1, sc->char_position_symbol, args, sc->type_names[T_CHARACTER], 1));
+
+ arg2 = cadr(args);
+ if (!is_string(arg2))
+ return(method_or_bust(sc, arg2, sc->char_position_symbol, args, sc->type_names[T_STRING], 2));
+
+ if (is_pair(cddr(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));
+ 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);
+ }
+ else start = 0;
+
+ porig = string_value(arg2);
+ len = string_length(arg2);
+ if (start >= len) return(sc->F);
+
+ if (is_character(arg1))
+ {
+ char c = character(arg1);
+ const char *p = strchr((const char *)(porig + start), (int)c); /* use strchrnul in Gnu C to catch embedded null case */
+ return((p) ? make_integer(sc, p - porig) : sc->F);
+ }
+ if (string_length(arg1) == 0)
+ return(sc->F);
+ pset = string_value(arg1);
+
+ pos = strcspn((const char *)(porig + start), (const char *)pset);
+ if ((pos + start) < len)
+ return(make_integer(sc, pos + start));
+
+ /* if the string has an embedded null, we can get erroneous results here --
+ * perhaps check for null at pos+start? What about a searched-for string that also has embedded nulls?
+ */
+ return(sc->F);
+}
+
+static s7_pointer char_position_p_ppi(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_int start)
+{
+ /* p1 is char, p2 is string */
+ const char *porig, *p;
+ s7_int len;
+ char c;
+
+ if (!is_string(p2))
+ wrong_type_error_nr(sc, sc->char_position_symbol, 2, p2, sc->type_names[T_STRING]);
+ if (start < 0)
+ wrong_type_error_nr(sc, sc->char_position_symbol, 3, wrap_integer(sc, start), a_non_negative_integer_string);
+
+ c = character(p1);
+ len = string_length(p2);
+ porig = string_value(p2);
+ if (start >= len) return(sc->F);
+ p = strchr((const char *)(porig + start), (int)c);
+ if (p) return(make_integer(sc, p - porig));
+ return(sc->F);
+}
+
+static s7_pointer g_char_position_csi(s7_scheme *sc, s7_pointer args)
+{
+ /* assume char arg1, no end */
+ const char *porig, *p;
+ char c = character(car(args));
+ s7_pointer arg2 = cadr(args);
+ s7_int start, len;
+
+ if (!is_string(arg2))
+ return(g_char_position(sc, args));
+
+ len = string_length(arg2); /* can't return #f here if len==0 -- need start error check first */
+ porig = string_value(arg2);
+
+ if (is_pair(cddr(args)))
+ {
+ s7_pointer arg3 = caddr(args);
+ if (!s7_is_integer(arg3))
+ 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);
+ if (start >= len) return(sc->F);
+ }
+ else start = 0;
+
+ if (len == 0) return(sc->F);
+ p = strchr((const char *)(porig + start), (int)c);
+ return((p) ? make_integer(sc, p - porig) : sc->F);
+}
+
+static s7_pointer char_position_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if ((is_character(cadr(expr))) && ((args == 2) || (args == 3)))
+ return(sc->char_position_csi);
+ return(f);
+}
+
+
+/* -------------------------------- string-position -------------------------------- */
+static s7_pointer g_string_position(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_position "(string-position str1 str2 (start 0)) returns the starting position of str1 in str2 or #f"
+ #define Q_string_position s7_make_signature(sc, 4, \
+ s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), \
+ sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol)
+ const char *s1, *s2, *p2;
+ s7_int start = 0;
+ s7_pointer s1p = car(args), s2p = cadr(args);
+
+ if (!is_string(s1p))
+ return(method_or_bust(sc, s1p, sc->string_position_symbol, args, sc->type_names[T_STRING], 1));
+ if (!is_string(s2p))
+ return(method_or_bust(sc, s2p, sc->string_position_symbol, args, sc->type_names[T_STRING], 2));
+
+ if (is_pair(cddr(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));
+ 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);
+ }
+
+ if (string_length(s1p) == 0)
+ return(sc->F);
+ s1 = string_value(s1p);
+ s2 = string_value(s2p);
+ if (start >= string_length(s2p))
+ return(sc->F);
+
+ p2 = strstr((const char *)(s2 + start), s1);
+ return((p2) ? make_integer(sc, p2 - s2) : sc->F);
+}
+
+
+/* -------------------------------- strings -------------------------------- */
+bool s7_is_string(s7_pointer p) {return(is_string(p));}
+
+static s7_pointer g_is_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_string "(string? obj) returns #t if obj is a string"
+ #define Q_is_string sc->pl_bt
+ check_boolean_method(sc, is_string, sc->is_string_symbol, args);
+}
+
+
+static s7_pointer nil_string; /* permanent "" */
+
+s7_int s7_string_length(s7_pointer str) {return(string_length(str));}
+
+
+#define NUM_STRING_WRAPPERS 8
+
+static s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len)
+{
+ s7_pointer x = car(sc->string_wrappers);
+#if S7_DEBUGGING
+ if ((full_type(x) & (~T_GC_MARK)) != (T_STRING | T_IMMUTABLE | T_UNHEAP | T_SAFE_PROCEDURE)) fprintf(stderr, "%s\n", describe_type_bits(sc, x));
+#endif
+ sc->string_wrappers = cdr(sc->string_wrappers);
+ string_value(x) = (char *)str;
+ string_length(x) = len;
+ return(x);
+}
+
+s7_pointer s7_make_string_wrapper(s7_scheme *sc, const char *str) {return(wrap_string(sc, str, safe_strlen(str)));}
+s7_pointer s7_make_string_wrapper_with_length(s7_scheme *sc, const char *str, s7_int len) {return(wrap_string(sc, str, len));}
+
+static Inline s7_pointer inline_make_empty_string(s7_scheme *sc, s7_int len, char fill)
+{
+ s7_pointer x;
+ block_t *b;
+ if (len == 0) return(nil_string);
+ new_cell(sc, x, T_STRING);
+ b = inline_mallocate(sc, len + 1);
+ string_block(x) = b;
+ string_value(x) = (char *)block_data(b);
+ if (fill != '\0')
+ local_memset((void *)(string_value(x)), fill, len);
+ string_value(x)[len] = 0;
+ string_hash(x) = 0;
+ string_length(x) = len;
+ add_string(sc, x);
+ return(x);
+}
+
+static s7_pointer make_empty_string(s7_scheme *sc, s7_int len, char fill) {return(inline_make_empty_string(sc, len, fill));}
+
+s7_pointer s7_make_string(s7_scheme *sc, const char *str) {return((str) ? make_string_with_length(sc, str, safe_strlen(str)) : nil_string);}
+
+static char *make_semipermanent_c_string(s7_scheme *sc, const char *str) /* strcpy but avoid malloc */
+{
+ s7_int len = safe_strlen(str);
+ char *x = (char *)permalloc(sc, len + 1);
+ memcpy((void *)x, (const void *)str, len);
+ x[len] = 0;
+ return(x);
+}
+
+s7_pointer s7_make_semipermanent_string(s7_scheme *sc, const char *str) /* for (s7) string permanent within one s7 instance (freed upon s7_free) */
+{
+ s7_pointer x;
+ s7_int len;
+ if (!str) return(nil_string);
+ x = alloc_pointer(sc);
+ set_full_type(x, T_STRING | T_IMMUTABLE | T_UNHEAP);
+ set_optimize_op(x, OP_CONSTANT);
+ len = safe_strlen(str);
+ string_length(x) = len;
+ string_block(x) = NULL;
+ string_value(x) = (char *)permalloc(sc, len + 1);
+ memcpy((void *)string_value(x), (const void *)str, len);
+ string_value(x)[len] = 0;
+ string_hash(x) = 0;
+ return(x);
+}
+
+static s7_pointer make_permanent_string(const char *str, s7_int len) /* for (s7) strings outside all s7 GC's */
+{
+ s7_pointer x = (s7_pointer)Calloc(1, sizeof(s7_cell));
+ set_full_type(x, T_STRING | T_IMMUTABLE | T_UNHEAP);
+ set_optimize_op(x, OP_CONSTANT);
+ string_length(x) = len;
+ if ((S7_DEBUGGING) && (len != safe_strlen(str))) fprintf(stderr, "%s[%d]: strlen(%s) != %" ld64 "\n", __func__, __LINE__, str, safe_strlen(str));
+ string_block(x) = NULL;
+ string_value(x) = (char *)str;
+ string_hash(x) = 0;
+ return(x);
+}
+
+s7_pointer s7_make_permanent_string(s7_scheme *sc, const char *str) /* keep s7_scheme* arg for backwards compatibility */
+{
+ return(make_permanent_string(str, safe_strlen(str)));
+}
+
+static void init_strings(void)
+{
+ nil_string = make_permanent_string("", 0);
+ nil_string->tf.u64_type = T_STRING | T_UNHEAP; /* turn off T_IMMUTABLE?? */
+ set_optimize_op(nil_string, OP_CONSTANT);
+
+ car_a_list_string = make_permanent_string("a pair whose car is also a pair", 31);
+ cdr_a_list_string = make_permanent_string("a pair whose cdr is also a pair", 31);
+
+ caar_a_list_string = make_permanent_string("a pair whose caar is also a pair", 32);
+ cadr_a_list_string = make_permanent_string("a pair whose cadr is also a pair", 32);
+ cdar_a_list_string = make_permanent_string("a pair whose cdar is also a pair", 32);
+ cddr_a_list_string = make_permanent_string("a pair whose cddr is also a pair", 32);
+
+ caaar_a_list_string = make_permanent_string("a pair whose caaar is also a pair", 33);
+ caadr_a_list_string = make_permanent_string("a pair whose caadr is also a pair", 33);
+ cadar_a_list_string = make_permanent_string("a pair whose cadar is also a pair", 33);
+ caddr_a_list_string = make_permanent_string("a pair whose caddr is also a pair", 33);
+ cdaar_a_list_string = make_permanent_string("a pair whose cdaar is also a pair", 33);
+ cdadr_a_list_string = make_permanent_string("a pair whose cdadr is also a pair", 33);
+ cddar_a_list_string = make_permanent_string("a pair whose cddar is also a pair", 33);
+ cdddr_a_list_string = make_permanent_string("a pair whose cdddr is also a pair", 33);
+
+ a_list_string = make_permanent_string("a list", 6);
+ an_eq_func_string = make_permanent_string("a procedure that can take two arguments", 39);
+ an_association_list_string = make_permanent_string("an association list", 19);
+ a_normal_real_string = make_permanent_string("a normal real", 13);
+ a_rational_string = make_permanent_string("an integer or a ratio", 21);
+ a_number_string = make_permanent_string("a number", 8);
+ a_procedure_string = make_permanent_string("a procedure", 11);
+ a_procedure_or_a_macro_string = make_permanent_string("a procedure or a macro", 22);
+ a_normal_procedure_string = make_permanent_string("a normal procedure", 18);
+ a_let_string = make_permanent_string("a let (an environment)", 22);
+ a_proper_list_string = make_permanent_string("a proper list", 13);
+ a_boolean_string = make_permanent_string("a boolean", 9);
+ a_byte_vector_string = make_permanent_string("a byte-vector", 13);
+ an_input_port_string = make_permanent_string("an input port", 13);
+ an_open_input_port_string = make_permanent_string("an open input port", 18);
+ an_open_output_port_string = make_permanent_string("an open output port", 19);
+ an_output_port_string = make_permanent_string("an output port", 14);
+ an_output_port_or_f_string = make_permanent_string("an output port or #f", 20);
+ an_input_string_port_string = make_permanent_string("an input string port", 20);
+ an_input_file_port_string = make_permanent_string("an input file port", 18);
+ an_output_string_port_string = make_permanent_string("an output string port", 21);
+ an_output_file_port_string = make_permanent_string("an output file port", 19);
+ a_thunk_string = make_permanent_string("a thunk", 7);
+ a_symbol_string = make_permanent_string("a symbol", 8);
+ a_non_negative_integer_string = make_permanent_string("a non-negative integer", 22);
+ an_unsigned_byte_string = make_permanent_string("an unsigned byte", 16);
+ something_applicable_string = make_permanent_string("a procedure or something applicable", 35);
+ a_random_state_object_string = make_permanent_string("a random-state object", 21);
+ a_format_port_string = make_permanent_string("#f, #t, (), or an open output port", 34);
+ a_non_constant_symbol_string = make_permanent_string("a non-constant symbol", 21);
+ a_sequence_string = make_permanent_string("a sequence", 10);
+ a_valid_radix_string = make_permanent_string("it should be between 2 and 16", 29);
+ result_is_too_large_string = make_permanent_string("result is too large", 19);
+ it_is_too_large_string = make_permanent_string("it is too large", 15);
+ it_is_too_small_string = make_permanent_string("it is less than the start position", 34);
+ it_is_negative_string = make_permanent_string("it is negative", 14);
+ it_is_nan_string = make_permanent_string("NaN usually indicates a numerical error", 39);
+ it_is_infinite_string = make_permanent_string("it is infinite", 14);
+ too_many_indices_string = make_permanent_string("too many indices", 16);
+ parameter_set_twice_string = make_permanent_string("parameter set twice, ~S in ~S", 29);
+ immutable_error_string = make_permanent_string("can't ~S ~S (it is immutable)", 29);
+ cant_bind_immutable_string = make_permanent_string("~A: can't bind an immutable object: ~S", 38);
+ intermediate_too_large_string = make_permanent_string("intermediate result is too large", 32);
+#if (!HAVE_COMPLEX_NUMBERS)
+ no_complex_numbers_string = make_permanent_string("this version of s7 does not support complex numbers", 51);
+#endif
+ keyword_value_missing_string = make_permanent_string("~A: keyword argument's value is missing: ~S in ~S", 49);
+
+ format_string_1 = make_permanent_string("format: ~S ~{~S~^ ~}: ~A", 24);
+ format_string_2 = make_permanent_string("format: ~S: ~A", 14);
+ format_string_3 = make_permanent_string("format: ~S ~{~S~^ ~}~&~NT^: ~A", 30);
+ format_string_4 = make_permanent_string("format: ~S~&~NT^: ~A", 20);
+
+ too_many_arguments_string = make_permanent_string("~S: too many arguments: ~A", 26);
+ not_enough_arguments_string = make_permanent_string("~S: not enough arguments: ~A", 28);
+}
+
+
+/* -------------------------------- make-string -------------------------------- */
+s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, s7_int len) {return(make_string_with_length(sc, str, len));}
+
+static s7_pointer g_make_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_make_string "(make-string len (val #\\space)) makes a string of length len filled with the character val (default: space)"
+ #define Q_make_string s7_make_signature(sc, 3, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol)
+
+ s7_pointer n = car(args);
+ s7_int len;
+ char fill;
+ if (!s7_is_integer(n))
+ {
+ check_method(sc, n, sc->make_string_symbol, args);
+ wrong_type_error_nr(sc, sc->make_string_symbol, 1, n, sc->type_names[T_INTEGER]);
+ }
+ if ((is_pair(cdr(args))) &&
+ (!is_character(cadr(args))))
+ return(method_or_bust(sc, cadr(args), sc->make_string_symbol, args, sc->type_names[T_CHARACTER], 2));
+
+ len = s7_integer_clamped_if_gmp(sc, n);
+ if (len == 0) return(nil_string);
+ if (len < 0)
+ 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)));
+
+ if (is_null(cdr(args)))
+ return(make_empty_string(sc, len, '\0')); /* #\null here means "don't fill/clear" */
+ fill = s7_character(cadr(args));
+ n = make_empty_string(sc, len, fill);
+ if (fill == '\0')
+ memclr((void *)string_value(n), (size_t)len);
+ return(n);
+}
+
+static s7_pointer make_string_p_i(s7_scheme *sc, s7_int len)
+{
+ if (len == 0) return(nil_string);
+ if (len < 0)
+ 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)));
+ return(make_empty_string(sc, len, '\0'));
+}
+
+
+#if (!WITH_PURE_S7)
+/* -------------------------------- string-length -------------------------------- */
+static s7_pointer g_string_length(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_length "(string-length str) returns the length of the string str"
+ #define Q_string_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)
+ s7_pointer p = car(args);
+ if (!is_string(p))
+ return(sole_arg_method_or_bust(sc, p, sc->string_length_symbol, args, sc->type_names[T_STRING]));
+ return(make_integer(sc, string_length(p)));
+}
+
+static s7_int string_length_i_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_string(p))
+ return(integer(method_or_bust_p(sc, p, sc->string_length_symbol, sc->type_names[T_STRING])));
+ return(string_length(p));
+}
+#endif
+
+
+/* -------------------------------- string-up|downcase -------------------------------- */
+static s7_pointer g_string_downcase(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_downcase "(string-downcase str) returns the lower case version of str."
+ #define Q_string_downcase sc->pcl_s
+
+ s7_pointer p = car(args), newstr;
+ s7_int i, len;
+ uint8_t *nstr;
+ const uint8_t *ostr;
+
+ if (!is_string(p))
+ return(method_or_bust_p(sc, p, sc->string_downcase_symbol, sc->type_names[T_STRING]));
+ len = string_length(p);
+ newstr = make_empty_string(sc, len, 0);
+
+ ostr = (const uint8_t *)string_value(p);
+ nstr = (uint8_t *)string_value(newstr);
+ if (len >= 128)
+ {
+ i = len - 1;
+ while (i >= 8)
+ LOOP_8(nstr[i] = lowers[(uint8_t)ostr[i]]; i--);
+ while (i >= 0) {nstr[i] = lowers[(uint8_t)ostr[i]]; i--;}
+ }
+ else
+ for (i = 0; i < len; i++) nstr[i] = lowers[(uint8_t)ostr[i]];
+ return(newstr);
+}
+
+static s7_pointer g_string_upcase(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_upcase "(string-upcase str) returns the upper case version of str."
+ #define Q_string_upcase sc->pcl_s
+
+ s7_pointer p = car(args), newstr;
+ s7_int i, len;
+ uint8_t *nstr;
+ const uint8_t *ostr;
+
+ if (!is_string(p))
+ return(method_or_bust_p(sc, p, sc->string_upcase_symbol, sc->type_names[T_STRING]));
+ len = string_length(p);
+ newstr = make_empty_string(sc, len, 0);
+
+ ostr = (const uint8_t *)string_value(p);
+ nstr = (uint8_t *)string_value(newstr);
+ if (len >= 128)
+ {
+ i = len - 1;
+ while (i >= 8)
+ LOOP_8(nstr[i] = uppers[(uint8_t)ostr[i]]; i--);
+ while (i >= 0) {nstr[i] = uppers[(uint8_t)ostr[i]]; i--;}
+ }
+ else
+ for (i = 0; i < len; i++) nstr[i] = uppers[(uint8_t)ostr[i]];
+ return(newstr);
+}
+
+
+/* -------------------------------- string-ref -------------------------------- */
+static s7_pointer string_ref_1(s7_scheme *sc, s7_pointer strng, s7_pointer index)
+{
+ char *str;
+ s7_int ind;
+
+ if (!s7_is_integer(index))
+ return(method_or_bust_pp(sc, index, sc->string_ref_symbol, strng, index, sc->type_names[T_INTEGER], 2));
+ ind = s7_integer_clamped_if_gmp(sc, index);
+ if (ind < 0)
+ out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, index, it_is_negative_string);
+ if (ind >= string_length(strng))
+ out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, index, it_is_too_large_string);
+
+ str = string_value(strng);
+ return(chars[((uint8_t *)str)[ind]]);
+}
+
+static s7_pointer g_string_ref(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_ref "(string-ref str index) returns the character at the index-th element of the string str"
+ #define Q_string_ref s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol)
+
+ s7_pointer strng = car(args);
+ if (!is_string(strng))
+ return(method_or_bust(sc, strng, sc->string_ref_symbol, args, sc->type_names[T_STRING], 1));
+ return(string_ref_1(sc, strng, cadr(args)));
+}
+
+static s7_pointer string_ref_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1)
+{
+ if (!is_string(p1))
+ return(method_or_bust(sc, p1, sc->string_ref_symbol, set_plist_2(sc, p1, make_integer(sc, i1)), sc->type_names[T_STRING], 1));
+ if ((i1 < 0) || (i1 >= string_length(p1)))
+ out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(chars[((uint8_t *)string_value(p1))[i1]]);
+}
+
+static s7_pointer string_ref_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer i1)
+{
+ if (!is_string(p1))
+ return(method_or_bust_pp(sc, p1, sc->string_ref_symbol, p1, i1, sc->type_names[T_STRING], 1));
+ return(string_ref_1(sc, p1, i1));
+}
+
+static s7_pointer string_ref_p_p0(s7_scheme *sc, s7_pointer p1, s7_pointer unused_i1)
+{
+ if (!is_string(p1))
+ return(method_or_bust_pp(sc, p1, sc->string_ref_symbol, p1, int_zero, sc->type_names[T_STRING], 1));
+ if (string_length(p1) <= 0)
+ out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, int_zero, it_is_too_large_string);
+ return(chars[((uint8_t *)string_value(p1))[0]]);
+}
+
+static s7_pointer string_plast_via_method(s7_scheme *sc, s7_pointer p1) /* tmock */
+{
+ s7_pointer len = method_or_bust_p(sc, p1, sc->length_symbol, sc->type_names[T_STRING]);
+ return(method_or_bust_with_type_pi(sc, p1, sc->string_ref_symbol, p1, integer(len) - 1, sc->type_names[T_STRING], 1));
+}
+
+static s7_pointer string_ref_p_plast(s7_scheme *sc, s7_pointer p1, s7_pointer unused_i1)
+{
+ if (!is_string(p1))
+ return(string_plast_via_method(sc, p1));
+ if (string_length(p1) <= 0)
+ out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, wrap_integer(sc, string_length(p1) - 1), it_is_too_large_string);
+ return(chars[((uint8_t *)string_value(p1))[string_length(p1) - 1]]);
+}
+
+static inline s7_pointer string_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1)
+{
+ if ((i1 < 0) || (i1 >= string_length(p1)))
+ out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(chars[((uint8_t *)string_value(p1))[i1]]);
+}
+
+static s7_pointer string_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1) {return(chars[((uint8_t *)string_value(p1))[i1]]);}
+
+
+/* -------------------------------- string-set! -------------------------------- */
+static s7_pointer g_string_set(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_set "(string-set! str index chr) sets the index-th element of the string str to the character chr"
+ #define Q_string_set s7_make_signature(sc, 4, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol)
+
+ s7_pointer strng = car(args), c, index = cadr(args);
+ char *str;
+ s7_int ind;
+
+ if (!is_mutable_string(strng))
+ return(mutable_method_or_bust(sc, strng, sc->string_set_symbol, args, sc->type_names[T_STRING], 1));
+ if (!s7_is_integer(index))
+ return(method_or_bust(sc, index, sc->string_set_symbol, args, sc->type_names[T_INTEGER], 2));
+
+ ind = s7_integer_clamped_if_gmp(sc, index);
+ if (ind < 0)
+ out_of_range_error_nr(sc, sc->string_set_symbol, int_two, index, a_non_negative_integer_string);
+ if (ind >= string_length(strng))
+ out_of_range_error_nr(sc, sc->string_set_symbol, int_two, index, it_is_too_large_string);
+
+ str = string_value(strng);
+ c = caddr(args);
+ if (!is_character(c))
+ return(method_or_bust(sc, c, sc->string_set_symbol, args, sc->type_names[T_CHARACTER], 3));
+
+ str[ind] = (char)s7_character(c);
+ return(c);
+}
+
+static s7_pointer string_set_p_pip(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2)
+{
+ if (!is_string(p1))
+ wrong_type_error_nr(sc, sc->string_set_symbol, 1, p1, sc->type_names[T_STRING]);
+ if (!is_character(p2))
+ wrong_type_error_nr(sc, sc->string_set_symbol, 2, p2, sc->type_names[T_CHARACTER]);
+ if ((i1 >= 0) && (i1 < string_length(p1)))
+ string_value(p1)[i1] = s7_character(p2);
+ else out_of_range_error_nr(sc, sc->string_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(p2);
+}
+
+static s7_pointer string_set_p_pip_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2)
+{
+ if ((i1 >= 0) && (i1 < string_length(p1)))
+ string_value(p1)[i1] = s7_character(p2);
+ else out_of_range_error_nr(sc, sc->string_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(p2);
+}
+
+static s7_pointer string_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1, s7_pointer p2) {string_value(p1)[i1] = s7_character(p2); return(p2);}
+
+
+/* -------------------------------- string-append -------------------------------- */
+static s7_pointer c_object_length(s7_scheme *sc, s7_pointer obj);
+
+static bool sequence_is_empty(s7_scheme *sc, s7_pointer obj) /* "is_empty" is some C++ struct?? */
+{
+ switch (type(obj))
+ {
+ case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR:
+ case T_VECTOR: return(vector_length(obj) == 0);
+ case T_NIL: return(true);
+ case T_PAIR: return(false);
+ case T_STRING: return(string_length(obj) == 0);
+ case T_HASH_TABLE: return(hash_table_entries(obj) == 0);
+ case T_C_OBJECT: return(s7_is_eqv(sc, c_object_length(sc, obj), int_zero));
+ case T_LET: if (obj != sc->rootlet) return(!tis_slot(let_slots(obj))); /* (append (rootlet) #f) */
+ default: return(false);
+ }
+}
+
+static s7_int sequence_length(s7_scheme *sc, s7_pointer lst)
+{
+ switch (type(lst))
+ {
+ case T_PAIR:
+ {
+ 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:
+ case T_VECTOR: return(vector_length(lst));
+ case T_STRING: return(string_length(lst));
+ case T_HASH_TABLE: return(hash_table_entries(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));
+ }}
+ return(-1);
+}
+
+static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args);
+
+static void string_append_2(s7_scheme *sc, s7_pointer newstr, s7_pointer args, const s7_pointer stop_arg, s7_pointer caller)
+{
+ s7_int len;
+ char *pos;
+ s7_pointer x;
+ 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;
+ }}
+ 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;
+ }
+}
+
+static s7_pointer g_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer caller)
+{
+ #define H_string_append "(string-append str1 ...) appends all its string arguments into one string"
+ #define Q_string_append sc->pcl_s
+
+ s7_int len = 0;
+ s7_pointer x, newstr;
+ bool just_strings = true;
+
+ if (is_null(args))
+ return(nil_string);
+
+ gc_protect_via_stack(sc, args);
+ /* get length for new string */
+ for (x = args; is_not_null(x); x = cdr(x))
+ {
+ s7_pointer p = car(x);
+ if (is_string(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;
+ }}
+ if (len == 0)
+ {
+ unstack_gc_protect(sc);
+ return(nil_string);
+ }
+ if (len > sc->max_string_length)
+ {
+ 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)));
+ }
+ 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;
+ }}}
+ else string_append_2(sc, newstr, args, sc->nil, caller);
+ unstack_gc_protect(sc);
+ return(newstr);
+}
+
+static s7_pointer g_string_append(s7_scheme *sc, s7_pointer args) {return(g_string_append_1(sc, args, sc->string_append_symbol));}
+
+static inline s7_pointer string_append_1(s7_scheme *sc, s7_pointer s1, s7_pointer s2)
+{
+ if ((is_string(s1)) && (is_string(s2)))
+ {
+ s7_int len, pos = string_length(s1);
+ s7_pointer newstr;
+ if (pos == 0) return(make_string_with_length(sc, string_value(s2), string_length(s2)));
+ 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)));
+ 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));
+ return(newstr);
+ }
+ return(g_string_append_1(sc, list_2(sc, s1, s2), sc->string_append_symbol));
+}
+
+static s7_pointer string_append_p_pp(s7_scheme *sc, s7_pointer s1, s7_pointer s2) {return(string_append_1(sc, s1, s2));}
+
+static s7_pointer g_string_append_2(s7_scheme *sc, s7_pointer args) {return(string_append_1(sc, car(args), cadr(args)));}
+
+static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr);
+
+static s7_pointer string_append_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ check_for_substring_temp(sc, expr);
+ return((args == 2) ? sc->string_append_2 : f);
+}
+
+
+/* -------------------------------- substring -------------------------------- */
+static s7_pointer start_and_end(s7_scheme *sc, s7_pointer caller, s7_pointer args, int32_t position, s7_pointer index_args, s7_int *start, s7_int *end)
+{
+ /* we assume that *start=0 and *end=length, that end is "exclusive", return true if the start/end points are not changed */
+ s7_pointer pstart = car(index_args);
+ s7_int index;
+
+ if (!s7_is_integer(pstart))
+ return(method_or_bust(sc, pstart, caller, args, sc->type_names[T_INTEGER], position));
+ index = s7_integer_clamped_if_gmp(sc, pstart);
+ if ((index < 0) ||
+ (index > *end)) /* *end == length here */
+ out_of_range_error_nr(sc, caller, small_int(position), pstart, (index < 0) ? it_is_negative_string : it_is_too_large_string);
+ *start = index;
+
+ if (is_pair(cdr(index_args)))
+ {
+ 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));
+ 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);
+ *end = index;
+ }
+ return(sc->unused);
+}
+
+static s7_pointer g_substring(s7_scheme *sc, s7_pointer args)
+{
+ #define H_substring "(substring str start (end (length str))) returns the portion of the string str between start and \
+end: (substring \"01234\" 1 2) -> \"1\""
+ #define Q_substring s7_make_circular_signature(sc, 2, 3, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol)
+
+ s7_pointer x, str = car(args);
+ s7_int start = 0, end, len;
+ char *s;
+
+ if (!is_string(str))
+ return(method_or_bust(sc, str, sc->substring_symbol, args, sc->type_names[T_STRING], 1));
+ end = string_length(str);
+ if (!is_null(cdr(args)))
+ {
+ x = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args), &start, &end);
+ if (x != sc->unused) return(x);
+ }
+ s = string_value(str);
+ len = end - start;
+ if (len == 0) return(nil_string);
+ x = inline_make_string_with_length(sc, (char *)(s + start), len);
+ string_value(x)[len] = 0;
+ return(x);
+}
+
+static s7_pointer g_substring_uncopied(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer str = car(args);
+ s7_int start = 0, end;
+
+ if (!is_string(str))
+ return(method_or_bust(sc, str, sc->substring_symbol, args, sc->type_names[T_STRING], 1));
+ end = string_length(str);
+ if (!is_null(cdr(args)))
+ {
+ s7_pointer x = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args), &start, &end);
+ if (x != sc->unused) return(x);
+ }
+ return(wrap_string(sc, (char *)(string_value(str) + start), end - start));
+}
+
+static s7_pointer substring_uncopied_p_pii(s7_scheme *sc, s7_pointer str, s7_int start, s7_int end)
+{
+ /* is_string arg1 checked in opt */
+ if ((end < start) || (end > string_length(str)))
+ out_of_range_error_nr(sc, sc->substring_symbol, int_three, wrap_integer(sc, end), (end < start) ? it_is_too_small_string : it_is_too_large_string);
+ if (start < 0)
+ out_of_range_error_nr(sc, sc->substring_symbol, int_two, wrap_integer(sc, start), it_is_negative_string);
+ return(wrap_string(sc, (char *)(string_value(str) + start), end - start));
+}
+
+static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args);
+
+static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr)
+{
+ int32_t substrs = 0;
+ /* don't use substring_uncopied for arg if arg is returned: (reverse! (write-string (substring x ...))) */
+ for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p))
+ {
+ 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);
+ }}
+}
+
+static s7_pointer string_substring_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr)
+{
+ /* used by several string functions */
+ check_for_substring_temp(sc, expr);
+ return(f);
+}
+
+
+/* -------------------------------- string-copy -------------------------------- */
+static s7_pointer g_string_copy(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_copy "(string-copy str dest-str (dest-start 0) dest-end) returns a copy of its string argument. If dest-str is given, \
+ string-copy copies its first argument into the second, starting at dest-start in the second string and returns dest-str"
+ #define Q_string_copy s7_make_signature(sc, 5, sc->is_string_symbol, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol)
+
+ s7_pointer source = car(args), p, dest;
+ s7_int start, end;
+
+ if (!is_string(source))
+ return(method_or_bust(sc, source, sc->string_copy_symbol, args, sc->type_names[T_STRING], 1));
+ if (is_null(cdr(args)))
+ return(make_string_with_length(sc, string_value(source), string_length(source)));
+
+ dest = cadr(args);
+ if (!is_string(dest))
+ wrong_type_error_nr(sc, sc->string_copy_symbol, 2, dest, sc->type_names[T_STRING]);
+ if (is_immutable_string(dest))
+ immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't string-copy to ~S; it is immutable", 40), dest));
+
+ end = string_length(dest);
+ p = cddr(args);
+ if (is_null(p))
+ start = 0;
+ else
+ {
+ if (!s7_is_integer(car(p)))
+ 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);
+ 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 (end > string_length(dest)) end = string_length(dest);
+ if (end <= start) return(dest);
+ if ((end - start) > string_length(source)) end = start + string_length(source);
+ memmove((void *)(string_value(dest) + start), (void *)(string_value(source)), end - start);
+ /* although I haven't tracked down a case, libasan+auto-tester reported source<dest with overlap, so use memmove */
+ return(dest);
+}
+
+static s7_pointer string_copy_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if (args == 1) check_for_substring_temp(sc, expr);
+ return(f);
+}
+
+
+/* -------------------------------- string comparisons -------------------------------- */
+static int32_t scheme_strcmp(s7_pointer s1, s7_pointer s2)
+{
+ /* tricky here because str[i] must be treated as unsigned: (string<? (string (integer->char #xf0)) (string (integer->char #x70)))
+ * and null or lack thereof does not say anything about the string end
+ */
+ size_t len1 = (size_t)string_length(s1);
+ size_t len2 = (size_t)string_length(s2);
+ size_t len = (len1 > len2) ? len2 : len1;
+ char *str1 = string_value(s1);
+ char *str2 = string_value(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);
+ }
+ 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;
+ 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 (len1 < len2)
+ return(-1);
+ return((len1 > len2) ? 1 : 0);
+}
+
+static bool is_string_via_method(s7_scheme *sc, s7_pointer p)
+{
+ if (s7_is_string(p))
+ return(true);
+ if (has_active_methods(sc, 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(false);
+}
+
+static s7_pointer g_string_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
+{
+ s7_pointer y = car(args);
+ if (!is_string(y))
+ return(method_or_bust(sc, y, sym, args, sc->type_names[T_STRING], 1));
+ 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)));
+ 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);
+ }}
+ return(sc->T);
+}
+
+static s7_pointer g_string_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
+{
+ s7_pointer y = car(args);
+ if (!is_string(y))
+ return(method_or_bust(sc, y, sym, args, sc->type_names[T_STRING], 1));
+ 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)));
+ 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);
+ }}
+ 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))));
+}
+
+static s7_pointer g_strings_are_equal(s7_scheme *sc, s7_pointer args)
+{
+ #define H_strings_are_equal "(string=? str ...) returns #t if all the string arguments are equal"
+ #define Q_strings_are_equal sc->pcl_bs
+
+ /* C-based check stops at null, but we can have embedded nulls.
+ * (let ((s1 "1234") (s2 "1245")) (string-set! s1 1 #\null) (string-set! s2 1 #\null) (string=? s1 s2))
+ */
+ s7_pointer y = car(args);
+ bool happy = true;
+
+ if (!is_string(y))
+ return(method_or_bust(sc, y, sc->string_eq_symbol, args, sc->type_names[T_STRING], 1));
+ for (s7_pointer x = cdr(args); is_pair(x); x = cdr(x))
+ {
+ 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);
+ }}
+ return((happy) ? sc->T : sc->F);
+}
+
+static s7_pointer g_strings_are_less(s7_scheme *sc, s7_pointer args)
+{
+ #define H_strings_are_less "(string<? str ...) returns #t if all the string arguments are increasing"
+ #define Q_strings_are_less sc->pcl_bs
+ return(g_string_cmp(sc, args, -1, sc->string_lt_symbol));
+}
+
+static s7_pointer g_strings_are_greater(s7_scheme *sc, s7_pointer args)
+{
+ #define H_strings_are_greater "(string>? str ...) returns #t if all the string arguments are decreasing"
+ #define Q_strings_are_greater sc->pcl_bs
+ return(g_string_cmp(sc, args, 1, sc->string_gt_symbol));
+}
+
+static s7_pointer g_strings_are_geq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_strings_are_geq "(string>=? str ...) returns #t if all the string arguments are equal or decreasing"
+ #define Q_strings_are_geq sc->pcl_bs
+ return(g_string_cmp_not(sc, args, -1, sc->string_geq_symbol));
+}
+
+static s7_pointer g_strings_are_leq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_strings_are_leq "(string<=? str ...) returns #t if all the string arguments are equal or increasing"
+ #define Q_strings_are_leq sc->pcl_bs
+ return(g_string_cmp_not(sc, args, 1, sc->string_leq_symbol));
+}
+
+static s7_pointer g_string_equal_2(s7_scheme *sc, s7_pointer args)
+{
+ if (!is_string(car(args)))
+ return(method_or_bust(sc, car(args), sc->string_eq_symbol, args, sc->type_names[T_STRING], 1));
+ if (!is_string(cadr(args)))
+ return(method_or_bust(sc, cadr(args), sc->string_eq_symbol, args, sc->type_names[T_STRING], 2));
+ return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args))));
+}
+
+static s7_pointer g_string_equal_2c(s7_scheme *sc, s7_pointer args)
+{
+ if (!is_string(car(args)))
+ return(method_or_bust(sc, car(args), sc->string_eq_symbol, args, sc->type_names[T_STRING], 1));
+ return(make_boolean(sc, scheme_strings_are_equal(car(args), cadr(args))));
+}
+
+static s7_pointer string_eq_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ if (!is_string(p1))
+ return(method_or_bust(sc, p1, sc->string_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 1));
+ if (!is_string(p2))
+ return(method_or_bust(sc, p2, sc->string_eq_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 2));
+ return(make_boolean(sc, scheme_strings_are_equal(p1, p2)));
+}
+
+static s7_pointer g_string_less_2(s7_scheme *sc, s7_pointer args)
+{
+ if (!is_string(car(args)))
+ return(method_or_bust(sc, car(args), sc->string_lt_symbol, args, sc->type_names[T_STRING], 1));
+ if (!is_string(cadr(args)))
+ return(method_or_bust(sc, cadr(args), sc->string_lt_symbol, args, sc->type_names[T_STRING], 2));
+ return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == -1));
+}
+
+static s7_pointer string_lt_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ if (!is_string(p1))
+ return(method_or_bust(sc, p1, sc->string_lt_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 1));
+ if (!is_string(p2))
+ return(method_or_bust(sc, p2, sc->string_lt_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 2));
+ return(make_boolean(sc, scheme_strcmp(p1, p2) == -1));
+}
+
+static s7_pointer g_string_greater_2(s7_scheme *sc, s7_pointer args)
+{
+ if (!is_string(car(args)))
+ return(method_or_bust(sc, car(args), sc->string_gt_symbol, args, sc->type_names[T_STRING], 1));
+ if (!is_string(cadr(args)))
+ return(method_or_bust(sc, cadr(args), sc->string_gt_symbol, args, sc->type_names[T_STRING], 2));
+ return(make_boolean(sc, scheme_strcmp(car(args), cadr(args)) == 1));
+}
+
+static s7_pointer string_gt_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ if (!is_string(p1))
+ return(method_or_bust(sc, p1, sc->string_gt_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 1));
+ if (!is_string(p2))
+ return(method_or_bust(sc, p2, sc->string_gt_symbol, set_plist_2(sc, p1, p2), sc->type_names[T_STRING], 2));
+ return(make_boolean(sc, scheme_strcmp(p1, p2) == 1));
+}
+
+#define check_string2_args(Sc, Caller, P1, P2) \
+ do { \
+ if (!is_string(p1)) return(method_or_bust(sc, P1, Caller, set_plist_2(Sc, P1, P2), sc->type_names[T_STRING], 1) != Sc->F); \
+ if (!is_string(p2)) return(method_or_bust(sc, P2, Caller, set_plist_2(Sc, P1, P2), sc->type_names[T_STRING], 2) != Sc->F); \
+ } while (0)
+
+static bool string_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) == -1);}
+static bool string_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_string2_args(sc, sc->string_lt_symbol, p1, p2);
+ return(scheme_strcmp(p1, p2) == -1);
+}
+
+static bool string_leq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) != 1);}
+static bool string_leq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_string2_args(sc, sc->string_leq_symbol, p1, p2);
+ return(scheme_strcmp(p1, p2) != 1);
+}
+
+static bool string_gt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) == 1);}
+static bool string_gt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_string2_args(sc, sc->string_gt_symbol, p1, p2);
+ return(scheme_strcmp(p1, p2) == 1);
+}
+
+static bool string_geq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcmp(p1, p2) != -1);}
+static bool string_geq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_string2_args(sc, sc->string_geq_symbol, p1, p2);
+ return(scheme_strcmp(p1, p2) != -1);
+}
+
+static bool string_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strings_are_equal(p1, p2));}
+static bool string_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_string2_args(sc, sc->string_eq_symbol, p1, p2);
+ return(scheme_strings_are_equal(p1, p2));
+}
+
+static s7_pointer string_equal_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ check_for_substring_temp(sc, expr);
+ return((args == 2) ? ((is_string(caddr(expr))) ? sc->string_equal_2c : sc->string_equal_2) : f);
+}
+
+static s7_pointer string_less_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ check_for_substring_temp(sc, expr);
+ return((args == 2) ? sc->string_less_2 : f);
+}
+
+static s7_pointer string_greater_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ check_for_substring_temp(sc, expr);
+ return((args == 2) ? sc->string_greater_2 : f);
+}
+
+
+#if (!WITH_PURE_S7)
+static int32_t scheme_strcasecmp(s7_pointer s1, s7_pointer s2)
+{
+ /* same as scheme_strcmp -- watch out for unwanted sign! and lack of trailing null (length sets string end).
+ */
+ s7_int len1 = string_length(s1);
+ s7_int len2 = string_length(s2);
+ s7_int len = (len1 > len2) ? len2 : len1;
+ const uint8_t *str1 = (const uint8_t *)string_value(s1);
+ const uint8_t *str2 = (const uint8_t *)string_value(s2);
+
+ for (s7_int i = 0; i < len; i++)
+ {
+ if (uppers[(int32_t)str1[i]] < uppers[(int32_t)str2[i]])
+ return(-1);
+ if (uppers[(int32_t)str1[i]] > uppers[(int32_t)str2[i]])
+ return(1);
+ }
+ if (len1 < len2)
+ return(-1);
+ return((len1 > len2) ? 1 : 0);
+}
+
+static bool scheme_strequal_ci(s7_pointer s1, s7_pointer s2)
+{
+ /* same as scheme_strcmp -- watch out for unwanted sign! */
+ s7_int len = string_length(s1);
+ s7_int len2 = string_length(s2);
+ const uint8_t *str1, *str2;
+
+ if (len != len2) return(false);
+ str1 = (const uint8_t *)string_value(s1);
+ str2 = (const uint8_t *)string_value(s2);
+ for (s7_int i = 0; i < len; i++)
+ if (uppers[(int32_t)str1[i]] != uppers[(int32_t)str2[i]])
+ return(false);
+ return(true);
+}
+
+static s7_pointer check_rest_are_strings(s7_scheme *sc, s7_pointer sym, s7_pointer x, s7_pointer args)
+{
+ for (s7_pointer y = 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);
+}
+
+static s7_pointer g_string_ci_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
+{
+ s7_pointer y = car(args);
+
+ if (!is_string(y))
+ return(method_or_bust(sc, y, sym, args, sc->type_names[T_STRING], 1));
+
+ 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)));
+ if (val == 0)
+ {
+ 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));
+ }
+ return(sc->T);
+}
+
+static s7_pointer g_string_ci_cmp_not(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym)
+{
+ s7_pointer y = car(args);
+
+ if (!is_string(y))
+ return(method_or_bust(sc, y, sym, args, sc->type_names[T_STRING], 1));
+ 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)));
+ if (scheme_strcasecmp(y, car(x)) == val)
+ return(check_rest_are_strings(sc, sym, cdr(x), args));
+ }
+ return(sc->T);
+}
+
+static s7_pointer g_strings_are_ci_equal(s7_scheme *sc, s7_pointer args)
+{
+ #define H_strings_are_ci_equal "(string-ci=? str ...) returns #t if all the string arguments are equal, ignoring case"
+ #define Q_strings_are_ci_equal sc->pcl_bs
+ return(g_string_ci_cmp(sc, args, 0, sc->string_ci_eq_symbol));
+}
+
+static s7_pointer g_strings_are_ci_less(s7_scheme *sc, s7_pointer args)
+{
+ #define H_strings_are_ci_less "(string-ci<? str ...) returns #t if all the string arguments are increasing, ignoring case"
+ #define Q_strings_are_ci_less sc->pcl_bs
+ return(g_string_ci_cmp(sc, args, -1, sc->string_ci_lt_symbol));
+}
+
+static s7_pointer g_strings_are_ci_greater(s7_scheme *sc, s7_pointer args)
+{
+ #define H_strings_are_ci_greater "(string-ci>? str ...) returns #t if all the string arguments are decreasing, ignoring case"
+ #define Q_strings_are_ci_greater sc->pcl_bs
+ return(g_string_ci_cmp(sc, args, 1, sc->string_ci_gt_symbol));
+}
+
+static s7_pointer g_strings_are_ci_geq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_strings_are_ci_geq "(string-ci>=? str ...) returns #t if all the string arguments are equal or decreasing, ignoring case"
+ #define Q_strings_are_ci_geq sc->pcl_bs
+ return(g_string_ci_cmp_not(sc, args, -1, sc->string_ci_geq_symbol));
+}
+
+static s7_pointer g_strings_are_ci_leq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_strings_are_ci_leq "(string-ci<=? str ...) returns #t if all the string arguments are equal or increasing, ignoring case"
+ #define Q_strings_are_ci_leq sc->pcl_bs
+ return(g_string_ci_cmp_not(sc, args, 1, sc->string_ci_leq_symbol));
+}
+
+static bool string_ci_lt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) == -1);}
+static bool string_ci_lt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_string2_args(sc, sc->string_ci_lt_symbol, p1, p2);
+ return(scheme_strcasecmp(p1, p2) == -1);
+}
+
+static bool string_ci_leq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) != 1);}
+static bool string_ci_leq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_string2_args(sc, sc->string_ci_leq_symbol, p1, p2);
+ return(scheme_strcasecmp(p1, p2) != 1);
+}
+
+static bool string_ci_gt_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) == 1);}
+static bool string_ci_gt_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_string2_args(sc, sc->string_ci_gt_symbol, p1, p2);
+ return(scheme_strcasecmp(p1, p2) == 1);
+}
+
+static bool string_ci_geq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) != -1);}
+static bool string_ci_geq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_string2_args(sc, sc->string_ci_geq_symbol, p1, p2);
+ return(scheme_strcasecmp(p1, p2) != -1);
+}
+
+static bool string_ci_eq_b_unchecked(s7_pointer p1, s7_pointer p2) {return(scheme_strcasecmp(p1, p2) == 0);}
+static bool string_ci_eq_b_7pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ check_string2_args(sc, sc->string_ci_eq_symbol, p1, p2);
+ return(scheme_strcasecmp(p1, p2) == 0);
+}
+#endif /* pure s7 */
+
+static s7_pointer g_string_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer args)
+{
+ s7_pointer x = car(args), chr;
+ s7_int start = 0, end;
+
+ if (!is_string(x))
+ return(method_or_bust(sc, x, caller, args, sc->type_names[T_STRING], 1)); /* not two methods here */
+ if (is_immutable_string(x))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, x));
+
+ chr = cadr(args);
+ if (!is_character(chr))
+ return(method_or_bust(sc, chr, caller, args, sc->type_names[T_CHARACTER], 2));
+
+ end = string_length(x);
+ if (!is_null(cddr(args)))
+ {
+ s7_pointer p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end);
+ if (p != sc->unused)
+ return(p);
+ if (start == end) return(chr);
+ }
+ if (end == 0) return(chr);
+ local_memset((void *)(string_value(x) + start), (int32_t)character(chr), end - start); /* not memclr even if chr=#\null! */
+ return(chr);
+}
+
+
+/* -------------------------------- string-fill! -------------------------------- */
+#if (!WITH_PURE_S7)
+static s7_pointer g_string_fill(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_fill "(string-fill! str chr start end) fills the string str with the character chr"
+ #define Q_string_fill s7_make_signature(sc, 5, \
+ s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol), \
+ sc->is_string_symbol, sc->is_char_symbol, sc->is_integer_symbol, sc->is_integer_symbol)
+ return(g_string_fill_1(sc, sc->string_fill_symbol, args));
+}
+#endif
+
+
+/* -------------------------------- string -------------------------------- */
+const char *s7_string(s7_pointer p) {return(string_value(p));}
+
+static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym)
+{
+ int32_t i, len;
+ s7_pointer x, newstr;
+ char *str;
+
+ /* get length for new string and check arg types */
+ for (len = 0, x = args; is_not_null(x); len++, x = cdr(x))
+ {
+ 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 (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)));
+ 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))
+ str[i] = character(car(x));
+ return(newstr);
+}
+
+static s7_pointer g_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string "(string chr...) appends all its character arguments into one string"
+ #define Q_string s7_make_circular_signature(sc, 1, 2, sc->is_string_symbol, sc->is_char_symbol)
+ return((is_null(args)) ? nil_string : g_string_1(sc, args, sc->string_symbol));
+}
+
+static s7_pointer g_string_c1(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer c = car(args), str;
+ /* no multiple values here because no pairs below */
+ if (!is_character(c))
+ return(method_or_bust(sc, c, sc->string_symbol, args, sc->type_names[T_CHARACTER], 1));
+ str = inline_make_empty_string(sc, 1, 0); /* can't put character(c) here because null is handled specially */
+ string_value(str)[0] = character(c);
+ return(str);
+}
+
+static s7_pointer string_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ return(((args == 1) && (!is_pair(cadr(expr)))) ? sc->string_c1 : f);
+}
+
+static s7_pointer string_p_p(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer str;
+ if (!is_character(p)) return(g_string_1(sc, set_plist_1(sc, p), sc->string_symbol));
+ str = inline_make_empty_string(sc, 1, 0);
+ string_value(str)[0] = character(p);
+ return(str);
+}
+
+
+/* -------------------------------- list->string -------------------------------- */
+#if (!WITH_PURE_S7)
+static s7_pointer g_list_to_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_list_to_string "(list->string lst) appends all the list's characters into one string; (apply string lst)"
+ #define Q_list_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_proper_list_symbol)
+
+ if (is_null(car(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)));
+ return(g_string_1(sc, car(args), sc->list_to_string_symbol));
+}
+#endif
+
+
+/* -------------------------------- string->list -------------------------------- */
+static s7_pointer string_to_list(s7_scheme *sc, const char *str, s7_int len)
+{
+ s7_pointer result;
+ if (len == 0)
+ return(sc->nil);
+ check_free_heap_size(sc, len);
+ init_temp(sc->y, sc->nil);
+ for (s7_int i = len - 1; i >= 0; i--)
+ sc->y = cons_unchecked(sc, chars[((uint8_t)str[i])], sc->y);
+ result = sc->y;
+ sc->y = sc->unused;
+ return(result);
+}
+
+#if (!WITH_PURE_S7)
+static s7_pointer g_string_to_list(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_to_list "(string->list str start end) returns the elements of the string str in a list; (map values str)"
+ #define Q_string_to_list s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_string_symbol, sc->is_integer_symbol)
+
+ s7_int start = 0, end;
+ s7_pointer p, str = car(args);
+
+ if (!is_string(str))
+ return(sole_arg_method_or_bust(sc, str, sc->string_to_list_symbol, args, sc->type_names[T_STRING]));
+ end = string_length(str);
+ if (!is_null(cdr(args)))
+ {
+ p = start_and_end(sc, sc->string_to_list_symbol, args, 2, cdr(args), &start, &end);
+ if (p != sc->unused) return(p);
+ if (start == end) return(sc->nil);
+ }
+ else
+ 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)));
+ sc->w = sc->nil;
+ check_free_heap_size(sc, end - start);
+ for (s7_int i = end - 1; i >= start; i--)
+ sc->w = cons_unchecked(sc, chars[((uint8_t)string_value(str)[i])], sc->w);
+ p = sc->w;
+ sc->w = sc->unused;
+ return(p);
+}
+
+static s7_pointer string_to_list_p_p(s7_scheme *sc, s7_pointer str)
+{
+ s7_int i, len;
+ s7_pointer p;
+ const uint8_t *val;
+ if (!is_string(str)) return(sole_arg_method_or_bust(sc, str, sc->string_to_list_symbol, set_plist_1(sc, str), sc->type_names[T_STRING]));
+ len = string_length(str);
+ if (len == 0) return(sc->nil);
+ check_free_heap_size(sc, len);
+ val = (const uint8_t *)string_value(str);
+ for (p = sc->nil, i = len - 1; i >= 0; i--) p = cons_unchecked(sc, chars[val[i]], p);
+ return(p);
+}
+#endif
+
+
+/* -------------------------------- port-closed? -------------------------------- */
+static s7_pointer g_is_port_closed(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_port_closed "(port-closed? p) returns #t if the port p is closed."
+ #define Q_is_port_closed s7_make_signature(sc, 2, sc->is_boolean_symbol, \
+ s7_make_signature(sc, 3, sc->is_input_port_symbol, sc->is_output_port_symbol, sc->not_symbol))
+ s7_pointer x = car(args);
+ if ((is_input_port(x)) || (is_output_port(x)))
+ return(make_boolean(sc, port_is_closed(x)));
+ if ((x == current_output_port(sc)) && (x == sc->F))
+ return(sc->F);
+ return(method_or_bust_p(sc, x, sc->is_port_closed_symbol, wrap_string(sc, "a port", 6)));
+}
+
+static bool is_port_closed_b_7p(s7_scheme *sc, s7_pointer x)
+{
+ if ((is_input_port(x)) || (is_output_port(x)))
+ return(port_is_closed(x));
+ if ((x == current_output_port(sc)) && (x == sc->F))
+ return(false);
+ return(method_or_bust_p(sc, x, sc->is_port_closed_symbol, wrap_string(sc, "a port", 6)) != sc->F);
+}
+
+
+/* -------------------------------- port-string -------------------------------- */
+static s7_pointer g_port_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_port_string "(port-string port) returns the port data as a string"
+ #define Q_port_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol))
+
+ s7_pointer port = car(args);
+ if ((!is_input_port(port)) && (!is_output_port(port)))
+ return(method_or_bust_p(sc, port, sc->port_string_symbol, wrap_string(sc, "a port", 6)));
+ if (!is_string_port(port))
+ wrong_type_error_nr(sc, wrap_string(sc, "port-string", 11), 1, port, wrap_string(sc, "a string port", 13));
+ if ((port_is_closed(port)) || (is_function_port(port)))
+ return(nil_string);
+ if (is_output_port(port))
+ return(s7_output_string(sc, port));
+ return(make_string_with_length(sc, (const char *)port_data(port), port_data_size(port))); /* max_string_length? */
+}
+
+static s7_pointer g_set_port_string(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer port = car(args), str;
+ s7_int str_len;
+ if ((!is_input_port(port)) && (!is_output_port(port)))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 1, port, wrap_string(sc, "an input or output port", 23));
+ if (!is_string_port(port))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 1, port, wrap_string(sc, "a string port", 13));
+ if (port_is_closed(port))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 1, port, wrap_string(sc, "an open port", 12));
+
+ str = cadr(args);
+ if (!is_string(str))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-string", 16), 2, str, sc->type_names[T_STRING]);
+
+ str_len = string_length(str);
+ if (is_input_port(port))
+ {
+ port_data(port) = (uint8_t *)string_value(str);
+ port_data(port)[str_len] = '\0';
+ port_data_size(port) = str_len;
+ port_position(port) = 0;
+ port_set_string_or_function(port, str);
+ }
+ else
+ {
+ /* TODO: output-string-port port-string setter code */
+ /* port_position = str_len, port_data_size needs to be big enough for this string, don't set port_string_or_function */
+ }
+ return(str);
+}
+
+
+/* -------------------------------- port-position -------------------------------- */
+static s7_pointer g_port_position(s7_scheme *sc, s7_pointer args)
+{
+ #define H_port_position "(port-position input-port) returns the current location (in bytes) \
+in the port's data where the next read will take place."
+ #define Q_port_position s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_input_port_symbol)
+
+ s7_pointer port = car(args);
+ if (!(is_input_port(port)))
+ sole_arg_wrong_type_error_nr(sc, sc->port_position_symbol, port, sc->type_names[T_INPUT_PORT]);
+ if (port_is_closed(port))
+ sole_arg_wrong_type_error_nr(sc, sc->port_position_symbol, port, an_open_input_port_string);
+ if (is_string_port(port))
+ return(make_integer(sc, port_position(port)));
+#if (!MS_WINDOWS)
+ if (is_file_port(port))
+ return(make_integer(sc, ftell(port_file(port))));
+#endif
+ return(int_zero);
+}
+
+static s7_pointer g_set_port_position(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer port = car(args), pos;
+ s7_int position;
+
+ if (!(is_input_port(port)))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 1, port, an_input_port_string);
+ if (port_is_closed(port))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 1, port, an_open_input_port_string);
+
+ pos = cadr(args);
+ if (!is_t_integer(pos))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-position", 18), 2, pos, sc->type_names[T_INTEGER]);
+ position = s7_integer_clamped_if_gmp(sc, pos);
+ if (position < 0)
+ out_of_range_error_nr(sc, sc->port_position_symbol, int_two, pos, it_is_negative_string);
+ if (is_string_port(port))
+ port_position(port) = (position > port_data_size(port)) ? port_data_size(port) : position;
+#if (!MS_WINDOWS)
+ else
+ if (is_file_port(port))
+ {
+ rewind(port_file(port));
+ fseek(port_file(port), (long)position, SEEK_SET);
+ }
+#endif
+ return(pos);
+}
+
+
+/* -------------------------------- port-file -------------------------------- */
+static s7_pointer g_port_file(s7_scheme *sc, s7_pointer args)
+{
+ #define H_port_file "(port-file port) returns the FILE* pointer associated with the port, wrapped in a c-pointer object"
+ #define Q_port_file s7_make_signature(sc, 2, sc->is_c_pointer_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol))
+
+ s7_pointer port = car(args);
+ if ((!is_input_port(port)) &&
+ (!is_output_port(port)))
+ sole_arg_wrong_type_error_nr(sc, sc->port_file_symbol, port, wrap_string(sc, "a port", 6));
+ if (port_is_closed(port))
+ sole_arg_wrong_type_error_nr(sc, sc->port_file_symbol, port, wrap_string(sc, "an open port", 12));
+#if (!MS_WINDOWS)
+ if (is_file_port(port))
+ return(s7_make_c_pointer_with_type(sc, (void *)(port_file(port)), sc->file__symbol, sc->F));
+#endif
+ return(s7_make_c_pointer(sc, NULL));
+}
+
+
+/* -------------------------------- port-line-number -------------------------------- */
+static s7_pointer port_line_number_p_p(s7_scheme *sc, s7_pointer x)
+{
+ if ((!(is_input_port(x))) ||
+ (port_is_closed(x)))
+ return(method_or_bust_p(sc, x, sc->port_line_number_symbol, an_input_port_string));
+ return(make_integer(sc, port_line_number(x)));
+}
+
+static s7_pointer g_port_line_number(s7_scheme *sc, s7_pointer args)
+{
+ #define H_port_line_number "(port-line-number input-file-port) returns the current read line number of port"
+ #define Q_port_line_number s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_input_port_symbol)
+ return(port_line_number_p_p(sc, (is_null(args)) ? current_input_port(sc) : car(args)));
+}
+
+s7_int s7_port_line_number(s7_scheme *sc, s7_pointer p)
+{
+ if (!(is_input_port(p)))
+ sole_arg_wrong_type_error_nr(sc, sc->port_line_number_symbol, p, sc->type_names[T_INPUT_PORT]);
+ return(port_line_number(p));
+}
+
+static s7_pointer g_set_port_line_number(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p, line;
+ if ((is_null(car(args))) ||
+ ((is_null(cdr(args))) && (is_t_integer(car(args)))))
+ p = current_input_port(sc);
+ else
+ {
+ 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);
+ }
+ line = (is_null(cdr(args)) ? car(args) : cadr(args));
+ if (!is_t_integer(line))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! port-line-number", 21), 2, line, sc->type_names[T_INTEGER]);
+ port_line_number(p) = integer(line);
+ return(line);
+}
+
+
+/* -------------------------------- port-filename -------------------------------- */
+const char *s7_port_filename(s7_scheme *sc, s7_pointer x)
+{
+ if (((is_input_port(x)) ||
+ (is_output_port(x))) &&
+ (!port_is_closed(x)))
+ return(port_filename(x));
+ return(NULL);
+}
+
+static s7_pointer port_filename_p_p(s7_scheme *sc, s7_pointer x)
+{
+ if (((is_input_port(x)) || (is_output_port(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! */
+ }
+ return(nil_string);
+ /* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */
+ }
+ return(method_or_bust_p(sc, x, sc->port_filename_symbol, wrap_string(sc, "an open port", 12)));
+}
+
+static s7_pointer g_port_filename(s7_scheme *sc, s7_pointer args)
+{
+ #define H_port_filename "(port-filename file-port) returns the filename associated with port"
+ #define Q_port_filename s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_output_port_symbol))
+ return(port_filename_p_p(sc, (is_null(args)) ? current_input_port(sc) : car(args)));
+}
+
+
+/* -------------------------------- pair-line-number -------------------------------- */
+static s7_pointer pair_line_number_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_pair(p))
+ return(method_or_bust_p(sc, p, sc->pair_line_number_symbol, sc->type_names[T_PAIR]));
+ return((has_location(p)) ? make_integer(sc, pair_line_number(p)) : sc->F);
+}
+
+static s7_pointer g_pair_line_number(s7_scheme *sc, s7_pointer args)
+{
+ #define H_pair_line_number "(pair-line-number pair) returns the line number at which it read 'pair', or #f if no such number is available"
+ #define Q_pair_line_number s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->not_symbol), sc->is_pair_symbol)
+ return(pair_line_number_p_p(sc, car(args)));
+}
+
+
+/* -------------------------------- pair-filename -------------------------------- */
+static s7_pointer g_pair_filename(s7_scheme *sc, s7_pointer args)
+{
+ #define H_pair_filename "(pair-filename pair) returns the name of the file containing 'pair'"
+ #define Q_pair_filename s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), sc->is_pair_symbol)
+
+ s7_pointer p = car(args);
+ if (is_pair(p))
+ return((has_location(p)) ? sc->file_names[pair_file_number(p)] : sc->F); /* maybe also pair_file_number(p) > 0 */
+ check_method(sc, p, sc->pair_filename_symbol, args);
+ sole_arg_wrong_type_error_nr(sc, sc->pair_filename_symbol, p, sc->type_names[T_PAIR]);
+ return(NULL);
+}
+
+
+/* -------------------------------- input-port? -------------------------------- */
+bool s7_is_input_port(s7_scheme *sc, s7_pointer p) {return(is_input_port(p));}
+static bool is_input_port_b(s7_pointer p) {return(is_input_port(p));}
+
+static s7_pointer g_is_input_port(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_input_port "(input-port? p) returns #t if p is an input port"
+ #define Q_is_input_port sc->pl_bt
+ check_boolean_method(sc, is_input_port, sc->is_input_port_symbol, args);
+}
+
+
+/* -------------------------------- output-port? -------------------------------- */
+bool s7_is_output_port(s7_scheme *sc, s7_pointer p) {return(is_output_port(p));}
+static bool is_output_port_b(s7_pointer p) {return(is_output_port(p));}
+
+static s7_pointer g_is_output_port(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_output_port "(output-port? p) returns #t if p is an output port"
+ #define Q_is_output_port sc->pl_bt
+ check_boolean_method(sc, is_output_port, sc->is_output_port_symbol, args);
+}
+
+
+/* -------------------------------- current-input-port -------------------------------- */
+s7_pointer s7_current_input_port(s7_scheme *sc) {return(current_input_port(sc));}
+
+static s7_pointer g_current_input_port(s7_scheme *sc, s7_pointer unused_args)
+{
+ #define H_current_input_port "(current-input-port) returns the current input port"
+ #define Q_current_input_port s7_make_signature(sc, 1, sc->is_input_port_symbol)
+ return(current_input_port(sc));
+}
+
+static s7_pointer g_set_current_input_port(s7_scheme *sc, s7_pointer args)
+{
+ #define H_set_current_input_port "(set-current-input-port port) sets the current-input port to port and returns the previous value of the input port"
+ #define Q_set_current_input_port s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_input_port_symbol)
+
+ s7_pointer port = car(args), old_port = current_input_port(sc);
+ if ((is_input_port(port)) &&
+ (!port_is_closed(port)))
+ set_current_input_port(sc, port);
+ else
+ {
+ check_method(sc, port, sc->set_current_input_port_symbol, args);
+ sole_arg_wrong_type_error_nr(sc, sc->set_current_input_port_symbol, port, an_open_input_port_string);
+ }
+ return(old_port);
+}
+
+s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer port)
+{
+ s7_pointer old_port = current_input_port(sc);
+ set_current_input_port(sc, port);
+ return(old_port);
+}
+
+
+/* -------------------------------- current-output-port -------------------------------- */
+s7_pointer s7_current_output_port(s7_scheme *sc) {return(current_output_port(sc));}
+
+s7_pointer s7_set_current_output_port(s7_scheme *sc, s7_pointer port)
+{
+ s7_pointer old_port = current_output_port(sc);
+ set_current_output_port(sc, port);
+ return(old_port);
+}
+
+static s7_pointer g_current_output_port(s7_scheme *sc, s7_pointer unused_args)
+{
+ #define H_current_output_port "(current-output-port) returns the current output port"
+ #define Q_current_output_port s7_make_signature(sc, 1, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
+ return(current_output_port(sc));
+}
+
+static s7_pointer g_set_current_output_port(s7_scheme *sc, s7_pointer args)
+{
+ #define H_set_current_output_port "(set-current-output-port port) sets the current-output port to port and returns the previous value of the output port"
+ #define Q_set_current_output_port s7_make_signature(sc, 2, \
+ s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), \
+ s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
+ s7_pointer port = car(args);
+ s7_pointer old_port = current_output_port(sc);
+ if (((is_output_port(port)) &&
+ (!port_is_closed(port))) || (port == sc->F))
+ set_current_output_port(sc, port);
+ else
+ {
+ check_method(sc, port, sc->set_current_output_port_symbol, args);
+ sole_arg_wrong_type_error_nr(sc, sc->set_current_output_port_symbol, port, an_output_port_or_f_string);
+ }
+ return(old_port);
+}
+
+
+/* -------------------------------- current-error-port -------------------------------- */
+s7_pointer s7_current_error_port(s7_scheme *sc) {return(current_error_port(sc));}
+
+s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port)
+{
+ s7_pointer old_port = current_error_port(sc);
+ set_current_error_port(sc, port);
+ return(old_port);
+}
+
+static s7_pointer g_current_error_port(s7_scheme *sc, s7_pointer unused_args)
+{
+ #define H_current_error_port "(current-error-port) returns the current error port"
+ #define Q_current_error_port s7_make_signature(sc, 1, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
+ return(current_error_port(sc));
+}
+
+static s7_pointer g_set_current_error_port(s7_scheme *sc, s7_pointer args)
+{
+ #define H_set_current_error_port "(set-current-error-port port) sets the current-error port to port and returns the previous value of the error port"
+ #define Q_set_current_error_port s7_make_signature(sc, 2, \
+ s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), \
+ s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
+ s7_pointer port = car(args);
+ s7_pointer old_port = current_error_port(sc);
+ if (((is_output_port(port)) &&
+ (!port_is_closed(port))) || (port == sc->F))
+ set_current_error_port(sc, port);
+ else
+ {
+ check_method(sc, port, sc->set_current_error_port_symbol, args);
+ sole_arg_wrong_type_error_nr(sc, sc->set_current_error_port_symbol, port, an_output_port_or_f_string);
+ }
+ return(old_port);
+}
+
+
+/* -------------------------------- char-ready? -------------------------------- */
+#if (!WITH_PURE_S7)
+static s7_pointer g_is_char_ready(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_char_ready "(char-ready? (port (current-input-port))) returns #t if a character is ready for input on the given port"
+ #define Q_is_char_ready s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_input_port_symbol)
+ s7_pointer pt, res;
+
+ if (is_null(args))
+ return(make_boolean(sc, (is_input_port(current_input_port(sc))) && (is_string_port(current_input_port(sc)))));
+
+ pt = car(args);
+ if (!is_input_port(pt))
+ return(method_or_bust_p(sc, pt, sc->is_char_ready_symbol, an_input_port_string));
+ if (port_is_closed(pt))
+ sole_arg_wrong_type_error_nr(sc, sc->is_char_ready_symbol, pt, an_open_input_port_string);
+ if (!is_function_port(pt))
+ return(make_boolean(sc, is_string_port(pt)));
+
+ res = (*(port_input_function(pt)))(sc, S7_IS_CHAR_READY, pt);
+ if (is_multiple_value(res)) /* can only happen if more than one value in res */
+ {
+ clear_multiple_value(res);
+ error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port char-ready? returned: ~S", 44), res));
+ }
+ return(make_boolean(sc, (res != sc->F))); /* char-ready? returns a boolean */
+}
+#endif
+
+/* -------- ports -------- */
+static int32_t closed_port_read_char(s7_scheme *sc, s7_pointer port);
+static s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol);
+static void closed_port_write_char(s7_scheme *sc, uint8_t c, s7_pointer port);
+static void closed_port_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port);
+static void closed_port_display(s7_scheme *sc, const char *s, s7_pointer port);
+
+static void close_closed_port(s7_scheme *sc, s7_pointer port) {return;}
+
+static port_functions_t closed_port_functions =
+ {closed_port_read_char, closed_port_write_char, closed_port_write_string, NULL, NULL, NULL, NULL,
+ closed_port_read_line, closed_port_display, close_closed_port};
+
+
+static void close_input_file(s7_scheme *sc, s7_pointer p)
+{
+ if (port_filename(p)) /* for string ports, this is the original input file name */
+ {
+ liberate(sc, port_filename_block(p));
+ port_filename(p) = NULL;
+ }
+ if (port_file(p))
+ {
+ fclose(port_file(p));
+ port_file(p) = NULL;
+ }
+ if (port_needs_free(p))
+ free_port_data(sc, p);
+
+ port_port(p)->pf = &closed_port_functions;
+ port_set_closed(p, true);
+ port_position(p) = 0;
+}
+
+static void close_input_string(s7_scheme *sc, s7_pointer p)
+{
+ if (port_filename(p)) /* for string ports, this is the original input file name */
+ {
+ liberate(sc, port_filename_block(p));
+ port_filename(p) = NULL;
+ }
+ if (port_needs_free(p))
+ free_port_data(sc, p);
+
+ port_port(p)->pf = &closed_port_functions;
+ port_set_closed(p, true);
+ port_position(p) = 0;
+}
+
+static void close_simple_input_string(s7_scheme *sc, s7_pointer p)
+{
+#if S7_DEBUGGING
+ if (port_filename(p)) fprintf(stderr, "%s: port has a filename\n", __func__);
+ if (port_needs_free(p)) fprintf(stderr, "%s: port needs free\n", __func__);
+#endif
+ port_port(p)->pf = &closed_port_functions;
+ port_set_closed(p, true);
+ port_position(p) = 0;
+}
+
+void s7_close_input_port(s7_scheme *sc, s7_pointer p) {port_close(p)(sc, p);}
+
+
+/* -------------------------------- close-input-port -------------------------------- */
+static s7_pointer g_close_input_port(s7_scheme *sc, s7_pointer args)
+{
+ #define H_close_input_port "(close-input-port port) closes the port"
+ #define Q_close_input_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, sc->is_input_port_symbol)
+
+ s7_pointer pt = car(args);
+ if (!is_input_port(pt))
+ return(method_or_bust_p(sc, pt, sc->close_input_port_symbol, an_input_port_string));
+ if ((!is_immutable_port(pt)) && /* (close-input-port *stdin*) */
+ (!is_loader_port(pt))) /* top-level unmatched (close-input-port (current-input-port)) should not clobber the loader's input port */
+ s7_close_input_port(sc, pt);
+ return(sc->unspecified);
+}
+
+
+/* -------------------------------- flush-output-port -------------------------------- */
+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)));
+}
+
+bool s7_flush_output_port(s7_scheme *sc, s7_pointer p)
+{
+ bool result = true;
+ if ((is_output_port(p)) && /* type=T_OUTPUT_PORT, so this excludes #f */
+ (is_file_port(p)) &&
+ (!port_is_closed(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;
+ }
+ if (fflush(port_file(p)) == -1)
+ file_error_nr(sc, "flush-output-port", strerror(errno), port_filename(p));
+ }
+ return(result);
+}
+
+static s7_pointer g_flush_output_port(s7_scheme *sc, s7_pointer args)
+{
+ #define H_flush_output_port "(flush-output-port port) flushes the file port (that is, it writes any accumulated output to the output file)"
+ #define Q_flush_output_port s7_make_signature(sc, 2, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
+
+ s7_pointer pt = (is_null(args)) ? current_output_port(sc) : car(args);
+ if (!is_output_port(pt))
+ {
+ if (pt == sc->F) return(pt);
+ check_method(sc, pt, sc->flush_output_port_symbol, args);
+ sole_arg_wrong_type_error_nr(sc, sc->flush_output_port_symbol, pt, an_output_port_or_f_string);
+ }
+ if (!s7_flush_output_port(sc, pt))
+ error_nr(sc, sc->io_error_symbol, set_elist_2(sc, wrap_string(sc, "flush-output-port ~S failed", 27), pt));
+ return(pt);
+}
+
+
+/* -------------------------------- close-output-port -------------------------------- */
+static void close_output_file(s7_scheme *sc, s7_pointer p)
+{
+ if (port_filename(p)) /* only a file output port has a filename(?) */
+ {
+ liberate(sc, port_filename_block(p));
+ port_filename(p) = NULL;
+ port_filename_length(p) = 0;
+ }
+ if (port_file(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");
+#else
+ if (port_position(p) > 0)
+ 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));
+ fclose(port_file(p));
+ port_file(p) = NULL;
+ }
+ port_port(p)->pf = &closed_port_functions;
+ port_set_closed(p, true);
+ port_position(p) = 0;
+}
+
+static void close_output_string(s7_scheme *sc, s7_pointer p)
+{
+ if (port_data(p))
+ {
+ port_data(p) = NULL;
+ port_data_size(p) = 0;
+ }
+ port_port(p)->pf = &closed_port_functions;
+ port_set_closed(p, true);
+ port_position(p) = 0;
+}
+
+static void close_output_port(s7_scheme *sc, s7_pointer p) {port_close(p)(sc, p);}
+
+void s7_close_output_port(s7_scheme *sc, s7_pointer p)
+{
+ if ((p == sc->F) || (is_immutable_port(p))) return; /* can these happen? */
+ close_output_port(sc, p);
+}
+
+static s7_pointer g_close_output_port(s7_scheme *sc, s7_pointer args)
+{
+ #define H_close_output_port "(close-output-port port) closes the port"
+ #define Q_close_output_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
+
+ s7_pointer pt = car(args);
+ if (!is_output_port(pt))
+ {
+ if (pt == sc->F) return(sc->unspecified);
+ check_method(sc, pt, sc->close_output_port_symbol, args);
+ sole_arg_wrong_type_error_nr(sc, sc->close_output_port_symbol, pt, an_output_port_or_f_string);
+ }
+ s7_close_output_port(sc, pt);
+ return(sc->unspecified);
+}
+
+
+/* -------- read character functions -------- */
+
+static int32_t file_read_char(s7_scheme *sc, s7_pointer port) {return(fgetc(port_file(port)));}
+
+static int32_t function_read_char(s7_scheme *sc, s7_pointer port)
+{
+ s7_pointer res = (*(port_input_function(port)))(sc, S7_READ_CHAR, port);
+ if (is_eof(res)) return(EOF);
+ 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));
+ }
+ 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! */
+}
+
+static int32_t string_read_char(s7_scheme *sc, s7_pointer port)
+{
+ return((port_data_size(port) <= port_position(port)) ? EOF : (uint8_t)port_data(port)[port_position(port)++]); /* port_string_length is 0 if no port string */
+}
+
+static int32_t output_read_char(s7_scheme *sc, s7_pointer port)
+{
+ sole_arg_wrong_type_error_nr(sc, sc->read_char_symbol, port, an_input_port_string);
+ return(0);
+}
+
+static int32_t closed_port_read_char(s7_scheme *sc, s7_pointer port)
+{
+ sole_arg_wrong_type_error_nr(sc, sc->read_char_symbol, port, an_open_input_port_string);
+ return(0);
+}
+
+
+/* -------- read line functions -------- */
+
+static s7_pointer output_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
+{
+ sole_arg_wrong_type_error_nr(sc, sc->read_line_symbol, port, an_input_port_string);
+ return(NULL);
+}
+
+static s7_pointer closed_port_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
+{
+ sole_arg_wrong_type_error_nr(sc, sc->read_line_symbol, port, an_open_input_port_string);
+ return(NULL);
+}
+
+static s7_pointer function_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
+{
+ s7_pointer res = (*(port_input_function(port)))(sc, S7_READ_LINE, 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-line returned: ~S", 42), res));
+ }
+ return(res);
+}
+
+static s7_pointer stdin_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
+{
+ if (!sc->read_line_buf)
+ {
+ sc->read_line_buf_size = 1024;
+ sc->read_line_buf = (char *)Malloc(sc->read_line_buf_size);
+ }
+ if (fgets(sc->read_line_buf, sc->read_line_buf_size, stdin))
+ return(s7_make_string(sc, sc->read_line_buf)); /* fgets adds the trailing '\0' */
+ return(nil_string);
+}
+
+static s7_pointer file_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
+{
+ /* read into read_line_buf concatenating reads until newline found. string is read_line_buf to pos-of-newline.
+ * reset file position to reflect newline pos.
+ */
+ int32_t reads = 0;
+ char *str;
+ s7_int read_size;
+ if (!sc->read_line_buf)
+ {
+ sc->read_line_buf_size = 1024;
+ sc->read_line_buf = (char *)Malloc(sc->read_line_buf_size);
+ }
+ read_size = sc->read_line_buf_size;
+ str = fgets(sc->read_line_buf, read_size, port_file(port)); /* reads size-1 at most, EOF and newline also terminate read */
+ if (!str) return(eof_object); /* EOF or error with no char read */
+
+ while (true)
+ {
+ s7_int cur_size;
+ 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));
+ }
+ 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));
+
+ /* need more data */
+ sc->read_line_buf_size *= 2;
+ sc->read_line_buf = (char *)Realloc(sc->read_line_buf, sc->read_line_buf_size);
+ buf = (char *)(sc->read_line_buf + cur_size);
+ str = fgets(buf, read_size, port_file(port));
+ if (!str) return(eof_object);
+ read_size = sc->read_line_buf_size;
+ }
+ return(eof_object);
+}
+
+static s7_pointer string_read_line(s7_scheme *sc, s7_pointer port, bool with_eol)
+{
+ s7_int i;
+ const char *port_str = (const char *)port_data(port);
+ s7_int port_start = port_position(port);
+ const char *start = port_str + port_start;
+ const char *cur = (const char *)strchr(start, (int)'\n'); /* this can run off the end making valgrind unhappy, but I think it's innocuous */
+ if (cur)
+ {
+ port_line_number(port)++;
+ i = cur - port_str;
+ port_position(port) = i + 1;
+ return(inline_make_string_with_length(sc, start, ((with_eol) ? i + 1 : i) - port_start));
+ }
+ i = port_data_size(port);
+ port_position(port) = i;
+ if (i <= port_start) /* the < part can happen -- if not caught we try to create a string of length - 1 -> segfault */
+ return(eof_object);
+ return(make_string_with_length(sc, start, i - port_start));
+}
+
+
+/* -------- write character functions -------- */
+
+static void resize_port_data(s7_scheme *sc, s7_pointer pt, s7_int new_size)
+{
+ s7_int loc = port_data_size(pt);
+ block_t *nb;
+
+ 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)));
+
+ nb = reallocate(sc, port_data_block(pt), new_size);
+ port_data_block(pt) = nb;
+ port_data(pt) = (uint8_t *)(block_data(nb));
+ port_data_size(pt) = new_size;
+}
+
+static void string_write_char_resized(s7_scheme *sc, uint8_t c, s7_pointer pt)
+{
+ /* this division looks repetitive, but it is much faster */
+ resize_port_data(sc, pt, port_data_size(pt) * 2);
+ port_data(pt)[port_position(pt)++] = c;
+}
+
+static void string_write_char(s7_scheme *sc, uint8_t c, s7_pointer pt)
+{
+ if (port_position(pt) < port_data_size(pt))
+ port_data(pt)[port_position(pt)++] = c;
+ else string_write_char_resized(sc, c, pt);
+}
+
+static void stdout_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {fputc(c, stdout);}
+static void stderr_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {fputc(c, stderr);}
+
+static void function_write_char(s7_scheme *sc, uint8_t c, s7_pointer port)
+{
+ push_stack_direct(sc, OP_NO_VALUES);
+ /* sc->args = sc->nil; */
+ (*(port_output_function(port)))(sc, c, port);
+ unstack_with(sc, OP_NO_VALUES);
+#if 1
+ memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */
+#else
+ sc->code = stack_end_code(sc);
+ sc->args = stack_end_args(sc);
+#endif
+}
+
+static Inline void inline_file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port)
+{
+ if (port_position(port) == sc->output_file_port_data_size)
+ {
+ fwrite((void *)(port_data(port)), 1, sc->output_file_port_data_size, port_file(port));
+ port_position(port) = 0;
+ }
+ port_data(port)[port_position(port)++] = c;
+}
+
+static void file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {inline_file_write_char(sc, c, port);}
+
+static void input_write_char(s7_scheme *sc, uint8_t c, s7_pointer port)
+{
+ sole_arg_wrong_type_error_nr(sc, sc->write_char_symbol, port, an_output_port_string);
+}
+
+static void closed_port_write_char(s7_scheme *sc, uint8_t c, s7_pointer port)
+{
+ sole_arg_wrong_type_error_nr(sc, sc->write_char_symbol, port, an_open_output_port_string);
+}
+
+
+/* -------- write string functions -------- */
+
+static void input_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port)
+{
+ sole_arg_wrong_type_error_nr(sc, sc->write_symbol, port, an_output_port_string);
+}
+
+static void closed_port_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port)
+{
+ sole_arg_wrong_type_error_nr(sc, sc->write_symbol, port, an_open_output_port_string);
+}
+
+static void input_display(s7_scheme *sc, const char *s, s7_pointer port)
+{
+ sole_arg_wrong_type_error_nr(sc, sc->display_symbol, port, an_output_port_string);
+}
+
+static void closed_port_display(s7_scheme *sc, const char *s, s7_pointer port)
+{
+ sole_arg_wrong_type_error_nr(sc, sc->display_symbol, port, an_open_output_port_string);
+}
+
+static void stdout_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port)
+{
+ if (str[len] == '\0')
+ fputs(str, stdout);
+ else
+ for (s7_int i = 0; i < len; i++)
+ fputc(str[i], stdout);
+}
+
+static void stderr_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port)
+{
+ if (str[len] == '\0')
+ fputs(str, stderr);
+ else
+ for (s7_int i = 0; i < len; i++)
+ fputc(str[i], stderr);
+}
+
+static void string_write_string_resized(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt)
+{
+ s7_int new_len = port_position(pt) + len; /* len is known to be non-zero, str might not be 0-terminated */
+ resize_port_data(sc, pt, new_len * 2);
+ memcpy((void *)(port_data(pt) + port_position(pt)), (const void *)str, len);
+ port_position(pt) = new_len;
+}
+
+static void string_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt)
+{
+ if ((S7_DEBUGGING) && (len == 0)) {fprintf(stderr, "string_write_string len == 0\n"); abort();}
+ if (port_position(pt) + len < port_data_size(pt))
+ {
+ memcpy((void *)(port_data(pt) + port_position(pt)), (const void *)str, len);
+ /* memcpy is much faster than the equivalent while loop, and faster than using the 4-bytes-at-a-time shuffle */
+ port_position(pt) += len;
+ }
+ else string_write_string_resized(sc, str, len, pt);
+}
+
+static void file_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt)
+{
+ s7_int new_len = port_position(pt) + len;
+ 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");
+#else
+ fwrite((void *)(port_data(pt)), 1, port_position(pt), port_file(pt));
+#endif
+ port_position(pt) = 0;
+ }
+ fwrite((const void *)str, 1, len, port_file(pt));
+ }
+ else
+ {
+ memcpy((void *)(port_data(pt) + port_position(pt)), (const void *)str, len);
+ port_position(pt) = new_len;
+ }
+}
+
+static void string_display(s7_scheme *sc, const char *s, s7_pointer port)
+{
+ if (s) string_write_string(sc, s, safe_strlen(s), port);
+}
+
+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");
+#else
+ fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port));
+#endif
+ 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));
+#else
+ fputs(s, port_file(port));
+#endif
+ }
+}
+
+static void function_display(s7_scheme *sc, const char *s, s7_pointer port)
+{
+ if (!s) return;
+ push_stack_direct(sc, OP_NO_VALUES);
+ /* sc->args = sc->nil; */ /* is this needed? */
+ for (; *s; s++)
+ (*(port_output_function(port)))(sc, *s, port);
+ unstack_with(sc, OP_NO_VALUES);
+#if 1
+ memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */
+#else
+ sc->code = stack_end_code(sc); /* sc->curlet = stack_end_let(sc) */
+ sc->args = stack_end_args(sc);
+#endif
+}
+
+static void function_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer pt)
+{
+ push_stack_direct(sc, OP_NO_VALUES);
+ /* sc->args = sc->nil; */ /* is this needed? */
+ for (s7_int i = 0; i < len; i++)
+ (*(port_output_function(pt)))(sc, str[i], pt);
+ unstack_with(sc, OP_NO_VALUES);
+#if 1
+ memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */
+#else
+ sc->code = stack_end_code(sc);
+ sc->args = stack_end_args(sc);
+#endif
+}
+
+static void stdout_display(s7_scheme *sc, const char *s, s7_pointer port) {if (s) fputs(s, stdout);}
+static void stderr_display(s7_scheme *sc, const char *s, s7_pointer port) {if (s) fputs(s, stderr);}
+
+
+/* -------------------------------- write-string -------------------------------- */
+static s7_pointer g_write_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_write_string "(write-string str port start end) writes str to port."
+ #define Q_write_string s7_make_circular_signature(sc, 3, 4, \
+ sc->is_string_symbol, sc->is_string_symbol, \
+ s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol),\
+ sc->is_integer_symbol)
+ s7_pointer str = car(args), port;
+ s7_int start = 0, end;
+ if (!is_string(str))
+ return(method_or_bust(sc, str, sc->write_string_symbol, args, sc->type_names[T_STRING], 1));
+
+ end = string_length(str);
+ if (!is_null(cdr(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);
+ }}
+ 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));
+ }
+ 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);
+ }
+ if (port_is_closed(port)) wrong_type_error_nr(sc, sc->write_string_symbol, 2, port, an_open_output_port_string);
+ if (start == end) return(str);
+ port_write_string(port)(sc, (char *)(string_value(str) + start), (end - start), port);
+ return(str);
+}
+
+static s7_pointer write_string_p_pp(s7_scheme *sc, s7_pointer str, s7_pointer port)
+{
+ if (!is_string(str))
+ return(method_or_bust_pp(sc, str, sc->write_string_symbol, str, port, sc->type_names[T_STRING], 1));
+ if (!is_output_port(port))
+ {
+ if (port == sc->F) return(str);
+ return(method_or_bust_pp(sc, port, sc->write_string_symbol, str, port, an_output_port_string, 2));
+ }
+ if (string_length(str) > 0)
+ port_write_string(port)(sc, string_value(str), string_length(str), port);
+ return(str);
+}
+
+
+/* -------- skip to newline readers -------- */
+static token_t token(s7_scheme *sc);
+
+static token_t file_read_semicolon(s7_scheme *sc, s7_pointer pt)
+{
+ int32_t c;
+ do (c = fgetc(port_file(pt))); while ((c != '\n') && (c != EOF));
+ port_line_number(pt)++;
+ return((c == EOF) ? TOKEN_EOF : token(sc));
+}
+
+static token_t string_read_semicolon(s7_scheme *sc, s7_pointer pt)
+{
+ const char *str = (const char *)(port_data(pt) + port_position(pt));
+ const char *orig_str = strchr(str, (int)'\n');
+ if (!orig_str)
+ {
+ port_position(pt) = port_data_size(pt);
+ return(TOKEN_EOF);
+ }
+ port_position(pt) += (orig_str - str + 1); /* + 1 because strchr leaves orig_str pointing at the newline */
+ port_line_number(pt)++;
+ return(token(sc));
+}
+
+
+/* -------- white space readers -------- */
+
+static int32_t file_read_white_space(s7_scheme *sc, s7_pointer port)
+{
+ int32_t c;
+ while (is_white_space(c = fgetc(port_file(port))))
+ if (c == '\n')
+ port_line_number(port)++;
+ return(c);
+}
+
+static int32_t terminated_string_read_white_space(s7_scheme *sc, s7_pointer pt)
+{
+ const uint8_t *str = (const uint8_t *)(port_data(pt) + port_position(pt));
+ uint8_t c;
+ /* here we know we have null termination and white_space[#\null] is false */
+ while (white_space[c = *str++]) /* 255 is not -1 = EOF */
+ if (c == '\n')
+ port_line_number(pt)++;
+ port_position(pt) = (c) ? str - port_data(pt) : port_data_size(pt);
+ return((int32_t)c);
+}
+
+
+/* -------- name readers -------- */
+#define BASE_10 10
+
+static s7_pointer file_read_name_or_sharp(s7_scheme *sc, s7_pointer pt, bool atom_case)
+{
+ int32_t c;
+ s7_int i = 1; /* sc->strbuf[0] has the first char of the string we're reading */
+ do {
+ c = fgetc(port_file(pt)); /* might return EOF */
+ if (c == '\n')
+ port_line_number(pt)++;
+
+ sc->strbuf[i++] = (unsigned char)c;
+ if (i >= sc->strbuf_size)
+ resize_strbuf(sc, i);
+ } while ((c != EOF) && (char_ok_in_a_name[c]));
+
+ if ((i == 2) &&
+ (sc->strbuf[0] == '\\'))
+ sc->strbuf[2] = '\0';
+ else
+ {
+ if (c != EOF)
+ {
+ if (c == '\n')
+ port_line_number(pt)--;
+ ungetc(c, port_file(pt));
+ }
+ sc->strbuf[i - 1] = '\0';
+ }
+ if (atom_case)
+ return(make_atom(sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR));
+ return(make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true));
+}
+
+static s7_pointer file_read_name(s7_scheme *sc, s7_pointer pt) {return(file_read_name_or_sharp(sc, pt, true));}
+static s7_pointer file_read_sharp(s7_scheme *sc, s7_pointer pt) {return(file_read_name_or_sharp(sc, pt, false));}
+
+static s7_pointer string_read_name_no_free(s7_scheme *sc, s7_pointer pt)
+{
+ /* sc->strbuf[0] has the first char of the string we're reading */
+ s7_pointer result;
+ uint8_t *str = (uint8_t *)(port_data(pt) + port_position(pt));
+
+ if (char_ok_in_a_name[*str])
+ {
+ s7_int k;
+ uint8_t *orig_str = str - 1;
+ str++;
+ while (char_ok_in_a_name[*str]) str++;
+ k = str - orig_str;
+ if (*str != 0)
+ port_position(pt) += (k - 1);
+ else port_position(pt) = port_data_size(pt);
+ /* this is equivalent to:
+ * str = strpbrk(str, "(); \"\t\r\n");
+ * if (!str) {k = strlen(orig_str); str = (char *)(orig_str + k);} else k = str - orig_str;
+ * but slightly faster.
+ */
+ if (!number_table[*orig_str])
+ 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);
+
+ memcpy((void *)(sc->strbuf), (void *)orig_str, k);
+ sc->strbuf[k] = '\0';
+ return(make_atom(sc, sc->strbuf, BASE_10, SYMBOL_OK, WITH_OVERFLOW_ERROR));
+ }
+ result = sc->singletons[(uint8_t)(sc->strbuf[0])];
+ if (!result)
+ {
+ sc->strbuf[1] = '\0';
+ result = make_symbol(sc, sc->strbuf, 1);
+ sc->singletons[(uint8_t)(sc->strbuf[0])] = result;
+ }
+ return(result);
+}
+
+static s7_pointer string_read_sharp(s7_scheme *sc, s7_pointer pt)
+{
+ /* sc->strbuf[0] has the first char of the string we're reading.
+ * since a *#readers* function might want to get further input, we can't mess with the input even when it is otherwise safe
+ */
+ char *str = (char *)(port_data(pt) + port_position(pt));
+ if (char_ok_in_a_name[(uint8_t)*str])
+ {
+ s7_int k;
+ char *orig_str = (char *)(str - 1);
+ str++;
+ while (char_ok_in_a_name[(uint8_t)(*str)]) {str++;}
+ k = str - orig_str;
+ port_position(pt) += (k - 1);
+ if ((k + 1) >= sc->strbuf_size)
+ 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));
+ }
+ if (sc->strbuf[0] == 'f')
+ return(sc->F);
+ if (sc->strbuf[0] == 't')
+ return(sc->T);
+ if (sc->strbuf[0] == '\\')
+ {
+ /* must be from #\( and friends -- a character that happens to be not ok-in-a-name */
+ sc->strbuf[1] = str[0];
+ sc->strbuf[2] = '\0';
+ port_position(pt)++;
+ }
+ else sc->strbuf[1] = '\0';
+ return(make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, pt, true));
+}
+
+static s7_pointer string_read_name(s7_scheme *sc, s7_pointer pt)
+{
+ /* port_string was allocated (and read from a file) so we can mess with it directly */
+ s7_pointer result;
+ uint8_t *str = (uint8_t *)(port_data(pt) + port_position(pt));
+ if (char_ok_in_a_name[*str])
+ {
+ s7_int k;
+ uint8_t endc;
+ uint8_t *orig_str = str - 1;
+ str++;
+ while (char_ok_in_a_name[*str]) str++;
+ k = str - orig_str;
+ port_position(pt) += (k - 1);
+ if (!number_table[*orig_str])
+ 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);
+ *str = endc;
+ return(result);
+ }
+ result = sc->singletons[(uint8_t)(sc->strbuf[0])];
+ if (!result)
+ {
+ sc->strbuf[1] = '\0';
+ result = make_symbol(sc, sc->strbuf, 1);
+ sc->singletons[(uint8_t)(sc->strbuf[0])] = result;
+ }
+ return(result);
+}
+
+static void port_set_filename(s7_scheme *sc, s7_pointer p, const char *name, size_t len)
+{
+ block_t *b = inline_mallocate(sc, len + 1);
+ port_filename_block(p) = b;
+ port_filename(p) = (char *)block_data(b);
+ memcpy((void *)block_data(b), (const void *)name, len);
+ port_filename(p)[len] = '\0';
+}
+
+static block_t *mallocate_port(s7_scheme *sc)
+{
+ #define PORT_LIST 8 /* sizeof(port_t): 160 */
+ block_t *p = sc->block_lists[PORT_LIST];
+ if (p)
+ sc->block_lists[PORT_LIST] = (block_t *)block_next(p);
+ else
+ { /* this is mallocate without the index calc */
+ p = mallocate_block(sc);
+ block_data(p) = (void *)permalloc(sc, (size_t)(1 << PORT_LIST));
+ block_set_index(p, PORT_LIST);
+ }
+ block_set_size(p, sizeof(port_t));
+ return(p);
+}
+
+static port_functions_t input_file_functions =
+ {file_read_char, input_write_char, input_write_string, file_read_semicolon, file_read_white_space,
+ file_read_name, file_read_sharp, file_read_line, input_display, close_input_file};
+
+static port_functions_t input_string_functions_1 =
+ {string_read_char, input_write_char, input_write_string, string_read_semicolon, terminated_string_read_white_space,
+ string_read_name, string_read_sharp, string_read_line, input_display, close_input_string};
+
+static s7_pointer read_file(s7_scheme *sc, FILE *fp, const char *name, s7_int max_size, const char *caller)
+{
+ s7_pointer port;
+#if (!MS_WINDOWS)
+ s7_int size;
+#endif
+ block_t *b = mallocate_port(sc);
+ new_cell(sc, port, T_INPUT_PORT);
+ gc_protect_via_stack(sc, port);
+ port_block(port) = b;
+ port_port(port) = (port_t *)block_data(b);
+ port_set_closed(port, false);
+ port_set_string_or_function(port, sc->nil);
+ /* if we're constantly opening files, and each open saves the file name in permanent memory, we gradually core-up */
+ port_filename_length(port) = safe_strlen(name);
+ port_set_filename(sc, port, name, port_filename_length(port));
+ port_line_number(port) = 1; /* first line is numbered 1 */
+ port_file_number(port) = 0;
+ add_input_port(sc, port);
+
+#if (!MS_WINDOWS)
+ /* this doesn't work in MS C */
+ fseek(fp, 0, SEEK_END);
+ size = ftell(fp);
+ rewind(fp);
+
+ /* pseudo files (under /proc for example) have size=0, but we can read them, so don't assume a 0 length file is empty */
+
+ if ((size > 0) && /* if (size != 0) we get (open-input-file "/dev/tty") -> (open "/dev/tty") read 0 bytes of an expected -1? */
+ ((max_size < 0) || (size < max_size))) /* load uses max_size = -1 */
+ {
+ block_t *block = mallocate(sc, size + 2);
+ 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;
+ }
+ content[size] = '\0';
+ content[size + 1] = '\0';
+ fclose(fp);
+
+ port_file(port) = NULL; /* make valgrind happy */
+ port_type(port) = STRING_PORT;
+ port_data(port) = content;
+ port_data_block(port) = block;
+ port_data_size(port) = size;
+ port_position(port) = 0;
+ port_needs_free(port) = true;
+ port_port(port)->pf = &input_string_functions_1;
+ }
+ else
+ {
+ port_file(port) = fp;
+ port_type(port) = FILE_PORT;
+ port_data(port) = NULL;
+ port_data_block(port) = NULL;
+ port_data_size(port) = 0;
+ port_position(port) = 0;
+ port_needs_free(port) = false;
+ port_port(port)->pf = &input_file_functions;
+ }
+#else
+ /* _stat64 is no better than the fseek/ftell route, and
+ * GetFileSizeEx and friends requires Windows.h which makes hash of everything else.
+ * fread until done takes too long on big files, so use a file port
+ */
+ port_file(port) = fp;
+ port_type(port) = FILE_PORT;
+ port_needs_free(port) = false;
+ port_data(port) = NULL;
+ port_data_block(port) = NULL;
+ port_data_size(port) = 0;
+ port_position(port) = 0;
+ port_port(port)->pf = &input_file_functions;
+#endif
+ unstack_gc_protect(sc);
+ return(port);
+}
+
+
+/* -------------------------------- open-input-file -------------------------------- */
+static int32_t remember_file_name(s7_scheme *sc, const char *file)
+{
+ for (int32_t i = 0; i <= sc->file_names_top; i++)
+ if (safe_strcmp(file, string_value(sc->file_names[i])))
+ return(i);
+
+ sc->file_names_top++;
+ if (sc->file_names_top >= sc->file_names_size)
+ {
+ 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));
+ }
+ 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));
+ }
+ for (int32_t i = old_size; i < sc->file_names_size; i++)
+ sc->file_names[i] = sc->F;
+ }
+ sc->file_names[sc->file_names_top] = s7_make_semipermanent_string(sc, file);
+ return(sc->file_names_top);
+}
+
+
+#ifndef MAX_SIZE_FOR_STRING_PORT
+ #define MAX_SIZE_FOR_STRING_PORT 10000000
+#endif
+
+static s7_pointer make_input_file(s7_scheme *sc, const char *name, FILE *fp)
+{
+ return(read_file(sc, fp, name, MAX_SIZE_FOR_STRING_PORT, "open"));
+}
+
+
+#if (!MS_WINDOWS)
+#include <sys/stat.h>
+#endif
+
+static bool is_directory(const char *filename)
+{
+#if (!MS_WINDOWS)
+ #ifdef S_ISDIR
+ struct stat statbuf;
+ return((stat(filename, &statbuf) >= 0) &&
+ (S_ISDIR(statbuf.st_mode)));
+ #endif
+#endif
+ return(false);
+}
+
+static block_t *expand_filename(s7_scheme *sc, const char *name)
+{
+#if WITH_GCC
+ if ((name[0] == '~') && (name[1] == '/')) /* catch one special case, "~/..." */
+ {
+ 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);
+ }}
+#endif
+ return(NULL);
+}
+
+static s7_pointer open_input_file_1(s7_scheme *sc, const char *name, const char *mode, const char *caller)
+{
+ FILE *fp;
+#if WITH_GCC
+ block_t *b;
+#endif
+ /* see if we can open this file before allocating a port */
+ if (is_directory(name))
+ file_error_nr(sc, caller, "file is a directory:", name);
+ errno = 0;
+ fp = fopen(name, mode);
+ if (fp)
+ return(make_input_file(sc, name, fp));
+
+#if (!MS_WINDOWS)
+ if (errno == EINVAL)
+ file_error_nr(sc, caller, "invalid mode", mode);
+#if WITH_GCC
+ if ((!name) || (!*name))
+ file_error_nr(sc, caller, strerror(errno), name);
+ b = expand_filename(sc, name);
+ if (b)
+ {
+ char *new_name = (char *)block_data(b);
+ fp = fopen(new_name, mode);
+ liberate(sc, b);
+ if (fp)
+ return(make_input_file(sc, name, fp));
+ }
+#endif
+#endif
+ file_error_nr(sc, caller, strerror(errno), name);
+ return(sc->io_error_symbol);
+}
+
+s7_pointer s7_open_input_file(s7_scheme *sc, const char *name, const char *mode)
+{
+ return(open_input_file_1(sc, name, mode, "open-input-file"));
+}
+
+static s7_pointer g_open_input_file(s7_scheme *sc, s7_pointer args)
+{
+ #define H_open_input_file "(open-input-file filename (mode \"r\")) opens filename for reading"
+ #define Q_open_input_file s7_make_signature(sc, 3, sc->is_input_port_symbol, sc->is_string_symbol, sc->is_string_symbol)
+
+ s7_pointer mode, name = car(args);
+ /* open-input-file can create a new output file if the file to be opened does not exist, and the "a" mode is given */
+
+ if (!is_string(name))
+ return(method_or_bust(sc, name, sc->open_input_file_symbol, args, sc->type_names[T_STRING], 1));
+ if (!is_pair(cdr(args)))
+ return(open_input_file_1(sc, string_value(name), "r", "open-input-file"));
+
+ mode = cadr(args);
+ if (!is_string(mode))
+ return(method_or_bust(sc, mode, sc->open_input_file_symbol, args, wrap_string(sc, "a string (a mode such as \"r\")", 29), 2));
+ /* since scheme allows embedded nulls, dumb stuff is accepted here: (open-input-file file "a\x00b") -- should this be an error? */
+ return(open_input_file_1(sc, string_value(name), string_value(mode), "open-input-file"));
+}
+
+static void close_stdin(s7_scheme *sc, s7_pointer port) {return;}
+static void close_stdout(s7_scheme *sc, s7_pointer port) {return;}
+static void close_stderr(s7_scheme *sc, s7_pointer port) {return;}
+
+static const port_functions_t stdin_functions =
+ {file_read_char, input_write_char, input_write_string, file_read_semicolon, file_read_white_space,
+ file_read_name, file_read_sharp, stdin_read_line, input_display, close_stdin};
+
+static const port_functions_t stdout_functions =
+ {output_read_char, stdout_write_char, stdout_write_string, NULL, NULL, NULL, NULL, output_read_line, stdout_display, close_stdout};
+
+static const port_functions_t stderr_functions =
+ {output_read_char, stderr_write_char, stderr_write_string, NULL, NULL, NULL, NULL, output_read_line, stderr_display, close_stderr};
+
+static void init_standard_ports(s7_scheme *sc)
+{
+ s7_pointer x;
+
+ /* standard output */
+ x = alloc_pointer(sc);
+ set_full_type(x, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP);
+ port_port(x) = (port_t *)Calloc(1, sizeof(port_t));
+ port_type(x) = FILE_PORT;
+ port_data(x) = NULL;
+ port_data_block(x) = NULL;
+ port_set_closed(x, false);
+ port_filename_length(x) = 8;
+ port_set_filename(sc, x, "*stdout*", 8);
+ port_file_number(x) = remember_file_name(sc, port_filename(x)); /* these numbers need to be correct for the evaluator (*function* data) */
+ port_line_number(x) = 0;
+ port_file(x) = stdout;
+ port_needs_free(x) = false;
+ port_port(x)->pf = &stdout_functions;
+ sc->standard_output = x;
+
+ /* standard error */
+ x = alloc_pointer(sc);
+ set_full_type(x, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP);
+ port_port(x) = (port_t *)Calloc(1, sizeof(port_t));
+ port_type(x) = FILE_PORT;
+ port_data(x) = NULL;
+ port_data_block(x) = NULL;
+ port_set_closed(x, false);
+ port_filename_length(x) = 8;
+ port_set_filename(sc, x, "*stderr*", 8);
+ port_file_number(x) = remember_file_name(sc, port_filename(x));
+ port_line_number(x) = 0;
+ port_file(x) = stderr;
+ port_needs_free(x) = false;
+ port_port(x)->pf = &stderr_functions;
+ sc->standard_error = x;
+
+ /* standard input */
+ x = alloc_pointer(sc);
+ set_full_type(x, T_INPUT_PORT | T_IMMUTABLE | T_UNHEAP);
+ port_port(x) = (port_t *)Calloc(1, sizeof(port_t));
+ port_type(x) = FILE_PORT;
+ port_set_closed(x, false);
+ port_set_string_or_function(x, sc->nil);
+ port_filename_length(x) = 7;
+ port_set_filename(sc, x, "*stdin*", 7);
+ port_file_number(x) = remember_file_name(sc, port_filename(x));
+ port_line_number(x) = 0;
+ port_file(x) = stdin;
+ port_data_block(x) = NULL;
+ port_needs_free(x) = false;
+ port_port(x)->pf = &stdin_functions;
+ sc->standard_input = x;
+
+ s7_define_variable_with_documentation(sc, "*stdin*", sc->standard_input, "*stdin* is the built-in input port, C's stdin");
+ s7_define_variable_with_documentation(sc, "*stdout*", sc->standard_output, "*stdout* is the built-in buffered output port, C's stdout");
+ s7_define_variable_with_documentation(sc, "*stderr*", sc->standard_error, "*stderr* is the built-in unbuffered output port, C's stderr");
+
+ set_current_input_port(sc, sc->standard_input);
+ set_current_output_port(sc, sc->standard_output);
+ set_current_error_port(sc, sc->standard_error);
+ sc->current_file = NULL;
+ sc->current_line = -1;
+}
+
+
+/* -------------------------------- open-output-file -------------------------------- */
+static const port_functions_t output_file_functions =
+ {output_read_char, file_write_char, file_write_string, NULL, NULL, NULL, NULL, output_read_line, file_display, close_output_file};
+
+s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode)
+{
+ FILE *fp;
+ s7_pointer x;
+ block_t *block, *b;
+ /* see if we can open this file before allocating a port */
+
+ errno = 0;
+ fp = fopen(name, mode);
+ if (!fp)
+ {
+#if (!MS_WINDOWS)
+ if (errno == EINVAL)
+ file_error_nr(sc, "open-output-file", "invalid mode", mode);
+#endif
+ file_error_nr(sc, "open-output-file", strerror(errno), name);
+ }
+ new_cell(sc, x, T_OUTPUT_PORT);
+ b = mallocate_port(sc);
+ port_block(x) = b;
+ port_port(x) = (port_t *)block_data(b);
+ port_type(x) = FILE_PORT;
+ port_set_closed(x, false);
+ port_filename_length(x) = safe_strlen(name);
+ port_set_filename(sc, x, name, port_filename_length(x));
+ port_line_number(x) = 1;
+ port_file_number(x) = 0;
+ port_file(x) = fp;
+ port_needs_free(x) = true; /* hmm -- I think these are freed via s7_close_output_port -> close_output_port */
+ port_position(x) = 0;
+ port_data_size(x) = sc->output_file_port_data_size;
+ block = mallocate(sc, sc->output_file_port_data_size);
+ port_data_block(x) = block;
+ port_data(x) = (uint8_t *)(block_data(block));
+ port_port(x)->pf = &output_file_functions;
+ add_output_port(sc, x);
+ return(x);
+}
+
+static s7_pointer g_open_output_file(s7_scheme *sc, s7_pointer args)
+{
+ #define H_open_output_file "(open-output-file filename (mode \"w\")) opens filename for writing"
+ #define Q_open_output_file s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_string_symbol, sc->is_string_symbol)
+
+ s7_pointer name = car(args);
+ if (!is_string(name))
+ return(method_or_bust(sc, name, sc->open_output_file_symbol, args, sc->type_names[T_STRING], 1));
+ if (!is_pair(cdr(args)))
+ return(s7_open_output_file(sc, string_value(name), "w"));
+ if (!is_string(cadr(args)))
+ return(method_or_bust(sc, cadr(args), sc->open_output_file_symbol, args, wrap_string(sc, "a string (a mode such as \"w\")", 29), 2));
+ return(s7_open_output_file(sc, string_value(name), string_value(cadr(args))));
+}
+
+
+/* -------------------------------- open-input-string -------------------------------- */
+
+/* a version of string ports using a pointer to the current location and a pointer to the end
+ * (rather than an integer for both, indexing from the base string) was not faster.
+ */
+
+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};
+
+static s7_pointer open_input_string(s7_scheme *sc, const char *input_string, s7_int len)
+{
+ s7_pointer x;
+ /* we could look for free entry in sc->input_string_ports and reuse it, but that takes longer than it saves,
+ * mainly because ports are marked free by the GC, so free entries happen once-in-a-long-while (while the list grows),
+ * and free_cell can't be used (freeze_t protecting the block). Perhaps free_frozen_cell (just sets type=T_FREE +(?) clears T_GC_MARKED),
+ * but how to recognize such cases (see tio.scm). Maybe a way in scheme to reuse such a port? (set! (port-string p) "asdf")?
+ */
+ block_t *b = mallocate_port(sc);
+ new_cell(sc, x, T_INPUT_PORT);
+ port_block(x) = b;
+ port_port(x) = (port_t *)block_data(b);
+ port_type(x) = STRING_PORT;
+ port_set_closed(x, false);
+ port_set_string_or_function(x, sc->nil);
+ port_data(x) = (uint8_t *)input_string;
+ port_data_block(x) = NULL;
+ port_data_size(x) = len;
+ port_position(x) = 0;
+ port_filename_block(x) = NULL;
+ port_filename_length(x) = 0;
+ port_filename(x) = NULL;
+ port_file_number(x) = 0;
+ port_line_number(x) = 0;
+ port_file(x) = NULL;
+ port_needs_free(x) = false;
+#if S7_DEBUGGING
+ 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);
+ if (sc->stop_at_error) abort();
+ }
+#endif
+ port_port(x)->pf = &input_string_functions;
+ add_input_string_port(sc, x);
+ return(x);
+}
+
+static /* inline */ s7_pointer open_and_protect_input_string(s7_scheme *sc, s7_pointer str)
+{
+ s7_pointer p = open_input_string(sc, string_value(str), string_length(str));
+ port_set_string_or_function(p, str);
+ return(p);
+}
+
+s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string)
+{
+ return(open_input_string(sc, input_string, safe_strlen(input_string)));
+}
+
+static s7_pointer g_open_input_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_open_input_string "(open-input-string str) opens an input port reading str"
+ #define Q_open_input_string s7_make_signature(sc, 2, sc->is_input_port_symbol, sc->is_string_symbol)
+
+ s7_pointer input_string = car(args);
+ if (!is_string(input_string))
+ return(sole_arg_method_or_bust(sc, input_string, sc->open_input_string_symbol, args, sc->type_names[T_STRING]));
+ return(open_and_protect_input_string(sc, input_string));
+}
+
+
+/* -------------------------------- open-output-string -------------------------------- */
+#define FORMAT_PORT_LENGTH 128
+/* the large majority (> 99% in my tests) of the output strings have less than 128 chars when the port is finally closed
+ * 256 is slightly slower (the calloc time below dominates the realloc time in string_write_string)
+ * 64 is much slower (realloc dominates)
+ */
+
+static const port_functions_t output_string_functions =
+ {output_read_char, string_write_char, string_write_string, NULL, NULL, NULL, NULL, output_read_line, string_display, close_output_string};
+
+s7_pointer s7_open_output_string(s7_scheme *sc)
+{
+ s7_pointer x;
+ block_t *b = mallocate_port(sc);
+ block_t *block = inline_mallocate(sc, sc->initial_string_port_length);
+ new_cell(sc, x, T_OUTPUT_PORT);
+ port_block(x) = b;
+ port_port(x) = (port_t *)block_data(b);
+ port_type(x) = STRING_PORT;
+ port_set_closed(x, false);
+ port_data_size(x) = sc->initial_string_port_length;
+ port_data_block(x) = block;
+ port_data(x) = (uint8_t *)(block_data(block));
+ port_data(x)[0] = '\0'; /* in case s7_get_output_string before any output */
+ port_position(x) = 0;
+ port_needs_free(x) = true;
+ port_filename_block(x) = NULL;
+ port_filename_length(x) = 0; /* protect against (port-filename (open-output-string)) */
+ port_filename(x) = NULL;
+ port_port(x)->pf = &output_string_functions;
+ add_output_port(sc, x);
+ return(x);
+}
+
+static s7_pointer g_open_output_string(s7_scheme *sc, s7_pointer unused_args)
+{
+ #define H_open_output_string "(open-output-string) opens an output string port"
+ #define Q_open_output_string s7_make_signature(sc, 1, sc->is_output_port_symbol)
+ return(s7_open_output_string(sc));
+}
+
+
+/* -------------------------------- get-output-string -------------------------------- */
+const char *s7_get_output_string(s7_scheme *sc, s7_pointer p)
+{
+ port_data(p)[port_position(p)] = '\0';
+ return((const char *)port_data(p));
+}
+
+s7_pointer s7_output_string(s7_scheme *sc, s7_pointer p)
+{
+ port_data(p)[port_position(p)] = '\0';
+ return(make_string_with_length(sc, (const char *)port_data(p), port_position(p)));
+}
+
+static inline void check_get_output_string_port(s7_scheme *sc, s7_pointer p)
+{
+ if (port_is_closed(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)));
+}
+/* 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?
+ * if pos>size shouldn't we raise an error somewhere?
+ */
+
+static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_get_output_string "(get-output-string port (clear-port #f)) returns the output accumulated in port. \
+If the optional 'clear-port' is #t, the current string is flushed."
+ #define Q_get_output_string s7_make_signature(sc, 3, sc->is_string_symbol, \
+ s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol), sc->is_boolean_symbol)
+ s7_pointer p;
+ bool clear_port = false;
+
+ if (is_pair(cdr(args)))
+ {
+ p = cadr(args);
+ if (!is_boolean(p))
+ 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);
+ if ((!is_output_port(p)) || (!is_string_port(p)))
+ {
+ if (p == sc->F) return(nil_string);
+ check_method(sc, p, sc->get_output_string_symbol, args);
+ wrong_type_error_nr(sc, sc->get_output_string_symbol, 1, p, wrap_string(sc, "an open string output port or #f", 32));
+ }
+ check_get_output_string_port(sc, p);
+
+ if ((clear_port) &&
+ (port_position(p) < port_data_size(p)))
+ {
+ block_t *block;
+ s7_pointer result = block_to_string(sc, port_data_block(p), port_position(p));
+ /* this is slightly faster than make_string_with_length(sc, (char *)(port_data(p)), port_position(p)): we're trading a mallocate for a memcpy */
+ port_data_size(p) = sc->initial_string_port_length;
+ block = inline_mallocate(sc, port_data_size(p));
+ port_data_block(p) = block;
+ port_data(p) = (uint8_t *)(block_data(block));
+ port_position(p) = 0;
+ port_data(p)[0] = '\0';
+ return(result);
+ }
+ return(make_string_with_length(sc, (const char *)port_data(p), port_position(p)));
+}
+
+static void op_get_output_string(s7_scheme *sc)
+{
+ s7_pointer port = sc->code;
+ if (!is_output_port(port))
+ wrong_type_error_nr(sc, sc->with_output_to_string_symbol, 1, port, wrap_string(sc, "an open string output port", 26));
+ check_get_output_string_port(sc, port);
+
+ if (port_position(port) >= port_data_size(port)) /* can the > part happen? */
+ sc->value = block_to_string(sc, reallocate(sc, port_data_block(port), port_position(port) + 1), port_position(port));
+ else sc->value = block_to_string(sc, port_data_block(port), port_position(port));
+
+ port_data(port) = NULL;
+ port_data_size(port) = 0;
+ port_data_block(port) = NULL;
+ port_needs_free(port) = false;
+}
+
+static s7_pointer g_get_output_string_uncopied(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p = car(args);
+ if ((!is_output_port(p)) || (!is_string_port(p)))
+ {
+ if (p == sc->F) return(nil_string);
+ return(method_or_bust_p(sc, p, sc->get_output_string_symbol, wrap_string(sc, "an output string port", 21)));
+ }
+ check_get_output_string_port(sc, p);
+ port_data(p)[port_position(p)] = '\0'; /* wrap_string can't do this, and (for example) open_input_string wants terminated strings */
+ return(wrap_string(sc, (const char *)port_data(p), port_position(p)));
+}
+
+
+/* -------------------------------- open-input-function -------------------------------- */
+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)));
+ return(NULL);
+}
+
+static void close_input_function(s7_scheme *sc, s7_pointer p)
+{
+ port_port(p)->pf = &closed_port_functions;
+ port_set_string_or_function(p, sc->closed_input_function); /* from s7_make_function so it is GC-protected */
+ port_set_closed(p, true);
+}
+
+static const port_functions_t input_function_functions =
+ {function_read_char, input_write_char, input_write_string, NULL, NULL, NULL, NULL, function_read_line, input_display, close_input_function};
+
+static void function_port_set_defaults(s7_pointer x)
+{
+ port_type(x) = FUNCTION_PORT;
+ port_data(x) = NULL;
+ port_data_block(x) = NULL;
+ port_set_closed(x, false);
+ port_needs_free(x) = false;
+ port_filename_block(x) = NULL; /* next three protect against port-filename misunderstandings */
+ port_filename(x) = NULL;
+ port_filename_length(x) = 0;
+ port_file_number(x) = 0;
+ port_line_number(x) = 0;
+ port_file(x) = NULL;
+}
+
+s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port))
+{
+ s7_pointer x;
+ block_t *b = mallocate_port(sc);
+ new_cell(sc, x, T_INPUT_PORT);
+ port_block(x) = b;
+ port_port(x) = (port_t *)block_data(b);
+ function_port_set_defaults(x);
+ port_set_string_or_function(x, sc->nil);
+ port_input_function(x) = function;
+ port_port(x)->pf = &input_function_functions;
+ add_input_port(sc, x);
+ return(x);
+}
+
+static void init_open_input_function_choices(s7_scheme *sc)
+{
+ sc->open_input_function_choices[S7_READ] = sc->read_symbol;
+ sc->open_input_function_choices[S7_READ_CHAR] = sc->read_char_symbol;
+ sc->open_input_function_choices[S7_READ_LINE] = sc->read_line_symbol;
+ sc->open_input_function_choices[S7_PEEK_CHAR] = sc->peek_char_symbol;
+#if (!WITH_PURE_S7)
+ sc->open_input_function_choices[S7_IS_CHAR_READY] = sc->is_char_ready_symbol;
+#endif
+}
+
+static s7_pointer input_scheme_function_wrapper(s7_scheme *sc, s7_read_t read_choice, s7_pointer port)
+{
+ return(s7_apply_function(sc, port_string_or_function(port), set_plist_1(sc, sc->open_input_function_choices[(int)read_choice])));
+}
+
+static s7_pointer g_open_input_function(s7_scheme *sc, s7_pointer args)
+{
+ #define H_open_input_function "(open-input-function func) opens an input function port"
+ #define Q_open_input_function s7_make_signature(sc, 2, sc->is_input_port_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol))
+
+ s7_pointer port, func = car(args);
+
+ if (!is_any_procedure(func)) /* is_procedure is too lenient: we need to flag (open-input-function (block)) for example */
+ 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));
+
+ port = s7_open_input_function(sc, input_scheme_function_wrapper);
+ port_set_string_or_function(port, func);
+ return(port);
+}
+
+
+/* -------------------------------- open-output-function -------------------------------- */
+static s7_pointer g_closed_output_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 write to a closed output-function port", 49)));
+ return(NULL);
+}
+
+static void close_output_function(s7_scheme *sc, s7_pointer p)
+{
+ port_port(p)->pf = &closed_port_functions;
+ port_set_string_or_function(p, sc->closed_output_function);
+ port_set_closed(p, true);
+}
+
+static const port_functions_t output_function_functions =
+ {output_read_char, function_write_char, function_write_string, NULL, NULL, NULL, NULL, output_read_line, function_display, close_output_function};
+
+s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port))
+{
+ s7_pointer x;
+ block_t *b = mallocate_port(sc);
+ new_cell(sc, x, T_OUTPUT_PORT);
+ port_block(x) = b;
+ port_port(x) = (port_t *)block_data(b);
+ function_port_set_defaults(x);
+ port_output_function(x) = function;
+ port_set_string_or_function(x, sc->nil);
+ port_port(x)->pf = &output_function_functions;
+ add_output_port(sc, x);
+ return(x);
+}
+
+static void output_scheme_function_wrapper(s7_scheme *sc, uint8_t c, s7_pointer port)
+{
+ s7_apply_function(sc, port_string_or_function(port), set_plist_1(sc, make_integer(sc, c)));
+}
+
+static s7_pointer g_open_output_function(s7_scheme *sc, s7_pointer args)
+{
+ #define H_open_output_function "(open-output-function func) opens an output function port"
+ #define Q_open_output_function s7_make_signature(sc, 2, sc->is_output_port_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol))
+
+ s7_pointer port, func = car(args);
+
+ if (!is_any_procedure(func))
+ 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));
+
+ port = s7_open_output_function(sc, output_scheme_function_wrapper);
+ port_set_string_or_function(port, func);
+ mark_function[T_OUTPUT_PORT] = mark_output_port;
+ return(port);
+}
+
+
+/* -------- current-input-port stack -------- */
+#define INPUT_PORT_STACK_INITIAL_SIZE 4
+
+static inline void push_input_port(s7_scheme *sc, s7_pointer new_port)
+{
+ if (sc->input_port_stack_loc >= sc->input_port_stack_size)
+ {
+ sc->input_port_stack_size *= 2;
+ sc->input_port_stack = (s7_pointer *)Realloc(sc->input_port_stack, sc->input_port_stack_size * sizeof(s7_pointer));
+ }
+ sc->input_port_stack[sc->input_port_stack_loc++] = current_input_port(sc);
+ set_current_input_port(sc, new_port);
+}
+
+static void pop_input_port(s7_scheme *sc)
+{
+ set_current_input_port(sc, (sc->input_port_stack_loc > 0) ? sc->input_port_stack[--(sc->input_port_stack_loc)] : sc->standard_input);
+}
+
+static s7_pointer input_port_if_not_loading(s7_scheme *sc)
+{
+ s7_pointer port = current_input_port(sc);
+ int32_t c;
+ if (!is_loader_port(port)) /* this flag is turned off by the reader macros, so we aren't in that context */
+ return(port);
+ c = port_read_white_space(port)(sc, port);
+ if (c > 0) /* we can get either EOF or NULL at the end */
+ {
+ backchar(c, port);
+ return(NULL);
+ }
+ return(sc->standard_input);
+}
+
+
+/* -------------------------------- read-char -------------------------------- */
+s7_pointer s7_read_char(s7_scheme *sc, s7_pointer port)
+{
+ int32_t c = port_read_character(port)(sc, port);
+ return((c == EOF) ? eof_object : chars[c]);
+}
+
+static s7_pointer g_read_char(s7_scheme *sc, s7_pointer args)
+{
+ #define H_read_char "(read-char (port (current-input-port))) returns the next character in the input port"
+ #define Q_read_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)
+
+ s7_pointer port;
+ if (is_not_null(args))
+ port = car(args);
+ else
+ {
+ port = input_port_if_not_loading(sc);
+ if (!port) return(eof_object);
+ }
+ if (!is_input_port(port))
+ return(method_or_bust_p(sc, port, sc->read_char_symbol, an_input_port_string));
+ return(chars[port_read_character(port)(sc, port)]);
+}
+
+static s7_pointer read_char_p_p(s7_scheme *sc, s7_pointer port)
+{
+ if (!is_input_port(port))
+ return(method_or_bust_p(sc, port, sc->read_char_symbol, an_input_port_string));
+ return(chars[port_read_character(port)(sc, port)]);
+}
+
+static s7_pointer g_read_char_1(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer port = car(args);
+ if (!is_input_port(port))
+ return(method_or_bust_p(sc, port, sc->read_char_symbol, an_input_port_string));
+ return(chars[port_read_character(port)(sc, port)]);
+}
+
+static s7_pointer read_char_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ return((args == 1) ? sc->read_char_1 : f);
+}
+
+
+/* -------------------------------- write-char -------------------------------- */
+s7_pointer s7_write_char(s7_scheme *sc, s7_pointer c, s7_pointer pt)
+{
+ if (pt != sc->F)
+ port_write_character(pt)(sc, s7_character(c), pt);
+ return(c);
+}
+
+static s7_pointer write_char_p_pp(s7_scheme *sc, s7_pointer c, s7_pointer port)
+{
+ if (!is_character(c))
+ return(method_or_bust_pp(sc, c, sc->write_char_symbol, c, port, sc->type_names[T_CHARACTER], 1));
+ if (!is_output_port(port))
+ {
+ if (port == sc->F) return(c);
+ check_method(sc, port, sc->write_char_symbol, set_mlist_2(sc, c, port));
+ wrong_type_error_nr(sc, sc->write_char_symbol, 2, port, an_output_port_or_f_string);
+ }
+ port_write_character(port)(sc, s7_character(c), port);
+ return(c);
+}
+
+static s7_pointer g_write_char(s7_scheme *sc, s7_pointer args)
+{
+ #define H_write_char "(write-char char (port (current-output-port))) writes char to the output port"
+ #define Q_write_char s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
+ return(write_char_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc)));
+}
+
+static s7_pointer write_char_p_p(s7_scheme *sc, s7_pointer c)
+{
+ if (!is_character(c))
+ return(method_or_bust_p(sc, c, sc->write_char_symbol, sc->type_names[T_CHARACTER]));
+ if (current_output_port(sc) == sc->F) return(c);
+ port_write_character(current_output_port(sc))(sc, s7_character(c), current_output_port(sc));
+ return(c);
+}
+
+/* (with-output-to-string (lambda () (write-char #\space))) -> " "
+ * (with-output-to-string (lambda () (write #\space))) -> "#\\space"
+ * (with-output-to-string (lambda () (display #\space))) -> " "
+ * is this correct? It's what Guile does. write-char is actually display-char.
+ */
+
+
+/* -------------------------------- peek-char -------------------------------- */
+s7_pointer s7_peek_char(s7_scheme *sc, s7_pointer port)
+{
+ int32_t c; /* needs to be an int32_t so EOF=-1, but not 255 */
+ if (is_string_port(port))
+ return((port_data_size(port) <= port_position(port)) ? chars[EOF] : chars[(uint8_t)port_data(port)[port_position(port)]]);
+ c = port_read_character(port)(sc, port);
+ if (c == EOF) return(eof_object);
+ backchar(c, port);
+ return(chars[c]);
+}
+
+static s7_pointer g_peek_char(s7_scheme *sc, s7_pointer args)
+{
+ #define H_peek_char "(peek-char (port (current-input-port))) returns the next character in the input port, but does not remove it from the input stream"
+ #define Q_peek_char s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)
+
+ s7_pointer res, port = (is_not_null(args)) ? car(args) : current_input_port(sc);
+ if (!is_input_port(port))
+ return(method_or_bust_p(sc, port, sc->peek_char_symbol, an_input_port_string));
+ if (port_is_closed(port))
+ sole_arg_wrong_type_error_nr(sc, sc->peek_char_symbol, port, an_open_input_port_string);
+ if (!is_function_port(port))
+ return(s7_peek_char(sc, port));
+
+ res = (*(port_input_function(port)))(sc, S7_PEEK_CHAR, 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 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));
+ return(res);
+}
+
+
+/* -------------------------------- read-byte -------------------------------- */
+static s7_pointer g_read_byte(s7_scheme *sc, s7_pointer args)
+{
+ #define H_read_byte "(read-byte (port (current-input-port))): reads a byte from the input port"
+ #define Q_read_byte s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_byte_symbol, sc->is_eof_object_symbol), sc->is_input_port_symbol)
+
+ s7_pointer port;
+ int32_t c;
+
+ if (is_not_null(args))
+ port = car(args);
+ else
+ {
+ port = input_port_if_not_loading(sc);
+ if (!port) return(eof_object);
+ }
+ if (!is_input_port(port))
+ return(method_or_bust_p(sc, port, sc->read_byte_symbol, an_input_port_string));
+ if (port_is_closed(port)) /* avoid reporting caller here as read-char */
+ sole_arg_wrong_type_error_nr(sc, sc->read_byte_symbol, port, an_open_input_port_string);
+ c = port_read_character(port)(sc, port);
+ return((c == EOF) ? eof_object : small_int(c));
+}
+
+
+/* -------------------------------- write-byte -------------------------------- */
+static s7_pointer g_write_byte(s7_scheme *sc, s7_pointer args)
+{
+ #define H_write_byte "(write-byte byte (port (current-output-port))): writes byte to the output port"
+ #define Q_write_byte s7_make_signature(sc, 3, sc->is_byte_symbol, sc->is_byte_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
+
+ s7_pointer port, b = car(args);
+ s7_int val;
+ if (!s7_is_integer(b))
+ return(method_or_bust(sc, b, sc->write_byte_symbol, args, sc->type_names[T_INTEGER], 1));
+
+ val = s7_integer_clamped_if_gmp(sc, b);
+ if ((val < 0) || (val > 255)) /* need to check this before port==#f, else (write-byte most-positive-fixnum #f) is not an error */
+ wrong_type_error_nr(sc, sc->write_byte_symbol, 1, b, an_unsigned_byte_string);
+
+ port = (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc);
+ if (!is_output_port(port))
+ {
+ if (port == sc->F) return(b);
+ check_method(sc, port, sc->write_byte_symbol, args);
+ wrong_type_error_nr(sc, sc->write_byte_symbol, 2, port, an_output_port_or_f_string);
+ }
+ if (port_is_closed(port)) /* avoid reporting caller here as write-char */
+ wrong_type_error_nr(sc, sc->write_byte_symbol, 2, port, an_open_output_port_string);
+
+ port_write_character(port)(sc, (uint8_t)val, port);
+ return(b);
+}
+
+
+/* -------------------------------- read-line -------------------------------- */
+static s7_pointer g_read_line(s7_scheme *sc, s7_pointer args)
+{
+ #define H_read_line "(read-line port (with-eol #f)) returns the next line from port, or #<eof>. \
+If 'with-eol' is not #f, read-line includes the trailing end-of-line character."
+ #define Q_read_line s7_make_signature(sc, 3, \
+ s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), \
+ sc->is_input_port_symbol, sc->is_boolean_symbol)
+ s7_pointer port;
+ bool with_eol = false;
+ if (is_not_null(args))
+ {
+ port = car(args);
+ if (!is_input_port(port))
+ 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)) */
+ }
+ else
+ {
+ port = input_port_if_not_loading(sc);
+ if (!port) return(eof_object);
+ }
+ return(port_read_line(port)(sc, port, with_eol));
+}
+
+static s7_pointer read_line_p_pp(s7_scheme *sc, s7_pointer port, s7_pointer with_eol)
+{
+ if (!is_input_port(port))
+ return(method_or_bust_pp(sc, port, sc->read_line_symbol, port, with_eol, an_input_port_string, 1));
+ return(port_read_line(port)(sc, port, with_eol != sc->F));
+}
+
+static s7_pointer read_line_p_p(s7_scheme *sc, s7_pointer port)
+{
+ if (!is_input_port(port))
+ return(method_or_bust_p(sc, port, sc->read_line_symbol, an_input_port_string));
+ return(port_read_line(port)(sc, port, false)); /* with_eol default is #f */
+}
+
+
+/* -------------------------------- read-string -------------------------------- */
+static s7_pointer g_read_string(s7_scheme *sc, s7_pointer args)
+{
+ /* read-chars would be a better name -- read-string could mean CL-style read-from-string (like eval-string)
+ * similarly read-bytes could return a byte-vector (rather than r7rs's read-bytevector)
+ * and write-string -> write-chars, write-bytevector -> write-bytes
+ */
+ #define H_read_string "(read-string k port) reads k characters from port into a new string and returns it."
+ #define Q_read_string s7_make_signature(sc, 3, \
+ s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_eof_object_symbol), \
+ sc->is_integer_symbol, sc->is_input_port_symbol)
+ s7_pointer k = car(args), port, s;
+ s7_int nchars;
+ uint8_t *str;
+
+ if (!s7_is_integer(k))
+ return(method_or_bust(sc, k, sc->read_string_symbol, args, sc->type_names[T_INTEGER], 1));
+ nchars = s7_integer_clamped_if_gmp(sc, k);
+ if (nchars < 0)
+ 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)));
+
+ if (!is_null(cdr(args)))
+ port = cadr(args);
+ else
+ {
+ port = input_port_if_not_loading(sc);
+ if (!port) return(eof_object);
+ }
+ if (!is_input_port(port))
+ return(method_or_bust_pp(sc, port, sc->read_string_symbol, k, port, an_input_port_string, 2));
+ if (port_is_closed(port))
+ wrong_type_error_nr(sc, sc->read_string_symbol, 2, port, an_open_input_port_string);
+
+ s = make_empty_string(sc, nchars, 0);
+ if (nchars == 0) return(s);
+ str = (uint8_t *)string_value(s);
+ if (is_string_port(port))
+ {
+ s7_int pos = port_position(port);
+ s7_int end = port_data_size(port);
+ s7_int len = end - pos;
+ if (len > nchars) len = nchars;
+ if (len <= 0) return(eof_object);
+ memcpy((void *)str, (void *)(port_data(port) + pos), len);
+ string_length(s) = len;
+ str[len] = '\0';
+ port_position(port) += len;
+ return(s);
+ }
+ if (is_file_port(port))
+ {
+ size_t len = fread((void *)str, 1, nchars, port_file(port));
+ str[len] = '\0';
+ string_length(s) = len;
+ return(s);
+ }
+ for (s7_int i = 0; i < nchars; i++)
+ {
+ int32_t c = port_read_character(port)(sc, port);
+ if (c == EOF)
+ {
+ if (i == 0)
+ return(eof_object);
+ string_length(s) = i;
+ return(s);
+ }
+ str[i] = (uint8_t)c;
+ }
+ return(s);
+}
+
+
+/* -------------------------------- 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; \
+ } 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); \
+ } 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; \
+ } while (0)
+
+static s7_pointer eval(s7_scheme *sc, opcode_t first_op);
+
+s7_pointer s7_read(s7_scheme *sc, s7_pointer port)
+{
+ if (is_input_port(port))
+ {
+ s7_pointer old_let = sc->curlet;
+ declare_jump_info();
+ set_curlet(sc, sc->rootlet);
+ push_input_port(sc, 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);
+ }
+ 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);
+ }
+ pop_input_port(sc);
+ set_curlet(sc, old_let);
+ restore_jump_info(sc);
+ return(sc->value);
+ }
+ sole_arg_wrong_type_error_nr(sc, sc->read_symbol, port, an_input_port_string);
+ return(NULL);
+}
+
+static s7_pointer g_read(s7_scheme *sc, s7_pointer args)
+{
+ #define H_read "(read (port (current-input-port))) returns the next object in the input port, or #<eof> at the end"
+ #define Q_read s7_make_signature(sc, 2, sc->T, sc->is_input_port_symbol)
+
+ s7_pointer port;
+ if (is_not_null(args))
+ port = car(args);
+ else
+ {
+ port = input_port_if_not_loading(sc);
+ if (!port) return(eof_object);
+ }
+ if (!is_input_port(port))
+ return(method_or_bust_p(sc, port, sc->read_symbol, an_input_port_string));
+
+ if (is_function_port(port))
+ {
+ 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));
+ }
+ return(res);
+ }
+ if ((is_string_port(port)) &&
+ (port_data_size(port) <= port_position(port)))
+ return(eof_object);
+
+ push_input_port(sc, port);
+ push_stack_op_let(sc, OP_READ_DONE); /* this stops the internal read process so we only get one form */
+ push_stack_op_let(sc, OP_READ_INTERNAL);
+ return(port);
+}
+
+
+/* -------------------------------- load -------------------------------- */
+#if WITH_MULTITHREAD_CHECKS
+typedef struct {
+ s7_scheme* sc;
+ const int32_t lock_count; /* Remember lock count in case we have skipped calls to leave_track_scope by longjmp-ing */
+} lock_scope_t;
+
+static lock_scope_t enter_lock_scope(s7_scheme *sc)
+{
+ int32_t result = pthread_mutex_trylock(&sc->lock);
+ if (result != 0)
+ {
+ fprintf(stderr, "pthread_mutex_trylock failed: %d (EBUSY: %d)", result, EBUSY);
+ abort();
+ }
+ sc->lock_count++;
+ {
+ lock_scope_t st = {.sc = sc, .lock_count = sc->lock_count};
+ return(st);
+ }
+}
+
+static void leave_lock_scope(lock_scope_t *st)
+{
+ while (st->sc->lock_count > st->lock_count)
+ {
+ st->sc->lock_count--;
+ pthread_mutex_unlock(&st->sc->lock);
+ }
+}
+
+#define TRACK(Sc) lock_scope_t lock_scope __attribute__ ((__cleanup__(leave_lock_scope))) = enter_lock_scope(Sc)
+#else
+#define TRACK(Sc)
+#endif
+
+/* various changes in this section courtesy of Woody Douglass 12-Jul-19 */
+
+static block_t *search_load_path(s7_scheme *sc, const char *name)
+{
+ s7_pointer lst = s7_load_path(sc);
+ if (is_pair(lst))
+ {
+#if MS_WINDOWS || defined(__linux__)
+ #define S7_FILENAME_MAX 4096 /* so we can handle 4095 chars (need trailing null) -- this limit could be added to *s7* */
+#else
+ #define S7_FILENAME_MAX 1024
+#endif
+ /* linux: PATH_MAX: 4096, windows: MAX_PATH: unlimited?, Mac: 1016?, BSD: MAX_PATH_LENGTH: 1024 */
+ block_t *b = mallocate(sc, S7_FILENAME_MAX);
+ 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);
+#ifdef _MSC_VER
+ if (_access(filename, 0) != -1)
+ return(b);
+#else
+ if (access(filename, F_OK) == 0)
+ return(b);
+#endif
+ }}
+ liberate(sc, b);
+ }
+ return(NULL);
+}
+
+#if WITH_C_LOADER
+#include <dlfcn.h>
+
+static block_t *full_filename(s7_scheme *sc, const char *filename)
+{
+ char *rtn;
+ block_t *block;
+ if ((S7_DEBUGGING) && ((!filename) || (!*filename))) fprintf(stderr, "%s[%d]: filename is %s\n", __func__, __LINE__, filename);
+ if (filename[0] == '/')
+ {
+ s7_int len = safe_strlen(filename);
+ block = mallocate(sc, len + 1);
+ rtn = (char *)block_data(block);
+ memcpy((void *)rtn, (const void *)filename, len);
+ rtn[len] = '\0';
+ }
+ else
+ {
+ char *pwd = getcwd(NULL, 0); /* docs say this means it will return a new string of the right size */
+ size_t pwd_len = safe_strlen(pwd);
+ size_t filename_len = safe_strlen(filename);
+ s7_int len = pwd_len + filename_len + 2; /* not 1! we need room for the '/' and the terminating 0 */
+ 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';
+ 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);
+}
+
+static s7_pointer load_shared_object(s7_scheme *sc, const char *fname, s7_pointer let)
+{
+ /* if fname ends in .so|.dylib, try loading it as a C shared object: (load "/home/bil/cl/m_j0.so" (inlet 'init_func 'init_m_j0)) */
+ s7_int fname_len = safe_strlen(fname);
+ if (((fname_len > 3) &&
+ (local_strcmp((const char *)(fname + (fname_len - 3)), ".so"))) || /* linux */
+ ((fname_len > 6) &&
+ (local_strcmp((const char *)(fname + (fname_len - 3)), ".dylib")))) /* mac */
+ {
+ void *library;
+ char *pwd_name = NULL;
+ block_t *pname = NULL;
+
+ if ((access(fname, F_OK) == 0) || (fname[0] == '/'))
+ {
+ 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);
+ }}
+ 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());
+ 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 (pname) liberate(sc, pname);
+ }
+ return(NULL);
+}
+#endif
+
+static s7_pointer load_file_1(s7_scheme *sc, const char *filename)
+{
+ char *local_file_name = NULL;
+ FILE* fp = fopen(filename, "r");
+#if WITH_GCC
+ if (!fp) /* catch one special case, "~/..." since it causes 99.9% of the "can't load ..." errors */
+ {
+ 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);
+ }}
+#endif
+ if (!fp)
+ {
+ const char *fname;
+ block_t *b = search_load_path(sc, filename);
+ if (!b) return(NULL);
+ fname = (const char *)block_data(b);
+ fp = fopen(fname, "r");
+ if (fp) local_file_name = copy_string_with_length(fname, safe_strlen(fname));
+ liberate(sc, b);
+ }
+ if (fp)
+ {
+ 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)));
+ 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);
+ set_loader_port(port);
+ push_input_port(sc, port);
+ return(port);
+ }
+ return(NULL);
+}
+
+s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e)
+{
+ /* returns either the value of the load or NULL if filename not found */
+ s7_pointer port;
+ declare_jump_info();
+ TRACK(sc);
+ if (e == sc->s7_starlet) return(NULL);
+ if (e == sc->nil) e = sc->rootlet; /* PERHAPS: this is a leftover from the days when () -> rootlet -- remove? */
+ if (!is_let(e)) s7_warn(sc, 128, "third argument (the let) to s7_load_with_environment is not a let");
+#if WITH_C_LOADER
+ port = load_shared_object(sc, filename, e);
+ if (port) return(port);
+#endif
+
+ if (is_directory(filename)) return(NULL);
+ port = load_file_1(sc, filename);
+ if (!port) return(NULL);
+
+ set_curlet(sc, e);
+ push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code);
+
+ store_jump_info(sc);
+ set_jump_info(sc, LOAD_SET_JUMP);
+ if (jump_loc == NO_JUMP)
+ eval(sc, OP_READ_INTERNAL);
+ else
+ if (jump_loc != ERROR_JUMP)
+ eval(sc, sc->cur_op);
+ pop_input_port(sc);
+ if (is_input_port(port))
+ s7_close_input_port(sc, port);
+ restore_jump_info(sc);
+
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+ return(sc->value);
+}
+
+s7_pointer s7_load(s7_scheme *sc, const char *filename) {return(s7_load_with_environment(sc, filename, sc->rootlet));}
+
+s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer e)
+{
+ s7_pointer port;
+ s7_int port_loc;
+ declare_jump_info();
+ TRACK(sc);
+
+ if (e == sc->nil) e = sc->rootlet; /* PERHAPS: this is a leftover from the days when () -> rootlet -- remove? */
+ if (content[bytes] != 0)
+ error_nr(sc, make_symbol(sc, "bad-data", 8), set_elist_1(sc, wrap_string(sc, "s7_load_c_string content is not terminated", 42)));
+ port = open_input_string(sc, content, bytes);
+ port_loc = gc_protect_1(sc, port);
+ set_loader_port(port);
+ push_input_port(sc, port);
+ set_curlet(sc, e);
+ push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code);
+ s7_gc_unprotect_at(sc, port_loc);
+
+ store_jump_info(sc);
+ set_jump_info(sc, LOAD_SET_JUMP);
+ if (jump_loc == NO_JUMP)
+ eval(sc, OP_READ_INTERNAL);
+ else
+ if (jump_loc != ERROR_JUMP)
+ eval(sc, sc->cur_op);
+ pop_input_port(sc);
+ if (is_input_port(port))
+ s7_close_input_port(sc, port);
+ restore_jump_info(sc);
+
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+ return(sc->value);
+}
+
+s7_pointer s7_load_c_string(s7_scheme *sc, const char *content, s7_int bytes)
+{
+ return(s7_load_c_string_with_environment(sc, content, bytes, sc->nil));
+}
+
+static s7_pointer g_load(s7_scheme *sc, s7_pointer args)
+{
+ #define H_load "(load file (let (rootlet))) loads the scheme file 'file'. The 'let' argument \
+defaults to the rootlet. To load into the current environment instead, pass (curlet)."
+ #define Q_load s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol)
+
+ s7_pointer name = car(args);
+ const char *fname;
+
+ if (!is_string(name))
+ return(method_or_bust(sc, name, sc->load_symbol, args, sc->type_names[T_STRING], 1));
+
+ if (is_pair(cdr(args)))
+ {
+ s7_pointer e = cadr(args);
+ if (!is_let(e))
+ 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));
+ set_curlet(sc, e);
+ }
+ else set_curlet(sc, sc->rootlet);
+
+ 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));
+
+ 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))));
+#if WITH_C_LOADER
+ {
+ s7_pointer p = load_shared_object(sc, fname, sc->curlet);
+ if (p) return(p);
+ }
+#endif
+ errno = 0;
+ if (!load_file_1(sc, fname))
+ file_error_nr(sc, "load", strerror(errno), fname);
+
+ push_stack_op_let(sc, OP_LOAD_CLOSE_AND_POP_IF_EOF); /* was pushing args and code, but I don't think they're used later */
+ push_stack_op_let(sc, OP_READ_INTERNAL);
+ return(sc->unspecified);
+}
+
+
+/* -------- *load-path* -------- */
+s7_pointer s7_load_path(s7_scheme *sc) {return(s7_symbol_local_value(sc, sc->load_path_symbol, sc->curlet));}
+
+s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir)
+{
+ s7_pointer slot = lookup_slot_from(sc->load_path_symbol, sc->curlet); /* rootlet possible here */
+ s7_pointer path = cons(sc, s7_make_string(sc, dir), slot_value(slot));
+ slot_set_value(slot, path);
+ return(path);
+}
+
+static s7_pointer g_load_path_set(s7_scheme *sc, s7_pointer args)
+{
+ /* new value must be either () or a proper list of strings */
+ s7_pointer x;
+ if (is_null(cadr(args))) return(cadr(args));
+ if (!is_pair(cadr(args)))
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S", 27), cadr(args)));
+ for (x = cadr(args); is_pair(x); x = cdr(x))
+ if (!is_string(car(x)))
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, wrap_string(sc, "can't set *load-path* to ~S, ~S is not a string", 47), cadr(args), car(x)));
+ if (!is_null(x))
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *load-path* to ~S, it is not a proper list", 52), cadr(args)));
+ return(cadr(args));
+}
+
+/* -------- *cload-directory* -------- */
+static s7_pointer g_cload_directory_set(s7_scheme *sc, s7_pointer args)
+{
+ /* this sets the directory for cload.scm's output */
+ s7_pointer cl_dir = cadr(args);
+ if (!is_string(cl_dir))
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *cload-directory* to ~S", 33), cadr(args)));
+ s7_symbol_set_value(sc, sc->cload_directory_symbol, cl_dir);
+ if (string_length(cl_dir) > 0) /* was strlen(string_value)? */
+ s7_add_to_load_path(sc, (const char *)(string_value(cl_dir)));
+ /* should this remove the previous *cload-directory* name first? or not affect *load-path* at all? */
+ return(cl_dir);
+}
+
+
+/* ---------------- autoload ---------------- */
+#define INITIAL_AUTOLOAD_NAMES_SIZE 4
+
+void s7_autoload_set_names(s7_scheme *sc, const char **names, s7_int size)
+{
+ /* names should be sorted alphabetically by the symbol name (the even indexes in the names array)
+ * size is the number of symbol names (half the size of the names array(
+ * the idea here is that by sticking to string constants we can handle 90% of the work at compile-time,
+ * with less start-up memory. Then eventually we'll add C libraries and every name in those libraries
+ * will come as an import once dlopen has picked up the library.
+ */
+ 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;
+ }
+ if (!sc->autoload_names)
+ {
+ sc->autoload_names = (const char ***)Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(const char **));
+ sc->autoload_names_sizes = (s7_int *)Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(s7_int));
+ sc->autoloaded_already = (bool **)Calloc(INITIAL_AUTOLOAD_NAMES_SIZE, sizeof(bool *));
+ sc->autoload_names_top = INITIAL_AUTOLOAD_NAMES_SIZE;
+ sc->autoload_names_loc = 0;
+ }
+ 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[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));
+ sc->autoload_names_loc++;
+}
+
+static const char *find_autoload_name(s7_scheme *sc, s7_pointer symbol, bool *already_loaded, bool loading)
+{
+ s7_int l = 0, libs = sc->autoload_names_loc;
+ const char *name = symbol_name(symbol);
+ for (s7_int lib = 0; lib < libs; lib++)
+ {
+ 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;
+ }}
+ return(NULL);
+}
+
+s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_function)
+{
+ /* add '(symbol . file) to s7's autoload table */
+ if (is_null(sc->autoload_table))
+ sc->autoload_table = s7_make_hash_table(sc, 32); /* add_hash_table here, perhaps sc->hash_tables->loc-- */
+ if (sc->safety >= MORE_SAFETY_WARNINGS)
+ {
+ 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_hash_table_set(sc, sc->autoload_table, symbol, file_or_function);
+ return(file_or_function);
+}
+
+static s7_pointer g_autoload(s7_scheme *sc, s7_pointer args)
+{
+ #define H_autoload "(autoload symbol file-or-function) adds the symbol to its table of autoloadable symbols. \
+If that symbol is encountered as an unbound variable, s7 either loads the file (following *load-path*), or calls \
+the function. The function takes one argument, the calling environment. Presumably the symbol is defined \
+in the file, or by the function."
+ #define Q_autoload s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->T)
+
+ s7_pointer sym = car(args), value;
+ 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));
+ sym = make_symbol(sc, string_value(sym), string_length(sym));
+ }
+ if (!is_symbol(sym))
+ {
+ check_method(sc, sym, sc->autoload_symbol, args);
+ wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a string (symbol-name) or a symbol", 34));
+ }
+ if (is_keyword(sym))
+ wrong_type_error_nr(sc, sc->autoload_symbol, 1, sym, wrap_string(sc, "a normal symbol (a keyword is never unbound)", 44));
+
+ value = cadr(args);
+ if (is_string(value))
+ return(s7_autoload(sc, sym, s7_immutable(make_string_with_length(sc, string_value(value), string_length(value)))));
+ if (((is_closure(value)) || (is_closure_star(value))) &&
+ (s7_is_aritable(sc, value, 1)))
+ return(s7_autoload(sc, sym, value));
+
+ check_method(sc, value, sc->autoload_symbol, args);
+ wrong_type_error_nr(sc, sc->autoload_symbol, 2, value, wrap_string(sc, "a string (file-name) or a thunk", 31));
+ return(NULL); /* make tcc happy */
+}
+
+
+/* -------------------------------- *autoload* -------------------------------- */
+static s7_pointer g_autoloader(s7_scheme *sc, s7_pointer args) /* the *autoload* function */
+{
+ #define H_autoloader "(*autoload* sym) returns the autoload info for the symbol sym, or #f."
+ #define Q_autoloader s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol)
+
+ s7_pointer sym = car(args);
+ if (!is_symbol(sym))
+ {
+ check_method(sc, sym, sc->autoloader_symbol, set_plist_1(sc, sym));
+ wrong_type_error_nr(sc, wrap_string(sc, "*autoload*", 10), 1, sym, sc->type_names[T_SYMBOL]);
+ }
+ if (sc->autoload_names)
+ {
+ bool loaded = false;
+ const char *file = find_autoload_name(sc, sym, &loaded, false);
+ if (file)
+ return(s7_make_string(sc, file));
+ }
+ if (is_hash_table(sc->autoload_table))
+ return(s7_hash_table_ref(sc, sc->autoload_table, sym));
+ return(sc->F);
+}
+
+
+/* ---------------- require ---------------- */
+static bool is_a_feature(const s7_pointer sym, s7_pointer lst) /* used only with *features* which (sigh) can be circular: (set-cdr! *features* *features*) */
+{
+ s7_pointer x = lst, slow = lst;
+ while (true)
+ {
+ if (!is_pair(x)) return(false);
+ if (sym == car(x)) return(true);
+ x = cdr(x);
+ if (!is_pair(x)) return(false);
+ if (sym == car(x)) return(true);
+ x = cdr(x);
+ slow = cdr(slow);
+ if (x == slow) return(false);
+ }
+ return(false);
+}
+
+static s7_pointer g_require(s7_scheme *sc, s7_pointer args)
+{
+ #define H_require "(require symbol . symbols) loads each file associated with each symbol if it has not been loaded already.\
+The symbols refer to the argument to \"provide\". (require lint.scm)"
+ /* #define Q_require s7_make_circular_signature(sc, 1, 2, sc->T, sc->is_symbol_symbol) */
+
+ gc_protect_via_stack(sc, args);
+ for (s7_pointer p = args; is_pair(p); p = cdr(p))
+ {
+ s7_pointer sym;
+ if (is_symbol(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_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));
+ }}
+ 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);
+}
+
+
+/* ---------------- provided? ---------------- */
+static s7_pointer g_is_provided(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_provided "(provided? symbol) returns #t if symbol is a member of the *features* list"
+ #define Q_is_provided s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_symbol_symbol)
+
+ s7_pointer sym = car(args), topf, x;
+ if (!is_symbol(sym))
+ return(method_or_bust_p(sc, sym, sc->is_provided_symbol, sc->type_names[T_SYMBOL]));
+
+ /* here the *features* list is spread out (or can be anyway) along the curlet chain,
+ * so we need to travel back all the way to the top level checking each *features* list in turn.
+ * Since *features* grows via cons (newest first), we can stop the scan if we hit the shared
+ * top-level at least.
+ */
+ topf = global_value(sc->features_symbol);
+ if (is_a_feature(sym, topf))
+ return(sc->T);
+
+ if (is_global(sc->features_symbol))
+ return(sc->F);
+ for (x = sc->curlet; let_id(x) > symbol_id(sc->features_symbol); x = let_outlet(x));
+ 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);
+ return(sc->F);
+}
+
+bool s7_is_provided(s7_scheme *sc, const char *feature)
+{
+ return(is_a_feature(make_symbol_with_strlen(sc, feature), s7_symbol_value(sc, sc->features_symbol))); /* this goes from local outward */
+}
+
+static bool is_provided_b_7p(s7_scheme *sc, s7_pointer sym)
+{
+ if (!is_symbol(sym))
+ return(method_or_bust_p(sc, sym, sc->is_provided_symbol, sc->type_names[T_SYMBOL]) != sc->F);
+ return(is_a_feature(sym, s7_symbol_value(sc, sc->features_symbol)));
+}
+
+
+/* ---------------- provide ---------------- */
+static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym)
+{
+ /* this has to be relative to the curlet: (load file env)
+ * the things loaded are only present in env, and go away with it, so should not be in the global *features* list
+ */
+ s7_pointer p;
+ if (!is_symbol(sym))
+ return(method_or_bust_p(sc, sym, sc->provide_symbol, sc->type_names[T_SYMBOL]));
+ if ((sc->curlet == sc->rootlet) || (sc->curlet == sc->shadow_rootlet)) /* sc->curlet can also be (for example) the repl top-level */
+ p = global_slot(sc->features_symbol);
+ else p = symbol_to_local_slot(sc, sc->features_symbol, sc->curlet); /* if sc->curlet is nil, this returns the global slot, else local slot */
+ if ((is_slot(p)) && (is_immutable_slot(p)))
+ s7_warn(sc, 256, "provide: *features* is immutable!\n");
+ else
+ {
+ 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);
+ }
+ else
+ 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);
+}
+
+static s7_pointer g_provide(s7_scheme *sc, s7_pointer args)
+{
+ #define H_provide "(provide symbol) adds symbol to the *features* list"
+ #define Q_provide s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_symbol_symbol)
+
+ if ((is_immutable(sc->curlet)) &&
+ (sc->curlet != sc->nil))
+ immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't provide '~S (current environment is immutable)", 52), car(args)));
+ return(c_provide(sc, car(args)));
+}
+
+void s7_provide(s7_scheme *sc, const char *feature) {c_provide(sc, make_symbol_with_strlen(sc, feature));}
+
+
+static s7_pointer g_features_set(s7_scheme *sc, s7_pointer args) /* *features* setter */
+{
+ s7_pointer nf = cadr(args);
+ if (is_null(nf))
+ return(sc->nil);
+ if (!is_pair(nf))
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *features* to ~S (*features* must be a list)", 54), nf));
+ if (s7_list_length(sc, nf) <= 0)
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *features* to an improper or circular list ~S", 55), nf));
+ for (s7_pointer p = nf; is_pair(p); p = cdr(p))
+ if (!is_symbol(car(p)))
+ sole_arg_wrong_type_error_nr(sc, sc->features_symbol, car(p), sc->type_names[T_SYMBOL]);
+ return(nf);
+}
+
+static s7_pointer g_libraries_set(s7_scheme *sc, s7_pointer args) /* *libraries* setter */
+{
+ s7_pointer nf = cadr(args);
+ if (is_null(nf)) return(nf);
+ if ((!is_pair(nf)) ||
+ (s7_list_length(sc, nf) <= 0))
+ 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))))
+ 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);
+}
+
+
+/* -------------------------------- eval-string -------------------------------- */
+s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer e)
+{
+ s7_pointer code, port, result;
+ TRACK(sc);
+ push_stack_direct(sc, OP_GC_PROTECT); /* not gc protection here, but restoration of original context */
+ port = s7_open_input_string(sc, str);
+ code = s7_read(sc, port);
+ s7_close_input_port(sc, port);
+ result = s7_eval(sc, T_Ext(code), e);
+ if (unchecked_stack_top_op(sc) == OP_GC_PROTECT) unstack_gc_protect(sc); /* pop_stack(sc); */
+ return(result);
+}
+
+s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str) {return(s7_eval_c_string_with_environment(sc, str, sc->nil));}
+
+static s7_pointer g_eval_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_eval_string "(eval-string str (let (curlet))) returns the result of evaluating the string str as Scheme code"
+ #define Q_eval_string s7_make_signature(sc, 3, sc->values_symbol, sc->is_string_symbol, sc->is_let_symbol)
+
+ s7_pointer port, str = car(args);
+ if (!is_string(str))
+ return(method_or_bust(sc, str, sc->eval_string_symbol, args, sc->type_names[T_STRING], 1));
+ if (string_length(str) == 0)
+ return(sc->F); /* (eval-string "") -> #f */
+ if (is_not_null(cdr(args)))
+ {
+ s7_pointer e = cadr(args);
+ if (!is_let(e))
+ 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 */
+ push_stack(sc, OP_EVAL_STRING, args, sc->code);
+ port = open_and_protect_input_string(sc, str);
+ push_input_port(sc, port);
+ push_stack_op_let(sc, OP_READ_INTERNAL);
+ return(sc->F); /* I think this means that sc->value defaults to #f in op_eval_string below, so (eval-string "") mimics (eval) -> #f */
+}
+
+static s7_pointer op_eval_string(s7_scheme *sc)
+{
+ while (s7_peek_char(sc, current_input_port(sc)) != eof_object) /* (eval-string "(+ 1 2) this is a mistake") */
+ {
+ 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_close_input_port(sc, current_input_port(sc));
+ pop_input_port(sc);
+ sc->code = sc->value;
+ set_current_code(sc, sc->code);
+ return(NULL);
+}
+
+
+/* -------------------------------- call-with-input-string -------------------------------- */
+static s7_pointer call_with_input(s7_scheme *sc, s7_pointer port, s7_pointer args)
+{
+ s7_pointer p = cadr(args);
+ port_set_string_or_function(port, car(args));
+ push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); /* #<unused> here is a marker (needed) */
+ push_stack(sc, OP_APPLY, list_1(sc, port), p);
+ return(sc->F);
+}
+
+static s7_pointer g_call_with_input_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_call_with_input_string "(call-with-input-string str proc) opens a string port for str and applies proc to it"
+ #define Q_call_with_input_string sc->pl_sf
+ /* (call-with-input-string "44" (lambda (p) (+ 1 (read p)))) -> 45 */
+
+ s7_pointer str = car(args), proc = cadr(args);
+ if (!is_string(str))
+ return(method_or_bust(sc, str, sc->call_with_input_string_symbol, args, sc->type_names[T_STRING], 1));
+
+ if (is_let(proc))
+ check_method(sc, proc, sc->call_with_input_string_symbol, 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));
+ 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));
+}
+
+
+/* -------------------------------- call-with-input-file -------------------------------- */
+static s7_pointer g_call_with_input_file(s7_scheme *sc, s7_pointer args)
+{
+ #define H_call_with_input_file "(call-with-input-file filename proc) opens filename and calls proc with the input port as its argument"
+ #define Q_call_with_input_file sc->pl_sf
+
+ s7_pointer str = car(args), proc = cadr(args);
+ if (!is_string(str))
+ return(method_or_bust(sc, str, sc->call_with_input_file_symbol, args, sc->type_names[T_STRING], 1));
+
+ 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));
+ 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));
+}
+
+
+/* -------------------------------- with-input-from-string -------------------------------- */
+static s7_pointer with_input(s7_scheme *sc, s7_pointer port, s7_pointer args)
+{
+ s7_pointer old_input_port = current_input_port(sc);
+ set_current_input_port(sc, port);
+ port_set_string_or_function(port, car(args));
+ push_stack(sc, OP_UNWIND_INPUT, old_input_port, port);
+ push_stack(sc, OP_APPLY, sc->nil, cadr(args));
+ return(sc->F);
+}
+
+static s7_int procedure_required_args(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_C_FUNCTION: return(c_function_min_args(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)));
+ return(s7_int_abs(closure_arity(x)));
+ }
+ return(0);
+}
+
+static s7_pointer g_with_input_from_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_with_input_from_string "(with-input-from-string str thunk) opens str as the temporary current-input-port and calls thunk"
+ #define Q_with_input_from_string sc->pl_sf
+
+ s7_pointer str = car(args), proc = cadr(args);
+ if (!is_string(str))
+ return(method_or_bust(sc, str, sc->with_input_from_string_symbol, args, sc->type_names[T_STRING], 1));
+ if (proc == global_value(sc->read_symbol))
+ {
+ if (string_length(str) == 0)
+ 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);
+ push_stack(sc, OP_UNWIND_INPUT, sc->unused, current_input_port(sc));
+ push_stack_op_let(sc, OP_READ_DONE);
+ push_stack_op_let(sc, OP_READ_INTERNAL);
+ return(current_input_port(sc));
+ }
+ 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));
+ }
+ 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:
+ * (with-input-from-string "#x2.1" (read))
+ * (read) -> whatever it can get from the current input port!
+ * ";with-input-from-string argument 2, #<eof>, is untyped but should be a thunk"
+ * (with-input-from-string "" (read-line)) -> hangs awaiting stdin input
+ * also this can't be split into wifs and wifs_read because we need the runtime value of 'read
+ */
+ return(with_input(sc, open_and_protect_input_string(sc, str), args));
+}
+
+
+/* -------------------------------- with-input-from-file -------------------------------- */
+static s7_pointer g_with_input_from_file(s7_scheme *sc, s7_pointer args)
+{
+ #define H_with_input_from_file "(with-input-from-file filename thunk) opens filename as the temporary current-input-port and calls thunk"
+ #define Q_with_input_from_file sc->pl_sf
+
+ s7_pointer str = car(args), proc = cadr(args);
+ if (!is_string(str))
+ return(method_or_bust(sc, str, sc->with_input_from_file_symbol, args, sc->type_names[T_STRING], 1));
+ 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));
+ }
+ 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));
+}
+
+static s7_pointer with_string_in(s7_scheme *sc, s7_pointer unused_args)
+{
+ s7_pointer old_port = current_input_port(sc);
+ set_current_input_port(sc, open_and_protect_input_string(sc, sc->value));
+ push_stack(sc, OP_UNWIND_INPUT, old_port, current_input_port(sc));
+ set_curlet(sc, inline_make_let(sc, sc->curlet));
+ return(opt2_pair(sc->code));
+}
+
+static s7_pointer with_file_in(s7_scheme *sc, s7_pointer unused_args)
+{
+ s7_pointer old_port = current_input_port(sc);
+ set_current_input_port(sc, open_input_file_1(sc, string_value(sc->value), "r", "with-input-from-file"));
+ push_stack(sc, OP_UNWIND_INPUT, old_port, current_input_port(sc));
+ set_curlet(sc, inline_make_let(sc, sc->curlet));
+ return(opt2_pair(sc->code));
+}
+
+static s7_pointer with_file_out(s7_scheme *sc, s7_pointer unused_args)
+{
+ s7_pointer old_port = current_output_port(sc);
+ set_current_output_port(sc, s7_open_output_file(sc, string_value(sc->value), "w"));
+ push_stack(sc, OP_UNWIND_OUTPUT, old_port, current_output_port(sc));
+ set_curlet(sc, make_let(sc, sc->curlet));
+ return(opt2_pair(sc->code));
+}
+
+static s7_pointer call_string_in(s7_scheme *sc, s7_pointer unused_args)
+{
+ s7_pointer port = open_and_protect_input_string(sc, sc->value);
+ push_stack(sc, OP_UNWIND_INPUT, sc->unused, port);
+ set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port));
+ return(opt2_pair(sc->code));
+}
+
+static s7_pointer call_file_in(s7_scheme *sc, s7_pointer unused_args)
+{
+ s7_pointer port = open_input_file_1(sc, string_value(sc->value), "r", "with-input-from-file");
+ push_stack(sc, OP_UNWIND_INPUT, sc->unused, port);
+ set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port));
+ return(opt2_pair(sc->code));
+}
+
+static s7_pointer call_file_out(s7_scheme *sc, s7_pointer unused_args)
+{
+ s7_pointer port = s7_open_output_file(sc, string_value(sc->value), "w");
+ push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port);
+ set_curlet(sc, make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port));
+ return(opt2_pair(sc->code));
+}
+
+static s7_pointer c_function_name_to_symbol(s7_scheme *sc, s7_pointer f)
+{
+ if (!is_c_function(f)) /* c_function* uses c_sym slot for arg_names */
+ return(make_symbol(sc, c_function_name(f), c_function_name_length(f)));
+ if (!c_function_symbol(f))
+ c_function_symbol(f) = make_symbol(sc, c_function_name(f), c_function_name_length(f));
+ return(c_function_symbol(f));
+}
+
+#define op_with_io_1(Sc) (((s7_function)(opt1(Sc->code, OPT1_ANY)))(Sc, Sc->nil))
+static s7_pointer op_lambda(s7_scheme *sc, s7_pointer code);
+
+static void op_with_io_1_method(s7_scheme *sc)
+{
+ s7_pointer lt = sc->value;
+ if (has_active_methods(sc, lt))
+ {
+ 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);
+ push_stack(sc, OP_GC_PROTECT, lt, sc->code);
+ sc->code = caddr(sc->code);
+ sc->value = op_lambda(sc, sc->code); /* don't unstack */
+ sc->value = find_and_apply_method(sc, lt, method, list_2(sc, lt, sc->value));
+ }
+ else
+ if (is_symbol(car(sc->code))) /* might be e.g. #_call-with-input-string so use c_function_name */
+ wrong_type_error_nr(sc, car(sc->code), 1, lt, sc->type_names[T_STRING]);
+ else wrong_type_error_nr(sc, wrap_string(sc, c_function_name(car(sc->code)), c_function_name_length(car(sc->code))), 1, lt, sc->type_names[T_STRING]);
+}
+
+static bool op_with_io_op(s7_scheme *sc)
+{
+ sc->value = cadr(sc->code);
+ if (is_string(sc->value))
+ {
+ sc->code = op_with_io_1(sc);
+ return(false);
+ }
+ push_stack_no_args_direct(sc, OP_WITH_IO_1);
+ sc->code = sc->value;
+ return(true);
+}
+
+static void op_with_output_to_string(s7_scheme *sc)
+{
+ s7_pointer old_port = current_output_port(sc);
+ set_current_output_port(sc, s7_open_output_string(sc));
+ push_stack(sc, OP_UNWIND_OUTPUT, old_port, current_output_port(sc));
+ set_curlet(sc, inline_make_let(sc, sc->curlet));
+ push_stack(sc, OP_GET_OUTPUT_STRING, old_port, current_output_port(sc));
+ sc->code = opt2_pair(sc->code);
+}
+
+static void op_call_with_output_string(s7_scheme *sc)
+{
+ s7_pointer port = s7_open_output_string(sc);
+ push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port);
+ set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt3_sym(sc->code), port));
+ push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port);
+ sc->code = opt2_pair(sc->code);
+}
+
+
+/* -------------------------------- iterators -------------------------------- */
+#if S7_DEBUGGING
+static s7_pointer titr_let(s7_scheme *sc, s7_pointer p, const char *func, int32_t line)
+{
+ 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);
+ if (sc->stop_at_error) abort();
+ }
+ return(p);
+}
+
+static s7_pointer titr_pair(s7_scheme *sc, s7_pointer p, const char *func, int32_t line)
+{
+ 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);
+ if (sc->stop_at_error) abort();
+ }
+ return(p);
+}
+
+static s7_pointer titr_hash(s7_scheme *sc, s7_pointer p, const char *func, int32_t line)
+{
+ 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);
+ if (sc->stop_at_error) abort();
+ }
+ return(p);
+}
+
+static s7_pointer titr_len(s7_scheme *sc, s7_pointer p, const char *func, int32_t line)
+{
+ 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);
+ if (sc->stop_at_error) abort();
+ }
+ return(p);
+}
+
+static s7_pointer titr_pos(s7_scheme *sc, s7_pointer p, const char *func, int32_t line)
+{
+ if (((is_let(iterator_sequence(p))) && (iterator_sequence(p) != sc->rootlet) && (iterator_sequence(p) != sc->s7_starlet)) ||
+ (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);
+ if (sc->stop_at_error) abort();
+ }
+ return(p);
+}
+#endif
+
+
+/* -------------------------------- iterator? -------------------------------- */
+static s7_pointer g_is_iterator(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_iterator "(iterator? obj) returns #t if obj is an iterator."
+ #define Q_is_iterator sc->pl_bt
+
+ s7_pointer x = car(args);
+ if (is_iterator(x)) return(sc->T);
+ /* closure itself is not an iterator: (let ((c1 (let ((+iterator+ #t) (a 0)) (lambda () (set! a (+ a 1)))))) (iterate c1)): error (a function not an iterator) */
+ check_boolean_method(sc, is_iterator, sc->is_iterator_symbol, args);
+ return(sc->F);
+}
+
+bool s7_is_iterator(s7_pointer obj) {return(is_iterator(obj));}
+
+static bool is_iterator_b_7p(s7_scheme *sc, s7_pointer obj) {return(g_is_iterator(sc, set_plist_1(sc, obj)) != sc->F);}
+
+
+static s7_pointer iterator_copy(s7_scheme *sc, s7_pointer p)
+{
+ /* fields are obj cur [loc|lcur] [len|slow|hcur] next, but untangling them in debugging case is a pain */
+ s7_pointer iter;
+ new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE);
+ memcpy((void *)iter, (void *)p, sizeof(s7_cell)); /* picks up ITER_OK I hope */
+ return(iter);
+}
+
+static s7_pointer iterator_finished(s7_scheme *sc, s7_pointer iterator) {return(ITERATOR_END);}
+
+static s7_pointer iterator_quit(s7_pointer iterator)
+{
+ iterator_next(iterator) = iterator_finished;
+ clear_iter_ok(iterator);
+ return(ITERATOR_END);
+}
+
+static s7_pointer let_iterate(s7_scheme *sc, s7_pointer iterator)
+{
+ s7_pointer p, slot = iterator_current_slot(iterator);
+ if (!tis_slot(slot))
+ return(iterator_quit(iterator));
+ iterator_set_current_slot(iterator, next_slot(slot));
+ p = iterator_let_cons(iterator);
+ if (!p)
+ return(cons(sc, slot_symbol(slot), slot_value(slot)));
+ set_car(p, slot_symbol(slot));
+ set_cdr(p, slot_value(slot));
+ return(p);
+}
+
+static s7_pointer hash_entry_to_cons(s7_scheme *sc, hash_entry_t *entry, s7_pointer p)
+{
+ if (!p)
+ return(cons(sc, hash_entry_key(entry), hash_entry_value(entry)));
+ set_car(p, hash_entry_key(entry));
+ set_cdr(p, hash_entry_value(entry));
+ return(p);
+}
+
+static s7_pointer hash_table_iterate(s7_scheme *sc, s7_pointer iterator)
+{
+ s7_pointer table;
+ s7_int len;
+ hash_entry_t **elements;
+ hash_entry_t *lst = iterator_hash_current(iterator);
+
+ if (lst)
+ {
+ iterator_hash_current(iterator) = hash_entry_next(lst);
+ return(hash_entry_to_cons(sc, lst, iterator_current(iterator)));
+ }
+ table = iterator_sequence(iterator); /* using iterator_length and hash_table_entries here was slightly slower */
+ len = hash_table_size(table);
+ elements = hash_table_elements(table);
+
+ for (s7_int loc = iterator_position(iterator) + 1; loc < len; loc++)
+ {
+ 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)));
+ }}
+ if (is_weak_hash_table(table))
+ {
+ clear_weak_hash_iterator(iterator);
+ weak_hash_iters(table)--;
+ }
+ return(iterator_quit(iterator));
+}
+
+static s7_pointer string_iterate(s7_scheme *sc, s7_pointer obj)
+{
+ if (iterator_position(obj) < iterator_length(obj))
+ return(chars[(uint8_t)(string_value(iterator_sequence(obj))[iterator_position(obj)++])]);
+ return(iterator_quit(obj));
+}
+
+static s7_pointer byte_vector_iterate(s7_scheme *sc, s7_pointer obj)
+{
+ if (iterator_position(obj) < iterator_length(obj))
+ return(small_int(byte_vector(iterator_sequence(obj), iterator_position(obj)++)));
+ return(iterator_quit(obj));
+}
+
+static s7_pointer float_vector_iterate(s7_scheme *sc, s7_pointer obj)
+{
+ if (iterator_position(obj) < iterator_length(obj))
+ return(make_real(sc, float_vector(iterator_sequence(obj), iterator_position(obj)++)));
+ return(iterator_quit(obj));
+}
+
+static s7_pointer int_vector_iterate(s7_scheme *sc, s7_pointer obj)
+{
+ if (iterator_position(obj) < iterator_length(obj))
+ return(make_integer(sc, int_vector(iterator_sequence(obj), iterator_position(obj)++)));
+ return(iterator_quit(obj));
+}
+
+static s7_pointer vector_iterate(s7_scheme *sc, s7_pointer obj)
+{
+ if (iterator_position(obj) < iterator_length(obj))
+ return(vector_element(iterator_sequence(obj), iterator_position(obj)++));
+ return(iterator_quit(obj));
+}
+
+static s7_pointer closure_iterate(s7_scheme *sc, s7_pointer obj)
+{
+ /* this can be confusing: below a hash-table is the "function", and a function is the "iterator" only because with-let exports +iterator+=#t -> infinite loop!
+ (with-let
+ (let ((+iterator+ #t))
+ (lambda () #<eof>)) ; this works because a function has an associated let?? with-let first arg should be a let.
+ (for-each
+ (make-hash-table) ; (hash-table) -- ((hash-table) ()) is #f (not an error)
+ ;(vector 1) ; error: vector-ref second argument, (), is nil but should be an integer
+ ;(vector) ; error: for-each first argument #() called with 1 argument?
+ ;(list) ; for-each first argument, (), is nil but should be a procedure or something applicable
+ (lambda args args) ; function as iterator because local +iterator+ above is #t, never returns #<eof> (always () because iterator func takes no args)
+ ;(lambda (asd) ()) ; error: make-iterator argument, #<lambda (asd)>, is a function but should be a thunk
+ ))
+ * similarly:
+ (with-let
+ (let ((+documentation+ "hiho")) (curlet))
+ (define (f) 1) ; (define (f) "a string" 1) would return doc as "a string"
+ (display (documentation f)) (newline)) ; "hiho" -- should we block +documentation+ in with-let?
+ */
+ s7_pointer result = s7_call(sc, iterator_sequence(obj), sc->nil);
+ /* this can't use s7_apply_function -- we need to catch the error handler's longjmp here */
+ if (result == ITERATOR_END)
+ {
+ iterator_next(obj) = iterator_finished;
+ clear_iter_ok(obj);
+ }
+ return(result);
+}
+
+static s7_pointer c_object_iterate(s7_scheme *sc, s7_pointer obj)
+{
+ s7_pointer result, p, cur;
+ if (iterator_position(obj) >= iterator_length(obj))
+ return(iterator_quit(obj));
+ p = iterator_sequence(obj);
+ cur = iterator_current(obj);
+ set_car(cur, p);
+ set_car(cdr(cur), make_integer(sc, iterator_position(obj))); /* perhaps wrap_integer, c_object_ref->c_object_getter is c_function in scheme? */
+ result = (*(c_object_ref(sc, p)))(sc, cur); /* used to save/restore sc->x|z here */
+ iterator_position(obj)++;
+ if (result == ITERATOR_END)
+ {
+ iterator_next(obj) = iterator_finished;
+ clear_iter_ok(obj);
+ }
+ return(result);
+}
+
+static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer obj);
+static s7_pointer pair_iterate(s7_scheme *sc, s7_pointer obj)
+{
+ s7_pointer result;
+ if (!is_pair(iterator_current(obj)))
+ return(iterator_quit(obj));
+ result = car(iterator_current(obj));
+ iterator_current(obj) = cdr(iterator_current(obj));
+ if (iterator_current(obj) == iterator_slow(obj))
+ iterator_current(obj) = sc->nil;
+ iterator_next(obj) = pair_iterate_1;
+ return(result);
+}
+
+static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer obj)
+{
+ s7_pointer result;
+ if (!is_pair(iterator_current(obj)))
+ return(iterator_quit(obj));
+ result = car(iterator_current(obj));
+ iterator_current(obj) = cdr(iterator_current(obj));
+ if (iterator_current(obj) == iterator_slow(obj))
+ iterator_current(obj) = sc->nil;
+ else iterator_set_slow(obj, cdr(iterator_slow(obj)));
+ iterator_next(obj) = pair_iterate;
+ return(result);
+}
+
+static s7_pointer find_make_iterator_method(s7_scheme *sc, s7_pointer e, s7_pointer iter)
+{
+ s7_pointer func;
+ if ((has_active_methods(sc, e)) &&
+ ((func = find_method_with_let(sc, e, sc->make_iterator_symbol)) != sc->undefined))
+ {
+ s7_pointer it;
+ gc_protect_via_stack(sc, iter);
+ 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));
+ return(it);
+ }
+ return(NULL);
+}
+
+
+/* -------------------------------- make-iterator -------------------------------- */
+static s7_pointer funclet_entry(s7_scheme *sc, s7_pointer x, s7_pointer sym)
+{
+ if ((has_closure_let(x)) && (is_let(closure_let(x))) && (closure_let(x) != sc->rootlet))
+ {
+ 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)));
+ if (is_slot(val))
+ return(slot_value(val));
+ }
+ return(NULL);
+}
+
+static bool is_iterable_closure(s7_scheme *sc, s7_pointer x)
+{
+ s7_pointer iter;
+ if (!is_thunk(sc, x))
+ sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, x, a_thunk_string);
+ iter = funclet_entry(sc, x, sc->local_iterator_symbol);
+ return((iter) && (iter != sc->F));
+}
+
+static s7_pointer s7_starlet_make_iterator(s7_scheme *sc, s7_pointer iter);
+static s7_int c_object_length_to_int(s7_scheme *sc, s7_pointer obj);
+
+s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e)
+{
+ s7_pointer iter, p;
+ new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE | T_ITER_OK);
+ iterator_sequence(iter) = e;
+
+ if (is_pair(e)) /* by far the most common case */
+ {
+ iterator_current(iter) = e;
+ iterator_next(iter) = pair_iterate;
+ iterator_set_slow(iter, e);
+ return(iter);
+ }
+ if (!is_let(e))
+ iterator_position(iter) = 0;
+
+ switch (type(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);
+ }
+ if (e == sc->s7_starlet)
+ 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));
+ iterator_next(iter) = let_iterate;
+ iterator_let_cons(iter) = NULL;
+ break;
+
+ case T_HASH_TABLE:
+ iterator_hash_current(iter) = NULL;
+ iterator_current(iter) = NULL;
+ 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);
+ }
+ break;
+
+ case T_STRING:
+ iterator_length(iter) = string_length(e);
+ iterator_next(iter) = string_iterate;
+ break;
+
+ case T_BYTE_VECTOR:
+ iterator_length(iter) = byte_vector_length(e);
+ iterator_next(iter) = byte_vector_iterate;
+ break;
+
+ case T_VECTOR:
+ iterator_length(iter) = vector_length(e);
+ iterator_next(iter) = vector_iterate;
+ break;
+
+ case T_INT_VECTOR:
+ iterator_length(iter) = vector_length(e);
+ iterator_next(iter) = int_vector_iterate;
+ break;
+
+ case T_FLOAT_VECTOR:
+ iterator_length(iter) = vector_length(e);
+ iterator_next(iter) = float_vector_iterate;
+ break;
+
+ case T_NIL: /* (make-iterator #()) -> #<iterator: vector>, so I guess () should also work */
+ iterator_length(iter) = 0;
+ iterator_next(iter) = iterator_finished;
+ clear_iter_ok(iter);
+ break;
+
+ case T_MACRO: case T_MACRO_STAR:
+ 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;
+ }
+ 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));
+ }
+ break;
+
+ case T_C_OBJECT:
+ iterator_length(iter) = c_object_length_to_int(sc, e);
+ p = find_make_iterator_method(sc, e, iter);
+ if (p) {free_cell(sc, iter); return(p);}
+ iterator_current(iter) = list_2_unchecked(sc, e, int_zero); /* if not unchecked, gc protect iter */
+ set_mark_seq(iter);
+ iterator_next(iter) = c_object_iterate;
+ break;
+
+ default:
+ free_cell(sc, iter); /* 19-Mar-22 */
+ sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, e, a_sequence_string);
+ }
+ return(iter);
+}
+
+static s7_pointer g_make_iterator(s7_scheme *sc, s7_pointer args)
+{
+ #define H_make_iterator "(make-iterator sequence carrier) returns an iterator object that returns the next value \
+in the sequence each time it is called. When it reaches the end, it returns " ITERATOR_END_NAME "."
+ #define Q_make_iterator s7_make_signature(sc, 3, sc->is_iterator_symbol, sc->is_sequence_symbol, sc->is_pair_symbol)
+
+ /* we need to call s7_make_iterator before fixing up the optional second arg in case let->method */
+ s7_pointer seq = car(args);
+ s7_pointer carrier = (is_pair(cdr(args))) ? cadr(args) : NULL;
+ s7_pointer iter = s7_make_iterator(sc, seq);
+
+ if (carrier)
+ {
+ if (!is_pair(carrier))
+ 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));
+
+ if (is_hash_table(iterator_sequence(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);
+ }}
+ return(iter);
+}
+
+
+/* -------------------------------- iterate -------------------------------- */
+static s7_pointer g_iterate(s7_scheme *sc, s7_pointer args)
+{
+ #define H_iterate "(iterate obj) returns the next element from the iterator obj, or " ITERATOR_END_NAME "."
+ #define Q_iterate s7_make_signature(sc, 2, sc->T, sc->is_iterator_symbol)
+ s7_pointer iter = car(args);
+ if (!is_iterator(iter))
+ return(sole_arg_method_or_bust(sc, iter, sc->iterate_symbol, args, sc->type_names[T_ITERATOR]));
+ return((iterator_next(iter))(sc, iter));
+}
+
+static s7_pointer iterate_p_p(s7_scheme *sc, s7_pointer iter)
+{
+ if (!is_iterator(iter))
+ return(method_or_bust_p(sc, iter, sc->iterate_symbol, sc->type_names[T_ITERATOR]));
+ return((iterator_next(iter))(sc, iter));
+}
+
+s7_pointer s7_iterate(s7_scheme *sc, s7_pointer obj) {return((iterator_next(obj))(sc, obj));}
+
+bool s7_iterator_is_at_end(s7_scheme *sc, s7_pointer obj)
+{
+ if (!is_iterator(obj))
+ sole_arg_wrong_type_error_nr(sc, sc->iterator_is_at_end_symbol, obj, sc->type_names[T_ITERATOR]);
+ return(!iter_ok(obj));
+}
+
+static bool op_implicit_iterate(s7_scheme *sc)
+{
+ s7_pointer s = lookup_checked(sc, car(sc->code));
+ if (!is_iterator(s)) {sc->last_function = s; return(false);}
+ sc->value = (iterator_next(s))(sc, s);
+ return(true);
+}
+
+
+/* -------------------------------- iterator-at-end? -------------------------------- */
+static bool iterator_is_at_end_b_7p(s7_scheme *sc, s7_pointer obj)
+{
+ if (!is_iterator(obj))
+ sole_arg_wrong_type_error_nr(sc, sc->iterator_is_at_end_symbol, obj, sc->type_names[T_ITERATOR]);
+ return(!iter_ok(obj));
+}
+
+static s7_pointer g_iterator_is_at_end(s7_scheme *sc, s7_pointer args)
+{
+ #define H_iterator_is_at_end "(iterator-at-end? iter) returns #t if the iterator has reached the end of its sequence."
+ #define Q_iterator_is_at_end s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_iterator_symbol)
+ s7_pointer iter = car(args);
+ if (!is_iterator(iter))
+ return(sole_arg_method_or_bust(sc, iter, sc->iterator_is_at_end_symbol, args, sc->type_names[T_ITERATOR]));
+ return(make_boolean(sc, !iter_ok(iter)));
+}
+
+
+/* -------------------------------- iterator-sequence -------------------------------- */
+static s7_pointer g_iterator_sequence(s7_scheme *sc, s7_pointer args)
+{
+ #define H_iterator_sequence "(iterator-sequence iterator) returns the sequence that iterator is traversing."
+ #define Q_iterator_sequence s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_iterator_symbol)
+ s7_pointer iter = car(args);
+ if (!is_iterator(iter))
+ return(sole_arg_method_or_bust(sc, iter, sc->iterator_sequence_symbol, args, sc->type_names[T_ITERATOR]));
+ return(iterator_sequence(iter));
+}
+
+
+/* -------- cycles -------- */
+
+#define INITIAL_SHARED_INFO_SIZE 8
+
+static int32_t shared_ref(shared_info_t *ci, const s7_pointer p)
+{
+ /* from print after collecting refs, not called by equality check, only called in object_to_port_with_circle_check_1 */
+ s7_pointer *objs = ci->objs;
+ 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);
+ }
+ return(0);
+}
+
+static void flip_ref(shared_info_t *ci, const s7_pointer p)
+{
+ s7_pointer *objs = ci->objs;
+ for (int32_t i = 0; i < ci->top; i++)
+ if (objs[i] == p)
+ {
+ ci->refs[i] = -ci->refs[i];
+ break;
+ }
+}
+
+static int32_t peek_shared_ref_1(shared_info_t *ci, const s7_pointer p)
+{
+ /* returns 0 if not found, otherwise the ref value for p */
+ s7_pointer *objs = ci->objs;
+ for (int32_t i = 0; i < ci->top; i++)
+ if (objs[i] == p)
+ return(ci->refs[i]);
+ return(0);
+}
+
+static int32_t peek_shared_ref(shared_info_t *ci, s7_pointer p)
+{
+ /* returns 0 if not found, otherwise the ref value for p */
+ return((is_collected_unchecked(p)) ? peek_shared_ref_1(ci, p) : 0);
+}
+
+static void enlarge_shared_info(shared_info_t *ci)
+{
+ ci->size *= 2;
+ ci->size2 = ci->size - 2;
+ ci->objs = (s7_pointer *)Realloc(ci->objs, ci->size * sizeof(s7_pointer));
+ ci->refs = (int32_t *)Realloc(ci->refs, ci->size * sizeof(int32_t));
+ ci->defined = (bool *)Realloc(ci->defined, ci->size * sizeof(bool));
+ /* this clearing is needed, memclr is not faster */
+ for (int32_t i = ci->top; i < ci->size; i++)
+ {
+ ci->refs[i] = 0;
+ ci->objs[i] = NULL;
+ }
+}
+
+static bool check_collected(s7_pointer top, shared_info_t *ci)
+{
+ s7_pointer *objs_end = (s7_pointer *)(ci->objs + ci->top);
+ 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;
+ }
+ set_cyclic(top);
+ return(true);
+}
+
+static bool collect_shared_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top, bool stop_at_print_length);
+static bool hash_keys_not_cyclic(s7_scheme *sc, s7_pointer hash);
+
+static bool collect_vector_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top, bool stop_at_print_length)
+{
+ s7_int plen;
+ bool cyclic = false;
+
+ if (stop_at_print_length)
+ {
+ plen = sc->print_length;
+ if (plen > vector_length(top))
+ plen = vector_length(top);
+ }
+ else plen = vector_length(top);
+
+ for (s7_int i = 0; i < plen; i++)
+ {
+ 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);
+ }}
+ if (cyclic) set_cyclic(top);
+ return(cyclic);
+}
+
+static bool collect_shared_info(s7_scheme *sc, shared_info_t *ci, s7_pointer top, bool stop_at_print_length)
+{
+ /* look for top in current list.
+ * As we collect objects (guaranteed to have structure) we set the collected bit. If we ever
+ * encounter an object with that bit on, we've seen it before so we have a possible cycle.
+ * Once the collection pass is done, we run through our list, and clear all these bits.
+ */
+ bool top_cyclic;
+
+ if (is_collected_or_shared(top))
+ return((!is_shared(top)) && (check_collected(top, ci)));
+
+ /* top not seen before -- add it to the list */
+ set_collected(top);
+
+ if (ci->top == ci->size)
+ enlarge_shared_info(ci);
+ ci->objs[ci->top++] = top;
+
+ top_cyclic = false;
+ /* now search the rest of this structure */
+ if (is_pair(top))
+ {
+ s7_pointer p;
+ if ((has_structure(car(top))) &&
+ (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 ((has_structure(p)) &&
+ (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);
+ else set_cyclic(top);
+ return(top_cyclic);
+ }
+
+ switch (type(top))
+ {
+ case T_VECTOR:
+ if (collect_vector_info(sc, ci, top, stop_at_print_length))
+ 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;
+ }
+ 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;
+ }}}
+ 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;
+ break;
+
+ case T_LET:
+ if (top == sc->rootlet)
+ {
+ 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);
+ }
+ 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;
+ }
+ 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;
+ }
+ 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;
+ }
+ 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;
+ }
+ break;
+ }
+ if (!top_cyclic)
+ set_shared(top);
+ else set_cyclic(top);
+ return(top_cyclic);
+}
+
+static shared_info_t *make_shared_info(s7_scheme *sc)
+{
+ shared_info_t *ci = (shared_info_t *)Calloc(1, sizeof(shared_info_t));
+ ci->size = INITIAL_SHARED_INFO_SIZE;
+ ci->size2 = ci->size - 2;
+ ci->objs = (s7_pointer *)Malloc(ci->size * sizeof(s7_pointer));
+ ci->refs = (int32_t *)Calloc(ci->size, sizeof(int32_t)); /* finder expects 0 = unseen previously */
+ ci->defined = (bool *)Calloc(ci->size, sizeof(bool));
+ ci->cycle_port = sc->F;
+ ci->init_port = sc->F;
+ return(ci);
+}
+
+static void free_shared_info(shared_info_t *ci)
+{
+ if (ci)
+ {
+ free(ci->objs);
+ free(ci->refs);
+ free(ci->defined);
+ free(ci);
+ }
+}
+
+static inline shared_info_t *clear_shared_info(shared_info_t *ci)
+{
+ if (ci->top > 0)
+ {
+ 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 */
+ ci->top = 0;
+ }
+ ci->ref = 0;
+ ci->has_hits = false;
+ ci->ctr = 0;
+ return(ci);
+}
+
+static shared_info_t *load_shared_info(s7_scheme *sc, s7_pointer top, bool stop_at_print_length, shared_info_t *ci)
+{
+ /* for the printer, here only if is_structure(top) and top is not sc->rootlet */
+ bool no_problem = true;
+ s7_int k, stop_len;
+
+ /* check for simple cases first */
+ if (is_pair(top))
+ {
+ 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;}
+ }}
+ 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 ((no_problem) &&
+ (!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);
+ }
+
+ 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);
+ }
+ 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);
+ }
+
+ 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);
+ {
+ /* collect all pointers associated with top */
+ bool cyclic = collect_shared_info(sc, ci, top, stop_at_print_length);
+ s7_pointer *ci_objs = ci->objs;
+ int32_t *ci_refs = ci->refs;
+ int32_t refs = 0;
+
+ for (int32_t i = 0; i < ci->top; i++)
+ clear_collected_and_shared(ci_objs[i]);
+
+ if (!cyclic)
+ return(NULL);
+ if (!(ci->has_hits))
+ return(NULL);
+
+ /* find if any were referenced twice (once for just being there, so twice=shared)
+ * we know there's at least one such reference because has_hits is true.
+ */
+ 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;
+ }}
+ ci->top = refs;
+ return(ci);
+ }
+}
+
+
+/* -------------------------------- cyclic-sequences -------------------------------- */
+static s7_pointer cyclic_sequences_p_p(s7_scheme *sc, s7_pointer obj)
+{
+ if (has_structure(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);
+ }}
+ return(sc->nil);
+}
+
+static s7_pointer g_cyclic_sequences(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cyclic_sequences "(cyclic-sequences obj) returns a list of elements that are cyclic."
+ #define Q_cyclic_sequences s7_make_signature(sc, 2, sc->is_proper_list_symbol, sc->T)
+ return(cyclic_sequences_p_p(sc, car(args)));
+}
+
+
+/* -------------------------------- object->port (display format etc) -------------------------------- */
+static int32_t circular_list_entries(s7_pointer lst)
+{
+ int32_t i = 1;
+ for (s7_pointer x = cdr(lst); ; i++, x = cdr(x))
+ {
+ int32_t j = 0;
+ for (s7_pointer y = lst; j < i; y = cdr(y), j++)
+ 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_))) \
+ object_to_port_with_circle_check_1(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);
+#define object_to_port(Sc, Obj, Port, Use_Write, Ci) (*display_functions[unchecked_type(Obj)])(Sc, Obj, Port, Use_Write, Ci)
+
+static bool string_needs_slashification(const uint8_t *str, s7_int len)
+{
+ /* we have to go by len (str len) not *s==0 because s7 strings can have embedded nulls */
+ const uint8_t *pend = (const uint8_t *)(str + len);
+ for (const uint8_t *p = str; p < pend; p++)
+ if (slashify_table[*p])
+ return(true);
+ return(false);
+}
+
+#define IN_QUOTES true
+#define NOT_IN_QUOTES false
+
+static void slashify_string_to_port(s7_scheme *sc, s7_pointer port, const char *p, s7_int len, bool quoted)
+{
+ const uint8_t *pcur, *pend, *pstart = NULL;
+ if (len == 0)
+ {
+ if (quoted)
+ port_write_string(port)(sc, "\"\"", 2, port);
+ return;
+ }
+ pend = (const uint8_t *)(p + len);
+
+ /* what about the trailing nulls? Guile writes them out (as does s7 currently)
+ * but that is not ideal. I'd like to use ~S for error messages, so that
+ * strings are clearly identified via the double-quotes, but this way of
+ * writing them is ugly:
+ * (let ((str (make-string 8 #\null))) (set! (str 0) #\a) str) -> "a\x00\x00\x00\x00\x00\x00\x00"
+ * but it would be misleading to omit them because:
+ * (let ((str (make-string 8 #\null))) (set! (str 0) #\a) (string-append str "bc")) -> "a\x00\x00\x00\x00\x00\x00\x00bc"
+ * also it is problematic to use sc->print_length here (rather than a separate string-print-length) because
+ * it is normally (say) 12 which truncates just about every string. In CL, *print-length*
+ * does not affect strings, symbols, or bit-vectors. But if the string is enormous,
+ * this function can bring us to a complete halt. string-print-length (as a *s7* field) is
+ * also problematic -- it does not behave as expected in many cases if it is limited to this
+ * function and string_to_port below, and if set too low, disables the repl.
+ */
+ if (quoted) port_write_character(port)(sc, '"', port);
+ 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)
+ 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);
+ }
+ if (quoted) port_write_character(port)(sc, '"', port);
+}
+
+static void output_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ if ((obj == sc->standard_output) ||
+ (obj == sc->standard_error))
+ port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), 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);
+ }
+ 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);
+ }
+}
+
+static void input_port_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ if (obj == sc->standard_input)
+ port_write_string(port)(sc, port_filename(obj), port_filename_length(obj), port);
+ 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)
+ {
+ #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);
+ }}
+ 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);
+ }
+}
+
+static bool symbol_needs_slashification(s7_scheme *sc, s7_pointer obj)
+{
+ uint8_t *pend;
+ char *str = symbol_name(obj);
+ s7_int len;
+
+ if ((str[0] == '#') || (str[0] == '\'') || (str[0] == ','))
+ return(true);
+ if (is_number(make_atom(sc, str, 10, NO_SYMBOLS, WITHOUT_OVERFLOW_ERROR)))
+ return(true);
+
+ len = symbol_name_length(obj);
+ pend = (uint8_t *)(str + len);
+ for (uint8_t *p = (uint8_t *)str; p < pend; p++)
+ if (symbol_slashify_table[*p])
+ return(true);
+ set_clean_symbol(obj);
+ return(false);
+}
+
+static /* inline */ void symbol_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ /* I think this is the only place we print a symbol's name; ci is needed to be a display_function, it is not used */
+ if ((!is_clean_symbol(obj)) &&
+ (symbol_needs_slashification(sc, obj)))
+ {
+ port_write_string(port)(sc, "(symbol \"", 9, port);
+ slashify_string_to_port(sc, port, symbol_name(obj), symbol_name_length(obj), NOT_IN_QUOTES);
+ port_write_string(port)(sc, "\")", 2, port);
+ }
+ else
+ {
+ char c = '\0';
+ if ((use_write == P_READABLE) || (use_write == P_CODE))
+ {
+ 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;
+ }
+ else
+ {
+ 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)
+{
+ s7_int size = vector_dimension(vect, cur_dim);
+ s7_int ind = index % size;
+ if (cur_dim > 0)
+ multivector_indices_to_string(sc, (index - ind) / size, vect, str, str_len, cur_dim - 1);
+ catstrs(str, str_len, " ", pos_int_to_str_direct(sc, ind), (char *)NULL);
+ return(str);
+}
+
+#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)
+{
+ if (use_write != P_READABLE)
+ {
+ if (*last)
+ 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);
+ }
+ 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);
+ else
+ {
+ port_write_string(port)(sc, "...)", 4, port);
+ return(flat_ref);
+ }
+ if (use_write != P_READABLE)
+ port_write_character(port)(sc, ')', port);
+ (*last) = true;
+ return(flat_ref);
+}
+
+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)
+{
+ bool last = false;
+ return(multivector_to_port_1(sc, vec, port, out_len, flat_ref, dimension, dimensions, &last, use_write, ci));
+}
+
+static void make_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port)
+{
+ s7_int vlen;
+ int32_t plen;
+ char buf[128];
+ const char* vtyp = "";
+
+ if (is_float_vector(vect))
+ vtyp = "float-";
+ else
+ if (is_int_vector(vect))
+ vtyp = "int-";
+ else
+ if (is_byte_vector(vect))
+ vtyp = "byte-";
+ vlen = vector_length(vect);
+
+ if (vector_rank(vect) == 1)
+ {
+ plen = (int32_t)catstrs_direct(buf, "(make-", vtyp, "vector ", integer_to_string_no_length(sc, vlen), " ", (const char *)NULL);
+ port_write_string(port)(sc, buf, plen, port);
+ }
+ else
+ {
+ s7_int dim;
+ 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);
+ }
+}
+
+static void write_vector_dimensions(s7_scheme *sc, s7_pointer vect, s7_pointer port)
+{
+ char buf[128];
+ s7_int dim, plen;
+ port_write_string(port)(sc, " '(", 3, port);
+ for (dim = 0; dim < vector_ndims(vect) - 1; dim++)
+ {
+ plen = 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 = catstrs_direct(buf, integer_to_string_no_length(sc, vector_dimension(vect, dim)), "))", (const char *)NULL);
+ port_write_string(port)(sc, buf, plen, port);
+}
+
+static void port_write_vector_typer(s7_scheme *sc, s7_pointer vect, s7_pointer port);
+
+static void vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *ci)
+{
+ s7_int i, len = vector_length(vect), plen;
+ bool too_long = false;
+ char buf[2048]; /* 128 is too small -- this is the list of indices with a few minor flourishes */
+
+ 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);
+ }
+ 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 (len > sc->print_length)
+ {
+ too_long = true;
+ len = sc->print_length;
+ }}
+ if ((!ci) &&
+ (len > 1000))
+ {
+ s7_int vlen = vector_length(vect);
+ s7_pointer *els = vector_elements(vect);
+ s7_pointer p0 = els[0];
+ for (i = 1; i < vlen; i++)
+ 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;
+ }}
+
+ check_stack_size(sc);
+ gc_protect_via_stack(sc, vect);
+ if (use_write == P_READABLE)
+ {
+ 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);
+ }}
+ 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);
+ }}}
+ 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);
+ }
+ 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);
+ }}
+ unstack_gc_protect(sc);
+}
+
+static int32_t print_vector_length(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write)
+{
+ int32_t plen, len = vector_length(vect);
+ char buf[128];
+ const char *vtype = "r";
+
+ if (is_int_vector(vect)) vtype = "i";
+ else if (is_byte_vector(vect)) vtype = "u";
+ 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);
+ else plen = (int32_t)catstrs_direct(buf, "#", vtype, "()", (const char *)NULL);
+ port_write_string(port)(sc, buf, plen, port);
+ return(-1);
+ }
+ if (use_write == P_READABLE)
+ return(len);
+ if (sc->print_length != 0)
+ return((len > sc->print_length) ? sc->print_length : len);
+
+ if (vector_rank(vect) > 1)
+ {
+ plen = (int32_t)catstrs_direct(buf, "#", vtype, pos_int_to_str_direct(sc, vector_ndims(vect)), "d(...)", (const char *)NULL);
+ port_write_string(port)(sc, buf, plen, port);
+ }
+ else
+ if (is_int_vector(vect))
+ port_write_string(port)(sc, "#i(...)", 7, port);
+ else
+ if (is_float_vector(vect))
+ port_write_string(port)(sc, "#r(...)", 7, port);
+ else port_write_string(port)(sc, "#u(...)", 7, port);
+ return(-1);
+}
+
+static void int_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ s7_int plen;
+ bool too_long;
+ char buf[128];
+ const char *p;
+ s7_int len = print_vector_length(sc, vect, port, use_write);
+ if (len < 0) return;
+ too_long = (len < vector_length(vect));
+
+ if ((use_write == P_READABLE) &&
+ (is_immutable_vector(vect)))
+ port_write_string(port)(sc, "(immutable! ", 12, port);
+
+ if (len > 1000)
+ {
+ s7_int i, vlen = vector_length(vect);
+ 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 (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;
+ }}
+ 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);
+ }}
+ 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;
+ }
+ if (too_long)
+ port_write_string(port)(sc, " ...)", 5, port);
+ else port_write_character(port)(sc, ')', port);
+ }
+ else
+ {
+ plen = catstrs_direct(buf, "#i", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL);
+ port_write_string(port)(sc, buf, plen, port);
+ gc_protect_via_stack(sc, vect);
+ multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), P_DISPLAY, NULL);
+ unstack_gc_protect(sc);
+ }
+ if ((use_write == P_READABLE) &&
+ (is_immutable_vector(vect)))
+ port_write_character(port)(sc, ')', port);
+}
+
+static void float_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ #define FV_BUFSIZE 512 /* some floats can take around 312 bytes */
+ char buf[FV_BUFSIZE];
+ s7_int i, plen;
+ bool too_long;
+ const s7_double *els = float_vector_floats(vect);
+ s7_int len = print_vector_length(sc, vect, port, use_write);
+ if (len < 0) return; /* vector-length=0 etc */
+ too_long = (len < vector_length(vect));
+
+ if ((use_write == P_READABLE) &&
+ (is_immutable_vector(vect)))
+ port_write_string(port)(sc, "(immutable! ", 12, port);
+
+ if (len > 1000)
+ {
+ s7_int vlen = vector_length(vect);
+ s7_double first = els[0];
+ for (i = 1; i < vlen; i++)
+ 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;
+ }}
+
+ if (vector_rank(vect) == 1)
+ {
+ port_write_string(port)(sc, "#r(", 3, port);
+ plen = snprintf(buf, FV_BUFSIZE - 4, "%.*g", sc->float_format_precision, els[0]); /* -4 so floatify has room */
+ 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);
+ }
+ if (too_long)
+ port_write_string(port)(sc, " ...)", 5, port);
+ else port_write_character(port)(sc, ')', port);
+ }
+ else
+ {
+ plen = catstrs_direct(buf, "#r", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL);
+ port_write_string(port)(sc, buf, plen, port);
+ gc_protect_via_stack(sc, vect);
+ multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), P_DISPLAY, NULL);
+ unstack_gc_protect(sc);
+ }
+ if ((use_write == P_READABLE) &&
+ (is_immutable_vector(vect)))
+ port_write_character(port)(sc, ')', port);
+}
+
+static void byte_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ s7_int i, plen;
+ bool too_long;
+ char buf[128];
+ const char *p;
+ s7_int len = print_vector_length(sc, vect, port, use_write);
+ if (len < 0) return;
+ too_long = (len < vector_length(vect));
+
+ if ((use_write == P_READABLE) &&
+ (is_immutable_vector(vect)))
+ port_write_string(port)(sc, "(immutable! ", 12, port);
+
+ if (len > 1000)
+ {
+ s7_int vlen = vector_length(vect);
+ 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 (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;
+ }}
+
+ if (vector_rank(vect) == 1)
+ {
+ port_write_string(port)(sc, "#u(", 3, 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);
+ }
+ if (too_long)
+ port_write_string(port)(sc, " ...)", 5, port);
+ else port_write_character(port)(sc, ')', port);
+ }
+ else
+ {
+ plen = catstrs_direct(buf, "#u", pos_int_to_str_direct(sc, vector_ndims(vect)), "d", (const char *)NULL);
+ port_write_string(port)(sc, buf, plen, port);
+ multivector_to_port(sc, vect, port, len, 0, 0, vector_ndims(vect), P_DISPLAY, NULL);
+ }
+ if ((use_write == P_READABLE) &&
+ (is_immutable_vector(vect)))
+ port_write_character(port)(sc, ')', 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 */
+ if (immutable)
+ port_write_string(port)(sc, "(immutable! ", 12, port);
+
+ if (string_length(obj) > 0)
+ {
+ /* 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;
+ }}
+ if (use_write == P_DISPLAY)
+ 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);
+ }
+ else
+ if (use_write != P_DISPLAY)
+ port_write_string(port)(sc, "\"\"", 2, port);
+
+ if (immutable)
+ port_write_character(port)(sc, ')', port);
+}
+
+static s7_int list_length_with_immutable_check(s7_scheme *sc, s7_pointer a, bool *immutable)
+{
+ s7_pointer slow = a, fast = a;
+ for (s7_int i = 0; ; i += 2)
+ {
+ if (!is_pair(fast)) return((is_null(fast)) ? i : -i);
+ if (is_immutable_pair(fast)) *immutable = true;
+ fast = cdr(fast);
+ if (!is_pair(fast)) return((is_null(fast)) ? (i + 1) : (-i - 1));
+ if (is_immutable_pair(fast)) *immutable = true;
+ fast = cdr(fast);
+ slow = cdr(slow);
+ if (fast == slow) return(0);
+ }
+ return(0);
+}
+
+static void simple_list_readable_display(s7_scheme *sc, s7_pointer lst, s7_int true_len, s7_int len, s7_pointer port, shared_info_t *ci, bool immutable)
+{
+ /* the easier cases: no circles or shared refs to patch up */
+ s7_pointer x;
+
+ if ((true_len > 0) && (!immutable))
+ {
+ 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);
+ }
+ else
+ {
+ s7_int immutable_ctr = 0;
+ if (is_immutable_pair(lst))
+ {
+ 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_null(x))
+ 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);
+ }
+ for (s7_int i = (true_len <= 0) ? 1 : 0; i < len; i++)
+ port_write_character(port)(sc, ')', port);
+ for (s7_int i = 0; i < immutable_ctr; i++)
+ port_write_character(port)(sc, ')', port);
+ }
+}
+
+static void pair_to_port(s7_scheme *sc, s7_pointer lst, s7_pointer port, use_write_t use_write, shared_info_t *ci)
+{
+ s7_pointer x;
+ s7_int i, len;
+ bool immutable = false;
+ s7_int true_len = list_length_with_immutable_check(sc, lst, &immutable);
+
+ if (true_len < 0) /* a dotted list -- handle cars, then final cdr */
+ len = (-true_len + 1);
+ else len = (true_len == 0) ? circular_list_entries(lst) : true_len; /* circular list (nil is handled by unique_to_port) */
+
+ if ((use_write == P_READABLE) && (ci))
+ {
+ 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 ((use_write != P_READABLE) &&
+ ((car(lst) == sc->quote_function) || (car(lst) == sc->quote_symbol)) &&
+ (true_len == 2))
+ {
+ bool need_new_ci = ((!ci) && (is_pair(cadr(lst))));
+ shared_info_t *new_ci = NULL, *temp_ci = NULL;
+ bool old_locked = sc->object_out_locked;
+ /* true_len == 2 is important, otherwise (list 'quote 1 2) -> '1 2 which looks weird
+ * or (object->string (apply . `''1)) -> "'quote 1"
+ * so (quote x) = 'x but (quote x y z) should be left alone (if evaluated, it's an error)
+ * :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);
+ 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! */
+ }
+ 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);
+ }
+ if (car(lst) == sc->quote_symbol)
+ port_write_character(port)(sc, ')', port);
+ return;
+ }
+#if WITH_IMMUTABLE_UNQUOTE
+ if ((car(lst) == sc->unquote_symbol) && (true_len == 2))
+ {
+ port_write_character(port)(sc, ',', port);
+ object_to_port_with_circle_check(sc, cadr(lst), port, P_WRITE, ci);
+ return;
+ }
+#endif
+
+ if (is_multiple_value(lst))
+ port_write_string(port)(sc, "(values ", 8, port);
+ else port_write_character(port)(sc, '(', port);
+
+ 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;
+ }
+ 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);
+ }
+ 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;
+ }
+ 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);
+ }
+ 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);
+ }}
+}
+
+static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let);
+static const char *hash_table_checker_name(s7_scheme *sc, s7_pointer ht);
+
+static const char *hash_table_typer_name(s7_scheme *sc, s7_pointer typer)
+{
+ s7_pointer sym;
+ if (is_c_function(typer)) return(c_function_name(typer));
+ if (is_boolean(typer)) return("#t");
+ if (typer == sc->unused) return("#<unused>"); /* mapper can be sc->unused briefly */
+ sym = find_closure(sc, typer, closure_let(typer));
+ if (is_null(sym)) return(NULL);
+ return(symbol_name(sym));
+}
+
+static void hash_typers_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port)
+{
+ if (((is_typed_hash_table(hash)) || (is_pair(hash_table_procedures(hash)))) &&
+ ((!is_boolean(hash_table_key_typer(hash))) || (!is_boolean(hash_table_value_typer(hash)))))
+ {
+ const char *typer = hash_table_typer_name(sc, hash_table_key_typer(hash));
+ port_write_string(port)(sc, " (cons ", 7, port);
+ port_write_string(port)(sc, typer, safe_strlen(typer), port);
+ port_write_character(port)(sc, ' ', port);
+ typer = hash_table_typer_name(sc, hash_table_value_typer(hash));
+ port_write_string(port)(sc, typer, safe_strlen(typer), port);
+ port_write_string(port)(sc, "))", 2, port);
+ }
+ else port_write_character(port)(sc, ')', port);
+}
+
+static void hash_table_procedures_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, bool closed, shared_info_t *ci)
+{
+ const char *typer = hash_table_checker_name(sc, hash);
+ if ((closed) && (is_immutable_hash_table(hash)))
+ port_write_string(port)(sc, "(immutable! ", 12, port);
+
+ 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);
+ }
+ 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);
+ }
+ 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);
+ 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);
+ port_write_string(port)(sc, typer, safe_strlen(typer), port);
+ hash_typers_to_port(sc, hash, port);
+ }
+ if (is_immutable_hash_table(hash))
+ port_write_character(port)(sc, ')', port);
+}
+
+static void hash_table_to_port(s7_scheme *sc, s7_pointer hash, s7_pointer port, use_write_t use_write, shared_info_t *ci)
+{
+ s7_int gc_iter, len = hash_table_entries(hash);
+ bool too_long = false, hash_cyclic = false, copied = false, immut = false, letd = false;
+ s7_pointer iterator, p;
+ int32_t href = -1;
+
+ if (len == 0)
+ {
+ if (use_write == P_READABLE)
+ 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);
+ }
+ return;
+ }
+
+ if (use_write != P_READABLE)
+ {
+ s7_int plen = sc->print_length;
+ if (plen <= 0)
+ {
+ port_write_string(port)(sc, "(hash-table ...)", 16, port);
+ return;
+ }
+ if (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;
+ }}}
+
+ iterator = s7_make_iterator(sc, hash);
+ gc_iter = gc_protect_1(sc, iterator);
+ p = cons_unchecked(sc, sc->F, sc->F);
+ iterator_current(iterator) = p;
+ set_mark_seq(iterator);
+ hash_cyclic = ((ci) && (is_cyclic(hash)) && ((href = peek_shared_ref(ci, hash)) != 0));
+
+ 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;
+ }
+ else
+ 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 */
+ }
+ else
+ {
+ 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);
+ }}}
+ 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);
+ }
+ 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;
+ }
+ 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);
+ }
+ if (use_write != P_READABLE)
+ {
+ 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);
+ }
+ else
+ 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);
+
+ if ((!immut) && (is_immutable_hash_table(hash)) && (!hash_cyclic))
+ port_write_string(port)(sc, ") (immutable! <h>))", 19, port);
+ }
+ s7_gc_unprotect_at(sc, gc_iter);
+ iterator_current(iterator) = sc->nil;
+ free_cell(sc, p); /* free_cell(sc, iterator); */ /* 18-Dec-18 removed */
+}
+
+static void slot_list_to_port(s7_scheme *sc, s7_pointer slot, s7_pointer port, shared_info_t *ci, bool bindings) /* bindings=let/inlet choice */
+{
+ bool first_time = true;
+ 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);
+ }
+ 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);
+ object_to_port_with_circle_check(sc, slot_value(slot), port, P_READABLE, ci);
+ if (bindings) port_write_character(port)(sc, ')', port);
+ }
+}
+
+static void slot_list_to_port_with_cycle(s7_scheme *sc, s7_pointer obj, s7_pointer slot, s7_pointer port, shared_info_t *ci, bool bindings)
+{
+ bool first_time = true;
+ for (; tis_slot(slot); slot = next_slot(slot))
+ {
+ 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);
+ }
+ 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);
+ }}
+ else
+ {
+ 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);
+ }}
+}
+
+static bool let_has_setter(s7_pointer obj)
+{
+ for (s7_pointer slot = let_slots(obj); tis_slot(slot); slot = next_slot(slot))
+ if ((slot_has_setter(slot)) || (is_immutable_slot(slot)))
+ return(true);
+ return(false);
+}
+
+static bool slot_setters_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci)
+{
+ bool spaced_out = false;
+ 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);
+ }
+ return(spaced_out);
+}
+
+static void immutable_slots_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, bool spaced_out)
+{
+ 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);
+ }
+}
+
+static void slot_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
+{
+ /* the slot symbol might need (symbol...) in which case we don't want the preceding quote */
+ symbol_to_port(sc, slot_symbol(obj), port, P_READABLE, NULL);
+ port_write_character(port)(sc, ' ', port);
+ object_to_port_with_circle_check(sc, slot_value(obj), port, use_write, ci);
+}
+
+static void internal_slot_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
+{
+ /* here we're displaying a slot in the debugger -- T_SLOT objects are not directly accessible in scheme */
+ port_write_string(port)(sc, "#<slot: ", 8, port);
+ symbol_to_port(sc, slot_symbol(obj), port, P_DISPLAY, NULL);
+ port_write_character(port)(sc, ' ', port);
+ object_to_port_with_circle_check(sc, slot_value(obj), port, use_write, ci);
+ port_write_character(port)(sc, '>', port);
+}
+
+static void let_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
+{
+ /* if outer env points to (say) method list, the object needs to specialize object->string itself */
+ if (has_active_methods(sc, obj))
+ {
+ 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;
+ }}
+ 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;}
+ if (sc->short_print) {port_write_string(port)(sc, "#<let>", 6, port); return;}
+
+ /* circles can happen here:
+ * (let () (let ((b (curlet))) (curlet))): #<let 'b #<let>>
+ * or (let ((b #f)) (set! b (curlet)) (curlet)): #1=#<let 'b #1#>
+ */
+ if (use_write == P_READABLE)
+ {
+ 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);
+ }
+ 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);
+ }}
+ 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);
+ }
+}
+
+static void write_macro_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port)
+{
+ s7_pointer expr, body = closure_body(obj), arglist = closure_args(obj);
+ /* this doesn't handle recursive macros well -- we need letrec or the equivalent as in write_closure_readably */
+ /* (letrec ((m2 (macro (x) `(if (> ,x 0) (m2 (- ,x 1)) 32)))) (object->string m2 :readable)) */
+
+ port_write_string(port)(sc, (is_either_macro(obj)) ? "(macro" : "(bacro", 6, port);
+ if ((is_macro_star(obj)) || (is_bacro_star(obj)))
+ port_write_character(port)(sc, '*', port);
+ if (is_symbol(arglist))
+ {
+ port_write_character(port)(sc, ' ', port);
+ port_write_string(port)(sc, symbol_name(arglist), symbol_name_length(arglist), port);
+ port_write_character(port)(sc, ' ', 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);
+ }
+ else port_write_string(port)(sc, " () ", 4, port);
+
+ for (expr = body; is_pair(expr); expr = cdr(expr))
+ object_to_port(sc, car(expr), port, P_WRITE, NULL);
+ port_write_character(port)(sc, ')', port);
+}
+
+
+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(NULL);
+}
+
+static bool slot_memq(const s7_pointer symbol, s7_pointer symbols)
+{
+ for (s7_pointer x = symbols; is_pair(x); x = cdr(x))
+ if (slot_symbol(car(x)) == symbol)
+ return(true);
+ return(false);
+}
+
+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)))
+ return(true);
+ return(false);
+}
+
+static void collect_symbol(s7_scheme *sc, s7_pointer sym, s7_pointer e, s7_pointer args, s7_int gc_loc)
+{
+ if ((!arg_memq(T_Sym(sym), args)) &&
+ (!slot_memq(sym, gc_protected_at(sc, gc_loc))))
+ {
+ s7_pointer slot = match_symbol(sym, e);
+ if (slot)
+ gc_protected_at(sc, gc_loc) = cons(sc, slot, gc_protected_at(sc, gc_loc));
+ }
+}
+
+static void collect_locals(s7_scheme *sc, s7_pointer body, s7_pointer e, s7_pointer args, s7_int gc_loc) /* currently called only in write_closure_readably */
+{
+ if (is_unquoted_pair(body))
+ {
+ collect_locals(sc, car(body), e, args, gc_loc);
+ collect_locals(sc, cdr(body), e, args, gc_loc);
+ }
+ else
+ if (is_symbol(body))
+ collect_symbol(sc, body, e, args, gc_loc);
+}
+
+static void collect_specials(s7_scheme *sc, s7_pointer e, s7_pointer args, s7_int gc_loc)
+{
+ collect_symbol(sc, sc->local_signature_symbol, e, args, gc_loc);
+ collect_symbol(sc, sc->local_setter_symbol, e, args, gc_loc);
+ collect_symbol(sc, sc->local_documentation_symbol, e, args, gc_loc);
+ collect_symbol(sc, sc->local_iterator_symbol, e, args, gc_loc);
+}
+
+static s7_pointer find_closure(s7_scheme *sc, s7_pointer closure, s7_pointer current_let)
+{
+ 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);
+ }
+ for (s7_pointer y = let_slots(e); tis_slot(y); y = next_slot(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 */
+ return(pair_macro(closure_body(closure)));
+ return(sc->nil);
+}
+
+static void write_closure_name(s7_scheme *sc, s7_pointer closure, s7_pointer port)
+{
+ s7_pointer x = find_closure(sc, closure, closure_let(closure));
+ if (is_symbol(x))
+ {
+ port_write_string(port)(sc, symbol_name(x), symbol_name_length(x), port);
+ return;
+ }
+ switch (type(closure))
+ {
+ case T_CLOSURE: port_write_string(port)(sc, "#<lambda ", 9, port); break;
+ case T_CLOSURE_STAR: port_write_string(port)(sc, "#<lambda* ", 10, port); break;
+ case T_BACRO: port_write_string(port)(sc, "#<bacro ", 8, port); break;
+ case T_BACRO_STAR: port_write_string(port)(sc, "#<bacro* ", 9, port); break;
+
+ case T_MACRO:
+ if (is_expansion(closure))
+ 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);
+ else port_write_string(port)(sc, "#<macro* ", 9, port);
+ break;
+ }
+
+ if (is_null(closure_args(closure)))
+ port_write_string(port)(sc, "()>", 3, port);
+ else
+ {
+ 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> */
+ }
+ 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);
+ }}
+}
+
+static s7_pointer closure_name(s7_scheme *sc, s7_pointer closure)
+{
+ /* this is used by the error handlers to get the current function name */
+ s7_pointer x = find_closure(sc, closure, sc->curlet);
+ if (is_symbol(x))
+ return(x);
+ if (is_pair(current_code(sc)))
+ return(current_code(sc));
+ return(closure); /* desperation -- the parameter list (caar here) will cause endless confusion in OP_APPLY errors! */
+}
+
+static s7_pointer pair_append(s7_scheme *sc, s7_pointer a, s7_pointer b)
+{
+ s7_pointer p = cdr(a), tp;
+ gc_protect_via_stack(sc, b);
+ if (is_null(p))
+ tp = cons(sc, car(a), b);
+ else
+ {
+ s7_pointer np;
+ 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, b);
+ }
+ unstack_gc_protect(sc);
+ return(tp);
+}
+
+static void write_closure_readably_1(s7_scheme *sc, s7_pointer obj, s7_pointer arglist, s7_pointer body, s7_pointer port)
+{
+ s7_int old_print_length = sc->print_length;
+
+ if (type(obj) == T_CLOSURE_STAR)
+ port_write_string(port)(sc, "(lambda* ", 9, port);
+ else port_write_string(port)(sc, "(lambda ", 8, port);
+
+ if ((is_pair(arglist)) &&
+ (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)));
+ object_to_port(sc, sc->temp9, port, P_WRITE, NULL);
+ sc->temp9 = sc->unused;
+ }
+ else object_to_port(sc, arglist, port, P_WRITE, NULL); /* here we just want the straight output (a b) not (list 'a 'b) */
+
+ sc->print_length = 1048576;
+ for (s7_pointer p = body; is_pair(p); p = cdr(p))
+ {
+ port_write_character(port)(sc, ' ', port);
+ object_to_port(sc, car(p), port, P_WRITE, NULL);
+ }
+ port_write_character(port)(sc, ')', port);
+ sc->print_length = old_print_length;
+}
+
+static void write_closure_readably(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci)
+{
+ s7_pointer body = closure_body(obj);
+ s7_pointer arglist = closure_args(obj);
+ s7_pointer pe, local_slots, setter = NULL, obj_slot = NULL;
+ s7_int gc_loc;
+ bool sent_let = false, sent_letrec = false;
+
+ 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;
+ }
+ 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);
+ }}
+ if (is_symbol(arglist)) arglist = set_dlist_1(sc, arglist);
+ pe = closure_let(obj);
+
+ gc_loc = gc_protect_1(sc, sc->nil);
+ collect_locals(sc, body, pe, arglist, gc_loc); /* collect locals used only here (and below) */
+ collect_specials(sc, pe, arglist, gc_loc);
+
+ if (s7_is_dilambda(obj))
+ {
+ 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);
+ }}
+
+ local_slots = T_Lst(gc_protected_at(sc, gc_loc)); /* possibly a list of slots */
+ if (!is_null(local_slots))
+ {
+ /* 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);
+ }}
+ if (sent_let) port_write_string(port)(sc, ") ", 2, port);
+ }
+
+ /* now we need to know if obj is in the closure_let via letrec, and if so, send out letrec+obj name+def below, then close it with obj-name??
+ * the two cases are: (let ((f (lambda () f)))...) which is ok now, and (letrec ((f (lambda () f)))...) which needs the letrec
+ */
+ 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;
+ }}
+
+ if (setter)
+ port_write_string(port)(sc, "(dilambda ", 10, port);
+
+ write_closure_readably_1(sc, obj, closure_args(obj), body, port);
+
+ if (setter)
+ {
+ port_write_character(port)(sc, ' ', port);
+ if (has_closure_let(setter))
+ 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);
+ }
+ if (sent_letrec)
+ {
+ port_write_string(port)(sc, ")) ", 3, port);
+ port_write_string(port)(sc, symbol_name(slot_symbol(obj_slot)), symbol_name_length(slot_symbol(obj_slot)), port);
+ port_write_character(port)(sc, ')', port);
+ }
+
+ if (sent_let)
+ port_write_character(port)(sc, ')', port);
+
+ s7_gc_unprotect_at(sc, gc_loc);
+}
+
+static void iterator_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
+{
+ 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? */
+ }}
+ 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);
+ }}}}}
+ else
+ {
+ const char *str;
+ if ((is_hash_table(iterator_sequence(obj))) && (is_weak_hash_table(iterator_sequence(obj))))
+ 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);
+ port_write_character(port)(sc, '>', port);
+ }
+}
+
+static void c_pointer_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
+{
+ #define CP_BUFSIZE 128
+ char buf[CP_BUFSIZE];
+ int32_t nlen;
+ /* c-pointer is special because we can't set the type or info fields from scheme except via the c-pointer function */
+
+ if (use_write == P_READABLE)
+ {
+ 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);
+ }}
+ 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);
+ }}
+ 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));
+ else nlen = snprintf(buf, CP_BUFSIZE, "#<c_pointer %p>", c_pointer(obj));
+ port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port);
+ }
+}
+
+static void random_state_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ #define B_BUFSIZE 128
+ char buf[B_BUFSIZE];
+ int32_t nlen;
+#if WITH_GMP
+ if (use_write == P_READABLE)
+ nlen = snprintf(buf, B_BUFSIZE, "#<bignum random-state>");
+ else nlen = snprintf(buf, B_BUFSIZE, "#<random-state %p>", obj);
+#else
+ if (use_write == P_READABLE)
+ nlen = snprintf(buf, B_BUFSIZE, "(random-state %" PRIu64 " %" PRIu64 ")", random_seed(obj), random_carry(obj));
+ else nlen = snprintf(buf, B_BUFSIZE, "#<random-state %" PRIu64 " %" PRIu64 ">", random_seed(obj), random_carry(obj));
+#endif
+ port_write_string(port)(sc, buf, clamp_length(nlen, B_BUFSIZE), port);
+}
+
+static void display_fallback(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
+{
+#if S7_DEBUGGING
+ print_debugging_state(sc, obj, port);
+#else
+ if (is_free(obj))
+ port_write_string(port)(sc, "<free cell!>", 12, port);
+ else port_write_string(port)(sc, "<unknown object!>", 17, port);
+#endif
+}
+
+static void unique_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
+{
+ port_write_string(port)(sc, unique_name(obj), unique_name_length(obj), port);
+}
+
+static void undefined_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ if ((obj != sc->undefined) &&
+ (use_write == P_READABLE))
+ {
+ port_write_string(port)(sc, "(with-input-from-string \"", 25, port);
+ port_write_string(port)(sc, undefined_name(obj), undefined_name_length(obj), port);
+ port_write_string(port)(sc, "\" read)", 7, port);
+ }
+ else port_write_string(port)(sc, undefined_name(obj), undefined_name_length(obj), port);
+}
+
+static void eof_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ if (use_write == P_READABLE)
+ port_write_string(port)(sc, "(begin #<eof>)", 14, port);
+ else port_write_string(port)(sc, eof_name(obj), eof_name_length(obj), port);
+}
+
+static void counter_to_port(s7_scheme *sc, s7_pointer unused_obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
+{
+ port_write_string(port)(sc, "#<counter>", 10, port);
+}
+
+static void integer_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
+{
+ 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);
+ }
+ else port_write_string(port)(sc, number_name(obj), number_name_length(obj), port);
+ }
+ else
+ {
+ s7_int nlen = 0;
+ const char *str = integer_to_string(sc, integer(obj), &nlen);
+ set_number_name(obj, str, nlen);
+ port_write_string(port)(sc, str, nlen, port);
+ }
+}
+
+static void number_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ if (has_number_name(obj))
+ port_write_string(port)(sc, number_name(obj), number_name_length(obj), port);
+ else
+ {
+ 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);
+ port_write_string(port)(sc, str, nlen, port);
+ }
+}
+
+#if WITH_GMP
+static void big_number_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ s7_int nlen = 0;
+ block_t *str = big_number_to_string_with_radix(sc, obj, BASE_10, 0, &nlen, use_write);
+ port_write_string(port)(sc, (char *)block_data(str), nlen, port);
+ liberate(sc, str);
+}
+#endif
+
+static void syntax_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
+{
+ port_write_string(port)(sc, "#_", 2, port);
+ port_display(port)(sc, symbol_name(syntax_symbol(obj)), port);
+}
+
+static void character_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ if (use_write == P_DISPLAY)
+ port_write_character(port)(sc, character(obj), port);
+ else port_write_string(port)(sc, character_name(obj), character_name_length(obj), port);
+}
+
+static void closure_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
+{
+ if (has_active_methods(sc, obj))
+ {
+ /* look for object->string method else fallback on ordinary case.
+ * can't use recursion on closure_let here because then the fallback name is #<let>.
+ * this is tricky!: (display (openlet (with-let (mock-c-pointer 0) (lambda () 1))))
+ * calls object->string on the closure whose closure_let is the mock-c-pointer;
+ * it has an object->string method that clears mock-c-pointers and tries again...
+ * so, display methods need to use coverlet/openlet.
+ */
+ 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;
+ }}
+ if (use_write == P_READABLE)
+ write_closure_readably(sc, obj, port, ci);
+ else write_closure_name(sc, obj, port);
+}
+
+static void macro_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ if (has_active_methods(sc, obj))
+ {
+ 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;
+ }}
+ if (use_write == P_READABLE)
+ write_macro_readably(sc, obj, port);
+ else write_closure_name(sc, obj, port);
+}
+
+static void c_function_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci)
+{
+ s7_pointer sym = c_function_name_to_symbol(sc, obj);
+ if ((!is_global(sym)) &&
+ (is_slot(initial_slot(sym))) &&
+ ((use_write == P_READABLE) || (lookup(sc, sym) != initial_value(sym))))
+ {
+ /* this is not ideal, but normally the initial_value == global_value (so we can't set a bit there), and the slot
+ * is not accessible here, so we can't tell that the #_ value was used (and probably needed) in the original code.
+ */
+ port_write_string(port)(sc, "#_", 2, port);
+ port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port);
+ return;
+ }
+ if (c_function_name_length(obj) > 0)
+ port_write_string(port)(sc, c_function_name(obj), c_function_name_length(obj), port);
+ else port_write_string(port)(sc, "#<c-function>", 13, port);
+}
+
+static void c_macro_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
+{
+ /* should this check initial_slot and so on as in c_function_to_port above? */
+ if (c_macro_name_length(obj) > 0)
+ {
+ port_write_string(port)(sc, "#_", 2, port);
+ port_write_string(port)(sc, c_macro_name(obj), c_macro_name_length(obj), port);
+ }
+ else port_write_string(port)(sc, "#<c-macro>", 10, port);
+}
+
+static void continuation_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
+{
+ if (is_symbol(continuation_name(obj)))
+ {
+ port_write_string(port)(sc, "#<continuation ", 15, port);
+ symbol_to_port(sc, continuation_name(obj), port, P_DISPLAY, NULL);
+ port_write_character(port)(sc, '>', port);
+ }
+ else port_write_string(port)(sc, "#<continuation>", 15, port);
+}
+
+static void goto_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
+{
+ if (is_symbol(call_exit_name(obj)))
+ {
+ port_write_string(port)(sc, "#<goto ", 7, port);
+ symbol_to_port(sc, call_exit_name(obj), port, P_DISPLAY, NULL);
+ port_write_character(port)(sc, '>', port);
+ }
+ else port_write_string(port)(sc, "#<goto>", 7, port);
+}
+
+static void catch_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
+{
+ port_write_string(port)(sc, "#<catch: ", 9, port);
+ object_to_port(sc, catch_tag(obj), port, use_write, ci);
+ port_write_character(port)(sc, '>', port);
+}
+
+static void dynamic_wind_to_port(s7_scheme *sc, s7_pointer unused_obj, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci)
+{
+ /* this can happen because (*s7* 'stack) can involve dynamic-wind markers */
+ port_write_string(port)(sc, "#<dynamic-wind>", 15, port);
+}
+
+static void c_object_name_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port)
+{
+ port_write_string(port)(sc, string_value(c_object_scheme_name(sc, obj)), string_length(c_object_scheme_name(sc, obj)), port);
+}
+
+static void c_object_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci)
+{
+#if (!DISABLE_DEPRECATED)
+ if (c_object_print(sc, obj))
+ {
+ char *str = ((*(c_object_print(sc, obj)))(sc, c_object_value(obj)));
+ port_display(port)(sc, str, port);
+ free(str);
+ return;
+ }
+#endif
+ if (c_object_to_string(sc, obj)) /* plist here and below can clobber args if SHOW_EVAL_ARGS */
+ port_display(port)(sc, s7_string((*(c_object_to_string(sc, obj)))(sc, set_mlist_2(sc, obj, (use_write == P_READABLE) ? sc->readable_keyword : sc->T))), port);
+ 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;
+ }
+ 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);
+ }}
+}
+
+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)
+{
+ if (obj == sc->stack)
+ port_write_string(port)(sc, "#<current stack>", 16, port);
+ else port_write_string(port)(sc, "#<stack>", 8, port);
+}
+
+static void init_display_functions(void)
+{
+ for (int32_t i = 0; i < 256; i++) display_functions[i] = display_fallback;
+ display_functions[T_FLOAT_VECTOR] = float_vector_to_port;
+ display_functions[T_INT_VECTOR] = int_vector_to_port;
+ display_functions[T_BYTE_VECTOR] = byte_vector_to_port;
+ display_functions[T_VECTOR] = vector_to_port;
+ display_functions[T_PAIR] = pair_to_port;
+ display_functions[T_HASH_TABLE] = hash_table_to_port;
+ display_functions[T_ITERATOR] = iterator_to_port;
+ display_functions[T_LET] = let_to_port;
+ display_functions[T_BOOLEAN] = unique_to_port;
+ display_functions[T_NIL] = unique_to_port;
+ display_functions[T_UNUSED] = unique_to_port;
+ display_functions[T_UNSPECIFIED] = unique_to_port;
+ display_functions[T_UNDEFINED] = undefined_to_port;
+ display_functions[T_EOF] = eof_to_port;
+ display_functions[T_INPUT_PORT] = input_port_to_port;
+ display_functions[T_OUTPUT_PORT] = output_port_to_port;
+ display_functions[T_COUNTER] = counter_to_port;
+ display_functions[T_STACK] = stack_to_port;
+ display_functions[T_INTEGER] = integer_to_port;
+ display_functions[T_RATIO] = number_to_port;
+ display_functions[T_REAL] = number_to_port;
+ display_functions[T_COMPLEX] = number_to_port;
+#if WITH_GMP
+ display_functions[T_BIG_INTEGER] = big_number_to_port;
+ display_functions[T_BIG_RATIO] = big_number_to_port;
+ display_functions[T_BIG_REAL] = big_number_to_port;
+ display_functions[T_BIG_COMPLEX] = big_number_to_port;
+#endif
+ display_functions[T_SYMBOL] = symbol_to_port;
+ display_functions[T_SYNTAX] = syntax_to_port;
+ display_functions[T_STRING] = string_to_port;
+ display_functions[T_CHARACTER] = character_to_port;
+ display_functions[T_CLOSURE] = closure_to_port;
+ display_functions[T_CLOSURE_STAR] = closure_to_port;
+ display_functions[T_MACRO] = macro_to_port;
+ display_functions[T_MACRO_STAR] = macro_to_port;
+ display_functions[T_BACRO] = macro_to_port;
+ display_functions[T_BACRO_STAR] = macro_to_port;
+ display_functions[T_C_RST_NO_REQ_FUNCTION] = c_function_to_port;
+ display_functions[T_C_FUNCTION] = c_function_to_port;
+ display_functions[T_C_FUNCTION_STAR] = c_function_to_port;
+ display_functions[T_C_MACRO] = c_macro_to_port;
+ display_functions[T_C_POINTER] = c_pointer_to_port;
+ display_functions[T_RANDOM_STATE] = random_state_to_port;
+ display_functions[T_CONTINUATION] = continuation_to_port;
+ display_functions[T_GOTO] = goto_to_port;
+ display_functions[T_CATCH] = catch_to_port;
+ display_functions[T_DYNAMIC_WIND] = dynamic_wind_to_port;
+ display_functions[T_C_OBJECT] = c_object_to_port;
+ display_functions[T_SLOT] = internal_slot_to_port;
+}
+
+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)
+{
+ int32_t ref = (is_collected(vr)) ? shared_ref(ci, vr) : 0;
+ if (ref == 0)
+ object_to_port(sc, vr, port, use_write, ci);
+ else
+ {
+ 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);
+ }}
+ 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);
+ }}
+}
+
+static s7_pointer cyclic_out(s7_scheme *sc, s7_pointer obj, s7_pointer port, shared_info_t *ci)
+{
+ int32_t ref, len;
+ char buf[128];
+
+ ci->cycle_port = s7_open_output_string(sc);
+ ci->cycle_loc = gc_protect_1(sc, ci->cycle_port);
+
+ port_write_string(port)(sc, "(let (", 6, port);
+ for (int32_t i = 0; i < ci->top; i++)
+ {
+ ref = peek_shared_ref(ci, ci->objs[i]); /* refs may be in any order */
+ if (ref < 0) {ref = -ref; flip_ref(ci, ci->objs[i]);}
+ len = (int32_t)catstrs_direct(buf, (i == 0) ? "(<" : "\n (<", pos_int_to_str_direct(sc, ref), "> ", (const char *)NULL);
+ port_write_string(port)(sc, buf, len, port);
+ ci->defined[ref] = false;
+ object_to_port_with_circle_check(sc, ci->objs[i], port, P_READABLE, ci);
+ port_write_character(port)(sc, ')', port);
+ ci->defined[ref] = true;
+ if (peek_shared_ref(ci, ci->objs[i]) > 0) flip_ref(ci, ci->objs[i]); /* ref < 0 -> use <%d> in object_to_port */
+ }
+ port_write_string(port)(sc, ")\n", 2, port);
+
+ if (ci->init_port != sc->F)
+ {
+ port_write_string(port)(sc, (const char *)(port_data(ci->init_port)), port_position(ci->init_port), port);
+ s7_close_output_port(sc, ci->init_port);
+ s7_gc_unprotect_at(sc, ci->init_loc);
+ ci->init_port = sc->F;
+ }
+
+ if (port_position(ci->cycle_port) > 0) /* 0 if e.g. (object->string (object->let (rootlet)) :readable) */
+ port_write_string(port)(sc, (const char *)(port_data(ci->cycle_port)), port_position(ci->cycle_port), port);
+ s7_close_output_port(sc, ci->cycle_port);
+ s7_gc_unprotect_at(sc, ci->cycle_loc);
+ ci->cycle_port = sc->F;
+
+ if ((is_immutable(obj)) && (!is_let(obj)))
+ port_write_string(port)(sc, " (immutable! ", 14, port);
+ else port_write_string(port)(sc, " ", 2, port);
+
+ ref = peek_shared_ref(ci, obj);
+ if (ref == 0)
+ object_to_port_with_circle_check(sc, obj, port, P_READABLE, ci);
+ else
+ {
+ len = (int32_t)catstrs_direct(buf, "<", pos_int_to_str_direct(sc, (ref < 0) ? -ref : ref), ">", (const char *)NULL);
+ port_write_string(port)(sc, buf, len, port);
+ }
+
+ if ((is_immutable(obj)) && (!is_let(obj)))
+ port_write_string(port)(sc, "))\n", 3, port);
+ else port_write_string(port)(sc, ")\n", 2, port);
+ return(obj);
+}
+
+static void object_out_1(s7_scheme *sc, s7_pointer obj, s7_pointer strport, use_write_t choice)
+{
+ if (sc->object_out_locked)
+ object_to_port_with_circle_check(sc, T_Pos(obj), strport, choice, sc->circle_info);
+ else
+ {
+ 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;
+ }
+ else object_to_port(sc, obj, strport, choice, NULL);
+ }
+}
+
+static inline s7_pointer object_out(s7_scheme *sc, s7_pointer obj, s7_pointer strport, use_write_t choice)
+{
+ if ((has_structure(obj)) && (obj != sc->rootlet))
+ object_out_1(sc, obj, strport, choice);
+ else object_to_port(sc, obj, strport, choice, NULL);
+ return(obj);
+}
+
+static s7_pointer new_format_port(s7_scheme *sc)
+{
+ s7_pointer x = alloc_pointer(sc);
+ s7_int len = FORMAT_PORT_LENGTH;
+ block_t *block, *b;
+ set_full_type(x, T_OUTPUT_PORT);
+ b = mallocate_port(sc);
+ port_block(x) = b;
+ port_port(x) = (port_t *)block_data(b);
+ port_type(x) = STRING_PORT;
+ port_set_closed(x, false);
+ port_data_size(x) = len;
+ port_next(x) = NULL;
+ block = mallocate(sc, len);
+ port_data(x) = (uint8_t *)(block_data(block));
+ port_data_block(x) = block;
+ port_data(x)[0] = '\0';
+ port_position(x) = 0;
+ port_needs_free(x) = false;
+ port_port(x)->pf = &output_string_functions;
+ return(x);
+}
+
+static inline s7_pointer open_format_port(s7_scheme *sc)
+{
+ s7_pointer x = sc->format_ports;
+ if (!x) return(new_format_port(sc));
+ sc->format_ports = (s7_pointer)(port_next(x));
+ port_position(x) = 0;
+ port_data(x)[0] = '\0';
+ return(x);
+}
+
+static void close_format_port(s7_scheme *sc, s7_pointer port)
+{
+ port_next(port) = (struct block_t *)(sc->format_ports);
+ sc->format_ports = port;
+}
+
+char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj)
+{
+ char *str;
+ s7_pointer strport;
+ s7_int len;
+
+ TRACK(sc);
+ if ((sc->safety > NO_SAFETY) &&
+ (!s7_is_valid(sc, obj)))
+ s7_warn(sc, 256, "the second argument to %s (the object): %p, is not an s7 object\n", __func__, obj);
+
+ strport = open_format_port(sc);
+ object_out(sc, T_Pos(obj), strport, P_WRITE);
+ len = port_position(strport);
+ if ((S7_DEBUGGING) && (len == 0)) fprintf(stderr, "%s[%d]: len == 0\n", __func__, __LINE__);
+ /* if (len == 0) {close_format_port(sc, strport); return(NULL);} */ /* probably never happens */
+ str = (char *)Malloc(len + 1);
+ memcpy((void *)str, (void *)port_data(strport), len);
+ str[len] = '\0';
+ close_format_port(sc, strport);
+ return(str);
+}
+
+static inline void restore_format_port(s7_scheme *sc, s7_pointer strport)
+{
+ block_t *block = inline_mallocate(sc, FORMAT_PORT_LENGTH);
+ port_data(strport) = (uint8_t *)(block_data(block));
+ port_data_block(strport) = block;
+ port_data(strport)[0] = '\0';
+ port_position(strport) = 0;
+ port_data_size(strport) = FORMAT_PORT_LENGTH;
+ port_needs_free(strport) = false;
+ close_format_port(sc, strport);
+}
+
+
+/* -------------------------------- object->string -------------------------------- */
+s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer obj, bool use_write) /* unavoidable backwards compatibility rigidity here */
+{
+ s7_pointer strport, res;
+
+ if ((sc->safety > NO_SAFETY) &&
+ (!s7_is_valid(sc, obj)))
+ s7_warn(sc, 256, "the second argument to %s (the object): %p, is not an s7 object\n", __func__, obj);
+
+ strport = open_format_port(sc);
+ object_out(sc, obj, strport, (use_write) ? P_WRITE : P_DISPLAY);
+
+ if (port_position(strport) >= port_data_size(strport))
+ res = block_to_string(sc, reallocate(sc, port_data_block(strport), port_position(strport) + 1), port_position(strport));
+ else res = block_to_string(sc, port_data_block(strport), port_position(strport));
+ restore_format_port(sc, strport);
+ return(res);
+}
+
+static s7_pointer g_object_to_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_object_to_string "(object->string obj (write #t) (max-len (*s7* 'most-positive-fixnum))) returns a string representation of obj."
+ #define Q_object_to_string s7_make_signature(sc, 4, \
+ sc->is_string_symbol, sc->T, \
+ s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_keyword_symbol), sc->is_integer_symbol)
+ use_write_t choice;
+ s7_pointer obj = car(args), strport, res;
+ s7_int out_len, pending_max = S7_INT64_MAX;
+ bool old_openlets = sc->has_openlets;
+
+ if (is_not_null(cdr(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));}}}}
+
+ 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);
+ }}
+ else choice = P_WRITE;
+ /* can't use s7_object_to_string here anymore because it assumes use_write arg is a boolean */
+
+ if (choice == P_READABLE)
+ sc->has_openlets = false; /* so (object->string obj :readable) ignores obj's object->string method -- is this a good idea? */
+ else check_method(sc, obj, sc->object_to_string_symbol, args);
+
+ strport = open_format_port(sc);
+ sc->objstr_max_len = pending_max;
+ object_out(sc, obj, strport, choice);
+ sc->objstr_max_len = S7_INT64_MAX;
+ out_len = port_position(strport);
+
+ if ((pending_max >= 0) &&
+ (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));
+ }
+ 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));
+ }
+ for (s7_int i = out_len - 3; i < out_len; i++)
+ 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);
+ else res = block_to_string(sc, port_data_block(strport), out_len);
+ restore_format_port(sc, strport);
+ sc->has_openlets = old_openlets;
+ return(res);
+}
+
+#if S7_DEBUGGING
+const char *s7_object_to_c_string_x(s7_scheme *sc, s7_pointer obj, s7_pointer urchoice);
+const char *s7_object_to_c_string_x(s7_scheme *sc, s7_pointer obj, s7_pointer urchoice) {return(string_value(g_object_to_string(sc, list_2(sc, obj, urchoice))));}
+#endif
+
+
+/* -------------------------------- newline -------------------------------- */
+void s7_newline(s7_scheme *sc, s7_pointer port)
+{
+ if (port != sc->F)
+ port_write_character(port)(sc, (uint8_t)'\n', port);
+}
+
+#define newline_char chars[(uint8_t)'\n']
+
+static s7_pointer g_newline(s7_scheme *sc, s7_pointer args)
+{
+ #define H_newline "(newline (port (current-output-port))) writes a carriage return to the port"
+ #define Q_newline s7_make_signature(sc, 2, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
+
+ s7_pointer port = (is_not_null(args)) ? car(args) : current_output_port(sc);
+ if (!is_output_port(port))
+ {
+ if (port == sc->F) return(newline_char);
+ check_method(sc, port, sc->newline_symbol, args);
+ sole_arg_wrong_type_error_nr(sc, sc->newline_symbol, port, an_output_port_or_f_string); /* 0 -> "zeroth" */
+ }
+ if (port_is_closed(port))
+ sole_arg_wrong_type_error_nr(sc, sc->newline_symbol, port, an_open_output_port_string);
+ s7_newline(sc, port);
+ return(newline_char); /* return(sc->unspecified) until 28-Sep-17, but for example (display c) returns c */
+}
+
+static s7_pointer newline_p(s7_scheme *sc)
+{
+ s7_newline(sc, current_output_port(sc));
+ return(newline_char);
+}
+
+static s7_pointer newline_p_p(s7_scheme *sc, s7_pointer port)
+{
+ if (!is_output_port(port))
+ {
+ if (port == sc->F) return(newline_char);
+ return(method_or_bust_p(sc, port, sc->newline_symbol, an_output_port_string));
+ }
+ s7_newline(sc, port);
+ return(newline_char);
+}
+
+
+/* -------------------------------- write -------------------------------- */
+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);
+ object_out(sc, obj, port, P_WRITE);
+ }
+ return(obj);
+}
+
+static s7_pointer write_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer port)
+{
+ if (!is_output_port(port))
+ {
+ if (port == sc->F) return(x);
+ check_method(sc, port, sc->write_symbol, set_mlist_2(sc, x, port));
+ wrong_type_error_nr(sc, sc->write_symbol, 2, port, an_output_port_or_f_string);
+ }
+ if (port_is_closed(port))
+ wrong_type_error_nr(sc, sc->write_symbol, 2, port, an_open_output_port_string);
+ return(object_out(sc, x, port, P_WRITE));
+}
+
+static s7_pointer g_write(s7_scheme *sc, s7_pointer args)
+{
+ #define H_write "(write obj (port (current-output-port))) writes (object->string obj) to the output port"
+ #define Q_write s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
+ check_method(sc, car(args), sc->write_symbol, args);
+ return(write_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc)));
+}
+
+static s7_pointer write_p_p(s7_scheme *sc, s7_pointer x)
+{
+ return((current_output_port(sc) == sc->F) ? x : object_out(sc, x, current_output_port(sc), P_WRITE));
+}
+
+
+/* -------------------------------- display -------------------------------- */
+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);
+ object_out(sc, obj, port, P_DISPLAY);
+ }
+ return(obj);
+}
+
+static s7_pointer display_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer port)
+{
+ if (!is_output_port(port))
+ {
+ if (port == sc->F) return(x);
+ check_method(sc, port, sc->display_symbol, set_mlist_2(sc, x, port));
+ wrong_type_error_nr(sc, sc->display_symbol, 2, port, an_output_port_or_f_string);
+ }
+ if (port_is_closed(port))
+ wrong_type_error_nr(sc, sc->display_symbol, 2, port, an_open_output_port_string);
+ check_method(sc, x, sc->display_symbol, set_plist_2(sc, x, port));
+ return(object_out(sc, x, port, P_DISPLAY));
+}
+
+static s7_pointer g_display(s7_scheme *sc, s7_pointer args)
+{
+ #define H_display "(display obj (port (current-output-port))) prints obj"
+ #define Q_display s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))
+ return(display_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : current_output_port(sc)));
+}
+
+static s7_pointer g_display_2(s7_scheme *sc, s7_pointer args) {return(display_p_pp(sc, car(args), cadr(args)));}
+
+static s7_pointer g_display_f(s7_scheme *unused_sc, s7_pointer args) {return(car(args));}
+
+static s7_pointer display_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if (args == 2) /* not check_for_substring_temp(sc, expr) here -- display returns arg so can be immutable if substring_uncopied */
+ return((caddr(expr) == sc->F) ? sc->display_f : sc->display_2);
+ return(f);
+}
+
+static s7_pointer display_p_p(s7_scheme *sc, s7_pointer x)
+{
+ if (current_output_port(sc) == sc->F) return(x);
+ check_method(sc, x, sc->display_symbol, set_plist_1(sc, x));
+ return(object_out(sc, x, current_output_port(sc), P_DISPLAY));
+}
+
+/* display may not be following the spec: (display '("a" #\b)): ("a" #\b), whereas Guile says (a b) */
+
+
+/* -------------------------------- call-with-output-string -------------------------------- */
+static s7_pointer g_call_with_output_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_call_with_output_string "(call-with-output-string proc) opens a string port applies proc to it, then returns the collected output"
+ #define Q_call_with_output_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol))
+
+ s7_pointer port, proc = car(args);
+ if (is_let(proc))
+ check_method(sc, proc, sc->call_with_output_string_symbol, args);
+ if ((!is_any_procedure(proc)) || /* this disallows goto/continuation */
+ (!s7_is_aritable(sc, proc, 1)))
+ return(method_or_bust(sc, proc, sc->call_with_output_string_symbol, args, wrap_string(sc, "a procedure of one argument (the port)", 38), 1));
+
+ port = s7_open_output_string(sc);
+ push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); /* #<unused> here is a marker (needed) */
+ push_stack(sc, OP_GET_OUTPUT_STRING, sc->unused, port); /* args checked in call_with_exit */
+ push_stack(sc, OP_APPLY, list_1_unchecked(sc, port), proc);
+ return(sc->F);
+}
+
+
+/* -------------------------------- call-with-output-file -------------------------------- */
+static s7_pointer g_call_with_output_file(s7_scheme *sc, s7_pointer args)
+{
+ #define H_call_with_output_file "(call-with-output-file filename proc) opens filename and calls proc with the output port as its argument"
+ #define Q_call_with_output_file sc->pl_sf
+
+ s7_pointer port, file = car(args), proc = cadr(args);
+ if (!is_string(file))
+ return(method_or_bust(sc, file, sc->call_with_output_file_symbol, args, sc->type_names[T_STRING], 1));
+ if ((!is_any_procedure(proc)) ||
+ (!s7_is_aritable(sc, proc, 1)))
+ return(method_or_bust(sc, proc, sc->call_with_output_file_symbol, args, wrap_string(sc, "a procedure of one argument (the port)", 38), 2));
+
+ port = s7_open_output_file(sc, string_value(file), "w");
+ push_stack(sc, OP_UNWIND_OUTPUT, sc->unused, port); /* #<unused> here is a marker (needed) */
+ push_stack(sc, OP_APPLY, list_1_unchecked(sc, port), proc);
+ return(sc->F);
+}
+
+
+/* -------------------------------- with-output-to-string -------------------------------- */
+static s7_pointer g_with_output_to_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_with_output_to_string "(with-output-to-string thunk) opens a string as a temporary current-output-port, \
+calls thunk, then returns the collected output"
+ #define Q_with_output_to_string s7_make_signature(sc, 2, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol))
+
+ s7_pointer old_output_port, proc = car(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-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)))
+ wrong_type_error_nr(sc, sc->with_output_to_string_symbol, 1, proc, a_normal_procedure_string);
+
+ old_output_port = current_output_port(sc);
+ set_current_output_port(sc, s7_open_output_string(sc));
+ push_stack(sc, OP_UNWIND_OUTPUT, old_output_port, current_output_port(sc));
+ push_stack(sc, OP_GET_OUTPUT_STRING, old_output_port, current_output_port(sc));
+ push_stack(sc, OP_APPLY, sc->nil, proc);
+ return(sc->F);
+}
+
+
+/* -------------------------------- with-output-to-file -------------------------------- */
+static s7_pointer g_with_output_to_file(s7_scheme *sc, s7_pointer args)
+{
+ #define H_with_output_to_file "(with-output-to-file filename thunk) opens filename as the temporary current-output-port and calls thunk"
+ #define Q_with_output_to_file sc->pl_sf
+
+ s7_pointer old_output_port, file = car(args), proc = cadr(args);
+ if (!is_string(file))
+ return(method_or_bust(sc, file, sc->with_output_to_file_symbol, args, sc->type_names[T_STRING], 1));
+ 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));
+ }
+ 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)))
+ wrong_type_error_nr(sc, sc->with_output_to_file_symbol, 1, proc, a_normal_procedure_string);
+
+ old_output_port = current_output_port(sc);
+ set_current_output_port(sc, s7_open_output_file(sc, string_value(file), "w"));
+ push_stack(sc, OP_UNWIND_OUTPUT, old_output_port, current_output_port(sc));
+ push_stack(sc, OP_APPLY, sc->nil, proc);
+ return(sc->F);
+}
+
+
+/* -------------------------------- format -------------------------------- */
+static /* inline */ s7_pointer copy_proper_list(s7_scheme *sc, s7_pointer lst);
+
+static noreturn void format_error_nr(s7_scheme *sc, const char *ur_msg, s7_int msg_len, const char *str, s7_pointer ur_args, format_data_t *fdat)
+{
+ s7_pointer x = NULL;
+ s7_pointer ctrl_str = (fdat->orig_str) ? fdat->orig_str : wrap_string(sc, str, safe_strlen(str));
+ s7_pointer args = (is_elist(ur_args)) ? copy_proper_list(sc, ur_args) : ur_args;
+ s7_pointer msg = wrap_string(sc, ur_msg, msg_len);
+ if (fdat->loc == 0)
+ {
+ if (is_pair(args))
+ 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
+ if (is_pair(args))
+ x = set_elist_5(sc, format_string_3, ctrl_str, args, wrap_integer(sc, fdat->loc + 20), msg); /* "~S ~{~S~^ ~}~&~NT^: ~A" */
+ else x = set_elist_4(sc, format_string_4, ctrl_str, wrap_integer(sc, fdat->loc + 20), msg); /* "~S~&~NT^: ~A" */
+ if (fdat->port)
+ {
+ close_format_port(sc, fdat->port);
+ fdat->port = NULL;
+ }
+ error_nr(sc, sc->format_error_symbol, x);
+}
+
+static void format_append_char(s7_scheme *sc, char c, s7_pointer port)
+{
+ port_write_character(port)(sc, c, port);
+ sc->format_column++;
+}
+
+static void format_append_newline(s7_scheme *sc, s7_pointer port)
+{
+ port_write_character(port)(sc, '\n', port);
+ sc->format_column = 0;
+}
+
+static void format_append_string(s7_scheme *sc, format_data_t *fdat, const char *str, s7_int len, s7_pointer port)
+{
+ port_write_string(port)(sc, str, len, port);
+ fdat->loc += len;
+ sc->format_column += len;
+}
+
+static void format_append_chars(s7_scheme *sc, format_data_t *fdat, char pad, s7_int chrs, s7_pointer port)
+{
+ 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;
+ }
+ 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;
+ }
+ fdat->loc += chrs;
+ sc->format_column += chrs;
+ }
+ else
+ {
+ block_t *b = mallocate(sc, chrs + 1);
+ char *str = (char *)block_data(b);
+ local_memset((void *)str, pad, chrs);
+ str[chrs] = '\0';
+ format_append_string(sc, fdat, str, chrs, port);
+ liberate(sc, b);
+ }
+}
+
+static s7_int format_read_integer(s7_int *cur_i, s7_int str_len, const char *str)
+{
+ /* we know that str[*cur_i] is a digit */
+ s7_int i, lval = 0;
+ for (i = *cur_i; i < str_len - 1; i++)
+ {
+ 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;
+#else
+ lval = dig + (lval * 10);
+#endif
+ }
+ else break;
+ }
+ *cur_i = i;
+ return(lval);
+}
+
+static void format_number(s7_scheme *sc, format_data_t *fdat, int32_t radix, s7_int width, s7_int precision, char float_choice, char pad, s7_pointer port)
+{
+ char *tmp;
+ block_t *b = NULL;
+ s7_int nlen = 0;
+ if (width < 0) width = 0;
+
+ /* precision choice depends on float_choice if it's -1 */
+ if (precision < 0)
+ {
+ if ((float_choice == 'e') ||
+ (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;
+ }}
+ /* should (format #f "~F" 1/3) return "1/3"?? in CL it's "0.33333334" */
+
+ if (pad != ' ')
+ {
+ 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);
+ else
+#endif
+ {
+ 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);
+ if ((WITH_GMP) || (radix != 10)) liberate(sc, b);
+ }
+ else
+ {
+#if (!WITH_GMP)
+ if (radix == 10)
+ 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);
+ }
+ format_append_string(sc, fdat, tmp, nlen, port);
+ if ((WITH_GMP) || (radix != 10)) liberate(sc, b);
+ }
+ fdat->args = cdr(fdat->args);
+ fdat->ctr++;
+}
+
+static const char *ordinal[11] = {"zeroth", "first", "second", "third", "fourth", "fifth", "sixth", "seventh", "eighth", "ninth", "tenth"};
+static const s7_int ordinal_length[11] = {6, 5, 6, 5, 6, 5, 5, 7, 6, 5, 5};
+
+static void format_ordinal_number(s7_scheme *sc, format_data_t *fdat, s7_pointer port)
+{
+ s7_int num = s7_integer_clamped_if_gmp(sc, car(fdat->args));
+ if (num < 11)
+ format_append_string(sc, fdat, ordinal[num], ordinal_length[num], port);
+ else
+ {
+ s7_int nlen = 0;
+ const char *tmp = integer_to_string(sc, num, &nlen);
+ format_append_string(sc, fdat, tmp, nlen, port);
+ num = num % 100;
+ if ((num >= 11) && (num <= 13))
+ 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);
+ }}
+ fdat->args = cdr(fdat->args);
+ fdat->ctr++;
+}
+
+static s7_int format_nesting(const char *str, char opener, char closer, s7_int start, s7_int end) /* start=i, end=str_len-1 */
+{
+ s7_int nesting = 1;
+ 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++;
+ }
+ return(-1);
+}
+
+static bool format_method(s7_scheme *sc, const char *str, format_data_t *fdat, s7_pointer port)
+{
+ s7_pointer func, obj = car(fdat->args);
+ char ctrl_str[3];
+
+ if ((!has_active_methods(sc, obj)) ||
+ ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined))
+ return(false);
+
+ ctrl_str[0] = '~';
+ ctrl_str[1] = str[0];
+ ctrl_str[2] = '\0';
+
+ if (port == obj) /* a problem! we need the openlet port for format, but that's an infinite loop when it calls format again as obj */
+ s7_apply_function(sc, func, set_plist_3(sc, port, wrap_string(sc, ctrl_str, 2), wrap_string(sc, "#<format port>", 14)));
+ else s7_apply_function(sc, func, set_plist_3(sc, port, wrap_string(sc, ctrl_str, 2), obj));
+
+ fdat->args = cdr(fdat->args);
+ fdat->ctr++;
+ return(true);
+}
+
+static s7_int format_n_arg(s7_scheme *sc, const char *str, format_data_t *fdat, s7_pointer args)
+{
+ s7_int n;
+
+ if (is_null(fdat->args)) /* (format #f "~nT") */
+ format_error_nr(sc, "~~N: missing argument", 21, str, args, fdat);
+ if (!s7_is_integer(car(fdat->args)))
+ format_error_nr(sc, "~~N: integer argument required", 30, str, args, fdat);
+ n = s7_integer_clamped_if_gmp(sc, car(fdat->args));
+
+ if (n < 0)
+ format_error_nr(sc, "~~N value is negative?", 22, str, args, fdat);
+ if (n > sc->max_format_length)
+ format_error_nr(sc, "~~N value is too big", 20, str, args, fdat);
+
+ fdat->args = cdr(fdat->args); /* I don't think fdat->ctr should be incremented here -- it's for (*s7* 'print-length) etc */
+ return(n);
+}
+
+static s7_int format_numeric_arg(s7_scheme *sc, const char *str, s7_int str_len, format_data_t *fdat, s7_int *i)
+{
+ s7_int old_i = *i;
+ s7_int width = format_read_integer(i, str_len, str);
+ 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, "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, "precision is too big", 20, str, fdat->args, fdat);
+ }
+ return(width);
+}
+
+static format_data_t *open_format_data(s7_scheme *sc)
+{
+ format_data_t *fdat;
+ sc->format_depth++;
+ if (sc->format_depth >= sc->num_fdats)
+ {
+ int32_t new_num_fdats = sc->format_depth * 2;
+ sc->fdats = (format_data_t **)Realloc(sc->fdats, sizeof(format_data_t *) * new_num_fdats);
+ for (int32_t k = sc->num_fdats; k < new_num_fdats; k++) sc->fdats[k] = NULL;
+ sc->num_fdats = new_num_fdats;
+ }
+ fdat = sc->fdats[sc->format_depth];
+ if (!fdat)
+ {
+ fdat = (format_data_t *)Malloc(sizeof(format_data_t));
+ sc->fdats[sc->format_depth] = fdat;
+ fdat->curly_len = 0;
+ fdat->curly_str = NULL;
+ fdat->ctr = 0;
+ }
+ else
+ {
+ if (fdat->port)
+ close_format_port(sc, fdat->port);
+ if (fdat->strport)
+ close_format_port(sc, fdat->strport);
+ }
+ fdat->port = NULL;
+ fdat->strport = NULL;
+ fdat->loc = 0;
+ fdat->curly_arg = sc->nil;
+ return(fdat);
+}
+
+#if WITH_GMP
+static bool is_one_or_big_one(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_big_number(p)) return(is_one(p));
+ if (is_t_big_integer(p)) return(mpz_cmp_ui(big_integer(p), 1) == 0);
+ if (is_t_big_real(p)) return(mpfr_cmp_d(big_real(p), 1.0) == 0);
+ return(false);
+}
+#else
+#define is_one_or_big_one(Sc, Num) is_one(Num)
+#endif
+
+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_int i, str_len;
+ format_data_t *fdat;
+ s7_pointer deferred_port;
+
+ if (len <= 0)
+ {
+ 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);
+ }}
+ else str_len = len;
+
+ fdat = open_format_data(sc);
+ fdat->args = args;
+ fdat->orig_str = orig_str;
+
+ if (with_result)
+ {
+ deferred_port = port;
+ port = open_format_port(sc);
+ fdat->port = port;
+ }
+ else deferred_port = sc->F;
+
+ 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);
+ }}
+ 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;
+ }}
+
+ ALL_DONE:
+ if (next_arg)
+ (*next_arg) = fdat->args;
+ else
+ if (is_not_null(fdat->args))
+ format_error_nr(sc, "too many arguments", 18, str, args, fdat);
+
+ if (i < str_len)
+ {
+ if (str[i] == '~')
+ format_error_nr(sc, "control string ends in tilde", 28, str, args, fdat);
+ format_append_char(sc, str[i], port);
+ }
+ sc->format_depth--;
+ if (with_result)
+ {
+ 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);
+ }
+ 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;
+ }
+ else result = make_string_with_length(sc, (char *)port_data(port), port_position(port));
+ close_format_port(sc, port);
+ fdat->port = NULL;
+ return(result);
+ }
+ return(nil_string);
+}
+
+static bool is_columnizing(const char *str) /* look for ~t ~,<int>T ~<int>,<int>t */
+{
+ 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);
+ }}}
+ return(false);
+}
+
+static s7_pointer g_format(s7_scheme *sc, s7_pointer args)
+{
+ #define H_format "(format out str . args) substitutes args into str sending the result to out. Most of \
+s7's format directives are taken from CL: ~% = newline, ~& = newline if the preceding output character was \
+no a newline, ~~ = ~, ~<newline> trims white space, ~* skips an argument, ~^ exits {} iteration if the arg list is exhausted, \
+~nT spaces over to column n, ~A prints a representation of any object, ~S is the same, but puts strings in double quotes, \
+~C prints a character, numbers are handled by ~F, ~E, ~G, ~B, ~O, ~D, and ~X with preceding numbers giving \
+spacing (and spacing character) and precision. ~{ starts an embedded format directive which is ended by ~}: \n\
+\n\
+ >(format #f \"dashed: ~{~A~^-~}\" '(1 2 3))\n\
+ \"dashed: 1-2-3\"\n\
+\n\
+~P inserts \"s\" if the current it is not 1 or 1.0 (use ~@P for \"ies\" or \"y\").\n\
+~B is number->string in base 2, ~O in base 8, ~D base 10, ~X base 16,\n\
+~E: (format #f \"~E\" 100.1) -&gt; \"1.001000e+02\" (%e in C)\n\
+~F: (format #f \"~F\" 100.1) -&gt; \"100.100000\" (%f in C)\n\
+~G: (format #f \"~G\" 100.1) -&gt; \"100.1\" (%g in C)\n\
+\n\
+If the 'out' argument is not an output port (i.e. #f, #t, or ()), the resultant string is returned. If it \
+is #t, the string is also sent to the current-output-port."
+
+ #define Q_format s7_make_circular_signature(sc, 2, 3, \
+ sc->is_string_symbol, s7_make_signature(sc, 3, sc->is_output_port_symbol, sc->is_boolean_symbol, sc->is_null_symbol), sc->T)
+
+ s7_pointer pt = car(args), str;
+ if (is_null(pt))
+ {
+ 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 */
+ }
+ 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)))))
+ 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));
+}
+
+const char *s7_format(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer result = g_format(sc, args);
+ return((is_string(result)) ? string_value(result) : NULL);
+}
+
+static s7_pointer g_format_f(s7_scheme *sc, s7_pointer args) /* port == #f, there are other args */
+{
+ s7_pointer str = cadr(args);
+ sc->format_column = 0;
+ 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, sc->F, string_value(str), cddr(args), NULL, true, true, string_length(str), str));
+}
+
+static s7_pointer g_format_just_control_string(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer pt = car(args);
+ s7_pointer str = cadr(args);
+ if (pt == sc->F)
+ return(str);
+
+ if (is_null(pt))
+ {
+ pt = current_output_port(sc);
+ if (pt == sc->F)
+ 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));
+ return(str);
+ }
+ if ((!is_output_port(pt)) ||
+ (port_is_closed(pt)))
+ return(method_or_bust(sc, pt, sc->format_symbol, args, a_format_port_string, 1));
+
+ if (string_length(str) == 0)
+ return(nil_string);
+
+ port_write_string(pt)(sc, string_value(str), string_length(str), pt);
+ return(nil_string);
+}
+
+static s7_pointer g_format_as_objstr(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer func, obj = caddr(args);
+ if ((!has_active_methods(sc, obj)) ||
+ ((func = find_method_with_let(sc, obj, sc->format_symbol)) == sc->undefined))
+ return(s7_object_to_string(sc, obj, false));
+ return(s7_apply_function(sc, func, set_plist_3(sc, sc->F, cadr(args), obj)));
+}
+
+static s7_pointer g_format_no_column(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer pt = car(args), str;
+ if (is_null(pt))
+ {
+ pt = current_output_port(sc);
+ if (pt == sc->F)
+ 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)))))
+ 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));
+}
+
+static s7_pointer format_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if (args > 1)
+ {
+ 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 (port == sc->F)
+ return(sc->format_f);
+ }
+ return(f);
+}
+
+
+#if WITH_SYSTEM_EXTRAS
+#include <fcntl.h>
+
+/* -------------------------------- directory? -------------------------------- */
+static bool is_directory_b_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_string(p))
+ sole_arg_wrong_type_error_nr(sc, sc->is_directory_symbol, p, sc->type_names[T_STRING]);
+ if (string_length(p) >= 2)
+ {
+ block_t *b = expand_filename(sc, string_value(p));
+ if (b)
+ {
+ bool result = is_directory((char *)block_data(b));
+ liberate(sc, b);
+ return(result);
+ }}
+ return(is_directory(string_value(p)));
+}
+
+static s7_pointer g_is_directory(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_directory "(directory? str) returns #t if str is the name of a directory"
+ #define Q_is_directory s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol)
+ return(make_boolean(sc, is_directory_b_7p(sc, car(args))));
+}
+
+/* -------------------------------- file-exists? -------------------------------- */
+static bool file_probe(const char *arg)
+{
+#if (!MS_WINDOWS)
+ return(access(arg, F_OK) == 0);
+#else
+ int32_t fd = open(arg, O_RDONLY, 0);
+ if (fd == -1) return(false);
+ close(fd);
+ return(true);
+#endif
+}
+
+static bool file_exists_b_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_string(p))
+ sole_arg_wrong_type_error_nr(sc, sc->file_exists_symbol, p, sc->type_names[T_STRING]);
+ if (string_length(p) >= 2)
+ {
+ block_t *b = expand_filename(sc, string_value(p));
+ if (b)
+ {
+ bool result = file_probe((char *)block_data(b));
+ liberate(sc, b);
+ return(result);
+ }}
+ return(file_probe(string_value(p)));
+}
+
+static s7_pointer g_file_exists(s7_scheme *sc, s7_pointer args)
+{
+ #define H_file_exists "(file-exists? filename) returns #t if the file exists"
+ #define Q_file_exists s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_string_symbol)
+ return(make_boolean(sc, file_exists_b_7p(sc, car(args))));
+}
+
+/* -------------------------------- delete-file -------------------------------- */
+static s7_pointer g_delete_file(s7_scheme *sc, s7_pointer args)
+{
+ #define H_delete_file "(delete-file filename) deletes the file filename."
+ #define Q_delete_file s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)
+
+ s7_pointer name = car(args);
+ if (!is_string(name))
+ return(sole_arg_method_or_bust(sc, name, sc->delete_file_symbol, args, sc->type_names[T_STRING]));
+ if (string_length(name) > 2)
+ {
+ 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));
+ }}
+ return(make_integer(sc, unlink(string_value(name))));
+}
+
+/* -------------------------------- getenv -------------------------------- */
+static s7_pointer g_getenv(s7_scheme *sc, s7_pointer args) /* r7rs says #f if no such variable. this used to return "" in that case, 6-May-22 */
+{
+ #define H_getenv "(getenv var) returns the value of an environment variable, or #f if none is found"
+ #define Q_getenv s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->not_symbol), sc->is_string_symbol)
+
+ char *result;
+ s7_pointer name = car(args);
+ if (!is_string(name))
+ return(sole_arg_method_or_bust(sc, name, sc->getenv_symbol, args, sc->type_names[T_STRING]));
+ result = getenv(string_value(name));
+ return((result) ? s7_make_string(sc, result) : sc->F);
+}
+
+/* -------------------------------- system -------------------------------- */
+static s7_pointer g_system(s7_scheme *sc, s7_pointer args)
+{
+ #define H_system "(system command) executes the command. If the optional second argument is #t, \
+system captures the output as a string and returns it."
+ #define Q_system s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol), sc->is_string_symbol, sc->is_boolean_symbol)
+
+#ifdef __EMSCRIPTEN__
+ return s7_nil(sc);
+#else
+ s7_pointer name = car(args);
+
+ if (!is_string(name))
+ return(sole_arg_method_or_bust(sc, name, sc->system_symbol, args, sc->type_names[T_STRING]));
+
+ if ((is_pair(cdr(args))) &&
+ (cadr(args) == sc->T))
+ {
+ #define BUF_SIZE 256
+ char buf[BUF_SIZE];
+ char *str = NULL;
+ 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;
+ }
+ 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));
+ }
+ return(nil_string);
+ }
+ return(make_integer(sc, system(string_value(name))));
+#endif
+}
+
+
+#if (!MS_WINDOWS)
+#include <dirent.h>
+
+/* -------------------------------- directory->list -------------------------------- */
+static s7_pointer directory_to_list_1(s7_scheme *sc, const char *dir_name)
+{
+ s7_pointer result;
+ DIR *dpos;
+ sc->w = sc->nil;
+ if ((dpos = opendir(dir_name)))
+ {
+ struct dirent *dirp;
+ while ((dirp = readdir(dpos)))
+ sc->w = cons_unchecked(sc, s7_make_string(sc, dirp->d_name), sc->w);
+ closedir(dpos);
+ }
+ result = sc->w;
+ sc->w = sc->unused;
+ return(result);
+}
+
+static s7_pointer g_directory_to_list(s7_scheme *sc, s7_pointer args)
+{
+ #define H_directory_to_list "(directory->list directory) returns the contents of the directory as a list of strings (filenames)."
+ #define Q_directory_to_list s7_make_signature(sc, 2, sc->is_list_symbol, sc->is_string_symbol) /* can return nil */
+
+ s7_pointer name = car(args);
+ if (!is_string(name))
+ return(method_or_bust_p(sc, name, sc->directory_to_list_symbol, sc->type_names[T_STRING]));
+ if (string_length(name) >= 2)
+ {
+ 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);
+ }}
+ return(directory_to_list_1(sc, string_value(name)));
+}
+
+/* -------------------------------- file-mtime -------------------------------- */
+static s7_pointer g_file_mtime(s7_scheme *sc, s7_pointer args)
+{
+ #define H_file_mtime "(file-mtime file): return the write date of file"
+ #define Q_file_mtime s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)
+
+ struct stat statbuf;
+ int32_t err;
+ s7_pointer name = car(args);
+
+ if (!is_string(name))
+ return(sole_arg_method_or_bust(sc, name, sc->file_mtime_symbol, args, sc->type_names[T_STRING]));
+ if (string_length(name) >= 2)
+ {
+ 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(string_value(name), &statbuf);
+ if (err < 0)
+ file_error_nr(sc, "file-mtime", strerror(errno), string_value(name));
+ return(make_integer(sc, (s7_int)(statbuf.st_mtime)));
+}
+#endif
+#endif /* with_system_extras */
+
+
+/* -------------------------------- lists -------------------------------- */
+s7_pointer s7_cons(s7_scheme *sc, s7_pointer a, s7_pointer b)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE);
+ set_car(x, a);
+ set_cdr(x, b);
+ return(x);
+}
+
+static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b)
+{
+ /* apparently slightly faster as a function? */
+ s7_pointer x;
+ new_cell_no_check(sc, x, T_PAIR | T_SAFE_PROCEDURE);
+ set_car(x, a);
+ set_cdr(x, b);
+ return(x);
+}
+
+static s7_pointer semipermanent_cons(s7_scheme *sc, s7_pointer a, s7_pointer b, uint64_t type)
+{
+ s7_pointer x = alloc_pointer(sc);
+ set_full_type(x, type | T_UNHEAP);
+ set_car(x, a);
+ unchecked_set_cdr(x, b);
+ return(x);
+}
+
+static s7_pointer semipermanent_list(s7_scheme *sc, s7_int len)
+{
+ s7_pointer p = sc->nil;
+ for (s7_int j = 0; j < len; j++)
+ p = semipermanent_cons(sc, sc->unused, p, T_PAIR | T_IMMUTABLE);
+ return(p);
+}
+
+s7_pointer s7_make_signature(s7_scheme *sc, s7_int len, ...)
+{
+ va_list ap;
+ s7_int i;
+ s7_pointer res = sc->nil;
+
+ for (i = 0; i < len; i++)
+ res = semipermanent_cons(sc, sc->unused, res, T_PAIR | T_IMMUTABLE);
+ va_start(ap, len);
+ i = 0;
+ for (s7_pointer p = res; is_pair(p); p = cdr(p), i++)
+ {
+ 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);
+ }
+ va_end(ap);
+ return((s7_pointer)res);
+}
+
+s7_pointer s7_make_circular_signature(s7_scheme *sc, s7_int cycle_point, s7_int len, ...)
+{
+ va_list ap;
+ s7_int i;
+ s7_pointer p, res = sc->nil, back = NULL, end = NULL;
+
+ for (i = 0; i < len; i++)
+ res = semipermanent_cons(sc, sc->nil, res, T_PAIR | T_IMMUTABLE);
+ va_start(ap, len);
+ for (p = res, i = 0; is_pair(p); p = cdr(p), i++)
+ {
+ 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);
+ if (i == cycle_point) back = p;
+ if (i == (len - 1)) end = p;
+ }
+ va_end(ap);
+ if (end) unchecked_set_cdr(end, back);
+ if (i < len)
+ s7_warn(sc, 256, "s7_make_circular_signature got too few entries: %s\n", display(res));
+ return((s7_pointer)res);
+}
+
+
+bool s7_is_pair(s7_pointer p) {return(is_pair(p));}
+static s7_pointer is_pair_p_p(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) ? sc->T : sc->F);}
+
+s7_pointer s7_car(s7_pointer p) {return(car(p));}
+s7_pointer s7_cdr(s7_pointer p) {return(cdr(p));}
+
+s7_pointer s7_cadr(s7_pointer p) {return(cadr(p));}
+s7_pointer s7_cddr(s7_pointer p) {return(cddr(p));}
+s7_pointer s7_cdar(s7_pointer p) {return(cdar(p));}
+s7_pointer s7_caar(s7_pointer p) {return(caar(p));}
+
+s7_pointer s7_caadr(s7_pointer p) {return(caadr(p));}
+s7_pointer s7_caddr(s7_pointer p) {return(caddr(p));}
+s7_pointer s7_cadar(s7_pointer p) {return(cadar(p));}
+s7_pointer s7_caaar(s7_pointer p) {return(caaar(p));}
+s7_pointer s7_cdadr(s7_pointer p) {return(cdadr(p));}
+s7_pointer s7_cdddr(s7_pointer p) {return(cdddr(p));}
+s7_pointer s7_cddar(s7_pointer p) {return(cddar(p));}
+s7_pointer s7_cdaar(s7_pointer p) {return(cdaar(p));}
+
+s7_pointer s7_caaadr(s7_pointer p) {return(caaadr(p));}
+s7_pointer s7_caaddr(s7_pointer p) {return(caaddr(p));}
+s7_pointer s7_caadar(s7_pointer p) {return(caadar(p));}
+s7_pointer s7_caaaar(s7_pointer p) {return(caaaar(p));}
+s7_pointer s7_cadadr(s7_pointer p) {return(cadadr(p));}
+s7_pointer s7_cadddr(s7_pointer p) {return(cadddr(p));}
+s7_pointer s7_caddar(s7_pointer p) {return(caddar(p));}
+s7_pointer s7_cadaar(s7_pointer p) {return(cadaar(p));}
+
+s7_pointer s7_cdaadr(s7_pointer p) {return(cdaadr(p));}
+s7_pointer s7_cdaddr(s7_pointer p) {return(cdaddr(p));}
+s7_pointer s7_cdadar(s7_pointer p) {return(cdadar(p));}
+s7_pointer s7_cdaaar(s7_pointer p) {return(cdaaar(p));}
+s7_pointer s7_cddadr(s7_pointer p) {return(cddadr(p));}
+s7_pointer s7_cddddr(s7_pointer p) {return(cddddr(p));}
+s7_pointer s7_cdddar(s7_pointer p) {return(cdddar(p));}
+s7_pointer s7_cddaar(s7_pointer p) {return(cddaar(p));}
+
+s7_pointer s7_set_car(s7_pointer p, s7_pointer q) {set_car(p, q); return(q);}
+s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q) {set_cdr(p, q); return(q);}
+
+
+/* -------------------------------------------------------------------------------- */
+void s7_list_to_array(s7_scheme *sc, s7_pointer list, s7_pointer *array, int32_t len)
+{
+ int32_t i = 0;
+ for (s7_pointer p = list; is_pair(p); p = cdr(p), i++) array[i] = car(p);
+ for (; i < len; i++) array[i] = sc->undefined;
+}
+
+
+/* ---------------- tree-leaves ---------------- */
+static inline s7_int tree_len_1(s7_scheme *sc, s7_pointer p)
+{
+ s7_int sum;
+ if ((S7_DEBUGGING) && (tree_is_cyclic(sc, p))) {fprintf(stderr, "%s[%d]: tree is cyclic\n", __func__, __LINE__); abort();}
+ for (sum = 0; is_pair(p); p = cdr(p))
+ {
+ s7_pointer cp = car(p);
+ if ((!is_pair(cp)) ||
+ (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++;
+ }}
+ return((is_null(p)) ? sum : sum + 1);
+}
+
+static inline s7_int tree_len(s7_scheme *sc, s7_pointer p)
+{
+ if (is_null(p))
+ return(0);
+ if ((!is_pair(p)) ||
+ (is_quote(car(p))))
+ return(1);
+ return(tree_len_1(sc, p));
+}
+
+static s7_int tree_leaves_i_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_list(p))
+ sole_arg_wrong_type_error_nr(sc, sc->tree_leaves_symbol, p, a_list_string);
+ if ((sc->safety > NO_SAFETY) &&
+ (tree_is_cyclic(sc, p)))
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-leaves: tree is cyclic: ~S", 31), p));
+ return(tree_len(sc, p));
+}
+
+static s7_pointer tree_leaves_p_p(s7_scheme *sc, s7_pointer tree)
+{
+ return(make_integer(sc, tree_leaves_i_7p(sc, tree)));
+}
+
+static s7_pointer g_tree_leaves(s7_scheme *sc, s7_pointer args)
+{
+ #define H_tree_leaves "(tree-leaves tree) returns the number of leaves in the tree"
+ #define Q_tree_leaves s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_list_symbol)
+ return(tree_leaves_p_p(sc, car(args)));
+}
+
+
+/* ---------------- tree-memq ---------------- */
+static inline bool tree_memq_1(s7_scheme *sc, s7_pointer sym, s7_pointer tree) /* sym need not be a symbol */
+{
+ if (is_quote(car(tree)))
+ return((!is_symbol(sym)) && (!is_pair(sym)) && (is_pair(cdr(tree))) && (sym == cadr(tree)));
+ do {
+ if (sym == car(tree))
+ return(true);
+
+ 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));
+ }
+ tree = cdr(tree);
+ if (sym == tree)
+ return(true);
+ } while (is_pair(tree));
+ return(false);
+}
+
+bool s7_tree_memq(s7_scheme *sc, s7_pointer sym, s7_pointer tree)
+{
+ if (sym == tree) return(true);
+ if (!is_pair(tree)) return(false);
+ if ((sc->safety > NO_SAFETY) &&
+ (tree_is_cyclic(sc, tree)))
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-memq: tree is cyclic: ~S", 29), tree));
+ return(tree_memq_1(sc, sym, tree));
+}
+
+static s7_pointer g_tree_memq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_tree_memq "(tree-memq obj tree) is a tree-oriented version of memq, but returning #t if the object is in the tree."
+ #define Q_tree_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->is_list_symbol)
+ s7_pointer tree = cadr(args);
+ if (!is_list(tree))
+ wrong_type_error_nr(sc, sc->tree_memq_symbol, 2, tree, a_list_string);
+ return(make_boolean(sc, s7_tree_memq(sc, car(args), tree)));
+}
+
+
+/* ---------------- tree-set-memq ---------------- */
+static inline bool pair_set_memq(s7_scheme *sc, s7_pointer tree)
+{
+ while (true)
+ {
+ s7_pointer p = car(tree);
+ if (is_symbol(p))
+ {
+ if (symbol_is_in_list(sc, p))
+ return(true);
+ }
+ else
+ if ((is_unquoted_pair(p)) &&
+ (pair_set_memq(sc, p)))
+ return(true);
+ tree = cdr(tree);
+ if (!is_pair(tree)) break;
+ }
+ return((is_symbol(tree)) && (symbol_is_in_list(sc, tree)));
+}
+
+static bool tree_set_memq_b_7pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree)
+{
+ bool non_symbols = false;
+ if (!is_list(syms))
+ wrong_type_error_nr(sc, sc->tree_set_memq_symbol, 1, syms, a_list_string);
+ if (is_null(syms)) return(false);
+ if (!is_list(tree))
+ wrong_type_error_nr(sc, sc->tree_set_memq_symbol, 2, tree, a_list_string);
+ if (is_null(tree)) return(false);
+ 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));
+ 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));
+ }
+ clear_symbol_list(sc);
+ for (s7_pointer p = syms; is_pair(p); p = cdr(p))
+ if (is_symbol(car(p)))
+ add_symbol_to_list(sc, car(p));
+ else non_symbols = true;
+
+ if /* ((!is_quote(car(tree))) && */ (pair_set_memq(sc, tree)) return(true);
+
+ 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);
+ return(false);
+}
+
+static s7_pointer tree_set_memq_p_pp(s7_scheme *sc, s7_pointer syms, s7_pointer tree)
+{
+ return(make_boolean(sc, tree_set_memq_b_7pp(sc, syms, tree)));
+}
+
+static s7_pointer g_tree_set_memq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_tree_set_memq "(tree-set-memq symbols tree) returns #t if any of the list of symbols is in the tree"
+ #define Q_tree_set_memq s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->is_list_symbol, sc->is_list_symbol)
+ return(make_boolean(sc, tree_set_memq_b_7pp(sc, car(args), cadr(args))));
+}
+
+static s7_pointer tree_set_memq_syms_direct(s7_scheme *sc, s7_pointer syms, s7_pointer tree)
+{
+ if (!is_list(tree))
+ wrong_type_error_nr(sc, sc->tree_set_memq_symbol, 2, tree, a_list_string);
+ if (is_null(tree)) return(sc->F);
+ if ((sc->safety > NO_SAFETY) &&
+ (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));
+ clear_symbol_list(sc);
+ for (s7_pointer p = syms; is_pair(p); p = cdr(p))
+ add_symbol_to_list(sc, car(p));
+ if (is_quote(car(tree))) return(sc->F);
+ return(make_boolean(sc, pair_set_memq(sc, tree)));
+}
+
+static s7_pointer g_tree_set_memq_syms(s7_scheme *sc, s7_pointer args)
+{
+ return(tree_set_memq_syms_direct(sc, car(args), cadr(args))); /* need other form for pp */
+}
+
+static s7_pointer tree_set_memq_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr)
+{
+ if ((is_proper_quote(sc, cadr(expr))) && /* not (tree-set-memq (quote) ...) */
+ (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);
+ return(sc->tree_set_memq_syms);
+ }
+ return(f);
+}
+
+
+/* ---------------- tree-count ---------------- */
+static s7_int tree_count(s7_scheme *sc, s7_pointer x, s7_pointer p, s7_int count)
+{
+ if (p == x) return(count + 1);
+ if ((!is_pair(p)) || (is_quote(car(p)))) return(count);
+ return(tree_count(sc, x, cdr(p), tree_count(sc, x, car(p), count)));
+}
+
+static inline s7_int tree_count_at_least(s7_scheme *sc, s7_pointer x, s7_pointer p, s7_int count, s7_int top)
+{
+ if (p == x) return(count + 1);
+ if ((!is_pair(p)) || (is_quote(car(p)))) return(count);
+ do {
+ count = tree_count_at_least(sc, x, car(p), count, top);
+ if (count >= top) return(count);
+ p = cdr(p);
+ if (p == x) return(count + 1);
+ } while (is_pair(p));
+ return(count);
+}
+
+static s7_pointer g_tree_count(s7_scheme *sc, s7_pointer args)
+{
+ #define H_tree_count "(tree-count obj tree max-count) returns how many times obj is in tree (using eq?), stopping at max-count (if specified)"
+ #define Q_tree_count s7_make_signature(sc, 4, sc->is_integer_symbol, sc->T, sc->is_list_symbol, sc->is_integer_symbol)
+ s7_pointer obj = car(args);
+ s7_pointer tree = cadr(args), count;
+
+ 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]);
+ if (is_null(tree)) return(int_zero);
+ wrong_type_error_nr(sc, sc->tree_count_symbol, 2, tree, a_list_string);
+ }
+ if ((sc->safety > NO_SAFETY) &&
+ (tree_is_cyclic(sc, tree)))
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "tree-count: tree is cyclic: ~S", 30), tree));
+ if (is_null(cddr(args)))
+ return(make_integer(sc, tree_count(sc, obj, tree, 0)));
+ count = caddr(args);
+ if (!s7_is_integer(count))
+ wrong_type_error_nr(sc, sc->tree_count_symbol, 3, count, sc->type_names[T_INTEGER]);
+ return(make_integer(sc, tree_count_at_least(sc, obj, tree, 0, s7_integer_clamped_if_gmp(sc, count))));
+}
+
+
+/* -------------------------------- pair? -------------------------------- */
+static s7_pointer g_is_pair(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_pair "(pair? obj) returns #t if obj is a pair (a non-empty list)"
+ #define Q_is_pair sc->pl_bt
+ check_boolean_method(sc, is_pair, sc->is_pair_symbol, args);
+}
+
+
+/* -------------------------------- list? -------------------------------- */
+bool s7_is_list(s7_scheme *sc, s7_pointer p) {return(is_list(p));}
+
+static bool is_list_b(s7_pointer p) {return((is_pair(p)) || (type(p) == T_NIL));}
+
+static s7_pointer g_is_list(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_list "(list? obj) returns #t if obj is a pair or null"
+ #define Q_is_list sc->pl_bt
+ #define is_a_list(p) s7_is_list(sc, p)
+ check_boolean_method(sc, is_a_list, sc->is_list_symbol, args);
+}
+
+static s7_int proper_list_length(s7_pointer a)
+{
+ s7_int i = 0;
+ for (s7_pointer b = a; is_pair(b); i++, b = cdr(b)) {};
+ return(i);
+}
+
+static s7_int proper_list_length_with_end(s7_pointer a, s7_pointer *c)
+{
+ s7_int i = 0;
+ s7_pointer b;
+ for (b = a; is_pair(b); i++, b = cdr(b)) {};
+ *c = b;
+ return(i);
+}
+
+s7_int s7_list_length(s7_scheme *sc, s7_pointer a) /* returns -len if list is dotted, 0 if it's (directly) circular */
+{
+ s7_pointer slow = a, fast = a;
+ for (s7_int i = 0; ; i += 2)
+ {
+ if (!is_pair(fast)) return((is_null(fast)) ? i : -i);
+ fast = cdr(fast);
+ 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);
+ }
+ return(0);
+}
+
+
+/* -------------------------------- proper-list? -------------------------------- */
+static /* inline */ s7_pointer copy_proper_list(s7_scheme *sc, s7_pointer lst)
+{
+ s7_pointer tp;
+ if (!is_pair(lst)) return(sc->nil);
+ sc->temp5 = lst;
+ tp = list_1(sc, car(lst));
+ sc->temp8 = tp;
+ for (s7_pointer p = cdr(lst), np = tp; is_pair(p); p = cdr(p), np = cdr(np))
+ {
+ set_cdr(np, list_1_unchecked(sc, car(p)));
+ p = cdr(p);
+ if (is_pair(p)) {np = cdr(np); set_cdr(np, list_1_unchecked(sc, car(p)));} else break;
+ p = cdr(p);
+ if (is_pair(p)) {np = cdr(np); set_cdr(np, list_1(sc, car(p)));} else break;
+ }
+ sc->temp8 = sc->unused;
+ sc->temp5 = sc->unused;
+ return(tp);
+}
+
+bool s7_is_proper_list(s7_scheme *sc, s7_pointer lst)
+{
+ /* #t if () or undotted/non-circular pair */
+ s7_pointer slow = lst, fast = lst;
+ while (true)
+ {
+ if (!is_pair(fast))
+ 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);
+ if (fast == slow) return(false);
+ }
+ return(true);
+}
+
+static s7_pointer g_is_proper_list(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_proper_list "(proper-list? x) returns #t is x is a list that is neither circular nor dotted."
+ #define Q_is_proper_list sc->pl_bt
+ return(make_boolean(sc, s7_is_proper_list(sc, car(args))));
+}
+
+static s7_pointer is_proper_list_p_p(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, s7_is_proper_list(sc, arg)));}
+
+static bool is_proper_list_1(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_null(cdr(p))));}
+static bool is_proper_list_2(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_pair(cdr(p))) && (is_null(cddr(p))));}
+static bool is_proper_list_3(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cddr(p))) && (is_null(cdddr(p))));}
+static bool is_proper_list_4(s7_scheme *unused_sc, s7_pointer p) {return(proper_list_length(p) == 4);}
+
+
+/* -------------------------------- make-list -------------------------------- */
+static s7_pointer make_big_list(s7_scheme *sc, s7_int len, s7_pointer init)
+{
+ s7_pointer res; /* expanding and using free_heap pointers as a block here is 10% faster */
+ check_free_heap_size(sc, len + 1); /* using cons_unchecked below, +1 in case we are on the trigger at the end */
+ sc->temp6 = sc->nil; /* sc->temp6 used only here currently */
+ for (s7_int i = 0; i < len; i++) sc->temp6 = cons_unchecked(sc, init, sc->temp6);
+ res = sc->temp6;
+ sc->temp6 = sc->unused;
+ return(res);
+}
+
+static inline s7_pointer make_list(s7_scheme *sc, s7_int len, s7_pointer init)
+{
+ switch (len)
+ {
+ case 0: return(sc->nil);
+ case 1: return(T_Pair(cons(sc, init, sc->nil)));
+ case 2: return(T_Pair(cons_unchecked(sc, init, cons(sc, init, sc->nil))));
+ case 3: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil)))));
+ case 4: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil))))));
+ case 5: return(T_Pair(cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons_unchecked(sc, init, cons(sc, init, sc->nil)))))));
+ 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)))))))));
+ default:
+ return(make_big_list(sc, len, init));
+ }
+ return(sc->nil); /* never happens, I hope */
+}
+
+s7_pointer s7_make_list(s7_scheme *sc, s7_int len, s7_pointer init) {return(make_list(sc, len, init));}
+
+static s7_pointer make_list_p_pp(s7_scheme *sc, s7_pointer n, s7_pointer init)
+{
+ s7_int len;
+ if (!s7_is_integer(n))
+ return(method_or_bust(sc, n, sc->make_list_symbol, set_plist_2(sc, n, init), sc->type_names[T_INTEGER], 1));
+
+ len = s7_integer_clamped_if_gmp(sc, n);
+#if WITH_GMP
+ if ((len == 0) && (!is_zero(n)))
+ out_of_range_error_nr(sc, sc->make_list_symbol, int_one, n, wrap_string(sc, "big integer is too big for s7_int", 33));
+#endif
+ if (len == 0) return(sc->nil); /* what about (make-list 0 123)? */
+ if (len < 0)
+ 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)));
+
+ return(make_list(sc, len, init));
+}
+
+static s7_pointer g_make_list(s7_scheme *sc, s7_pointer args)
+{
+ #define H_make_list "(make-list length (initial-element #f)) returns a list of 'length' elements whose value is 'initial-element'."
+ #define Q_make_list s7_make_signature(sc, 3, sc->is_proper_list_symbol, sc->is_integer_symbol, sc->T)
+ return(make_list_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : sc->F));
+}
+
+
+/* -------------------------------- list-ref -------------------------------- */
+s7_pointer s7_list_ref(s7_scheme *sc, s7_pointer lst, s7_int num)
+{
+ s7_int i;
+ s7_pointer x;
+ for (x = lst, i = 0; (i < num) && (is_pair(x)); i++, x = cdr(x)) {}
+ if ((i == num) && (is_pair(x)))
+ return(car(x));
+ return(sc->nil);
+}
+
+static s7_pointer list_ref_1(s7_scheme *sc, s7_pointer lst, s7_pointer ind)
+{
+ s7_int index;
+ s7_pointer p = lst;
+
+ if (!s7_is_integer(ind))
+ return(method_or_bust_pp(sc, ind, sc->list_ref_symbol, lst, ind, sc->type_names[T_INTEGER], 2));
+ index = s7_integer_clamped_if_gmp(sc, ind);
+ if ((index < 0) || (index > sc->max_list_length)) /* max-list-length check for circular list-ref? */
+ out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, ind, (index < 0) ? it_is_negative_string : it_is_too_large_string);
+ for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {}
+ if (is_pair(p)) return(car(p));
+ if (is_null(p))
+ out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, ind, it_is_too_large_string);
+ wrong_type_error_nr(sc, sc->list_ref_symbol, 1, lst, a_proper_list_string);
+ return(NULL);
+}
+
+static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices);
+
+static s7_pointer ref_index_checked(s7_scheme *sc, s7_pointer caller, s7_pointer in_obj, s7_pointer args)
+{
+ 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));
+ /* 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)));
+}
+
+static s7_pointer g_list_ref(s7_scheme *sc, s7_pointer args)
+{
+ #define H_list_ref "(list-ref lst i ...) returns the i-th element (0-based) of the list"
+ #define Q_list_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol)
+ /* (let ((L '((1 2 3) (4 5 6)))) (list-ref L 1 2)) */
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst))
+ return(method_or_bust(sc, lst, sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1));
+
+ lst = list_ref_1(sc, lst, cadr(args));
+ if (is_pair(cddr(args)))
+ return(ref_index_checked(sc, global_value(sc->list_ref_symbol), lst, args));
+ return(lst);
+}
+
+static bool op_implicit_pair_ref_a(s7_scheme *sc)
+{
+ s7_pointer s = lookup_checked(sc, car(sc->code));
+ if (!is_pair(s)) {sc->last_function = s; return(false);}
+ sc->value = list_ref_1(sc, s, fx_call(sc, cdr(sc->code)));
+ return(true);
+}
+
+static s7_pointer fx_implicit_pair_ref_a(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer s = lookup_checked(sc, car(arg));
+ if (!is_pair(s))
+ return(s7_apply_function(sc, s, list_1(sc, fx_call(sc, cdr(arg)))));
+ return(list_ref_1(sc, s, fx_call(sc, cdr(arg))));
+}
+
+static s7_pointer implicit_pair_index_checked(s7_scheme *sc, s7_pointer obj, s7_pointer in_obj, s7_pointer indices)
+{
+ if (!is_applicable(in_obj))
+ {
+ 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));
+ }
+ return(implicit_index(sc, in_obj, cdr(indices)));
+}
+
+static bool op_implicit_pair_ref_aa(s7_scheme *sc)
+{
+ s7_pointer i1;
+ s7_pointer s = lookup_checked(sc, car(sc->code));
+ if (!is_pair(s)) {sc->last_function = s; return(false);}
+ sc->args = fx_call(sc, cddr(sc->code));
+ i1 = fx_call(sc, cdr(sc->code));
+ sc->value = implicit_pair_index_checked(sc, s, list_ref_1(sc, s, i1), set_plist_2(sc, i1, sc->args));
+ return(true);
+}
+
+static s7_pointer list_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if (args == 2)
+ {
+ 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);
+ }}
+ return(f);
+}
+
+static inline s7_pointer list_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1)
+{
+ s7_pointer p = p1;
+ if ((i1 < 0) || (i1 > sc->max_list_length))
+ out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ for (s7_int i = 0; ((is_pair(p)) && (i < i1)); i++, p = cdr(p));
+ 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);
+ wrong_type_error_nr(sc, sc->list_ref_symbol, 1, p1, a_proper_list_string);
+ }
+ return(car(p));
+}
+
+static s7_pointer list_ref_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1)
+{
+ if (!is_pair(p1))
+ wrong_type_error_nr(sc, sc->list_ref_symbol, 1, p1, sc->type_names[T_PAIR]);
+ return(list_ref_p_pi_unchecked(sc, p1, i1));
+}
+
+static s7_pointer list_ref_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ if (!is_pair(p1))
+ return(g_list_ref(sc, set_plist_2(sc, p1, p2)));
+ if (!s7_is_integer(p2))
+ wrong_type_error_nr(sc, sc->list_ref_symbol, 1, p2, sc->type_names[T_INTEGER]);
+ return(list_ref_p_pi_unchecked(sc, p1, s7_integer_clamped_if_gmp(sc, p2)));
+}
+
+
+/* -------------------------------- list-set! -------------------------------- */
+s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, s7_int num, s7_pointer val)
+{
+ s7_int i;
+ s7_pointer x;
+ for (x = lst, i = 0; (i < num) && (is_pair(x)); i++, x = cdr(x)) {}
+ if ((i == num) &&
+ (is_pair(x)))
+ set_car(x, T_Ext(val));
+ return(val);
+}
+
+static s7_pointer g_list_set_1(s7_scheme *sc, s7_pointer lst, s7_pointer args, int32_t arg_num)
+{
+ #define H_list_set "(list-set! lst i ... val) sets the i-th element (0-based) of the list to val"
+ #define Q_list_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_pair_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol)
+
+ s7_int index;
+ s7_pointer p = lst, ind;
+ /* (let ((L '((1 2 3) (4 5 6)))) (list-set! L 1 2 32) L) */
+
+ if (!is_mutable_pair(lst))
+ return(mutable_method_or_bust(sc, lst, sc->list_set_symbol, set_ulist_1(sc, lst, args), sc->type_names[T_PAIR], 1));
+ ind = car(args);
+ if ((arg_num > 2) && (is_null(cdr(args))))
+ {
+ set_car(lst, ind);
+ return(ind);
+ }
+ if (!s7_is_integer(ind))
+ return(method_or_bust(sc, ind, sc->list_set_symbol, set_ulist_1(sc, lst, args), sc->type_names[T_INTEGER], 2));
+ index = s7_integer_clamped_if_gmp(sc, ind);
+ if ((index < 0) || (index > sc->max_list_length))
+ out_of_range_error_nr(sc, sc->list_set_symbol, wrap_integer(sc, arg_num), ind, (index < 0) ? it_is_negative_string : it_is_too_large_string);
+
+ for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {}
+ 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);
+ wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, a_proper_list_string);
+ }
+ if (is_null(cddr(args)))
+ set_car(p, cadr(args));
+ else
+ {
+ if (!s7_is_pair(car(p)))
+ 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));
+}
+
+static s7_pointer g_list_set(s7_scheme *sc, s7_pointer args) {return(g_list_set_1(sc, car(args), cdr(args), 2));}
+
+static inline s7_pointer list_set_p_pip_unchecked(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2)
+{
+ s7_pointer p = p1;
+ if ((i1 < 0) || (i1 > sc->max_list_length))
+ out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ for (s7_int i = 0; ((is_pair(p)) && (i < i1)); i++, p = cdr(p));
+ 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);
+ wrong_type_error_nr(sc, sc->list_set_symbol, 1, p1, a_proper_list_string);
+ }
+ set_car(p, p2);
+ return(p2);
+}
+
+static s7_pointer list_increment_p_pip_unchecked(opt_info *o)
+{
+ s7_scheme *sc = o->sc;
+ s7_pointer p = slot_value(o->v[2].p), p1, p2;
+ s7_int index = integer(p);
+ if ((index < 0) || (index > sc->max_list_length))
+ out_of_range_error_nr(sc, sc->list_set_symbol, int_two, p, (index < 0) ? it_is_negative_string : it_is_too_large_string);
+ p1 = slot_value(o->v[1].p);
+ p = p1;
+ for (s7_int i = 0; ((is_pair(p)) && (i < index)); i++, p = cdr(p));
+ 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);
+ 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);
+ set_car(p, p2);
+ return(p2);
+}
+
+static s7_pointer list_set_p_pip(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) /* this may be uncallable now -- opt'd away in every case? */
+{
+ if (!is_pair(p1))
+ wrong_type_error_nr(sc, sc->list_set_symbol, 1, p1, sc->type_names[T_PAIR]);
+ return(list_set_p_pip_unchecked(sc, p1, i1, p2));
+}
+
+static s7_pointer g_list_set_i(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer lst = car(args), val;
+ s7_pointer p = lst;
+ s7_int index;
+ if (!is_mutable_pair(lst))
+ return(mutable_method_or_bust(sc, lst, sc->list_set_symbol, args, sc->type_names[T_PAIR], 1));
+
+ index = s7_integer_clamped_if_gmp(sc, cadr(args));
+ if ((index < 0) || (index > sc->max_list_length))
+ out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string);
+
+ for (s7_int i = 0; (i < index) && is_pair(p); i++, p = cdr(p)) {}
+ 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);
+ wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, a_proper_list_string);
+ }
+ val = caddr(args);
+ set_car(p, val);
+ return(val);
+}
+
+static s7_pointer list_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if ((args == 3) &&
+ (s7_is_integer(caddr(expr))) &&
+ (s7_integer_clamped_if_gmp(sc, caddr(expr)) >= 0) &&
+ (s7_integer_clamped_if_gmp(sc, caddr(expr)) < sc->max_list_length))
+ return(sc->list_set_i);
+ return(f);
+}
+
+
+/* -------------------------------- list-tail -------------------------------- */
+static s7_pointer list_tail_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer p)
+{
+ s7_int i, index;
+ if (!s7_is_integer(p))
+ return(method_or_bust_pp(sc, p, sc->list_tail_symbol, lst, p, sc->type_names[T_INTEGER], 2));
+ index = s7_integer_clamped_if_gmp(sc, p);
+
+ if (!is_list(lst)) /* (list-tail () 0) -> () */
+ return(method_or_bust_with_type_pi(sc, lst, sc->list_tail_symbol, lst, index, a_list_string, 1));
+ if ((index < 0) || (index > sc->max_list_length))
+ out_of_range_error_nr(sc, sc->list_tail_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string);
+ for (i = 0; (i < index) && (is_pair(lst)); i++, lst = cdr(lst)) {}
+ if (i < index)
+ out_of_range_error_nr(sc, sc->list_tail_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string);
+ return(lst);
+}
+
+static s7_pointer g_list_tail(s7_scheme *sc, s7_pointer args)
+{
+ #define H_list_tail "(list-tail lst i) returns the list from the i-th element on"
+ #define Q_list_tail s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol) /* #t: (list-tail '(1 . 2) 1) -> 2 */
+ return(list_tail_p_pp(sc, car(args), cadr(args)));
+}
+
+
+/* -------------------------------- cons -------------------------------- */
+static s7_pointer g_cons(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cons "(cons a b) returns a pair containing a and b"
+ #define Q_cons s7_make_signature(sc, 3, sc->is_pair_symbol, sc->T, sc->T)
+
+ s7_pointer x;
+ new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE);
+ set_car(x, car(args));
+ set_cdr(x, cadr(args));
+ return(x);
+}
+
+static s7_pointer cons_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ s7_pointer x;
+ new_cell(sc, x, T_PAIR | T_SAFE_PROCEDURE);
+ set_car(x, p1);
+ set_cdr(x, p2);
+ return(x);
+}
+
+
+/* -------- car -------- */
+
+static s7_pointer g_car(s7_scheme *sc, s7_pointer args)
+{
+ #define H_car "(car pair) returns the first element of the pair"
+ #define Q_car sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (is_pair(lst))
+ return(car(lst));
+ return(sole_arg_method_or_bust(sc, lst, sc->car_symbol, args, sc->type_names[T_PAIR]));
+}
+
+static s7_pointer car_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_pair(p))
+ return(car(p));
+ return(sole_arg_method_or_bust(sc, p, sc->car_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR]));
+}
+
+static s7_pointer g_list_ref_at_0(s7_scheme *sc, s7_pointer args)
+{
+ if (is_pair(car(args))) return(caar(args));
+ return(method_or_bust(sc, car(args), sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1)); /* 1=arg num if error */
+}
+
+
+static s7_pointer g_set_car(s7_scheme *sc, s7_pointer args)
+{
+ #define H_set_car "(set-car! pair val) sets the pair's first element to val"
+ #define Q_set_car s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T)
+
+ s7_pointer p = car(args);
+ if (!is_mutable_pair(p)) return(mutable_method_or_bust(sc, p, sc->set_car_symbol, args, sc->type_names[T_PAIR], 1));
+ set_car(p, cadr(args));
+ return(car(p));
+}
+
+static Inline s7_pointer inline_set_car(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ if (!is_mutable_pair(p1)) return(mutable_method_or_bust(sc, p1, sc->set_car_symbol, set_plist_1(sc, p1), sc->type_names[T_PAIR], 1));
+ set_car(p1, p2);
+ return(p2);
+}
+
+static s7_pointer set_car_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(inline_set_car(sc, p1, p2));}
+
+
+/* -------- cdr -------- */
+static s7_pointer g_cdr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cdr "(cdr pair) returns the second element of the pair"
+ #define Q_cdr sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (is_pair(lst))
+ return(cdr(lst));
+ return(sole_arg_method_or_bust(sc, lst, sc->cdr_symbol, args, sc->type_names[T_PAIR]));
+}
+
+static s7_pointer cdr_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if (is_pair(p))
+ return(cdr(p));
+ return(sole_arg_method_or_bust(sc, p, sc->cdr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR]));
+}
+
+
+static s7_pointer g_set_cdr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_set_cdr "(set-cdr! pair val) sets the pair's second element to val"
+ #define Q_set_cdr s7_make_signature(sc, 3, sc->T, sc->is_pair_symbol, sc->T)
+
+ s7_pointer p = car(args);
+ if (!is_mutable_pair(p)) return(mutable_method_or_bust(sc, p, sc->set_cdr_symbol, args, sc->type_names[T_PAIR], 1));
+ set_cdr(p, cadr(args));
+ return(cdr(p));
+}
+
+static Inline s7_pointer inline_set_cdr(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ if (!is_mutable_pair(p1)) return(mutable_method_or_bust(sc, p1, sc->set_cdr_symbol, set_plist_1(sc, p1), sc->type_names[T_PAIR], 1));
+ set_cdr(p1, p2);
+ return(p2);
+}
+
+static s7_pointer set_cdr_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(inline_set_cdr(sc, p1, p2));}
+
+
+/* -------- caar --------*/
+static s7_pointer g_caar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_caar "(caar lst) returns (car (car lst)): (caar '((1 2))) -> 1"
+ #define Q_caar sc->pl_p
+
+ s7_pointer lst = car(args);
+ /* it makes no difference in timing to move lst here or below (i.e. lst=car(lst) then return(car(lst)) and so on) */
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caar_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caar_symbol, lst, car_a_list_string);
+ return(caar(lst));
+
+}
+
+static s7_pointer caar_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if ((is_pair(p)) && (is_pair(car(p)))) return(caar(p));
+ if (is_pair(p)) sole_arg_wrong_type_error_nr(sc, sc->caar_symbol, p, car_a_list_string);
+ return(sole_arg_method_or_bust(sc, p, sc->caar_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR]));
+}
+
+
+/* -------- cadr --------*/
+static s7_pointer g_cadr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cadr "(cadr lst) returns (car (cdr lst)): (cadr '(1 2 3)) -> 2"
+ #define Q_cadr sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadr_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadr_symbol, lst, cdr_a_list_string);
+ return(cadr(lst));
+}
+
+static s7_pointer cadr_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if ((is_pair(p)) && (is_pair(cdr(p)))) return(cadr(p));
+ if (is_pair(p)) sole_arg_wrong_type_error_nr(sc, sc->cadr_symbol, p, cdr_a_list_string);
+ return(sole_arg_method_or_bust(sc, p, sc->cadr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR]));
+}
+
+static s7_pointer g_list_ref_at_1(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(method_or_bust(sc, lst, sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1));
+ if (!is_pair(cdr(lst))) out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, cadr(args), it_is_too_large_string);
+ return(cadr(lst));
+}
+
+
+/* -------- cdar -------- */
+static s7_pointer g_cdar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cdar "(cdar lst) returns (cdr (car lst)): (cdar '((1 2 3))) -> '(2 3)"
+ #define Q_cdar sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdar_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdar_symbol, lst, car_a_list_string);
+ return(cdar(lst));
+}
+
+static s7_pointer cdar_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if ((is_pair(p)) && (is_pair(car(p)))) return(cdar(p));
+ if (!is_pair(p)) sole_arg_wrong_type_error_nr(sc, sc->cdar_symbol, p, car_a_list_string);
+ return(sole_arg_method_or_bust(sc, p, sc->cdar_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR]));
+}
+
+
+/* -------- cddr -------- */
+static s7_pointer g_cddr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cddr "(cddr lst) returns (cdr (cdr lst)): (cddr '(1 2 3 4)) -> '(3 4)"
+ #define Q_cddr sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddr_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddr_symbol, lst, cdr_a_list_string);
+ return(cddr(lst));
+}
+
+static s7_pointer cddr_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if ((is_pair(p)) && (is_pair(cdr(p)))) return(cddr(p));
+ if (is_pair(p)) sole_arg_wrong_type_error_nr(sc, sc->cddr_symbol, p, cdr_a_list_string);
+ return(sole_arg_method_or_bust(sc, p, sc->cddr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR]));
+}
+
+/* -------- caaar -------- */
+static s7_pointer caaar_p_p(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaar_symbol, lst, car_a_list_string);
+ if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaar_symbol, lst, caar_a_list_string);
+ if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaar_symbol, lst, caar_a_list_string);
+ return(caaar(lst));
+}
+
+static s7_pointer g_caaar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_caaar "(caaar lst) returns (car (car (car lst))): (caaar '(((1 2)))) -> 1"
+ #define Q_caaar sc->pl_p
+ return(caaar_p_p(sc, car(args)));
+}
+
+/* -------- caadr -------- */
+static s7_pointer caadr_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cadr(p)))) return(caadr(p));
+ if (!is_pair(p)) return(sole_arg_method_or_bust(sc, p, sc->caadr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(p))) sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, p, cdr_a_list_string);
+ sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, p, cadr_a_list_string);
+ return(NULL);
+}
+
+static s7_pointer g_caadr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_caadr "(caadr lst) returns (car (car (cdr lst))): (caadr '(1 (2 3))) -> 2"
+ #define Q_caadr sc->pl_p
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caadr_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, lst, cdr_a_list_string);
+ if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, lst, cadr_a_list_string);
+ return(caadr(lst));
+}
+
+/* -------- cadar -------- */
+static s7_pointer g_cadar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cadar "(cadar lst) returns (car (cdr (car lst))): (cadar '((1 2 3))) -> 2"
+ #define Q_cadar sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadar_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, lst, car_a_list_string);
+ if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, lst, cdar_a_list_string);
+ return(cadar(lst));
+}
+
+static s7_pointer cadar_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if ((is_pair(p)) && (is_pair(car(p))) && (is_pair(cdar(p)))) return(cadar(p));
+ if (!is_pair(p)) return(sole_arg_method_or_bust(sc, p, sc->cadar_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR]));
+ if (!is_pair(car(p))) sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, p, car_a_list_string);
+ sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, p, cdar_a_list_string);
+ return(NULL);
+}
+
+/* -------- cdaar -------- */
+static s7_pointer cdaar_p_p(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaar_symbol, lst, car_a_list_string);
+ if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaar_symbol, lst, caar_a_list_string);
+ return(cdaar(lst));
+}
+
+static s7_pointer g_cdaar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cdaar "(cdaar lst) returns (cdr (car (car lst))): (cdaar '(((1 2 3)))) -> '(2 3)"
+ #define Q_cdaar sc->pl_p
+ return(cdaar_p_p(sc, car(args)));
+}
+
+/* -------- caddr -------- */
+static s7_pointer g_caddr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_caddr "(caddr lst) returns (car (cdr (cdr lst))): (caddr '(1 2 3 4)) -> 3"
+ #define Q_caddr sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caddr_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, lst, cdr_a_list_string);
+ if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, lst, cddr_a_list_string);
+ return(caddr(lst));
+}
+
+static s7_pointer caddr_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if ((is_pair(p)) && (is_pair(cdr(p))) && (is_pair(cddr(p)))) return(caddr(p));
+ if (!is_pair(p)) return(sole_arg_method_or_bust(sc, p, sc->caddr_symbol, set_plist_1(sc, p), sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(p))) sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, p, cdr_a_list_string);
+ sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, p, cddr_a_list_string);
+ return(NULL);
+}
+
+static s7_pointer g_list_ref_at_2(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer lst = car(args);
+ if (!is_pair(lst))
+ return(method_or_bust(sc, lst, sc->list_ref_symbol, args, sc->type_names[T_PAIR], 1));
+ if ((!is_pair(cdr(lst))) || (!is_pair(cddr(lst))))
+ out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, cadr(args), it_is_too_large_string);
+ return(caddr(lst));
+}
+
+
+/* -------- cdddr -------- */
+static s7_pointer cdddr_p_p(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddr_symbol, lst, cdr_a_list_string);
+ if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddr_symbol, lst, cddr_a_list_string);
+ return(cdddr(lst));
+}
+
+static s7_pointer g_cdddr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cdddr "(cdddr lst) returns (cdr (cdr (cdr lst))): (cdddr '(1 2 3 4)) -> '(4)"
+ #define Q_cdddr sc->pl_p
+ return(cdddr_p_p(sc, car(args)));
+}
+
+/* -------- cdadr -------- */
+static s7_pointer cdadr_p_p(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadr_symbol, lst, cdr_a_list_string);
+ if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadr_symbol, lst, cadr_a_list_string);
+ return(cdadr(lst));
+}
+
+static s7_pointer g_cdadr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cdadr "(cdadr lst) returns (cdr (car (cdr lst))): (cdadr '(1 (2 3 4))) -> '(3 4)"
+ #define Q_cdadr sc->pl_p
+ return(cdadr_p_p(sc, car(args)));
+}
+
+/* -------- cddar -------- */
+static s7_pointer cddar_p_p(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddar_symbol, lst, car_a_list_string);
+ if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddar_symbol, lst, cdar_a_list_string);
+ return(cddar(lst));
+}
+
+static s7_pointer g_cddar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cddar "(cddar lst) returns (cdr (cdr (car lst))): (cddar '((1 2 3 4))) -> '(3 4)"
+ #define Q_cddar sc->pl_p
+ return(cddar_p_p(sc, car(args)));
+}
+
+/* -------- caaaar -------- */
+static s7_pointer g_caaaar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_caaaar "(caaaar lst) returns (car (car (car (car lst)))): (caaaar '((((1 2))))) -> 1"
+ #define Q_caaaar sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaaar_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaaar_symbol, lst, car_a_list_string);
+ if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaaar_symbol, lst, caar_a_list_string);
+ if (!is_pair(caaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaaar_symbol, lst, caaar_a_list_string);
+ return(caaaar(lst));
+}
+
+/* -------- caaadr -------- */
+static s7_pointer g_caaadr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_caaadr "(caaadr lst) returns (car (car (car (cdr lst)))): (caaadr '(1 ((2 3)))) -> 2"
+ #define Q_caaadr sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaadr_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaadr_symbol, lst, cdr_a_list_string);
+ if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaadr_symbol, lst, cadr_a_list_string);
+ if (!is_pair(caadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaadr_symbol, lst, caadr_a_list_string);
+ return(caaadr(lst));
+}
+
+/* -------- caadar -------- */
+static s7_pointer g_caadar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_caadar "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2"
+ #define Q_caadar sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caadar_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadar_symbol, lst, car_a_list_string);
+ if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadar_symbol, lst, cdar_a_list_string);
+ if (!is_pair(cadar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caadar_symbol, lst, cadar_a_list_string);
+ return(caadar(lst));
+}
+
+/* -------- cadaar -------- */
+static s7_pointer g_cadaar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cadaar "(cadaar lst) returns (car (cdr (car (car lst)))): (cadaar '(((1 2 3)))) -> 2"
+ #define Q_cadaar sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadaar_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadaar_symbol, lst, car_a_list_string);
+ if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadaar_symbol, lst, caar_a_list_string);
+ if (!is_pair(cdaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadaar_symbol, lst, cdaar_a_list_string);
+ return(cadaar(lst));
+}
+
+/* -------- caaddr -------- */
+
+static s7_pointer caaddr_p_p(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caaddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaddr_symbol, lst, cdr_a_list_string);
+ if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaddr_symbol, lst, cddr_a_list_string);
+ if (!is_pair(caddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->caaddr_symbol, lst, caddr_a_list_string);
+ return(caaddr(lst));
+}
+
+static s7_pointer g_caaddr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_caaddr "(caaddr lst) returns (car (car (cdr (cdr lst)))): (caaddr '(1 2 (3 4))) -> 3"
+ #define Q_caaddr sc->pl_p
+ return(caaddr_p_p(sc, car(args)));
+}
+
+/* -------- cadddr -------- */
+static s7_pointer cadddr_p_p(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadddr_symbol, lst, cdr_a_list_string);
+ if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadddr_symbol, lst, cddr_a_list_string);
+ if (!is_pair(cdddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadddr_symbol, lst, cdddr_a_list_string);
+ return(cadddr(lst));
+}
+
+static s7_pointer g_cadddr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cadddr "(cadddr lst) returns (car (cdr (cdr (cdr lst)))): (cadddr '(1 2 3 4 5)) -> 4"
+ #define Q_cadddr sc->pl_p
+ return(cadddr_p_p(sc, car(args)));
+}
+
+/* -------- cadadr -------- */
+static s7_pointer cadadr_p_p(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadadr_symbol, lst, cdr_a_list_string);
+ if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadadr_symbol, lst, cadr_a_list_string);
+ if (!is_pair(cdadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cadadr_symbol, lst, cdadr_a_list_string);
+ return(cadadr(lst));
+}
+
+static s7_pointer g_cadadr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cadadr "(cadadr lst) returns (car (cdr (car (cdr lst)))): (cadadr '(1 (2 3 4))) -> 3"
+ #define Q_cadadr sc->pl_p
+ return(cadadr_p_p(sc, car(args)));
+}
+
+/* -------- caddar -------- */
+static s7_pointer caddar_p_p(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caddar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddar_symbol, lst, car_a_list_string);
+ if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddar_symbol, lst, cdar_a_list_string);
+ if (!is_pair(cddar(lst))) sole_arg_wrong_type_error_nr(sc, sc->caddar_symbol, lst, cddar_a_list_string);
+ return(caddar(lst));
+}
+
+static s7_pointer g_caddar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_caddar "(caddar lst) returns (car (cdr (cdr (car lst)))): (caddar '((1 2 3 4))) -> 3"
+ #define Q_caddar sc->pl_p
+ return(caddar_p_p(sc, car(args)));
+}
+
+/* -------- cdaaar -------- */
+static s7_pointer g_cdaaar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cdaaar "(cdaaar lst) returns (cdr (car (car (car lst)))): (cdaaar '((((1 2 3))))) -> '(2 3)"
+ #define Q_cdaaar sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaaar_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaaar_symbol, lst, car_a_list_string);
+ if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaaar_symbol, lst, caar_a_list_string);
+ if (!is_pair(caaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaaar_symbol, lst, caaar_a_list_string);
+ return(cdaaar(lst));
+}
+
+/* -------- cdaadr -------- */
+static s7_pointer g_cdaadr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cdaadr "(cdaadr lst) returns (cdr (car (car (cdr lst)))): (cdaadr '(1 ((2 3 4)))) -> '(3 4)"
+ #define Q_cdaadr sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaadr_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaadr_symbol, lst, cdr_a_list_string);
+ if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaadr_symbol, lst, cadr_a_list_string);
+ if (!is_pair(caadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaadr_symbol, lst, caadr_a_list_string);
+ return(cdaadr(lst));
+}
+
+/* -------- cdadar -------- */
+static s7_pointer g_cdadar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cdadar "(cdadar lst) returns (cdr (car (cdr (car lst)))): (cdadar '((1 (2 3 4)))) -> '(3 4)"
+ #define Q_cdadar sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdadar_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadar_symbol, lst, car_a_list_string);
+ if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadar_symbol, lst, cdar_a_list_string);
+ if (!is_pair(cadar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdadar_symbol, lst, cadar_a_list_string);
+ return(cdadar(lst));
+}
+
+/* -------- cddaar -------- */
+static s7_pointer g_cddaar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cddaar "(cddaar lst) returns (cdr (cdr (car (car lst)))): (cddaar '(((1 2 3 4)))) -> '(3 4)"
+ #define Q_cddaar sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddaar_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddaar_symbol, lst, car_a_list_string);
+ if (!is_pair(caar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddaar_symbol, lst, caar_a_list_string);
+ if (!is_pair(cdaar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddaar_symbol, lst, cdaar_a_list_string);
+ return(cddaar(lst));
+}
+
+/* -------- cdaddr -------- */
+static s7_pointer g_cdaddr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cdaddr "(cdaddr lst) returns (cdr (car (cdr (cdr lst)))): (cdaddr '(1 2 (3 4 5))) -> '(4 5)"
+ #define Q_cdaddr sc->pl_p
+
+ s7_pointer lst = car(args);
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdaddr_symbol, args, sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaddr_symbol, lst, cdr_a_list_string);
+ if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaddr_symbol, lst, cddr_a_list_string);
+ if (!is_pair(caddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdaddr_symbol, lst, caddr_a_list_string);
+ return(cdaddr(lst));
+}
+
+/* -------- cddddr -------- */
+
+static s7_pointer cddddr_p_p(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddddr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddddr_symbol, lst, cdr_a_list_string);
+ if (!is_pair(cddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddddr_symbol, lst, cddr_a_list_string);
+ if (!is_pair(cdddr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddddr_symbol, lst, cdddr_a_list_string);
+ return(cddddr(lst));
+}
+
+static s7_pointer g_cddddr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cddddr "(cddddr lst) returns (cdr (cdr (cdr (cdr lst)))): (cddddr '(1 2 3 4 5)) -> '(5)"
+ #define Q_cddddr sc->pl_p
+ return(cddddr_p_p(sc, car(args)));
+}
+
+
+/* -------- cddadr -------- */
+static s7_pointer cddadr_p_p(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cddadr_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
+ if (!is_pair(cdr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddadr_symbol, lst, cdr_a_list_string);
+ if (!is_pair(cadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddadr_symbol, lst, cadr_a_list_string);
+ if (!is_pair(cdadr(lst))) sole_arg_wrong_type_error_nr(sc, sc->cddadr_symbol, lst, cdadr_a_list_string);
+ return(cddadr(lst));
+}
+
+static s7_pointer g_cddadr(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cddadr "(cddadr lst) returns (cdr (cdr (car (cdr lst)))): (cddadr '(1 (2 3 4 5))) -> '(4 5)"
+ #define Q_cddadr sc->pl_p
+ return(cddadr_p_p(sc, car(args)));
+}
+
+
+/* -------- cdddar -------- */
+
+static s7_pointer cdddar_p_p(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cdddar_symbol, set_plist_1(sc, lst), sc->type_names[T_PAIR]));
+ if (!is_pair(car(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddar_symbol, lst, car_a_list_string);
+ if (!is_pair(cdar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddar_symbol, lst, cdar_a_list_string);
+ if (!is_pair(cddar(lst))) sole_arg_wrong_type_error_nr(sc, sc->cdddar_symbol, lst, cddar_a_list_string);
+ return(cdddar(lst));
+}
+
+static s7_pointer g_cdddar(s7_scheme *sc, s7_pointer args)
+{
+ #define H_cdddar "(cdddar lst) returns (cdr (cdr (cdr (car lst)))): (cdddar '((1 2 3 4 5))) -> '(4 5)"
+ #define Q_cdddar sc->pl_p
+ return(cdddar_p_p(sc, car(args)));
+}
+
+/* -------------------------------- assoc assv assq -------------------------------- */
+s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer x)
+{
+ s7_pointer y = x;
+ while (true)
+ {
+ /* we can blithely take the car of anything, since we're not treating it as an object,
+ * then if we get a bogus match, the following check that caar made sense ought to catch it.
+ * if car(#<unspecified>) = #<unspecified> (initialization time), then cdr(nil)->unspec
+ * and subsequent caar(unspec)->unspec so we could forgo half the is_pair checks below.
+ * This breaks if "x" is a dotted list -- the last cdr is not nil, so we lose.
+ */
+ LOOP_8(if ((obj == unchecked_car(car(x))) && (is_pair(car(x)))) 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); /* not reached */
+}
+
+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)));
+}
+
+static s7_pointer g_assq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_assq "(assq obj alist) returns the key-value pair associated (via eq?) with the key obj in the association list alist"
+ #define Q_assq s7_make_signature(sc, 3, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol)
+ return(assq_p_pp(sc, car(args), cadr(args)));
+ /* we don't check for (pair? (car x)) here (or in assv) so we get some inconsistency with assoc:
+ * (assq #f '(#f 2 . 3)) -> #f, (assoc #f '(#f 2 . 3)) -> 'error
+ */
+}
+
+static s7_pointer assv_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ s7_pointer z;
+ if (!is_pair(y))
+ {
+ if (is_null(y)) return(sc->F);
+ return(method_or_bust_pp(sc, y, sc->assv_symbol, x, y, an_association_list_string, 2));
+ }
+ if (is_simple(x))
+ return(s7_assq(sc, x, y));
+
+ z = y;
+ while (true)
+ {
+ /* here we can't play the assq == game because s7_is_eqv thinks it's getting a legit s7 object */
+ if ((is_pair(car(y))) && (s7_is_eqv(sc, x, caar(y)))) return(car(y));
+ y = cdr(y);
+ if (!is_pair(y)) return(sc->F);
+
+ if ((is_pair(car(y))) && (s7_is_eqv(sc, x, caar(y)))) return(car(y));
+ y = cdr(y);
+ if (!is_pair(y)) return(sc->F);
+
+ z = cdr(z);
+ if (z == y) return(sc->F);
+ }
+ return(sc->F); /* not reached */
+}
+
+static s7_pointer g_assv(s7_scheme *sc, s7_pointer args) /* g_assv is called by g_assoc below */
+{
+ #define H_assv "(assv obj alist) returns the key-value pair associated (via eqv?) with the key obj in the association list alist"
+ #define Q_assv Q_assq
+ return(assv_p_pp(sc, car(args), cadr(args)));
+}
+
+s7_pointer s7_assoc(s7_scheme *sc, s7_pointer sym, s7_pointer lst)
+{
+ s7_pointer x, y;
+ if (!is_pair(lst))
+ return(sc->F);
+ x = lst;
+ y = lst;
+ while (true)
+ {
+ if ((is_pair(car(x))) && (s7_is_equal(sc, sym, caar(x)))) return(car(x));
+ x = cdr(x);
+ if (!is_pair(x)) return(sc->F);
+
+ if ((is_pair(car(x))) && (s7_is_equal(sc, sym, caar(x)))) 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);
+}
+
+static s7_pointer assoc_1(s7_scheme *sc, s7_pointer obj, s7_pointer x)
+{
+ s7_pointer y = 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);
+ }
+ return(sc->F);
+ }
+ while (true)
+ {
+ if ((is_pair(car(x))) && (s7_is_equal(sc, obj, caar(x)))) return(car(x));
+ x = cdr(x);
+ if (!is_pair(x)) return(sc->F);
+
+ if ((is_pair(car(x))) && (s7_is_equal(sc, obj, caar(x)))) 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); /* not reached */
+}
+
+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 */
+}
+
+static s7_pointer g_is_eq(s7_scheme *sc, s7_pointer args);
+static s7_pointer g_is_eqv(s7_scheme *sc, s7_pointer args);
+static s7_pfunc s7_bool_optimize(s7_scheme *sc, s7_pointer expr);
+
+static s7_pointer g_assoc(s7_scheme *sc, s7_pointer args)
+{
+ #define H_assoc "(assoc obj alist (func #f)) returns the key-value pair associated (via equal?) with the key obj in the association list alist.\
+If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?"
+ #define Q_assoc s7_make_signature(sc, 4, \
+ s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), \
+ sc->T, sc->is_list_symbol, sc->is_procedure_symbol)
+ s7_pointer x = cadr(args), obj, eq_func = NULL;
+
+ if (!is_null(x))
+ {
+ if (!is_pair(x))
+ 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 */
+ }
+ if (is_pair(cddr(args)))
+ {
+ s7_pointer y;
+ eq_func = caddr(args);
+ /* here we know x is a pair, but need to protect against circular lists */
+ /* 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);
+ }
+ 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);
+ }}}
+
+ /* 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));
+ if (!s7_is_aritable(sc, eq_func, 2))
+ 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));
+ set_opt1_fast(y, x);
+ 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);
+ 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);
+ }
+ return(sc->unspecified);
+ }
+ if (is_null(x)) return(sc->F);
+ obj = car(args);
+ if (is_simple(obj))
+ return(s7_assq(sc, obj, x));
+ return(assoc_1(sc, obj, x));
+}
+
+static s7_pointer assoc_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x)
+{
+ if (!is_pair(x))
+ {
+ if (is_null(x)) return(sc->F);
+ return(method_or_bust(sc, x, sc->assoc_symbol, set_plist_2(sc, obj, x), an_association_list_string, 2));
+ }
+ if (!is_pair(car(x))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, x, an_association_list_string);
+ if (is_simple(obj)) return(s7_assq(sc, obj, x));
+ return(assoc_1(sc, obj, x));
+}
+
+static bool op_assoc_if(s7_scheme *sc)
+{
+ s7_pointer orig_args = car(sc->args);
+ /* code=func, args=(list (list args)) with f/opt1_fast=list, value=result of comparison
+ * (assoc 3 '((1 . a) (2 . b) (3 . c) (4 . d)) =)
+ */
+ if (sc->value != sc->F) /* previous comparison was not #f -- return (car list) */
+ {
+ sc->value = car(opt1_fast(orig_args));
+ return(true);
+ }
+ if (!is_pair(cdr(opt1_fast(orig_args)))) /* (assoc 3 '((1 . 2) . 3) =) or nil */
+ {
+ sc->value = sc->F;
+ return(true);
+ }
+ set_opt1_fast(orig_args, cdr(opt1_fast(orig_args))); /* cdr down arg list */
+
+ if (sc->cur_op == OP_ASSOC_IF1)
+ {
+ /* circular list check */
+ if (opt1_fast(orig_args) == opt2_slow(orig_args))
+ {
+ 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);
+ }
+ else push_stack_direct(sc, OP_ASSOC_IF1);
+
+ if (!is_pair(car(opt1_fast(orig_args)))) /* (assoc 1 '((2 . 2) 3) =) -- we access caaadr below */
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "assoc: second argument is not an alist: ~S", 42), orig_args));
+ /* not sure about this -- we could simply skip the entry both here and in g_assoc
+ * (assoc 1 '((2 . 2) 3)) -> #f
+ * (assoc 1 '((2 . 2) 3) =) -> error currently
+ */
+ if (needs_copied_args(sc->code))
+ sc->args = list_2(sc, caar(orig_args), caar(opt1_fast(orig_args)));
+ else sc->args = set_plist_2(sc, caar(orig_args), caar(opt1_fast(orig_args)));
+ return(false);
+}
+
+static s7_pointer assoc_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if ((args == 3) && (is_normal_symbol(cadddr(expr))))
+ {
+ if (cadddr(expr) == sc->is_eq_symbol) return(global_value(sc->assq_symbol));
+ if (cadddr(expr) == sc->is_eqv_symbol) return(global_value(sc->assv_symbol));
+ }
+ return(f);
+}
+
+
+/* ---------------- member, memv, memq ---------------- */
+s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x)
+{
+ s7_pointer y = x;
+ while (true)
+ {
+ LOOP_4(if (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);
+}
+
+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)));
+}
+
+static s7_pointer g_memq(s7_scheme *sc, s7_pointer args)
+{
+ #define H_memq "(memq obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memq uses eq?"
+ #define Q_memq sc->pl_tl
+
+ s7_pointer x = car(args);
+ s7_pointer y = cadr(args);
+ if (is_pair(y))
+ return(s7_memq(sc, x, y));
+ if (is_null(y))
+ return(sc->F);
+ return(method_or_bust_pp(sc, y, sc->memq_symbol, x, y, a_list_string, 2));
+}
+
+/* I think (memq 'c '(a b . c)) should return #f because otherwise (memq () ...) would return the () at the end */
+/* if memq's list is a quoted list, it won't be changing, so we can tell ahead of time that it is a proper list, and what its length is */
+
+static s7_pointer g_memq_2(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer x = cadr(args);
+ const s7_pointer obj = car(args);
+ if (obj == car(x)) return(x);
+ return((obj == cadr(x)) ? cdr(x) : sc->F);
+}
+
+static s7_pointer memq_2_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x)
+{
+ if (obj == car(x)) return(x);
+ return((obj == cadr(x)) ? cdr(x) : sc->F);
+}
+
+static s7_pointer memq_3_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x)
+{
+ if (obj == car(x)) return(x);
+ if (obj == cadr(x)) return(cdr(x));
+ return((obj == caddr(x)) ? cddr(x) : sc->F);
+}
+
+static s7_pointer g_memq_3(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer x = cadr(args);
+ const s7_pointer obj = car(args);
+ while (true)
+ {
+ if (obj == car(x)) return(x);
+ x = cdr(x);
+ if (obj == car(x)) return(x);
+ x = cdr(x);
+ if (obj == car(x)) return(x);
+ x = cdr(x);
+ if (!is_pair(x)) return(sc->F);
+ }
+ return(sc->F);
+}
+
+static s7_pointer memq_4_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x)
+{
+ while (true)
+ {
+ LOOP_4(if (obj == car(x)) return(x); x = cdr(x));
+ if (!is_pair(x)) return(sc->F);
+ }
+ return(sc->F);
+}
+
+static s7_pointer g_memq_4(s7_scheme *sc, s7_pointer args) {return(memq_4_p_pp(sc, car(args), cadr(args)));}
+
+static s7_pointer g_memq_any(s7_scheme *sc, s7_pointer args)
+{
+ /* no circular list check needed in this case */
+ s7_pointer x = cadr(args);
+ const s7_pointer obj = car(args);
+ while (true)
+ {
+ LOOP_4(if (obj == car(x)) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F));
+ }
+ return(sc->F);
+}
+
+static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr)
+{
+ s7_pointer lst = caddr(expr);
+ if ((is_proper_quote(sc, lst)) &&
+ (is_pair(cadr(lst))))
+ {
+ 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);
+ }}
+ return(f);
+}
+
+static bool numbers_are_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b)
+{
+#if WITH_GMP
+ if ((is_big_number(a)) || (is_big_number(b)))
+ return(big_numbers_are_eqv(sc, a, b));
+ if (type(a) != type(b)) return(false);
+#endif
+ /* if (type(a) != type(b)) return(false); */ /* (eqv? 1 1.0) -> #f! but assume that we've checked types already */
+
+ /* switch is apparently as expensive as 3-4 if's! so this only loses if every call involves complex numbers? */
+ if (is_t_integer(a)) return(integer(a) == integer(b));
+ if (is_t_real(a)) return(real(a) == real(b)); /* NaNs are not equal to anything including themselves */
+ if (is_t_ratio(a)) return((numerator(a) == numerator(b)) && (denominator(a) == denominator(b)));
+ if (!is_t_complex(a)) return(false);
+ return((real_part(a) == real_part(b)) && (imag_part(a) == imag_part(b)));
+}
+
+static s7_pointer memv_number(s7_scheme *sc, s7_pointer obj, s7_pointer x)
+{
+ s7_pointer y = x;
+#if (!WITH_GMP)
+ uint8_t obj_type = type(obj);
+#endif
+ while (true)
+ {
+#if WITH_GMP
+ LOOP_4(if ((is_number(car(x))) && (numbers_are_eqv(sc, obj, car(x)))) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F));
+#else
+ LOOP_4(if ((type(car(x)) == obj_type) && (numbers_are_eqv(sc, obj, car(x)))) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F));
+#endif
+ y = cdr(y);
+ if (x == y) return(sc->F);
+ }
+ return(sc->F);
+}
+
+static s7_pointer memv_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ s7_pointer z;
+ if (!is_pair(y))
+ {
+ if (is_null(y)) return(sc->F);
+ return(method_or_bust_pp(sc, y, sc->memv_symbol, x, y, a_list_string, 2));
+ }
+ if (is_simple(x)) return(s7_memq(sc, x, y));
+ if (is_number(x)) return(memv_number(sc, x, y));
+
+ z = y;
+ while (true)
+ {
+ if (s7_is_eqv(sc, x, car(y))) return(y);
+ y = cdr(y);
+ if (!is_pair(y)) return(sc->F);
+
+ if (s7_is_eqv(sc, x, car(y))) return(y);
+ y = cdr(y);
+ if (!is_pair(y)) return(sc->F);
+
+ z = cdr(z);
+ if (z == y) return(sc->F);
+ }
+ return(sc->F); /* not reached */
+}
+
+static s7_pointer g_memv(s7_scheme *sc, s7_pointer args)
+{
+ #define H_memv "(memv obj list) looks for obj in list and returns the list from that point if it is found, otherwise #f. memv uses eqv?"
+ #define Q_memv sc->pl_tl
+ return(memv_p_pp(sc, car(args), cadr(args)));
+}
+
+
+s7_pointer s7_member(s7_scheme *sc, s7_pointer sym, s7_pointer lst)
+{
+ for (s7_pointer x = lst; is_pair(x); x = cdr(x))
+ if (s7_is_equal(sc, sym, car(x)))
+ return(x);
+ return(sc->F);
+}
+
+static s7_pointer member(s7_scheme *sc, s7_pointer obj, s7_pointer x)
+{
+ s7_pointer y = 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);
+ }
+ 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);
+ }
+ return(sc->F);
+}
+
+static bool p_to_b(opt_info *p);
+
+static s7_pointer g_member(s7_scheme *sc, s7_pointer args)
+{
+ #define H_member "(member obj list (func #f)) looks for obj in list and returns the list from that point if it is found, otherwise #f. \
+member uses equal? If 'func' is a function of 2 arguments, it is used for the comparison instead of 'equal?"
+ #define Q_member s7_make_signature(sc, 4, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T, sc->is_list_symbol, sc->is_procedure_symbol)
+
+ /* this could be extended to accept sequences:
+ * (member #\a "123123abnfc" char=?) -> "abnfc"
+ * (member "abc" "123abc321" string=?) -> "abc321" but there's the string length complication
+ * (member 1 #(0 1 2) =) -> #(1 2) etc but what would it do for a hash-table?
+ * the third arg can be weird: (member #f (list #t) cons) -> (#t) -- cons returns '(#f . #t) which is true, so we get '(#t)
+ * should this be an error: (member '(1 2 3) () '(1 . 2)) -- the third arg is bogus, but the second is nil
+ *
+ * here as in assoc, sort, and make-hash-table we accept macros, but I can't think of a good reason to do so.
+ */
+ s7_pointer x = cadr(args), obj;
+
+ if ((!is_pair(x)) && (!is_null(x)))
+ return(method_or_bust(sc, x, sc->member_symbol, args, a_list_string, 2));
+
+ if (is_not_null(cddr(args)))
+ {
+ 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);
+ }
+
+ 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);
+ }}
+ if (type(eq_func) < T_CONTINUATION)
+ 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);
+ 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) */
+ set_opt1_fast(y, x);
+ 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);
+ 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);
+ }
+ return(sc->unspecified);
+ }
+ if (is_null(x)) return(sc->F);
+ obj = car(args);
+ if (is_simple(obj))
+ return(s7_memq(sc, obj, x));
+ /* the only things that aren't simply == here are c_object, string, number, vector, hash-table, pair, and c_pointer, but all the other cases are unlikely */
+ if (is_number(obj))
+ return(memv_number(sc, obj, x));
+ return(member(sc, obj, x));
+}
+
+static s7_pointer member_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer x)
+{
+ if (is_null(x)) return(sc->F);
+ if (!is_pair(x)) return(method_or_bust(sc, x, sc->member_symbol, set_plist_2(sc, obj, x), a_list_string, 2));
+ if (is_simple(obj)) return(s7_memq(sc, obj, x));
+ if (is_number(obj)) return(memv_number(sc, obj, x));
+ return(member(sc, obj, x));
+}
+
+static s7_pointer member_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if ((args == 3) && (is_normal_symbol(cadddr(expr))))
+ {
+ if (cadddr(expr) == sc->is_eq_symbol) return(memq_chooser(sc, global_value(sc->memq_symbol), 2, expr));
+ if (cadddr(expr) == sc->is_eqv_symbol) return(global_value(sc->memv_symbol));
+ }
+ return(f);
+}
+
+static bool op_member_if(s7_scheme *sc)
+{
+ s7_pointer orig_args = car(sc->args);
+ /* code=func, args = (list (list original args)) with opt1_fast->position in cadr (the list),
+ * the extra indirection (list (list...)) is needed because call/cc copies arg lists
+ * value = result of comparison
+ */
+ if (sc->value != sc->F) /* previous comparison was not #f -- return list */
+ {
+ sc->value = opt1_fast(orig_args);
+ return(true);
+ }
+ if (!is_pair(cdr(opt1_fast(orig_args)))) /* no more args -- return #f */
+ {
+ sc->value = sc->F;
+ return(true);
+ }
+ set_opt1_fast(orig_args, cdr(opt1_fast(orig_args))); /* cdr down arg list */
+
+ if (sc->cur_op == OP_MEMBER_IF1)
+ {
+ /* circular list check */
+ if (opt1_fast(orig_args) == opt2_slow(orig_args))
+ {
+ 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);
+ }
+ else push_stack_direct(sc, OP_MEMBER_IF1);
+
+ if (needs_copied_args(sc->code))
+ sc->args = list_2(sc, caar(orig_args), car(opt1_fast(orig_args)));
+ else sc->args = set_plist_2(sc, caar(orig_args), car(opt1_fast(orig_args)));
+ return(false);
+}
+
+
+/* -------------------------------- list -------------------------------- */
+static s7_pointer g_list(s7_scheme *sc, s7_pointer args)
+{
+ #define H_list "(list ...) returns its arguments in a list"
+ #define Q_list s7_make_circular_signature(sc, 1, 2, sc->is_proper_list_symbol, sc->T)
+ return(copy_proper_list(sc, args));
+}
+
+static s7_pointer g_list_0(s7_scheme *sc, s7_pointer args) {return(sc->nil);}
+static s7_pointer g_list_1(s7_scheme *sc, s7_pointer args) {return(list_1(sc, car(args)));}
+static s7_pointer g_list_2(s7_scheme *sc, s7_pointer args) {return(list_2(sc, car(args), cadr(args)));}
+static s7_pointer g_list_3(s7_scheme *sc, s7_pointer args) {return(list_3(sc, car(args), cadr(args), caddr(args)));}
+static s7_pointer g_list_4(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p = cddr(args);
+ return(list_4(sc, car(args), cadr(args), car(p), cadr(p)));
+}
+
+static s7_pointer list_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ if (args == 0) return(sc->list_0);
+ if (args == 1) return(sc->list_1);
+ if (args == 2) return(sc->list_2);
+ if (args == 3) return(sc->list_3);
+ return((args == 4) ? sc->list_4 : f);
+}
+
+static s7_pointer list_p_p(s7_scheme *sc, s7_pointer p1) {return(list_1(sc, sc->value = p1));}
+static s7_pointer list_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) {return(list_2(sc, p1, p2));}
+static s7_pointer list_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) {return(list_3(sc, p1, p2, p3));}
+/* if the GC sees a free cell here, protect it in the caller, not here, but sometimes the GC is called here! */
+
+static void check_list_validity(s7_scheme *sc, const char *caller, s7_pointer lst)
+{
+ s7_pointer p = lst;
+ 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));
+ }
+}
+
+s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...)
+{
+ va_list ap;
+ s7_pointer p;
+ if (num_values == 0)
+ return(sc->nil);
+ sc->w = make_list(sc, num_values, sc->unused);
+ p = sc->w;
+ va_start(ap, num_values);
+ for (s7_int i = 0; i < num_values; i++, p = cdr(p))
+ set_car(p, va_arg(ap, s7_pointer));
+ va_end(ap);
+ if (sc->safety > NO_SAFETY)
+ check_list_validity(sc, __func__, sc->w);
+ p = sc->w;
+ sc->w = sc->unused;
+ return(p);
+}
+
+s7_pointer s7_list_nl(s7_scheme *sc, s7_int num_values, ...) /* arglist should be NULL terminated */
+{
+ s7_int i = 0;
+ va_list ap;
+ s7_pointer p;
+
+ if (num_values == 0)
+ return(sc->nil);
+
+ sc->w = make_list(sc, num_values, sc->unused);
+ va_start(ap, num_values);
+ for (s7_pointer q = sc->w; i < num_values; i++, q = cdr(q))
+ {
+ 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 */
+ }
+ set_car(q, p);
+ }
+ p = va_arg(ap, s7_pointer);
+ va_end(ap);
+ if (p) wrong_number_of_arguments_error_nr(sc, "too many arguments for s7_list_nl: ~S", 37, sc->w);
+
+ if (sc->safety > NO_SAFETY)
+ check_list_validity(sc, __func__, sc->w);
+
+ p = sc->w;
+ sc->w = sc->unused;
+ return(p);
+}
+
+static s7_pointer safe_list_1(s7_scheme *sc)
+{
+ if (!list_is_in_use(sc->safe_lists[1]))
+ {
+ sc->current_safe_list = 1;
+ set_list_in_use(sc->safe_lists[1]);
+#if S7_DEBUGGING
+ sc->safe_list_uses[1]++;
+#endif
+ return(sc->safe_lists[1]);
+ }
+ return(cons(sc, sc->nil, sc->nil));
+}
+
+static s7_pointer safe_list_2(s7_scheme *sc)
+{
+ if (!list_is_in_use(sc->safe_lists[2]))
+ {
+ sc->current_safe_list = 2;
+ set_list_in_use(sc->safe_lists[2]);
+#if S7_DEBUGGING
+ sc->safe_list_uses[2]++;
+#endif
+ return(sc->safe_lists[2]);
+ }
+ return(cons_unchecked(sc, sc->nil, list_1(sc, sc->nil)));
+}
+
+static s7_pointer make_safe_list(s7_scheme *sc, s7_int num_args)
+{
+ if (num_args < NUM_SAFE_LISTS)
+ {
+ sc->current_safe_list = num_args;
+ if (!is_pair(sc->safe_lists[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]);
+#if S7_DEBUGGING
+ sc->safe_list_uses[num_args]++;
+#endif
+ return(sc->safe_lists[num_args]);
+ }}
+ return(make_big_list(sc, num_args, sc->nil));
+}
+
+static inline s7_pointer safe_list_if_possible(s7_scheme *sc, s7_int num_args)
+{
+ if ((num_args < NUM_SAFE_PRELISTS) &&
+ (!list_is_in_use(sc->safe_lists[num_args])))
+ {
+ sc->current_safe_list = num_args;
+ set_list_in_use(sc->safe_lists[num_args]);
+#if S7_DEBUGGING
+ sc->safe_list_uses[num_args]++;
+#endif
+ return(sc->safe_lists[num_args]);
+ }
+ return(make_safe_list(sc, num_args));
+}
+
+static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer tp = sc->nil, np = NULL, pp;
+
+ /* we know here that car(args) is a list and cdr(args) is not nil; this function does not check sc->max_list_length; called only in g_append */
+ gc_protect_via_stack(sc, args);
+ for (s7_pointer y = args; is_pair(y); y = cdr(y)) /* arglist so not dotted */
+ {
+ 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)));
+ }
+ 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_sequence(p))
+ {
+ 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);
+ }}}}
+ unstack_gc_protect(sc);
+ return(tp);
+}
+
+static s7_pointer append_in_place(s7_scheme *sc, s7_pointer a, s7_pointer b)
+{
+ /* tack b onto the end of a without copying either -- 'a' is changed! */
+ s7_pointer p;
+ if (is_null(a)) return(b);
+ p = a;
+ while (is_not_null(cdr(p))) p = cdr(p);
+ set_cdr(p, b);
+ return(a);
+}
+
+
+/* -------------------------------- vectors -------------------------------- */
+bool s7_is_vector(s7_pointer p) {return(is_any_vector(p));}
+bool s7_is_float_vector(s7_pointer p) {return(is_float_vector(p));}
+bool s7_is_int_vector(s7_pointer p) {return(is_int_vector(p));}
+bool s7_is_byte_vector(s7_pointer p) {return(is_byte_vector(p));}
+
+static bool is_byte_vector_b_p(s7_pointer b) {return(is_byte_vector(b));}
+
+s7_int s7_vector_length(s7_pointer vec) {return(vector_length(vec));}
+
+static s7_pointer t_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val)
+{
+ vector_element(vec, loc) = val;
+ return(val);
+}
+
+static s7_pointer typed_vector_typer_symbol(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer typer = typed_vector_typer(p);
+ return((is_c_function(typer)) ? c_function_symbol(typer) : find_closure(sc, typer, closure_let(typer)));
+}
+
+static const char *typed_vector_typer_name(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer typer = typed_vector_typer(p);
+ return((is_c_function(typer)) ? c_function_name(typer) : symbol_name(typed_vector_typer_symbol(sc, p)));
+}
+
+static void port_write_vector_typer(s7_scheme *sc, s7_pointer vect, s7_pointer port)
+{
+ const char *setter = make_type_name(sc, typed_vector_typer_name(sc, vect), NO_ARTICLE);
+ port_write_string(port)(sc, setter, safe_strlen(setter), port);
+}
+
+static noreturn void typed_vector_type_error_nr(s7_scheme *sc, s7_pointer vec, s7_pointer val)
+{
+ 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))));
+}
+
+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 */
+{
+ if ((sc->safety >= NO_SAFETY) &&
+ (typed_vector_typer_call(sc, vec, set_plist_1(sc, val)) == sc->F))
+ typed_vector_type_error_nr(sc, vec, val);
+ vector_element(vec, loc) = val;
+ return(val);
+}
+
+static s7_pointer t_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(vector_element(vec, loc));}
+static s7_pointer int_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(make_integer(sc, int_vector(vec, loc)));}
+static s7_pointer float_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(make_real(sc, float_vector(vec, loc)));}
+static s7_pointer byte_vector_getter(s7_scheme *sc, s7_pointer bv, s7_int loc) {return(small_int(byte_vector(bv, loc)));}
+
+static s7_pointer int_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val)
+{
+ if (s7_is_integer(val))
+ int_vector(vec, loc) = s7_integer_clamped_if_gmp(sc, val);
+ else wrong_type_error_nr(sc, sc->int_vector_set_symbol, 3, val, sc->type_names[T_INTEGER]);
+ return(val);
+}
+
+static s7_pointer float_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val)
+{
+ float_vector(vec, loc) = real_to_double(sc, val, "float-vector-set!");
+ return(val);
+}
+
+static s7_pointer byte_vector_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_pointer val)
+{
+ s7_int byte;
+ if (!s7_is_integer(val))
+ wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, val, sc->type_names[T_INTEGER]);
+ byte = s7_integer_clamped_if_gmp(sc, val);
+ if ((byte < 0) || (byte >= 256))
+ wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, val, wrap_string(sc, "a byte", 6));
+ byte_vector(str, loc) = (uint8_t)byte;
+ return(val);
+}
+
+static block_t *mallocate_empty_block(s7_scheme *sc)
+{
+ block_t *b;
+ b = mallocate_block(sc);
+ block_data(b) = NULL;
+ block_info(b) = NULL;
+ return(b);
+}
+
+#define mallocate_vector(Sc, Len) ((Len) > 0) ? inline_mallocate(Sc, Len) : mallocate_empty_block(Sc)
+
+static inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */
+{
+ s7_pointer x;
+ block_t *b = mallocate_vector(sc, len * sizeof(s7_pointer));
+ new_cell(sc, x, T_VECTOR | T_SAFE_PROCEDURE);
+ vector_length(x) = len;
+ vector_block(x) = b;
+ vector_elements(x) = (s7_pointer *)block_data(b);
+ vector_set_dimension_info(x, NULL);
+ vector_getter(x) = t_vector_getter;
+ vector_setter(x) = t_vector_setter;
+ add_vector(sc, x);
+ return(x);
+}
+
+static inline s7_pointer make_simple_float_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */
+{
+ s7_pointer x;
+ block_t *b = mallocate_vector(sc, len * sizeof(s7_double));
+ new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE);
+ vector_length(x) = len;
+ vector_block(x) = b;
+ float_vector_floats(x) = (s7_double *)block_data(b);
+ vector_set_dimension_info(x, NULL);
+ vector_getter(x) = float_vector_getter;
+ vector_setter(x) = float_vector_setter;
+ add_vector(sc, x);
+ return(x);
+}
+
+static inline s7_pointer make_simple_int_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */
+{
+ s7_pointer x;
+ block_t *b = mallocate_vector(sc, len * sizeof(s7_int));
+ new_cell(sc, x, T_INT_VECTOR | T_SAFE_PROCEDURE);
+ vector_length(x) = len;
+ vector_block(x) = b;
+ int_vector_ints(x) = (s7_int *)block_data(b);
+ vector_set_dimension_info(x, NULL);
+ vector_getter(x) = int_vector_getter;
+ vector_setter(x) = int_vector_setter;
+ add_vector(sc, x);
+ return(x);
+}
+
+static s7_pointer make_simple_byte_vector(s7_scheme *sc, s7_int len)
+{
+ s7_pointer x;
+ block_t *b = inline_mallocate(sc, len);
+ new_cell(sc, x, T_BYTE_VECTOR | T_SAFE_PROCEDURE);
+ vector_block(x) = b;
+ byte_vector_bytes(x) = (uint8_t *)block_data(b);
+ vector_length(x) = len;
+ vector_set_dimension_info(x, NULL);
+ vector_getter(x) = byte_vector_getter;
+ vector_setter(x) = byte_vector_setter;
+ add_vector(sc, x);
+ return(x);
+}
+
+static Vectorized void t_vector_fill(s7_pointer vec, s7_pointer obj)
+{
+ s7_pointer *orig = vector_elements(vec);
+ s7_int len = vector_length(vec), i, left;
+ if (len == 0) return;
+ /* splitting out this part made no difference in speed; type check of obj is handled elsewhere */
+ left = len - 8;
+ i = 0;
+ while (i <= left)
+ LOOP_8(orig[i++] = obj);
+ for (; i < len; i++)
+ orig[i] = obj;
+}
+
+static s7_pointer make_vector_1(s7_scheme *sc, s7_int len, bool filled, uint8_t typ)
+{
+ s7_pointer x;
+
+ if (len < 0)
+ 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)));
+
+ /* 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);
+ vector_length(x) = len;
+ if (len == 0)
+ {
+ vector_block(x) = mallocate_empty_block(sc);
+ any_vector_elements(x) = NULL;
+ if (typ == T_VECTOR) set_has_simple_elements(x);
+ }
+ 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);
+ }
+ 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;
+ }
+ 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);
+ }}
+ vector_set_dimension_info(x, NULL);
+ return(x);
+}
+
+#define FILLED true
+#define NOT_FILLED false
+
+s7_pointer s7_make_vector(s7_scheme *sc, s7_int len)
+{
+ s7_pointer v = make_vector_1(sc, len, FILLED, T_VECTOR);
+ add_vector(sc, v);
+ return(v);
+}
+
+s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill)
+{
+ s7_pointer vect = make_simple_vector(sc, len);
+ t_vector_fill(vect, fill);
+ return(vect);
+}
+
+static vdims_t *make_wrap_only(s7_scheme *sc) /* this makes sc->wrap_only */
+{
+ vdims_t *v = (vdims_t *)mallocate_block(sc);
+ vdims_original(v) = sc->F;
+ vector_elements_should_be_freed(v) = false;
+ vdims_rank(v) = 1;
+ vdims_dims(v) = NULL;
+ vdims_offsets(v) = NULL;
+ return(v);
+}
+
+static vdims_t *make_vdims(s7_scheme *sc, bool elements_should_be_freed, s7_int dims, const s7_int *dim_info)
+{
+ vdims_t *v;
+ if ((dims == 1) && (!elements_should_be_freed))
+ return(sc->wrap_only);
+
+ if (dims > 1)
+ {
+ s7_int offset = 1;
+ v = (vdims_t *)mallocate(sc, dims * 2 * sizeof(s7_int));
+ vdims_original(v) = sc->F;
+ vector_elements_should_be_freed(v) = elements_should_be_freed;
+ 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];
+ for (s7_int i = dims - 1; i >= 0; i--)
+ {
+ vdims_offsets(v)[i] = offset;
+ offset *= vdims_dims(v)[i];
+ }
+ return(v);
+ }
+ v = (vdims_t *)mallocate_block(sc);
+ vdims_original(v) = sc->F;
+ vector_elements_should_be_freed(v) = elements_should_be_freed;
+ vdims_rank(v) = 1;
+ vdims_dims(v) = NULL;
+ vdims_offsets(v) = NULL;
+ return(v);
+}
+
+static s7_pointer make_any_vector(s7_scheme *sc, int32_t type, s7_int len, s7_int dims, const s7_int *dim_info)
+{
+ const s7_pointer p = make_vector_1(sc, len, FILLED, type);
+ if (dim_info)
+ {
+ vector_set_dimension_info(p, make_vdims(sc, false, dims, dim_info));
+ add_multivector(sc, p);
+ }
+ else add_vector(sc, p);
+ return(p);
+}
+
+s7_pointer s7_make_int_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_INT_VECTOR, len, dims, dim_info));}
+s7_pointer s7_make_byte_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_BYTE_VECTOR, len, dims, dim_info));}
+s7_pointer s7_make_float_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_FLOAT_VECTOR, len, dims, dim_info));}
+s7_pointer s7_make_normal_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_VECTOR, len, dims, dim_info));}
+
+s7_pointer s7_make_float_vector_wrapper(s7_scheme *sc, s7_int len, s7_double *data, s7_int dims, s7_int *dim_info, bool free_data)
+{
+ /* this wraps up a C-allocated/freed double array as an s7 vector */
+ s7_pointer x;
+ block_t *b = mallocate_empty_block(sc);
+ new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE);
+ vector_block(x) = b;
+ float_vector_floats(x) = data;
+ vector_getter(x) = float_vector_getter;
+ vector_setter(x) = float_vector_setter;
+ vector_length(x) = len;
+ if (!dim_info)
+ {
+ s7_int di[1];
+ di[0] = len;
+ vector_set_dimension_info(x, make_vdims(sc, free_data, 1, di));
+ }
+ else vector_set_dimension_info(x, make_vdims(sc, free_data, dims, dim_info));
+ add_multivector(sc, x);
+ return(x);
+}
+
+
+/* -------------------------------- vector-fill! -------------------------------- */
+static Vectorized void float_vector_fill(s7_pointer vec, s7_double x)
+{
+ s7_int len = vector_length(vec);
+ if (len == 0) return;
+ if (x == 0.0)
+ {
+ if (STEP_8(len))
+ memclr64((void *)float_vector_floats(vec), len * sizeof(s7_double));
+ else memclr((void *)float_vector_floats(vec), len * sizeof(s7_double));
+ }
+ else
+ {
+ s7_int i = 0, left = len - 8;
+ s7_double *orig = float_vector_floats(vec);
+ while (i <= left)
+ LOOP_8(orig[i++] = x);
+ for (; i < len; i++)
+ orig[i] = x;
+ }
+}
+
+static Vectorized void int_vector_fill(s7_pointer vec, s7_int k)
+{
+ s7_int len = vector_length(vec);
+ if (len == 0) return;
+ if (k == 0)
+ {
+ if (STEP_8(len))
+ memclr64((void *)int_vector_ints(vec), len * sizeof(s7_int));
+ else memclr((void *)int_vector_ints(vec), len * sizeof(s7_int));
+ }
+ else
+ {
+ s7_int i = 0, left = len - 8;
+ s7_int *orig = int_vector_ints(vec);
+ while (i <= left)
+ LOOP_8(orig[i++] = k);
+ for (; i < len; i++)
+ orig[i] = k;
+ }
+}
+
+static void byte_vector_fill(s7_pointer vec, uint8_t byte)
+{
+ s7_int len = vector_length(vec);
+ if (len == 0) return;
+ if (byte > 0)
+ local_memset((void *)(byte_vector_bytes(vec)), byte, len);
+ else /* byte == 0 */
+ if (STEP_64(len))
+ memclr64((void *)(byte_vector_bytes(vec)), len);
+ else memclr((void *)(byte_vector_bytes(vec)), len);
+}
+
+void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj)
+{
+ switch (type(vec))
+ {
+ 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]);
+ 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]);
+ 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));
+ byte_vector_fill(vec, (uint8_t)s7_integer_clamped_if_gmp(sc, obj));
+ break;
+ case T_VECTOR:
+ default:
+ t_vector_fill(vec, obj);
+ }
+}
+
+static s7_pointer g_vector_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer args)
+{
+ s7_pointer x = car(args), fill;
+ s7_int start = 0, end;
+
+ if (!is_any_vector(x))
+ {
+ check_method(sc, x, sc->vector_fill_symbol, args);
+ /* not two_methods (and fill!) here else we get stuff like:
+ * (let ((e (openlet (inlet 'fill! (lambda (obj val) (string-fill! (obj 'value) val)) 'value "01234")))) (vector-fill! e #\a) (e 'value)) -> "aaaaa"
+ */
+ wrong_type_error_nr(sc, caller, 1, x, sc->type_names[T_VECTOR]);
+ }
+ if (is_immutable_vector(x))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, x));
+
+ fill = cadr(args);
+
+ if ((is_typed_t_vector(x)) &&
+ (typed_vector_typer_call(sc, x, set_plist_1(sc, fill)) == sc->F))
+ {
+ const char *tstr = make_type_name(sc, typed_vector_typer_name(sc, x), INDEFINITE_ARTICLE);
+ wrong_type_error_nr(sc, wrap_string(sc, "vector fill!", 12), 2, fill, wrap_string(sc, tstr, safe_strlen(tstr)));
+ }
+ 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));
+ }
+ 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));
+ }
+ end = vector_length(x);
+ if (!is_null(cddr(args)))
+ {
+ s7_pointer p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end);
+ if (p != sc->unused) return(p);
+ if (start == end) return(fill);
+ }
+ if (end == 0) return(fill);
+
+ if ((start == 0) && (end == vector_length(x)))
+ s7_vector_fill(sc, x, fill);
+ else
+ if (is_t_vector(x))
+ 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;
+ }
+ 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);
+ }
+ return(fill);
+}
+
+#if (!WITH_PURE_S7)
+/* -------------------------------- vector-fill! -------------------------------- */
+static s7_pointer g_vector_fill(s7_scheme *sc, s7_pointer args)
+{
+ #define H_vector_fill "(vector-fill! v val start end) sets all elements of the vector v between start and end to val"
+ #define Q_vector_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->T, sc->is_integer_symbol)
+ return(g_vector_fill_1(sc, sc->vector_fill_symbol, args));
+}
+
+/* -------------------------------- vector-append -------------------------------- */
+static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_pointer caller);
+static s7_pointer copy_source_no_dest(s7_scheme *sc, s7_pointer source, s7_pointer args);
+
+static s7_pointer g_vector_append(s7_scheme *sc, s7_pointer args)
+{
+ /* returns a one-dimensional vector. To handle multidimensional vectors, we'd need to
+ * ensure all the dimensional data matches (rank, size of each dimension except the last etc),
+ * which is too much trouble.
+ */
+ #define H_vector_append "(vector-append . vectors) returns a new (1-dimensional) vector containing the elements of its vector arguments."
+ #define Q_vector_append sc->pcl_v
+
+ s7_pointer p = args;
+ if (is_null(args))
+ return(make_simple_vector(sc, 0));
+
+ if ((is_null(cdr(args))) &&
+ (is_any_vector(car(args))))
+ return(copy_source_no_dest(sc, car(args), args));
+
+ for (int32_t i = 0; is_pair(p); p = cdr(p), i++)
+ {
+ 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]);
+ }}
+ return(vector_append(sc, args, type(car(args)), sc->vector_append_symbol));
+}
+
+static s7_pointer vector_append_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ s7_pointer val;
+ sc->temp7 = list_2(sc, p1, p2); /* ideally this list would be stack_protected, avoiding temp7 (method call above) */
+ val = g_vector_append(sc, sc->temp7);
+ sc->temp7 = sc->unused;
+ return(val);
+}
+
+static s7_pointer vector_append_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3)
+{
+ s7_pointer val;
+ sc->temp7 = list_3(sc, p1, p2, p3);
+ val = g_vector_append(sc, sc->temp7);
+ sc->temp7 = sc->unused;
+ return(val);
+}
+#endif
+
+
+/* -------------------------------- vector-ref|set! -------------------------------- */
+s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_int index)
+{
+ if (index >= vector_length(vec))
+ out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string);
+ return(vector_getter(vec)(sc, vec, index));
+}
+
+s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer a)
+{
+ if (index >= vector_length(vec))
+ out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string);
+ if (is_typed_vector(vec))
+ return(typed_vector_setter(sc, vec, index, a));
+ vector_setter(vec)(sc, vec, index, T_Ext(a));
+ return(a);
+}
+
+s7_pointer *s7_vector_elements(s7_pointer vec) {return(vector_elements(vec));}
+
+/* these are for s7.h */
+s7_int *s7_int_vector_elements(s7_pointer vec) {return(int_vector_ints(vec));}
+s7_int s7_int_vector_ref(s7_pointer vec, s7_int index) {return(int_vector(vec, index));}
+s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value) {int_vector(vec, index) = value; return(value);}
+
+uint8_t *s7_byte_vector_elements(s7_pointer vec) {return(byte_vector_bytes(vec));}
+uint8_t s7_byte_vector_ref(s7_pointer vec, s7_int index) {return(byte_vector(vec, index));}
+uint8_t s7_byte_vector_set(s7_pointer vec, s7_int index, uint8_t value) {byte_vector(vec, index) = value; return(value);}
+
+s7_double *s7_float_vector_elements(s7_pointer vec) {return(float_vector_floats(vec));}
+s7_double s7_float_vector_ref(s7_pointer vec, s7_int index) {return(float_vector(vec, index));}
+s7_double s7_float_vector_set(s7_pointer vec, s7_int index, s7_double value) {float_vector(vec, index) = value; return(value);}
+
+s7_int s7_vector_dimensions(s7_pointer vec, s7_int *dims, s7_int dims_size)
+{
+ if (dims_size <= 0) return(0);
+ if (vector_dimension_info(vec))
+ {
+ 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);
+ return(lim);
+ }
+ dims[0] = vector_length(vec);
+ return(1);
+}
+
+s7_int s7_vector_dimension(s7_pointer vec, s7_int dim)
+{
+ if (vector_dimension_info(vec))
+ return(vector_dimension(vec, dim));
+ return((dim == 0) ? vector_length(vec) : -1);
+}
+
+s7_int s7_vector_offsets(s7_pointer vec, s7_int *offs, s7_int offs_size)
+{
+ if (offs_size <= 0) return(0);
+ if (vector_dimension_info(vec))
+ {
+ 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);
+ return(lim);
+ }
+ offs[0] = 1;
+ return(1);
+}
+
+
+static s7_int flatten_multivector_indices(s7_scheme *sc, s7_pointer vector, s7_int indices, va_list ap)
+{
+ s7_int index, rank = vector_rank(vector);
+ if (rank != indices)
+ {
+ va_end(ap);
+ wrong_number_of_arguments_error_nr(sc, "s7_vector_ref_n: wrong number of indices: ~A", 44, wrap_integer(sc, indices));
+ }
+ if (rank == 1)
+ index = va_arg(ap, s7_int);
+ else
+ {
+ s7_int 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]);
+ }}
+ va_end(ap);
+ return(index);
+}
+
+s7_pointer s7_vector_ref_n(s7_scheme *sc, s7_pointer vector, s7_int indices, ...)
+{
+ s7_int index;
+ va_list ap;
+ va_start(ap, indices);
+ index = flatten_multivector_indices(sc, vector, indices, ap);
+ return(vector_getter(vector)(sc, vector, index));
+}
+
+s7_pointer s7_vector_set_n(s7_scheme *sc, s7_pointer vector, s7_pointer value, s7_int indices, ...)
+{
+ s7_int index;
+ va_list ap;
+ va_start(ap, indices);
+ index = flatten_multivector_indices(sc, vector, indices, ap);
+ if (is_typed_vector(vector))
+ return(typed_vector_setter(sc, vector, index, value));
+ return(vector_setter(vector)(sc, vector, index, value));
+}
+
+
+/* -------------------------------- vector->list -------------------------------- */
+s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect)
+{
+ s7_int len = vector_length(vect);
+ s7_pointer result;
+ if (len == 0) return(sc->nil);
+ init_temp(sc->y, sc->nil);
+ gc_protect_via_stack(sc, vect);
+ switch (type(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);
+ 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);
+ 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);
+ 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);
+ break;
+ }
+ unstack_gc_protect(sc);
+ result = sc->y;
+ sc->y = sc->unused;
+ return(result);
+}
+
+s7_pointer s7_array_to_list(s7_scheme *sc, s7_int num_values, s7_pointer *array)
+{
+ s7_pointer result;
+ if (num_values == 0) return(sc->nil);
+ init_temp(sc->y, sc->nil);
+ check_free_heap_size(sc, num_values);
+ for (s7_int i = num_values - 1; i >= 0; i--)
+ sc->y = cons_unchecked(sc, array[i], sc->y);
+ result = sc->y;
+ if (sc->safety > NO_SAFETY)
+ check_list_validity(sc, __func__, result);
+ sc->y = sc->unused;
+ return(result);
+}
+
+#if (!WITH_PURE_S7)
+static s7_pointer g_vector_to_list(s7_scheme *sc, s7_pointer args)
+{
+ #define H_vector_to_list "(vector->list v (start 0) end) returns the elements of the vector v as a list; (map values v)"
+ #define Q_vector_to_list s7_make_signature(sc, 4, sc->is_proper_list_symbol, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_symbol)
+
+ s7_int i, start = 0, end;
+ s7_pointer p, vec = car(args);
+ if (!is_any_vector(vec))
+ return(sole_arg_method_or_bust(sc, vec, sc->vector_to_list_symbol, args, sc->type_names[T_VECTOR]));
+
+ end = vector_length(vec);
+ if (!is_null(cdr(args)))
+ {
+ p = start_and_end(sc, sc->vector_to_list_symbol, args, 2, cdr(args), &start, &end);
+ if (p != sc->unused) return(p);
+ if (start == end) 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, "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;
+ gc_protect_via_stack(sc, vec);
+ if (is_t_vector(vec))
+ for (i = end - 1; i >= start; i--) sc->w = cons_unchecked(sc, vector_element(vec, i), sc->w);
+ else for (i = end - 1; i >= start; i--) sc->w = cons_unchecked(sc, vector_getter(vec)(sc, vec, i), sc->w);
+ unstack_gc_protect(sc);
+ p = sc->w;
+ sc->w = sc->unused;
+ return(p);
+}
+
+static s7_pointer vector_to_list_p_p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_any_vector(p))
+ return(method_or_bust_p(sc, p, sc->vector_to_list_symbol, sc->type_names[T_VECTOR]));
+ return(s7_vector_to_list(sc, p));
+}
+#endif
+
+
+/* -------------------------------- string->byte-vector -------------------------------- */
+static s7_pointer g_string_to_byte_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_string_to_byte_vector "(string->byte-vector obj) turns a string into a byte-vector."
+ #define Q_string_to_byte_vector s7_make_signature(sc, 2, sc->is_byte_vector_symbol, sc->is_string_symbol)
+ s7_pointer str = car(args);
+ if (!is_string(str))
+ 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)));
+ return(s7_copy_1(sc, sc->string_to_byte_vector_symbol, set_plist_2(sc, str, make_simple_byte_vector(sc, string_length(str)))));
+}
+
+
+/* -------------------------------- byte-vector->string -------------------------------- */
+static s7_pointer g_byte_vector_to_string(s7_scheme *sc, s7_pointer args)
+{
+ #define H_byte_vector_to_string "(byte-vector->string obj) turns a byte-vector into a string."
+ #define Q_byte_vector_to_string s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_byte_vector_symbol)
+ s7_pointer v = car(args);
+ if (!is_byte_vector(v))
+ 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)));
+ 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))));
+}
+
+
+/* -------------------------------- vector -------------------------------- */
+static s7_pointer g_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_vector "(vector ...) returns a vector whose elements are the arguments"
+ #define Q_vector s7_make_circular_signature(sc, 1, 2, sc->is_vector_symbol, sc->T)
+
+ s7_pointer vec, b;
+ s7_int len = proper_list_length_with_end(args, &b);
+ if (!is_null(b))
+ 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)));
+ 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);
+ }
+ return(vec);
+}
+
+static inline s7_pointer vector_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2)
+{
+ s7_pointer vec = make_simple_vector(sc, 2);
+ vector_element(vec, 0) = p1;
+ vector_element(vec, 1) = p2;
+ return(vec);
+}
+
+static s7_pointer g_vector_2(s7_scheme *sc, s7_pointer args) {return(vector_p_pp(sc, car(args), cadr(args)));}
+
+static s7_pointer g_vector_3(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer vec = make_simple_vector(sc, 3);
+ vector_element(vec, 0) = car(args); args = cdr(args);
+ vector_element(vec, 1) = car(args);
+ vector_element(vec, 2) = cadr(args);
+ return(vec);
+}
+
+static s7_pointer vector_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ if (args == 2) return(sc->vector_2);
+ return((args == 3) ? sc->vector_3 : f);
+}
+
+
+/* -------------------------------- float-vector? -------------------------------- */
+static s7_pointer g_is_float_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_float_vector "(float-vector? obj) returns #t if obj is an homogeneous float vector"
+ #define Q_is_float_vector sc->pl_bt
+ check_boolean_method(sc, s7_is_float_vector, sc->is_float_vector_symbol, args);
+}
+
+
+/* -------------------------------- float-vector -------------------------------- */
+static s7_pointer g_float_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_float_vector "(float-vector ...) returns an homogeneous float vector whose elements are the arguments"
+ #define Q_float_vector s7_make_circular_signature(sc, 1, 2, sc->is_float_vector_symbol, sc->is_real_symbol)
+
+ s7_pointer vec, b;
+ s7_int len = proper_list_length_with_end(args, &b);
+ if (!is_null(b))
+ 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)));
+ 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));
+ }}
+ return(vec);
+}
+
+static s7_pointer float_vector_p_d(s7_scheme *sc, s7_double x)
+{
+ s7_pointer vec = make_simple_float_vector(sc, 1);
+ float_vector(vec, 0) = x;
+ return(vec);
+}
+
+static s7_pointer float_vector_p_i(s7_scheme *sc, s7_int x) /* thash */
+{
+ s7_pointer vec = make_simple_float_vector(sc, 1);
+ float_vector(vec, 0) = (s7_double)x;
+ return(vec);
+}
+/* p_dd case doesn't get any hits */
+
+
+/* -------------------------------- int-vector? -------------------------------- */
+static s7_pointer g_is_int_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_int_vector "(int-vector? obj) returns #t if obj is an homogeneous s7_int vector"
+ #define Q_is_int_vector sc->pl_bt
+ check_boolean_method(sc, is_int_vector, sc->is_int_vector_symbol, args);
+}
+
+
+/* -------------------------------- int-vector -------------------------------- */
+static s7_pointer g_int_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_int_vector "(int-vector ...) returns an homogeneous s7_int vector whose elements are the arguments"
+ #define Q_int_vector s7_make_circular_signature(sc, 1, 2, sc->is_int_vector_symbol, sc->is_integer_symbol)
+
+ s7_int i = 0;
+ s7_pointer vec, b;
+ s7_int len = proper_list_length_with_end(args, &b);
+ if (!is_null(b))
+ 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)));
+ 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));
+ int_vector(vec, i) = s7_integer_clamped_if_gmp(sc, p);
+ }
+ return(vec);
+}
+
+static s7_pointer int_vector_p_i(s7_scheme *sc, s7_int x)
+{
+ s7_pointer vec = make_simple_int_vector(sc, 1);
+ int_vector(vec, 0) = x;
+ return(vec);
+}
+/* p_ii case doesn't get any hits */
+
+
+/* -------------------------------- byte-vector? -------------------------------- */
+static s7_pointer g_is_byte_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector"
+ #define Q_is_byte_vector sc->pl_bt
+ check_boolean_method(sc, is_byte_vector_b_p, sc->is_byte_vector_symbol, args);
+}
+
+
+/* -------------------------------- byte-vector -------------------------------- */
+static s7_pointer g_byte_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_byte_vector "(byte-vector ...) returns a byte-vector whose elements are the arguments"
+ #define Q_byte_vector s7_make_circular_signature(sc, 1, 2, sc->is_byte_vector_symbol, sc->is_byte_symbol)
+
+ s7_int i = 0;
+ s7_pointer vec, end;
+ uint8_t *str;
+ s7_int len = proper_list_length_with_end(args, &end);
+ if (!is_null(end))
+ 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)));
+ vec = make_simple_byte_vector(sc, len);
+ str = byte_vector_bytes(vec);
+ for (s7_pointer x = args; is_pair(x); i++, x = cdr(x))
+ {
+ s7_pointer byte = car(x);
+ s7_int b;
+ if (is_t_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
+#endif
+ 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);
+ str[i] = (uint8_t)b;
+ }
+ return(vec);
+}
+
+
+#if (!WITH_PURE_S7)
+/* -------------------------------- list->vector -------------------------------- */
+static s7_pointer g_list_to_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_list_to_vector "(list->vector lst) returns a vector containing the elements of lst; (apply vector lst)"
+ #define Q_list_to_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_proper_list_symbol)
+
+ s7_pointer p = car(args);
+ if (is_null(p))
+ return(make_simple_vector(sc, 0)); /* was s7_make_vector */
+ sc->temp3 = p;
+ if (!s7_is_proper_list(sc, p))
+ return(method_or_bust_p(sc, p, sc->list_to_vector_symbol, a_proper_list_string));
+ p = g_vector(sc, p);
+ sc->temp3 = sc->unused;
+ return(p);
+}
+
+/* -------------------------------- vector-length -------------------------------- */
+static s7_pointer g_vector_length(s7_scheme *sc, s7_pointer args)
+{
+ #define H_vector_length "(vector-length v) returns the length of vector v"
+ #define Q_vector_length s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol)
+
+ s7_pointer vec = car(args);
+ if (!is_any_vector(vec))
+ return(sole_arg_method_or_bust(sc, vec, sc->vector_length_symbol, args, sc->type_names[T_VECTOR]));
+ return(make_integer(sc, vector_length(vec)));
+}
+
+static s7_int vector_length_i_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_any_vector(p))
+ return(integer(method_or_bust_p(sc, p, sc->vector_length_symbol, sc->type_names[T_VECTOR])));
+ return(vector_length(p));
+}
+
+static s7_pointer vector_length_p_p(s7_scheme *sc, s7_pointer vec)
+{
+ if (!is_any_vector(vec))
+ return(method_or_bust_p(sc, vec, sc->vector_length_symbol, sc->type_names[T_VECTOR]));
+ return(make_integer(sc, vector_length(vec)));
+}
+#endif
+
+
+/* -------------------------------- subvector subvector? subvector-vector subvector-position -------------------------------- */
+static bool s7_is_subvector(s7_pointer g) {return((is_any_vector(g)) && (is_subvector(g)));}
+
+static s7_pointer g_is_subvector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_subvector "(subvector? obj) returns #t if obj is a subvector"
+ #define Q_is_subvector sc->pl_bt
+ check_boolean_method(sc, s7_is_subvector, sc->is_subvector_symbol, args);
+}
+
+static s7_pointer g_subvector_position(s7_scheme *sc, s7_pointer args)
+{
+ #define H_subvector_position "(subvector-position obj) returns obj's offset"
+ #define Q_subvector_position s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_subvector_symbol)
+
+ s7_pointer sv = car(args);
+ if (s7_is_subvector(sv))
+ {
+ /* we can't use vector_elements(sv) - vector_elements(subvector_vector(sv)) because that assumes we're looking at s7_pointer*,
+ * so a subvector of a byte_vector gets a bogus position (0 if position is less than 8 etc).
+ * 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)))));
+ }}
+ return(sole_arg_method_or_bust(sc, sv, sc->subvector_position_symbol, args, sc->type_names[T_VECTOR]));
+}
+
+static s7_pointer g_subvector_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_subvector_vector "(subvector-vector obj) returns the vector underlying the subvector obj"
+ #define Q_subvector_vector s7_make_signature(sc, 2, sc->is_vector_symbol, sc->is_subvector_symbol)
+
+ if (s7_is_subvector(car(args)))
+ return(subvector_vector(car(args)));
+ return(sole_arg_method_or_bust(sc, car(args), sc->subvector_vector_symbol, args, sc->type_names[T_VECTOR]));
+}
+
+static s7_pointer subvector(s7_scheme *sc, s7_pointer vect, s7_int skip_dims, s7_int index)
+{
+ s7_int dims = vector_ndims(vect) - skip_dims;
+ s7_pointer x;
+ new_cell(sc, x, ((full_type(vect) & (~T_UNHEAP)) & (~T_COLLECTED)) | T_SUBVECTOR | T_SAFE_PROCEDURE); /* no T_UNHEAP because we're new but vect might be unheaped */
+ vector_length(x) = 0;
+ vector_block(x) = mallocate_empty_block(sc);
+ any_vector_elements(x) = NULL;
+ vector_getter(x) = vector_getter(vect);
+ vector_setter(x) = vector_setter(vect);
+ if (dims > 1)
+ {
+ vdims_t *v = (vdims_t *)mallocate_block(sc);
+ vdims_rank(v) = dims;
+ vdims_dims(v) = (s7_int *)(vector_dimensions(vect) + skip_dims);
+ vdims_offsets(v) = (s7_int *)(vector_offsets(vect) + skip_dims);
+ vdims_original(v) = vect;
+ vector_elements_should_be_freed(v) = false;
+ vector_set_dimension_info(x, v);
+ }
+ else
+ {
+ vector_set_dimension_info(x, NULL);
+ subvector_set_vector(x, vect);
+ }
+ if (is_t_vector(vect))
+ mark_function[T_VECTOR] = mark_vector_possibly_shared;
+ else mark_function[type(vect)] = mark_int_or_float_vector_possibly_shared;
+
+ vector_length(x) = (skip_dims > 0) ? vector_offset(vect, skip_dims - 1) : vector_length(vect);
+ if (is_int_vector(vect))
+ int_vector_ints(x) = (s7_int *)(int_vector_ints(vect) + index);
+ else
+ if (is_float_vector(vect))
+ 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);
+ else byte_vector_bytes(x) = (uint8_t *)(byte_vector_bytes(vect) + index);
+ add_multivector(sc, x);
+ return(x);
+}
+
+static inline vdims_t *list_to_dims(s7_scheme *sc, s7_pointer x)
+{
+ s7_int i, offset;
+ s7_pointer y;
+ s7_int *ds, *os;
+ s7_int len = proper_list_length(x);
+ vdims_t *v = (vdims_t *)inline_mallocate(sc, len * 2 * sizeof(s7_int));
+ vdims_rank(v) = len;
+ vdims_offsets(v) = (s7_int *)(vdims_dims(v) + len);
+ vector_elements_should_be_freed(v) = false;
+ ds = vdims_dims(v);
+ os = vdims_offsets(v);
+
+ for (i = 0, y = x; is_not_null(y); i++, y = cdr(y))
+ ds[i] = s7_integer_clamped_if_gmp(sc, car(y));
+
+ for (i = len - 1, offset = 1; i >= 0; i--)
+ {
+ os[i] = offset;
+ offset *= ds[i];
+ }
+ return(v);
+}
+
+static s7_pointer g_subvector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_subvector "(subvector original-vector (start 0) (end original-vector-len) new-dimensions) returns \
+a vector that points to the same elements as the original-vector but with different starting point, end point, and dimensional info."
+ #define Q_subvector s7_make_signature(sc, 5, sc->is_subvector_symbol, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_symbol, sc->is_pair_symbol)
+
+ /* (let ((v1 #2d((1 2 3) (4 5 6)))) (let ((v2 (subvector v1 0 6))) v2)) -> #(1 2 3 4 5 6)
+ * (let ((v1 #(1 2 3 4 5 6))) (let ((v2 (subvector v1 0 6 '(3 2)))) v2)) -> #2D((1 2) (3 4) (5 6))
+ */
+ s7_pointer orig = car(args), x;
+ vdims_t *v = NULL;
+ s7_int new_len, orig_len, offset = 0;
+
+ if (!is_any_vector(orig))
+ return(method_or_bust(sc, orig, sc->subvector_symbol, args, sc->type_names[T_VECTOR], 1));
+
+ orig_len = vector_length(orig);
+ new_len = orig_len;
+
+ if (is_pair(cdr(args))) /* get start point in vector */
+ {
+ 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));
+ 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);
+ 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;
+ }}}
+
+ if (is_t_vector(orig))
+ mark_function[T_VECTOR] = mark_vector_possibly_shared;
+ else mark_function[type(orig)] = mark_int_or_float_vector_possibly_shared; /* I think this works for byte-vectors also */
+
+ new_cell(sc, x, ((full_type(orig) & (~T_UNHEAP)) & (~T_COLLECTED)) | T_SUBVECTOR | T_SAFE_PROCEDURE);
+ vector_block(x) = mallocate_empty_block(sc);
+ vector_set_dimension_info(x, v);
+ if (!v) subvector_set_vector(x, orig);
+ vector_length(x) = new_len; /* might be less than original length */
+ if ((new_len == 0) && (is_t_vector(orig))) set_has_simple_elements(x);
+ vector_getter(x) = vector_getter(orig);
+ vector_setter(x) = vector_setter(orig);
+
+ if (is_int_vector(orig))
+ int_vector_ints(x) = (s7_int *)(int_vector_ints(orig) + offset);
+ else
+ if (is_float_vector(orig))
+ 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);
+ else byte_vector_bytes(x) = (uint8_t *)(byte_vector_bytes(orig) + offset);
+ add_multivector(sc, x);
+ return(x);
+}
+
+
+/* -------------------------------- vector-ref -------------------------------- */
+static s7_pointer vector_ref_1(s7_scheme *sc, s7_pointer vect, s7_pointer indices)
+{
+ s7_int index = 0;
+ if (vector_length(vect) == 0)
+ out_of_range_error_nr(sc, sc->vector_ref_symbol, int_one, vect, it_is_too_large_string);
+
+ if (vector_rank(vect) > 1)
+ {
+ 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));
+ 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);
+
+ 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));
+ }
+ /* if not enough indices, return a subvector covering whatever is left */
+ if (i < vector_ndims(vect))
+ return(subvector(sc, vect, i, index));
+ }
+ else
+ {
+ s7_pointer p = car(indices);
+ /* (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));
+ 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);
+
+ 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));
+ }}
+ return((vector_getter(vect))(sc, vect, index));
+}
+
+static s7_pointer g_vector_ref(s7_scheme *sc, s7_pointer args)
+{
+ #define H_vector_ref "(vector-ref v ... i) returns the i-th element of vector v."
+ #define Q_vector_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol, sc->is_integer_symbol)
+
+ s7_pointer vec = car(args);
+ if (!is_any_vector(vec))
+ return(method_or_bust(sc, vec, sc->vector_ref_symbol, args, sc->type_names[T_VECTOR], 1));
+ return(vector_ref_1(sc, vec, cdr(args))); /* 19-Jan-19 */
+}
+
+static s7_pointer vector_ref_p_pi(s7_scheme *sc, s7_pointer v, s7_int i)
+{
+ if ((!is_t_vector(v)) ||
+ (vector_rank(v) > 1) ||
+ (i < 0) || (i >= vector_length(v)))
+ return(g_vector_ref(sc, set_plist_2(sc, v, make_integer(sc, i))));
+ return(vector_element(v, i));
+}
+
+static s7_pointer vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer v, s7_int i) /* callable but just barely (tgsl.scm) */
+{
+ if ((i >= 0) && (i < vector_length(v)))
+ return(vector_getter(v)(sc, v, i));
+ out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(v);
+}
+
+static s7_pointer t_vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer v, s7_int i)
+{
+ if ((i >= 0) && (i < vector_length(v)))
+ return(vector_element(v, i));
+ out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(v);
+}
+
+static s7_pointer vector_ref_p_pii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2)
+{
+ if ((!is_any_vector(v)) ||
+ (vector_rank(v) != 2) ||
+ (i1 < 0) || (i2 < 0) ||
+ (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1)))
+ return(g_vector_ref(sc, set_plist_3(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2))));
+ return(vector_getter(v)(sc, v, i2 + (i1 * vector_offset(v, 0))));
+}
+
+static s7_pointer vector_ref_p_pii_direct(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2)
+{
+ if ((i1 < 0) || (i2 < 0) ||
+ (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1)))
+ return(g_vector_ref(sc, set_plist_3(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2))));
+ return(vector_element(v, i2 + (i1 * vector_offset(v, 0))));
+}
+
+static s7_pointer t_vector_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i) {return(vector_element(v, i));}
+
+static inline s7_pointer vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer ind)
+{
+ s7_int index;
+ if ((!is_t_vector(vec)) ||
+ (vector_rank(vec) != 1) ||
+ (!s7_is_integer(ind)))
+ return(g_vector_ref(sc, set_plist_2(sc, vec, ind)));
+ index = s7_integer_clamped_if_gmp(sc, ind);
+ if ((index < 0) || (index >= vector_length(vec)))
+ out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, ind, (index < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(vector_element(vec, index));
+}
+
+static s7_pointer g_vector_ref_2(s7_scheme *sc, s7_pointer args) {return(vector_ref_p_pp(sc, car(args), cadr(args)));}
+
+static s7_pointer g_vector_ref_3(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer vec = car(args), i1, i2;
+ s7_int ix, iy;
+
+ if (!is_any_vector(vec))
+ return(g_vector_ref(sc, args));
+ if (vector_rank(vec) != 2)
+ return(g_vector_ref(sc, args));
+
+ i1 = cadr(args);
+ if (!s7_is_integer(i1))
+ return(g_vector_ref(sc, args));
+ i2 = caddr(args);
+ if (!s7_is_integer(i2))
+ return(g_vector_ref(sc, args));
+ ix = s7_integer_clamped_if_gmp(sc, i1);
+ iy = s7_integer_clamped_if_gmp(sc, i2);
+ if ((ix >= 0) && (iy >= 0) &&
+ (ix < vector_dimension(vec, 0)) && (iy < vector_dimension(vec, 1)))
+ {
+ s7_int index = (ix * vector_offset(vec, 0)) + iy; /* vector_offset(vec, 1) == 1 */
+ return(vector_getter(vec)(sc, vec, index));
+ }
+ return(g_vector_ref(sc, args));
+}
+
+static s7_pointer vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ if (args == 2)
+ return(sc->vector_ref_2);
+ return((args == 3) ? sc->vector_ref_3 : f);
+}
+
+
+/* -------------------------------- vector-set! -------------------------------- */
+static s7_pointer g_vector_set(s7_scheme *sc, s7_pointer args)
+{
+ #define H_vector_set "(vector-set! v i ... value) sets the i-th element of vector v to value."
+ #define Q_vector_set s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_any_at_end_symbol)
+
+ s7_pointer vec = car(args), val;
+ s7_int index;
+
+ if (!is_any_vector(vec))
+ return(method_or_bust(sc, vec, sc->vector_set_symbol, args, sc->type_names[T_VECTOR], 1));
+ if (is_immutable_vector(vec))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vec));
+ if (vector_length(vec) == 0)
+ out_of_range_error_nr(sc, sc->vector_set_symbol, int_one, vec, it_is_too_large_string);
+
+ if (vector_rank(vec) > 1)
+ {
+ s7_int i;
+ 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));
+ 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);
+
+ 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);
+ if (i != vector_ndims(vec))
+ 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
+ * if at least one index is missing, and the value fits. It also makes error detection harder,
+ * but so does the current vector-ref handling. Can't decide...
+ * (define v (make-vector '(2 3) 0)) (vector-set! v 0 #(1 2 3)) -> error, but (vector-ref v 0) -> #(0 0 0)
+ * Other possible additions: complex-vector and string-vector.
+ */
+ val = car(x);
+ }
+ else
+ {
+ 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));
+ 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);
+
+ 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))));
+ }
+ val = caddr(args);
+ }
+ if (is_typed_t_vector(vec))
+ return(typed_vector_setter(sc, vec, index, val));
+ if (is_t_vector(vec))
+ vector_element(vec, index) = val;
+ else vector_setter(vec)(sc, vec, index, val);
+ return(val);
+}
+
+static s7_pointer vector_set_p_pip(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p) /* almost never called -- see one case in s7test.scm[13736] */
+{
+ if ((!is_any_vector(v)) || (vector_rank(v) > 1) || (i < 0) || (i >= vector_length(v)))
+ return(g_vector_set(sc, set_plist_3(sc, v, make_integer(sc, i), p)));
+ if (is_t_vector(v))
+ {
+ if (is_typed_vector(v)) return(typed_vector_setter(sc, v, i, p));
+ vector_element(v, i) = p;
+ }
+ else vector_setter(v)(sc, v, i, p);
+ return(p);
+}
+
+static s7_pointer vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p)
+{
+ if ((i >= 0) && (i < vector_length(v)))
+ vector_element(v, i) = p;
+ else out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(p);
+}
+
+static s7_pointer vector_set_p_piip(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_pointer p)
+{
+ if ((!is_any_vector(v)) ||
+ (vector_rank(v) != 2) ||
+ (i1 < 0) || (i2 < 0) ||
+ (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1)))
+ return(g_vector_set(sc, set_plist_4(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2), p)));
+ if (is_t_vector(v))
+ {
+ if (is_typed_vector(v))
+ 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);
+ return(p);
+}
+
+static s7_pointer vector_set_p_piip_direct(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_pointer p)
+{
+ /* normal untyped vector, rank == 2, uncallable? */
+ if ((i1 < 0) || (i2 < 0) ||
+ (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1)))
+ return(g_vector_set(sc, set_plist_4(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2), p)));
+ vector_element(v, i2 + (i1 * vector_offset(v, 0))) = p;
+ return(p);
+}
+
+static s7_pointer typed_vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p)
+{
+ if ((i >= 0) && (i < vector_length(v)))
+ typed_vector_setter(sc, v, i, p);
+ else out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(p);
+}
+
+static s7_pointer typed_vector_set_p_piip_direct(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_pointer p)
+{
+ if ((i1 < 0) || (i2 < 0) ||
+ (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1)))
+ return(g_vector_set(sc, set_plist_4(sc, v, make_integer(sc, i1), make_integer_unchecked(sc, i2), p)));
+ return(typed_vector_setter(sc, v, i2 + (i1 * vector_offset(v, 0)), p));
+}
+
+static s7_pointer t_vector_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i, s7_pointer p) {vector_element(v, i) = p; return(p);}
+
+static s7_pointer typed_t_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p)
+{
+ typed_vector_setter(sc, v, i, p);
+ return(p);
+}
+
+static s7_pointer g_vector_set_3(s7_scheme *sc, s7_pointer args)
+{
+ /* (vector-set! vector index value) */
+ s7_pointer ind, vec = car(args), val;
+ s7_int index;
+
+ if (!is_any_vector(vec))
+ return(g_vector_set(sc, args));
+ if (is_immutable_vector(vec))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vec));
+ if (vector_rank(vec) > 1)
+ return(g_vector_set(sc, args));
+
+ ind = cadr(args);
+ if (!s7_is_integer(ind))
+ return(g_vector_set(sc, args));
+ index = s7_integer_clamped_if_gmp(sc, ind);
+ if ((index < 0) || (index >= vector_length(vec)))
+ out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string);
+
+ val = caddr(args);
+ if (is_typed_t_vector(vec))
+ return(typed_vector_setter(sc, vec, index, val));
+ if (is_t_vector(vec))
+ vector_element(vec, index) = val;
+ else vector_setter(vec)(sc, vec, index, val);
+ return(val);
+}
+
+static s7_pointer vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer ind, s7_pointer val)
+{
+ s7_int index;
+
+ if ((!is_t_vector(vec)) || (vector_rank(vec) > 1))
+ return(g_vector_set(sc, set_plist_3(sc, vec, ind, val)));
+ if (is_immutable_vector(vec))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vec));
+ if (!s7_is_integer(ind))
+ return(g_vector_set(sc, set_plist_3(sc, vec, ind, val)));
+ index = s7_integer_clamped_if_gmp(sc, ind);
+ if ((index < 0) || (index >= vector_length(vec)))
+ out_of_range_error_nr(sc, sc->vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string);
+
+ if (is_typed_vector(vec))
+ return(typed_vector_setter(sc, vec, index, val));
+ vector_element(vec, index) = val;
+ return(val);
+}
+
+static s7_pointer g_vector_set_4(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer v = car(args), ip1 = cadr(args), ip2 = caddr(args), val;
+ s7_int i1, i2;
+ if ((!is_any_vector(v)) ||
+ (vector_rank(v) != 2) ||
+ (is_immutable_vector(v)) ||
+ (!s7_is_integer(ip1)) ||
+ (!s7_is_integer(ip2)))
+ return(g_vector_set(sc, args));
+ i1 = s7_integer_clamped_if_gmp(sc, ip1);
+ i2 = s7_integer_clamped_if_gmp(sc, ip2);
+ if ((i1 < 0) || (i2 < 0) ||
+ (i1 >= vector_dimension(v, 0)) || (i2 >= vector_dimension(v, 1)))
+ return(g_vector_set(sc, args));
+ val = cadddr(args);
+ if (is_typed_t_vector(v))
+ return(typed_vector_setter(sc, v, i2 + (i1 * vector_offset(v, 0)), val));
+ if (is_t_vector(v))
+ vector_element(v, i2 + (i1 * vector_offset(v, 0))) = val;
+ else vector_setter(v)(sc, v, i2 + (i1 * vector_offset(v, 0)), val);
+ return(val);
+}
+
+static s7_pointer vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ if (args == 3) return(sc->vector_set_3);
+ return((args == 4) ? sc->vector_set_4 : f);
+}
+
+
+/* -------------------------------- make-vector -------------------------------- */
+static s7_int multivector_length(s7_scheme *sc, s7_pointer x, s7_pointer caller)
+{
+ s7_pointer y;
+ s7_int len, dims = s7_list_length(sc, x);
+ if (dims <= 0) /* 0 if circular, negative if dotted */
+ 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)));
+ 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]);
+#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);
+#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);
+ }
+ return(len);
+}
+
+static void check_vector_typer_c_function(s7_scheme *sc, s7_pointer caller, s7_pointer typf)
+{
+ s7_pointer sig = c_function_signature(typf);
+ 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, typf, wrap_string(sc, "a boolean procedure", 19));
+ if (!c_function_name(typf))
+ wrong_type_error_nr(sc, caller, 2, typf, wrap_string(sc, "a named function", 16));
+ if (!c_function_marker(typf))
+ c_function_set_marker(typf, mark_vector_1);
+ if (!c_function_symbol(typf))
+ c_function_symbol(typf) = make_symbol(sc, c_function_name(typf), c_function_name_length(typf));
+}
+
+static inline s7_pointer make_multivector(s7_scheme *sc, s7_pointer vec, s7_pointer x)
+{
+ vdims_t *v = list_to_dims(sc, x);
+ vdims_original(v) = sc->F;
+ vector_set_dimension_info(vec, v);
+ add_multivector(sc, vec);
+ return(vec);
+}
+
+static s7_pointer g_make_vector_1(s7_scheme *sc, s7_pointer args, s7_pointer caller)
+{
+ s7_int len;
+ s7_pointer x = car(args), fill = sc->unspecified, vec, typf = sc->T;
+ int32_t result_type = T_VECTOR;
+
+ if (s7_is_integer(x))
+ {
+ len = s7_integer_clamped_if_gmp(sc, x);
+ if (len < 0)
+ 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));
+ if (!s7_is_integer(car(x)))
+ 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);
+ }
+
+ if (is_pair(cdr(args)))
+ {
+ fill = cadr(args);
+ if (caller == sc->make_int_vector_symbol)
+ 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 (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);
+ }}}
+ /* 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.
+ */
+ if ((result_type == T_VECTOR) &&
+ (typf != sc->T) && /* default value */
+ (s7_apply_function(sc, typf, set_plist_1(sc, fill)) == sc->F))
+ {
+ const char *tstr = make_type_name(sc, (is_c_function(typf)) ? c_function_name(typf) : symbol_name(find_closure(sc, typf, closure_let(typf))), INDEFINITE_ARTICLE);
+ wrong_type_error_nr(sc, sc->make_vector_symbol, 2, fill, wrap_string(sc, tstr, safe_strlen(tstr)));
+ }
+
+ vec = make_vector_1(sc, len, NOT_FILLED, result_type);
+ if ((result_type == T_VECTOR) &&
+ (typf != sc->T)) /* default value */
+ {
+ set_typed_vector(vec);
+ typed_vector_set_typer(vec, typf);
+
+ if ((is_c_function(typf)) &&
+ (c_function_has_simple_elements(typf)))
+ set_has_simple_elements(vec);
+ }
+ s7_vector_fill(sc, vec, fill);
+ if ((is_pair(x)) &&
+ (is_pair(cdr(x))))
+ return(make_multivector(sc, vec, x));
+ add_vector(sc, vec);
+ return(vec);
+}
+
+static s7_pointer g_make_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_make_vector "(make-vector len (value #<unspecified>) type) returns a vector of len elements initialized to value. \
+To create a multidimensional vector, put the dimension bounds in a list (this is to avoid ambiguities such as \
+(make-vector 1 2) where it's not clear whether the '2' is an initial value or a dimension size). (make-vector '(2 3) 1.0) \
+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))
+ return(g_make_vector_1(sc, args, sc->make_vector_symbol));
+}
+
+
+/* -------------------------------- make-float-vector -------------------------------- */
+static s7_pointer g_make_float_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_make_float_vector "(make-float-vector len (init 0.0)) returns a float-vector."
+ #define Q_make_float_vector s7_make_signature(sc, 3, \
+ sc->is_float_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_real_symbol)
+ s7_int len;
+ s7_pointer x, p = car(args);
+ block_t *arr;
+
+ if ((is_pair(cdr(args))) || (!s7_is_integer(p)))
+ {
+ 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));
+#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));
+#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));
+ }
+ else init = real_zero;
+ if (s7_is_integer(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);
+ }
+ 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));
+ add_vector(sc, x);
+ return(x);
+ }
+
+ len = s7_integer_clamped_if_gmp(sc, p);
+ if (len < 0)
+ 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)));
+
+ arr = mallocate_vector(sc, len * sizeof(s7_double));
+ new_cell(sc, x, T_FLOAT_VECTOR | T_SAFE_PROCEDURE);
+ vector_length(x) = len;
+ vector_block(x) = arr;
+ float_vector_floats(x) = (s7_double *)block_data(arr);
+ if (len > 0)
+ {
+ 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_set_dimension_info(x, NULL);
+ vector_getter(x) = float_vector_getter;
+ vector_setter(x) = float_vector_setter;
+
+ add_vector(sc, x);
+ return(x);
+}
+
+static s7_pointer make_float_vector_p_pp(s7_scheme *sc, s7_pointer len, s7_pointer fill)
+{
+ if ((is_t_integer(len)) && (is_t_real(fill)) &&
+ (integer(len)>= 0) && (integer(len) < sc->max_vector_length))
+ {
+ s7_pointer fv = make_simple_float_vector(sc, integer(len));
+ float_vector_fill(fv, real(fill));
+ return(fv);
+ }
+ return(g_make_float_vector(sc, set_plist_2(sc, len, fill)));
+}
+
+
+/* -------------------------------- make-int-vector -------------------------------- */
+static s7_pointer g_make_int_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_make_int_vector "(make-int-vector len (init 0)) returns an int-vector."
+ #define Q_make_int_vector s7_make_signature(sc, 3, sc->is_int_vector_symbol, \
+ s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_integer_symbol)
+ s7_int len;
+ s7_pointer x, p = car(args);
+ block_t *arr;
+
+ if ((is_pair(cdr(args))) ||
+ (!s7_is_integer(p)))
+ {
+ 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));
+ }
+ else init = int_zero;
+ if (s7_is_integer(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);
+ }
+ 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));
+ add_vector(sc, x);
+ return(x);
+ }
+
+ len = s7_integer_clamped_if_gmp(sc, p);
+ if (len < 0)
+ 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)));
+
+ arr = mallocate_vector(sc, len * sizeof(s7_int));
+ new_cell(sc, x, T_INT_VECTOR | T_SAFE_PROCEDURE);
+ vector_length(x) = len;
+ vector_block(x) = arr;
+ int_vector_ints(x) = (s7_int *)block_data(arr);
+ if (len > 0)
+ {
+ 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_set_dimension_info(x, NULL);
+ vector_getter(x) = int_vector_getter;
+ vector_setter(x) = int_vector_setter;
+
+ add_vector(sc, x);
+ return(x);
+}
+
+static s7_pointer make_int_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init)
+{
+ s7_pointer x = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR);
+ int_vector_fill(x, init);
+ add_vector(sc, x);
+ return(x);
+}
+
+
+/* -------------------------------- make-byte-vector -------------------------------- */
+static s7_pointer g_make_byte_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_make_byte_vector "(make-byte-vector len (byte 0)) makes a byte-vector of length len filled with byte."
+ #define Q_make_byte_vector s7_make_signature(sc, 3, sc->is_byte_vector_symbol, \
+ s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_byte_symbol)
+ s7_int len = 0, ib = 0;
+ s7_pointer p = car(args), init;
+
+ 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));
+ 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);
+ 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)));
+ }
+ 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));
+ 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);
+ }
+ else init = int_zero;
+
+ if (!s7_is_integer(p))
+ return(g_make_vector_1(sc, set_plist_2(sc, p, init), sc->make_byte_vector_symbol));
+
+ p = make_simple_byte_vector(sc, len);
+ if (len > 0) /* make-byte-vector 2) should return #u(0 0) so we always need to fill */
+ local_memset((void *)(byte_vector_bytes(p)), ib, len);
+ return(p);
+}
+
+static s7_pointer make_byte_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init)
+{
+ s7_pointer p;
+ if (len < 0)
+ 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)));
+ 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);
+ if (len > 0)
+ local_memset((void *)(byte_vector_bytes(p)), init, len);
+ return(p);
+}
+
+
+/* -------------------------------- vector? -------------------------------- */
+static s7_pointer g_is_vector(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_vector "(vector? obj) returns #t if obj is a vector"
+ #define Q_is_vector sc->pl_bt
+ check_boolean_method(sc, is_any_vector, sc->is_vector_symbol, args);
+}
+
+
+/* -------------------------------- vector-rank -------------------------------- */
+s7_int s7_vector_rank(s7_pointer vect) {return((s7_int)(vector_rank(vect)));}
+
+static s7_pointer g_vector_rank(s7_scheme *sc, s7_pointer args)
+{
+ #define H_vector_rank "(vector-rank vect) returns the number of dimensions in vect"
+ #define Q_vector_rank s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_vector_symbol)
+ s7_pointer x = car(args);
+ if (!is_any_vector(x))
+ return(sole_arg_method_or_bust(sc, x, sc->vector_rank_symbol, args, sc->type_names[T_VECTOR]));
+ return(make_integer(sc, vector_rank(x)));
+}
+
+
+/* -------------------------------- vector-dimension -------------------------------- */
+static s7_pointer g_vector_dimension(s7_scheme *sc, s7_pointer args)
+{
+ #define H_vector_dimension "(vector-dimension vect n) returns the size of the n-th dimension (n is 0-based)"
+ #define Q_vector_dimension s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_vector_symbol, sc->is_integer_symbol)
+ s7_pointer v = car(args);
+ s7_pointer np = cadr(args);
+ s7_int n;
+ if (!is_any_vector(v))
+ return(method_or_bust(sc, v, sc->vector_dimension_symbol, args, sc->type_names[T_VECTOR], 1));
+ if (!s7_is_integer(np))
+ return(method_or_bust(sc, v, sc->vector_dimension_symbol, args, sc->type_names[T_INTEGER], 2));
+ 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));
+ 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))));
+ if (vector_has_dimension_info(v))
+ return(make_integer(sc, vector_dimension(v, n)));
+ return(make_integer(sc, vector_length(v)));
+}
+
+
+/* -------------------------------- vector-dimensions -------------------------------- */
+static s7_pointer g_vector_dimensions(s7_scheme *sc, s7_pointer args)
+{
+ #define H_vector_dimensions "(vector-dimensions vect) returns a list of vect's dimensions"
+ #define Q_vector_dimensions s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_vector_symbol)
+
+ s7_pointer x = car(args);
+ if (!is_any_vector(x))
+ return(sole_arg_method_or_bust(sc, x, sc->vector_dimensions_symbol, args, sc->type_names[T_VECTOR]));
+ if (vector_rank(x) == 1)
+ return(list_1(sc, make_integer(sc, vector_length(x))));
+
+ sc->w = sc->nil;
+ for (s7_int i = vector_ndims(x) - 1; i >= 0; i--)
+ sc->w = cons(sc, make_integer(sc, vector_dimension(x, i)), sc->w);
+ x = sc->w;
+ sc->w = sc->unused;
+ return(x);
+}
+
+
+/* -------------------------------- vector-typer -------------------------------- */
+static s7_pointer g_vector_typer(s7_scheme *sc, s7_pointer args)
+{
+ #define H_vector_typer "(vector-typer vect) returns the vector's element type checking function"
+ #define Q_vector_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_vector_symbol)
+
+ s7_pointer v = car(args);
+ if (!is_any_vector(v))
+ return(sole_arg_method_or_bust(sc, v, sc->vector_typer_symbol, args, sc->type_names[T_VECTOR]));
+
+ if (is_typed_t_vector(v)) return(typed_vector_typer(v));
+ if (is_float_vector(v)) return(global_value(sc->is_float_symbol));
+ if (is_int_vector(v)) return(global_value(sc->is_integer_symbol));
+ if (is_byte_vector(v)) return(global_value(sc->is_byte_symbol));
+ return(sc->F);
+}
+
+static s7_pointer g_set_vector_typer(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer v = car(args), typer = cadr(args);
+
+ if (!is_any_vector(v))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! vector-typer", 17), 1, v, sc->type_names[T_VECTOR]);
+ if (is_immutable_vector(v))
+ immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable so its vector-typer can't be set!", 49), v));
+
+ 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));
+ 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 */
+ }}
+ else
+ {
+ if (is_c_function(typer))
+ 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 <...>" */
+ }
+ 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);
+ else clear_has_simple_elements(v); /* 15-Oct-23 */
+ }
+ return(typer);
+}
+
+
+/* -------------------------------- multivector -------------------------------- */
+#define MULTIVECTOR_TOO_MANY_ELEMENTS -1
+#define MULTIVECTOR_NOT_ENOUGH_ELEMENTS -2
+
+static int32_t traverse_vector_data(s7_scheme *sc, s7_pointer vec, s7_int flat_ref, s7_int dimension, s7_int dimensions, s7_int *sizes, s7_pointer lst)
+{
+ /* we're filling vec, we're currently looking for element flat_ref,
+ * we're at ref in dimension of dimensions, where sizes gives the bounds, and lst is our data
+ * #3D(((1 2 3) (4 5 6)) ((7 8 9) (10 11 12)))
+ */
+ s7_pointer x = lst;
+ for (s7_int i = 0; i < sizes[dimension]; i++, x = cdr(x))
+ {
+ if (!is_pair(x))
+ return(MULTIVECTOR_NOT_ENOUGH_ELEMENTS);
+ if (dimension == (dimensions - 1))
+ 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);
+ }}
+ return((is_null(x)) ? flat_ref : MULTIVECTOR_TOO_MANY_ELEMENTS);
+}
+
+static s7_pointer reverse_in_place_unchecked(s7_scheme *sc, s7_pointer term, s7_pointer list)
+{
+ s7_pointer p = list, result = term;
+ while (true)
+ {
+ s7_pointer q;
+ LOOP_4(if (is_null(p)) return(result); q = cdr(p); set_cdr(p, result); result = p; p = q); /* return, not break because LOOP_4 is itself a do loop */
+ }
+ return(result);
+}
+
+static s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list)
+{
+ return(reverse_in_place_unchecked(sc, sc->nil, 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));
+}
+
+static s7_pointer g_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
+{
+ /* get the dimension bounds from data, make the new vector, fill it from data
+ * dims needs to be s7_int so we can at least give correct error messages.
+ */
+ s7_pointer vec, x = data;
+ s7_int err, vec_loc;
+ s7_int *sizes;
+
+ /* (#2d((1 2 3) (4 5 6)) 0 0) -> 1
+ * (#2d((1 2 3) (4 5 6)) 1 1) -> 5
+ * (#3d(((1 2) (3 4)) ((5 6) (7 8))) 1 1 0) -> 7
+ * #3d(((1 2) (3 4)) ((5 6) (7))) -> error, #3d(((1 2) (3 4)) ((5 6) (7 8 9))), #3d(((1 2) (3 4)) (5 (7 8 9))) etc
+ * but a special case: #nd() is an n-dimensional empty vector
+ */
+
+ 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)));
+
+ 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)));
+ 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))));
+
+ sizes = (s7_int *)Calloc(dims, sizeof(s7_int));
+ for (s7_int i = 0; i < dims; i++)
+ {
+ sizes[i] = proper_list_length(x);
+ 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);
+ }}
+
+ 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);
+ sc->w = sc->unused;
+
+ /* now fill the vector checking that all the lists match */
+ err = traverse_vector_data(sc, vec, 0, 0, dims, sizes, data);
+
+ free(sizes);
+ s7_gc_unprotect_at(sc, vec_loc);
+ if (err < 0)
+ multivector_error_nr(sc, (err == MULTIVECTOR_TOO_MANY_ELEMENTS) ? "found too many elements" : "not enough elements found", data);
+ return(vec);
+}
+
+static s7_pointer g_int_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
+{
+ /* dims > 1, sc->value is a pair (not null) */
+ s7_pointer *src;
+ s7_int len;
+ sc->value = g_multivector(sc, dims, data);
+ src = (s7_pointer *)vector_elements(sc->value);
+ len = vector_length(sc->value);
+ for (s7_int i = 0; i < len; i++)
+ if (!is_t_integer(src[i]))
+ wrong_type_error_nr(sc, wrap_string(sc, "#i(...)", 7), i + 1, src[i], sc->type_names[T_INTEGER]);
+ sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), int_zero), sc->make_int_vector_symbol);
+ return(s7_copy_1(sc, sc->int_vector_symbol, set_plist_2(sc, sc->value, sc->args)));
+}
+
+static s7_pointer g_byte_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
+{
+ /* dims > 1, sc->value is a pair (not null) */
+ s7_pointer *src;
+ s7_int len;
+ sc->value = g_multivector(sc, dims, data);
+ src = (s7_pointer *)vector_elements(sc->value);
+ len = vector_length(sc->value);
+ for (s7_int i = 0; i < len; i++)
+ if (!is_byte(src[i]))
+ wrong_type_error_nr(sc, wrap_string(sc, "#u(...)", 7), i + 1, src[i], wrap_string(sc, "a byte", 6));
+ sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), int_zero), sc->make_byte_vector_symbol);
+ return(s7_copy_1(sc, sc->byte_vector_symbol, set_plist_2(sc, sc->value, sc->args)));
+}
+
+static s7_pointer g_float_multivector(s7_scheme *sc, s7_int dims, s7_pointer data)
+{
+ /* dims > 1, sc->value is a pair (not null) */
+ s7_pointer *src;
+ s7_int len;
+ sc->value = g_multivector(sc, dims, data);
+ src = (s7_pointer *)vector_elements(sc->value);
+ len = vector_length(sc->value);
+ for (s7_int i = 0; i < len; i++)
+ if (!is_real(src[i]))
+ wrong_type_error_nr(sc, wrap_string(sc, "#r(...)", 7), i + 1, src[i], sc->type_names[T_REAL]);
+ sc->args = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, sc->value)), real_zero), sc->make_float_vector_symbol);
+ return(s7_copy_1(sc, sc->float_vector_symbol, set_plist_2(sc, sc->value, sc->args)));
+}
+
+static Vectorized s7_pointer s7_vector_copy_1(s7_scheme *sc, s7_pointer old_vect)
+{
+ s7_int len = vector_length(old_vect);
+ s7_pointer new_vect;
+
+ if (is_t_vector(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)));
+ }
+ 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);
+ /* 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++;
+ return(new_vect);
+ }
+
+ if (is_float_vector(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);
+ 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)); */
+ return(new_vect);
+ }
+
+ if (is_int_vector(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);
+ 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++;
+ return(new_vect);
+ }
+
+ if (is_byte_vector(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);
+ 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++;
+ return(new_vect);
+ }
+ return(NULL);
+}
+
+s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vect) {return(s7_vector_copy_1(sc, old_vect));} /* repeated for Vectorized */
+
+static s7_pointer univect_ref(s7_scheme *sc, s7_pointer args, s7_pointer caller, int32_t typ)
+{
+ s7_pointer v = car(args), index;
+ s7_int ind;
+
+ if (type(v) != typ)
+ return(method_or_bust(sc, v, caller, args, sc->type_names[typ], 1));
+
+ if (vector_rank(v) == 1)
+ {
+ index = cadr(args);
+ if (!s7_is_integer(index))
+ 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);
+ if (!is_null(cddr(args)))
+ out_of_range_error_nr(sc, caller, int_two, cdr(args), too_many_indices_string);
+ }
+ else
+ {
+ s7_int i;
+ 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);
+ }
+ if (is_not_null(x))
+ 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));
+ }
+ if (typ == T_FLOAT_VECTOR)
+ return(make_real(sc, float_vector(v, ind)));
+ return((typ == T_INT_VECTOR) ? make_integer(sc, int_vector(v, ind)) : small_int(byte_vector(v, ind)));
+}
+
+static s7_pointer univect_set(s7_scheme *sc, s7_pointer args, s7_pointer caller, int32_t typ)
+{
+ s7_pointer vec = car(args), val, index;
+ s7_int ind;
+
+ if (type(vec) != typ)
+ return(method_or_bust(sc, vec, caller, args, sc->type_names[typ], 1));
+ if (is_immutable_vector(vec))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, vec));
+
+ if (vector_rank(vec) > 1)
+ {
+ s7_int i;
+ 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);
+ }
+ 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));
+ 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));
+ 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));
+ /* 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));
+ 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);
+ 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));
+ 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));
+ 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);
+ }
+ 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);
+ }
+ return(val);
+}
+
+
+/* -------------------------------- float-vector-ref -------------------------------- */
+static s7_pointer g_float_vector_ref(s7_scheme *sc, s7_pointer args)
+{
+ #define H_float_vector_ref "(float-vector-ref v ...) returns an element of the float-vector v."
+ #define Q_float_vector_ref s7_make_circular_signature(sc, 2, 3, \
+ s7_make_signature(sc, 2, sc->is_float_symbol, sc->is_float_vector_symbol), \
+ sc->is_float_vector_symbol, sc->is_integer_symbol)
+ return(univect_ref(sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR));
+}
+
+static inline s7_pointer float_vector_ref_p_pp(s7_scheme *sc, s7_pointer v, s7_pointer index)
+{
+ s7_int ind;
+ if (!is_float_vector(v))
+ return(method_or_bust_pp(sc, v, sc->float_vector_ref_symbol, v, index, sc->type_names[T_FLOAT_VECTOR], 1));
+ if (vector_rank(v) != 1)
+ return(univect_ref(sc, set_plist_2(sc, v, index), sc->float_vector_ref_symbol, T_FLOAT_VECTOR));
+ if (!s7_is_integer(index))
+ return(method_or_bust_pp(sc, index, sc->float_vector_ref_symbol, v, index, sc->type_names[T_INTEGER], 2));
+ ind = s7_integer_clamped_if_gmp(sc, index);
+ if ((ind < 0) || (ind >= vector_length(v)))
+ out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(make_real(sc, float_vector(v, ind)));
+}
+
+static s7_pointer g_fv_ref_2(s7_scheme *sc, s7_pointer args) {return(float_vector_ref_p_pp(sc, car(args), cadr(args)));}
+
+static s7_pointer g_fv_ref_3(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer fv = car(args), index;
+ s7_int ind1, ind2;
+ if (!is_float_vector(fv))
+ return(method_or_bust(sc, fv, sc->float_vector_ref_symbol, args, sc->type_names[T_FLOAT_VECTOR], 1));
+ if (vector_rank(fv) != 2)
+ return(univect_ref(sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR));
+ index = cadr(args);
+ if (!s7_is_integer(index))
+ return(method_or_bust(sc, index, sc->float_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2));
+ ind1 = s7_integer_clamped_if_gmp(sc, index);
+ if ((ind1 < 0) || (ind1 >= vector_dimension(fv, 0)))
+ out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, index, (ind1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ index = caddr(args);
+ if (!s7_is_integer(index))
+ return(method_or_bust(sc, index, sc->float_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3));
+ ind2 = s7_integer_clamped_if_gmp(sc, index);
+ if ((ind2 < 0) || (ind2 >= vector_dimension(fv, 1)))
+ out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_three, index, (ind2 < 0) ? it_is_negative_string : it_is_too_large_string);
+ ind1 = ind1 * vector_offset(fv, 0) + ind2;
+ return(make_real(sc, float_vector(fv, ind1)));
+}
+
+static inline s7_int ref_check_index(s7_scheme *sc, s7_pointer v, s7_int i)
+{
+ /* according to callgrind, it is faster to split out the bounds check */
+ if ((i < 0) || (i >= vector_length(v)))
+ out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(i);
+}
+
+static inline s7_double float_vector_ref_d_7pi(s7_scheme *sc, s7_pointer v, s7_int i) {return(float_vector(v, ref_check_index(sc, v, i)));}
+static double float_vector_ref_d_7pi_direct(s7_scheme *sc, s7_pointer v, s7_int i) {return(float_vector(v, i));}
+static s7_pointer float_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer v, s7_int i) {return(make_real(sc, float_vector(v, i)));}
+static s7_pointer float_vector_ref_p_pi_direct_wrapped(s7_scheme *sc, s7_pointer v, s7_int i) {return(wrap_real(sc, float_vector(v, i)));}
+
+static inline s7_double float_vector_ref_d_7pii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2)
+{
+ if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
+ out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
+ out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(float_vector(v, i2 + (i1 * vector_offset(v, 0))));
+}
+
+static s7_double float_vector_ref_d_7piii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3)
+{ /* uncallable? */
+ if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
+ out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
+ out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string);
+ if ((i3 < 0) || (i3 >= vector_dimension(v, 2)))
+ out_of_range_error_nr(sc, sc->float_vector_ref_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(float_vector(v, i3 + (i2 * vector_offset(v, 1)) + (i1 * vector_offset(v, 0))));
+}
+
+static s7_pointer float_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ return((args == 2) ? sc->fv_ref_2 : ((args == 3) ? sc->fv_ref_3 : f));
+}
+
+
+/* -------------------------------- float-vector-set! -------------------------------- */
+static s7_pointer g_float_vector_set(s7_scheme *sc, s7_pointer args)
+{
+ #define H_float_vector_set "(float-vector-set! v i ... value) sets the i-th element of the float-vector v to value."
+ #define Q_float_vector_set s7_make_circular_signature(sc, 3, 4, \
+ sc->is_real_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_real_at_end_symbol)
+ return(univect_set(sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR));
+}
+
+static s7_pointer g_fv_set_3(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer fv = car(args), index, value;
+ s7_int ind;
+ if (!is_float_vector(fv))
+ return(method_or_bust(sc, fv, sc->float_vector_set_symbol, args, sc->type_names[T_FLOAT_VECTOR], 1));
+ if (vector_rank(fv) != 1)
+ return(univect_set(sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR));
+ if (is_immutable_vector(fv))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->float_vector_set_symbol, fv));
+ index = cadr(args);
+ if (!s7_is_integer(index))
+ return(method_or_bust(sc, index, sc->float_vector_set_symbol, args, sc->type_names[T_INTEGER], 2));
+ ind = s7_integer_clamped_if_gmp(sc, index);
+ if ((ind < 0) || (ind >= vector_length(fv)))
+ out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string);
+ value = caddr(args);
+ if (!is_real(value))
+ return(method_or_bust(sc, value, sc->float_vector_set_symbol, args, sc->type_names[T_REAL], 3));
+ float_vector(fv, ind) = s7_real(value);
+ return(value);
+}
+
+static s7_pointer g_fv_set_unchecked(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer fv, value = caddr(args);
+ s7_int ind;
+ if (!is_real(value))
+ wrong_type_error_nr(sc, sc->float_vector_set_symbol, 3, value, sc->type_names[T_REAL]);
+ fv = car(args);
+ if (is_immutable_vector(fv))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->float_vector_set_symbol, fv));
+ ind = s7_integer_clamped_if_gmp(sc, cadr(args));
+ float_vector(fv, ind) = s7_real(value);
+ return(value);
+}
+
+static bool find_matching_ref(s7_scheme *sc, const s7_pointer getter, s7_pointer expr)
+{
+ /* expr: (*set! v i val), val exists (i.e. args=3, so cddddr is null) */
+ s7_pointer v = cadr(expr), ind = caddr(expr);
+ if ((is_symbol(v)) && (!is_pair(ind)))
+ {
+ 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);
+ }}
+ return(false);
+}
+
+static s7_pointer float_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if (args == 3)
+ return((find_matching_ref(sc, sc->float_vector_ref_symbol, expr)) ? sc->fv_set_unchecked : sc->fv_set_3);
+ return(f);
+}
+
+static s7_double float_vector_set_d_7pid_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i, s7_double x) {float_vector(v, i) = x; return(x);}
+
+static s7_int set_check_index(s7_scheme *sc, s7_pointer v, s7_int i)
+{
+ if ((i < 0) || (i >= vector_length(v)))
+ out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(i);
+}
+
+static s7_double float_vector_set_d_7pid(s7_scheme *sc, s7_pointer v, s7_int i, s7_double x) {float_vector(v, (set_check_index(sc, v, i))) = x; return(x);}
+
+static s7_double float_vector_set_d_7piid(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_double x)
+{
+ if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
+ out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
+ out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string);
+ float_vector(v, i2 + (i1 * vector_offset(v, 0))) = x;
+ return(x);
+}
+
+static s7_double float_vector_set_d_7piiid(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3, s7_double x)
+{ /* uncallable? */
+ if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
+ out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
+ out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string);
+ if ((i3 < 0) || (i3 >= vector_dimension(v, 2)))
+ out_of_range_error_nr(sc, sc->float_vector_set_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? it_is_negative_string : it_is_too_large_string);
+ float_vector(v, i3 + (i2 * vector_offset(v, 1)) + (i1 * vector_offset(v, 0))) = x;
+ return(x);
+}
+
+static s7_pointer float_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p)
+{
+ float_vector(v, i) = real_to_double(sc, p, "float-vector-set!");
+ return(p);
+}
+
+
+/* -------------------------------- int-vector-ref -------------------------------- */
+static s7_pointer g_int_vector_ref(s7_scheme *sc, s7_pointer args)
+{
+ #define H_int_vector_ref "(int-vector-ref v ...) returns an element of the int-vector v."
+ #define Q_int_vector_ref s7_make_circular_signature(sc, 2, 3, \
+ s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_int_vector_symbol), \
+ sc->is_int_vector_symbol, sc->is_integer_symbol)
+ return(univect_ref(sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR));
+}
+
+static s7_int int_vector_ref_i_pi_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i) {return(int_vector(v, i));}
+static s7_pointer int_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer v, s7_int i) {return(make_integer(sc, int_vector(v, i)));}
+static s7_pointer int_vector_ref_p_pi_direct_wrapped(s7_scheme *sc, s7_pointer v, s7_int i) {return(wrap_integer(sc, int_vector(v, i)));}
+
+static s7_int int_vector_ref_i_7pi(s7_scheme *sc, s7_pointer v, s7_int i)
+{
+ if ((i < 0) || (i >= vector_length(v)))
+ out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(int_vector(v, i));
+}
+
+static s7_int int_vector_ref_i_7pii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2)
+{
+ if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
+ out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
+ out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(int_vector(v, i2 + (i1 * vector_offset(v, 0))));
+}
+
+static s7_int int_vector_ref_i_7piii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3)
+{
+ if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
+ out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
+ out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string);
+ if ((i3 < 0) || (i3 >= vector_dimension(v, 2)))
+ out_of_range_error_nr(sc, sc->int_vector_ref_symbol, small_int(4), wrap_integer(sc, i3), (i3 < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(int_vector(v, i3 + (i2 * vector_offset(v, 1)) + (i1 * vector_offset(v, 0))));
+}
+
+static inline s7_pointer int_vector_ref_p_pp(s7_scheme *sc, s7_pointer v, s7_pointer index)
+{
+ s7_int ind;
+ if (!is_int_vector(v))
+ return(method_or_bust_pp(sc, v, sc->int_vector_ref_symbol, v, index, sc->type_names[T_INT_VECTOR], 1));
+ if (vector_rank(v) != 1)
+ return(univect_ref(sc, set_plist_2(sc, v, index), sc->int_vector_ref_symbol, T_INT_VECTOR));
+ if (!s7_is_integer(index))
+ return(method_or_bust_pp(sc, index, sc->int_vector_ref_symbol, v, index, sc->type_names[T_INTEGER], 2));
+ ind = s7_integer_clamped_if_gmp(sc, index);
+ if ((ind < 0) || (ind >= vector_length(v)))
+ out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(make_integer(sc, int_vector(v, ind)));
+}
+
+static s7_pointer g_iv_ref_2(s7_scheme *sc, s7_pointer args) {return(int_vector_ref_p_pp(sc, car(args), cadr(args)));}
+
+static s7_pointer g_iv_ref_3(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer iv = car(args), index;
+ s7_int ind1, ind2;
+ if (!is_int_vector(iv))
+ return(method_or_bust(sc, iv, sc->int_vector_ref_symbol, args, sc->type_names[T_INT_VECTOR], 1));
+ if (vector_rank(iv) != 2)
+ return(univect_ref(sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR));
+ index = cadr(args);
+ if (!s7_is_integer(index))
+ return(method_or_bust(sc, index, sc->int_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2));
+ ind1 = s7_integer_clamped_if_gmp(sc, index);
+ if ((ind1 < 0) || (ind1 >= vector_dimension(iv, 0)))
+ out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, index, (ind1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ index = caddr(args);
+ if (!s7_is_integer(index))
+ return(method_or_bust(sc, index, sc->int_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3));
+ ind2 = s7_integer_clamped_if_gmp(sc, index);
+ if ((ind2 < 0) || (ind2 >= vector_dimension(iv, 1)))
+ out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_three, index, (ind2 < 0) ? it_is_negative_string : it_is_too_large_string);
+ ind1 = ind1 * vector_offset(iv, 0) + ind2;
+ return(make_integer(sc, int_vector(iv, ind1)));
+}
+
+static s7_pointer int_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ return((args == 2) ? sc->iv_ref_2 : ((args == 3) ? sc->iv_ref_3 : f));
+}
+
+
+/* -------------------------------- int-vector-set! -------------------------------- */
+static s7_pointer g_int_vector_set(s7_scheme *sc, s7_pointer args)
+{
+ #define H_int_vector_set "(int-vector-set! v i ... value) sets the i-th element of the int-vector v to value."
+ #define Q_int_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol)
+ return(univect_set(sc, args, sc->int_vector_set_symbol, T_INT_VECTOR));
+}
+
+static s7_int int_vector_set_i_7pii_direct(s7_scheme *unused_sc, s7_pointer v, s7_int i, s7_int x) {int_vector(v, i) = x; return(x);}
+
+static s7_pointer int_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer v, s7_int i, s7_pointer p)
+{
+ int_vector(v, i) = s7_integer_clamped_if_gmp(sc, p);
+ return(p);
+}
+
+static s7_int int_vector_set_i_7pii(s7_scheme *sc, s7_pointer v, s7_int i, s7_int x)
+{
+ if ((i < 0) || (i >= vector_length(v)))
+ out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, i), (i < 0) ? it_is_negative_string : it_is_too_large_string);
+ int_vector(v, i) = x;
+ return(x);
+}
+
+static s7_int int_vector_set_i_7piii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3)
+{
+ if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
+ out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
+ out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string);
+ int_vector(v, i2 + (i1 * vector_offset(v, 0))) = i3;
+ return(i3);
+}
+
+static s7_pointer int_vector_set_p_ppp(s7_scheme *sc, s7_pointer v, s7_pointer index, s7_pointer val)
+{
+ if ((is_int_vector(v)) && (vector_rank(v) == 1) && (!is_immutable_vector(v)) &&
+ (is_t_integer(index)) && (is_t_integer(val)))
+ {
+ 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);
+ 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));
+ if (vector_rank(v) != 1)
+ 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));
+ /* (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));
+ 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));
+#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);
+ }
+#else
+ if (S7_DEBUGGING) fprintf(stderr, "fell through %s[%d]\n", __func__, __LINE__);
+#endif
+ }
+ return(val);
+}
+
+static s7_pointer g_iv_set_3(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer v = car(args), index, value;
+ s7_int ind;
+ if (!is_int_vector(v))
+ return(method_or_bust(sc, v, sc->int_vector_set_symbol, args, sc->type_names[T_INT_VECTOR], 1));
+ if (vector_rank(v) != 1)
+ return(univect_set(sc, args, 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));
+ index = cadr(args);
+ if (!s7_is_integer(index))
+ return(method_or_bust(sc, index, sc->int_vector_set_symbol, args, sc->type_names[T_INTEGER], 2));
+ ind = s7_integer_clamped_if_gmp(sc, index);
+ if ((ind < 0) || (ind >= vector_length(v)))
+ out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string);
+ value = caddr(args);
+ if (!s7_is_integer(value))
+ return(method_or_bust(sc, value, sc->int_vector_set_symbol, args, sc->type_names[T_INTEGER], 3));
+ int_vector(v, ind) = s7_integer_clamped_if_gmp(sc, value);
+ return(value);
+}
+
+static s7_pointer int_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ return((args == 3) ? sc->iv_set_3 : f);
+}
+
+
+/* -------------------------------- byte-vector-ref -------------------------------- */
+static s7_pointer g_byte_vector_ref(s7_scheme *sc, s7_pointer args)
+{
+ #define H_byte_vector_ref "(byte-vector-ref vect index) returns the byte at the index-th element of the byte-vector vect"
+ #define Q_byte_vector_ref s7_make_circular_signature(sc, 2, 3, \
+ s7_make_signature(sc, 2, sc->is_byte_symbol, sc->is_byte_vector_symbol), \
+ sc->is_byte_vector_symbol, sc->is_integer_symbol)
+ return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR));
+}
+
+static s7_int byte_vector_ref_i_7pi(s7_scheme *sc, s7_pointer p1, s7_int i1)
+{
+ if ((i1 < 0) || (i1 >= byte_vector_length(p1)))
+ out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ return((s7_int)((byte_vector(p1, i1))));
+}
+
+static s7_int byte_vector_ref_i_7pii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2)
+{
+ if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
+ out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
+ out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string);
+ return((s7_int)byte_vector(v, i2 + (i1 * vector_offset(v, 0))));
+}
+
+static s7_pointer byte_vector_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1) {return(small_int((byte_vector(p1, i1))));}
+static s7_int byte_vector_ref_i_7pi_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1) {return(byte_vector(p1, i1));}
+
+static s7_pointer g_bv_ref_2(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer v = car(args), index;
+ s7_int ind;
+ if (!is_byte_vector(v))
+ return(method_or_bust(sc, v, sc->byte_vector_ref_symbol, args, sc->type_names[T_BYTE_VECTOR], 1));
+ if (vector_rank(v) != 1)
+ return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR));
+ index = cadr(args);
+ if (!s7_is_integer(index))
+ return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2));
+ ind = s7_integer_clamped_if_gmp(sc, index);
+ if ((ind < 0) || (ind >= vector_length(v)))
+ out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string);
+ return(small_int(byte_vector(v, ind)));
+}
+
+static s7_pointer g_bv_ref_3(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer iv = car(args), index;
+ s7_int ind1, ind2;
+ if (!is_byte_vector(iv))
+ return(method_or_bust(sc, iv, sc->byte_vector_ref_symbol, args, sc->type_names[T_BYTE_VECTOR], 1));
+ if (vector_rank(iv) != 2)
+ return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR));
+ index = cadr(args);
+ if (!s7_is_integer(index))
+ return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 2));
+ ind1 = s7_integer_clamped_if_gmp(sc, index);
+ if ((ind1 < 0) || (ind1 >= vector_dimension(iv, 0)))
+ out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, index, (ind1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ index = caddr(args);
+ if (!s7_is_integer(index))
+ return(method_or_bust(sc, index, sc->byte_vector_ref_symbol, args, sc->type_names[T_INTEGER], 3));
+ ind2 = s7_integer_clamped_if_gmp(sc, index);
+ if ((ind2 < 0) || (ind2 >= vector_dimension(iv, 1)))
+ out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_three, index, (ind2 < 0) ? it_is_negative_string : it_is_too_large_string);
+ ind1 = ind1 * vector_offset(iv, 0) + ind2;
+ return(small_int(byte_vector(iv, ind1)));
+}
+
+static s7_pointer byte_vector_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ return((args == 2) ? sc->bv_ref_2 : ((args == 3) ? sc->bv_ref_3 : f));
+}
+
+
+/* -------------------------------- byte-vector-set -------------------------------- */
+static s7_pointer g_byte_vector_set(s7_scheme *sc, s7_pointer args)
+{
+ #define H_byte_vector_set "(byte-vector-set! vect index byte) sets the index-th element of the byte-vector vect to the integer byte"
+ #define Q_byte_vector_set s7_make_circular_signature(sc, 2, 3, sc->is_byte_symbol, sc->is_byte_vector_symbol, sc->is_integer_symbol)
+ return(univect_set(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR));
+}
+
+static s7_int byte_vector_set_i_7pii(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_int i2)
+{
+ if (!is_byte_vector(p1))
+ wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 1, p1, a_byte_vector_string);
+ if ((i2 < 0) || (i2 > 255))
+ wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, wrap_integer(sc, i2), an_unsigned_byte_string);
+ if ((i1 < 0) || (i1 >= byte_vector_length(p1)))
+ out_of_range_error_nr(sc, sc->byte_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ byte_vector(p1, i1) = (uint8_t)i2;
+ return(i2);
+}
+
+static s7_int byte_vector_set_i_7pii_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1, s7_int i2)
+{
+ byte_vector(p1, i1) = (uint8_t)i2; return(i2);
+}
+
+static s7_pointer byte_vector_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer p1, s7_int i1, s7_pointer p2)
+{ /* uncallable */
+ byte_vector(p1, i1) = (uint8_t)s7_integer(p2); return(p2);
+}
+
+static s7_int byte_vector_set_i_7piii(s7_scheme *sc, s7_pointer v, s7_int i1, s7_int i2, s7_int i3)
+{
+ if ((i3 < 0) || (i3 > 255))
+ wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 4, wrap_integer(sc, i3), an_unsigned_byte_string);
+ if ((i1 < 0) || (i1 >= vector_dimension(v, 0)))
+ out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, i1), (i1 < 0) ? it_is_negative_string : it_is_too_large_string);
+ if ((i2 < 0) || (i2 >= vector_dimension(v, 1)))
+ out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_three, wrap_integer(sc, i2), (i2 < 0) ? it_is_negative_string : it_is_too_large_string);
+ byte_vector(v, i2 + (i1 * vector_offset(v, 0))) = i3;
+ return(i3);
+}
+
+static s7_pointer g_bv_set_3(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer v = car(args), index, value;
+ s7_int ind, uval;
+ if (!is_byte_vector(v))
+ return(method_or_bust(sc, v, sc->byte_vector_set_symbol, args, sc->type_names[T_BYTE_VECTOR], 1));
+ if (vector_rank(v) != 1)
+ return(univect_set(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR));
+ if (is_immutable_vector(v))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->byte_vector_set_symbol, v));
+ index = cadr(args);
+ if (!s7_is_integer(index))
+ return(method_or_bust(sc, index, sc->byte_vector_set_symbol, args, sc->type_names[T_INTEGER], 2));
+ ind = s7_integer_clamped_if_gmp(sc, index);
+ if ((ind < 0) || (ind >= vector_length(v)))
+ out_of_range_error_nr(sc, sc->byte_vector_set_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string);
+ value = caddr(args);
+ if (!s7_is_integer(value))
+ return(method_or_bust(sc, value, sc->byte_vector_set_symbol, args, sc->type_names[T_INTEGER], 3));
+ uval = s7_integer_clamped_if_gmp(sc, value);
+ if ((uval < 0) || (uval > 255))
+ wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, value, an_unsigned_byte_string);
+ byte_vector(v, ind) = (uint8_t)uval;
+ return(value);
+}
+
+static s7_pointer byte_vector_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ return((args == 3) ? sc->bv_set_3 : f);
+}
+
+
+/* -------------------------------------------------------------------------------- */
+static bool c_function_is_ok(s7_scheme *sc, s7_pointer x)
+{
+ s7_pointer p = lookup_unexamined(sc, car(x)); /* lookup_global is usually slower (faster in Snd) */
+ if ((p == opt1_cfunc(x)) ||
+ ((p) && (is_any_c_function(p)) && (c_function_class(p) == c_function_class(opt1_cfunc(x))) && (set_opt1_cfunc(x, p))))
+ return(true);
+ sc->last_function = p;
+ return(false);
+}
+
+static bool cl_function_is_ok(s7_scheme *sc, s7_pointer x)
+{
+ sc->last_function = lookup_unexamined(sc, car(x));
+ return(sc->last_function == opt1_cfunc(x));
+}
+
+static bool arglist_has_rest(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p;
+ for (p = args; is_pair(p); p = cdr(p))
+ if (car(p) == sc->rest_keyword)
+ return(true);
+ return(!is_null(p));
+}
+
+
+/* -------------------------------- sort! -------------------------------- */
+static int32_t dbl_less(const void *f1, const void *f2)
+{
+ if ((*((const s7_double *)f1)) < (*((const s7_double *)f2))) return(-1);
+ return(((*((const s7_double *)f1)) > (*((const s7_double *)f2))) ? 1 : 0);
+}
+
+static int32_t int_less(const void *f1, const void *f2)
+{
+ if ((*((const s7_int *)f1)) < (*((const s7_int *)f2))) return(-1);
+ return(((*((const s7_int *)f1)) > (*((const s7_int *)f2))) ? 1 : 0);
+}
+
+static int32_t dbl_greater(const void *f1, const void *f2) {return(-dbl_less(f1, f2));}
+static int32_t int_greater(const void *f1, const void *f2) {return(-int_less(f1, f2));}
+
+static int32_t byte_less(const void *f1, const void *f2)
+{
+ if ((*((const uint8_t *)f1)) < (*((const uint8_t *)f2))) return(-1);
+ return(((*((const uint8_t *)f1)) > (*((const uint8_t *)f2))) ? 1 : 0);
+}
+
+static int32_t byte_greater(const void *f1, const void *f2) {return(-byte_less(f1, f2));}
+
+static int32_t dbl_less_2(const void *f1, const void *f2)
+{
+ s7_double p1 = real(*((const s7_pointer *)f1));
+ s7_double p2 = real(*((const s7_pointer *)f2));
+ if (p1 < p2) return(-1);
+ return((p1 > p2) ? 1 : 0);
+}
+
+static int32_t int_less_2(const void *f1, const void *f2)
+{
+ s7_int p1 = integer(*((const s7_pointer *)f1));
+ s7_int p2 = integer(*((const s7_pointer *)f2));
+ if (p1 < p2) return(-1);
+ return((p1 > p2) ? 1 : 0);
+}
+
+static int32_t dbl_greater_2(const void *f1, const void *f2) {return(-dbl_less_2(f1, f2));}
+static int32_t int_greater_2(const void *f1, const void *f2) {return(-int_less_2(f1, f2));}
+
+static int32_t str_less_2(const void *f1, const void *f2)
+{
+ s7_pointer p1 = (*((const s7_pointer *)f1));
+ s7_pointer p2 = (*((const s7_pointer *)f2));
+ return(scheme_strcmp(p1, p2));
+}
+
+static int32_t str_greater_2(const void *f1, const void *f2) {return(-str_less_2(f1, f2));}
+
+static int32_t chr_less_2(const void *f1, const void *f2)
+{
+ uint8_t p1 = character(*((const s7_pointer *)f1));
+ uint8_t p2 = character(*((const s7_pointer *)f2));
+ if (p1 < p2) return(-1);
+ return((p1 > p2) ? 1 : 0);
+}
+
+static int32_t chr_greater_2(const void *f1, const void *f2) {return(-chr_less_2(f1, f2));}
+
+#if MS_WINDOWS || defined(__APPLE__) || defined(__FreeBSD__)
+struct sort_r_data {void *arg; int32_t (*compar)(const void *a1, const void *a2, void *aarg);};
+
+static int32_t sort_r_arg_swap(void *s, const void *aa, const void *bb)
+{
+ struct sort_r_data *ss = (struct sort_r_data*)s;
+ return (ss->compar)(aa, bb, ss->arg);
+}
+#endif
+
+/* qsort_r in Linux requires _GNU_SOURCE and is different from q_sort_r in FreeBSD, neither matches qsort_s in Windows
+ * this code tested only in Linux and the mac -- my virtualbox freebsd died, netbsd and openbsd run using fallback code.
+ *
+ * qsort_r allocates an internal array (msort.c line 221) if the original array is > 1024 elements (or whatever),
+ * then calls the sort comparison function in a loop, after which it frees its temporary array. This is an unavoidable
+ * memory leak if the comparison function calls s7_error (or its equivalent) which longjmps to the nearest catch
+ * (or, sigh, segfaults if none exists). I can't see any way to hack around this memory leak -- don't raise
+ * an error in the sort function!
+ */
+static void local_qsort_r(void *base, size_t nmemb, size_t size, int32_t (*compar)(const void *, const void *, void *), void *arg)
+{
+#if (defined(__linux__)) && (defined(__GLIBC__)) /* __GLIBC__ because musl does not have qsort_r and has no way to detect it */
+ qsort_r(base, nmemb, size, compar, arg);
+#else
+#if defined(__APPLE__) || defined(__FreeBSD__) /* not in OpenBSD or NetBSD as far as I can tell */
+ struct sort_r_data tmp = {arg, compar};
+ qsort_r(base, nmemb, size, &tmp, &sort_r_arg_swap);
+#else
+#if MS_WINDOWS
+ struct sort_r_data tmp = {arg, compar};
+ qsort_s(base, nmemb, size, sort_r_arg_swap, &tmp);
+#else
+ /* from the Net somewhere, by "Pete", about 25 times slower than libc's qsort_r in this context */
+ if (nmemb > 1)
+ {
+ uint8_t *array = (uint8_t *)base;
+ uint8_t *after = (uint8_t *)(nmemb * size + array);
+ size_t h, t;
+ nmemb /= 4;
+ h = nmemb + 1;
+ for (t = 1; nmemb != 0; nmemb /= 4)
+ 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;
+ } while (t != 0);
+ }
+#endif
+#endif
+#endif
+}
+
+static int32_t vector_sort(const void *v1, const void *v2, void *arg)
+{
+ s7_scheme *sc = (s7_scheme *)arg;
+ return(((*(sc->sort_f))(sc, (*(const s7_pointer *)v1), (*(const s7_pointer *)v2))) ? -1 : 1);
+}
+
+static int32_t vector_sort_lt(const void *v1, const void *v2, void *arg) /* for qsort_r */
+{
+ s7_pointer s1 = (*(const s7_pointer *)v1);
+ s7_pointer s2 = (*(const s7_pointer *)v2);
+ if ((is_t_integer(s1)) && (is_t_integer(s2)))
+ return((integer(s1) < integer(s2)) ? -1 : 1);
+ return((lt_b_7pp((s7_scheme *)arg, s1, s2)) ? -1 : 1);
+}
+
+static int32_t vector_car_sort(const void *v1, const void *v2, void *arg)
+{
+ s7_scheme *sc = (s7_scheme *)arg;
+ s7_pointer a = (*(const s7_pointer *)v1);
+ s7_pointer b = (*(const s7_pointer *)v2);
+ a = (is_pair(a)) ? car(a) : g_car(sc, set_plist_1(sc, a));
+ b = (is_pair(b)) ? car(b) : g_car(sc, set_plist_1(sc, b));
+ return(((*(sc->sort_f))(sc, a, b)) ? -1 : 1);
+}
+
+static int32_t vector_cdr_sort(const void *v1, const void *v2, void *arg)
+{
+ s7_scheme *sc = (s7_scheme *)arg;
+ s7_pointer a = (*(const s7_pointer *)v1);
+ s7_pointer b = (*(const s7_pointer *)v2);
+ a = (is_pair(a)) ? cdr(a) : g_cdr(sc, set_plist_1(sc, a));
+ b = (is_pair(b)) ? cdr(b) : g_cdr(sc, set_plist_1(sc, b));
+ return(((*(sc->sort_f))(sc, a, b)) ? -1 : 1);
+}
+
+static int32_t opt_bool_sort(const void *v1, const void *v2, void *arg)
+{
+ s7_scheme *sc = (s7_scheme *)arg;
+ slot_set_value(sc->sort_v1, (*(const s7_pointer *)v1)); /* first slot in curlet */
+ slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2)); /* second slot in curlet */
+ return((sc->sort_fb(sc->sort_o)) ? -1 : 1);
+}
+
+static int32_t opt_bool_sort_0(const void *v1, const void *v2, void *arg)
+{
+ s7_scheme *sc = (s7_scheme *)arg;
+ slot_set_value(sc->sort_v1, (*(const s7_pointer *)v1)); /* first slot in curlet */
+ slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2)); /* second slot in curlet */
+ return((sc->sort_fb(sc->sort_o)) ? -1 : 1);
+}
+
+static int32_t opt_bool_sort_p(const void *v1, const void *v2, void *arg)
+{
+ s7_scheme *sc = (s7_scheme *)arg;
+ slot_set_value(sc->sort_v1, (*(const s7_pointer *)v1));
+ slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2));
+ return((sc->opts[0]->v[O_WRAP].fp(sc->opts[0]) == sc->F) ? 1 : -1);
+}
+
+#define SORT_O1 1
+static inline int32_t begin_bool_sort_bp(s7_scheme *sc, const void *v1, const void *v2, bool int_expr)
+{
+ s7_int i;
+ opt_info *top = sc->opts[0], *o;
+ slot_set_value(sc->sort_v1, (*(const s7_pointer *)v1));
+ slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2));
+ for (i = 0; i < sc->sort_body_len - 1; i++)
+ {
+ o = top->v[SORT_O1 + i].o1;
+ o->v[0].fp(o);
+ }
+ o = top->v[SORT_O1 + i].o1;
+ if (int_expr)
+ return((o->v[0].fb(o)) ? -1 : 1);
+ return((o->v[0].fp(o) != sc->F) ? -1 : 1);
+}
+
+static int32_t opt_begin_bool_sort_b(const void *v1, const void *v2, void *arg) {return(begin_bool_sort_bp((s7_scheme *)arg, v1, v2, true));}
+static int32_t opt_begin_bool_sort_p(const void *v1, const void *v2, void *arg) {return(begin_bool_sort_bp((s7_scheme *)arg, v1, v2, false));}
+
+static int32_t opt_begin_bool_sort_b2(const void *v1, const void *v2, void *arg)
+{
+ s7_scheme *sc = (s7_scheme *)arg;
+ opt_info *top = sc->opts[0], *o;
+ slot_set_value(sc->sort_v1, (*(const s7_pointer *)v1));
+ slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2));
+ o = top->v[SORT_O1].o1;
+ o->v[0].fp(o);
+ o = top->v[SORT_O1 + 1].o1;
+ return((o->v[0].fb(o)) ? -1 : 1);
+}
+
+static int32_t closure_sort(const void *v1, const void *v2, void *arg)
+{
+ s7_scheme *sc = (s7_scheme *)arg;
+ slot_set_value(sc->sort_v1, (*(const s7_pointer *)v1));
+ slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2));
+ push_stack(sc, OP_EVAL_DONE, sc->sort_body, sc->code);
+ sc->code = sc->sort_body; /* this should be ok because we checked in advance that it is a safe closure (no sort! for example) */
+ eval(sc, sc->sort_op);
+ return((sc->value != sc->F) ? -1 : 1);
+}
+
+static int32_t closure_sort_begin(const void *v1, const void *v2, void *arg)
+{
+ s7_scheme *sc = (s7_scheme *)arg;
+ slot_set_value(sc->sort_v1, (*(const s7_pointer *)v1));
+ slot_set_value(sc->sort_v2, (*(const s7_pointer *)v2));
+ push_stack(sc, OP_EVAL_DONE, sc->sort_body, sc->code);
+ push_stack_no_args(sc, OP_BEGIN_NO_HOOK, T_Pair(sc->sort_begin));
+ sc->code = sc->sort_body;
+ eval(sc, sc->sort_op);
+ return((sc->value != sc->F) ? -1 : 1);
+}
+
+static s7_b_7pp_t s7_b_7pp_function(s7_pointer f);
+static opt_info *alloc_opt_info(s7_scheme *sc);
+static bool bool_optimize(s7_scheme *sc, s7_pointer expr);
+static bool bool_optimize_nw(s7_scheme *sc, s7_pointer expr);
+static bool cell_optimize(s7_scheme *sc, s7_pointer expr);
+
+static s7_pointer g_sort(s7_scheme *sc, s7_pointer args)
+{
+ #define H_sort "(sort! sequence less?) sorts a sequence using the function 'less?' to compare elements."
+ #define Q_sort s7_make_signature(sc, 3, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_procedure_symbol)
+
+ s7_pointer data = car(args), lessp, lx;
+ s7_int len = 0, n, k;
+ int32_t (*sort_func)(const void *v1, const void *v2, void *arg);
+ s7_pointer *elements;
+
+ /* both the intermediate vector (if any) and the current args pointer need GC protection,
+ * but it is a real bother to unprotect args at every return statement, so I'll use temp3
+ */
+ sc->temp3 = args; /* this is needed but maybe insufficient... if sort is semisafe, we should protect the args, not the list: use OP_GC_PROTECT? */
+ if (is_null(data))
+ {
+ /* (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));
+ if (!s7_is_aritable(sc, lessp, 2))
+ wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, an_eq_func_string);
+ return(sc->nil);
+ }
+
+ if (!is_sequence(data)) /* precede immutable because #f (for example) is immutable: "can't sort #f because it is immutable" is a joke */
+ wrong_type_error_nr(sc, sc->sort_symbol, 1, data, a_sequence_string);
+ if (is_immutable(data))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->sort_symbol, data));
+
+ lessp = cadr(args);
+ if (type(lessp) <= T_GOTO)
+ wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, a_normal_procedure_string);
+ if (!s7_is_aritable(sc, lessp, 2))
+ wrong_type_error_nr(sc, sc->sort_symbol, 2, lessp, an_eq_func_string);
+ if ((is_any_macro(lessp)) && (!is_c_macro(lessp))) clear_all_optimizations(sc, closure_body(lessp));
+
+ sort_func = NULL;
+ sc->sort_f = NULL;
+
+ if (is_safe_c_function(lessp)) /* (sort! a <) */
+ {
+ 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));
+ 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));
+ }}}}
+
+ 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));
+ if (len < 2)
+ 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);
+ }
+ 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;
+
+ 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);
+ }
+ 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;
+ }
+ break;
+
+ case T_VECTOR:
+ len = vector_length(data);
+ if (len < 2)
+ 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);
+ }
+ break;
+
+ default:
+ return(method_or_bust(sc, data, sc->sort_symbol, args, wrap_string(sc, "a sortable sequence", 19), 1));
+ }
+
+ n = len - 1;
+ k = (n / 2) + 1;
+ lx = make_simple_vector(sc, (sc->safety <= NO_SAFETY) ? 4 : 6);
+ t_vector_fill(lx, sc->nil); /* make_mutable_integer below can trigger GC, so all elements of lx must be legit */
+ init_temp(sc->y, lx);
+ vector_element(lx, 0) = make_mutable_integer(sc, n);
+ vector_element(lx, 1) = make_mutable_integer(sc, k);
+ vector_element(lx, 2) = make_mutable_integer(sc, 0);
+ vector_element(lx, 3) = make_mutable_integer(sc, 0);
+ if (sc->safety > NO_SAFETY)
+ {
+ vector_element(lx, 4) = make_mutable_integer(sc, 0);
+ vector_element(lx, 5) = make_integer_unchecked(sc, n * n);
+ }
+ push_stack(sc, OP_SORT, args, lx);
+ sc->y = sc->unused;
+ return(sc->F);
+ /* if the comparison function waffles, sort! can hang: (sort! '(1 2 3) (lambda (a b) (= a b)))
+ * set 'safety to 1 to add a check for this loop, but the "safe" procedures are direct, so unchecked.
+ */
+}
+
+/* these are for the eval sort -- sort a vector, then if necessary put that data into the original sequence */
+static s7_pointer vector_into_list(s7_scheme *sc, s7_pointer vect, s7_pointer lst)
+{
+ s7_pointer *elements = vector_elements(vect);
+ s7_int i = 0, len = vector_length(vect);
+ 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));
+ set_car(p, elements[i]);
+ }
+ return(lst);
+}
+
+static s7_pointer vector_into_fi_vector(s7_pointer source, s7_pointer dest)
+{
+ s7_pointer *elements = vector_elements(source);
+ s7_int len = vector_length(source);
+ 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]);
+ }
+ else
+ {
+ s7_int *ints = int_vector_ints(dest);
+ for (s7_int i = 0; i < len; i++) ints[i] = integer(elements[i]);
+ }
+ return(dest);
+}
+
+static s7_pointer vector_into_string(s7_pointer vect, s7_pointer dest)
+{
+ s7_pointer *elements = vector_elements(vect);
+ s7_int len = vector_length(vect);
+ 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]);
+ }
+ else
+ {
+ uint8_t *str = (uint8_t *)string_value(dest);
+ for (s7_int i = 0; i < len; i++) str[i] = character(elements[i]);
+ }
+ return(dest);
+}
+
+#define SORT_N integer(vector_element(sc->code, 0))
+#define SORT_K integer(vector_element(sc->code, 1))
+#define SORT_J integer(vector_element(sc->code, 2))
+#define SORT_K1 integer(vector_element(sc->code, 3))
+#define SORT_CALLS integer(vector_element(sc->code, 4))
+#define SORT_STOP integer(vector_element(sc->code, 5))
+#define SORT_DATA(K) vector_element(car(sc->args), K)
+#define SORT_LESSP cadr(sc->args)
+
+static s7_pointer op_heapsort(s7_scheme *sc)
+{
+ s7_int n = SORT_N, j, k = SORT_K1;
+
+ if ((n == k) || (k > ((s7_int)(n / 2)))) /* k == n == 0 is the first case */
+ return(sc->code);
+ if (sc->safety > NO_SAFETY)
+ {
+ 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));
+ }
+ j = 2 * k;
+ SORT_J = j;
+ if (j < n)
+ {
+ 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));
+ else sc->args = with_list_t2(SORT_DATA(j), SORT_DATA(j + 1));
+ sc->code = lx;
+ sc->value = sc->T; /* for eval */
+ }
+ else sc->value = sc->F;
+ return(NULL);
+}
+
+static bool op_sort1(s7_scheme *sc)
+{
+ s7_int j = SORT_J, k = SORT_K1;
+ s7_pointer lx = SORT_LESSP;
+ if (is_true(sc, sc->value))
+ {
+ j = j + 1;
+ SORT_J = j;
+ }
+ push_stack_direct(sc, OP_SORT2);
+ if (needs_copied_args(lx))
+ sc->args = list_2(sc, SORT_DATA(k), SORT_DATA(j));
+ else sc->args = with_list_t2(SORT_DATA(k), SORT_DATA(j));
+ sc->code = lx;
+ return(false);
+}
+
+static bool op_sort2(s7_scheme *sc)
+{
+ s7_int j = SORT_J, k = SORT_K1;
+ if (is_true(sc, sc->value))
+ {
+ s7_pointer lx = SORT_DATA(j);
+ SORT_DATA(j) = SORT_DATA(k);
+ SORT_DATA(k) = lx;
+ }
+ else return(true);
+ SORT_K1 = SORT_J;
+ return(false);
+}
+
+static bool op_sort(s7_scheme *sc)
+{
+ /* coming in sc->args is sort args (data less?), sc->code = #(n k 0 ...)
+ * here we call the inner loop until k <= 0 [the local k! -- this is tricky because scheme passes args by value]
+ */
+ s7_int k = SORT_K;
+ if (k > 0)
+ {
+ SORT_K = k - 1;
+ SORT_K1 = k - 1;
+ push_stack_direct(sc, OP_SORT);
+ return(false);
+ }
+ return(true);
+}
+
+static bool op_sort3(s7_scheme *sc)
+{
+ s7_int n = SORT_N;
+ s7_pointer lx;
+ if (n <= 0)
+ {
+ sc->value = car(sc->args);
+ return(true);
+ }
+ lx = SORT_DATA(0);
+ SORT_DATA(0) = SORT_DATA(n);
+ SORT_DATA(n) = lx;
+ SORT_N = n - 1;
+ SORT_K1 = 0;
+ push_stack_direct(sc, OP_SORT3);
+ return(false);
+}
+
+
+/* -------- hash tables -------- */
+
+static void free_hash_table(s7_scheme *sc, s7_pointer table)
+{
+ if (hash_table_entries(table) > 0)
+ {
+ 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);
+ }}}
+ liberate(sc, hash_table_block(table));
+}
+
+static hash_entry_t *make_hash_entry(s7_scheme *sc, s7_pointer key, s7_pointer value, s7_int raw_hash)
+{
+ hash_entry_t *p = (hash_entry_t *)mallocate_block(sc);
+ hash_entry_key(p) = key;
+ hash_entry_set_value(p, value);
+ hash_entry_set_raw_hash(p, raw_hash);
+ return(p);
+}
+
+
+/* -------------------------------- hash-table? -------------------------------- */
+bool s7_is_hash_table(s7_pointer p) {return(is_hash_table(p));}
+
+static s7_pointer g_is_hash_table(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_hash_table "(hash-table? obj) returns #t if obj is a hash-table"
+ #define Q_is_hash_table sc->pl_bt
+ check_boolean_method(sc, is_hash_table, sc->is_hash_table_symbol, args);
+}
+
+
+/* -------------------------------- hash-table-entries -------------------------------- */
+static s7_pointer g_hash_table_entries(s7_scheme *sc, s7_pointer args)
+{
+ #define H_hash_table_entries "(hash-table-entries obj) returns the number of entries in the hash-table obj"
+ #define Q_hash_table_entries s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_hash_table_symbol)
+
+ if (!is_hash_table(car(args)))
+ return(sole_arg_method_or_bust(sc, car(args), sc->hash_table_entries_symbol, args, sc->type_names[T_HASH_TABLE]));
+ return(make_integer(sc, hash_table_entries(car(args))));
+}
+
+static s7_int hash_table_entries_i_7p(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_hash_table(p))
+ return(integer(method_or_bust_p(sc, p, sc->hash_table_entries_symbol, sc->type_names[T_HASH_TABLE])));
+ return(hash_table_entries(p));
+}
+
+
+/* -------------------------------- hash-table-key|value-typer -------------------------------- */
+static s7_pointer g_hash_table_key_typer(s7_scheme *sc, s7_pointer args)
+{
+ #define H_hash_table_key_typer "(hash-table-key-typer hash) returns the hash-table's key type checking function"
+ #define Q_hash_table_key_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_hash_table_symbol)
+
+ s7_pointer h = car(args);
+ if (!is_hash_table(h)) return(sole_arg_method_or_bust(sc, h, sc->hash_table_key_typer_symbol, args, sc->type_names[T_HASH_TABLE]));
+ if (is_typed_hash_table(h)) return(hash_table_key_typer(h));
+ return(sc->F);
+}
+
+static s7_pointer g_hash_table_value_typer(s7_scheme *sc, s7_pointer args)
+{
+ #define H_hash_table_value_typer "(hash-table-value-typer hash) returns the hash-table's value type checking function"
+ #define Q_hash_table_value_typer s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->not_symbol, sc->is_procedure_symbol), sc->is_hash_table_symbol)
+
+ s7_pointer h = car(args);
+ if (!is_hash_table(h)) return(sole_arg_method_or_bust(sc, h, sc->hash_table_value_typer_symbol, args, sc->type_names[T_HASH_TABLE]));
+ if (is_typed_hash_table(h)) return(hash_table_value_typer(h));
+ return(sc->F);
+}
+
+static s7_pointer make_hash_table_procedures(s7_scheme *sc)
+{
+ s7_pointer x = cons(sc, sc->T, sc->T); /* checker, mapped */
+ set_opt1_any(x, sc->T); /* key */
+ set_opt2_any(x, sc->T); /* value */
+ return(x);
+}
+
+static s7_pointer copy_hash_table_procedures(s7_scheme *sc, s7_pointer table)
+{
+ if (is_pair(hash_table_procedures(table)))
+ {
+ s7_pointer x = cons(sc, hash_table_procedures_checker(table), hash_table_procedures_mapper(table));
+ set_opt1_any(x, hash_table_key_typer(table));
+ set_opt2_any(x, hash_table_value_typer(table));
+ return(x);
+ }
+ return(sc->nil);
+}
+
+static void check_hash_table_typer(s7_scheme *sc, s7_pointer caller, s7_pointer h, s7_pointer typer)
+{
+ if (is_c_function(typer))
+ {
+ 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));
+ if (!c_function_name(typer))
+ 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));
+ 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));
+ }
+ 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));
+ 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));
+ 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 (is_null(hash_table_procedures(h)))
+ hash_table_set_procedures(h, make_hash_table_procedures(sc));
+ set_is_typed_hash_table(h);
+}
+
+static s7_pointer g_set_hash_table_key_typer(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer h = car(args), typer = cadr(args);
+
+ if (!is_hash_table(h))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! hash_table-key-typer", 25), 1, h, sc->type_names[T_HASH_TABLE]);
+ if (is_immutable_hash_table(h))
+ immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable so its key-typer can't be set!", 46), h));
+
+ 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);
+ }}
+ else
+ {
+ check_hash_table_typer(sc, sc->hash_table_key_typer_symbol, h, typer);
+ hash_table_set_key_typer(h, typer);
+ }
+ return(typer);
+}
+
+static s7_pointer g_set_hash_table_value_typer(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer h = car(args), typer = cadr(args);
+
+ if (!is_hash_table(h))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! hash_table-value-typer", 27), 1, h, sc->type_names[T_HASH_TABLE]);
+ if (is_immutable_hash_table(h))
+ immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable so its value-typer can't be set!", 48), h));
+
+ 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);
+ }}
+ else
+ {
+ check_hash_table_typer(sc, sc->hash_table_value_typer_symbol, h, typer);
+ hash_table_set_value_typer(h, typer);
+ }
+ return(typer);
+}
+
+
+/* ---------------- hash map and equality tables ---------------- */
+/* built in hash loc tables for eq? eqv? equal? equivalent? = string=? string-ci=? char=? char-ci=? (default=equal?) */
+#define hash_loc(Sc, Table, Key) (*(hash_table_mapper(Table)[type(Key)]))(Sc, Table, Key)
+
+static hash_map_t eq_hash_map[NUM_TYPES];
+static hash_map_t string_eq_hash_map[NUM_TYPES];
+static hash_map_t char_eq_hash_map[NUM_TYPES];
+static hash_map_t closure_hash_map[NUM_TYPES];
+static hash_map_t equivalent_hash_map[NUM_TYPES];
+static hash_map_t c_function_hash_map[NUM_TYPES];
+#if (!WITH_PURE_S7)
+static hash_map_t string_ci_eq_hash_map[NUM_TYPES];
+static hash_map_t char_ci_eq_hash_map[NUM_TYPES];
+#endif
+/* also default_hash_map */
+
+
+/* ---------------- hash-code ---------------- */
+/* eqfunc handling which will require other dummy tables */
+
+static s7_pointer make_dummy_hash_table(s7_scheme *sc) /* make the absolute minimal hash-table that can support hash-code */
+{
+ s7_pointer table = alloc_pointer(sc);
+ set_type_bit(table, T_IMMUTABLE | T_HASH_TABLE | T_UNHEAP);
+ hash_table_mapper(table) = default_hash_map;
+ return(table);
+}
+
+s7_int s7_hash_code(s7_scheme *sc, s7_pointer obj, s7_pointer eqfunc)
+{
+ return(default_hash_map[type(obj)](sc, sc->dummy_equal_hash_table, obj));
+}
+
+static s7_pointer g_hash_code(s7_scheme *sc, s7_pointer args)
+{
+ #define H_hash_code "(hash-code obj (eqfunc)) returns an integer suitable for use as a hash code for obj."
+ #define Q_hash_code s7_make_signature(sc, 3, sc->is_integer_symbol, sc->T, sc->T)
+ s7_pointer obj = car(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)));
+ return(make_integer(sc, default_hash_map[type(obj)](sc, sc->dummy_equal_hash_table, obj)));
+}
+
+
+static bool (*equals[NUM_TYPES])(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci);
+static bool (*equivalents[NUM_TYPES])(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci);
+
+static hash_entry_t *(*default_hash_checks[NUM_TYPES])(s7_scheme *sc, s7_pointer table, s7_pointer key);
+static hash_entry_t *(*equal_hash_checks[NUM_TYPES])(s7_scheme *sc, s7_pointer table, s7_pointer key);
+
+
+/* ---------------- hash empty ---------------- */
+static hash_entry_t *hash_empty(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(sc->unentry);}
+
+/* ---------------- hash syntax ---------------- */
+static s7_int hash_map_syntax(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(pointer_map(syntax_symbol(key)));}
+
+static hash_entry_t *hash_equal_syntax(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ 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 */
+ return(x);
+ return(sc->unentry);
+}
+
+/* ---------------- hash symbols ---------------- */
+static s7_int hash_map_symbol(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(pointer_map(key));}
+
+static hash_entry_t *hash_symbol(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ for (hash_entry_t *x = hash_table_element(table, pointer_map(key) & hash_table_mask(table)); x; x = hash_entry_next(x))
+ if (key == hash_entry_key(x))
+ return(x);
+ return(sc->unentry);
+}
+
+
+/* ---------------- hash numbers ---------------- */
+static s7_int hash_map_int(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ return(s7_int_abs(integer(key)));
+}
+
+static s7_int hash_map_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ /* if numerator is -9223372036854775808, s7_int_abs overflows -- need to divide, then abs: -9223372036854775808/3: -3074457345618258602 3074457345618258602
+ * (s7_int)floorl(fabsl(fraction(key))) is no good here, 3441313796169221281/1720656898084610641: 1 2 (in valgrind),
+ * floor ratio is 1: (- (* 2 1720656898084610641) 3441313796169221281) -> 1
+ * or (gmp:) 1.999999999999999999418826611445214136431E0, so the floorl(fabsl) version is wrong
+ */
+ return(s7_int_abs(numerator(key) / denominator(key))); /* needs to be compatible with default-hash-table-float-epsilon which is unfortunate */
+}
+
+static s7_int hash_float_location(s7_double x)
+{
+ s7_double dx;
+ if ((is_NaN(x)) || (is_inf(x))) return(0);
+ dx = fabs(x);
+ if (dx > DOUBLE_TO_INT64_LIMIT) return(0);
+ return((s7_int)floor(dx));
+}
+ /* isnormal here in place of is_NaN and is_inf is slower.
+ * using x*100 to expand small float bin range runs afoul of the hash-table-float-epsilon bin calcs
+ */
+
+static s7_int hash_map_real(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ return(hash_float_location(real(key)));
+}
+
+static s7_int hash_map_complex(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ return(hash_float_location(real_part(key))/* + hash_float_location(imag_part(key)) */); /* imag-part confuses epsilon distance calcs */
+}
+
+#if WITH_GMP
+static s7_int hash_map_big_int(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ /* may need to use quotient here */
+ mpz_abs(sc->mpz_1, big_integer(key));
+ return(mpz_get_si(sc->mpz_1)); /* returns the bits that fit */
+}
+
+static s7_int hash_map_big_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ mpq_abs(sc->mpq_1, big_ratio(key));
+ mpz_fdiv_q(sc->mpz_1, mpq_numref(sc->mpq_1), mpq_denref(sc->mpq_1));
+ return(mpz_get_si(sc->mpz_1));
+}
+
+static s7_int hash_map_big_real_1(s7_scheme *sc, s7_pointer table, mpfr_t key)
+{
+ if ((mpfr_nan_p(key)) || (mpfr_inf_p(key))) return(0);
+ mpfr_abs(sc->mpfr_1, key, MPFR_RNDN);
+ /* mpfr_get_si returns most-positive-int if > 2^63! luckily there aren't any more of these */
+ mpfr_get_z(sc->mpz_1, sc->mpfr_1, MPFR_RNDD); /* floor not round */
+ return(mpz_get_si(sc->mpz_1));
+}
+
+static s7_int hash_map_big_real(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ return(hash_map_big_real_1(sc, table, big_real(key)));
+}
+
+static s7_int hash_map_big_complex(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ return(hash_map_big_real_1(sc, table, mpc_realref(big_complex(key))));
+}
+#endif
+
+static hash_entry_t *find_number_in_bin(s7_scheme *sc, hash_entry_t *bin, s7_pointer key)
+{
+ s7_double old_eps = sc->equivalent_float_epsilon;
+ bool (*equiv)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) = equivalents[type(key)];
+ sc->equivalent_float_epsilon = sc->hash_table_float_epsilon;
+ 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(NULL);
+}
+
+static hash_entry_t *hash_number_equivalent(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ /* for equivalent? and =, kind of complicated because two bins can be involved if the key is close to an integer */
+#if WITH_GMP
+ /* first try loc from hash_loc, then get key-floor(key) [with abs], and check against
+ * epsilon: diff < eps call find big in bin-1, diff > 1.0-eps call same in bin+1
+ */
+ s7_int loc1, hash_mask = hash_table_mask(table);
+ s7_int loc = hash_loc(sc, table, key);
+ s7_int hash_loc = loc & hash_mask;
+ hash_entry_t *i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key);
+ if (i1) return(i1);
+
+ if (is_real(key))
+ {
+ s7_pointer res = any_real_to_mpfr(sc, key, sc->mpfr_1);
+ if (res) return(sc->unentry);
+ }
+ else
+ if (is_t_complex(key))
+ mpfr_set_d(sc->mpfr_1, real_part(key), MPFR_RNDN);
+ else mpfr_set(sc->mpfr_1, mpc_realref(big_complex(key)), MPFR_RNDN);
+
+ /* mpfr_1 is big_real, so we can use hash_loc of big_real (and can ignore NaN's): */
+ mpfr_abs(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN);
+ mpfr_add_d(sc->mpfr_2, sc->mpfr_1, sc->hash_table_float_epsilon, MPFR_RNDN);
+ mpfr_get_z(sc->mpz_1, sc->mpfr_2, MPFR_RNDD);
+ loc1 = mpz_get_si(sc->mpz_1);
+ if (loc1 != loc)
+ {
+ if (loc1 == hash_table_mask(table)) loc1 = 0;
+ hash_loc = loc1 & hash_mask;
+ i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key);
+ return((i1) ? i1 : sc->unentry);
+ }
+ mpfr_sub_d(sc->mpfr_2, sc->mpfr_1, sc->hash_table_float_epsilon, MPFR_RNDN);
+ mpfr_get_z(sc->mpz_1, sc->mpfr_2, MPFR_RNDD);
+ loc1 = mpz_get_si(sc->mpz_1);
+ if (loc1 != loc)
+ {
+ if (loc1 < 0) loc1 = hash_table_mask(table);
+ hash_loc = loc1 & hash_mask;
+ i1 = find_number_in_bin(sc, hash_table_element(table, hash_loc), key);
+ if (i1) return(i1);
+ }
+ return(sc->unentry);
+#else
+ s7_double keyval = (is_real(key)) ? s7_real(key) : real_part(key);
+ s7_double fprobe = fabs(keyval);
+ s7_int iprobe = (s7_int)floor(fprobe);
+ s7_double bin_dist = fprobe - iprobe;
+ s7_int loc = iprobe & hash_table_mask(table);
+ hash_entry_t *i1 = find_number_in_bin(sc, hash_table_element(table, loc), key);
+ if (i1) return(i1);
+
+ if (bin_dist <= sc->hash_table_float_epsilon) /* maybe closest is below iprobe, key+eps>iprobe but key maps to iprobe-1 */
+ i1 = find_number_in_bin(sc, hash_table_element(table, (loc > 0) ? loc - 1 : hash_table_mask(table)), key);
+ else
+ if (bin_dist >= (1.0 - sc->hash_table_float_epsilon))
+ i1 = find_number_in_bin(sc, hash_table_element(table, (loc < hash_table_mask(table)) ? loc + 1 : 0), key);
+ return((i1) ? i1 : sc->unentry);
+#endif
+}
+
+static hash_entry_t *hash_int(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+#if WITH_GMP
+ if ((is_t_integer(key)) || (is_t_big_integer(key)))
+#else
+ if (is_t_integer(key))
+#endif
+ {
+ s7_int hash_mask = hash_table_mask(table);
+ hash_entry_t *x;
+#if WITH_GMP
+ s7_int kv = (is_t_integer(key)) ? integer(key) : mpz_get_si(big_integer(key));
+#else
+ s7_int kv = integer(key);
+#endif
+ 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);
+#else
+ if (integer(hash_entry_key(x)) == kv)
+ return(x);
+#endif
+ }
+ return(sc->unentry);
+}
+
+static hash_entry_t *hash_float(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ /* if a hash-table has only t_real keys, its checker is hash_float, but we might use a t_big_real key */
+#if WITH_GMP
+ if ((is_t_real(key)) || (is_t_big_real(key)))
+#else
+ if (is_t_real(key))
+#endif
+ {
+ s7_double keyval;
+ s7_int loc, hash_mask;
+#if WITH_GMP
+ if (is_t_real(key))
+ {
+ 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);
+ }
+#else
+ keyval = real(key);
+ if (is_NaN(keyval)) return(sc->unentry);
+#endif
+ hash_mask = hash_table_mask(table);
+ 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 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);
+#endif
+ }}
+ return(sc->unentry);
+}
+
+static hash_entry_t *hash_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ 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 (num_eq_b_7pp(sc, key, hash_entry_key(x)))
+ return(x);
+ return(sc->unentry);
+}
+
+static hash_entry_t *hash_real_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+#if WITH_GMP
+ if ((is_t_real(key)) && (is_NaN(real(key)))) return(sc->unentry);
+ if ((is_t_big_real(key)) && (mpfr_nan_p(big_real(key)))) return(sc->unentry);
+ return(hash_num_eq(sc, table, key));
+#else
+ return((is_NaN(s7_real(key))) ? sc->unentry : hash_num_eq(sc, table, key));
+#endif
+}
+
+static hash_entry_t *hash_complex_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+#if WITH_GMP
+ if ((is_t_complex(key)) && ((is_NaN(real_part(key))) || (is_NaN(imag_part(key))))) return(sc->unentry);
+ if ((is_t_big_complex(key)) && ((mpfr_nan_p(mpc_realref(big_complex(key)))) || (mpfr_nan_p(mpc_imagref(big_complex(key)))))) return(sc->unentry);
+ return(hash_num_eq(sc, table, key));
+#else
+ return(((is_NaN(real_part(key))) || (is_NaN(imag_part(key)))) ? sc->unentry : hash_num_eq(sc, table, key));
+#endif
+}
+
+static hash_entry_t *hash_number_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if (is_number(key))
+ {
+#if (!WITH_GMP)
+ 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);
+ }
+ else
+#endif
+ return((is_real(key)) ? hash_real_num_eq(sc, table, key) : hash_complex_num_eq(sc, table, key));
+ }
+ return(sc->unentry);
+}
+
+
+/* ---------------- hash characters ---------------- */
+static s7_int hash_map_char(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(character(key));}
+
+static hash_entry_t *hash_char(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if (is_character(key))
+ {
+ /* return(hash_eq(sc, table, key));
+ * but I think if we get here at all, we have to be using default_hash_checks|maps -- see hash_symbol above.
+ */
+ 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);
+ }
+ return(sc->unentry);
+}
+
+#if (!WITH_PURE_S7)
+static s7_int hash_map_ci_char(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(upper_character(key));}
+
+static hash_entry_t *hash_ci_char(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if (is_character(key))
+ {
+ 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);
+ }
+ return(sc->unentry);
+}
+#endif
+
+
+/* ---------------- hash strings ---------------- */
+static s7_int hash_map_string(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if (string_hash(key) == 0)
+ string_hash(key) = raw_string_hash((const uint8_t *)string_value(key), string_length(key));
+ return(string_hash(key));
+}
+
+static hash_entry_t *hash_string(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if (is_string(key))
+ {
+ hash_entry_t *x;
+ s7_int key_len = string_length(key);
+ uint64_t hash_mask = (uint64_t)hash_table_mask(table);
+ uint64_t hash;
+ 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));
+ 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);
+ }
+ 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);
+ }
+ return(sc->unentry);
+}
+
+#if (!WITH_PURE_S7)
+static s7_int hash_map_ci_string(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ s7_int len = string_length(key);
+ return((len == 0) ? 0 : (len + (uppers[(int32_t)(string_value(key)[0])] << 4)));
+}
+
+static hash_entry_t *hash_ci_string(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if (is_string(key))
+ {
+ 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);
+ }
+ return(sc->unentry);
+}
+#endif
+
+
+/* ---------------- hash eq? ---------------- */
+static s7_int hash_map_nil(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(type(key));}
+
+static s7_int hash_map_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(pointer_map(key));}
+
+static hash_entry_t *hash_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ /* explicit eq? as hash equality func for (for example) symbols as keys */
+ s7_int hash_mask = hash_table_mask(table);
+ s7_int loc = pointer_map(key) & hash_mask; /* hash_map_eq */
+ for (hash_entry_t *x = hash_table_element(table, loc); x; x = hash_entry_next(x))
+ if (key == hash_entry_key(x))
+ return(x);
+ return(sc->unentry);
+}
+
+/* ---------------- hash eqv? ---------------- */
+static hash_entry_t *hash_eqv(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ hash_entry_t *x;
+ s7_int hash_mask = hash_table_mask(table);
+ s7_int loc = hash_loc(sc, table, key) & hash_mask;
+ if (is_number(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);
+#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);
+#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(sc->unentry);
+}
+
+/* ---------------- hash equal? ---------------- */
+static s7_int hash_map_hash_table(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ /* hash-tables are equal if key/values match independent of table size and entry order.
+ * if not using equivalent?, hash_table_checker|mapper must also be the same.
+ * since order doesn't matter, but equal tables need to map to the same bin, we can't use key's
+ * entries except when key has 1 or 2 entries (or 3 to be tedious).
+ * Keys are supposed to be constant while keys, so a hash-table shouldn't be a key of itself.
+ */
+ s7_int len = hash_table_entries(key);
+ if ((len == 0) || (len > 2) || (hash_table_size(key) > 32)) return(len);
+
+ {
+ s7_pointer key1 = NULL, val1;
+ hash_entry_t **els = hash_table_elements(key);
+ s7_int size = hash_table_size(key);
+ 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))));
+ }}
+ return(0); /* placate the compiler */
+}
+
+static s7_int hash_map_int_vector(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if (vector_length(key) == 0)
+ return(0);
+ if (vector_length(key) == 1)
+ return(s7_int_abs(int_vector(key, 0)));
+ return(vector_length(key) + s7_int_abs(int_vector(key, 0)) + s7_int_abs(int_vector(key, 1))); /* overflow is ok here (in + or abs), as long as it's consistent */
+}
+
+static s7_int hash_map_byte_vector(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if (byte_vector_length(key) == 0)
+ return(0);
+ if (byte_vector_length(key) == 1)
+ return((s7_int)byte_vector(key, 0));
+ return(byte_vector_length(key) + byte_vector(key, 0) + byte_vector(key, 1));
+}
+
+static s7_int hash_map_float_vector(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if (vector_length(key) == 0)
+ return(0);
+ if (vector_length(key) == 1)
+ return(hash_float_location(float_vector(key, 0)));
+ return(vector_length(key) + hash_float_location(float_vector(key, 0)) + hash_float_location(float_vector(key, 1)));
+}
+
+static s7_int hash_map_vector(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if ((vector_length(key) == 0) ||
+ (is_sequence_or_iterator(vector_element(key, 0))))
+ return(vector_length(key));
+ if ((vector_length(key) == 1) ||
+ (is_sequence_or_iterator(vector_element(key, 1))))
+ return(hash_loc(sc, table, vector_element(key, 0)));
+ return(vector_length(key) + hash_loc(sc, table, vector_element(key, 0)) + hash_loc(sc, table, vector_element(key, 1))); /* see above */
+}
+
+
+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)));
+ /* 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);
+ sc->value = s7_call(sc, f, set_plist_1(sc, key));
+ unstack_gc_protect(sc);
+ 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));
+ return(integer(sc->value));
+}
+
+static s7_int hash_map_let(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ /* lets are equal if same symbol/value pairs, independent of order, taking into account shadowing. equal? follows outlet, but that is ridiculous here. */
+ s7_pointer slot, slot1 = NULL, slot2 = NULL;
+ s7_int slots;
+
+ if ((key == sc->rootlet) || (!tis_slot(let_slots(key)))) return(0);
+
+ 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++;
+ }
+ for (slot = let_slots(key); tis_slot(slot); slot = next_slot(slot))
+ clear_match_symbol(slot_symbol(slot));
+
+ if (slots == 1)
+ return(pointer_map(slot_symbol(slot1)) + ((is_sequence_or_iterator(slot_value(slot1))) ? 0 : hash_loc(sc, table, slot_value(slot1))));
+
+ 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))));
+ return(slots);
+}
+
+static hash_entry_t *hash_equal_eq(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ 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 (hash_entry_key(x) == key)
+ return(x);
+ return(sc->unentry);
+}
+
+static hash_entry_t *hash_equal_integer(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ s7_int keyint = integer(key);
+ s7_int loc = s7_int_abs(keyint) & hash_table_mask(table); /* hash_loc -> hash_map_integer */
+ 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);
+#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);
+#endif
+ }
+ return(sc->unentry);
+}
+
+static hash_entry_t *hash_equal_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ s7_int keynum = numerator(key), keyden = denominator(key);
+ s7_int loc = s7_int_abs(keynum / keyden) & hash_table_mask(table); /* hash_loc -> hash_map_ratio */
+ 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);
+#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);
+#endif
+ }
+ return(sc->unentry);
+}
+
+static hash_entry_t *hash_equal_real(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ s7_int loc;
+ s7_double keydbl = real(key);
+ if (is_NaN(keydbl)) return(sc->unentry);
+ loc = hash_float_location(keydbl) & hash_table_mask(table);
+ 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);
+#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);
+#endif
+ }
+ return(sc->unentry);
+}
+
+static hash_entry_t *hash_equal_complex(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ s7_int loc;
+ s7_double keyrl = real_part(key);
+ s7_double keyim = imag_part(key);
+
+#if WITH_GMP
+ if ((is_NaN(keyrl)) || (is_NaN(keyim))) return(sc->unentry);
+#endif
+ loc = hash_map_complex(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_t_complex(hash_entry_key(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);
+#endif
+ }
+ return(sc->unentry);
+}
+
+static hash_entry_t *hash_equal_any(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ bool (*equal)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) = equals[type(key)];
+ s7_int hash = hash_loc(sc, table, key);
+ s7_int loc = hash & 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)) /* avoid the equal funcs if possible -- this saves in both hash timing tests */
+ 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)))
+ return(x);
+ return(sc->unentry);
+}
+
+
+/* ---------------- hash c_functions ---------------- */
+static s7_int hash_map_c_function(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ s7_function f = c_function_call(hash_table_procedures_mapper(table));
+ return(integer(f(sc, with_list_t1(key))));
+}
+
+static s7_int hash_map_c_pointer(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ return(pointer_map(c_pointer(key)));
+}
+
+static s7_int hash_map_undefined(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ return(raw_string_hash((const uint8_t *)(undefined_name(key) + 1), undefined_name_length(key) - 1) + undefined_name_length(key));
+ /* undefined_name always starts with "#", so we omit it above */
+}
+
+static s7_int hash_map_iterator(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ /* cycles can happen here if the iterator_sequence contains the iterator and hash_loc checks that element */
+ return(type(iterator_sequence(key)) + hash_loc(sc, table, iterator_sequence(key)));
+}
+
+static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key);
+
+static hash_entry_t *hash_c_function(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if (is_pair(hash_table_procedures(table)))
+ {
+ s7_int hash_mask = hash_table_mask(table);
+ s7_function f = c_function_call(hash_table_procedures_checker(table));
+ s7_int hash = hash_loc(sc, table, key);
+ 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);
+ }
+ return(sc->unentry);
+ }
+ return(hash_equal(sc, table, key));
+}
+
+static int32_t len_upto_100(s7_pointer p)
+{
+ int32_t i = 0;
+ for (s7_pointer x = p; (is_pair(x)) && (i < 100); i++, x = cdr(x));
+ return(i);
+}
+
+static s7_int hash_map_pair(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ /* len+loc(car) is not horrible, but it means (for example) every list '(set! ...) is hashed to the same location,
+ * so at least we need to take cadr into account if possible. Better would combine the list_length (or tree-leaves == tree_len(sc, p))
+ * with stats like symbols/pairs/constants at top level, then use those to spread it out over all the locs.
+ * key can be cyclic, so tree_len would need to check for cycles.
+ */
+ s7_pointer p1 = cdr(key);
+ s7_int loc = 0;
+
+ if (!is_sequence_or_iterator(car(key)))
+ loc = hash_loc(sc, table, car(key)) + 1;
+ else
+ if ((is_pair(car(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;
+ else
+ 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 () */
+ loc += hash_loc(sc, table, p1);
+ return((loc << 3) + len_upto_100(key));
+}
+
+static hash_entry_t *hash_closure(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if (is_pair(hash_table_procedures(table)))
+ {
+ s7_int hash_mask = hash_table_mask(table);
+ s7_pointer f = hash_table_procedures_checker(table);
+ 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);
+ return(sc->unentry);
+ }
+ return(hash_equal(sc, table, key));
+}
+
+static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ return((*(equal_hash_checks[type(key)]))(sc, table, key));
+}
+
+/* ---------------- hash equivalent? ---------------- */
+static hash_entry_t *hash_equivalent(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ hash_entry_t *x;
+ s7_int hash, loc;
+
+ if (is_number(key))
+ {
+#if WITH_GMP
+ if (!is_nan_b_7p(sc, 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);
+#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);
+ return(sc->unentry);
+ }
+ hash = hash_loc(sc, table, key);
+ loc = hash & hash_table_mask(table);
+ for (x = hash_table_element(table, loc); x; x = hash_entry_next(x))
+ if (hash_entry_key(x) == key)
+ return(x);
+
+ 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)))
+ return(x);
+ return(sc->unentry);
+}
+
+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));
+}
+
+
+/* -------------------------------- make-hash-table -------------------------------- */
+s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size)
+{
+ s7_pointer table;
+ block_t *els;
+ /* size is rounded up to the next power of 2 */
+
+ if (size < 2)
+ size = 2;
+ 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++;
+ }
+ els = (block_t *)callocate(sc, size * sizeof(hash_entry_t *));
+ new_cell(sc, table, T_HASH_TABLE | T_SAFE_PROCEDURE);
+ hash_table_mask(table) = size - 1;
+ hash_table_set_block(table, els);
+ hash_table_elements(table) = (hash_entry_t **)(block_data(els));
+ hash_table_checker(table) = hash_empty;
+ hash_table_mapper(table) = default_hash_map;
+ hash_table_entries(table) = 0;
+ hash_table_set_procedures(table, sc->nil);
+ add_hash_table(sc, table);
+ return(table);
+}
+
+static bool compatible_types(s7_scheme *sc, const s7_pointer eq_type, const s7_pointer value_type)
+{
+ if (eq_type == sc->T) return(true);
+ 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));
+ return(false);
+}
+
+static s7_pointer g_is_equal(s7_scheme *sc, s7_pointer args);
+static s7_pointer g_is_equivalent(s7_scheme *sc, s7_pointer args);
+
+static s7_pointer g_make_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer caller)
+{
+ #define H_make_hash_table "(make-hash-table (size 8) eq-func typer) returns a new hash table. eq-func is the function \
+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_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));
+ 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));
+ if ((size > sc->max_vector_length) ||
+ (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);
+ }
+#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);
+ }}}
+ return(s7_make_hash_table(sc, size));
+}
+
+static s7_pointer g_make_hash_table(s7_scheme *sc, s7_pointer args)
+{
+ return(g_make_hash_table_1(sc, args, sc->make_hash_table_symbol));
+}
+
+
+/* -------------------------------- make-weak-hash-table -------------------------------- */
+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_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;
+ return(table);
+}
+
+static const char *hash_table_checker_name(s7_scheme *sc, s7_pointer ht)
+{
+ if (hash_table_checker(ht) == hash_equal) return("equal?");
+ if (hash_table_checker(ht) == hash_equivalent) return("equivalent?");
+ if (hash_table_checker(ht) == hash_eq) return("eq?");
+ if (hash_table_checker(ht) == hash_eqv) return("eqv?");
+ if (hash_table_checker(ht) == hash_string) return("string=?");
+#if (!WITH_PURE_S7)
+ if (hash_table_checker(ht) == hash_ci_string) return("string-ci=?");
+ if (hash_table_checker(ht) == hash_ci_char) return("char-ci=?");
+#endif
+ if (hash_table_checker(ht) == hash_char) return("char=?");
+ if (hash_table_checker(ht) == hash_number_num_eq) return("=");
+ return("#f");
+}
+
+
+/* -------------------------------- weak-hash-table? -------------------------------- */
+static s7_pointer g_is_weak_hash_table(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_weak_hash_table "(weak-hash-table? obj) returns #t if obj is a weak hash-table"
+ #define Q_is_weak_hash_table sc->pl_bt
+ #define is_weak_hash(p) ((is_hash_table(p)) && (is_weak_hash_table(p)))
+ check_boolean_method(sc, is_weak_hash, sc->is_weak_hash_table_symbol, args);
+}
+
+static void init_hash_maps(void)
+{
+ for (int32_t i = 0; i < NUM_TYPES; i++)
+ {
+ default_hash_map[i] = hash_map_nil;
+ string_eq_hash_map[i] = hash_map_nil;
+ char_eq_hash_map[i] = hash_map_nil;
+#if (!WITH_PURE_S7)
+ string_ci_eq_hash_map[i] = hash_map_nil;
+ char_ci_eq_hash_map[i] = hash_map_nil;
+#endif
+ closure_hash_map[i] = hash_map_closure;
+ c_function_hash_map[i] = hash_map_c_function;
+ eq_hash_map[i] = hash_map_eq;
+
+ equal_hash_checks[i] = hash_equal_any;
+ default_hash_checks[i] = hash_equal;
+ }
+ default_hash_map[T_CHARACTER] = hash_map_char;
+ default_hash_map[T_SYMBOL] = hash_map_symbol;
+ default_hash_map[T_SYNTAX] = hash_map_syntax;
+ default_hash_map[T_STRING] = hash_map_string;
+ default_hash_map[T_BYTE_VECTOR] = hash_map_byte_vector;
+ default_hash_map[T_HASH_TABLE] = hash_map_hash_table;
+ default_hash_map[T_VECTOR] = hash_map_vector;
+ default_hash_map[T_INT_VECTOR] = hash_map_int_vector;
+ default_hash_map[T_FLOAT_VECTOR] = hash_map_float_vector;
+ default_hash_map[T_LET] = hash_map_let;
+ default_hash_map[T_PAIR] = hash_map_pair;
+ default_hash_map[T_C_POINTER] = hash_map_c_pointer;
+ default_hash_map[T_UNDEFINED] = hash_map_undefined;
+ default_hash_map[T_ITERATOR] = hash_map_iterator;
+ for (int32_t i = T_OUTPUT_PORT; i < NUM_TYPES; i++)
+ default_hash_map[i] = hash_map_eq;
+
+ default_hash_map[T_INTEGER] = hash_map_int;
+ default_hash_map[T_RATIO] = hash_map_ratio;
+ default_hash_map[T_REAL] = hash_map_real;
+ default_hash_map[T_COMPLEX] = hash_map_complex;
+#if WITH_GMP
+ default_hash_map[T_BIG_INTEGER] = hash_map_big_int;
+ default_hash_map[T_BIG_RATIO] = hash_map_big_ratio;
+ default_hash_map[T_BIG_REAL] = hash_map_big_real;
+ default_hash_map[T_BIG_COMPLEX] = hash_map_big_complex;
+#endif
+
+ string_eq_hash_map[T_STRING] = hash_map_string;
+ string_eq_hash_map[T_BYTE_VECTOR] = hash_map_byte_vector;
+ char_eq_hash_map[T_CHARACTER] = hash_map_char;
+#if (!WITH_PURE_S7)
+ string_ci_eq_hash_map[T_STRING] = hash_map_ci_string;
+ char_ci_eq_hash_map[T_CHARACTER] = hash_map_ci_char;
+#endif
+
+ for (int32_t i = 0; i < NUM_TYPES; i++)
+ equivalent_hash_map[i] = default_hash_map[i];
+
+ equal_hash_checks[T_SYNTAX] = hash_equal_syntax;
+ equal_hash_checks[T_SYMBOL] = hash_equal_eq;
+ equal_hash_checks[T_CHARACTER] = hash_equal_eq;
+ equal_hash_checks[T_INTEGER] = hash_equal_integer;
+ equal_hash_checks[T_RATIO] = hash_equal_ratio;
+ equal_hash_checks[T_REAL] = hash_equal_real;
+ equal_hash_checks[T_COMPLEX] = hash_equal_complex;
+
+ default_hash_checks[T_STRING] = hash_string;
+ default_hash_checks[T_INTEGER] = hash_int;
+ default_hash_checks[T_REAL] = hash_float;
+ default_hash_checks[T_SYMBOL] = hash_symbol;
+ default_hash_checks[T_CHARACTER] = hash_char;
+}
+
+#if S7_DEBUGGING & (0)
+static s7_pointer hash_table_to_let(s7_scheme *sc, s7_pointer obj);
+#endif
+
+static void resize_hash_table(s7_scheme *sc, s7_pointer table)
+{
+ s7_int entries = hash_table_entries(table);
+ hash_entry_t **old_els = hash_table_elements(table);
+ s7_pointer dproc = hash_table_procedures(table); /* new block_t so we need to pass this across */
+ s7_int old_size = hash_table_size(table);
+ s7_int new_size = old_size * 4;
+ s7_int hash_mask = new_size - 1;
+#if S7_DEBUGGING & (0)
+ s7_pointer old_data = s7_gc_protect_via_stack(sc, slot_value(symbol_to_local_slot(sc, make_symbol(sc, "stats:0|1|2|n|max", 17), hash_table_to_let(sc, table))));
+#endif
+ block_t *np = (block_t *)callocate(sc, new_size * sizeof(hash_entry_t *));
+ hash_entry_t **new_els = (hash_entry_t **)(block_data(np));
+
+ for (s7_int i = 0; i < old_size; i++)
+ {
+ 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;
+ }}
+ liberate(sc, hash_table_block(table));
+ hash_table_set_block(table, np);
+ hash_table_elements(table) = new_els;
+ hash_table_mask(table) = hash_mask; /* was new_size - 1 14-Jun-21 */
+ hash_table_set_procedures(table, dproc);
+ hash_table_entries(table) = entries;
+#if S7_DEBUGGING & (0)
+ fprintf(stderr, "%s: %s -> ", __func__, display(old_data));
+ unstack_gc_protect(sc);
+ fprintf(stderr, "%s\n", display(slot_value(symbol_to_local_slot(sc, make_symbol(sc, "stats:0|1|2|n|max", 17), hash_table_to_let(sc, table)))));
+#endif
+}
+
+
+/* -------------------------------- hash-table-ref -------------------------------- */
+s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ return(hash_entry_value((*hash_table_checker(table))(sc, table, key)));
+}
+
+static s7_pointer g_hash_table_ref(s7_scheme *sc, s7_pointer args)
+{
+ #define H_hash_table_ref "(hash-table-ref table key) returns the value associated with key in the hash table"
+ #define Q_hash_table_ref s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_hash_table_symbol, sc->T)
+
+ s7_pointer table = car(args), nt;
+ if (!is_hash_table(table))
+ return(method_or_bust(sc, table, sc->hash_table_ref_symbol, args, sc->type_names[T_HASH_TABLE], 1));
+ nt = s7_hash_table_ref(sc, table, cadr(args));
+
+ if (is_pair(cddr(args)))
+ return(ref_index_checked(sc, global_value(sc->hash_table_ref_symbol), nt, args));
+ return(nt);
+}
+
+static s7_pointer g_hash_table_ref_2(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer table = car(args);
+ if (!is_hash_table(table))
+ return(method_or_bust(sc, table, sc->hash_table_ref_symbol, args, sc->type_names[T_HASH_TABLE], 1));
+ return(hash_entry_value((*hash_table_checker(table))(sc, table, cadr(args))));
+}
+
+static s7_pointer hash_table_ref_p_pp(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ if (!is_hash_table(table))
+ return(method_or_bust(sc, table, sc->hash_table_ref_symbol, set_plist_2(sc, table, key), sc->type_names[T_HASH_TABLE], 1));
+ return(hash_entry_value((*hash_table_checker(table))(sc, table, key)));
+}
+
+static bool op_implicit_hash_table_ref_a(s7_scheme *sc)
+{
+ s7_pointer s = lookup_checked(sc, car(sc->code));
+ if (!is_hash_table(s)) {sc->last_function = s; return(false);}
+ sc->value = s7_hash_table_ref(sc, s, fx_call(sc, cdr(sc->code)));
+ return(true);
+}
+
+static s7_pointer fx_implicit_hash_table_ref_a(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer s = lookup_checked(sc, car(arg));
+ if (!is_hash_table(s))
+ return(s7_apply_function(sc, s, list_1(sc, fx_call(sc, cdr(arg)))));
+ return(s7_hash_table_ref(sc, s, fx_call(sc, cdr(arg))));
+}
+
+static bool op_implicit_hash_table_ref_aa(s7_scheme *sc)
+{
+ s7_pointer in_obj, out_key;
+ s7_pointer table = lookup_checked(sc, car(sc->code));
+ if (!is_hash_table(table)) {sc->last_function = table; return(false);}
+ out_key = fx_call(sc, cdr(sc->code));
+ in_obj = s7_hash_table_ref(sc, table, out_key);
+ if (is_hash_table(in_obj))
+ sc->value = s7_hash_table_ref(sc, in_obj, fx_call(sc, cddr(sc->code)));
+ else sc->value = implicit_pair_index_checked(sc, table, in_obj, set_plist_2(sc, out_key, fx_call(sc, cddr(sc->code)))); /* -> implicit_index */
+ return(true);
+}
+
+static s7_pointer hash_table_ref_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if (args == 2)
+ {
+ 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);
+ return(sc->hash_table_ref_2);
+ }
+ return(f);
+}
+
+
+/* -------------------------------- hash-table-set! -------------------------------- */
+static s7_pointer remove_from_hash_table(s7_scheme *sc, s7_pointer table, hash_entry_t *p)
+{
+ hash_entry_t *x;
+ s7_int hash_mask, loc;
+
+ if (p == sc->unentry) return(sc->F);
+ hash_mask = hash_table_mask(table);
+ loc = hash_entry_raw_hash(p) & hash_mask;
+ x = hash_table_element(table, loc);
+ if (x == p)
+ hash_table_element(table, loc) = hash_entry_next(x);
+ else
+ {
+ 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;
+ }}
+ hash_table_entries(table)--;
+ if ((hash_table_entries(table) == 0) &&
+ (hash_table_mapper(table) == default_hash_map))
+ {
+ hash_table_checker(table) = hash_empty;
+ hash_clear_chosen(table);
+ }
+ liberate_block(sc, x);
+ return(sc->F);
+}
+
+static void cull_weak_hash_table(s7_scheme *sc, s7_pointer table)
+{
+ s7_int len = hash_table_size(table);
+ hash_entry_t **entries = hash_table_elements(table);
+ for (s7_int i = 0; i < len; i++)
+ {
+ 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;
+ }}
+}
+
+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];
+ else
+ {
+ hash_table_checker(table) = hash_equal;
+ hash_set_chosen(table);
+ }}
+}
+
+static s7_pointer hash_table_typer_symbol(s7_scheme *sc, s7_pointer typer)
+{
+ if (typer == sc->T)
+ return(sc->T);
+ return((is_c_function(typer)) ? c_function_symbol(typer) : find_closure(sc, typer, closure_let(typer)));
+}
+
+static void check_hash_types(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value)
+{
+ if (has_hash_key_type(table)) /* symbol_type and c_function_symbol exist and symbol_type is not T_FREE */
+ {
+ 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)));
+ }}
+ 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))));
+ }}}
+ 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)));
+ }}
+ 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))));
+ }}}
+}
+
+static void check_hash_table_checker(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ /* check type -- raise error if incompatible with eq func set by make-hash-table */
+ 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)));
+ }
+ 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)));
+ }
+ 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));
+#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))));
+#endif
+}
+
+s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value)
+{
+ s7_int hash_mask, loc;
+ hash_entry_t *p, *x;
+
+ if (value == sc->F)
+ return(remove_from_hash_table(sc, table, (*hash_table_checker(table))(sc, table, key)));
+
+ if ((is_typed_hash_table(table)) && (sc->safety >= NO_SAFETY)) /* this order is faster */
+ check_hash_types(sc, table, key, value);
+
+ x = (*hash_table_checker(table))(sc, table, key);
+ if (x != sc->unentry)
+ {
+ hash_entry_set_value(x, T_Ext(value));
+ return(value);
+ }
+ /* hash_entry_raw_hash(x) can save the hash_loc from the lookup operations, but at some added complexity in
+ * all the preceding code. This saves about 5% compute time best case in this function.
+ */
+ if (!hash_chosen(table))
+ hash_table_set_default_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_default_checker etc */
+ else
+ if (sc->safety > NO_SAFETY)
+ check_hash_table_checker(sc, table, key);
+
+ p = mallocate_block(sc);
+ hash_entry_key(p) = key;
+ hash_entry_set_value(p, T_Ext(value));
+ hash_entry_set_raw_hash(p, hash_loc(sc, table, key));
+ hash_mask = hash_table_mask(table);
+ loc = hash_entry_raw_hash(p) & hash_mask;
+ hash_entry_next(p) = hash_table_element(table, loc);
+ hash_table_element(table, loc) = p;
+ hash_table_entries(table)++;
+ if (hash_table_entries(table) > hash_mask)
+ resize_hash_table(sc, table);
+ return(value);
+}
+
+static s7_pointer g_hash_table_set(s7_scheme *sc, s7_pointer args)
+{
+ #define H_hash_table_set "(hash-table-set! table key value) sets the value associated with key in the hash table to value"
+ #define Q_hash_table_set s7_make_signature(sc, 4, sc->T, sc->is_hash_table_symbol, sc->T, sc->T)
+
+ s7_pointer table = car(args);
+ if (!is_mutable_hash_table(table))
+ return(mutable_method_or_bust(sc, table, sc->hash_table_set_symbol, args, sc->type_names[T_HASH_TABLE], 1));
+ return(s7_hash_table_set(sc, table, cadr(args), caddr(args)));
+}
+
+static s7_pointer hash_table_set_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3)
+{
+ if (!is_mutable_hash_table(p1)) /* is_hash_table(p1) is here */
+ return(mutable_method_or_bust_ppp(sc, p1, sc->hash_table_set_symbol, p1, p2, p3, sc->type_names[T_HASH_TABLE], 1));
+ return(s7_hash_table_set(sc, p1, p2, p3));
+}
+
+static s7_pointer hash_table_set_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if ((args == 3) && (optimize_op(expr) == HOP_SAFE_C_SSA))
+ {
+ 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)))
+ {
+ 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);
+}
+
+
+/* -------------------------------- hash-table -------------------------------- */
+static inline s7_pointer hash_table_add(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value)
+{
+ s7_int hash, hash_mask, loc;
+ hash_entry_t *p;
+
+ if (!hash_chosen(table))
+ hash_table_set_default_checker(table, type(key)); /* raw_hash value (hash_loc(sc, table, key)) does not change via hash_table_set_default_checker etc */
+
+ hash_mask = hash_table_mask(table);
+ hash = hash_loc(sc, table, key);
+ 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) &&
+ (s7_is_equal(sc, hash_entry_key(x), key)))
+ return(value);
+
+ p = mallocate_block(sc);
+ hash_entry_key(p) = key;
+ hash_entry_set_value(p, T_Ext(value));
+ hash_entry_set_raw_hash(p, hash);
+ hash_entry_next(p) = hash_table_element(table, loc);
+ hash_table_element(table, loc) = p;
+ hash_table_entries(table)++;
+ if (hash_table_entries(table) > hash_mask)
+ resize_hash_table(sc, table);
+ return(value);
+}
+
+static s7_pointer g_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer caller)
+{
+ s7_pointer ht;
+ 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));
+ 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)));
+
+ 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));
+ return(ht);
+}
+
+static s7_pointer g_hash_table(s7_scheme *sc, s7_pointer args)
+{
+ #define H_hash_table "(hash-table ...) returns a hash-table containing the symbol/value pairs passed as its arguments. \
+That is, (hash-table 'a 1 'b 2) returns a new hash-table with the two key/value pairs preinstalled."
+ #define Q_hash_table s7_make_circular_signature(sc, 1, 2, sc->is_hash_table_symbol, sc->T)
+ return(g_hash_table_1(sc, args, sc->hash_table_symbol));
+}
+
+static s7_pointer g_hash_table_2(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer ht = s7_make_hash_table(sc, sc->default_hash_table_length);
+ if (cadr(args) != sc->F)
+ hash_table_add(sc, ht, car(args), cadr(args));
+ return(ht);
+}
+
+
+/* -------------------------------- weak-hash-table -------------------------------- */
+static s7_pointer g_weak_hash_table(s7_scheme *sc, s7_pointer args)
+{
+ #define H_weak_hash_table "(weak-hash-table ...) returns a weak-hash-table containing the symbol/value pairs passed as its arguments. \
+That is, (weak-hash-table 'a 1 'b 2) returns a new weak-hash-table with the two key/value pairs preinstalled."
+ #define Q_weak_hash_table Q_hash_table
+
+ s7_pointer table = g_hash_table_1(sc, args, sc->weak_hash_table_symbol);
+ set_weak_hash_table(table);
+ weak_hash_iters(table) = 0;
+ return(table);
+}
+
+static s7_pointer hash_table_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ return((args == 2) ? sc->hash_table_2 : f);
+}
+
+static void check_old_hash(s7_scheme *sc, s7_pointer old_hash, s7_pointer new_hash, s7_int start, s7_int end)
+{
+ s7_int count = 0;
+ s7_int old_len = hash_table_size(old_hash);
+ hash_entry_t **old_lists = hash_table_elements(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))
+ {
+ if (count >= end)
+ return;
+ if (count >= start)
+ check_hash_types(sc, new_hash, hash_entry_key(x), hash_entry_value(x));
+ }
+}
+
+static s7_pointer hash_table_copy(s7_scheme *sc, s7_pointer old_hash, s7_pointer new_hash, s7_int start, s7_int end)
+{
+ s7_int old_len, new_mask, count = 0;
+ hash_entry_t **old_lists, **new_lists;
+
+ if (is_typed_hash_table(new_hash))
+ check_old_hash(sc, old_hash, new_hash, start, end);
+
+ old_len = hash_table_size(old_hash);
+ new_mask = hash_table_mask(new_hash);
+ old_lists = hash_table_elements(old_hash);
+ new_lists = hash_table_elements(new_hash);
+
+ 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);
+ }
+ 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++;
+ }
+ hash_table_entries(new_hash) = count - start;
+ return(new_hash);
+ }
+
+ /* this can't be optimized much because we have to look for key matches (we're copying old_hash into the existing, non-empty 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)
+ 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);
+}
+
+static s7_pointer hash_table_fill(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer table = car(args), val = cadr(args);
+ if (is_immutable_hash_table(table))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->fill_symbol, table));
+
+ if (hash_table_entries(table) > 0)
+ {
+ 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);
+ }
+ 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)));
+ }
+ 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);
+ /* keys haven't changed, so no need to mess with hash_table_checker */
+ }
+ return(val);
+}
+
+static s7_pointer hash_table_reverse(s7_scheme *sc, s7_pointer old_hash)
+{
+ s7_int len = hash_table_size(old_hash);
+ hash_entry_t **old_lists = hash_table_elements(old_hash);
+ s7_pointer new_hash = s7_make_hash_table(sc, len);
+ gc_protect_via_stack(sc, new_hash);
+
+ /* old_hash checker/mapper functions don't always make sense reversed, although the key/value typers might be ok */
+ for (s7_int i = 0; i < len; i++)
+ for (hash_entry_t *x = old_lists[i]; x; x = hash_entry_next(x))
+ s7_hash_table_set(sc, new_hash, hash_entry_value(x), hash_entry_key(x));
+
+ if (is_weak_hash_table(old_hash)) /* 17-May-23, not sure it makes sense to reverse a weak-hash-table but... */
+ {
+ set_weak_hash_table(new_hash);
+ weak_hash_iters(new_hash) = 0;
+ }
+ unstack_gc_protect(sc);
+ return(new_hash);
+}
+
+
+/* -------------------------------- functions -------------------------------- */
+bool s7_is_function(s7_pointer p) {return(is_c_function(p));}
+
+static s7_pointer fallback_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr) {return(f);}
+
+static void s7_function_set_class(s7_scheme *sc, s7_pointer f, s7_pointer base_f)
+{
+ c_function_class(f) = c_function_class(base_f);
+ c_function_set_base(f, base_f);
+}
+
+static s7_pointer make_function(s7_scheme *sc, const char *name, s7_function f, s7_int req, s7_int opt, bool rst, const char *doc, s7_pointer x, c_proc_t *ptr)
+{
+ set_full_type(x, ((req == 0) && (rst)) ? T_C_RST_NO_REQ_FUNCTION : T_C_FUNCTION);
+
+ c_function_data(x) = ptr;
+ c_function_call(x) = f; /* f is T_App but needs cast */
+ c_function_set_base(x, x);
+ c_function_set_setter(x, sc->F);
+ c_function_name(x) = name; /* (procedure-name proc) => (format #f "~A" proc) */
+ c_function_name_length(x) = safe_strlen(name);
+ c_function_documentation(x) = (doc) ? make_semipermanent_c_string(sc, doc) : NULL;
+ c_function_signature(x) = sc->F;
+
+ c_function_min_args(x) = req;
+ c_function_optional_args(x) = opt; /* T_C_FUNCTION_STAR type may be set later, so T_Fst not usable here */
+ c_function_max_args(x) = (rst) ? MAX_ARITY : req + opt;
+
+ c_function_class(x) = ++sc->f_class;
+ c_function_chooser(x) = fallback_chooser;
+ c_function_opt_data(x) = NULL;
+ c_function_marker(x) = NULL;
+ c_function_symbol(x) = NULL;
+ return(x);
+}
+
+static c_proc_t *alloc_semipermanent_function(s7_scheme *sc)
+{
+ #define ALLOC_FUNCTION_SIZE 256
+ if (sc->alloc_function_k == ALLOC_FUNCTION_SIZE)
+ {
+ sc->alloc_function_cells = (c_proc_t *)Malloc(ALLOC_FUNCTION_SIZE * sizeof(c_proc_t));
+ add_saved_pointer(sc, sc->alloc_function_cells);
+ sc->alloc_function_k = 0;
+ }
+ return(&(sc->alloc_function_cells[sc->alloc_function_k++]));
+}
+
+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_pointer x = alloc_pointer(sc);
+ x = make_function(sc, name, f, required_args, optional_args, rest_arg, doc, x, alloc_semipermanent_function(sc));
+ unheap(sc, x);
+ return(x);
+}
+
+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_pointer p = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc);
+ set_type_bit(p, T_SAFE_PROCEDURE);
+ return(p);
+}
+
+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_pointer func = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc);
+ set_type_bit(func, T_SAFE_PROCEDURE);
+ if (signature) c_function_signature(func) = signature;
+ return(func);
+}
+
+
+/* -------------------------------- procedure? -------------------------------- */
+bool s7_is_procedure(s7_pointer x) {return(is_procedure(x));}
+
+static s7_pointer g_is_procedure(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_procedure "(procedure? obj) returns #t if obj is a procedure"
+ #define Q_is_procedure sc->pl_bt
+ return(make_boolean(sc, is_procedure(car(args))));
+}
+
+
+static void s7_function_set_setter(s7_scheme *sc, s7_pointer getter, s7_pointer setter)
+{
+ /* this is internal, used only with c_function setters, so we don't need to worry about the GC mark choice */
+ c_function_set_setter(global_value(getter), global_value(setter));
+}
+
+s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_body(p) : sc->nil);}
+s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_let(p) : sc->rootlet);}
+s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_args(p) : sc->nil);}
+
+
+/* -------------------------------- procedure-source -------------------------------- */
+static s7_pointer procedure_type_to_symbol(s7_scheme *sc, int32_t type)
+{
+ switch (type)
+ {
+ case T_CLOSURE: return(sc->lambda_symbol);
+ case T_CLOSURE_STAR: return(sc->lambda_star_symbol);
+ case T_MACRO: return(sc->macro_symbol);
+ case T_MACRO_STAR: return(sc->macro_star_symbol);
+ case T_BACRO: return(sc->bacro_symbol);
+ case T_BACRO_STAR: return(sc->bacro_star_symbol);
+ default: if (S7_DEBUGGING) fprintf(stderr, "%s[%d] wants %d symbol\n", __func__, __LINE__, type); /* break; ? */
+ }
+ return(sc->lambda_symbol);
+}
+
+static s7_pointer g_procedure_source(s7_scheme *sc, s7_pointer args)
+{
+ #define H_procedure_source "(procedure-source func) tries to return the definition of func"
+ #define Q_procedure_source s7_make_signature(sc, 2, sc->is_list_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol))
+ /* make it look like a scheme-level lambda */
+ s7_pointer p = car(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)));
+ if ((is_c_function(p)) || (is_c_macro(p)))
+ return(sc->nil);
+
+ check_method(sc, p, sc->procedure_source_symbol, set_plist_1(sc, p));
+ if (has_closure_let(p))
+ {
+ 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);
+ return(append_in_place(sc, list_2(sc, procedure_type_to_symbol(sc, type(p)), closure_args(p)), body));
+ }
+ if (!is_procedure(p))
+ sole_arg_wrong_type_error_nr(sc, sc->procedure_source_symbol, p, a_procedure_or_a_macro_string);
+ return(sc->nil);
+ /* perhaps include file/line? perhaps some way to return comments in code -- source code as string exactly as in file? */
+}
+
+
+/* -------------------------------- *current-function* -------------------------------- */
+static s7_pointer let_to_function(s7_scheme *sc, s7_pointer e)
+{
+ if ((!e) || (e == sc->rootlet) || (!is_let(e)))
+ return(sc->F);
+ if (!((is_funclet(e)) || (is_maclet(e))))
+ return(sc->F);
+ if ((has_let_file(e)) &&
+ (let_file(e) <= (s7_int)sc->file_names_top) &&
+ (let_line(e) > 0))
+ return(list_3(sc, funclet_function(e), sc->file_names[let_file(e)], make_integer(sc, let_line(e))));
+ return(funclet_function(e));
+}
+
+static s7_pointer g_function(s7_scheme *sc, s7_pointer args)
+{
+ #define H_function "(*function* env field) returns the current function. (*function*) is like __func__ in C. \
+If 'env is specified, *function* looks for the current function in the environment 'e. If 'field (a symbol) is given \
+a function-specific value is returned. The fields are 'name (the name of the current function), 'signature, 'arity,\
+ 'documentation, 'value (the function itself), 'line and 'file (the function's definition location), 'funclet, 'source, \
+and 'arglist. (define (func x y) (*function* (curlet) 'arglist)) (func 1 2): '(x y)"
+
+ #define Q_function s7_make_signature(sc, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol)
+
+ s7_pointer e, sym = NULL, fname, fval;
+ 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;
+ return(let_to_function(sc, e));
+ }
+ e = car(args);
+ if (!is_let(e))
+ sole_arg_wrong_type_error_nr(sc, sc->_function__symbol, e, sc->type_names[T_LET]);
+ if (is_pair(cdr(args)))
+ {
+ sym = cadr(args);
+ if (!is_symbol(sym))
+ wrong_type_error_nr(sc, sc->_function__symbol, 2, sym, sc->type_names[T_SYMBOL]);
+ }
+ if (e == sc->rootlet)
+ return(sc->F);
+ if (!((is_funclet(e)) || (is_maclet(e))))
+ e = let_outlet(e);
+ if (is_null(cdr(args)))
+ return(let_to_function(sc, e));
+ if ((e == sc->rootlet) || (!is_let(e)))
+ return(sc->F);
+ if (!((is_funclet(e)) || (is_maclet(e))))
+ return(sc->F);
+
+ if (is_keyword(sym))
+ sym = keyword_symbol(sym);
+ fname = funclet_function(e);
+ fval = s7_symbol_local_value(sc, fname, e);
+
+ if (sym == sc->name_symbol) return(fname);
+ if (sym == sc->signature_symbol) return(s7_signature(sc, fval));
+ if (sym == sc->arity_symbol) return(s7_arity(sc, fval));
+ if (sym == sc->documentation_symbol) return(s7_make_string(sc, s7_documentation(sc, fval)));
+ if (sym == sc->value_symbol) return(fval);
+ if ((sym == sc->line_symbol) && (has_let_file(e))) return(make_integer(sc, let_line(e)));
+ if ((sym == sc->file_symbol) && (has_let_file(e))) return(sc->file_names[let_file(e)]);
+ if (sym == make_symbol(sc, "funclet", 7)) return(e);
+ if (sym == make_symbol(sc, "source", 6)) return(g_procedure_source(sc, set_plist_1(sc, fval)));
+ if ((sym == make_symbol(sc, "arglist", 7)) && ((is_any_closure(fval)) || (is_any_macro(fval)))) return(closure_args(fval));
+ return(sc->F);
+}
+
+
+/* -------------------------------- funclet -------------------------------- */
+s7_pointer s7_funclet(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_let(p) : sc->rootlet);}
+
+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_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 */
+ }
+ check_method(sc, p, sc->funclet_symbol, args);
+ if (!((is_any_procedure(p)) || (is_c_object(p))))
+ sole_arg_wrong_type_error_nr(sc, sc->funclet_symbol, p, a_procedure_or_a_macro_string);
+ return(find_let(sc, p));
+}
+
+
+/* -------------------------------- s7_define_function and friends --------------------------------
+ *
+ * all c_func* are semipermanent, but they might be local: (let () (load "libm.scm" (curlet)) ...)
+ * 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_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
+ s7_pointer sym = make_symbol_with_strlen(sc, name);
+ s7_define(sc, sc->rootlet, sym, func);
+ return(sym);
+}
+
+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)
+{
+ /* 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);
+ s7_pointer sym = make_symbol_with_strlen(sc, name);
+ s7_define(sc, sc->rootlet, sym, func);
+ return(sym);
+}
+
+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)
+{
+ /* 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 */
+ s7_pointer sym = make_symbol_with_strlen(sc, name);
+ s7_define(sc, sc->rootlet, sym, func);
+ c_function_set_marker(func, NULL);
+ return(sym);
+}
+
+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_pointer bfunc;
+ s7_pointer func = s7_make_typed_function(sc, name, fnc, 1, optional_args, false, doc, signature); /* includes "safe" bit */
+ s7_pointer sym = make_symbol_with_strlen(sc, name);
+ s7_define(sc, sc->rootlet, sym, func);
+ if (sym_to_type != T_FREE)
+ symbol_set_type(sym, sym_to_type);
+ c_function_symbol(func) = sym;
+ c_function_set_marker(func, marker);
+ if (simple) c_function_set_has_simple_elements(func);
+ c_function_set_bool_setter(func, bfunc = s7_make_safe_function(sc, name, bool_setter, 2, 0, false, NULL));
+ c_function_set_has_bool_setter(func);
+ c_function_set_setter(bfunc, func);
+ set_is_bool_function(bfunc);
+ return(sym);
+}
+
+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)
+{
+ /* 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);
+ s7_pointer sym = make_symbol_with_strlen(sc, name);
+ if (signature) c_function_signature(func) = signature;
+ s7_define(sc, sc->rootlet, sym, func);
+ return(sym);
+}
+
+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_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
+ s7_pointer sym = make_symbol_with_strlen(sc, name);
+ if (signature) c_function_signature(func) = signature;
+ set_is_semisafe(func);
+ s7_define(sc, sc->rootlet, sym, func);
+ return(sym);
+}
+
+s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc)
+{
+ s7_pointer func, local_args;
+ char *internal_arglist;
+ s7_int n_args, len = safe_strlen(arglist);
+ s7_int gc_loc;
+ block_t *b = inline_mallocate(sc, len + 4);
+
+ internal_arglist = (char *)block_data(b);
+ internal_arglist[0] = '\'';
+ internal_arglist[1] = '(';
+ memcpy((void *)(internal_arglist + 2), (const void *)arglist, len);
+ internal_arglist[len + 2] = ')';
+ internal_arglist[len + 3] = '\0';
+ local_args = s7_eval_c_string(sc, internal_arglist);
+ gc_loc = gc_protect_1(sc, local_args);
+ liberate(sc, b);
+ n_args = s7_list_length(sc, local_args);
+ if (n_args < 0)
+ {
+ s7_warn(sc, 256, "%s rest argument is not supported in C-side define*: %s\n", name, arglist);
+ n_args = -n_args;
+ }
+ func = s7_make_function(sc, name, fnc, 0, n_args, false, doc);
+
+ if (n_args > 0)
+ {
+ s7_pointer p = local_args;
+ s7_pointer *names = (s7_pointer *)permalloc(sc, n_args * sizeof(s7_pointer));
+ s7_pointer *defaults = (s7_pointer *)permalloc(sc, n_args * sizeof(s7_pointer));
+
+ set_full_type(func, T_C_FUNCTION_STAR | T_UNHEAP); /* unheap from s7_make_function */
+ c_function_call_args(func) = NULL;
+ c_function_arg_names(func) = names;
+ c_function_arg_defaults(func) = defaults;
+ c_func_set_simple_defaults(func);
+ /* (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;
+ }}}
+ else set_full_type(func, T_C_FUNCTION | T_UNHEAP);
+
+ s7_gc_unprotect_at(sc, gc_loc);
+ return(func);
+}
+
+s7_pointer s7_make_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc)
+{
+ s7_pointer func = s7_make_function_star(sc, name, fnc, arglist, doc);
+ set_full_type(func, full_type(func) | T_SAFE_PROCEDURE); /* don't step on the c_func_has_simple_defaults flag */
+ if (is_c_function_star(func)) /* thunk -> c_function */
+ c_function_call_args(func) = semipermanent_list(sc, c_function_optional_args(func));
+ return(func);
+}
+
+static void define_function_star_1(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc, bool safe, s7_pointer signature)
+{
+ s7_pointer func;
+ if (safe)
+ func = s7_make_safe_function_star(sc, name, fnc, arglist, doc);
+ else func = s7_make_function_star(sc, name, fnc, arglist, doc);
+ s7_define(sc, sc->rootlet, make_symbol_with_strlen(sc, name), func);
+ if (signature) c_function_signature(func) = signature;
+}
+
+void s7_define_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc)
+{
+ define_function_star_1(sc, name, fnc, arglist, doc, false, NULL);
+}
+
+void s7_define_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc)
+{
+ define_function_star_1(sc, name, fnc, arglist, doc, true, NULL);
+}
+
+void s7_define_typed_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc, s7_pointer signature)
+{
+ define_function_star_1(sc, name, fnc, arglist, doc, true, signature);
+}
+
+
+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_pointer func = s7_make_function(sc, name, fnc, required_args, optional_args, rest_arg, doc);
+ s7_pointer sym = make_symbol_with_strlen(sc, name);
+ set_full_type(func, T_C_MACRO | T_DONT_EVAL_ARGS | T_UNHEAP); /* s7_make_function includes T_UNHEAP */
+ s7_define(sc, sc->rootlet, sym, func);
+ return(sym);
+}
+
+
+/* -------------------------------- macro? -------------------------------- */
+bool s7_is_macro(s7_scheme *sc, s7_pointer x) {return(is_any_macro(x));}
+static bool is_macro_b(s7_pointer x) {return(is_any_macro(x));}
+
+static s7_pointer g_is_macro(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_macro "(macro? arg) returns #t if 'arg' is a macro or a bacro"
+ #define Q_is_macro sc->pl_bt
+ check_boolean_method(sc, is_any_macro, sc->is_macro_symbol, args);
+}
+
+static bool closure_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int32_t args);
+
+static s7_pointer s7_macroexpand(s7_scheme *sc, s7_pointer mac, s7_pointer args)
+{
+ int32_t arg_len;
+ if (!s7_is_proper_list(sc, args))
+ return(sc->F);
+
+ arg_len = proper_list_length(args);
+ if (!closure_is_aritable(sc, mac, closure_args(mac), arg_len))
+ return(sc->F);
+
+ push_stack_direct(sc, OP_EVAL_DONE);
+ sc->code = mac;
+ sc->args = args;
+ set_curlet(sc, make_let(sc, closure_let(sc->code)));
+ eval(sc, OP_APPLY_LAMBDA);
+ return(sc->value);
+}
+
+
+/* -------------------------------- documentation -------------------------------- */
+const char *s7_documentation(s7_scheme *sc, s7_pointer x)
+{
+ s7_pointer val;
+ if (is_symbol(x))
+ {
+ if (is_keyword(x)) return(NULL);
+ if (symbol_has_help(x))
+ return(symbol_help(x));
+ x = s7_symbol_value(sc, x); /* this is needed by Snd */
+ }
+ if ((is_any_c_function(x)) ||
+ (is_c_macro(x)))
+ return((const char *)c_function_documentation(x));
+
+ if (is_syntax(x))
+ return(syntax_documentation(x));
+
+ val = funclet_entry(sc, x, sc->local_documentation_symbol);
+ if ((val) && (is_string(val)))
+ return(string_value(val));
+
+ if (has_closure_let(x))
+ {
+ val = closure_body(x);
+ if ((is_pair(val)) && (is_string(car(val))))
+ return((char *)string_value(car(val)));
+ }
+ return(NULL);
+}
+
+static s7_pointer g_documentation(s7_scheme *sc, s7_pointer args)
+{
+ #define H_documentation "(documentation obj) returns obj's documentation string"
+ #define Q_documentation s7_make_signature(sc, 2, sc->is_string_symbol, sc->T) /* should (documentation 1) be an error? */
+
+ s7_pointer p = car(args);
+ if (is_symbol(p))
+ {
+ if ((symbol_has_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)
+ * so we check that case ahead of time here, rather than going through check_method which does not
+ * call find_let unless has_active_methods(sc, func). Adding T_HAS_METHODS to all closures causes other troubles.
+ */
+ if (has_closure_let(p))
+ {
+ s7_pointer func = funclet_entry(sc, p, sc->documentation_symbol);
+ if (func)
+ return(s7_apply_function(sc, func, args));
+ func = closure_body(p);
+ if ((is_pair(func)) && (is_string(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);
+ return(s7_make_string(sc, s7_documentation(sc, p)));
+}
+
+const char *s7_set_documentation(s7_scheme *sc, s7_pointer sym, const char *new_doc)
+{
+ if (is_keyword(sym)) return(NULL);
+ if (is_symbol(sym))
+ {
+ symbol_set_has_help(sym);
+ symbol_set_help(sym, copy_string(new_doc));
+ add_saved_pointer(sc, symbol_help(sym));
+ }
+ return(new_doc);
+}
+
+
+/* -------------------------------- help -------------------------------- */
+const char *s7_help(s7_scheme *sc, s7_pointer obj)
+{
+ if (is_syntax(obj))
+ return(syntax_documentation(obj));
+
+ if (is_symbol(obj))
+ {
+ /* here look for name */
+ if (s7_documentation(sc, obj))
+ return(s7_documentation(sc, obj));
+ obj = s7_symbol_value(sc, obj);
+ }
+ if (is_any_procedure(obj))
+ return(s7_documentation(sc, obj));
+
+ if (obj == sc->s7_starlet)
+ return("*s7* is a let that gives access to s7's internal state: e.g. (*s7* 'print-length)");
+
+ /* if is string, apropos? (can scan symbol table) */
+ return(NULL);
+}
+
+static s7_pointer g_help(s7_scheme *sc, s7_pointer args)
+{
+ #define H_help "(help obj) returns obj's documentation"
+ #define Q_help s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_string_symbol, sc->is_boolean_symbol), sc->T)
+ const char *doc;
+ check_method(sc, car(args), sc->help_symbol, args);
+ doc = s7_help(sc, car(args));
+ return((doc) ? s7_make_string(sc, doc) : sc->F);
+}
+
+
+/* -------------------------------- signature -------------------------------- */
+static void init_signatures(s7_scheme *sc)
+{
+ sc->string_signature = s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol);
+ sc->byte_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_byte_symbol, sc->is_byte_vector_symbol, sc->is_integer_symbol);
+ sc->vector_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_vector_symbol, sc->is_integer_symbol);
+ sc->float_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_float_symbol, sc->is_float_vector_symbol, sc->is_integer_symbol);
+ sc->int_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_int_vector_symbol, sc->is_integer_symbol);
+ sc->c_object_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_c_object_symbol, sc->T);
+ sc->let_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_let_symbol, sc->is_symbol_symbol);
+ sc->hash_table_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_hash_table_symbol, sc->T);
+ sc->pair_signature = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_pair_symbol, sc->is_integer_symbol);
+}
+
+static s7_pointer g_signature(s7_scheme *sc, s7_pointer args)
+{
+ #define H_signature "(signature obj) returns obj's signature"
+ #define Q_signature s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->is_boolean_symbol), sc->T)
+
+ s7_pointer p = car(args);
+ switch (type(p))
+ {
+ case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION:
+ case T_C_FUNCTION_STAR: case T_C_MACRO:
+ return((s7_pointer)c_function_signature(p));
+
+ case T_MACRO: case T_MACRO_STAR:
+ 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);
+ }
+
+ 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);
+ {
+ 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);
+ case T_INT_VECTOR: return((vector_length(p) == 0) ? sc->F : sc->int_vector_signature);
+ case T_BYTE_VECTOR: return((vector_length(p) == 0) ? sc->F : sc->byte_vector_signature);
+ case T_PAIR: return(sc->pair_signature);
+ case T_STRING: return(sc->string_signature);
+
+ 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(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));
+ p = g_signature(sc, set_plist_1(sc, p));
+ return(list_1(sc, (is_pair(p)) ? car(p) : sc->T));
+
+ case T_C_OBJECT:
+ check_method(sc, p, sc->signature_symbol, args);
+ return(sc->c_object_signature);
+
+ case T_LET:
+ check_method(sc, p, sc->signature_symbol, args);
+ return(sc->let_signature);
+
+ 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)));
+ }}
+ break;
+
+ default: break;
+ }
+ return(sc->F);
+}
+
+s7_pointer s7_signature(s7_scheme *sc, s7_pointer func) {return(g_signature(sc, set_plist_1(sc, func)));}
+
+
+/* -------------------------------- dynamic-wind -------------------------------- */
+static s7_pointer closure_or_f(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer body;
+ if (!is_closure(p)) return(p);
+ body = closure_body(p);
+ if (is_pair(cdr(body))) return(p);
+ if (!is_pair(car(body))) return(sc->F);
+ return((is_quote(caar(body))) ? sc->F : p);
+}
+
+static s7_pointer make_baffled_closure(s7_scheme *sc, s7_pointer inp)
+{
+ /* for dynamic-wind to protect initial and final functions from call/cc */
+ s7_pointer nclo = make_closure_unchecked(sc, sc->nil, closure_body(inp), type(inp), 0); /* always preceded by new dw cell */
+ s7_pointer let = make_let(sc, closure_let(inp)); /* let_outlet(let) = closure_let(inp) */
+ set_baffle_let(let);
+ set_let_baffle_key(let, sc->baffle_ctr++);
+ closure_set_let(nclo, let);
+ return(nclo);
+}
+
+static bool is_dwind_thunk(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_MACRO: case T_BACRO: case T_CLOSURE:
+ case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR:
+ return(is_null(closure_args(x))); /* this case does not match is_aritable -- it could be loosened -- arity=0 below would need fixup */
+ case T_C_FUNCTION:
+ return(c_function_is_aritable(x, 0));
+ case T_C_FUNCTION_STAR:
+ return(c_function_max_args(x) >= 0);
+ case T_C_MACRO:
+ return((c_macro_min_args(x) <= 0) && (c_macro_max_args(x) >= 0));
+ case T_GOTO: case T_CONTINUATION: case T_C_RST_NO_REQ_FUNCTION:
+ return(true);
+ }
+ return(x == sc->F); /* (dynamic-wind #f (lambda () 3) #f) */
+}
+
+static s7_pointer g_dynamic_wind_unchecked(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p, inp, outp;
+
+ new_cell(sc, p, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */
+ dynamic_wind_in(p) = closure_or_f(sc, car(args));
+ dynamic_wind_body(p) = cadr(args);
+ dynamic_wind_out(p) = closure_or_f(sc, caddr(args));
+
+ inp = dynamic_wind_in(p);
+ if ((is_any_closure(inp)) && (!is_safe_closure(inp))) /* wrap this use of inp in a with-baffle */
+ dynamic_wind_in(p) = make_baffled_closure(sc, inp);
+
+ outp = dynamic_wind_out(p);
+ if ((is_any_closure(outp)) && (!is_safe_closure(outp)))
+ dynamic_wind_out(p) = make_baffled_closure(sc, outp);
+
+ /* since we don't care about the in and out results, and they are thunks, if the body is not a pair,
+ * or is a quoted thing, we just ignore that function.
+ */
+ push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p); /* args will be the saved result, code = s7_dynwind_t obj */
+ if (inp != sc->F)
+ {
+ dynamic_wind_state(p) = DWIND_INIT;
+ push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(p));
+ }
+ else
+ {
+ dynamic_wind_state(p) = DWIND_BODY;
+ push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_body(p));
+ }
+ return(sc->F);
+}
+
+static s7_pointer g_dynamic_wind_init(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p, inp = closure_or_f(sc, car(args));
+ new_cell(sc, p, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */
+ dynamic_wind_in(p) = inp;
+ dynamic_wind_body(p) = cadr(args);
+ dynamic_wind_out(p) = sc->F;
+ if ((is_any_closure(inp)) && (!is_safe_closure(inp))) /* wrap this use of inp in a with-baffle */
+ dynamic_wind_in(p) = make_baffled_closure(sc, inp);
+ push_stack(sc, OP_DYNAMIC_WIND, sc->nil, p); /* args will be the saved result, code = s7_dynwind_t obj */
+ dynamic_wind_state(p) = DWIND_INIT;
+ push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(p));
+ return(sc->F);
+}
+
+static s7_pointer g_dynamic_wind_body(s7_scheme *sc, s7_pointer args)
+{
+ push_stack(sc, OP_APPLY, sc->nil, cadr(args));
+ return(sc->F);
+}
+
+static s7_pointer g_dynamic_wind(s7_scheme *sc, s7_pointer args)
+{
+ #define H_dynamic_wind "(dynamic-wind init body finish) calls init, then body, then finish, \
+each a function of no arguments, guaranteeing that finish is called even if body is exited"
+ #define Q_dynamic_wind s7_make_signature(sc, 4, sc->values_symbol, \
+ s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->not_symbol), \
+ sc->is_procedure_symbol, \
+ s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->not_symbol))
+
+ if (!is_dwind_thunk(sc, car(args)))
+ return(method_or_bust(sc, car(args), sc->dynamic_wind_symbol, args, wrap_string(sc, "a thunk or #f", 13), 1));
+ if (!is_thunk(sc, cadr(args)))
+ return(method_or_bust(sc, cadr(args), sc->dynamic_wind_symbol, args, a_thunk_string, 2));
+ if (!is_dwind_thunk(sc, caddr(args)))
+ return(method_or_bust(sc, caddr(args), sc->dynamic_wind_symbol, args, wrap_string(sc, "a thunk or #f", 13), 3));
+
+ /* this won't work:
+ (let ((final (lambda (a b c) (list a b c))))
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () (set! final (lambda () (display "in final"))))
+ final))
+ * but why not? 'final' is a thunk by the time it is evaluated. catch (the error handler) is similar.
+ * It can't work here because we set up the dynamic_wind_out slot below and
+ * even if the thunk check was removed, we'd still be trying to apply the original function.
+ */
+ return(g_dynamic_wind_unchecked(sc, args));
+}
+
+static bool is_lambda(s7_scheme *sc, s7_pointer sym)
+{
+ return((sym == sc->lambda_symbol) && (symbol_id(sym) == 0)); /* do we need (!sc->in_with_let) ? */
+ /* symbol_id=0 means it has never been rebound (T_GLOBAL might not be set for initial stuff) */
+}
+
+static int32_t is_ok_thunk(s7_scheme *sc, s7_pointer arg) /* used only in dynamic_wind_chooser */
+{
+ /* 0 = not ok, 1 = ok but not simple, 2 = ok body is just #f, 3 = #f */
+ if (arg == sc->F) return(3);
+ if ((is_pair(arg)) &&
+ (is_lambda(sc, car(arg))) &&
+ (is_pair(cdr(arg))) &&
+ (is_null(cadr(arg))) && /* (lambda () ...) */
+ (is_pair(cddr(arg))) &&
+ (s7_is_proper_list(sc, cddr(arg))))
+ return(((is_null(cdddr(arg))) && (caddr(arg) == sc->F)) ? 2 : 1); /* 2: (lambda () #f) */
+ return(0);
+}
+
+static s7_pointer dynamic_wind_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr)
+{
+ if ((args == 3) &&
+ (is_ok_thunk(sc, caddr(expr))))
+ {
+ int32_t init = is_ok_thunk(sc, cadr(expr));
+ int32_t end = is_ok_thunk(sc, cadddr(expr));
+ if ((init > 1) && (end > 1)) return(sc->dynamic_wind_body);
+ if ((init > 0) && (end > 1)) return(sc->dynamic_wind_init);
+ if ((init > 0) && (end > 0)) return(sc->dynamic_wind_unchecked);
+ }
+ return(f);
+}
+
+s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_pointer finish)
+{
+ /* this is essentially s7_call with a dynamic-wind wrapper around "body" */
+ declare_jump_info();
+ store_jump_info(sc);
+ set_jump_info(sc, DYNAMIC_WIND_SET_JUMP);
+ if (jump_loc != NO_JUMP)
+ {
+ if (jump_loc != ERROR_JUMP)
+ eval(sc, sc->cur_op);
+ }
+ else
+ {
+ s7_pointer p;
+ push_stack_direct(sc, OP_EVAL_DONE); /* this is ok because we have called setjmp etc */
+ sc->args = sc->nil;
+ new_cell(sc, p, T_DYNAMIC_WIND);
+ dynamic_wind_in(p) = T_Ext(init);
+ dynamic_wind_body(p) = T_Ext(body);
+ 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;
+ }
+ else
+ {
+ dynamic_wind_state(p) = DWIND_BODY;
+ sc->code = body;
+ }
+ eval(sc, OP_APPLY);
+ }
+ restore_jump_info(sc);
+
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+ return(sc->value);
+}
+
+static void op_unwind_output(s7_scheme *sc)
+{
+ bool is_file = is_file_port(sc->code);
+
+ if ((is_output_port(sc->code)) &&
+ (!port_is_closed(sc->code)))
+ s7_close_output_port(sc, sc->code); /* may call fflush */
+ if (((is_output_port(sc->args)) &&
+ (!port_is_closed(sc->args))) ||
+ (sc->args == sc->F))
+ set_current_output_port(sc, sc->args);
+ if ((is_file) &&
+ (is_multiple_value(sc->value)))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+}
+
+static void op_unwind_input(s7_scheme *sc)
+{
+ /* sc->code is an input port */
+ if (!port_is_closed(sc->code))
+ s7_close_input_port(sc, sc->code);
+ if ((is_input_port(sc->args)) &&
+ (!port_is_closed(sc->args)))
+ set_current_input_port(sc, sc->args);
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+}
+
+static bool op_dynamic_wind(s7_scheme *sc)
+{
+ s7_pointer dwind = T_Dyn(sc->code);
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_truncated(dwind));
+ if (dynamic_wind_state(dwind) == DWIND_INIT)
+ {
+ dynamic_wind_state(dwind) = DWIND_BODY;
+ push_stack(sc, OP_DYNAMIC_WIND, sc->nil, dwind);
+ sc->code = dynamic_wind_body(dwind);
+ sc->args = sc->nil;
+ return(true); /* goto apply */
+ }
+ if (dynamic_wind_state(dwind) == DWIND_BODY)
+ {
+ 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);
+ }
+ if (is_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) */
+ sc->value = splice_in_values(sc, multiple_value(sc->args));
+ else sc->value = sc->args; /* value saved above */
+ return(false);
+}
+
+
+/* -------------------------------- c-object? -------------------------------- */
+bool s7_is_c_object(s7_pointer p) {return(is_c_object(p));}
+
+static s7_pointer g_is_c_object(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_c_object "(c-object? obj) returns #t is obj is a c-object."
+ #define Q_is_c_object sc->pl_bt
+ s7_pointer obj = car(args);
+ if (is_c_object(obj)) return(sc->T);
+ if (!has_active_methods(sc, obj)) return(sc->F);
+ return(apply_boolean_method(sc, obj, sc->is_c_object_symbol));
+}
+
+
+/* -------------------------------- c-object-type -------------------------------- */
+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 */
+}
+
+static void fallback_free(void *value) {}
+static void fallback_mark(void *value) {}
+
+static s7_pointer fallback_ref(s7_scheme *sc, s7_pointer args) {apply_error_nr(sc, car(args), cdr(args)); return(NULL);}
+static s7_pointer fallback_set(s7_scheme *sc, s7_pointer args) {syntax_error_nr(sc, "attempt to set ~S?", 18, car(args)); return(NULL);}
+static s7_pointer fallback_length(s7_scheme *sc, s7_pointer obj) {return(sc->F);}
+
+s7_int s7_c_object_type(s7_pointer obj) {return((is_c_object(obj)) ? c_object_type(obj) : -1);}
+
+static s7_pointer g_c_object_type(s7_scheme *sc, s7_pointer args)
+{
+ #define H_c_object_type "(c-object-type obj) returns the c_object's type tag."
+ #define Q_c_object_type s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_c_object_symbol)
+
+ s7_pointer p = car(args);
+ if (is_c_object(p))
+ return(make_integer(sc, c_object_type(p))); /* this is the c_object_types table index = tag */
+
+ /* method or bust with only one arg -- sole_arg_method_or_bust? */
+ if (!has_active_methods(sc, p))
+ sole_arg_wrong_type_error_nr(sc, sc->c_object_type_symbol, p, sc->type_names[T_C_OBJECT]);
+ return(find_and_apply_method(sc, p, sc->c_object_type_symbol, args));
+}
+
+static s7_pointer g_c_object_set(s7_scheme *sc, s7_pointer args) /* called in c_object_set_function */
+{
+ s7_pointer obj = car(args);
+ if (!is_c_object(obj)) /* (call/cc (setter (block))) will call c-object-set! with the continuation as the argument! */
+ wrong_type_error_nr(sc, make_symbol(sc, "c-object-set!", 13), 1, obj, sc->type_names[T_C_OBJECT]);
+ return((*(c_object_set(sc, obj)))(sc, args));
+}
+
+s7_int s7_make_c_type(s7_scheme *sc, const char *name) /* shouldn't this be s7_make_c_object_type? */
+{
+ c_object_t *c_type;
+ s7_int tag = sc->num_c_object_types++;
+
+ 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 *));
+ }
+ 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 *));
+ }}
+ 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;
+ c_type->scheme_name = make_permanent_string(name, safe_strlen(name));
+ c_type->getter = sc->F;
+ c_type->setter = sc->F;
+ c_type->free = fallback_free;
+ c_type->mark = fallback_mark;
+ c_type->ref = fallback_ref;
+ c_type->set = fallback_set;
+ c_type->outer_type = T_C_OBJECT;
+ c_type->length = fallback_length;
+ /* all other fields are NULL */
+ return(tag);
+}
+
+void s7_c_type_set_gc_free(s7_scheme *sc, s7_int tag, s7_pointer (*gc_free)(s7_scheme *sc, s7_pointer obj)) {sc->c_object_types[tag]->gc_free = gc_free;}
+void s7_c_type_set_gc_mark(s7_scheme *sc, s7_int tag, s7_pointer (*marker)(s7_scheme *sc, s7_pointer obj)) {sc->c_object_types[tag]->gc_mark = marker;}
+void s7_c_type_set_equal(s7_scheme *sc, s7_int tag, bool (*equal)(void *value1, void *value2)) {sc->c_object_types[tag]->eql = equal;}
+void s7_c_type_set_is_equal(s7_scheme *sc, s7_int tag, s7_pointer (*is_equal)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->equal = is_equal;}
+void s7_c_type_set_copy(s7_scheme *sc, s7_int tag, s7_pointer (*copy)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->copy = copy;}
+void s7_c_type_set_fill(s7_scheme *sc, s7_int tag, s7_pointer (*fill)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->fill = fill;}
+void s7_c_type_set_reverse(s7_scheme *sc, s7_int tag, s7_pointer (*reverse)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->reverse = reverse;}
+void s7_c_type_set_to_list(s7_scheme *sc, s7_int tag, s7_pointer (*to_list)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->to_list = to_list;}
+void s7_c_type_set_to_string(s7_scheme *sc, s7_int tag, s7_pointer (*to_string)(s7_scheme *sc, s7_pointer args)) {sc->c_object_types[tag]->to_string = to_string;}
+
+void s7_c_type_set_length(s7_scheme *sc, s7_int tag, s7_pointer (*length)(s7_scheme *sc, s7_pointer args))
+{
+ sc->c_object_types[tag]->length = (length) ? length : fallback_length; /* is_sequence(c_obj) is #t so we need a length method */
+}
+
+void s7_c_type_set_is_equivalent(s7_scheme *sc, s7_int tag, s7_pointer (*is_equivalent)(s7_scheme *sc, s7_pointer args))
+{
+ sc->c_object_types[tag]->equivalent = is_equivalent;
+}
+
+void s7_c_type_set_free(s7_scheme *sc, s7_int tag, void (*gc_free)(void *value))
+{
+ sc->c_object_types[tag]->free = (gc_free) ? gc_free : fallback_free;
+}
+
+void s7_c_type_set_mark(s7_scheme *sc, s7_int tag, void (*mark)(void *value))
+{
+ sc->c_object_types[tag]->mark = (mark) ? mark : fallback_mark;
+}
+
+void s7_c_type_set_ref(s7_scheme *sc, s7_int tag, s7_pointer (*ref)(s7_scheme *sc, s7_pointer args))
+{
+ sc->c_object_types[tag]->ref = (ref) ? ref : fallback_ref;
+ sc->c_object_types[tag]->outer_type = (sc->c_object_types[tag]->ref == fallback_ref) ? T_C_OBJECT : (T_C_OBJECT | T_SAFE_PROCEDURE);
+}
+
+void s7_c_type_set_getter(s7_scheme *sc, s7_int tag, s7_pointer getter)
+{
+ sc->c_object_types[tag]->getter = (getter) ? T_Fnc(getter) : sc->F;
+}
+
+void s7_c_type_set_set(s7_scheme *sc, s7_int tag, s7_pointer (*set)(s7_scheme *sc, s7_pointer args))
+{
+ sc->c_object_types[tag]->set = (set) ? set : fallback_set;
+}
+
+void s7_c_type_set_setter(s7_scheme *sc, s7_int tag, s7_pointer setter)
+{
+ sc->c_object_types[tag]->setter = (setter) ? T_Fnc(setter) : sc->F;
+}
+
+void *s7_c_object_value(s7_pointer obj) {return(c_object_value(obj));}
+
+void *s7_c_object_value_checked(s7_pointer obj, s7_int type)
+{
+ if ((is_c_object(obj)) && (c_object_type(obj) == type))
+ return(c_object_value(obj));
+ return(NULL);
+}
+
+static s7_pointer make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let, bool with_gc)
+{
+ s7_pointer x;
+ new_cell(sc, x, sc->c_object_types[type]->outer_type);
+
+ /* c_object_info(x) = &(sc->c_object_types[type]); */
+ /* that won't work because c_object_types can move when it is realloc'd and the old stuff is freed by realloc
+ * and since we're checking (for example) ref_2 existence as not null, we can't use a table of c_object_t's!
+ * Using mallocate (s7_make_c_object_with_data) is faster, but not enough to warrant the code.
+ */
+ c_object_type(x) = type;
+ c_object_value(x) = value;
+ c_object_set_let(x, let);
+ c_object_s7(x) = sc;
+ if (with_gc) add_c_object(sc, x);
+ return(x);
+}
+
+s7_pointer s7_make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let)
+{
+ return(make_c_object_with_let(sc, type, value, let, true));
+}
+
+s7_pointer s7_make_c_object(s7_scheme *sc, s7_int type, void *value)
+{
+ return(make_c_object_with_let(sc, type, value, sc->rootlet, true));
+}
+
+s7_pointer s7_make_c_object_without_gc(s7_scheme *sc, s7_int type, void *value)
+{
+ return(make_c_object_with_let(sc, type, value, sc->rootlet, false));
+}
+
+s7_pointer s7_c_object_let(s7_pointer obj) {return(c_object_let(obj));}
+
+s7_pointer s7_c_object_set_let(s7_scheme *sc, s7_pointer obj, s7_pointer e)
+{
+ if ((!is_immutable(obj)) &&
+ (is_let(e)))
+ c_object_set_let(obj, e);
+ return(e);
+}
+
+static s7_pointer c_object_length(s7_scheme *sc, s7_pointer obj)
+{
+ return((*(c_object_len(sc, obj)))(sc, set_clist_1(sc, obj)));
+}
+
+static s7_int c_object_length_to_int(s7_scheme *sc, s7_pointer obj)
+{
+ s7_pointer res = (*(c_object_len(sc, obj)))(sc, set_clist_1(sc, obj));
+ if (s7_is_integer(res))
+ return(s7_integer_clamped_if_gmp(sc, res));
+ return(-1);
+}
+
+static s7_pointer copy_c_object(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer obj = car(args);
+ check_method(sc, obj, sc->copy_symbol, args);
+ if (!c_object_copy(sc, obj))
+ missing_method_error_nr(sc, sc->copy_symbol, obj);
+ return((*(c_object_copy(sc, obj)))(sc, args));
+}
+
+static s7_pointer c_object_type_to_let(s7_scheme *sc, s7_pointer cobj)
+{
+ s7_int type = c_object_type(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)));
+ /* can't display equal et al in c_types -- maybe sc->F or the pointer? or add getter equivalent fields for equal et al? */
+}
+
+static void apply_c_object(s7_scheme *sc) /* -------- applicable c_object -------- */
+{
+ sc->value = (*(c_object_ref(sc, sc->code)))(sc, set_ulist_1(sc, sc->code, sc->args));
+ set_car(sc->u1_1, sc->F);
+}
+
+static bool op_implicit_c_object_ref_a(s7_scheme *sc)
+{
+ s7_pointer c = lookup_checked(sc, car(sc->code));
+ if (!is_c_object(c)) {sc->last_function = c; return(false);}
+ set_car(sc->t2_2, fx_call(sc, cdr(sc->code)));
+ set_car(sc->t2_1, c); /* fx_call above might use sc->t2* */
+ sc->value = (*(c_object_ref(sc, c)))(sc, sc->t2_1);
+ return(true);
+}
+
+static s7_pointer fx_implicit_c_object_ref_a(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer c = lookup_checked(sc, car(arg));
+ if (!is_c_object(c))
+ return(s7_apply_function(sc, c, list_1(sc, fx_call(sc, cdr(arg)))));
+ set_car(sc->t2_2, fx_call(sc, cdr(arg)));
+ set_car(sc->t2_1, c); /* fx_call above might use sc->t2* */
+ return((*(c_object_ref(sc, c)))(sc, sc->t2_1));
+}
+
+
+/* -------- 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)
+{
+ s7_pointer get_func, set_func;
+ char *internal_set_name;
+ s7_int len, name_len;
+
+ if (!name) return(sc->F);
+ name_len = safe_strlen(name);
+ len = 16 + name_len;
+ internal_set_name = (char *)permalloc(sc, len);
+ internal_set_name[0] = '\0';
+ catstrs_direct(internal_set_name, "[set-", name, "]", (const char *)NULL);
+ get_func = s7_make_safe_function(sc, name, getter, get_req_args, get_opt_args, false, documentation);
+ s7_define(sc, envir, make_symbol(sc, name, name_len), get_func);
+ set_func = s7_make_safe_function(sc, internal_set_name, setter, set_req_args, set_opt_args, false, documentation);
+ c_function_set_setter(get_func, set_func);
+ return(get_func);
+}
+
+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)
+{
+ 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)
+{
+ 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);
+ if (get_sig) c_function_signature(get_func) = get_sig;
+ if (set_sig) c_function_signature(set_func) = set_sig;
+ return(get_func);
+}
+
+
+/* -------------------------------- dilambda? -------------------------------- */
+bool s7_is_dilambda(s7_pointer obj)
+{
+ switch (type(obj))
+ {
+ case T_MACRO: case T_MACRO_STAR:
+ case T_BACRO: case T_BACRO_STAR:
+ case T_CLOSURE: case T_CLOSURE_STAR:
+ return(is_any_procedure(closure_setter_or_map_list(obj))); /* type >= T_CLOSURE (excludes goto/continuation) */
+ case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION_STAR:
+ return(is_any_procedure(c_function_setter(obj)));
+ case T_C_MACRO:
+ return(is_any_procedure(c_macro_setter(obj)));
+ }
+ return(false);
+}
+
+static s7_pointer g_is_dilambda(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_dilambda "(dilambda? obj) returns #t if obj is a procedure with setter."
+ #define Q_is_dilambda sc->pl_bt
+ check_boolean_method(sc, s7_is_dilambda, sc->is_dilambda_symbol, args);
+}
+
+
+/* -------------------------------- dilambda -------------------------------- */
+static s7_pointer g_dilambda(s7_scheme *sc, s7_pointer args)
+{
+ #define H_dilambda "(dilambda getter setter) sets getter's setter to be setter."
+ #define Q_dilambda s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->is_procedure_symbol)
+
+ s7_pointer getter = car(args), setter;
+ if (!is_any_procedure(getter))
+ wrong_type_error_nr(sc, sc->dilambda_symbol, 1, getter, a_procedure_or_a_macro_string);
+
+ setter = cadr(args);
+ if (!is_any_procedure(setter))
+ wrong_type_error_nr(sc, sc->dilambda_symbol, 2, setter, a_procedure_or_a_macro_string);
+
+ s7_set_setter(sc, getter, setter);
+ return(getter);
+}
+
+
+/* -------------------------------- arity -------------------------------- */
+static s7_pointer closure_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer x_args)
+{
+ /* x_args is unprocessed -- it is exactly the list as used in the closure[*] definition */
+ int32_t len;
+
+ if (is_symbol(x_args)) /* any number of args is ok */
+ return(cons(sc, int_zero, max_arity));
+ if (closure_arity_unknown(x))
+ closure_set_arity(x, s7_list_length(sc, x_args));
+ len = closure_arity(x);
+ if (len < 0) /* dotted list => rest arg, (length '(a b . c)) is -2 */
+ return(cons(sc, make_integer(sc, -len), max_arity));
+ return(cons(sc, make_integer(sc, len), make_integer_unchecked(sc, len)));
+}
+
+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);
+ 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 */
+ }}
+}
+
+static s7_pointer closure_star_arity_to_cons(s7_scheme *sc, s7_pointer x, s7_pointer x_args)
+{
+ closure_star_arity_1(sc, x, x_args);
+ return((closure_arity(x) == -1) ? cons(sc, int_zero, max_arity) : cons(sc, int_zero, make_integer(sc, closure_arity(x))));
+}
+
+static int32_t closure_arity_to_int(s7_scheme *sc, s7_pointer x)
+{
+ /* not lambda* here */
+ if (closure_arity_unknown(x))
+ {
+ int32_t i;
+ 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);
+ else
+ {
+ if (i == 0)
+ return(-1);
+ closure_set_arity(x, -i);
+ }}
+ return(closure_arity(x));
+}
+
+static int32_t closure_star_arity_to_int(s7_scheme *sc, s7_pointer x)
+{
+ /* not lambda here */
+ closure_star_arity_1(sc, x, closure_args(x));
+ return(closure_arity(x));
+}
+
+s7_pointer s7_arity(s7_scheme *sc, s7_pointer x)
+{
+ switch (type(x))
+ {
+ case T_C_FUNCTION:
+ return(cons(sc, make_integer(sc, c_function_min_args(x)), make_integer_unchecked(sc, c_function_max_args(x))));
+ case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION_STAR:
+ return(cons(sc, int_zero, make_integer(sc, c_function_max_args(x))));
+ case T_MACRO: case T_BACRO: case T_CLOSURE:
+ return(closure_arity_to_cons(sc, x, closure_args(x)));
+ case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR:
+ return(closure_star_arity_to_cons(sc, x, closure_args(x)));
+ case T_C_MACRO:
+ return(cons(sc, make_integer(sc, c_macro_min_args(x)), make_integer_unchecked(sc, c_macro_max_args(x))));
+ case T_GOTO: case T_CONTINUATION:
+ return(cons(sc, int_zero, max_arity));
+ case T_STRING:
+ return((string_length(x) == 0) ? sc->F : cons(sc, int_one, int_one));
+ case T_LET:
+ return(cons(sc, int_one, int_one));
+ case T_C_OBJECT:
+ check_method(sc, x, sc->arity_symbol, set_plist_1(sc, x));
+ return((is_safe_procedure(x)) ? cons(sc, int_zero, max_arity) : sc->F);
+ case T_VECTOR:
+ if (vector_length(x) == 0) return(sc->F);
+ if (has_simple_elements(x)) return(cons(sc, int_one, make_integer(sc, vector_rank(x))));
+ return(cons(sc, int_one, max_arity));
+ case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR:
+ return((vector_length(x) == 0) ? sc->F : cons(sc, int_one, make_integer(sc, vector_rank(x))));
+ case T_PAIR: case T_HASH_TABLE:
+ return(cons(sc, int_one, max_arity));
+ case T_ITERATOR:
+ return(cons(sc, int_zero, int_zero));
+ case T_SYNTAX:
+ return(cons(sc, small_int(syntax_min_args(x)), (syntax_max_args(x) == -1) ? max_arity : small_int(syntax_max_args(x))));
+ }
+ return(sc->F);
+}
+
+static s7_pointer g_arity(s7_scheme *sc, s7_pointer args)
+{
+ #define H_arity "(arity obj) the min and max number of args that obj can be applied to. Returns #f if the object is not applicable."
+ #define Q_arity s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_pair_symbol, sc->not_symbol), sc->T)
+ /* check_method(sc, p, sc->arity_symbol, args); */
+ return(s7_arity(sc, car(args)));
+}
+
+
+/* -------------------------------- aritable? -------------------------------- */
+static bool closure_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int32_t args)
+{
+ /* x_args is unprocessed -- it is exactly the list as used in the closure definition */
+ s7_int len;
+
+ if (args == 0)
+ return(!is_pair(x_args));
+ if (is_symbol(x_args)) /* any number of args is ok */
+ return(true);
+
+ len = closure_arity(x);
+ if (len == CLOSURE_ARITY_NOT_SET)
+ {
+ len = s7_list_length(sc, x_args);
+ closure_set_arity(x, len);
+ }
+ if (len < 0) /* dotted list => rest arg, (length '(a b . c)) is -2 */
+ return((-len) <= args); /* so we have enough to take care of the required args */
+ return(args == len); /* in a normal lambda list, there are no other possibilities */
+}
+
+static bool closure_star_is_aritable(s7_scheme *sc, s7_pointer x, s7_pointer x_args, int32_t args)
+{
+ if (is_symbol(x_args))
+ return(true);
+ closure_star_arity_1(sc, x, x_args);
+ return((closure_arity(x) == -1) ||
+ (args <= closure_arity(x)));
+}
+
+bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args)
+{
+ switch (type(x))
+ {
+ case T_C_FUNCTION:
+ 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);
+ case T_C_FUNCTION_STAR:
+ return(c_function_max_args(x) >= args);
+
+ case T_MACRO: case T_BACRO: case T_CLOSURE:
+ return(closure_is_aritable(sc, x, closure_args(x), args));
+
+ case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR:
+ return(closure_star_is_aritable(sc, x, closure_args(x), args));
+
+ case T_C_MACRO:
+ return((c_macro_min_args(x) <= args) &&
+ (c_macro_max_args(x) >= args));
+
+ case T_GOTO: case T_CONTINUATION:
+ return(true);
+
+ case T_STRING:
+ return((args == 1) && (string_length(x) > 0)); /* ("" 0) -> error */
+
+ 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));
+ }
+
+ 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)));
+
+ case T_LET: case T_HASH_TABLE: case T_PAIR: /* for hash-table, this refers to (table 'key) */
+ return(args == 1);
+
+ case T_ITERATOR:
+ return(args == 0);
+
+ case T_SYNTAX:
+ return((args >= syntax_min_args(x)) && ((args <= syntax_max_args(x)) || (syntax_max_args(x) == -1)));
+ }
+ return(false);
+}
+
+static s7_pointer g_is_aritable(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_aritable "(aritable? obj num-args) returns #t if 'obj can be applied to 'num-args arguments."
+ #define Q_is_aritable s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->T, sc->is_integer_symbol)
+
+ s7_pointer n = cadr(args);
+ s7_int num;
+
+ if (!s7_is_integer(n)) /* remember gmp case! */
+ return(method_or_bust(sc, n, sc->is_aritable_symbol, args, sc->type_names[T_INTEGER], 2));
+
+ num = s7_integer_clamped_if_gmp(sc, n);
+ if (num < 0)
+ out_of_range_error_nr(sc, sc->is_aritable_symbol, int_two, n, it_is_negative_string);
+ if (num > MAX_ARITY) num = MAX_ARITY;
+ return(make_boolean(sc, s7_is_aritable(sc, car(args), num)));
+}
+
+static bool is_aritable_b_7pp(s7_scheme *sc, s7_pointer f, s7_pointer i) {return(g_is_aritable(sc, set_plist_2(sc, f, i)) != sc->F);}
+
+static int32_t arity_to_int(s7_scheme *sc, s7_pointer x)
+{
+ int32_t args;
+ switch (type(x))
+ {
+ case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION_STAR:
+ return(c_function_max_args(x));
+
+ case T_MACRO: case T_BACRO: case T_CLOSURE:
+ args = closure_arity_to_int(sc, x);
+ return((args < 0) ? MAX_ARITY : args);
+
+ case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR:
+ args = closure_star_arity_to_int(sc, x);
+ return((args < 0) ? MAX_ARITY : args);
+
+ case T_C_MACRO: return(c_macro_max_args(x));
+ /* case T_C_OBJECT: return(MAX_ARITY); */ /* this currently can't be called */
+ /* vectors et al don't make sense here -- this is called only in g_set_setter below where it is restricted to is_any_procedure (type>=T_CLOSURE) */
+ }
+ if (S7_DEBUGGING) fprintf(stderr, "%s -1\n", __func__);
+ return(-1); /* unreachable I think */
+}
+
+
+/* -------------------------------- sequence? -------------------------------- */
+static s7_pointer g_is_sequence(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_sequence "(sequence? obj) returns #t if obj is a sequence (vector, string, pair, etc)"
+ #define Q_is_sequence sc->pl_bt
+ check_boolean_method(sc, is_simple_sequence, sc->is_sequence_symbol, args);
+}
+
+static bool is_sequence_b(s7_pointer p) {return(is_simple_sequence(p));}
+
+
+/* -------------------------------- setter ------------------------------------------------ */
+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]));
+ return(cadr(args));
+}
+
+static s7_pointer b_is_symbol_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_SYMBOL, args));}
+static s7_pointer b_is_syntax_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_SYNTAX, args));}
+static s7_pointer b_is_let_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_LET, args));}
+static s7_pointer b_is_iterator_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_ITERATOR, args));}
+static s7_pointer b_is_c_pointer_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_C_POINTER, args));}
+static s7_pointer b_is_input_port_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_INPUT_PORT, args));}
+static s7_pointer b_is_output_port_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_OUTPUT_PORT, args));}
+static s7_pointer b_is_eof_object_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_EOF, args));}
+static s7_pointer b_is_random_state_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_RANDOM_STATE, args));}
+static s7_pointer b_is_char_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_CHARACTER, args));}
+static s7_pointer b_is_string_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_STRING, args));}
+static s7_pointer b_is_float_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_FLOAT_VECTOR, args));}
+static s7_pointer b_is_int_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_INT_VECTOR, args));}
+static s7_pointer b_is_byte_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_BYTE_VECTOR, args));}
+static s7_pointer b_is_hash_table_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_HASH_TABLE, args));}
+static s7_pointer b_is_continuation_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_CONTINUATION, args));}
+static s7_pointer b_is_null_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_NIL, args));}
+static s7_pointer b_is_pair_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_PAIR, args));}
+static s7_pointer b_is_boolean_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_BOOLEAN, args));}
+static s7_pointer b_is_undefined_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_UNDEFINED, args));}
+static s7_pointer b_is_unspecified_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_UNSPECIFIED, args));}
+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)); \
+ } 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);}
+static s7_pointer b_is_complex_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_complex, args, "a number", 8);}
+static s7_pointer b_is_gensym_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_gensym, args, "a gensym", 8);}
+static s7_pointer b_is_keyword_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_symbol_and_keyword, args, "a keyword", 9);}
+static s7_pointer b_is_openlet_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, has_methods, args, "an open let", 11);}
+static s7_pointer b_is_macro_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_macro, args, "a macro", 7);}
+static s7_pointer b_is_integer_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_integer, args, "an integer", 10);}
+static s7_pointer b_is_byte_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_byte, args, "an unsigned byte", 16);}
+static s7_pointer b_is_real_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_real, args, "a real", 6);}
+static s7_pointer b_is_float_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_t_real, args, "a float", 7);}
+static s7_pointer b_is_rational_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_rational, args, "a rational", 10);}
+static s7_pointer b_is_list_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_list, args, "a list", 6);}
+static s7_pointer b_is_vector_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_vector, args, "a vector", 8);}
+static s7_pointer b_is_procedure_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_procedure, args, "a procedure", 11);}
+static s7_pointer b_is_dilambda_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_dilambda, args, "a dilambda", 10);}
+static s7_pointer b_is_sequence_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_sequence, args, "a sequence", 10);}
+static s7_pointer b_is_subvector_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_subvector, args, "a subvector", 11);}
+static s7_pointer b_is_weak_hash_table_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_weak_hash_table, args, "a weak hash-table", 17);}
+
+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)));
+ return(cadr(args));
+}
+
+static s7_pointer lambda_setter(s7_scheme *sc, s7_pointer p)
+{
+ if (is_any_procedure(closure_setter(p))) /* setter already known */
+ return(closure_setter(p));
+ if (!closure_no_setter(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);
+ }
+ /* 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);
+ }
+ return(sc->F);
+}
+
+static s7_pointer symbol_setter(s7_scheme *sc, s7_pointer sym, s7_pointer e)
+{
+ s7_pointer slot, setter;
+ if (is_keyword(sym))
+ return(sc->F);
+ if (e == sc->rootlet)
+ slot = global_slot(sym);
+ else
+ {
+ s7_pointer old_e = sc->curlet;
+ set_curlet(sc, e);
+ slot = s7_slot(sc, sym);
+ set_curlet(sc, old_e);
+ }
+ if ((!is_slot(slot)) || (!slot_has_setter(slot))) return(sc->F);
+ setter = slot_setter(slot);
+ if ((is_any_procedure(setter)) && (is_bool_function(setter))) return(c_function_setter(setter));
+ return(setter);
+}
+
+static s7_pointer setter_p_pp(s7_scheme *sc, s7_pointer p, s7_pointer e)
+{
+ if (!is_let(e))
+ wrong_type_error_nr(sc, sc->setter_symbol, 2, e, sc->type_names[T_LET]); /* need to check this in case let arg is bogus */
+
+ switch (type(p))
+ {
+ case T_MACRO: case T_MACRO_STAR:
+ case T_BACRO: case T_BACRO_STAR:
+ case T_CLOSURE: case T_CLOSURE_STAR:
+ return(lambda_setter(sc, p));
+
+ case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_RST_NO_REQ_FUNCTION:
+ return(c_function_setter(p));
+
+ case T_C_MACRO:
+ return(c_macro_setter(p));
+
+ case T_C_OBJECT:
+ check_method(sc, p, sc->setter_symbol, set_plist_2(sc, p, e));
+ return((c_object_set(sc, p) == fallback_set) ? sc->F : sc->c_object_set_function); /* for example ((setter obj) obj 0 1.0) if s7test block */
+ /* this could wrap the setter as an s7_function giving p's class-name etc */
+
+ case T_LET:
+ check_method(sc, p, sc->setter_symbol, set_plist_2(sc, p, e));
+ return(global_value(sc->let_set_symbol));
+
+ case T_ITERATOR: /* (set! (iter) val) doesn't fit the other setters */
+ return((is_any_closure(iterator_sequence(p))) ? closure_setter(iterator_sequence(p)) : sc->F);
+
+ case T_PAIR: return(global_value(sc->list_set_symbol)); /* or maybe initial-value? */
+ case T_HASH_TABLE: return(global_value(sc->hash_table_set_symbol));
+ case T_STRING: return(global_value(sc->string_set_symbol));
+ case T_BYTE_VECTOR: return(global_value(sc->byte_vector_set_symbol));
+ case T_VECTOR: return(global_value(sc->vector_set_symbol));
+ case T_INT_VECTOR: return(global_value(sc->int_vector_set_symbol));
+ case T_FLOAT_VECTOR: return(global_value(sc->float_vector_set_symbol));
+ case T_SLOT: return((slot_has_setter(p)) ? slot_setter(p) : sc->F);
+
+ case T_SYMBOL: /* (setter symbol let) */
+ return(symbol_setter(sc, p, e));
+ }
+ /* wrong_type_error_nr(sc, sc->setter_symbol, 1, p, wrap_string(sc, "something that might have a setter", 34)); */ /* this seems unfriendly */
+ return(sc->F);
+}
+
+static s7_pointer g_setter(s7_scheme *sc, s7_pointer args)
+{
+ #define H_setter "(setter obj let) returns the setter associated with obj"
+ #define Q_setter s7_make_signature(sc, 3, s7_make_signature(sc, 2, \
+ sc->not_symbol, sc->is_procedure_symbol), sc->T, s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_null_symbol))
+ return(setter_p_pp(sc, car(args), (is_pair(cdr(args))) ? cadr(args) : sc->curlet));
+}
+
+s7_pointer s7_setter(s7_scheme *sc, s7_pointer obj) {return(setter_p_pp(sc, obj, sc->curlet));}
+
+
+/* -------------------------------- set-setter -------------------------------- */
+static void protect_setter(s7_scheme *sc, s7_pointer sym, s7_pointer fnc)
+{
+ s7_int loc;
+ if (sc->protected_setters_size == sc->protected_setters_loc)
+ {
+ s7_int size = sc->protected_setters_size;
+ s7_int new_size = 2 * size;
+ block_t *ob = vector_block(sc->protected_setters);
+ block_t *nb = reallocate(sc, ob, new_size * sizeof(s7_pointer));
+ block_info(nb) = NULL;
+ vector_block(sc->protected_setters) = nb;
+ vector_elements(sc->protected_setters) = (s7_pointer *)block_data(nb);
+ vector_length(sc->protected_setters) = new_size;
+
+ ob = vector_block(sc->protected_setter_symbols);
+ nb = reallocate(sc, ob, new_size * sizeof(s7_pointer));
+ vector_block(sc->protected_setter_symbols) = nb;
+ vector_elements(sc->protected_setter_symbols) = (s7_pointer *)block_data(nb);
+ 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;
+ }
+ sc->protected_setters_size = new_size;
+ }
+ loc = sc->protected_setters_loc++;
+ vector_element(sc->protected_setters, loc) = fnc; /* has_closure => T_Clo(fnc) checked earlier */
+ vector_element(sc->protected_setter_symbols, loc) = sym;
+}
+
+static s7_pointer symbol_set_setter(s7_scheme *sc, s7_pointer sym, s7_pointer args)
+{
+ s7_pointer func, slot;
+ if (is_keyword(sym))
+ wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, sym, wrap_string(sc, "a normal symbol (a keyword can't be set)", 40));
+
+ if (is_pair(cddr(args)))
+ {
+ 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);
+ 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);
+ }}
+ else
+ {
+ slot = s7_slot(sc, sym); /* (set! (setter 'x) (lambda (s v) ...)) */
+ func = cadr(args);
+ }
+ if (!is_slot(slot))
+ return(sc->F);
+
+ 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));
+ 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));
+ 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));
+ 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));
+ 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 (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 */
+ if (func != sc->F)
+ slot_set_has_setter(slot);
+ return(func);
+}
+
+static s7_pointer g_set_setter(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p = car(args), setter;
+ if (is_symbol(p)) /* has to precede cadr(args) checks, (set! (setter 'x let) ...) where setter is caddr(args) */
+ return(symbol_set_setter(sc, p, args));
+ if (p == sc->s7_starlet)
+ wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, p, wrap_string(sc, "something other than *s7*", 25));
+
+ setter = cadr(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));
+ 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));
+ 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));
+ }
+ switch (type(p))
+ {
+ case T_MACRO: case T_MACRO_STAR:
+ case T_BACRO: case T_BACRO_STAR:
+ case T_CLOSURE: case T_CLOSURE_STAR:
+ closure_set_setter(p, setter);
+ if (setter == sc->F)
+ 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));
+ 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));
+ c_function_set_setter(p, setter);
+ if ((is_any_closure(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);
+ break;
+
+ default: /* (set! (setter 4) ...) or p==continuation etc */
+ wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, p, wrap_string(sc, "a symbol, a procedure, or a macro", 33));
+ }
+ return(setter);
+}
+
+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);
+ }
+ 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_setter(global_slot(p), sc->F);
+ return(sc->F);
+ }
+ return(g_set_setter(sc, set_plist_2(sc, p, setter))); /* if T_Clo(setter), doesn't it need GC protection as above? */
+}
+
+/* (let () (define xxx 23) (define (hix) (set! xxx 24)) (hix) (set! (setter 'xxx) (lambda (sym val) (format *stderr* "val: ~A~%" val) val)) (hix))
+ * so set setter before use!
+ */
+
+static s7_pointer call_c_function_setter(s7_scheme *sc, s7_pointer func, s7_pointer symbol, s7_pointer new_value)
+{
+ if (has_let_arg(func)) /* setter has optional third arg, the let */
+ return(c_function_call(func)(sc, with_list_t3(symbol, new_value, sc->curlet)));
+ return(c_function_call(func)(sc, with_list_t2(symbol, new_value)));
+}
+
+static s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer new_value) /* see also op_set1 */
+{
+ s7_pointer func = slot_setter(slot), result;
+ if (is_c_function(func))
+ return(call_c_function_setter(sc, func, slot_symbol(slot), new_value));
+ if (!is_any_procedure(func))
+ return(new_value);
+ sc->temp10 = (has_let_arg(func)) ? list_3(sc, slot_symbol(slot), new_value, sc->curlet) : list_2(sc, slot_symbol(slot), new_value);
+ /* safe lists here are much slower -- the setters are called more often for some reason (see tset.scm) */
+ result = s7_call(sc, func, sc->temp10);
+ sc->temp10 = sc->unused;
+ return(result);
+}
+
+static s7_pointer bind_symbol_with_setter(s7_scheme *sc, opcode_t op, s7_pointer symbol, s7_pointer new_value)
+{
+ s7_pointer func = setter_p_pp(sc, symbol, sc->curlet);
+ if (is_c_function(func))
+ return(call_c_function_setter(sc, func, symbol, new_value));
+ if (!is_any_procedure(func))
+ return(new_value);
+ sc->args = (has_let_arg(func)) ? list_3(sc, symbol, new_value, sc->curlet) : list_2(sc, symbol, new_value);
+ push_stack_direct(sc, op);
+ sc->code = func;
+ return(sc->no_value); /* this means the setter in set! needs to goto APPLY to get the new value */
+}
+
+
+/* -------------------------------- hooks -------------------------------- */
+s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook)
+{
+ return(s7_symbol_local_value(sc, sc->body_symbol, closure_let(hook)));
+}
+
+s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions)
+{
+ if (is_list(functions))
+ let_set_2(sc, closure_let(hook), sc->body_symbol, functions);
+ return(functions);
+}
+
+
+/* -------------------------------- eq? eqv? equal? equivalent? -------------------------------- */
+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 */
+}
+
+static s7_pointer is_eq_p_pp(s7_scheme *sc, s7_pointer obj1, s7_pointer obj2)
+{
+ return(make_boolean(sc, ((obj1 == obj2) || ((is_unspecified(obj1)) && (is_unspecified(obj2))))));
+}
+
+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)))))));
+ /* (eq? (apply apply apply values '(())) #<unspecified>) should return #t */
+}
+
+bool s7_is_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b)
+{
+#if WITH_GMP
+ if ((is_big_number(a)) || (is_big_number(b))) return(big_numbers_are_eqv(sc, a, b));
+#endif
+ if (type(a) != type(b)) return(false);
+ if ((a == b) && (!is_number(a))) /* if a is NaN, a == b doesn't mean (eqv? a b) */
+ return(true); /* a == b means (let ((x "a")) (let ((y x)) (eqv? x y))) is #t */
+ if (is_number(a)) return(numbers_are_eqv(sc, a, b));
+ if (is_unspecified(a)) return(true); /* types are the same so we know b is also unspecified */
+ return(false);
+}
+
+static s7_pointer g_is_eqv(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_eqv "(eqv? obj1 obj2) returns #t if obj1 is equivalent to obj2"
+ #define Q_is_eqv sc->pcl_bt
+ return(make_boolean(sc, s7_is_eqv(sc, car(args), cadr(args))));
+}
+
+static s7_pointer is_eqv_p_pp(s7_scheme *sc, s7_pointer obj1, s7_pointer obj2) {return(make_boolean(sc, s7_is_eqv(sc, obj1, obj2)));}
+
+static bool floats_are_equivalent(s7_scheme *sc, s7_double x, s7_double y)
+{
+ s7_double diff;
+ if (x == y) return(true);
+ diff = fabs(x - y);
+ if (diff <= sc->equivalent_float_epsilon) return(true);
+ return((is_NaN(x)) && (is_NaN(y)));
+}
+
+#if WITH_GMP
+static bool big_floats_are_equivalent(s7_scheme *sc, mpfr_t x, mpfr_t y)
+{
+ /* protect mpfr_1 */
+ if ((mpfr_nan_p(x)) || (mpfr_nan_p(y)))
+ return((mpfr_nan_p(x)) && (mpfr_nan_p(y)));
+ mpfr_sub(sc->mpfr_3, x, y, MPFR_RNDN);
+ mpfr_abs(sc->mpfr_3, sc->mpfr_3, MPFR_RNDN);
+ return(mpfr_cmp_d(sc->mpfr_3, sc->equivalent_float_epsilon) <= 0);
+}
+#endif
+
+static bool eq_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *unused_ci) {return(x == y);}
+
+static bool symbol_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) /* symbol equal uses eq -- should it check keywords as below? */
+{
+ if (x == y) return(true);
+ if (!is_symbol(y)) return(false);
+ if (is_keyword(y))
+ 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))));
+}
+
+static bool unspecified_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ return(is_unspecified(y));
+}
+
+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)))));
+}
+
+static bool is_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ return((*(equals[type(x)]))(sc, x, y, ci));
+}
+
+static bool is_equivalent_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ return((*(equivalents[type(x)]))(sc, x, y, ci));
+}
+
+static bool c_pointer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ shared_info_t *nci = ci;
+ if (x == y) return(true);
+ if (!s7_is_c_pointer(y)) return(false);
+ if (c_pointer(x) != c_pointer(y)) return(false);
+ if (c_pointer_type(x) != c_pointer_type(y))
+ {
+ 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);
+ }
+ 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(true);
+}
+
+static bool c_pointer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ shared_info_t *nci = ci;
+ if (x == y) return(true);
+ if (!s7_is_c_pointer(y)) return(false);
+ if (c_pointer(x) != c_pointer(y)) return(false);
+ if (c_pointer_type(x) != c_pointer_type(y))
+ {
+ 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);
+ }
+ 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(true);
+}
+
+static bool string_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ return((is_string(y)) && (scheme_strings_are_equal(x, y)));
+}
+
+static bool syntax_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ return((is_syntax(y)) && (syntax_symbol(x) == syntax_symbol(y)));
+}
+
+static bool port_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(x == y);}
+
+static bool port_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ if (x == y) return(true);
+ if (type(x) != type(y)) return(false);
+ if ((port_is_closed(x)) && (port_is_closed(y))) return(true);
+ if ((port_is_closed(x)) || (port_is_closed(y))) return(false); /* if either is closed, port_port (below) might be null */
+ if (port_type(x) != port_type(y)) return(false);
+ switch (port_type(x))
+ {
+ 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))));
+ 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))));
+ case FUNCTION_PORT:
+ if (is_input_port(x))
+ return(port_input_function(x) == port_input_function(y));
+ return(port_output_function(x) == port_output_function(y));
+ }
+ return(false);
+}
+
+static void add_shared_ref(shared_info_t *ci, s7_pointer x, int32_t ref_x)
+{
+ /* called only in equality check, not printer */
+ if (ci->top == ci->size)
+ enlarge_shared_info(ci);
+ set_collected(x);
+ ci->objs[ci->top] = x;
+ ci->refs[ci->top++] = ref_x;
+}
+
+static Inline bool inline_equal_ref(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) /* pair_equal:lg/list/io, [read] */
+{
+ /* here we know x and y are pointers to the same type of structure */
+ int32_t ref_y = (is_collected(y)) ? peek_shared_ref_1(ci, y) : 0;
+ if (is_collected(x))
+ {
+ 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 */
+ /* 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);
+ }
+ 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;
+ }
+ return(false);
+}
+
+static bool equal_ref(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(inline_equal_ref(sc, x, y, ci));}
+
+static bool c_objects_are_equal(s7_scheme *sc, s7_pointer a, s7_pointer b, shared_info_t *ci)
+{
+ s7_pointer (*to_list)(s7_scheme *sc, s7_pointer args);
+ shared_info_t *nci = ci;
+ s7_pointer pa, pb;
+
+ if (a == b)
+ return(true);
+ if (!is_c_object(b))
+ return(false);
+ if (c_object_type(a) != c_object_type(b))
+ return(false);
+
+ if (c_object_equal(sc, a))
+ return(((*(c_object_equal(sc, a)))(sc, set_clist_2(sc, a, b))) != sc->F);
+ if (c_object_eql(sc, a))
+ return((*(c_object_eql(sc, a)))(c_object_value(a), c_object_value(b)));
+
+ to_list = c_object_to_list(sc, a);
+ if (!to_list)
+ return(false);
+ if (ci)
+ {
+ if (equal_ref(sc, a, b, ci)) return(true); /* and nci == ci above */
+ }
+ else nci = clear_shared_info(sc->circle_info);
+
+ for (pa = to_list(sc, set_plist_1(sc, a)), pb = to_list(sc, set_plist_1(sc, b)); is_pair(pa) && (is_pair(pb)); pa = cdr(pa), pb = cdr(pb))
+ if (!(is_equal_1(sc, car(pa), car(pb), nci)))
+ return(false);
+ return(pa == pb); /* presumably both are nil if successful */
+}
+
+#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)))); \
+ }} \
+ while (0)
+
+static bool c_objects_are_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ check_equivalent_method(sc, x, y);
+ if (c_object_equivalent(sc, x))
+ return(((*(c_object_equivalent(sc, x)))(sc, set_plist_2(sc, x, y))) != sc->F);
+ return(c_objects_are_equal(sc, x, y, ci));
+}
+
+static bool hash_table_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool equivalent)
+{
+ hash_entry_t **lists;
+ s7_int len;
+ shared_info_t *nci = ci;
+ hash_check_t hf;
+ bool (*eqf)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci);
+
+ if (x == y)
+ return(true);
+ if (!is_hash_table(y))
+ {
+ if (equivalent)
+ check_equivalent_method(sc, y, x);
+ return(false);
+ }
+ if ((ci) && (equal_ref(sc, x, y, ci))) return(true);
+
+ if (hash_table_entries(x) != hash_table_entries(y))
+ return(false);
+ if (hash_table_entries(x) == 0)
+ return(true);
+ 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);
+ if (hash_table_mapper(x) != hash_table_mapper(y))
+ return(false);
+ }
+
+ len = hash_table_size(x);
+ lists = hash_table_elements(x);
+ if (!nci) nci = clear_shared_info(sc->circle_info);
+ eqf = (equivalent) ? is_equivalent_1 : is_equal_1;
+
+ hf = hash_table_checker(y);
+ 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);
+ }
+ /* 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?
+ */
+ return(true);
+ }
+
+ /* we need to protect the current shared_info data (nci) here so the current hash_table_checker won't work --
+ * outside equal?/eqivalent? they can safely assume that they can start a new shared_info process.
+ */
+ 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);
+ }
+ return(true);
+}
+
+static bool hash_table_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(hash_table_equal_1(sc, x, y, ci, false));}
+static bool hash_table_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(hash_table_equal_1(sc, x, y, ci, true));}
+
+static bool slots_match(s7_scheme *sc, s7_pointer px, s7_pointer y, shared_info_t *nci)
+{
+ 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(false);
+}
+
+static bool slots_equivalent_match(s7_scheme *sc, s7_pointer px, s7_pointer y, shared_info_t *nci)
+{
+ 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(false);
+}
+
+static bool let_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool equivalent)
+{
+ s7_pointer ex, ey, px, py;
+ shared_info_t *nci = ci;
+ int32_t x_len, y_len;
+
+ if ((!is_let(y)) || (x == sc->rootlet) || (y == sc->rootlet)) /* (equal? (rootlet) (rootlet)) is checked in let_equal below */
+ return(false);
+
+ if ((ci) && (equal_ref(sc, x, y, ci))) return(true);
+
+ clear_symbol_list(sc);
+ 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++;
+ }
+
+ 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);
+
+ 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);
+ }
+
+ if (x_len != y_len) /* symbol in x, not in y */
+ return(false);
+
+ if (!nci) nci = clear_shared_info(sc->circle_info);
+
+ 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);
+ }
+ return(true);
+}
+
+static bool let_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ /* x == y if all unshadowed vars match, leaving aside the rootlet, so that for any local variable, we get the same value in either x or y */
+ return((x == y) || (let_equal_1(sc, x, y, ci, false)));
+}
+
+/* what should these do if there are setters? */
+static bool let_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ if (x == y) return(true);
+ if (!is_global(sc->is_equivalent_symbol))
+ {
+ check_equivalent_method(sc, x, y);
+ check_equivalent_method(sc, y, x);
+ }
+ return(let_equal_1(sc, x, y, ci, true));
+}
+
+static bool closure_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ if (x == y)
+ return(true);
+ if (type(x) != type(y))
+ return(false);
+ if ((has_active_methods(sc, x)) &&
+ (has_active_methods(sc, y)))
+ {
+ 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(false);
+}
+
+static bool closure_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ if (x == y)
+ return(true);
+ if (type(x) != type(y))
+ return(false);
+ if (has_active_methods(sc, y))
+ check_equivalent_method(sc, x, y);
+ /* not sure about this -- we can't simply check let_equal(closure_let(x), closure_let(y))
+ * 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)));
+}
+
+static bool pair_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ s7_pointer px, py;
+ if (x == y)
+ return(true);
+ if (!is_pair(y))
+ return(false);
+ if (!ci)
+ ci = clear_shared_info(sc->circle_info);
+ else
+ if (inline_equal_ref(sc, x, y, ci))
+ return(true);
+
+ if (!is_equal_1(sc, car(x), car(y), ci)) return(false);
+ for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); px = cdr(px), py = cdr(py))
+ {
+ if (!is_equal_1(sc, car(px), car(py), ci)) return(false);
+ if (inline_equal_ref(sc, px, py, ci)) return(true);
+ }
+ return((px == py) || (is_equal_1(sc, px, py, ci)));
+}
+
+static bool pair_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ s7_pointer px, py;
+ if (x == y)
+ return(true);
+ if (!is_pair(y))
+ {
+ check_equivalent_method(sc, y, x);
+ return(false);
+ }
+ if (!ci)
+ ci = clear_shared_info(sc->circle_info);
+ else
+ if (inline_equal_ref(sc, x, y, ci))
+ return(true);
+
+ if (!is_equivalent_1(sc, car(x), car(y), ci)) return(false);
+ for (px = cdr(x), py = cdr(y); (is_pair(px)) && (is_pair(py)); px = cdr(px), py = cdr(py))
+ {
+ if (!is_equivalent_1(sc, car(px), car(py), ci)) return(false);
+ if (inline_equal_ref(sc, px, py, ci)) return(true);
+ }
+ return((px == py) || ((is_equivalent_1(sc, px, py, ci))));
+}
+
+static bool vector_rank_match(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ s7_int x_dims;
+
+ if (!vector_has_dimension_info(x))
+ return((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1));
+ x_dims = vector_ndims(x);
+ if (x_dims == 1)
+ return((!vector_has_dimension_info(y)) || (vector_ndims(y) == 1));
+ if ((!vector_has_dimension_info(y)) ||
+ (x_dims != vector_ndims(y)))
+ return(false);
+
+ for (s7_int j = 0; j < x_dims; j++)
+ if (vector_dimension(x, j) != vector_dimension(y, j))
+ return(false);
+ return(true);
+}
+
+static bool iv_meq(const s7_int *ex, const s7_int *ey, s7_int len)
+{
+ s7_int i = 0, left = len - 8;
+ while (i <= left)
+ LOOP_8(if (ex[i] != ey[i]) return(false); i++);
+ for (; i < len; i++)
+ if (ex[i] != ey[i])
+ return(false);
+ return(true);
+}
+
+static bool byte_vector_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y)
+{
+ s7_int len = vector_length(x);
+ const uint8_t *xp = byte_vector_bytes(x);
+ const uint8_t *yp = byte_vector_bytes(y);
+ for (s7_int i = 0; i < len; i++)
+ if (xp[i] != yp[i])
+ return(false);
+ return(true);
+}
+
+static bool biv_meq(s7_pointer x, s7_pointer y)
+{
+ s7_int len = vector_length(x);
+ const uint8_t *xp = byte_vector_bytes(x);
+ const s7_int *yp = int_vector_ints(y);
+ for (s7_int i = 0; i < len; i++)
+ if ((s7_int)(xp[i]) != yp[i])
+ return(false);
+ 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)
+{
+ s7_int len;
+ shared_info_t *nci = ci;
+
+ if (!is_any_vector(y)) return(false);
+ base_vector_equal(sc, x, y); /* sets len */
+ if (type(x) != type(y))
+ {
+ if ((is_int_vector(x)) && (is_byte_vector(y)))
+ return(biv_meq(y, x));
+ if ((is_byte_vector(x)) && (is_int_vector(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);
+ return(true);
+ }
+ if (!has_simple_elements(x))
+ {
+ if (ci)
+ {
+ 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++)
+ if (!(is_equal_1(sc, vector_element(x, i), vector_element(y, i), nci)))
+ return(false);
+ return(true);
+}
+
+static bool byte_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ s7_int len;
+ if (!is_byte_vector(y))
+ return(vector_equal(sc, x, y, ci));
+ base_vector_equal(sc, x, y);
+ return(byte_vector_equal_1(sc, x, y));
+}
+
+static bool int_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ s7_int len;
+ if (!is_int_vector(y))
+ return(vector_equal(sc, x, y, ci));
+ base_vector_equal(sc, x, y);
+ return(iv_meq(int_vector_ints(x), int_vector_ints(y), len));
+}
+
+static bool float_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ s7_int len;
+ if (!is_float_vector(y))
+ return(vector_equal(sc, x, y, ci));
+ base_vector_equal(sc, x, y);
+ for (s7_int i = 0; i < len; i++)
+ if (float_vector(x, i) != float_vector(y, i))
+ return(false);
+ return(true);
+}
+
+static bool vector_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ /* if this is split like vector_equal above, remember it is called by iterator_equal_1 below */
+ s7_int i, len;
+ shared_info_t *nci = ci;
+
+ if (x == y)
+ return(true);
+ if (!is_any_vector(y))
+ {
+ check_equivalent_method(sc, y, x);
+ return(false);
+ }
+ len = vector_length(x);
+ if (len != vector_length(y)) return(false);
+ if (len == 0) return(true);
+ if (!vector_rank_match(sc, x, y)) return(false);
+
+ if (type(x) != type(y))
+ {
+ /* (equivalent? (make-int-vector 3 0) (make-vector 3 0)) -> #t
+ * (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));
+ if ((is_byte_vector(x)) && (is_int_vector(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);
+ return(true);
+ }
+
+ if (is_float_vector(x))
+ {
+ 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);
+ }
+ 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);
+ return(true);
+ }
+ if (is_int_vector(x))
+ return(iv_meq(int_vector_ints(x), int_vector_ints(y), len));
+ if (is_byte_vector(x))
+ return(byte_vector_equal_1(sc, x, y));
+
+ if (!has_simple_elements(x))
+ {
+ if (ci)
+ {
+ if (equal_ref(sc, x, y, ci)) return(true);
+ }
+ else nci = clear_shared_info(sc->circle_info);
+ }
+ for (i = 0; i < len; i++)
+ if (!(is_equivalent_1(sc, vector_element(x, i), vector_element(y, i), nci)))
+ return(false);
+ return(true);
+}
+
+static bool iterator_equal_1(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool equivalent)
+{
+ s7_pointer x_seq, y_seq, xs, ys;
+
+ if (x == y) return(true);
+ if (!is_iterator(y)) return(false);
+
+ x_seq = iterator_sequence(x);
+ y_seq = iterator_sequence(y);
+
+ switch (type(x_seq))
+ {
+ 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)));
+
+ 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_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);
+ }
+ else
+ 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));
+ return(is_null(xs) && is_null(ys));
+
+ case T_NIL: /* (make-iterator #()) works, so () should too */
+ return(is_null(y_seq)); /* perhaps for equivalent case, check position in y as well as pair(seq(y))? */
+
+ 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));
+ }
+ 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) */
+ if (equivalent)
+ {
+ if (!let_equivalent(sc, x_seq, y_seq, ci))
+ return(false);
+ }
+ else
+ 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));
+ return(is_slot_end(xs) && is_slot_end(ys));
+
+ case T_HASH_TABLE:
+ if (!is_hash_table(y_seq)) return(false);
+ if (hash_table_entries(x_seq) != hash_table_entries(y_seq)) return(false);
+ 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_equivalent(sc, x_seq, y_seq, ci));
+
+ case T_CLOSURE: case T_CLOSURE_STAR:
+ return(x_seq == y_seq); /* or closure_equal/equivalent? */
+
+ default: break;
+ }
+ return(false);
+}
+
+static bool iterator_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(iterator_equal_1(sc, x, y, ci, false));}
+static bool iterator_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return(iterator_equal_1(sc, x, y, ci, true));}
+
+#if WITH_GMP
+static bool big_integer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ /* (equal? 1 1.0) -> #f */
+ if (is_t_big_integer(y))
+ return(mpz_cmp(big_integer(x), big_integer(y)) == 0);
+ return((is_t_integer(y)) && (mpz_cmp_si(big_integer(x), integer(y)) == 0));
+}
+
+static bool big_ratio_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ if (is_t_big_ratio(y))
+ 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)))));
+ return(false);
+}
+
+static bool big_real_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ if (is_t_big_real(y))
+ return(mpfr_equal_p(big_real(x), big_real(y)));
+ if (is_t_real(y))
+ {
+ if (mpfr_nan_p(big_real(x))) return(false);
+ return((!is_NaN(real(y))) &&
+ (mpfr_cmp_d(big_real(x), real(y)) == 0));
+ }
+ return(false);
+}
+
+static bool big_complex_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ if ((mpfr_nan_p(mpc_realref(big_complex(x)))) || (mpfr_nan_p(mpc_imagref(big_complex(x)))))
+ 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));
+ 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));
+ return(false);
+}
+#endif
+
+static bool integer_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ if (is_t_integer(y))
+ return(integer(x) == integer(y));
+#if WITH_GMP
+ if (is_t_big_integer(y))
+ return(mpz_cmp_si(big_integer(y), integer(x)) == 0);
+#endif
+ return(false);
+}
+
+/* apparently ratio_equal is predefined in g++ -- name collision on mac */
+static bool fraction_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ if (is_t_ratio(y))
+ return((numerator(x) == numerator(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)))));
+#endif
+ return(false);
+}
+
+static bool real_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ if (is_t_real(y))
+ return(real(x) == real(y));
+#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));
+#endif
+ return(false);
+}
+
+static bool complex_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ if (is_t_complex(y))
+ return((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y)));
+#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);
+ 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));
+ }
+#endif
+ return(false);
+}
+
+#if WITH_GMP
+static bool big_integer_or_ratio_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci, bool int_case)
+{
+ if (int_case)
+ mpfr_set_z(sc->mpfr_1, big_integer(x), MPFR_RNDN);
+ else mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN);
+
+ switch (type(y))
+ {
+ case T_INTEGER:
+ if (int_case)
+ 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:
+ mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
+ case T_REAL:
+ mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
+ 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);
+ 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);
+ 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:
+ mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
+ case T_BIG_REAL:
+ 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);
+ }}
+ return(false);
+}
+
+static bool big_integer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ return(big_integer_or_ratio_equivalent(sc, x, y, ci, true));
+}
+
+static bool big_ratio_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ return(big_integer_or_ratio_equivalent(sc, x, y, ci, false));
+}
+
+
+static bool big_real_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ switch (type(y))
+ {
+ case T_INTEGER:
+ mpfr_set_si(sc->mpfr_2, integer(y), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
+ case T_RATIO:
+ mpfr_set_d(sc->mpfr_2, fraction(y), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
+ case T_REAL:
+ mpfr_set_d(sc->mpfr_2, real(y), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
+ 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);
+ 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:
+ mpfr_set_z(sc->mpfr_2, big_integer(y), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
+ case T_BIG_RATIO:
+ mpfr_set_q(sc->mpfr_2, big_ratio(y), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, big_real(x), sc->mpfr_2));
+ case T_BIG_REAL:
+ 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);
+ }}
+ return(false);
+}
+
+static bool big_complex_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ mpfr_set_d(sc->mpfr_1, sc->equivalent_float_epsilon, MPFR_RNDN);
+ switch (type(y))
+ {
+ 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)));
+ 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)));
+ 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)));
+ 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)));
+ 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)));
+ 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)));
+ 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)));
+ 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)))));
+ }
+ return(false);
+}
+
+static bool both_floats_are_equivalent(s7_scheme *sc, s7_pointer y)
+{
+ if (!big_floats_are_equivalent(sc, sc->mpfr_1, mpc_realref(big_complex(y))))
+ return(false);
+ 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);
+}
+#endif
+
+static bool integer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ switch (type(y))
+ {
+ case T_INTEGER:
+ return(integer(x) == integer(y));
+ case T_RATIO:
+ return(floats_are_equivalent(sc, (double)integer(x), fraction(y)));
+ case T_REAL:
+ 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))));
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ return(mpz_cmp_si(big_integer(y), integer(x)) == 0);
+ case T_BIG_RATIO:
+ mpfr_set_si(sc->mpfr_1, integer(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));
+ case T_BIG_REAL:
+ mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y)));
+ case T_BIG_COMPLEX:
+ mpfr_set_si(sc->mpfr_1, integer(x), MPFR_RNDN);
+ return(both_floats_are_equivalent(sc, y));
+#endif
+ }
+ return(false);
+}
+
+static bool fraction_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ switch (type(y))
+ {
+ case T_INTEGER:
+ return(floats_are_equivalent(sc, (double)fraction(x), integer(y)));
+ case T_RATIO:
+ return(floats_are_equivalent(sc, (double)fraction(x), fraction(y)));
+ case T_REAL:
+ 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))));
+#if WITH_GMP
+ case T_BIG_INTEGER:
+ mpfr_set_z(sc->mpfr_1, big_integer(y), MPFR_RNDN);
+ mpfr_set_d(sc->mpfr_2, fraction(x), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
+ case T_BIG_RATIO:
+ mpfr_set_d(sc->mpfr_1, fraction(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));
+ case T_BIG_REAL:
+ mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y)));
+ case T_BIG_COMPLEX:
+ mpfr_set_d(sc->mpfr_1, fraction(x), MPFR_RNDN);
+ return(both_floats_are_equivalent(sc, y));
+#endif
+ }
+ return(false);
+}
+
+static bool real_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ switch (type(y))
+ {
+ case T_INTEGER:
+ return(floats_are_equivalent(sc, real(x), integer(y)));
+ case T_RATIO:
+ return(floats_are_equivalent(sc, real(x), fraction(y)));
+ case T_REAL:
+ 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))));
+#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(x), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, sc->mpfr_1, sc->mpfr_2));
+ case T_BIG_RATIO:
+ mpfr_set_d(sc->mpfr_1, real(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));
+ case T_BIG_REAL:
+ mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
+ return(big_floats_are_equivalent(sc, sc->mpfr_1, big_real(y)));
+ case T_BIG_COMPLEX:
+ mpfr_set_d(sc->mpfr_1, real(x), MPFR_RNDN);
+ return(both_floats_are_equivalent(sc, y));
+#endif
+ }
+ return(false);
+}
+
+static bool complex_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+ switch (type(y))
+ {
+ case T_INTEGER:
+ return((floats_are_equivalent(sc, real_part(x), integer(y))) &&
+ (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)));
+ case T_REAL:
+ return((floats_are_equivalent(sc, real_part(x), real(y))) &&
+ (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))));
+#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)));
+ 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)));
+ 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)));
+ 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)))));
+#endif
+ }
+ return(false);
+}
+
+static bool random_state_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci)
+{
+#if WITH_GMP
+ return(x == y);
+#else
+ return((x == y) ||
+ ((is_random_state(y)) &&
+ (random_seed(x) == random_seed(y)) &&
+ (random_carry(x) == random_carry(y))));
+#endif
+}
+
+static void init_equals(void)
+{
+ for (int32_t i = 0; i < NUM_TYPES; i++) {equals[i] = eq_equal; equivalents[i] = eq_equal;}
+ equals[T_SYMBOL] = eq_equal;
+ equals[T_C_POINTER] = c_pointer_equal;
+ equals[T_UNSPECIFIED] = unspecified_equal;
+ equals[T_UNDEFINED] = undefined_equal;
+ equals[T_STRING] = string_equal;
+ equals[T_SYNTAX] = syntax_equal;
+ equals[T_C_OBJECT] = c_objects_are_equal;
+ equals[T_RANDOM_STATE] = random_state_equal;
+ equals[T_ITERATOR] = iterator_equal;
+ equals[T_INPUT_PORT] = port_equal;
+ equals[T_OUTPUT_PORT] = port_equal;
+ equals[T_MACRO] = closure_equal;
+ equals[T_MACRO_STAR] = closure_equal;
+ equals[T_BACRO] = closure_equal;
+ equals[T_BACRO_STAR] = closure_equal;
+ equals[T_CLOSURE] = closure_equal;
+ equals[T_CLOSURE_STAR] = closure_equal;
+ equals[T_HASH_TABLE] = hash_table_equal;
+ equals[T_LET] = let_equal;
+ equals[T_PAIR] = pair_equal;
+ equals[T_VECTOR] = vector_equal;
+ equals[T_INT_VECTOR] = int_vector_equal;
+ equals[T_BYTE_VECTOR] = byte_vector_equal;
+ equals[T_FLOAT_VECTOR] = float_vector_equal;
+ equals[T_INTEGER] = integer_equal;
+ equals[T_RATIO] = fraction_equal;
+ equals[T_REAL] = real_equal;
+ equals[T_COMPLEX] = complex_equal;
+#if WITH_GMP
+ equals[T_BIG_INTEGER] = big_integer_equal;
+ equals[T_BIG_RATIO] = big_ratio_equal;
+ equals[T_BIG_REAL] = big_real_equal;
+ equals[T_BIG_COMPLEX] = big_complex_equal;
+#endif
+ equivalents[T_SYMBOL] = symbol_equivalent;
+ equivalents[T_C_POINTER] = c_pointer_equivalent;
+ equivalents[T_UNSPECIFIED] = unspecified_equal;
+ equivalents[T_UNDEFINED] = undefined_equal;
+ equivalents[T_STRING] = string_equal;
+ equivalents[T_SYNTAX] = syntax_equal;
+ equivalents[T_C_OBJECT] = c_objects_are_equivalent;
+ equivalents[T_RANDOM_STATE] = random_state_equal;
+ equivalents[T_ITERATOR] = iterator_equivalent;
+ equivalents[T_INPUT_PORT] = port_equivalent;
+ equivalents[T_OUTPUT_PORT] = port_equivalent;
+ equivalents[T_MACRO] = closure_equivalent;
+ equivalents[T_MACRO_STAR] = closure_equivalent;
+ equivalents[T_BACRO] = closure_equivalent;
+ equivalents[T_BACRO_STAR] = closure_equivalent;
+ equivalents[T_CLOSURE] = closure_equivalent;
+ equivalents[T_CLOSURE_STAR] = closure_equivalent;
+ equivalents[T_HASH_TABLE] = hash_table_equivalent;
+ equivalents[T_LET] = let_equivalent;
+ equivalents[T_PAIR] = pair_equivalent;
+ equivalents[T_VECTOR] = vector_equivalent;
+ equivalents[T_INT_VECTOR] = vector_equivalent;
+ equivalents[T_FLOAT_VECTOR] = vector_equivalent;
+ equivalents[T_BYTE_VECTOR] = vector_equivalent;
+ equivalents[T_INTEGER] = integer_equivalent;
+ equivalents[T_RATIO] = fraction_equivalent;
+ equivalents[T_REAL] = real_equivalent;
+ equivalents[T_COMPLEX] = complex_equivalent;
+#if WITH_GMP
+ equivalents[T_BIG_INTEGER] = big_integer_equivalent;
+ equivalents[T_BIG_RATIO] = big_ratio_equivalent;
+ equivalents[T_BIG_REAL] = big_real_equivalent;
+ equivalents[T_BIG_COMPLEX] = big_complex_equivalent;
+#endif
+}
+
+bool s7_is_equal(s7_scheme *sc, s7_pointer x, s7_pointer y) {return((*(equals[type(x)]))(sc, x, y, NULL));}
+bool s7_is_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y) {return((*(equivalents[type(x)]))(sc, x, y, NULL));}
+
+static s7_pointer g_is_equal(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_equal "(equal? obj1 obj2) returns #t if obj1 is equal to obj2"
+ #define Q_is_equal sc->pcl_bt
+ return(make_boolean(sc, is_equal_1(sc, car(args), cadr(args), NULL)));
+}
+
+static s7_pointer g_is_equivalent(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_equivalent "(equivalent? obj1 obj2) returns #t if obj1 is close enough to obj2."
+ #define Q_is_equivalent sc->pcl_bt
+ return(make_boolean(sc, is_equivalent_1(sc, car(args), cadr(args), NULL)));
+}
+
+static s7_pointer is_equal_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((is_equal_1(sc, a, b, NULL)) ? sc->T : sc->F);}
+static s7_pointer is_equivalent_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) {return((is_equivalent_1(sc, a, b, NULL)) ? sc->T : sc->F);}
+
+
+/* ---------------------------------------- length, copy, fill ---------------------------------------- */
+static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst); /* why isn't this in s7.h? */
+
+static s7_pointer (*length_functions[256])(s7_scheme *sc, s7_pointer obj);
+static s7_pointer any_length(s7_scheme *sc, s7_pointer obj) {return(sc->F);}
+
+static s7_pointer pair_length(s7_scheme *sc, s7_pointer a)
+{
+ s7_int i = 0;
+ s7_pointer slow = a, fast = a; /* we know a is a pair, don't start with fast = cdr(a)! else if a len = 3, we never match */
+ while (true)
+ {
+ 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);
+ }
+ return(real_infinity);
+}
+
+static s7_pointer nil_length(s7_scheme *sc, s7_pointer lst) {return(int_zero);}
+static s7_pointer v_length(s7_scheme *sc, s7_pointer v) {return(make_integer(sc, vector_length(v)));}
+static s7_pointer str_length(s7_scheme *sc, s7_pointer v) {return(make_integer(sc, string_length(v)));}
+static s7_pointer bv_length(s7_scheme *sc, s7_pointer v) {return(make_integer(sc, byte_vector_length(v)));}
+static s7_pointer h_length(s7_scheme *sc, s7_pointer lst) {return(make_integer(sc, hash_table_size(lst)));}
+static s7_pointer iter_length(s7_scheme *sc, s7_pointer lst) {return(s7_length(sc, iterator_sequence(lst)));}
+
+static s7_pointer c_obj_length(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_global(sc->length_symbol))
+ check_method(sc, lst, sc->length_symbol, set_plist_1(sc, lst));
+ return(c_object_length(sc, lst));
+}
+
+static s7_pointer lt_length(s7_scheme *sc, s7_pointer lst)
+{
+ if (!is_global(sc->length_symbol))
+ check_method(sc, lst, sc->length_symbol, set_plist_1(sc, lst));
+ return(make_integer(sc, let_length(sc, lst)));
+}
+
+static s7_pointer fnc_length(s7_scheme *sc, s7_pointer lst)
+{
+ return((has_active_methods(sc, lst)) ? make_integer(sc, closure_length(sc, lst)) : sc->F);
+}
+
+static s7_pointer ip_length(s7_scheme *sc, s7_pointer port)
+{
+ if (port_is_closed(port))
+ return(sc->F); /* or 0? */
+ if (is_string_port(port))
+ return(make_integer(sc, port_data_size(port))); /* length of string we're reading */
+#if (!MS_WINDOWS)
+ if (is_file_port(port))
+ {
+ long len;
+ long cur_pos = ftell(port_file(port));
+ fseek(port_file(port), 0, SEEK_END);
+ len = ftell(port_file(port));
+ rewind(port_file(port));
+ fseek(port_file(port), cur_pos, SEEK_SET);
+ return(make_integer(sc, len));
+ }
+#endif
+ return(sc->F);
+}
+
+static s7_pointer op_length(s7_scheme *sc, s7_pointer port)
+{
+ if (port_is_closed(port))
+ return(sc->F); /* or 0? */
+ return((is_string_port(port)) ? make_integer(sc, port_position(port)) : sc->F); /* length of string we've written */
+}
+
+static s7_pointer rs_length(s7_scheme *sc, s7_pointer port) {return((WITH_GMP) ? sc->F : int_two);}
+
+static void init_length_functions(void)
+{
+ for (int32_t i = 0; i < 256; i++) length_functions[i] = any_length;
+ length_functions[T_NIL] = nil_length;
+ length_functions[T_PAIR] = pair_length;
+ length_functions[T_VECTOR] = v_length;
+ length_functions[T_FLOAT_VECTOR] = v_length;
+ length_functions[T_INT_VECTOR] = v_length;
+ length_functions[T_STRING] = str_length;
+ length_functions[T_BYTE_VECTOR] = bv_length;
+ length_functions[T_ITERATOR] = iter_length;
+ length_functions[T_HASH_TABLE] = h_length;
+ length_functions[T_C_OBJECT] = c_obj_length;
+ length_functions[T_LET] = lt_length;
+ length_functions[T_CLOSURE] = fnc_length;
+ length_functions[T_CLOSURE_STAR] = fnc_length;
+ length_functions[T_INPUT_PORT] = ip_length;
+ length_functions[T_OUTPUT_PORT] = op_length;
+ length_functions[T_RANDOM_STATE] = rs_length;
+}
+
+static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst) {return((*length_functions[unchecked_type(lst)])(sc, lst));}
+
+static s7_pointer g_length(s7_scheme *sc, s7_pointer args)
+{
+ #define H_length "(length obj) returns the length of obj, which can be a list, vector, string, input-port, or hash-table. \
+The length of a dotted list does not include the final cdr, and is returned as a negative number. A circular \
+list has infinite length. Length of anything else returns #f."
+ #define Q_length s7_make_signature(sc, 2, s7_make_signature(sc, 3, sc->is_integer_symbol, sc->is_infinite_symbol, sc->not_symbol), sc->T)
+ return((*length_functions[unchecked_type(car(args))])(sc, car(args)));
+}
+
+/* length_p_p = s7_length */
+
+
+/* -------------------------------- copy -------------------------------- */
+static s7_pointer string_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_pointer val)
+{
+ if (is_character(val))
+ {
+ string_value(str)[loc] = s7_character(val);
+ return(val);
+ }
+ set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not a character", 25));
+ set_caddr(sc->elist_3, val);
+ error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3);
+ return(NULL);
+}
+
+static s7_pointer string_getter(s7_scheme *sc, s7_pointer str, s7_int loc)
+{
+ return(chars[(uint8_t)(string_value(str)[loc])]); /* cast needed else (copy (string (integer->char 255))...) is trouble */
+}
+
+static s7_pointer c_object_setter(s7_scheme *sc, s7_pointer obj, s7_int loc, s7_pointer val)
+{
+ return((*(c_object_set(sc, obj)))(sc, with_list_t3(obj, wrap_integer(sc, loc), val))); /* was make_integer 14-Nov-23 */
+}
+
+static s7_pointer c_object_getter(s7_scheme *sc, s7_pointer obj, s7_int loc)
+{
+ return((*(c_object_ref(sc, obj)))(sc, set_plist_2(sc, obj, wrap_integer(sc, loc)))); /* was make_integer 14-Nov-23 */
+}
+
+static s7_pointer let_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_pointer val)
+{
+ /* loc is irrelevant here, val has to be of the form (cons symbol value)
+ * if symbol is already in e, its value is changed, otherwise a new slot is added to e
+ */
+ if (is_pair(val))
+ {
+ 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));
+ }}
+ 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);
+ return(sc->wrong_type_arg_symbol);
+}
+
+static s7_pointer hash_table_setter(s7_scheme *sc, s7_pointer e, s7_int loc, s7_pointer val)
+{
+ /* loc is irrelevant here, e is the hash-table, val has to be of the form (cons key value)
+ * if key is already in e, its value is changed, otherwise a new slot is added to e, cadr(elist_3) is caller
+ */
+ if (!is_pair(val))
+ {
+ set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not (cons key value)", 30));
+ set_caddr(sc->elist_3, val);
+ error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3);
+ }
+ return(s7_hash_table_set(sc, e, car(val), cdr(val)));
+}
+
+static s7_pointer copy_hash_table(s7_scheme *sc, s7_pointer source)
+{
+ s7_pointer new_hash = s7_make_hash_table(sc, hash_table_size(source));
+ gc_protect_via_stack(sc, new_hash);
+ hash_table_checker(new_hash) = hash_table_checker(source);
+ if (hash_chosen(source)) hash_set_chosen(new_hash);
+ hash_table_mapper(new_hash) = hash_table_mapper(source);
+ hash_table_set_procedures(new_hash, copy_hash_table_procedures(sc, source));
+ hash_table_copy(sc, source, new_hash, 0, hash_table_entries(source));
+ if (is_typed_hash_table(source))
+ {
+ set_is_typed_hash_table(new_hash);
+ if (has_hash_key_type(source)) set_has_hash_key_type(new_hash);
+ if (has_hash_value_type(source)) set_has_hash_value_type(new_hash);
+ if (has_simple_keys(source)) set_has_simple_keys(new_hash);
+ if (has_simple_values(source)) set_has_simple_values(new_hash);
+ }
+ if (is_weak_hash_table(source)) /* 16-May-23 */
+ {
+ set_weak_hash_table(new_hash);
+ weak_hash_iters(new_hash) = 0;
+ }
+ unstack_gc_protect(sc);
+ return(new_hash);
+}
+
+static s7_pointer copy_vector(s7_scheme *sc, s7_pointer source)
+{
+ s7_int len = vector_length(source);
+ s7_pointer vec;
+ if (!is_typed_vector(source))
+ return(s7_vector_copy(sc, source));
+ if (len == 0)
+ return(make_simple_vector(sc, 0));
+ vec = make_vector_1(sc, len, NOT_FILLED, T_VECTOR);
+ set_typed_vector(vec);
+ typed_vector_set_typer(vec, typed_vector_typer(source));
+ if (has_simple_elements(source)) set_has_simple_elements(vec);
+ for (s7_int i = 0; i < len; i++)
+ vector_element(vec, i) = vector_element(source, i);
+ if (vector_rank(source) > 1)
+ return(make_multivector(sc, vec, g_vector_dimensions(sc, set_plist_1(sc, source)))); /* see g_subvector to avoid g_vector_dimensions */
+ add_vector(sc, vec);
+ return(vec);
+}
+
+static s7_pointer copy_source_no_dest(s7_scheme *sc, s7_pointer source, s7_pointer args)
+{
+ s7_pointer dest;
+ switch (type(source))
+ {
+ case T_STRING:
+ return(make_string_with_length(sc, string_value(source), string_length(source)));
+
+ case T_C_OBJECT:
+ return(copy_c_object(sc, args));
+
+ case T_RANDOM_STATE:
+ return(random_state_copy(sc, args));
+
+ case T_HASH_TABLE: /* this has to copy nearly everything */
+ return(copy_hash_table(sc, source));
+
+ case T_ITERATOR:
+ return(iterator_copy(sc, source));
+
+ case T_LET:
+ check_method(sc, source, sc->copy_symbol, args);
+ return(let_copy(sc, source)); /* this copies only the local let and points to outer lets */
+
+ case T_CLOSURE: case T_CLOSURE_STAR:
+ case T_MACRO: case T_MACRO_STAR:
+ case T_BACRO: case T_BACRO_STAR:
+ check_method(sc, source, sc->copy_symbol, args);
+ return(copy_closure(sc, source));
+
+ case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR:
+ return(s7_vector_copy(sc, source)); /* "shallow" copy */
+
+ case T_VECTOR:
+ return(copy_vector(sc, source));
+
+ case T_PAIR: /* top level only, as in the other cases, checks for circles */
+ return(copy_any_list(sc, source));
+
+ case T_INTEGER:
+ new_cell(sc, dest, T_INTEGER);
+ set_integer(dest, integer(source));
+ return(dest);
+ case T_RATIO:
+ new_cell(sc, dest, T_RATIO);
+ set_numerator(dest, numerator(source));
+ set_denominator(dest, denominator(source));
+ return(dest);
+ case T_REAL:
+ new_cell(sc, dest, T_REAL);
+ set_real(dest, real(source));
+ return(dest);
+ case T_COMPLEX:
+ new_cell(sc, dest, T_COMPLEX);
+ set_real_part(dest, real_part(source));
+ set_imag_part(dest, imag_part(source));
+ return(dest);
+#if WITH_GMP
+ case T_BIG_INTEGER: return(mpz_to_big_integer(sc, big_integer(source)));
+ case T_BIG_RATIO: return(mpq_to_big_ratio(sc, big_ratio(source)));
+ case T_BIG_REAL: return(mpfr_to_big_real(sc, big_real(source)));
+ case T_BIG_COMPLEX: return(mpc_to_number(sc, big_complex(source)));
+#endif
+
+ case T_C_POINTER:
+ dest = s7_make_c_pointer_with_type(sc, c_pointer(source), c_pointer_type(source), c_pointer_info(source));
+ c_pointer_weak1(dest) = c_pointer_weak1(source);
+ c_pointer_weak2(dest) = c_pointer_weak2(source);
+ return(dest);
+ }
+ return(source);
+}
+
+static s7_pointer copy_p_p(s7_scheme *sc, s7_pointer source) {return(copy_source_no_dest(sc, source, set_plist_1(sc, source)));}
+
+static s7_pointer copy_c_object_to_same_type(s7_scheme *sc, s7_pointer dest, s7_pointer source, s7_int dest_start, s7_int dest_end, s7_int source_start)
+{
+ s7_pointer (*cref)(s7_scheme *sc, s7_pointer args) = c_object_ref(sc, source);
+ s7_pointer (*cset)(s7_scheme *sc, s7_pointer args) = c_object_set(sc, dest);
+ if ((is_safe_c_function(c_object_getf(sc, source))) &&
+ (is_safe_c_function(c_object_setf(sc, dest)))) /* maybe not worth the extra code */
+ {
+ s7_pointer mi = wrapped_integer(sc);
+ s7_pointer mj = wrapped_integer(sc);
+ 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);
+ }}
+ else
+ {
+ s7_pointer mi = make_mutable_integer(sc, 0);
+ s7_int gc_loc1 = gc_protect_1(sc, mi);
+ 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);
+ }
+ s7_gc_unprotect_at(sc, gc_loc1);
+ s7_gc_unprotect_at(sc, gc_loc2);
+ free_cell(sc, mi);
+ free_cell(sc, mj);
+ }
+ return(dest);
+}
+
+static s7_pointer copy_to_same_type(s7_scheme *sc, s7_pointer dest, s7_pointer source, s7_int dest_start, s7_int dest_end, s7_int source_start)
+{
+ /* types equal, but not a let (handled in s7_copy_1), returns NULL if not copied here */
+ s7_int source_len = dest_end - dest_start;
+ switch (type(source))
+ {
+ 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);
+ }
+
+ 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 */
+ }
+ else memcpy((void *)((vector_elements(dest)) + dest_start), (void *)((vector_elements(source)) + source_start), source_len * sizeof(s7_pointer));
+ return(dest);
+
+ case T_INT_VECTOR:
+ memcpy((void *)((int_vector_ints(dest)) + dest_start), (void *)((int_vector_ints(source)) + source_start), source_len * sizeof(s7_int));
+ return(dest);
+ case T_FLOAT_VECTOR:
+ memcpy((void *)((float_vector_floats(dest)) + dest_start), (void *)((float_vector_floats(source)) + source_start), source_len * sizeof(s7_double));
+ 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));
+ 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);
+ else memcpy((void *)(byte_vector_bytes(dest) + dest_start), (void *)((string_value(source)) + source_start), source_len);
+ return(dest);
+
+ case T_RANDOM_STATE:
+#if (!WITH_GMP)
+ random_seed(dest) = random_seed(source);
+ random_carry(dest) = random_carry(source);
+#endif
+ return(dest);
+
+ case T_C_OBJECT:
+ return(copy_c_object_to_same_type(sc, dest, source, dest_start, dest_end, source_start));
+
+ case T_LET:
+ return(NULL);
+
+ 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);
+ }
+
+ default:
+ return(dest);
+ }
+ return(NULL);
+}
+
+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]);
+ 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);
+ error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6);
+}
+
+static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args)
+{
+ #define H_copy "(copy obj) returns a copy of obj, (copy src dest) copies src into dest, (copy src dest start end) copies src from start to end."
+ /* #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->is_sequence_symbol, sc->is_integer_symbol) */
+ /* this is not right when c-object types are handled in lint -- a generator or Snd object need not consider itself a sequence,
+ * but it can provide a copy method. So, I think I'll just use #t
+ */
+ #define Q_copy s7_make_circular_signature(sc, 3, 4, sc->T, sc->T, sc->T, sc->is_integer_symbol)
+
+ s7_pointer source = car(args), dest;
+ s7_int i, j, dest_len, start, end, source_len;
+ s7_pointer (*set)(s7_scheme *sc, s7_pointer obj, s7_int loc, s7_pointer val) = NULL;
+ s7_pointer (*get)(s7_scheme *sc, s7_pointer obj, s7_int loc) = NULL;
+ bool have_indices;
+
+ if (is_null(cdr(args))) /* (copy obj) */
+ return(copy_source_no_dest(sc, source, 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)));
+
+ if ((is_immutable(dest)) &&
+ (dest != sc->readable_keyword) &&
+ (dest != sc->nil)) /* error_hook copies with cadr(args) :readable, so it's currently NULL */
+ wrong_type_error_nr(sc, caller, 2, dest, wrap_string(sc, "a mutable object", 16)); /* so this segfaults if not checking for :readable */
+
+ have_indices = (is_pair(cddr(args)));
+ if ((source == dest) && (!have_indices))
+ return(dest);
+
+ /* gc_protect_via_stack(sc, args); */ /* why is this problematic? */
+ sc->w = args;
+
+ switch (type(source))
+ {
+ 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));
+ }
+ end = s7_list_length(sc, source);
+ if (end == 0)
+ end = circular_list_entries(source);
+ else
+ if (end < 0) end = -end;
+ break;
+
+ case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR:
+ get = vector_getter(source);
+ end = vector_length(source);
+ break;
+
+ case T_STRING:
+ get = string_getter;
+ end = string_length(source);
+ break;
+
+ case T_HASH_TABLE:
+ if (source == dest) return(dest);
+ end = hash_table_entries(source);
+ break;
+
+ case T_RANDOM_STATE:
+ get = random_state_getter;
+ end = 2;
+ break;
+
+ 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) */
+ }
+ check_method(sc, source, sc->copy_symbol, args);
+ get = c_object_getter;
+ end = c_object_length_to_int(sc, source);
+ break;
+
+ case T_LET:
+ 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));
+ 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);
+ }
+ end = let_length(sc, source);
+ break;
+
+ case T_NIL:
+ end = 0;
+ if (is_sequence(dest))
+ 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));
+ }
+
+ start = 0;
+ if (have_indices)
+ {
+ s7_pointer p = start_and_end(sc, caller, args, 3, cddr(args), &start, &end);
+ if (p != sc->unused) return(p);
+ }
+ if ((start == 0) && (source == dest))
+ return(dest);
+
+ source_len = end - start;
+ if (source_len == 0)
+ {
+ if (!is_sequence(dest))
+ wrong_type_error_nr(sc, caller, 2, dest, a_sequence_string);
+ return(dest);
+ }
+
+ switch (type(dest))
+ {
+ case T_PAIR:
+ dest_len = source_len;
+ break;
+
+ 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)]));
+ case T_FLOAT_VECTOR:
+ set = vector_setter(dest);
+ dest_len = vector_length(dest);
+ break;
+
+ case T_VECTOR:
+ set = (is_typed_vector(dest)) ? typed_vector_setter : vector_setter(dest);
+ dest_len = vector_length(dest);
+ break;
+
+ case T_STRING:
+ set = string_setter;
+ dest_len = string_length(dest);
+ set_cadr(sc->elist_3, caller); /* for possible error handling in string_setter */
+ break;
+
+ case T_HASH_TABLE:
+ set = hash_table_setter;
+ dest_len = source_len;
+ set_cadr(sc->elist_3, caller); /* for possible error handling in hash_table_setter */
+ break;
+
+ 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);
+ }
+ 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));
+ if (dest == sc->s7_starlet)
+ 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 */
+ break;
+
+ case T_NIL:
+ return(sc->nil);
+
+ case T_RANDOM_STATE:
+ set = random_state_setter;
+ dest_len = 2;
+ 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));
+ }
+
+ if (dest_len == 0)
+ return(dest);
+
+ /* end is source_len if not set explicitly */
+ if (dest_len < source_len)
+ {
+ end = dest_len + start;
+ source_len = dest_len;
+ }
+
+ if ((source != dest) &&
+ ((type(source) == type(dest)) ||
+ ((is_string_or_byte_vector(source)) &&
+ (is_string_or_byte_vector(dest)))))
+ {
+ s7_pointer res = copy_to_same_type(sc, dest, source, 0, source_len, start);
+ if (res) return(res);
+ }
+
+ switch (type(source))
+ {
+ 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);
+ }
+
+ 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);
+ }
+ 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)));
+ }
+ 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);
+ }}
+ 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);
+ }}
+ 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);
+ }}
+ 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);
+ }}
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }
+ break;
+ }
+
+ if (is_pair(dest))
+ {
+ 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]));
+ }
+ 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));
+ }
+ 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++)
+ set(sc, dest, j, get(sc, source, i));
+ /* some choices probably should raise an error, but don't:
+ * (copy (make-hash-table) "1") ; nothing to copy (empty hash table), so no error
+ */
+ return(dest);
+}
+
+s7_pointer s7_copy(s7_scheme *sc, s7_pointer args) {return(s7_copy_1(sc, sc->copy_symbol, args));}
+#define g_copy s7_copy
+
+
+/* -------------------------------- reverse -------------------------------- */
+s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a) /* just pairs */
+{
+ /* reverse list -- produce new list (other code assumes this function does not return the original!) */
+ s7_pointer x, p;
+
+ if (is_null(a)) return(a);
+ if (!is_pair(cdr(a)))
+ return((is_null(cdr(a))) ? list_1(sc, car(a)) : cons(sc, cdr(a), car(a))); /* don't return 'a' itself */
+ sc->w = list_1(sc, car(a));
+ for (x = cdr(a), p = a; is_pair(x); x = cdr(x), p = cdr(p))
+ {
+ 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);
+ }
+ if (x == p) /* this can take awhile to notice there's a cycle, but what does the caller expect? */
+ 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;
+ return(p);
+}
+
+/* s7_reverse sometimes tacks extra nodes on the end of a reversed circular list (it detects the cycle too late)
+ * (let ((lst (list 0))) (set! (cdr lst) lst) (reverse lst)) -> (#1=(0 . #1#) 0 0 0)
+ */
+
+static s7_pointer string_reverse(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer np;
+ char *dest, *source = string_value(p);
+ s7_int len = string_length(p);
+ char *end = (char *)(source + len);
+ np = make_empty_string(sc, len, '\0');
+ dest = (char *)(string_value(np) + len);
+ while (source < end) *(--dest) = *source++;
+ return(np);
+}
+
+static s7_pointer byte_vector_reverse(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer np;
+ uint8_t *dest;
+ const uint8_t *source = byte_vector_bytes(p);
+ s7_int len = byte_vector_length(p);
+ const uint8_t *end = (const uint8_t *)(source + len);
+ np = make_simple_byte_vector(sc, len);
+ dest = (uint8_t *)(byte_vector_bytes(np) + len);
+ while (source < end) *(--dest) = *source++;
+ return(np);
+}
+
+static s7_pointer int_vector_reverse(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer np;
+ s7_int *dest, *source = int_vector_ints(p);
+ s7_int len = vector_length(p);
+ s7_int *end = (s7_int *)(source + len);
+ if (vector_rank(p) > 1)
+ np = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, p)), int_zero), sc->make_int_vector_symbol);
+ else np = make_simple_int_vector(sc, len);
+ dest = (s7_int *)(int_vector_ints(np) + len);
+ while (source < end) *(--dest) = *source++;
+ return(np);
+}
+
+static s7_pointer float_vector_reverse(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer np;
+ s7_double *dest, *source = float_vector_floats(p);
+ s7_int len = vector_length(p);
+ s7_double *end = (s7_double *)(source + len);
+ if (vector_rank(p) > 1)
+ np = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, p)), real_zero), sc->make_float_vector_symbol);
+ else np = make_simple_float_vector(sc, len);
+ dest = (s7_double *)(float_vector_floats(np) + len);
+ while (source < end) *(--dest) = *source++;
+ return(np);
+}
+
+static s7_pointer vector_reverse(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer np;
+ s7_pointer *dest, *source = vector_elements(p);
+ s7_int len = vector_length(p);
+ s7_pointer *end = (s7_pointer *)(source + len);
+ if (vector_rank(p) > 1)
+ np = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, p))));
+ else np = make_simple_vector(sc, len);
+ dest = (s7_pointer *)(vector_elements(np) + len);
+ while (source < end) *(--dest) = *source++;
+ if (is_typed_vector(p))
+ {
+ set_typed_vector(np);
+ typed_vector_set_typer(np, typed_vector_typer(p));
+ if (has_simple_elements(p)) set_has_simple_elements(np);
+ }
+ return(np);
+}
+
+static s7_pointer reverse_p_p(s7_scheme *sc, s7_pointer p)
+{
+ sc->temp3 = p;
+ if (is_pair(p)) return(s7_reverse(sc, p)); /* by far the most common case */
+ switch (type(p))
+ {
+ case T_NIL: return(sc->nil);
+ /* case T_PAIR: return(s7_reverse(sc, p)); */
+ case T_STRING: return(string_reverse(sc, p));
+ case T_BYTE_VECTOR: return(byte_vector_reverse(sc, p));
+ case T_INT_VECTOR: return(int_vector_reverse(sc, p));
+ case T_FLOAT_VECTOR: return(float_vector_reverse(sc, p));
+ case T_VECTOR: return(vector_reverse(sc, p));
+ case T_HASH_TABLE: return(hash_table_reverse(sc, 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);
+ 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));
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't reverse let: ~S", 21), p));
+ default:
+ return(method_or_bust_p(sc, p, sc->reverse_symbol, a_sequence_string));
+ }
+ return(sc->nil);
+}
+
+static s7_pointer g_reverse(s7_scheme *sc, s7_pointer args)
+{
+ #define H_reverse "(reverse lst) returns a list with the elements of lst in reverse order. reverse \
+also accepts a string or vector argument."
+ #define Q_reverse s7_make_signature(sc, 2, sc->is_sequence_symbol, sc->is_sequence_symbol)
+ return(reverse_p_p(sc, car(args)));
+}
+
+static s7_pointer any_list_reverse_in_place(s7_scheme *sc, s7_pointer term, s7_pointer list)
+{
+ s7_pointer p, result;
+ if (is_null(list)) return(term);
+ p = list;
+ result = term;
+ while (true)
+ {
+ s7_pointer q = cdr(p);
+ if (is_null(q))
+ {
+ set_cdr(p, result);
+ return(p);
+ }
+ if ((is_pair(q)) && (!is_immutable_pair(q)))
+ {
+ set_cdr(p, result);
+ result = p;
+ p = q;
+ }
+ else return(sc->nil); /* improper or immutable */
+ }
+ return(result);
+}
+
+static s7_pointer string_or_byte_vector_reverse_in_place(s7_scheme *sc, s7_pointer p)
+{
+ s7_int len;
+ uint8_t *bytes;
+
+ if (is_string(p))
+ {
+ len = string_length(p);
+ bytes = (uint8_t *)string_value(p);
+ }
+ else
+ {
+ len = byte_vector_length(p);
+ bytes = byte_vector_bytes(p);
+ }
+ if (len < 2) return(p);
+
+ if (is_immutable(p)) /* "" might be immutable but we want (reverse! "") to return "" */
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p));
+
+#if (defined(__linux__)) && (defined(__GLIBC__)) /* need byteswp.h */
+ /* this code (from StackOverflow with changes) is much faster: */
+#include <byteswap.h>
+ if ((len & 0x7f) == 0)
+ {
+ 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));
+ }}
+ 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));
+ }}
+ else
+#endif
+ {
+ char *s1 = (char *)bytes;
+ char *s2 = (char *)(s1 + len - 1);
+ while (s1 < s2) {char c; c = *s1; *s1++ = *s2; *s2-- = c;}
+ }
+ return(p);
+}
+
+static s7_pointer int_vector_reverse_in_place(s7_scheme *sc, s7_pointer p)
+{
+ s7_int len = vector_length(p);
+ s7_int *s1 = int_vector_ints(p), *s2;
+
+ if (len < 2) return(p); /* (reverse! #i()) -> #i() independent of immutable bit */
+ if (is_immutable_vector(p))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p));
+
+ s2 = (s7_int *)(s1 + len - 1);
+ 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);
+ }
+ 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);
+ }
+ else while (s1 < s2) {s7_int c; c = *s1; *s1++ = *s2; *s2-- = c;}
+ return(p);
+}
+
+static s7_pointer float_vector_reverse_in_place(s7_scheme *sc, s7_pointer p)
+{
+ s7_int len = vector_length(p);
+ s7_double *s1 = float_vector_floats(p), *s2;
+ if (len < 2) return(p);
+ if (is_immutable_vector(p))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p));
+ s2 = (s7_double *)(s1 + len - 1);
+ 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);
+ }
+ else
+ if ((len & 0xf) == 0)
+ while (s1 < s2)
+ {
+ 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);
+}
+
+static s7_pointer vector_reverse_in_place(s7_scheme *sc, s7_pointer p)
+{
+ s7_int len = vector_length(p);
+ s7_pointer *s1 = vector_elements(p), *s2;
+ if (len < 2) return(p);
+ if (is_immutable_vector(p))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, p));
+ s2 = (s7_pointer *)(s1 + len - 1);
+ 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);
+ }
+ else
+ if ((len & 0xf) == 0)
+ while (s1 < s2)
+ {
+ 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);
+}
+
+static s7_pointer g_reverse_in_place(s7_scheme *sc, s7_pointer args)
+{
+ #define H_reverse_in_place "(reverse! lst) reverses lst in place"
+ #define Q_reverse_in_place Q_reverse
+
+ /* (reverse v) is only slighly faster than (reverse! (copy v)) */
+ s7_pointer p = car(args);
+ switch (type(p))
+ {
+ case T_NIL: /* (reverse! ()) -> () */
+ return(sc->nil);
+
+ case T_PAIR:
+ if (is_immutable_pair(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);
+ }
+ /* (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))
+ * To make (reverse! p) direct:
+ * for (l = p, r = cdr(p); is_pair(r); l = r, r = cdr(r)) opt1(r) = l;
+ * if (!is_null(r)) sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, p, a_proper_list_string);
+ * for (r = l, l = p; l != r; l = cdr(l)) {t = car(l); set_car(l, car(r)); set_car(r, t); if (cdr(l) != r) r = opt1(r);}
+ * immutable check is needed else (reverse! (catch #t 1 cons)) clobbers sc->wrong_type_arg_info
+ */
+
+ case T_BYTE_VECTOR:
+ case T_STRING: return(string_or_byte_vector_reverse_in_place(sc, p));
+ case T_INT_VECTOR: return(int_vector_reverse_in_place(sc, p));
+ case T_FLOAT_VECTOR: return(float_vector_reverse_in_place(sc, p));
+ case T_VECTOR: return(vector_reverse_in_place(sc, p));
+
+ 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)) &&
+ (!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);
+}
+
+
+/* -------------------------------- fill! -------------------------------- */
+static s7_pointer pair_fill(s7_scheme *sc, s7_pointer args) /* args=(list tree-to-fill fill-val start end) */
+{
+ /* ambiguous ("tree-fill"?) but if it's like vector-fill, we just stomp on the top level */
+ s7_pointer obj = car(args), val;
+ s7_int i, start = 0, end, len;
+
+#if WITH_HISTORY
+ if ((is_immutable_pair(obj)) && (obj != sc->eval_history1) && (obj != sc->eval_history2))
+#else
+ if (is_immutable_pair(obj))
+#endif
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->fill_symbol, obj));
+ if (obj == global_value(sc->features_symbol)) /* (let_id(sc->curlet) == symbol_id(sc->features_symbol)) && (obj == local_value(sc->features_symbol))) */
+ error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't fill! *features*", 22)));
+ if (obj == global_value(sc->libraries_symbol))
+ error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't fill! *libraries*", 23)));
+
+ val = cadr(args);
+ len = s7_list_length(sc, obj);
+ end = len;
+ if (end < 0) end = -end; else {if (end == 0) end = 123123123;}
+ if (!is_null(cddr(args)))
+ {
+ s7_pointer p = start_and_end(sc, sc->fill_symbol, args, 3, cddr(args), &start, &end);
+ if (p != sc->unused) return(p);
+ if (start == end) return(val);
+ }
+ if (len > 0)
+ {
+ s7_pointer p;
+ if (end < len) len = end;
+ for (i = 0, p = obj; i < start; p = cdr(p), i++);
+ for (; i < len; p = cdr(p), i++) set_car(p, val);
+ return(val);
+ }
+ i = 0;
+ for (s7_pointer x = obj, y = obj; ; i++)
+ {
+ if ((end > 0) && (i >= end))
+ 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);
+ }
+ x = cdr(x);
+ if ((i & 1) != 0) y = cdr(y);
+ if (x == y)
+ return(val);
+ }
+ return(val);
+}
+
+s7_pointer s7_fill(s7_scheme *sc, s7_pointer args)
+{
+ #define H_fill "(fill! obj val (start 0) end) fills obj with val"
+ #define Q_fill s7_make_circular_signature(sc, 3, 4, sc->T, sc->is_sequence_symbol, sc->T, sc->is_integer_symbol)
+
+ /* individual functions below check for immutable objects (rather than checking once for all here) because
+ * they are used elsewhere, and there are complications (the history lists in pair_fill for example).
+ * However, obj might have a setter which disallows val -- I guess we'll run that setter using val,
+ * to get the fill value to use (or raise an error). But here we have the value not the symbol/slot!
+ */
+ s7_pointer p = car(args);
+ switch (type(p))
+ {
+ case T_STRING: return(g_string_fill_1(sc, sc->fill_symbol, args)); /* redundant type check here and below */
+ case T_PAIR: return(pair_fill(sc, 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));
+ 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));
+ case T_LET:
+ check_method(sc, p, sc->fill_symbol, args);
+ return(let_fill(sc, 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);
+ return((*(c_object_fill(sc, p)))(sc, args));
+ default:
+ check_method(sc, p, sc->fill_symbol, args);
+ }
+ wrong_type_error_nr(sc, sc->fill_symbol, 1, p, a_sequence_string); /* (fill! 1 0) */
+ return(NULL);
+}
+
+#define g_fill s7_fill
+
+
+/* -------------------------------- append -------------------------------- */
+static s7_int total_sequence_length(s7_scheme *sc, s7_pointer args, s7_pointer caller, uint8_t typ)
+{
+ s7_pointer p = args;
+ s7_int len = 0;
+
+ for (s7_int i = 1; is_pair(p); p = cdr(p), i++)
+ {
+ 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);
+ }
+ if (n < 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);
+}
+
+static s7_pointer vector_append(s7_scheme *sc, s7_pointer args, uint8_t typ, s7_pointer caller)
+{
+ s7_pointer new_vec, p, pargs, vtyper = NULL;
+ s7_pointer *v_elements = NULL;
+ s7_double *fv_elements = NULL;
+ s7_int *iv_elements = NULL;
+ uint8_t *byte_elements = NULL;
+ s7_int i, len;
+ bool typed;
+
+ gc_protect_via_stack(sc, args);
+ len = total_sequence_length(sc, args, caller, (typ == T_VECTOR) ? T_FREE : ((typ == T_FLOAT_VECTOR) ? T_REAL : T_INTEGER));
+ if (len > sc->max_vector_length)
+ {
+ 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)));
+ }
+ 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);
+ set_stack_protected2(sc, new_vec);
+ add_vector(sc, new_vec);
+ if (len == 0)
+ {
+ unstack_gc_protect(sc);
+ return(new_vec);
+ }
+ if (typ == T_VECTOR)
+ v_elements = vector_elements(new_vec);
+ else
+ if (typ == T_FLOAT_VECTOR)
+ fv_elements = float_vector_floats(new_vec);
+ else
+ if (typ == T_INT_VECTOR)
+ 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 */
+ /* push_stack_no_let(sc, OP_GC_PROTECT, new_vec, pargs); */
+ set_stack_protected3(sc, pargs);
+ for (i = 0, p = args; is_pair(p); p = cdr(p)) /* in-place copy by goofing (temporarily) with new_vec's elements pointer */
+ {
+ 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);
+ }}
+ /* 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)
+ vector_elements(new_vec) = v_elements;
+ else
+ if (typ == T_FLOAT_VECTOR)
+ float_vector_floats(new_vec) = fv_elements;
+ else
+ if (typ == T_INT_VECTOR)
+ int_vector_ints(new_vec) = iv_elements;
+ else byte_vector_bytes(new_vec) = byte_elements;
+ vector_length(new_vec) = len;
+ if ((typed) && (vtyper))
+ {
+ set_typed_vector(new_vec);
+ typed_vector_set_typer(new_vec, vtyper);
+ }
+ unstack_gc_protect(sc);
+ return(new_vec);
+}
+
+static s7_pointer hash_table_append(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer new_hash, key_typer = NULL, value_typer = NULL;
+ bool typed = true;
+ gc_protect_via_stack(sc, args);
+ check_stack_size(sc);
+ new_hash = s7_make_hash_table(sc, sc->default_hash_table_length);
+ set_stack_protected2(sc, new_hash);
+ for (s7_pointer p = args; is_pair(p); p = cdr(p))
+ {
+ 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;
+ }}
+ if ((typed) && (key_typer))
+ {
+ hash_table_set_procedures(new_hash, make_hash_table_procedures(sc));
+ set_is_typed_hash_table(new_hash);
+ hash_table_set_key_typer(new_hash, key_typer);
+ hash_table_set_value_typer(new_hash, value_typer);
+ }
+ if (is_weak_hash_table(car(args))) /* 16-May-23, args gc protected above, should we limit weak-hash result to pure weak-hash args? */
+ {
+ set_weak_hash_table(new_hash);
+ weak_hash_iters(new_hash) = 0;
+ }
+ set_plist_2(sc, sc->nil, sc->nil);
+ unstack_gc_protect(sc);
+ return(new_hash);
+}
+
+static s7_pointer let_append(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer new_let, e = car(args);
+ check_method(sc, e, sc->append_symbol, args);
+ gc_protect_via_stack(sc, args);
+ new_let = make_let(sc, sc->rootlet);
+ set_stack_protected2(sc, new_let);
+ for (s7_pointer p = args; is_pair(p); p = cdr(p))
+ if (!sequence_is_empty(sc, car(p)))
+ s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, car(p), new_let));
+ set_plist_2(sc, sc->nil, sc->nil);
+ unstack_gc_protect(sc);
+ return(new_let);
+}
+
+static s7_pointer g_append(s7_scheme *sc, s7_pointer args)
+{
+ #define H_append "(append ...) returns its argument sequences appended into one sequence"
+ #define Q_append s7_make_circular_signature(sc, 0, 1, sc->T)
+
+ if (is_null(args)) return(sc->nil); /* (append) -> () */
+ if (is_null(cdr(args))) return(car(args)); /* (append <anything>) -> <anything> */
+ sc->value = args;
+ args = copy_proper_list(sc, args); /* copied since other args might invoke methods */
+ sc->value = args;
+ switch (type(car(args)))
+ {
+ case T_NIL: return(g_list_append(sc, cdr(args)));
+ case T_PAIR: return(g_list_append(sc, args));
+ case T_STRING: return(g_string_append_1(sc, args, sc->append_symbol));
+ /* should this work in the generic append: (append "12" #\3) -- currently an error, (append (list 1 2) 3) -> '(1 2 . 3), but vector is error */
+ case T_HASH_TABLE: return(hash_table_append(sc, args));
+ case T_LET: return(let_append(sc, args));
+ case T_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR:
+ return(vector_append(sc, args, type(car(args)), sc->append_symbol));
+ default: check_method(sc, car(args), sc->append_symbol, args);
+ }
+ wrong_type_error_nr(sc, sc->append_symbol, 1, car(args), a_sequence_string); /* (append 1 0) */
+ return(NULL);
+}
+
+static s7_pointer append_p_ppp(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3) {return(g_append(sc, set_plist_3(sc, p1, p2, p3)));}
+
+s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b)
+{
+ if (is_pair(a))
+ {
+ s7_pointer q, p, np, op;
+ if ((!is_pair(b)) && (!is_null(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)));
+ }
+ if (!is_null(p))
+ wrong_type_error_nr(sc, sc->append_symbol, 1, a, a_proper_list_string);
+ set_cdr(np, b);
+ sc->temp8 = sc->unused;
+ return(q);
+ }
+ if (is_null(a)) return(b);
+ return(g_append(sc, set_plist_2(sc, a, b)));
+}
+
+static s7_pointer g_append_2(s7_scheme *sc, s7_pointer args) {return(s7_append(sc, car(args), cadr(args)));}
+
+static s7_pointer append_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ if (args == 2) return(sc->append_2);
+ return(f);
+}
+
+
+/* -------------------------------- object->let -------------------------------- */
+static s7_pointer byte_vector_to_list(s7_scheme *sc, const uint8_t *str, s7_int len)
+{
+ s7_pointer p;
+ if (len == 0) return(sc->nil);
+ check_free_heap_size(sc, len);
+ sc->w = sc->nil;
+ for (s7_int i = len - 1; i >= 0; i--)
+ sc->w = cons_unchecked(sc, small_int((uint32_t)(str[i])), sc->w);
+ p = sc->w;
+ sc->w = sc->unused;
+ return(p);
+}
+
+static s7_pointer hash_table_to_list(s7_scheme *sc, s7_pointer obj)
+{
+ s7_pointer x, iterator;
+ if (hash_table_entries(obj) <= 0) return(sc->nil);
+ iterator = s7_make_iterator(sc, obj);
+ gc_protect_via_stack(sc, iterator);
+ sc->w = sc->nil;
+ while (true)
+ {
+ x = s7_iterate(sc, iterator);
+ if (iterator_is_at_end(iterator)) break;
+ sc->w = cons(sc, x, sc->w);
+ }
+ x = sc->w;
+ sc->w = sc->unused;
+ unstack_gc_protect(sc);
+ return(x);
+}
+
+static s7_pointer iterator_to_list(s7_scheme *sc, s7_pointer obj)
+{
+ s7_pointer result = sc->nil, p = NULL;
+ s7_int results = 0;
+ while (true)
+ {
+ 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);
+ }
+ 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;
+ }}
+ 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);
+ }}}
+}
+
+static s7_pointer c_obj_to_list(s7_scheme *sc, s7_pointer obj) /* "c_object_to_list" is the ->list method mentioned below */
+{
+ int64_t len;
+ s7_pointer x, z, zc, result;
+ s7_int gc_z;
+
+ if (c_object_to_list(sc, obj))
+ return((*(c_object_to_list(sc, obj)))(sc, set_plist_1(sc, obj)));
+
+ x = c_object_length(sc, obj);
+ if (!s7_is_integer(x)) return(sc->F);
+ len = s7_integer_clamped_if_gmp(sc, x);
+ if (len < 0)
+ return(sc->F);
+ if (len == 0)
+ return(sc->nil);
+
+ result = make_list(sc, len, sc->nil);
+ sc->temp7 = result;
+ zc = wrapped_integer(sc); /* was make_mutable_integer 17-Nov-23 */
+ z = list_2_unchecked(sc, obj, zc);
+ gc_z = gc_protect_1(sc, z);
+ x = result;
+ for (int64_t i = 0; i < len; i++, x = cdr(x)) /* used to save/restore sc->x|z here */
+ {
+ set_integer(zc, i);
+ set_car(x, (*(c_object_ref(sc, obj)))(sc, z));
+ }
+ s7_gc_unprotect_at(sc, gc_z);
+ sc->temp7 = sc->unused;
+ return(result);
+}
+
+static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj) /* used only in format_to_port_1 and (map values ...) */
+{
+ switch (type(obj))
+ {
+ case T_STRING: return(string_to_list(sc, string_value(obj), string_length(obj)));
+ case T_BYTE_VECTOR: return(byte_vector_to_list(sc, byte_vector_bytes(obj), byte_vector_length(obj)));
+ case T_HASH_TABLE: return(hash_table_to_list(sc, obj));
+ case T_ITERATOR: return(iterator_to_list(sc, obj));
+ case T_C_OBJECT: return(c_obj_to_list(sc, obj));
+ case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR:
+ return(s7_vector_to_list(sc, obj));
+ case T_LET:
+#if (!WITH_PURE_S7)
+ check_method(sc, obj, sc->let_to_list_symbol, set_plist_1(sc, obj));
+#endif
+ return(s7_let_to_list(sc, obj));
+ }
+ return(obj);
+}
+
+
+/* ---------------- object->let ---------------- */
+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));
+ 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);
+ 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));
+ }
+ s7_gc_unprotect_at(sc, gc_loc);
+ }
+ return(let);
+}
+
+static s7_pointer random_state_to_let(s7_scheme *sc, s7_pointer obj)
+{
+#if WITH_GMP
+ return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_random_state_symbol));
+#else
+ if (!sc->seed_symbol)
+ {
+ sc->seed_symbol = make_symbol(sc, "seed", 4);
+ 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))));
+#endif
+}
+
+static s7_pointer vector_to_let(s7_scheme *sc, s7_pointer obj)
+{
+ s7_pointer let;
+ 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)));
+ 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;
+ }
+ s7_varlet(sc, let, sc->position_symbol, make_integer(sc, pos));
+ s7_varlet(sc, let, sc->original_vector_symbol, subvector_vector(obj));
+ }
+ if (is_typed_t_vector(obj))
+ s7_varlet(sc, let, sc->signature_symbol, g_signature(sc, set_plist_1(sc, obj)));
+
+#if S7_DEBUGGING
+ if ((is_t_vector(obj)) && (is_symbol_table(obj))) /* (object->let (symbol-table)) */
+ {
+ 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_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))))));
+ }
+#endif
+
+ unstack_gc_protect(sc);
+ return(let);
+}
+
+static void hash_table_checker_to_let(s7_scheme *sc, s7_pointer let, s7_pointer obj)
+{
+ if ((hash_table_checker(obj) == hash_eq) ||
+ (hash_table_checker(obj) == hash_c_function) ||
+ (hash_table_checker(obj) == hash_closure) ||
+ (hash_table_checker(obj) == hash_equal_eq) ||
+ (hash_table_checker(obj) == hash_equal_syntax) ||
+ (hash_table_checker(obj) == hash_symbol))
+ s7_varlet(sc, let, sc->function_symbol, sc->is_eq_symbol);
+ else
+ if (hash_table_checker(obj) == hash_eqv)
+ 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);
+ 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 (!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);
+#endif
+}
+
+static s7_pointer hash_table_to_let(s7_scheme *sc, s7_pointer obj)
+{
+ s7_pointer let;
+ s7_int gc_loc;
+ if (!sc->entries_symbol)
+ {
+ sc->entries_symbol = make_symbol(sc, "entries", 7);
+ 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)));
+ gc_loc = gc_protect_1(sc, let);
+ if (is_weak_hash_table(obj))
+ s7_varlet(sc, let, sc->weak_symbol, sc->T);
+
+ if (is_typed_hash_table(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);
+ 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);
+ }
+ else hash_table_checker_to_let(sc, let, obj);
+
+#if S7_DEBUGGING
+ if (hash_table_entries(obj) > 0)
+ {
+ 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;
+ }
+ 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))))));
+ }
+#endif
+
+ s7_gc_unprotect_at(sc, gc_loc);
+ return(let);
+}
+
+static s7_pointer iterator_to_let(s7_scheme *sc, s7_pointer obj)
+{
+ s7_pointer let, seq = iterator_sequence(obj);
+ if (!sc->at_end_symbol)
+ {
+ sc->at_end_symbol = make_symbol(sc, "at-end", 6);
+ 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));
+ gc_protect_via_stack(sc, let);
+ if (is_pair(seq))
+ s7_varlet(sc, let, sc->size_symbol, s7_length(sc, seq));
+ else
+ if (is_hash_table(seq))
+ s7_varlet(sc, let, sc->size_symbol, make_integer(sc, hash_table_entries(seq)));
+ else s7_varlet(sc, let, sc->size_symbol, s7_length(sc, obj));
+ if ((is_string(seq)) ||
+ (is_any_vector(seq)) ||
+ (seq == sc->rootlet) ||
+ (is_c_object(seq)) ||
+ (is_hash_table(seq)))
+ s7_varlet(sc, let, sc->position_symbol, make_integer(sc, iterator_position(obj)));
+ else
+ if (is_pair(seq))
+ s7_varlet(sc, let, sc->position_symbol, iterator_current(obj));
+ unstack_gc_protect(sc);
+ return(let);
+}
+
+static s7_pointer let_to_let(s7_scheme *sc, s7_pointer obj)
+{
+ /* how to handle setters?
+ * (display (let ((e (let ((i 0)) (set! (setter 'i) integer?) (curlet)))) (object->let e))):
+ * "(inlet 'value (inlet 'i 0) 'type let? 'length 1 'open #f 'outlet () 'immutable? #f)"
+ */
+ s7_pointer let;
+ s7_int gc_loc;
+ if (!sc->open_symbol)
+ {
+ sc->open_symbol = make_symbol(sc, "open", 4);
+ 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)));
+ gc_loc = gc_protect_1(sc, let);
+ if (obj == sc->rootlet)
+ s7_varlet(sc, let, sc->alias_symbol, sc->rootlet_symbol);
+ else
+ if (obj == sc->owlet) /* this can't happen, I think -- owlet is always copied first */
+ 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)));
+ }}
+ 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 (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_gc_unprotect_at(sc, gc_loc);
+ return(let);
+}
+
+static s7_pointer c_object_to_let(s7_scheme *sc, s7_pointer obj)
+{
+ s7_pointer let, clet = c_object_let(obj);
+ if (!sc->class_symbol)
+ {
+ sc->class_symbol = make_symbol(sc, "class", 5);
+ 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));
+ 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_gc_unprotect_at(sc, gc_loc);
+ }
+ return(let);
+}
+
+static s7_pointer port_to_let(s7_scheme *sc, s7_pointer obj) /* note the underbars! */
+{
+ s7_pointer let;
+ s7_int gc_loc;
+ if (!sc->data_symbol)
+ {
+ sc->data_symbol = make_symbol(sc, "data", 4);
+ sc->port_type_symbol = make_symbol(sc, "port-type", 9);
+ sc->closed_symbol = make_symbol(sc, "closed", 6);
+ 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)));
+ 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)));
+#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));
+ }}
+#endif
+ }
+ if ((is_string_port(obj)) && /* file port might not have a data buffer */
+ (port_data(obj)) &&
+ (port_data_size(obj) > 0))
+ {
+ s7_varlet(sc, let, sc->size_symbol, make_integer(sc, port_data_size(obj)));
+ s7_varlet(sc, let, sc->position_symbol, make_integer(sc, port_position(obj)));
+ /* I think port_data need not be null-terminated, but s7_make_string assumes it is:
+ * 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? */
+ }
+ if (is_function_port(obj))
+ s7_varlet(sc, let, sc->function_symbol, port_string_or_function(obj));
+ s7_gc_unprotect_at(sc, gc_loc);
+ return(let);
+}
+
+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)));
+ gc_protect_via_stack(sc, let);
+ if (is_pair(sig))
+ s7_varlet(sc, let, sc->local_signature_symbol, sig);
+ if (doc)
+ s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc));
+
+ if (is_let(closure_let(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)));
+ }}
+
+ if (closure_setter(obj) != sc->F)
+ s7_varlet(sc, let, sc->local_setter_symbol, closure_setter(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)));
+ unstack_gc_protect(sc);
+ return(let);
+}
+
+static s7_pointer c_pointer_to_let(s7_scheme *sc, s7_pointer obj)
+{
+ /* c_pointer_info can be a let and might have an object->let method (see c_object below) */
+ if (!sc->c_type_symbol)
+ {
+ sc->c_type_symbol = make_symbol(sc, "c-type", 6);
+ sc->info_symbol = make_symbol(sc, "info", 4);
+ }
+ 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)));
+}
+
+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)));
+ gc_protect_via_stack(sc, let);
+ if (is_pair(sig))
+ s7_varlet(sc, let, sc->local_signature_symbol, sig);
+ if (doc)
+ s7_varlet(sc, let, sc->local_documentation_symbol, s7_make_string(sc, doc));
+
+ if (c_function_setter(obj) != sc->F) /* c_macro_setter is the same underlying field */
+ s7_varlet(sc, let, sc->local_setter_symbol, c_function_setter(obj));
+ unstack_gc_protect(sc);
+ return(let);
+}
+
+static s7_pointer goto_to_let(s7_scheme *sc, s7_pointer obj)
+{
+ /* there's room in s7_cell to store the procedure, but we would have to mark it (goto escapes, context GC'd) */
+ if (!sc->active_symbol)
+ 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)));
+ 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))));
+}
+
+static s7_pointer object_to_let_p_p(s7_scheme *sc, s7_pointer obj)
+{
+ switch (type(obj))
+ {
+ case T_NIL: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_null_symbol));
+ case T_UNSPECIFIED: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_unspecified_symbol));
+ case T_UNDEFINED: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_undefined_symbol));
+ case T_EOF: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_eof_object_symbol));
+ case T_BOOLEAN: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_boolean_symbol));
+ case T_CHARACTER: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_char_symbol));
+ case T_SYMBOL: return(symbol_to_let(sc, obj));
+ case T_RANDOM_STATE: return(random_state_to_let(sc, obj));
+ case T_GOTO: return(goto_to_let(sc, obj));
+ case T_C_POINTER: return(c_pointer_to_let(sc, obj));
+ case T_ITERATOR: return(iterator_to_let(sc, obj));
+ case T_HASH_TABLE: return(hash_table_to_let(sc, obj));
+ case T_LET: return(let_to_let(sc, obj));
+ case T_C_OBJECT: return(c_object_to_let(sc, obj));
+
+ case T_INTEGER: case T_BIG_INTEGER: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_integer_symbol));
+ case T_RATIO: case T_BIG_RATIO: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_rational_symbol));
+ case T_REAL: case T_BIG_REAL: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_real_symbol));
+ case T_COMPLEX: case T_BIG_COMPLEX: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_complex_symbol));
+
+ 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))));
+ 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)));
+ 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))));
+
+ 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, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_continuation_symbol));
+
+ case T_INPUT_PORT: case T_OUTPUT_PORT:
+ return(port_to_let(sc, obj));
+
+ case T_CLOSURE: case T_CLOSURE_STAR: case T_MACRO: case T_MACRO_STAR: case T_BACRO: case T_BACRO_STAR:
+ return(closure_to_let(sc, obj));
+
+ case T_C_MACRO: case T_C_FUNCTION_STAR:
+ case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION:
+ return(c_function_to_let(sc, obj));
+
+ default:
+ return(sc->F);
+ }
+ return(sc->F);
+}
+
+static s7_pointer g_object_to_let(s7_scheme *sc, s7_pointer args)
+{
+ #define H_object_to_let "(object->let obj) returns a let (namespace) describing obj."
+ #define Q_object_to_let s7_make_signature(sc, 2, sc->is_let_symbol, sc->T)
+ return(object_to_let_p_p(sc, car(args)));
+}
+
+
+/* ---------------- stacktrace ---------------- */
+static s7_pointer stacktrace_find_caller(s7_scheme *sc, s7_pointer e)
+{
+ if ((is_let(e)) && (e != sc->rootlet))
+ return(((is_funclet(e)) || (is_maclet(e))) ? funclet_function(e) : stacktrace_find_caller(sc, let_outlet(e)));
+ return(sc->F);
+}
+
+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))));
+}
+
+static int64_t stacktrace_find_error_hook_quit(s7_scheme *sc)
+{
+ for (int64_t i = stack_top(sc) - 1; i >= 3; i -= 4)
+ if (stack_op(sc->stack, i) == OP_ERROR_HOOK_QUIT)
+ return(i);
+ return(-1);
+}
+
+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));
+}
+
+static bool stacktrace_error_hook_function(s7_scheme *sc, s7_pointer sym)
+{
+ if (is_symbol(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))));
+ }
+ 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)
+{
+ 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);
+ }}}
+ return(notes);
+ }
+ if ((is_pair(code)) &&
+ (s7_list_length(sc, code) > 0) &&
+ (depth < 32))
+ {
+ notes = stacktrace_walker(sc, car(code), e, notes, code_cols, total_cols, notes_start_col, as_comment, depth + 1);
+ return(stacktrace_walker(sc, cdr(code), e, notes, code_cols, total_cols, notes_start_col, as_comment, depth + 2));
+ }
+ return(notes);
+}
+
+static block_t *stacktrace_add_func(s7_scheme *sc, s7_pointer f, s7_pointer code, const char *errstr, char *notes, s7_int code_max, bool as_comment)
+{
+ s7_int newlen, errlen = strlen(errstr);
+ char *newstr, *str;
+ block_t *newp, *b;
+ if ((is_symbol(f)) &&
+ (f != car(code)))
+ {
+ newlen = symbol_name_length(f) + errlen + 10;
+ newp = mallocate(sc, newlen);
+ newstr = (char *)block_data(newp); /* newstr[0] = '\0'; */
+ errlen = catstrs_direct(newstr, symbol_name(f), ": ", errstr, (const char *)NULL);
+ }
+ else
+ {
+ newlen = errlen + 8;
+ newp = mallocate(sc, newlen);
+ newstr = (char *)block_data(newp); /* newstr[0] = '\0'; */
+ if ((errlen > 2) && (errstr[2] == '('))
+ errlen = catstrs_direct(newstr, " ", errstr, (const char *)NULL);
+ else
+ {
+ 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'; */
+
+ if (errlen >= code_max)
+ {
+ newstr[code_max - 4] = '.';
+ newstr[code_max - 3] = '.';
+ newstr[code_max - 2] = '.';
+ newstr[code_max - 1] = '\0';
+ catstrs_direct(str, (as_comment) ? "; " : "", newstr, (notes) ? notes : "", "\n", (const char *)NULL);
+ }
+ else
+ {
+ /* 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);
+ }
+ else catstrs(str, newlen, "\n", (char *)NULL);
+ }
+ liberate(sc, newp);
+ return(b);
+}
+
+static s7_pointer stacktrace_1(s7_scheme *sc, s7_int frames_max, s7_int code_cols, s7_int total_cols, s7_int notes_start_col, bool as_comment)
+{
+ char *str = NULL;
+ block_t *strp = NULL;
+ int64_t loc, frames = 0;
+ int64_t top = (sc->stack_end - sc->stack_start) / 4; /* (*s7* 'stack_top), not stack_top(sc)! */
+ clear_symbol_list(sc);
+
+ if (stacktrace_in_error_handler(sc, top))
+ {
+ 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? */
+ }
+ 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;
+ }
+ for (loc = top - 1; loc > 0; loc--)
+ {
+ 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);
+ }}}}}
+ 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))));
+}
+
+static s7_pointer g_stacktrace(s7_scheme *sc, s7_pointer args)
+{
+ #define H_stacktrace "(stacktrace (max-frames 30) (code-cols 50) (total-cols 80) (note-col 50) as-comment) returns \
+a stacktrace as a string. Each line has two portions, the code being evaluated and a note giving \
+the value of local variables in that code. The first argument sets how many lines are displayed. \
+The next three arguments set the length and layout of those lines. 'as-comment' if #t causes each \
+line to be preceded by a semicolon."
+ #define Q_stacktrace s7_make_signature(sc, 6, \
+ sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol, \
+ sc->is_integer_symbol, sc->is_integer_symbol, sc->is_boolean_symbol)
+
+ s7_int max_frames = 30, code_cols = 50, total_cols = 80, notes_start_col = 50;
+ bool as_comment = false;
+
+ 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));
+ max_frames = s7_integer_clamped_if_gmp(sc, car(args));
+ if ((max_frames <= 0) || (max_frames > S7_INT32_MAX))
+ 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));
+ }}}}}
+ return(stacktrace_1(sc, max_frames, code_cols, total_cols, notes_start_col, as_comment));
+}
+
+
+/* -------- s7_history, s7_add_to_history, s7_history_enabled -------- */
+
+s7_pointer s7_add_to_history(s7_scheme *sc, s7_pointer entry)
+{
+#if WITH_HISTORY
+ set_current_code(sc, entry);
+#endif
+ return(entry);
+}
+
+s7_pointer s7_history(s7_scheme *sc)
+{
+#if WITH_HISTORY
+ if (sc->cur_code == sc->history_sink)
+ return(sc->old_cur_code);
+#endif
+ return(sc->cur_code);
+}
+
+bool s7_history_enabled(s7_scheme *sc)
+{
+#if WITH_HISTORY
+ return(sc->cur_code != sc->history_sink);
+#else
+ return(false);
+#endif
+}
+
+bool s7_set_history_enabled(s7_scheme *sc, bool enabled)
+{
+#if WITH_HISTORY
+ bool old_enabled = (sc->cur_code == sc->history_sink);
+ if (enabled) /* this needs to restore the old cur_code (saving its position in the history_buffer) */
+ sc->cur_code = sc->old_cur_code;
+ else
+ if (sc->cur_code != sc->history_sink)
+ {
+ sc->old_cur_code = sc->cur_code;
+ sc->cur_code = sc->history_sink;
+ }
+ return(old_enabled);
+#else
+ return(false);
+#endif
+}
+
+#if WITH_HISTORY
+static s7_pointer history_cons(s7_scheme *sc, s7_pointer code, s7_pointer args)
+{
+ s7_pointer p = car(sc->history_pairs);
+ sc->history_pairs = cdr(sc->history_pairs);
+ set_car(p, code);
+ unchecked_set_cdr(p, args);
+ return(p);
+}
+#else
+#define history_cons(Sc, Code, Args) Code
+#endif
+
+
+/* -------------------------------- profile -------------------------------- */
+static void swap_stack(s7_scheme *sc, opcode_t new_op, s7_pointer new_code, s7_pointer new_args)
+{
+ s7_pointer code, args, e;
+ opcode_t op;
+
+ sc->stack_end -= 4;
+ code = stack_end_code(sc);
+ e = stack_end_let(sc);
+ args = stack_end_args(sc);
+ op = (opcode_t)T_Op(stack_end_op(sc)); /* this should be begin1 */
+ if ((S7_DEBUGGING) && (op != OP_BEGIN_NO_HOOK) && (op != OP_BEGIN_HOOK))
+ fprintf(stderr, "swap %s in %s\n", op_names[op], display(s7_name_to_value(sc, "estr")));
+ push_stack(sc, new_op, new_args, new_code);
+ stack_end_code(sc) = code;
+ stack_end_let(sc) = e;
+ stack_end_args(sc) = args;
+ stack_end_op(sc) = (s7_pointer)op;
+ sc->stack_end += 4;
+}
+
+static s7_pointer find_funclet(s7_scheme *sc, s7_pointer e)
+{
+ if ((e == sc->rootlet) || (!is_let(e))) return(sc->F);
+ if (!((is_funclet(e)) || (is_maclet(e)))) e = let_outlet(e);
+ if ((e == sc->rootlet) || (!is_let(e))) return(sc->F);
+ return(((is_funclet(e)) || (is_maclet(e))) ? e : sc->F);
+}
+
+#define PD_INITIAL_SIZE 16
+enum {PD_CALLS = 0, PD_RECUR, PD_START, PD_ITOTAL, PD_ETOTAL, PD_BLOCK_SIZE};
+
+static s7_pointer g_profile_out(s7_scheme *sc, s7_pointer args)
+{
+ s7_int pos = integer(car(args)) * PD_BLOCK_SIZE;
+ profile_data_t *pd = sc->profile_data;
+ s7_int *v = (s7_int *)(pd->timing_data + pos);
+ v[PD_RECUR]--;
+ if (v[PD_RECUR] == 0)
+ {
+ s7_int cur_time = (my_clock() - v[PD_START]);
+ v[PD_ITOTAL] += cur_time;
+ v[PD_ETOTAL] += (cur_time - pd->excl[pd->excl_top]);
+ pd->excl_top--;
+ pd->excl[pd->excl_top] += cur_time;
+ }
+ return(sc->F);
+}
+
+static s7_pointer g_profile_in(s7_scheme *sc, s7_pointer args) /* only external func -- added to each profiled func by add_profile above */
+{
+ #define H_profile_in "(profile-in e) is the profiler's hook into closures"
+ #define Q_profile_in s7_make_signature(sc, 3, sc->T, sc->is_integer_symbol, sc->is_let_symbol)
+
+ s7_pointer e;
+ s7_int pos;
+ if (sc->profile == 0) return(sc-> F);
+
+ pos = integer(car(args));
+ e = find_funclet(sc, cadr(args));
+
+ if ((is_let(e)) &&
+ (is_symbol(funclet_function(e))))
+ {
+ s7_pointer func_name = funclet_function(e);
+ s7_int *v;
+ 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));
+ 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;
+ }
+ 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);
+ }}
+ 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_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);
+ }
+ swap_stack(sc, OP_DYNAMIC_UNWIND_PROFILE, sc->profile_out, car(args));
+ }
+ return(sc->F);
+}
+
+static s7_pointer profile_info_out(s7_scheme *sc)
+{
+ s7_pointer p, pp, vs, vi, vn, vf, vl, matches;
+ s7_int i;
+ profile_data_t *pd = sc->profile_data;
+ if ((!pd) || (pd->top == 0)) return(sc->F);
+ p = make_list(sc, 7, sc->F);
+ sc->w = p;
+ set_car(p, vs = make_simple_vector(sc, pd->top));
+ set_car(cdr(p), vi = make_simple_int_vector(sc, pd->top * PD_BLOCK_SIZE));
+ set_car(cddr(p), make_integer(sc, ticks_per_second()));
+ pp = cdddr(p);
+ set_car(pp, vn = make_simple_vector(sc, pd->top));
+ set_car(cdr(pp), vf = make_simple_vector(sc, pd->top));
+ set_car(cddr(pp), vl = make_simple_int_vector(sc, pd->top));
+ matches = cdddr(pp);
+ set_car(matches, sc->nil);
+ 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]);
+ }
+ 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];
+ }
+ for (i = 0; i < pd->top; i++) if (pd->funcs[i]) clear_match_symbol(pd->funcs[i]);
+ memcpy((void *)int_vector_ints(vl), (void *)pd->lines, pd->top * sizeof(s7_int));
+ memcpy((void *)int_vector_ints(vi), (void *)pd->timing_data, pd->top * PD_BLOCK_SIZE * sizeof(s7_int));
+ sc->w = sc->unused;
+ return(p);
+}
+
+static s7_pointer clear_profile_info(s7_scheme *sc)
+{
+ if (sc->profile_data)
+ {
+ profile_data_t *pd = sc->profile_data;
+ memclr(pd->timing_data, pd->top * PD_BLOCK_SIZE * sizeof(s7_int));
+ memclr(pd->funcs, pd->top * sizeof(s7_pointer));
+ memclr(pd->let_names, pd->top * sizeof(s7_pointer));
+ memclr(pd->files, pd->top * sizeof(s7_pointer));
+ 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_top = 0;
+ sc->profiling_gensyms = false;
+ }
+ return(sc->F);
+}
+
+static s7_pointer make_profile_info(s7_scheme *sc)
+{
+ if (!sc->profile_data)
+ {
+ profile_data_t *pd = (profile_data_t *)Malloc(sizeof(profile_data_t));
+ pd->size = PD_INITIAL_SIZE;
+ pd->excl_size = PD_INITIAL_SIZE;
+ pd->top = 0;
+ pd->excl_top = 0;
+ pd->funcs = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer));
+ pd->let_names = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer));
+ pd->files = (s7_pointer *)Calloc(pd->size, sizeof(s7_pointer));
+ pd->lines = (s7_int *)Calloc(pd->size, sizeof(s7_int));
+ pd->excl = (s7_int *)Calloc(pd->excl_size, sizeof(s7_int));
+ pd->timing_data = (s7_int *)Calloc(pd->size * PD_BLOCK_SIZE, sizeof(s7_int));
+ sc->profile_data = pd;
+ }
+ return(sc->F);
+}
+
+
+/* -------------------------------- dynamic-unwind -------------------------------- */
+static s7_pointer dynamic_unwind(s7_scheme *sc, s7_pointer func, s7_pointer e)
+{
+ if ((S7_DEBUGGING) && (is_multiple_value(sc->value)))
+ fprintf(stderr, "%s[%d]: unexpected multiple-value! %s %s %s\n", __func__, __LINE__, display(func), display(e), display(sc->value));
+ return(s7_apply_function(sc, func, set_plist_2(sc, e, sc->value))); /* s7_apply_function returns sc->value */
+}
+
+static s7_pointer g_dynamic_unwind(s7_scheme *sc, s7_pointer args)
+{
+ #define H_dynamic_unwind "(dynamic-unwind func arg) pushes func and arg on the stack, then (func arg) is called when the stack unwinds."
+ #define Q_dynamic_unwind s7_make_signature(sc, 3, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->T)
+
+ s7_pointer func = car(args);
+ if (((is_closure(func)) && (closure_arity_to_int(sc, func) == 2)) ||
+ ((is_c_function(func)) && (c_function_is_aritable(func, 2))) ||
+ ((is_closure_star(func)) && (closure_star_arity_to_int(sc, func) == 2)) ||
+ ((is_c_function_star(func)) && (c_function_max_args(func) == 2)))
+ swap_stack(sc, OP_DYNAMIC_UNWIND, func, cadr(args));
+ else wrong_type_error_nr(sc, sc->dynamic_unwind_symbol, 1, func, wrap_string(sc, "a procedure of two arguments", 28));
+ return(cadr(args));
+}
+
+
+/* -------------------------------- catch -------------------------------- */
+static s7_pointer g_catch(s7_scheme *sc, s7_pointer args)
+{
+ #define H_catch "(catch tag thunk handler) evaluates thunk; if an error occurs that matches the tag (#t matches all), the handler is called"
+ #define Q_catch s7_make_signature(sc, 4, sc->values_symbol, \
+ s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_boolean_symbol), \
+ sc->is_procedure_symbol, sc->is_procedure_symbol)
+ s7_pointer p, proc, err;
+
+ /* Guile sets up the catch before looking for arg errors: (catch #t log (lambda args "hiho")) -> "hiho"
+ * which is consistent in that (catch #t (lambda () (log))...) should probably be the same as (catch #t log ...)
+ * but what if the error handler arg is messed up? Seems weird to handle args in reverse order with an intervening let etc.
+ * I think log as the second arg is an outer error (we don't wait until the catch is called, then fall into
+ * the local error handler).
+ */
+ /* if ((is_let(err)) && (is_openlet(err))) check_method(sc, err, sc->catch_symbol, args); */ /* causes exit from s7! */
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]\n", __func__, __LINE__);
+
+ 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)));
+ 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));
+ }
+ 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)));
+ err = caddr(args);
+ if (!is_applicable(err))
+ wrong_type_error_nr(sc, sc->catch_symbol, 3, err, something_applicable_string);
+ /* should we check here for (aritable? err 2)? (catch #t (lambda () 1) "hiho") -> 1
+ * currently this is checked only if the error handler is called
+ */
+
+ new_cell(sc, p, T_CATCH);
+ catch_tag(p) = car(args);
+ catch_goto_loc(p) = stack_top(sc);
+ catch_op_loc(p) = (int32_t)(sc->op_stack_now - sc->op_stack);
+ catch_set_handler(p, err);
+ catch_cstack(p) = sc->goto_start;
+ push_stack(sc, (intptr_t)((is_any_macro(err)) ? OP_CATCH_2 : OP_CATCH), args, p);
+
+ if (is_closure(proc)) /* not also lambda* here because we need to handle the arg defaults */
+ {
+ /* is_thunk above checks is_aritable(proc, 0), but if it's (lambda args ...) we have to set up the let with args=()
+ * the case that caught this: (catch #t make-hook ...)
+ */
+ 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));
+ else set_curlet(sc, inline_make_let(sc, closure_let(proc)));
+ push_stack_no_args_direct(sc, sc->begin_op);
+ }
+ else push_stack(sc, OP_APPLY, sc->nil, proc);
+ return(sc->F);
+}
+
+s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7_pointer error_handler)
+{
+ s7_pointer p, result;
+ if (sc->stack_end == sc->stack_start) /* no stack! */
+ push_stack_direct(sc, OP_EVAL_DONE);
+
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]\n", __func__, __LINE__);
+ new_cell(sc, p, T_CATCH);
+ catch_tag(p) = tag;
+ catch_goto_loc(p) = stack_top(sc);
+ catch_op_loc(p) = (int32_t)(sc->op_stack_now - sc->op_stack);
+ catch_set_handler(p, error_handler);
+ catch_cstack(p) = sc->goto_start;
+
+ {
+ declare_jump_info();
+ TRACK(sc);
+ store_jump_info(sc);
+ set_jump_info(sc, S7_CALL_SET_JUMP);
+
+ 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;
+ }
+ 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;
+ }
+ restore_jump_info(sc);
+ }
+
+ return(result);
+}
+
+static void op_c_catch(s7_scheme *sc)
+{
+ /* (catch #t (lambda () (set! ("hi") #\a)) (lambda args args))
+ * code is (catch #t (lambda () ....) (lambda args ....))
+ */
+ s7_pointer p, f = cadr(sc->code), args = cddr(sc->code), tag;
+
+ /* defer making the error lambda */
+ if (!is_pair(f)) /* (catch #t ...) or (catch sym ...) */
+ tag = (is_symbol(f)) ? lookup_checked(sc, f) : f;
+ else tag = cadr(f); /* (catch 'sym ...) */
+
+ new_cell(sc, p, T_CATCH); /* the catch object sitting on the stack */
+ catch_tag(p) = tag;
+ catch_goto_loc(p) = stack_top(sc);
+ catch_op_loc(p) = sc->op_stack_now - sc->op_stack;
+ catch_set_handler(p, cdadr(args)); /* not yet a closure... */
+ catch_cstack(p) = sc->goto_start;
+ push_stack(sc, OP_CATCH_1, sc->code, p); /* code ignored here, except by GC */
+ set_curlet(sc, inline_make_let(sc, sc->curlet));
+ sc->code = T_Pair(cddar(args));
+}
+
+static void op_c_catch_all(s7_scheme *sc)
+{
+ s7_pointer p;
+ new_cell(sc, p, T_CATCH);
+ catch_tag(p) = sc->T;
+ catch_goto_loc(p) = stack_top(sc);
+ catch_op_loc(p) = sc->op_stack_now - sc->op_stack;
+ catch_set_handler(p, sc->nil);
+ catch_cstack(p) = sc->goto_start;
+ push_stack(sc, OP_CATCH_ALL, opt2_con(sc->code), p); /* push_stack: op args code */
+ sc->code = T_Pair(opt1_pair(cdr(sc->code))); /* the body of the first lambda (or car of it if catch_all_o) */
+}
+
+static void op_c_catch_all_a(s7_scheme *sc)
+{
+ op_c_catch_all(sc);
+ sc->value = fx_call(sc, sc->code);
+}
+
+
+/* -------------------------------- owlet -------------------------------- */
+/* error reporting info -- save filename and line number */
+
+static s7_pointer init_owlet(s7_scheme *sc)
+{
+ s7_pointer p; /* watch out for order below */
+ s7_pointer e = make_let(sc, sc->rootlet);
+ sc->temp3 = e;
+ sc->error_type = add_slot_checked_with_id(sc, e, make_symbol(sc, "error-type", 10), sc->F); /* the error type or tag ('division-by-zero) */
+ sc->error_data = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-data", 10), sc->F); /* the message or information passed by the error function */
+ sc->error_code = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-code", 10), sc->F); /* the code that s7 thinks triggered the error */
+ sc->error_line = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-line", 10), p = make_permanent_integer(0)); /* the line number of that code */
+ add_saved_pointer(sc, p);
+ sc->error_file = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-file", 10), sc->F); /* the file name of that code */
+ sc->error_position = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-position", 14), p = make_permanent_integer(0)); /* file-byte position of that code */
+ add_saved_pointer(sc, p);
+#if WITH_HISTORY
+ sc->error_history = add_slot_unchecked_with_id(sc, e, make_symbol(sc, "error-history", 13), sc->F); /* buffer of previous evaluations */
+#endif
+ sc->temp3 = sc->unused;
+ return(e);
+}
+
+#if WITH_HISTORY
+static s7_pointer cull_history(s7_scheme *sc, s7_pointer code)
+{
+ clear_symbol_list(sc); /* make a list of words banned from the history */
+ add_symbol_to_list(sc, sc->s7_starlet_symbol);
+ add_symbol_to_list(sc, sc->eval_symbol);
+ add_symbol_to_list(sc, make_symbol(sc, "debug", 5));
+ add_symbol_to_list(sc, make_symbol(sc, "trace-in", 8));
+ add_symbol_to_list(sc, make_symbol(sc, "trace-out", 9));
+ add_symbol_to_list(sc, sc->dynamic_unwind_symbol);
+ add_symbol_to_list(sc, make_symbol(sc, "history-enabled", 15));
+ 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);
+ if (cdr(p) == code) break;
+ }
+ return(code);
+}
+#endif
+
+static s7_pointer g_owlet(s7_scheme *sc, s7_pointer args)
+{
+#if WITH_HISTORY
+ #define H_owlet "(owlet) returns the environment at the point of the last error. \
+It has the additional local variables: error-type, error-data, error-code, error-line, error-file, and error-history."
+#else
+ #define H_owlet "(owlet) returns the environment at the point of the last error. \
+It has the additional local variables: error-type, error-data, error-code, error-line, and error-file."
+#endif
+ #define Q_owlet s7_make_signature(sc, 1, sc->is_let_symbol)
+ /* if owlet is not copied, (define e (owlet)), e changes as owlet does! */
+
+ s7_pointer e;
+ bool old_gc = sc->gc_off;
+ if (is_pair(args))
+ error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->owlet_symbol, args));
+#if WITH_HISTORY
+ slot_set_value(sc->error_history, cull_history(sc, slot_value(sc->error_history)));
+#endif
+ e = let_copy(sc, sc->owlet);
+ gc_protect_via_stack(sc, e);
+
+ /* make sure the pairs/reals/strings/integers are copied: should be error-data, error-code, and error-history */
+ sc->gc_off = true;
+
+ 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)));
+ }}
+ sc->gc_off = old_gc;
+ unstack_gc_protect(sc);
+ return(e);
+}
+
+
+/* -------- catch handlers -------- (don't free the catcher) */
+static void load_catch_cstack(s7_scheme *sc, s7_pointer c)
+{
+ if (catch_cstack(c))
+ sc->goto_start = catch_cstack(c);
+}
+
+static bool catch_all_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ s7_pointer catcher = T_Cat(stack_code(sc->stack, catch_loc));
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ sc->value = stack_args(sc->stack, catch_loc); /* error result, optimize_func_three_args -> op_c_catch_all etc */
+ if (sc->value == sc->unused) sc->value = type;
+ sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(catcher));
+ sc->stack_end = (s7_pointer *)(sc->stack_start + catch_goto_loc(catcher));
+ load_catch_cstack(sc, catcher);
+ pop_stack(sc);
+ return(true);
+}
+
+static bool catch_2_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ /* this is the macro-error-handler case from g_catch
+ * (let () (define-macro (m . args) (apply (car args) (cadr args))) (catch #t (lambda () (error abs -1)) m))
+ */
+ s7_pointer x = T_Cat(stack_code(sc->stack, catch_loc));
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ if ((catch_tag(x) == sc->T) || (catch_tag(x) == type) || (type == sc->T))
+ {
+ sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(x));
+ sc->stack_end = (s7_pointer *)(sc->stack_start + catch_goto_loc(x));
+ sc->code = catch_handler(x);
+ load_catch_cstack(sc, x);
+ if (needs_copied_args(sc->code))
+ 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);
+ }
+ return(false);
+}
+
+static bool catch_1_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ s7_pointer x = T_Cat(stack_code(sc->stack, catch_loc));
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ if ((catch_tag(x) == sc->T) || /* the normal case */
+ (catch_tag(x) == type) ||
+ (type == sc->T))
+ {
+ opcode_t op = stack_op(sc->stack, catch_loc);
+ s7_pointer catcher = x, error_body, error_args;
+ s7_pointer error_func = catch_handler(catcher);
+ uint64_t loc = catch_goto_loc(catcher);
+
+ init_temp(sc->y, type);
+ sc->value = info;
+
+ sc->temp4 = stack_let(sc->stack, catch_loc); /* GC protect this, since we're moving the stack top below */
+ sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(catcher));
+ sc->stack_end = (s7_pointer *)(sc->stack_start + loc);
+ load_catch_cstack(sc, catcher);
+
+ /* very often the error handler just returns either a constant ('error or #f), or
+ * the args passed to it, so there's no need to laboriously make a closure,
+ * and apply it -- just set sc->value to the closure body (or the args) and return.
+ * so first examine closure_body(error_func)
+ * if it is a constant, or quoted symbol, return that,
+ * if it is the args symbol, return (list type info)
+ */
+
+ /* 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);
+ }
+ 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 ((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);
+ }}
+ /* 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__);
+ }
+ 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->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:
+ * ;(): too many arguments: (a1 ())
+ * when this apply tries to call the handler. So, we need a special case error check here!
+ */
+ sc->args = list_2(sc, type, info); /* almost never able to skip this -- costs more to check! */
+ sc->w = sc->unused;
+ sc->y = sc->unused;
+ sc->cur_op = OP_APPLY;
+ /* explicit eval needed if s7_call called into scheme where a caught error occurred (ex6 in exs7.c)
+ * but putting it here (via eval(sc, OP_APPLY)) means the C stack is not cleared correctly in non-s7-call cases,
+ * so defer it until s7_call
+ */
+ return(true);
+ }
+ return(false);
+}
+
+static bool catch_dynamic_wind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ s7_pointer x = T_Dyn(stack_code(sc->stack, catch_loc));
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ if (dynamic_wind_state(x) == DWIND_BODY)
+ {
+ 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);
+ }
+ return(false);
+}
+
+static bool catch_out_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ s7_pointer x = T_Pro(stack_code(sc->stack, catch_loc)); /* "code" = port that we opened */
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ s7_close_output_port(sc, x);
+ x = stack_args(sc->stack, catch_loc); /* "args" = port that we shadowed, if not #<unused> */
+ if (x != sc->unused)
+ set_current_output_port(sc, x);
+ return(false);
+}
+
+static bool catch_in_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ s7_close_input_port(sc, T_Pri(stack_code(sc->stack, catch_loc))); /* "code" = port that we opened */
+ if (stack_args(sc->stack, catch_loc) != sc->unused)
+ set_current_input_port(sc, stack_args(sc->stack, catch_loc)); /* "args" = port that we shadowed */
+ return(false);
+}
+
+static bool catch_read_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ pop_input_port(sc);
+ return(false);
+}
+
+static bool catch_eval_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ s7_close_input_port(sc, current_input_port(sc));
+ pop_input_port(sc);
+ return(false);
+}
+
+static bool catch_barrier_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{ /* can this happen? is it doing the right thing? read/eval/call_begin_hook push_stack op_barrier but only s7_read includes a port (this is not hit in s7test.scm) */
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ 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);
+ s7_close_input_port(sc, stack_args(sc->stack, catch_loc));
+ }
+ return(false);
+}
+
+static bool catch_error_hook_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, stack_code(sc->stack, catch_loc));
+ /* apparently there was an error during *error-hook* evaluation, but Rick wants the hook re-established anyway */
+ (*reset_hook) = true;
+ /* avoid infinite loop -- don't try to (re-)evaluate (buggy) *error-hook*! */
+ return(false);
+}
+
+static bool catch_goto_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ call_exit_active(stack_args(sc->stack, catch_loc)) = false;
+ return(false);
+}
+
+static bool catch_map_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ sc->map_call_ctr--;
+ 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;}
+ return(false);
+}
+
+static bool op_let_temp_done1(s7_scheme *sc);
+
+static bool catch_let_temporarily_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ /* this is aimed at let-temp error-hook... error -- not yet tested much */
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ if ((!*reset_hook) &&
+ (hook_has_functions(sc->error_hook)))
+ {
+ s7_pointer error_hook_funcs = s7_hook_functions(sc, sc->error_hook);
+
+ let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, sc->nil);
+ let_set_2(sc, closure_let(sc->let_temp_hook), sc->body_symbol, error_hook_funcs);
+ sc->code = sc->let_temp_hook;
+ sc->args = list_2(sc, type, info);
+
+ push_stack_direct(sc, OP_EVAL_DONE);
+ set_curlet(sc, make_let(sc, closure_let(sc->code)));
+ eval(sc, OP_APPLY_LAMBDA);
+
+ let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, error_hook_funcs);
+ let_set_2(sc, closure_let(sc->let_temp_hook), sc->body_symbol, sc->nil);
+
+ sc->args = stack_args(sc->stack, catch_loc);
+ sc->code = stack_code(sc->stack, catch_loc);
+ set_curlet(sc, stack_let(sc->stack, catch_loc));
+
+ 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);
+ }}
+ else let_temp_done(sc, stack_args(sc->stack, catch_loc), T_Let(stack_let(sc->stack, catch_loc)));
+ return(false);
+}
+
+static bool catch_let_temp_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ s7_pointer slot = stack_code(sc->stack, catch_loc);
+ s7_pointer val = stack_args(sc->stack, catch_loc);
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s, unwind setting %s to %s\n", __func__, display_truncated(slot), display_truncated(val));
+ if (is_immutable_slot(slot)) /* we're already in an error/throw situation, so raising an error here leads to an infinite loop */
+ s7_warn(sc, 512, "let-temporarily can't reset %s to %s: it is immutable!", symbol_name(slot_symbol(slot)), display(val));
+ else slot_set_value(slot, val);
+ return(false);
+}
+
+static bool catch_let_temp_s7_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ s7_starlet_set_1(sc, T_Sym(stack_code(sc->stack, catch_loc)), stack_args(sc->stack, catch_loc));
+ return(false);
+}
+
+static bool catch_let_temp_s7_direct_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ sc->has_openlets = (stack_args(sc->stack, catch_loc) != sc->F);
+ return(false);
+}
+
+static bool catch_dynamic_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook)
+{
+ /* if func has an error, s7_error will call it as it unwinds the stack -- an infinite loop. So, cancel the unwind first */
+ if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__);
+ set_stack_op(sc->stack, catch_loc, OP_GC_PROTECT);
+
+ /* we're in an error or throw, so there is no return value to report, but we need to decrement *debug-spaces* (if in debug)
+ * stack_let is the trace-in let at the point of the dynamic_unwind call
+ */
+ if (sc->debug > 0)
+ {
+ 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 */
+ }
+ return(false);
+}
+
+typedef bool (*catch_function_t)(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info, bool *reset_hook);
+static catch_function_t catchers[NUM_OPS];
+
+static void init_catchers(void)
+{
+ for (int32_t i = 0; i < NUM_OPS; i++) catchers[i] = NULL;
+ catchers[OP_CATCH_ALL] = catch_all_function;
+ catchers[OP_CATCH_2] = catch_2_function;
+ catchers[OP_CATCH_1] = catch_1_function;
+ catchers[OP_CATCH] = catch_1_function;
+ catchers[OP_DYNAMIC_WIND] = catch_dynamic_wind_function;
+ catchers[OP_DYNAMIC_UNWIND] = catch_dynamic_unwind_function;
+ catchers[OP_GET_OUTPUT_STRING] = catch_out_function;
+ catchers[OP_UNWIND_OUTPUT] = catch_out_function;
+ catchers[OP_UNWIND_INPUT] = catch_in_function;
+ catchers[OP_READ_DONE] = catch_read_function; /* perhaps an error during (read) */
+ catchers[OP_EVAL_STRING] = catch_eval_function;
+ catchers[OP_BARRIER] = catch_barrier_function;
+ catchers[OP_DEACTIVATE_GOTO] = catch_goto_function;
+ catchers[OP_LET_TEMP_DONE] = catch_let_temporarily_function;
+ catchers[OP_LET_TEMP_UNWIND] = catch_let_temp_unwind_function;
+ catchers[OP_LET_TEMP_S7_UNWIND] = catch_let_temp_s7_unwind_function;
+ catchers[OP_LET_TEMP_S7_DIRECT_UNWIND] = catch_let_temp_s7_direct_unwind_function;
+ catchers[OP_ERROR_HOOK_QUIT] = catch_error_hook_function;
+ catchers[OP_MAP_UNWIND] = catch_map_unwind_function;
+}
+
+/* -------------------------------- throw -------------------------------- */
+static s7_pointer g_throw(s7_scheme *sc, s7_pointer args)
+{
+ #define H_throw "(throw tag . info) is like (error ...) but it does not affect owlet. \
+It looks for an existing catch with a matching tag, and jumps to it if found. Otherwise it raises an error."
+ #define Q_throw s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T)
+
+ bool ignored_flag = false;
+ s7_pointer type = car(args), info = cdr(args);
+ gc_protect_via_stack(sc, args);
+ /* type can be anything: (throw (list 1 2 3) (make-list 512)), sc->w and sc->value not good here for gc protection */
+
+ for (int64_t i = stack_top(sc) - 5; i >= 3; i -= 4) /* look for a catcher */
+ {
+ 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);
+ }}
+ 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));
+ return(sc->F);
+}
+
+
+/* -------------------------------- warn -------------------------------- */
+#if WITH_GCC
+static __attribute__ ((format (printf, 3, 4))) void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...)
+#else
+static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...) /* len = max size of output string (for vsnprintf) */
+#endif
+{
+ if ((current_error_port(sc) != sc->F) && (!sc->muffle_warnings))
+ {
+ int32_t bytes;
+ va_list ap;
+ block_t *b = mallocate(sc, len);
+ char *str = (char *)block_data(b);
+ str[0] = '\0';
+ va_start(ap, ctrl);
+ 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);
+ if ((bytes > 0) && (current_error_port(sc) != sc->F))
+ port_write_string(current_error_port(sc))(sc, str, bytes, current_error_port(sc));
+ liberate(sc, b);
+ }
+}
+
+
+/* -------------------------------- error -------------------------------- */
+static void fill_error_location(s7_scheme *sc)
+{
+ if (((is_input_port(current_input_port(sc))) && (is_loader_port(current_input_port(sc)))) ||
+ (((sc->cur_op >= OP_READ_LIST) && (sc->cur_op <= OP_READ_DONE))))
+ {
+ set_integer(slot_value(sc->error_line), port_line_number(current_input_port(sc)));
+ set_integer(slot_value(sc->error_position), port_position(current_input_port(sc)));
+ slot_set_value(sc->error_file, wrap_string(sc, port_filename(current_input_port(sc)), port_filename_length(current_input_port(sc))));
+ }
+ 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);
+ }
+}
+
+static void format_to_error_port(s7_scheme *sc, const char *str, s7_pointer args, s7_int len)
+{
+ if (current_error_port(sc) != sc->F)
+ format_to_port_1(sc, current_error_port(sc), str, args, NULL, false, true /* is_columnizing(str) */, len, NULL);
+ /* is_columnizing on every call is much slower than ignoring the issue */
+}
+
+static noreturn void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info)
+{
+ bool reset_error_hook = false;
+ s7_pointer cur_code = current_code(sc);
+
+ sc->format_depth = -1;
+ sc->object_out_locked = false; /* possible error in obj->str method after object_out has set this flag */
+ sc->has_openlets = true; /* same problem -- we need a cleaner way to handle this, op_?_unwind */
+ sc->value = info; /* feeble GC protection (otherwise info is sometimes freed in this function), throw also protects type */
+
+ if (sc->current_safe_list > 0)
+ clear_list_in_use(sc->safe_lists[sc->current_safe_list]);
+ slot_set_value(sc->error_type, type);
+ slot_set_value(sc->error_data, info);
+
+ if (unchecked_type(sc->curlet) != T_LET)
+ set_curlet(sc, sc->rootlet); /* in the reader, the sc->curlet stack entry is mostly ignored, so it can be (and usually is) garbage */
+ let_set_outlet(sc->owlet, sc->curlet);
+ slot_set_value(sc->error_code, cur_code); /* if mv here, evalable code has the mv bit set, maybe from c-macro that uses s7_values */
+
+#if WITH_HISTORY
+ slot_set_value(sc->error_history, sc->cur_code);
+ if (sc->cur_code != sc->history_sink)
+ {
+ sc->cur_code = (sc->using_history1) ? sc->eval_history2 : sc->eval_history1;
+ sc->using_history1 = (!sc->using_history1);
+ pair_fill(sc, set_plist_2(sc, sc->cur_code, sc->nil));
+ }
+#endif
+ if (is_pair(cur_code))
+ {
+ 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);
+ }
+ 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;
+ }}
+ if ((line <= 0) || (file < 0))
+ 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]);
+ }}
+ else fill_error_location(sc);
+
+ /* look for a catcher, call catch*function in the error context (before unwinding the stack), outlet(owlet) is curlet */
+ /* top is 1 past actual top, top - 1 is op, if op = OP_CATCH, top - 4 is the cell containing the catch struct */
+ for (int64_t i = stack_top(sc) - 1; i >= 3; i -= 4)
+ {
+ 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);
+ }}
+ /* error not caught (but catcher might have been called and returned false) */
+
+ if ((!reset_error_hook) &&
+ (hook_has_functions(sc->error_hook)))
+ {
+ s7_pointer error_hook_funcs = s7_hook_functions(sc, sc->error_hook);
+ /* (set! (hook-functions *error-hook*) (list (lambda (h) (format *stderr* "got error ~A~%" (h 'data))))) */
+ let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, sc->nil);
+ let_set_2(sc, closure_let(sc->let_temp_hook), sc->body_symbol, error_hook_funcs);
+ /* if the *error-hook* functions trigger an error, we had better not have hook_functions(*error-hook*) still set! */
+
+ /* here we have no catcher (anywhere!), we're headed back to the top-level(?), so error_hook_quit can call reset_stack? */
+ push_stack(sc, OP_ERROR_HOOK_QUIT, sc->nil, error_hook_funcs); /* restore *error-hook* upon successful (or any!) evaluation */
+ sc->code = sc->let_temp_hook;
+ sc->args = list_2(sc, type, info);
+ /* if we drop into the longjmp below, the hook functions are not called!
+ * OP_ERROR_HOOK_QUIT performs the longjmp, so it should be safe to go to eval.
+ */
+ set_curlet(sc, make_let(sc, closure_let(sc->code)));
+ eval(sc, OP_APPLY_LAMBDA);
+ /* we'll longjmp below -- is that really what we want? */
+ }
+ else
+ {
+ s7_int op = sc->print_length;
+ 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);
+ /* 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);
+ 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 */
+ }
+ 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);
+ }
+ 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));
+ }
+ /* 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));
+ }}
+ 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_continuation(type))
+ * go into repl here with access to continuation? Or expect *error-handler* to deal with it?
+ */
+ sc->value = type;
+ sc->cur_op = OP_ERROR_QUIT;
+ }
+ LongJmp(*(sc->goto_start), ERROR_JUMP);
+}
+
+s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info) /* s7.h backwards compatibility */
+{
+ error_nr(sc, type, info);
+ /* info is a temporary value -- do not expect it to be useful beyond the error handler procedure itself */
+ return(type);
+}
+
+static noreturn void read_error_1_nr(s7_scheme *sc, const char *errmsg, bool string_error)
+{
+ /* read errors happen before the evaluator gets involved, so forms such as:
+ * (catch #t (lambda () (car '( . ))) (lambda arg 'error))
+ * do not catch the error if we simply signal an error when we encounter it.
+ */
+ s7_pointer pt = current_input_port(sc);
+
+ if (!string_error)
+ {
+ /* 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));
+ }}}
+
+ if ((port_line_number(pt) > 0) &&
+ (port_filename(pt)))
+ {
+ s7_int nlen = 0;
+ s7_int len = safe_strlen(errmsg) + port_filename_length(pt) + safe_strlen(sc->current_file) + 128;
+ 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);
+ 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);
+ 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)));
+}
+
+static noreturn void read_error_nr(s7_scheme *sc, const char *errmsg) {read_error_1_nr(sc, errmsg, false);}
+static noreturn void string_read_error_nr(s7_scheme *sc, const char *errmsg) {read_error_1_nr(sc, errmsg, true);}
+
+static s7_pointer g_error(s7_scheme *sc, s7_pointer args)
+{
+ #define H_error "(error type ...) signals an error. The 'type' can be used with catch to trap \
+particular errors. If the error is not caught, s7 treats the second argument as a format control string, \
+and applies it to the rest of the arguments."
+ #define Q_error s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T)
+
+ if (is_string(car(args))) /* a CL-style error -- use tag='no-catch */
+ error_nr(sc, make_symbol(sc, "no-catch", 8), args);
+ error_nr(sc, car(args), cdr(args));
+ return(sc->unspecified);
+}
+
+static char *truncate_string(char *form, s7_int len, use_write_t use_write)
+{
+ uint8_t *f = (uint8_t *)form;
+ s7_int i;
+ if (use_write != P_DISPLAY)
+ {
+ /* 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);
+ 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';
+ }}
+ 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);
+ }
+ i = len - 4;
+ if (i >= 0) {form[i] = '.'; form[i + 1] = '.'; form[i + 2] = '.'; form[i + 3] = '\0';}
+ else form[len] = '\0';
+ }
+ return(form);
+}
+
+static s7_pointer object_to_string_truncated(s7_scheme *sc, s7_pointer p)
+{
+ s7_pointer strp;
+ s7_int len = sc->print_length;
+ s7_int old_max_len = sc->objstr_max_len;
+ sc->objstr_max_len = len + 2;
+ strp = s7_object_to_string(sc, p, false);
+ sc->objstr_max_len = old_max_len;
+ if (string_length(strp) > len)
+ truncate_string(string_value(strp), len, P_DISPLAY); /* only use of truncate_string */
+ return(strp);
+}
+
+static s7_pointer tree_descend(s7_scheme *sc, s7_pointer p, uint32_t line)
+{
+ s7_pointer tp;
+ if (!is_pair(p)) return(NULL);
+ if (has_location(p))
+ {
+ 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);
+ }}
+ tp = tree_descend(sc, car(p), line);
+ return((tp) ? tp : tree_descend(sc, cdr(p), line));
+}
+
+static noreturn void missing_close_paren_error_nr(s7_scheme *sc)
+{
+ char *syntax_msg = NULL;
+ s7_pointer pt = current_input_port(sc);
+
+ if (unchecked_type(sc->curlet) != T_LET)
+ set_curlet(sc, sc->rootlet);
+
+ /* check *missing-close-paren-hook* */
+ if (hook_has_functions(sc->missing_close_paren_hook))
+ {
+ 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)));
+ }
+ result = s7_call(sc, sc->missing_close_paren_hook, sc->nil);
+ if (result != sc->unspecified)
+ 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);
+ }}
+
+ if ((port_line_number(pt) > 0) &&
+ (port_filename(pt)))
+ {
+ s7_int nlen;
+ s7_int len = port_filename_length(pt) + safe_strlen(sc->current_file) + safe_strlen(syntax_msg) + 128;
+ 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);
+ }
+ 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);
+ string_length(p) = nlen;
+ error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p));
+ }
+
+ if (syntax_msg)
+ {
+ s7_int len = safe_strlen(syntax_msg) + 128;
+ s7_pointer p = make_empty_string(sc, len, '\0');
+ char *msg = string_value(p);
+ len = catstrs(msg, len, "missing close paren\n", syntax_msg, "\n", (char *)NULL);
+ free(syntax_msg);
+ string_length(p) = len;
+ error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p));
+ }
+ if ((is_input_port(pt)) &&
+ (!port_is_closed(pt)) &&
+ (port_data(pt)) &&
+ (port_position(pt) > 0))
+ {
+ s7_pointer p = make_empty_string(sc, 128, '\0');
+ s7_int pos = port_position(pt);
+ s7_int start = pos - 40;
+ char *msg = string_value(p);
+ memcpy((void *)msg, (const void *)"missing close paren: ", 21);
+ if (start < 0) start = 0;
+ memcpy((void *)(msg + 21), (void *)(port_data(pt) + start), pos - start);
+ string_length(p) = 21 + pos - start;
+ error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p));
+ }
+ error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "missing close paren", 19)));
+}
+
+static noreturn void improper_arglist_error_nr(s7_scheme *sc)
+{
+ /* sc->code is the last (dotted) arg, sc->args is the arglist reversed not including sc->code
+ * the original was `(func ,@(reverse args) . ,code) essentially where func is sc->value or pop_op_stack(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));
+ 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));
+}
+
+static void op_error_hook_quit(s7_scheme *sc)
+{
+ let_set_2(sc, closure_let(sc->error_hook), sc->body_symbol, sc->code); /* restore old value */
+ let_set_2(sc, closure_let(sc->let_temp_hook), sc->body_symbol, sc->nil);
+ /* now mimic the end of the normal error handler. Since this error hook evaluation can happen
+ * in an arbitrary s7_call nesting, we can't just return from the current evaluation --
+ * we have to jump to the original (top-level) call. Otherwise '#<unspecified> or whatever
+ * is simply treated as the (non-error) return value, and the higher level evaluations
+ * get confused.
+ */
+ stack_reset(sc); /* is this necessary? is it a good idea?? */
+ push_stack_op(sc, OP_ERROR_QUIT); /* added 3-Dec-16: try to make sure we actually exit! */
+ sc->cur_op = OP_ERROR_QUIT;
+ if (sc->longjmp_ok)
+ LongJmp(*(sc->goto_start), ERROR_QUIT_JUMP);
+}
+
+
+/* -------------------------------- begin_hook -------------------------------- */
+void (*s7_begin_hook(s7_scheme *sc))(s7_scheme *sc, bool *val) {return(sc->begin_hook);}
+
+void s7_set_begin_hook(s7_scheme *sc, void (*hook)(s7_scheme *sc, bool *val))
+{
+ sc->begin_hook = hook;
+ sc->begin_op = (hook) ? OP_BEGIN_HOOK : OP_BEGIN_NO_HOOK;
+}
+
+static bool call_begin_hook(s7_scheme *sc)
+{
+ bool result = false;
+ /* originally begin_hook was bool (*hook)(s7_scheme *sc): the value was returned directly,
+ * rather than going through a *bool arg (&result below). That works in gcc (Linux/OSX),
+ * but does not work in MS Visual C++. In the latter, the compiler apparently completely
+ * eliminates any local, returning (for example) a thread-relative stack-allocated value
+ * directly, but then by the time we get here, that variable has vanished, and we get
+ * garbage. We had to thwart the optimization by adding if ((flag) && (!flag)) fprintf(...);
+ * So, in the new form (26-Jun-13), the value is passed directly into an s7 variable
+ * that I hope can't be optimized out of existence.
+ *
+ * cm/src/Scheme.cpp, used in Snd (listener looking for C-g I think)
+ * originally this facility was aimed at interrupting infinite loops, and the expected usage was:
+ * set begin_hook, eval-string(...), unset begin_hook
+ */
+ opcode_t op = sc->cur_op;
+ push_stack_direct(sc, OP_BARRIER);
+ sc->begin_hook(sc, &result);
+ if (result)
+ {
+ s7_pointer cur_code = current_code(sc);
+ /* set (owlet) in case we were interrupted and need to see why something was hung */
+ slot_set_value(sc->error_type, sc->F);
+ 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));
+ }
+ 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);
+ }
+#if WITH_HISTORY
+ slot_set_value(sc->error_history, sc->F);
+#endif
+ let_set_outlet(sc->owlet, sc->curlet);
+ sc->value = make_symbol(sc, "begin-hook-interrupt", 20);
+ /* otherwise the evaluator returns whatever random thing is in sc->value (normally #<closure>)
+ * which makes debugging unnecessarily difficult. ?? why not return something useful? make return s7_pointer*, not bool*
+ */
+ s7_quit(sc); /* don't call gc here -- eval_c_string is the context -- allows interrupt of infinite loop */
+ return(true);
+ }
+ pop_stack_no_op(sc);
+ sc->cur_op = op; /* for better error handling. otherwise we get "barrier" as the offending function name in syntax_error */
+ return(false);
+}
+
+
+/* -------------------------------- apply -------------------------------- */
+static s7_pointer apply_list_star(s7_scheme *sc, s7_pointer d)
+{
+ /* we check this ahead of time: if (is_null(cdr(d))) return(car(d)); */
+ s7_pointer p;
+ gc_protect_via_stack(sc, d);
+ p = cons(sc, car(d), cdr(d));
+ sc->w = p;
+ while (is_not_null(cddr(p)))
+ {
+ d = cdr(d);
+ set_cdr(p, cons(sc, car(d), cdr(d)));
+ if (is_not_null(cdr(d)))
+ p = cdr(p);
+ }
+ unstack_gc_protect(sc);
+ set_cdr(p, cadr(p));
+ return(sc->w);
+}
+
+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));
+}
+
+static s7_pointer g_apply(s7_scheme *sc, s7_pointer args)
+{
+ #define H_apply "(apply func ...) applies func to the rest of the arguments"
+ #define Q_apply s7_make_circular_signature(sc, 2, 3, sc->values_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_sequence_symbol), sc->T)
+
+ /* can apply always be replaced with apply values? (apply + '(1 2 3)) is the same as (+ (apply values '(1 2 3)))
+ * not if apply* in disguise, I think: (apply + 1 2 ()) -> 3, (apply + 1 2 (apply values ())) -> error
+ */
+ s7_pointer func = car(args);
+ if (!is_applicable(func))
+ apply_error_nr(sc, func, cdr(args));
+
+ if (is_null(cdr(args)))
+ {
+ push_stack(sc, OP_APPLY, sc->nil, func);
+ return(sc->nil);
+ }
+ if (is_safe_procedure(func))
+ {
+ s7_pointer p, q;
+ for (q = args, p = cdr(args); is_not_null(cdr(p)); q = p, p = cdr(p));
+ /* 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);
+ 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)));
+ }
+ push_stack(sc, OP_APPLY, cdr(args), func);
+ return(sc->nil);
+ }
+ sc->code = func;
+ sc->args = (is_null(cddr(args))) ? cadr(args) : apply_list_star(sc, cdr(args));
+ if (!s7_is_proper_list(sc, sc->args))
+ apply_list_error_nr(sc, sc->args);
+
+ /* (define imp (immutable! (cons 0 (immutable! (cons 1 (immutable! (cons 2 ())))))))
+ * (define (fop4 x y) (apply x y))
+ * (display (object->string (apply (lambda (a . b) (cons a b)) imp) :readable)) -> (list 0 1 2)
+ * (display (object->string (fop4 (lambda (a . b) (cons a b)) imp) :readable)) -> (cons 0 (immutable! (cons 1 (immutable! (cons 2 ())
+ * g_apply sees the first one and thinks the lambda arg is unsafe, apply_ss sees the second and thinks it is safe (hence the list is not copied),
+ * so calling sort on the first is fine, but on the second gets an immutable object error.
+ */
+ sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, sc->args) : sc->args;
+ push_stack_direct(sc, OP_APPLY);
+ return(sc->nil);
+}
+
+s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args)
+{
+ TRACK(sc);
+ if (is_c_function(fnc))
+ return(c_function_call(fnc)(sc, args));
+ /* if [if (!is_applicable(fnc)) apply_error_nr(sc, fnc, sc->args);] here, needs_copied_args can be T_App */
+ push_stack_direct(sc, OP_EVAL_DONE);
+ sc->code = fnc;
+ sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args;
+ eval(sc, OP_APPLY);
+ /* we're limited in choices here -- the caller might be (say) car(sc->t1_1) = fn_proc(...) where the fn_proc
+ * happens to fallback on a method -- we can't just push OP_APPLY and drop back into the evaluator normally.
+ */
+ return(sc->value);
+}
+
+static s7_pointer apply_method_closure(s7_scheme *sc, s7_pointer func, s7_pointer args)
+{
+ push_stack_direct(sc, OP_EVAL_DONE);
+ sc->code = func;
+ sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args;
+ set_curlet(sc, make_let(sc, closure_let(sc->code)));
+ eval(sc, OP_APPLY_LAMBDA);
+ return(sc->value);
+}
+
+static s7_pointer apply_c_function_unopt(s7_scheme *sc, s7_pointer func, s7_pointer args);
+
+static s7_pointer implicit_index_checked(s7_scheme *sc, s7_pointer obj, s7_pointer in_obj, s7_pointer indices)
+{
+ 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));
+ return(implicit_index(sc, in_obj, cdr(indices)));
+}
+
+static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices)
+{
+ /* (let ((lst '("12" "34"))) (lst 0 1)) -> #\2
+ * (let ((lst (list #(1 2) #(3 4)))) (lst 0 1)) -> 2
+ * this can get tricky: ((list (lambda (a) (+ a 1)) (lambda (b) (* b 2))) 1 2) -> 4
+ * but what if func takes rest/optional args, etc: ((list (lambda args (car args))) 0 "hi" 0)
+ * should this return #\h or "hi"?? currently it is "hi" which is consistent with ((lambda args (car args)) "hi" 0)
+ * but ((lambda (arg) arg) "hi" 0) is currently an error (too many arguments)
+ * maybe it should be (((lambda (arg) arg) "hi") 0) -> #\h
+ */
+ s7_pointer res, in_obj;
+ switch (type(obj))
+ {
+ case T_VECTOR: /* (#(#(1 2) #(3 4)) 1 1) -> 4 */
+ return(vector_ref_1(sc, obj, indices));
+
+ case T_FLOAT_VECTOR:
+ res = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->float_vector_ref_symbol, T_FLOAT_VECTOR);
+ set_car(sc->u1_1, sc->F);
+ return(res);
+
+ case T_INT_VECTOR:
+ res = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->int_vector_ref_symbol, T_INT_VECTOR);
+ set_car(sc->u1_1, sc->F);
+ return(res);
+
+ case T_BYTE_VECTOR:
+ res = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->byte_vector_ref_symbol, T_BYTE_VECTOR);
+ set_car(sc->u1_1, sc->F);
+ return(res);
+
+ 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));
+ if (!is_t_integer(car(indices)))
+ 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(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(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(in_obj);
+
+ case T_C_OBJECT:
+ res = (*(c_object_ref(sc, obj)))(sc, set_ulist_1(sc, obj, indices));
+ set_car(sc->u1_1, sc->F);
+ return(res);
+
+ case T_ITERATOR: /* indices is not nil, so this is an error */
+ error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, obj, indices));
+
+ 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));
+ 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);
+ sc->temp10 = sc->unused;
+ if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "mv: %s %s %s\n", display(obj), display(indices), display(sc->value));
+ /* if mv: sc->value = splice_in_values(sc, multiple_value(sc->value)); */
+ return(sc->value);
+
+ case T_C_FUNCTION:
+ return(apply_c_function_unopt(sc, obj, indices));
+
+ case T_C_RST_NO_REQ_FUNCTION:
+ return(c_function_call(obj)(sc, indices));
+
+ default:
+ if (!is_applicable(obj)) /* (#2d((0 0)(0 0)) 0 0 0) */
+ 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));
+ return(sc->value);
+ }
+}
+
+static inline void fill_star_defaults(s7_scheme *sc, s7_pointer func, int32_t start_arg, int32_t n_args, s7_pointer par)
+{
+ s7_pointer *df = c_function_arg_defaults(func);
+ if (c_func_has_simple_defaults(func))
+ for (int32_t i = start_arg; i < n_args; i++, par = cdr(par))
+ set_car(par, df[i]);
+ 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);
+ }
+}
+
+static s7_pointer set_c_function_star_args(s7_scheme *sc)
+{
+ int32_t i, j;
+ s7_pointer arg, par, call_args, func = sc->code;
+ s7_pointer *df;
+ int32_t n_args = c_function_max_args(func); /* not counting keywords, I think */
+
+ if (is_safe_procedure(func))
+ call_args = c_function_call_args(func);
+ else
+ {
+ call_args = make_list(sc, c_function_optional_args(func), sc->F);
+ gc_protect_via_stack(sc, call_args);
+ }
+
+ /* assume at the start that there are no keywords */
+ for (i = 0, arg = sc->args, par = call_args; (i < n_args) && (is_pair(arg)); i++, arg = cdr(arg), par = cdr(par))
+ if (!is_symbol_and_keyword(car(arg)))
+ 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);
+ }
+ 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));
+ }
+ if (i < n_args)
+ fill_star_defaults(sc, func, i, n_args, par);
+ if (!is_safe_procedure(func)) unstack_gc_protect(sc);
+ return(call_args);
+}
+
+static s7_pointer set_c_function_star_defaults(s7_scheme *sc, int32_t num)
+{
+ s7_pointer call_args, func = sc->code, par;
+ int32_t n_args = c_function_max_args(func);
+
+ if (is_safe_procedure(func))
+ call_args = c_function_call_args(func);
+ else
+ {
+ call_args = make_list(sc, c_function_optional_args(func), sc->F);
+ gc_protect_via_stack(sc, call_args);
+ }
+ par = call_args;
+ if (num == 1)
+ {
+ set_car(par, car(sc->args));
+ par = cdr(par);
+ }
+ fill_star_defaults(sc, func, num, n_args, par);
+ if (!is_safe_procedure(func)) unstack_gc_protect(sc);
+ return(call_args);
+}
+
+#define apply_c_function_star(Sc) Sc->value = c_function_call(Sc->code)(Sc, set_c_function_star_args(Sc))
+#define apply_c_function_star_fill_defaults(Sc, Num) Sc->value = c_function_call(Sc->code)(Sc, set_c_function_star_defaults(Sc, Num))
+
+s7_pointer s7_apply_function_star(s7_scheme *sc, s7_pointer fnc, s7_pointer args)
+{
+ TRACK(sc);
+ if (is_c_function_star(fnc))
+ {
+ sc->w = sc->args;
+ sc->z = sc->code;
+ sc->args = T_Ext(args);
+ sc->code = fnc;
+ apply_c_function_star(sc);
+ sc->args = sc->w;
+ sc->code = sc->z;
+ return(sc->value);
+ }
+ push_stack_direct(sc, OP_EVAL_DONE);
+ sc->code = fnc;
+ sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, args) : args;
+ eval(sc, OP_APPLY);
+ return(sc->value);
+}
+
+/* -------------------------------- eval -------------------------------- */
+s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e)
+{
+ declare_jump_info();
+ TRACK(sc);
+ 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);
+ 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);
+ }
+ 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);
+ }
+ else
+ {
+ push_stack_direct(sc, OP_EVAL_DONE);
+ sc->code = code;
+ set_curlet(sc, (is_let(e)) ? e : sc->rootlet);
+ eval(sc, OP_EVAL);
+ }
+ restore_jump_info(sc);
+
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+ return(sc->value);
+}
+
+s7_pointer s7_eval_with_location(s7_scheme *sc, s7_pointer code, s7_pointer e, const char *caller, const char *file, s7_int line)
+{
+ s7_pointer result;
+ if (caller)
+ {
+ sc->s7_call_name = caller;
+ sc->s7_call_file = file;
+ sc->s7_call_line = line;
+ }
+ result = s7_eval(sc, code, (e == sc->nil) ? sc->rootlet : e);
+ if (caller)
+ {
+ sc->s7_call_name = NULL;
+ sc->s7_call_file = NULL;
+ sc->s7_call_line = -1;
+ }
+ return(result);
+}
+
+static s7_pointer g_eval(s7_scheme *sc, s7_pointer args)
+{
+ #define H_eval "(eval code (let (curlet))) evaluates code in the environment let. 'let' \
+defaults to the curlet; to evaluate something in the top-level environment instead, \
+pass (rootlet):\n\
+\n\
+ (define x 32) \n\
+ (let ((x 3))\n\
+ (eval 'x (rootlet)))\n\
+\n\
+ returns 32"
+ #define Q_eval s7_make_signature(sc, 3, sc->values_symbol, sc->T, sc->is_let_symbol)
+
+ if (is_not_null(cdr(args)))
+ {
+ s7_pointer e = cadr(args);
+ if (!is_let(e))
+ wrong_type_error_nr(sc, sc->eval_symbol, 2, e, a_let_string);
+ set_curlet(sc, e);
+ }
+ sc->code = car(args);
+
+ if ((sc->safety > NO_SAFETY) &&
+ (is_pair(sc->code)))
+ {
+ check_free_heap_size(sc, 8192);
+ sc->code = copy_body(sc, sc->code);
+ }
+ else
+ if (is_optimized(sc->code))
+ clear_all_optimizations(sc, sc->code); /* clears "unsafe" ops, not all ops */
+
+ set_current_code(sc, sc->code);
+ if (stack_top(sc) < 12)
+ push_stack_op(sc, OP_BARRIER);
+ push_stack_direct(sc, OP_EVAL);
+ return(sc->nil);
+}
+
+
+s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args)
+{
+ if (is_c_function(func))
+ return(c_function_call(func)(sc, args)); /* no check for wrong-number-of-args -- is that reasonable? maybe use apply_c_function(sc, func, args) */
+ {
+ declare_jump_info();
+ TRACK(sc);
+ set_current_code(sc, history_cons(sc, func, args));
+ if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, "%s: %s %s\n", __func__, display_truncated(func), display_truncated(args)));
+
+ sc->temp4 = T_App(func); /* this is feeble GC protection */
+ sc->temp2 = T_Lst(args); /* only use of temp2 */
+
+ store_jump_info(sc);
+ 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 == 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);
+ }
+ 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 */
+ return(sc->value);
+ }
+}
+
+s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args, const char *caller, const char *file, s7_int line)
+{
+ s7_pointer result;
+ if (caller)
+ {
+ sc->s7_call_name = caller;
+ sc->s7_call_file = file;
+ sc->s7_call_line = line;
+ }
+ result = s7_call(sc, func, args);
+ if (caller)
+ {
+ sc->s7_call_name = NULL;
+ sc->s7_call_file = NULL;
+ sc->s7_call_line = -1;
+ }
+ return(result);
+}
+
+
+/* -------------------------------- type-of -------------------------------- */
+#if (!WITH_GCC)
+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)));
+}
+#else
+#define gen_type_match(Sc, Val, Typ) \
+ ({s7_pointer _val_ = Val; \
+ ((type(_val_) == Typ) || \
+ ((has_active_methods(Sc, _val_)) && \
+ (apply_boolean_method(Sc, _val_, Sc->type_to_typers[Typ]) != Sc->F)));})
+#endif
+
+static void init_typers(s7_scheme *sc)
+{
+ sc->type_to_typers[T_FREE] = sc->F;
+ sc->type_to_typers[T_PAIR] = sc->is_pair_symbol;
+ sc->type_to_typers[T_NIL] = sc->is_null_symbol;
+ sc->type_to_typers[T_UNUSED] = sc->F;
+ sc->type_to_typers[T_EOF] = sc->is_eof_object_symbol;
+ sc->type_to_typers[T_UNDEFINED] = sc->is_undefined_symbol;
+ sc->type_to_typers[T_UNSPECIFIED] = sc->is_unspecified_symbol;
+ sc->type_to_typers[T_BOOLEAN] = sc->is_boolean_symbol;
+ sc->type_to_typers[T_CHARACTER] = sc->is_char_symbol;
+ sc->type_to_typers[T_SYMBOL] = sc->is_symbol_symbol; /* and keyword? */
+ sc->type_to_typers[T_SYNTAX] = sc->is_syntax_symbol;
+ sc->type_to_typers[T_INTEGER] = sc->is_integer_symbol;
+ sc->type_to_typers[T_RATIO] = sc->is_rational_symbol;
+ sc->type_to_typers[T_REAL] = sc->is_float_symbol;
+ sc->type_to_typers[T_COMPLEX] = sc->is_complex_symbol;
+ sc->type_to_typers[T_BIG_INTEGER] = sc->is_integer_symbol;
+ sc->type_to_typers[T_BIG_RATIO] = sc->is_rational_symbol;
+ sc->type_to_typers[T_BIG_REAL] = sc->is_float_symbol;
+ sc->type_to_typers[T_BIG_COMPLEX] = sc->is_complex_symbol;
+ sc->type_to_typers[T_STRING] = sc->is_string_symbol;
+ sc->type_to_typers[T_BYTE_VECTOR] = sc->is_byte_vector_symbol;
+ sc->type_to_typers[T_C_OBJECT] = sc->is_c_object_symbol;
+ sc->type_to_typers[T_VECTOR] = sc->is_vector_symbol;
+ sc->type_to_typers[T_INT_VECTOR] = sc->is_int_vector_symbol;
+ sc->type_to_typers[T_FLOAT_VECTOR] = sc->is_float_vector_symbol;
+ sc->type_to_typers[T_CATCH] = sc->F;
+ sc->type_to_typers[T_DYNAMIC_WIND] = sc->F;
+ sc->type_to_typers[T_HASH_TABLE] = sc->is_hash_table_symbol;
+ sc->type_to_typers[T_LET] = sc->is_let_symbol;
+ sc->type_to_typers[T_ITERATOR] = sc->is_iterator_symbol;
+ sc->type_to_typers[T_STACK] = sc->F;
+ sc->type_to_typers[T_COUNTER] = sc->F;
+ sc->type_to_typers[T_SLOT] = sc->F;
+ sc->type_to_typers[T_C_POINTER] = sc->is_c_pointer_symbol;
+ sc->type_to_typers[T_OUTPUT_PORT] = sc->is_output_port_symbol;
+ sc->type_to_typers[T_INPUT_PORT] = sc->is_input_port_symbol;
+ sc->type_to_typers[T_RANDOM_STATE] = sc->is_random_state_symbol;
+ sc->type_to_typers[T_GOTO] = sc->is_goto_symbol;
+ sc->type_to_typers[T_CONTINUATION] = sc->is_continuation_symbol;
+ sc->type_to_typers[T_CLOSURE] = sc->is_procedure_symbol;
+ sc->type_to_typers[T_CLOSURE_STAR] = sc->is_procedure_symbol;
+ sc->type_to_typers[T_C_MACRO] = sc->is_macro_symbol;
+ sc->type_to_typers[T_MACRO] = sc->is_macro_symbol;
+ sc->type_to_typers[T_MACRO_STAR] = sc->is_macro_symbol;
+ sc->type_to_typers[T_BACRO] = sc->is_macro_symbol;
+ sc->type_to_typers[T_BACRO_STAR] = sc->is_macro_symbol;
+ sc->type_to_typers[T_C_FUNCTION] = sc->is_procedure_symbol;
+ sc->type_to_typers[T_C_FUNCTION_STAR] = sc->is_procedure_symbol;
+ sc->type_to_typers[T_C_RST_NO_REQ_FUNCTION] = sc->is_procedure_symbol;
+}
+
+s7_pointer s7_type_of(s7_scheme *sc, s7_pointer arg) {return(sc->type_to_typers[type(arg)]);}
+
+static s7_pointer g_type_of(s7_scheme *sc, s7_pointer args)
+{
+ #define H_type_of "(type-of obj) returns a symbol describing obj's type: (type-of 1): 'integer?"
+ #define Q_type_of s7_make_signature(sc, 2, s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->not_symbol), sc->T)
+ return(sc->type_to_typers[type(car(args))]);
+}
+
+
+/* -------------------------------- exit emergency-exit -------------------------------- */
+void s7_quit(s7_scheme *sc)
+{
+ sc->longjmp_ok = false;
+ pop_input_port(sc);
+ stack_reset(sc);
+ push_stack_op_let(sc, OP_EVAL_DONE);
+}
+
+#ifndef EXIT_SUCCESS
+ #define EXIT_SUCCESS 0
+ #define EXIT_FAILURE 1
+#endif
+
+static s7_pointer g_emergency_exit(s7_scheme *sc, s7_pointer args)
+{
+ #define H_emergency_exit "(emergency-exit (obj #t)) exits s7 immediately. 'obj', the value passed to libc's _exit, can be an integer or #t=success (0) or #f=fail (1)."
+ #define Q_emergency_exit s7_make_signature(sc, 2, sc->T, sc->T)
+
+ s7_pointer obj;
+ if (is_null(args)) _exit(EXIT_SUCCESS); /* r7rs spec says use _exit here (which does not call any functions registered with atexit or on_exit */
+ obj = car(args);
+ if (obj == sc->F) _exit(EXIT_FAILURE);
+ if ((obj == sc->T) || (!s7_is_integer(obj))) _exit(EXIT_SUCCESS);
+ _exit((int)s7_integer_clamped_if_gmp(sc, obj));
+ return(sc->F);
+}
+
+static s7_pointer g_exit(s7_scheme *sc, s7_pointer args)
+{
+ #define H_exit "(exit obj) exits s7. 'obj', the value passed to libc's exit, can be an integer or #t=success (0) or #f=fail (1)."
+ #define Q_exit s7_make_signature(sc, 2, sc->T, sc->T)
+ /* calling s7_eval_c_string in an atexit function seems to be problematic -- it works, but args can be changed? */
+
+ s7_pointer obj;
+ /* r7rs.pdf says exit checks the stack for dynamic-winds and runs the "after" functions, if any --
+ * this strikes me as ridiculous -- surely they don't expect me to find all the stacks (other s7's running etc)
+ * and search them for dynamic-winds? The exit must happen in either the init or body sections -- how can we
+ * guarantee the quit function makes sense if even the init hasn't run to completion yet? Anyone who calls exit
+ * should clean up resources themselves. Anyway, scheme's exit is also supposed to allow atexit functions
+ * to be called, so we need to use libc's exit, not _exit -- there's an example C program at the end of s7test.scm.
+ */
+ 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_quit(sc);
+
+ if (show_gc_stats(sc))
+ s7_warn(sc, 256, "gc calls %" ld64 " total time: %f\n", sc->gc_calls, (double)(sc->gc_total_time) / ticks_per_second());
+
+ if (is_null(args)) exit(EXIT_SUCCESS); /* allow atexit functions etc */
+ obj = car(args);
+ if (obj == sc->F) exit(EXIT_FAILURE);
+ if ((obj == sc->T) || (!s7_is_integer(obj))) exit(EXIT_SUCCESS);
+ exit((int)s7_integer_clamped_if_gmp(sc, obj));
+ return(sc->F); /* never reached? */
+}
+
+#if WITH_GCC
+static s7_pointer g_abort(s7_scheme *sc, s7_pointer args) {abort(); return(NULL);}
+#endif
+
+
+/* -------------------------------- optimizer stuff -------------------------------- */
+/* There is a problem with cache misses: a bigger cache reduces one test from 24 seconds to 17 (cachegrind agrees).
+ * But how to optimize s7 for cache hits? The culprits are eval and gc. Looking at the numbers,
+ * I think the least affected tests are able to use opt_info optimization which makes everything local?
+ */
+
+#if S7_DEBUGGING
+static void check_t_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var)
+{
+ 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);
+ if (sc->stop_at_error) abort();
+ }
+}
+
+static s7_pointer t_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
+{
+ check_t_1(sc, sc->curlet, func, expr, symbol);
+ return(slot_value(let_slots(sc->curlet)));
+}
+
+static s7_pointer T_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
+{
+ check_t_1(sc, let_outlet(sc->curlet), func, expr, symbol);
+ return(slot_value(let_slots(let_outlet(sc->curlet))));
+}
+
+static void check_u_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var)
+{
+ 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);
+ if (sc->stop_at_error) abort();
+ }
+}
+
+static s7_pointer u_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
+{
+ check_u_1(sc, sc->curlet, func, expr, symbol);
+ return(slot_value(next_slot(let_slots(sc->curlet))));
+}
+
+static s7_pointer U_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
+{
+ check_u_1(sc, let_outlet(sc->curlet), func, expr, symbol);
+ return(slot_value(next_slot(let_slots(let_outlet(sc->curlet)))));
+}
+
+static void check_v_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var)
+{
+ 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);
+ if (sc->stop_at_error) abort();
+ }
+}
+
+static s7_pointer v_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
+{
+ check_v_1(sc, sc->curlet, func, expr, symbol);
+ return(slot_value(next_slot(next_slot(let_slots(sc->curlet)))));
+}
+
+static s7_pointer V_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
+{
+ check_v_1(sc, let_outlet(sc->curlet), func, expr, symbol);
+ return(slot_value(next_slot(next_slot(let_slots(let_outlet(sc->curlet))))));
+}
+
+static void check_o_1(s7_scheme *sc, s7_pointer e, const char* func, s7_pointer expr, s7_pointer var)
+{
+ s7_pointer slot = s7_slot(sc, var);
+ 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);
+ if (sc->stop_at_error) abort();
+ }
+}
+
+static s7_pointer o_lookup_1(s7_scheme *sc, s7_pointer symbol, const char *func, s7_pointer expr)
+{
+ check_o_1(sc, let_outlet(sc->curlet), func, expr, symbol);
+ return(inline_lookup_from(sc, symbol, let_outlet(sc->curlet)));
+}
+
+#define t_lookup(Sc, Symbol, Expr) t_lookup_1(Sc, Symbol, __func__, Expr)
+#define u_lookup(Sc, Symbol, Expr) u_lookup_1(Sc, Symbol, __func__, Expr)
+#define v_lookup(Sc, Symbol, Expr) v_lookup_1(Sc, Symbol, __func__, Expr)
+#define T_lookup(Sc, Symbol, Expr) T_lookup_1(Sc, Symbol, __func__, Expr)
+#define U_lookup(Sc, Symbol, Expr) U_lookup_1(Sc, Symbol, __func__, Expr)
+#define V_lookup(Sc, Symbol, Expr) V_lookup_1(Sc, Symbol, __func__, Expr)
+#define o_lookup(Sc, Symbol, Expr) o_lookup_1(Sc, Symbol, __func__, Expr)
+#else
+#define t_lookup(Sc, Symbol, Expr) slot_value(let_slots(sc->curlet))
+#define u_lookup(Sc, Symbol, Expr) slot_value(next_slot(let_slots(sc->curlet)))
+#define v_lookup(Sc, Symbol, Expr) slot_value(next_slot(next_slot(let_slots(sc->curlet))))
+#define T_lookup(Sc, Symbol, Expr) slot_value(let_slots(let_outlet(sc->curlet)))
+#define U_lookup(Sc, Symbol, Expr) slot_value(next_slot(let_slots(let_outlet(sc->curlet))))
+#define V_lookup(Sc, Symbol, Expr) slot_value(next_slot(next_slot(let_slots(let_outlet(sc->curlet)))))
+#define o_lookup(Sc, Symbol, Expr) inline_lookup_from(Sc, Symbol, let_outlet(Sc->curlet))
+#endif
+
+#define s_lookup(Sc, Sym, Expr) lookup(Sc, Sym)
+#define g_lookup(Sc, Sym, Expr) lookup_global(Sc, Sym)
+
+/* arg here is the full expression */
+static s7_pointer fx_c(s7_scheme *sc, s7_pointer arg) {return(arg);}
+static s7_pointer fx_q(s7_scheme *sc, s7_pointer arg) {return(cadr(arg));}
+static s7_pointer fx_unsafe_s(s7_scheme *sc, s7_pointer arg) {return(lookup_checked(sc, T_Sym(arg)));}
+
+static s7_pointer fx_s(s7_scheme *sc, s7_pointer arg) {return(lookup(sc, T_Sym(arg)));}
+static s7_pointer fx_g(s7_scheme *sc, s7_pointer arg) {return((is_global(arg)) ? global_value(arg) : lookup(sc, arg));}
+static s7_pointer fx_o(s7_scheme *sc, s7_pointer arg) {return(o_lookup(sc, T_Sym(arg), arg));}
+static s7_pointer fx_t(s7_scheme *sc, s7_pointer arg) {return(t_lookup(sc, T_Sym(arg), arg));}
+static s7_pointer fx_u(s7_scheme *sc, s7_pointer arg) {return(u_lookup(sc, T_Sym(arg), arg));}
+static s7_pointer fx_v(s7_scheme *sc, s7_pointer arg) {return(v_lookup(sc, T_Sym(arg), arg));}
+static s7_pointer fx_T(s7_scheme *sc, s7_pointer arg) {return(T_lookup(sc, T_Sym(arg), arg));}
+static s7_pointer fx_U(s7_scheme *sc, s7_pointer arg) {return(U_lookup(sc, T_Sym(arg), arg));}
+static s7_pointer fx_V(s7_scheme *sc, s7_pointer arg) {return(V_lookup(sc, T_Sym(arg), arg));}
+static s7_pointer fx_c_nc(s7_scheme *sc, s7_pointer arg) {return(fn_call(sc, arg));}
+static s7_pointer fx_c_0c(s7_scheme *sc, s7_pointer arg) {return(fn_proc(arg)(sc, sc->nil));}
+static s7_pointer fx_cons_cc(s7_scheme *sc, s7_pointer arg) {return(cons(sc, cadr(arg), caddr(arg)));}
+static s7_pointer fx_curlet(s7_scheme *sc, s7_pointer arg) {return(s7_curlet(sc));}
+
+#define fx_c_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ return(fn_proc(arg)(sc, with_list_t1(Lookup(sc, cadr(arg), arg)))); \
+ }
+
+fx_c_any(fx_c_s, s_lookup)
+fx_c_any(fx_c_g, g_lookup)
+fx_c_any(fx_c_t, t_lookup)
+fx_c_any(fx_c_u, u_lookup)
+fx_c_any(fx_c_v, v_lookup)
+fx_c_any(fx_c_o, o_lookup)
+fx_c_any(fx_c_T, T_lookup)
+fx_c_any(fx_c_V, V_lookup)
+
+static s7_pointer fx_c_g_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup_global(sc, cadr(arg))));}
+static s7_pointer fx_c_s_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg))));}
+static s7_pointer fx_c_o_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, o_lookup(sc, cadr(arg), arg)));}
+static s7_pointer fx_c_t_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg)));}
+static s7_pointer fx_c_u_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, u_lookup(sc, cadr(arg), arg)));}
+static s7_pointer fx_c_v_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, v_lookup(sc, cadr(arg), arg)));}
+
+
+#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))); \
+ }
+ /* using car_p_p(val) here is exactly the same in speed according to callgrind, also opt3_sym(arg) for cadr(arg) */
+
+fx_car_any(fx_car_s, s_lookup)
+fx_car_any(fx_car_t, t_lookup)
+fx_car_any(fx_car_u, u_lookup)
+fx_car_any(fx_car_o, o_lookup)
+fx_car_any(fx_car_T, T_lookup)
+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); \
+ return((is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val))); \
+ }
+
+fx_cdr_any(fx_cdr_s, s_lookup)
+fx_cdr_any(fx_cdr_t, t_lookup)
+fx_cdr_any(fx_cdr_u, u_lookup)
+fx_cdr_any(fx_cdr_v, v_lookup)
+fx_cdr_any(fx_cdr_o, o_lookup)
+fx_cdr_any(fx_cdr_T, T_lookup)
+fx_cdr_any(fx_cdr_U, U_lookup)
+
+
+#define fx_cadr_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)) && (is_pair(cdr(val)))) ? cadr(val) : g_cadr(sc, set_plist_1(sc, val))); \
+ }
+
+fx_cadr_any(fx_cadr_s, s_lookup)
+fx_cadr_any(fx_cadr_t, t_lookup)
+fx_cadr_any(fx_cadr_u, u_lookup)
+fx_cadr_any(fx_cadr_o, o_lookup)
+
+
+#define fx_cddr_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)) && (is_pair(cdr(val)))) ? cddr(val) : g_cddr(sc, set_plist_1(sc, val))); \
+ }
+
+fx_cddr_any(fx_cddr_s, s_lookup)
+fx_cddr_any(fx_cddr_t, t_lookup)
+fx_cddr_any(fx_cddr_u, u_lookup)
+fx_cddr_any(fx_cddr_o, o_lookup)
+
+
+#define fx_add_s1_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer x = Lookup(sc, cadr(arg), arg); \
+ if ((!WITH_GMP) && (is_t_integer(x))) return(make_integer(sc, integer(x) + 1)); \
+ return(g_add_x1_1(sc, x, 1)); /* arg=(+ x 1) */ \
+ }
+
+fx_add_s1_any(fx_add_s1, s_lookup)
+fx_add_s1_any(fx_add_t1, t_lookup)
+fx_add_s1_any(fx_add_u1, u_lookup)
+fx_add_s1_any(fx_add_v1, v_lookup)
+fx_add_s1_any(fx_add_T1, T_lookup)
+fx_add_s1_any(fx_add_U1, U_lookup)
+fx_add_s1_any(fx_add_V1, V_lookup)
+
+
+static s7_pointer fx_num_eq_xi_1(s7_scheme *sc, s7_pointer args, s7_pointer val, s7_int y)
+{
+ if ((S7_DEBUGGING) && (is_t_integer(val))) fprintf(stderr, "%s[%d]: %s is an integer\n", __func__, __LINE__, display(val));
+ switch (type(val))
+ {
+ case T_REAL: return(make_boolean(sc, real(val) == y));
+ case T_RATIO:
+ case T_COMPLEX: return(sc->F);
+#if WITH_GMP
+ case T_BIG_INTEGER: return(make_boolean(sc, mpz_cmp_si(big_integer(val), y) == 0));
+ case T_BIG_REAL: return(make_boolean(sc, mpfr_cmp_si(big_real(val), y) == 0));
+ case T_BIG_RATIO:
+ case T_BIG_COMPLEX: return(sc->F);
+#endif
+ default: return(method_or_bust_pp(sc, val, sc->num_eq_symbol, val, cadr(args), a_number_string, 1));
+ }
+ return(sc->T);
+}
+
+static s7_pointer fx_num_eq_s0f(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer val = lookup(sc, cadr(arg));
+ if (is_t_real(val)) return(make_boolean(sc, real(val) == 0.0));
+ return(make_boolean(sc, num_eq_b_7pp(sc, val, real_zero)));
+}
+
+#define fx_num_eq_si_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer args = cdr(arg); \
+ s7_pointer val = Lookup(sc, car(args), arg); \
+ s7_int y = integer(cadr(args)); \
+ return((is_t_integer(val)) ? make_boolean(sc, integer(val) == y) : \
+ ((is_t_real(val)) ? make_boolean(sc, real(val) == y) : fx_num_eq_xi_1(sc, args, val, y))); \
+}
+
+fx_num_eq_si_any(fx_num_eq_si, s_lookup)
+fx_num_eq_si_any(fx_num_eq_ti, t_lookup)
+fx_num_eq_si_any(fx_num_eq_ui, u_lookup)
+fx_num_eq_si_any(fx_num_eq_vi, v_lookup)
+fx_num_eq_si_any(fx_num_eq_Ti, T_lookup)
+fx_num_eq_si_any(fx_num_eq_oi, o_lookup)
+
+#define fx_num_eq_s0_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer val = Lookup(sc, cadr(arg), arg); \
+ return((is_t_integer(val)) ? make_boolean(sc, integer(val) == 0) : fx_num_eq_xi_1(sc, cdr(arg), val, 0)); \
+ }
+
+fx_num_eq_s0_any(fx_num_eq_s0, s_lookup)
+fx_num_eq_s0_any(fx_num_eq_t0, t_lookup)
+fx_num_eq_s0_any(fx_num_eq_u0, u_lookup)
+fx_num_eq_s0_any(fx_num_eq_v0, v_lookup)
+
+static s7_pointer fx_num_eq_0s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer val = lookup(sc, opt3_sym(arg)); /* opt3_sym: caddr(arg) -- this actually makes a measurable difference in callgrind! */
+ return((is_t_integer(val)) ? make_boolean(sc, integer(val) == 0) : g_num_eq(sc, set_plist_2(sc, val, int_zero)));
+}
+
+
+static s7_pointer fx_random_i(s7_scheme *sc, s7_pointer arg)
+{
+#if WITH_GMP
+ return(g_random_i(sc, cdr(arg)));
+#else
+ return(make_integer(sc, (s7_int)(integer(cadr(arg)) * next_random(sc->default_random_state))));
+#endif
+}
+
+#if (!WITH_GMP)
+static s7_pointer fx_add_i_random(s7_scheme *sc, s7_pointer arg)
+{
+ s7_int x = integer(cadr(arg));
+ s7_int y = opt3_int(cdr(arg)); /* cadadr */
+ return(make_integer(sc, x + (s7_int)(y * next_random(sc->default_random_state)))); /* (+ -1 (random 1)) -- placement of the (s7_int) cast matters! */
+}
+#endif
+
+static s7_pointer fx_add_sf(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, cadr(arg)), real(opt2_con(cdr(arg))), 1));}
+static s7_pointer fx_add_fs(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, opt2_sym(cdr(arg))), real(cadr(arg)), 2));}
+static s7_pointer fx_add_tf(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, t_lookup(sc, cadr(arg), arg), real(opt2_con(cdr(arg))), 1));}
+static s7_pointer fx_add_ft(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, t_lookup(sc, opt2_sym(cdr(arg)), arg), real(cadr(arg)), 2));}
+
+#define fx_add_si_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer x = Lookup(sc, cadr(arg), arg); \
+ 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)); \
+ } \
+ else return(make_integer(sc, integer(x) + integer(opt2_con(cdr(arg))))); \
+ } \
+ return(add_p_pp(sc, x, opt2_con(cdr(arg)))); /* caddr(arg) */ \
+ }
+
+fx_add_si_any(fx_add_si, s_lookup)
+fx_add_si_any(fx_add_ti, t_lookup)
+
+static s7_pointer fx_add_ss(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, s_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_add_ts(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, t_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_add_tu(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_add_ut(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, u_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_add_uv(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, u_lookup(sc, cadr(arg), arg), v_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_add_us(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, u_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_add_vu(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, v_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+
+#define fx_subtract_s1_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer x = Lookup(sc, cadr(arg), arg); \
+ if ((!WITH_GMP) && (is_t_integer(x))) return(make_integer(sc, integer(x) - 1)); \
+ return(minus_c1(sc, x)); \
+ }
+
+fx_subtract_s1_any(fx_subtract_s1, s_lookup)
+fx_subtract_s1_any(fx_subtract_t1, t_lookup)
+fx_subtract_s1_any(fx_subtract_u1, u_lookup)
+fx_subtract_s1_any(fx_subtract_v1, v_lookup)
+fx_subtract_s1_any(fx_subtract_T1, T_lookup)
+fx_subtract_s1_any(fx_subtract_U1, U_lookup)
+
+
+#define fx_subtract_si_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer x = Lookup(sc, cadr(arg), arg); \
+ 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)); \
+ } \
+ else return(make_integer(sc, integer(x) - integer(opt2_con(cdr(arg))))); \
+ } \
+ return(subtract_p_pp(sc, x, opt2_con(cdr(arg)))); /* caddr(arg) */ \
+ }
+
+fx_subtract_si_any(fx_subtract_si, s_lookup)
+fx_subtract_si_any(fx_subtract_ti, t_lookup)
+fx_subtract_si_any(fx_subtract_ui, u_lookup)
+
+
+#define fx_subtract_sf_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer x = Lookup(sc, cadr(arg), arg); \
+ if (is_t_real(x)) \
+ return(make_real(sc, real(x) - real(opt2_con(cdr(arg))))); /* caddr(arg) */ \
+ return(g_subtract_2f(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \
+ }
+
+fx_subtract_sf_any(fx_subtract_sf, s_lookup)
+fx_subtract_sf_any(fx_subtract_tf, t_lookup)
+
+
+#define fx_subtract_ss_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) {return(subtract_p_pp(sc, Lookup1(sc, cadr(arg), arg), Lookup2(sc, opt2_sym(cdr(arg)), arg)));}
+
+fx_subtract_ss_any(fx_subtract_ss, s_lookup, s_lookup)
+fx_subtract_ss_any(fx_subtract_ts, t_lookup, s_lookup)
+fx_subtract_ss_any(fx_subtract_tu, t_lookup, u_lookup)
+fx_subtract_ss_any(fx_subtract_ut, u_lookup, t_lookup)
+fx_subtract_ss_any(fx_subtract_us, u_lookup, s_lookup)
+
+
+static s7_pointer fx_subtract_fs(s7_scheme *sc, s7_pointer arg)
+{
+ s7_double n = real(cadr(arg));
+ s7_pointer x = lookup(sc, opt2_sym(cdr(arg))); /* caddr(arg) */
+ switch (type(x))
+ {
+ case T_INTEGER: return(make_real(sc, n - integer(x)));
+ case T_RATIO: return(make_real(sc, n - fraction(x)));
+ case T_REAL: return(make_real(sc, n - real(x)));
+ case T_COMPLEX: return(make_complex_not_0i(sc, n - real_part(x), -imag_part(x)));
+#if WITH_GMP
+ case T_BIG_INTEGER: case T_BIG_RATIO: case T_BIG_REAL: case T_BIG_COMPLEX:
+ return(subtract_p_pp(sc, cadr(arg), x));
+#endif
+ default:
+ return(method_or_bust_pp(sc, x, sc->subtract_symbol, cadr(arg), x, a_number_string, 2));
+ }
+ return(x);
+}
+
+#define fx_is_eq_sc_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ return(make_boolean(sc, Lookup(sc, cadr(arg), arg) == opt2_con(cdr(arg)))); /* fx_choose checks that the second arg is not unspecified */ \
+ }
+
+fx_is_eq_sc_any(fx_is_eq_sc, s_lookup)
+fx_is_eq_sc_any(fx_is_eq_tc, t_lookup)
+fx_is_eq_sc_any(fx_is_eq_uc, u_lookup)
+
+
+#define fx_is_eq_car_sq_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer a = cdr(arg); \
+ s7_pointer lst = Lookup(sc, opt3_sym(a), arg); \
+ return(make_boolean(sc, (is_pair(lst)) ? (car(lst) == opt2_con(a)) : s7_is_eq(g_car(sc, set_plist_1(sc, lst)), opt2_con(a)))); \
+ }
+
+fx_is_eq_car_sq_any(fx_is_eq_car_sq, s_lookup)
+fx_is_eq_car_sq_any(fx_is_eq_car_tq, t_lookup)
+
+
+static s7_pointer fx_is_eq_caar_sq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer a = cdr(arg);
+ s7_pointer lst = lookup(sc, opt3_sym(a));
+ if ((is_pair(lst)) && (is_pair(car(lst))))
+ return(make_boolean(sc, caar(lst) == opt2_con(a)));
+ return(make_boolean(sc, s7_is_eq(g_caar(sc, set_plist_1(sc, lst)), opt2_con(a))));
+}
+
+static s7_pointer fx_not_is_eq_car_sq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer lst = lookup(sc, opt1_sym(cdr(arg)));
+ if (is_pair(lst))
+ return(make_boolean(sc, car(lst) != opt3_con(cdr(arg))));
+ return(make_boolean(sc, !s7_is_eq(g_car(sc, set_plist_1(sc, lst)), opt3_con(cdr(arg)))));
+}
+
+#define fx_is_pair_car_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer p = Lookup(sc, opt3_sym(arg), arg); \
+ return((is_pair(p)) ? make_boolean(sc, is_pair(car(p))) : g_is_pair(sc, set_plist_1(sc, g_car(sc, set_plist_1(sc, p))))); \
+ }
+
+fx_is_pair_car_s_any(fx_is_pair_car_s, s_lookup)
+fx_is_pair_car_s_any(fx_is_pair_car_t, t_lookup)
+
+
+#define fx_is_pair_cdr_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer p = Lookup(sc, opt3_sym(arg), arg); \
+ return((is_pair(p)) ? make_boolean(sc, is_pair(cdr(p))) : g_is_pair(sc, set_plist_1(sc, g_cdr(sc, set_plist_1(sc, p))))); \
+ }
+
+fx_is_pair_cdr_s_any(fx_is_pair_cdr_s, s_lookup)
+fx_is_pair_cdr_s_any(fx_is_pair_cdr_t, t_lookup)
+fx_is_pair_cdr_s_any(fx_is_pair_cdr_u, u_lookup)
+
+
+#define fx_is_pair_cadr_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer p = Lookup(sc, opt3_sym(arg), arg); \
+ return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_pair(cadr(p))) : g_is_pair(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \
+ }
+
+fx_is_pair_cadr_s_any(fx_is_pair_cadr_s, s_lookup)
+fx_is_pair_cadr_s_any(fx_is_pair_cadr_t, t_lookup)
+
+
+#define fx_is_pair_cddr_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer p = Lookup(sc, opt3_sym(arg), arg); \
+ return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_pair(cddr(p))) : g_is_pair(sc, set_plist_1(sc, g_cddr(sc, set_plist_1(sc, p))))); \
+ }
+
+fx_is_pair_cddr_s_any(fx_is_pair_cddr_s, s_lookup)
+fx_is_pair_cddr_s_any(fx_is_pair_cddr_t, t_lookup)
+
+
+#define fx_is_null_cdr_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer p = Lookup(sc, opt3_sym(arg), arg); \
+ return((is_pair(p)) ? make_boolean(sc, is_null(cdr(p))) : g_is_null(sc, set_plist_1(sc, g_cdr(sc, set_plist_1(sc, p))))); \
+ }
+
+fx_is_null_cdr_s_any(fx_is_null_cdr_s, s_lookup)
+fx_is_null_cdr_s_any(fx_is_null_cdr_t, t_lookup)
+
+
+#define fx_is_null_cadr_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer p = Lookup(sc, opt3_sym(arg), arg); \
+ return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_null(cadr(p))) : g_is_null(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \
+ }
+
+fx_is_null_cadr_s_any(fx_is_null_cadr_s, s_lookup)
+fx_is_null_cadr_s_any(fx_is_null_cadr_t, t_lookup)
+
+
+#define fx_is_null_cddr_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer p = Lookup(sc, opt3_sym(arg), arg); \
+ return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_null(cddr(p))) : g_is_null(sc, set_plist_1(sc, g_cddr(sc, set_plist_1(sc, p))))); \
+ }
+
+fx_is_null_cddr_s_any(fx_is_null_cddr_s, s_lookup)
+fx_is_null_cddr_s_any(fx_is_null_cddr_t, t_lookup)
+
+
+#define fx_is_symbol_cadr_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer p = Lookup(sc, opt3_sym(arg), arg); \
+ return(((is_pair(p)) && (is_pair(cdr(p)))) ? make_boolean(sc, is_symbol(cadr(p))) : g_is_symbol(sc, set_plist_1(sc, g_cadr(sc, set_plist_1(sc, p))))); \
+ }
+
+fx_is_symbol_cadr_s_any(fx_is_symbol_cadr_s, s_lookup)
+fx_is_symbol_cadr_s_any(fx_is_symbol_cadr_t, t_lookup)
+
+static s7_pointer fx_is_symbol_car_t(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer val = t_lookup(sc, opt3_sym(arg), arg);
+ return(make_boolean(sc, (is_pair(val)) ? is_symbol(car(val)) : is_symbol(g_car(sc, set_plist_1(sc, val)))));
+}
+
+static s7_pointer fx_floor_sqrt_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = lookup(sc, opt3_sym(arg));
+#if WITH_GMP
+ if ((is_t_big_integer(p)) &&
+ (mpz_cmp_ui(big_integer(p), 0) >= 0)) /* p >= 0 */
+ {
+ mpz_sqrt(sc->mpz_1, big_integer(p));
+ return(mpz_to_integer(sc, sc->mpz_1));
+ }
+#else
+ if (!is_negative_b_7p(sc, p))
+ return(make_integer(sc, (s7_int)floor(sqrt(s7_number_to_real_with_location(sc, p, sc->sqrt_symbol)))));
+#endif
+ return(floor_p_p(sc, sqrt_p_p(sc, p)));
+}
+
+
+static s7_pointer fx_is_positive_u(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p1 = u_lookup(sc, cadr(arg), arg);
+ if (is_t_integer(p1)) return(make_boolean(sc, integer(p1) > 0));
+ return(make_boolean(sc, is_positive_b_7p(sc, p1)));
+}
+
+static s7_pointer fx_is_zero_u(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_zero_b_7p(sc, u_lookup(sc, cadr(arg), arg))));}
+
+#define fx_real_part_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer z = Lookup(sc, cadr(arg), arg); \
+ return((is_t_complex(z)) ? make_real(sc, real_part(z)) : real_part_p_p(sc, z)); \
+ }
+
+fx_real_part_s_any(fx_real_part_s, s_lookup)
+fx_real_part_s_any(fx_real_part_t, t_lookup)
+
+#define fx_imag_part_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer z = Lookup(sc, cadr(arg), arg); \
+ return((is_t_complex(z)) ? make_real(sc, imag_part(z)) : imag_part_p_p(sc, z)); \
+ }
+
+fx_imag_part_s_any(fx_imag_part_s, s_lookup)
+fx_imag_part_s_any(fx_imag_part_t, t_lookup) /* not used in current timing tests */
+
+#define fx_iterate_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer iter = Lookup(sc, cadr(arg), arg); \
+ if (is_iterator(iter)) \
+ return((iterator_next(iter))(sc, iter)); \
+ return(method_or_bust_p(sc, iter, sc->iterate_symbol, sc->type_names[T_ITERATOR])); \
+ }
+
+fx_iterate_s_any(fx_iterate_s, s_lookup)
+fx_iterate_s_any(fx_iterate_o, o_lookup)
+fx_iterate_s_any(fx_iterate_T, T_lookup)
+
+static s7_pointer fx_read_char_0(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer port = input_port_if_not_loading(sc);
+ if (!port) return(eof_object);
+ if (!is_input_port(port))
+ return(method_or_bust_p(sc, port, sc->read_char_symbol, an_input_port_string));
+ return(chars[port_read_character(port)(sc, port)]);
+}
+
+static s7_pointer fx_length_s(s7_scheme *sc, s7_pointer arg) {return(s7_length(sc, lookup(sc, cadr(arg))));}
+static s7_pointer fx_length_t(s7_scheme *sc, s7_pointer arg) {return(s7_length(sc, t_lookup(sc, cadr(arg), arg)));}
+
+static s7_pointer fx_num_eq_length_i(s7_scheme *sc, s7_pointer arg)
+{
+ /* avoid make_integer (and telescope opts), we get here with car=length expr, cadr=int */
+ s7_int ilen = integer(opt3_con(arg)); /* is_t_integer checked in fx_choose */
+ s7_pointer val = lookup(sc, opt3_sym(cdr(arg)));
+
+ switch (type(val))
+ {
+ case T_PAIR: return(make_boolean(sc, s7_list_length(sc, val) == ilen));
+ case T_NIL: return(make_boolean(sc, ilen == 0));
+ case T_STRING: return(make_boolean(sc, string_length(val) == ilen));
+ case T_HASH_TABLE: return(make_boolean(sc, (hash_table_size(val)) == ilen));
+ case T_C_OBJECT: return(make_boolean(sc, c_object_length_to_int(sc, val) == ilen));
+ case T_LET: return(make_boolean(sc, let_length(sc, val) == ilen));
+
+ case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR:
+ return(make_boolean(sc, vector_length(val) == ilen));
+
+ case T_ITERATOR:
+ {
+ 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));
+ /* fall through */
+
+ default:
+ sole_arg_wrong_type_error_nr(sc, sc->length_symbol, val, a_sequence_string);
+ /* here we already lost because we checked for the length above */
+ }
+ return(sc->F);
+}
+
+static s7_pointer fx_less_length_i(s7_scheme *sc, s7_pointer arg)
+{
+ s7_int ilen = integer(opt3_con(arg)); /* caddr(arg) */
+ s7_pointer val = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg) */
+
+ switch (type(val))
+ {
+ case T_PAIR: return(make_boolean(sc, s7_list_length(sc, val) < ilen));
+ case T_NIL: return(make_boolean(sc, ilen > 0));
+ case T_STRING: return(make_boolean(sc, string_length(val) < ilen));
+ case T_HASH_TABLE: return(make_boolean(sc, (hash_table_size(val)) < ilen)); /* was <=? -- changed 15-Dec-15, then again 6-Jan-17: mask is len-1 */
+ case T_C_OBJECT: return(make_boolean(sc, c_object_length_to_int(sc, val) < ilen));
+ case T_LET: return(make_boolean(sc, let_length(sc, val) < ilen)); /* this works because let_length handles the length method itself! */
+
+ case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR:
+ return(make_boolean(sc, vector_length(val) < ilen));
+
+ case T_ITERATOR:
+ {
+ 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));
+ /* fall through */
+
+ default:
+ sole_arg_wrong_type_error_nr(sc, sc->length_symbol, val, a_sequence_string); /* no check method here because we checked above */
+ }
+ return(sc->F);
+}
+
+static s7_pointer fx_is_null_s(s7_scheme *sc, s7_pointer arg) {return((is_null(lookup(sc, cadr(arg)))) ? sc->T : sc->F);}
+static s7_pointer fx_is_null_o(s7_scheme *sc, s7_pointer arg) {return((is_null(o_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);} /* very few hits */
+static s7_pointer fx_is_null_t(s7_scheme *sc, s7_pointer arg) {return((is_null(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+static s7_pointer fx_is_null_u(s7_scheme *sc, s7_pointer arg) {return((is_null(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+static s7_pointer fx_is_null_v(s7_scheme *sc, s7_pointer arg) {return((is_null(v_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+static s7_pointer fx_is_null_T(s7_scheme *sc, s7_pointer arg) {return((is_null(T_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+static s7_pointer fx_is_symbol_s(s7_scheme *sc, s7_pointer arg) {return((is_symbol(lookup(sc, cadr(arg)))) ? sc->T : sc->F);}
+static s7_pointer fx_is_symbol_t(s7_scheme *sc, s7_pointer arg) {return((is_symbol(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+static s7_pointer fx_is_symbol_u(s7_scheme *sc, s7_pointer arg) {return((is_symbol(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+static s7_pointer fx_is_eof_s(s7_scheme *sc, s7_pointer arg) {return((lookup(sc, cadr(arg)) == eof_object) ? sc->T : sc->F);}
+static s7_pointer fx_is_eof_t(s7_scheme *sc, s7_pointer arg) {return((t_lookup(sc, cadr(arg), arg) == eof_object) ? sc->T : sc->F);}
+static s7_pointer fx_is_eof_u(s7_scheme *sc, s7_pointer arg) {return((u_lookup(sc, cadr(arg), arg) == eof_object) ? sc->T : sc->F);}
+static s7_pointer fx_is_type_s(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(lookup(sc, cadr(arg)))));}
+static s7_pointer fx_is_type_t(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(t_lookup(sc, cadr(arg), arg))));}
+static s7_pointer fx_is_type_u(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(u_lookup(sc, cadr(arg), arg))));}
+#if WITH_GMP
+static s7_pointer fx_is_integer_s(s7_scheme *sc, s7_pointer arg) {return((s7_is_integer(lookup(sc, cadr(arg)))) ? sc->T : sc->F);}
+static s7_pointer fx_is_integer_t(s7_scheme *sc, s7_pointer arg) {return((s7_is_integer(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+#else
+static s7_pointer fx_is_integer_s(s7_scheme *sc, s7_pointer arg) {return((is_t_integer(lookup(sc, cadr(arg)))) ? sc->T : sc->F);}
+static s7_pointer fx_is_integer_t(s7_scheme *sc, s7_pointer arg) {return((is_t_integer(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+#endif
+static s7_pointer fx_is_string_s(s7_scheme *sc, s7_pointer arg) {return((is_string(lookup(sc, cadr(arg)))) ? sc->T : sc->F);}
+static s7_pointer fx_is_string_t(s7_scheme *sc, s7_pointer arg) {return((is_string(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+static s7_pointer fx_is_procedure_s(s7_scheme *sc, s7_pointer arg) {return((is_procedure(lookup(sc, cadr(arg)))) ? sc->T : sc->F);}
+static s7_pointer fx_is_procedure_t(s7_scheme *sc, s7_pointer arg) {return((is_procedure(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+static s7_pointer fx_is_pair_s(s7_scheme *sc, s7_pointer arg) {return((is_pair(lookup(sc, cadr(arg)))) ? sc->T : sc->F);}
+static s7_pointer fx_is_pair_t(s7_scheme *sc, s7_pointer arg) {return((is_pair(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+static s7_pointer fx_is_pair_u(s7_scheme *sc, s7_pointer arg) {return((is_pair(u_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+static s7_pointer fx_is_pair_v(s7_scheme *sc, s7_pointer arg) {return((is_pair(v_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+static s7_pointer fx_is_keyword_s(s7_scheme *sc, s7_pointer arg) {return((is_symbol_and_keyword(lookup(sc, cadr(arg)))) ? sc->T : sc->F);}
+static s7_pointer fx_is_vector_s(s7_scheme *sc, s7_pointer arg) {return((is_any_vector(lookup(sc, cadr(arg)))) ? sc->T : sc->F);}
+static s7_pointer fx_is_vector_t(s7_scheme *sc, s7_pointer arg) {return((is_any_vector(t_lookup(sc, cadr(arg), arg))) ? sc->T : sc->F);}
+static s7_pointer fx_is_proper_list_s(s7_scheme *sc, s7_pointer arg) {return((s7_is_proper_list(sc, lookup(sc, cadr(arg)))) ? sc->T : sc->F);}
+static s7_pointer fx_not_s(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_false(sc, lookup(sc, cadr(arg)))));}
+static s7_pointer fx_not_t(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_false(sc, t_lookup(sc, cadr(arg), arg))));}
+static s7_pointer fx_not_o(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, is_false(sc, o_lookup(sc, cadr(arg), arg))));}
+static s7_pointer fx_not_is_pair_s(s7_scheme *sc, s7_pointer arg) {return((is_pair(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);}
+static s7_pointer fx_not_is_pair_t(s7_scheme *sc, s7_pointer arg) {return((is_pair(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);}
+static s7_pointer fx_not_is_pair_u(s7_scheme *sc, s7_pointer arg) {return((is_pair(u_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);}
+static s7_pointer fx_not_is_pair_v(s7_scheme *sc, s7_pointer arg) {return((is_pair(v_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);}
+static s7_pointer fx_not_is_null_s(s7_scheme *sc, s7_pointer arg) {return((is_null(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);}
+static s7_pointer fx_not_is_null_t(s7_scheme *sc, s7_pointer arg) {return((is_null(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);}
+static s7_pointer fx_not_is_null_u(s7_scheme *sc, s7_pointer arg) {return((is_null(u_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);}
+static s7_pointer fx_not_is_symbol_s(s7_scheme *sc, s7_pointer arg) {return((is_symbol(lookup(sc, opt3_sym(arg)))) ? sc->F : sc->T);}
+static s7_pointer fx_not_is_symbol_t(s7_scheme *sc, s7_pointer arg) {return((is_symbol(t_lookup(sc, opt3_sym(arg), arg))) ? sc->F : sc->T);}
+
+#define fx_c_sc_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t2_1, Lookup(sc, cadr(arg), arg)); \
+ set_car(sc->t2_2, opt2_con(cdr(arg))); \
+ return(fn_proc(arg)(sc, sc->t2_1)); \
+ }
+
+fx_c_sc_any(fx_c_sc, s_lookup)
+fx_c_sc_any(fx_c_tc, t_lookup)
+fx_c_sc_any(fx_c_uc, u_lookup) /* few hits */
+fx_c_sc_any(fx_c_vc, v_lookup)
+fx_c_sc_any(fx_c_oc, o_lookup)
+
+
+static s7_pointer fx_c_sc_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));}
+static s7_pointer fx_c_si_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), integer(opt2_con(cdr(arg)))));}
+static s7_pointer fx_c_ti_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg)))));}
+static s7_pointer fx_c_ti_remainder(s7_scheme *sc, s7_pointer arg) {return(remainder_p_pi(sc, t_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg)))));}
+static s7_pointer fx_c_tc_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), opt2_con(cdr(arg))));}
+static s7_pointer fx_vector_ref_tc(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pi(sc, t_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg)))));}
+ /* tc happens a lot, but others almost never */
+
+static s7_pointer fx_memq_sc(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));}
+static s7_pointer fx_memq_sc_3(s7_scheme *sc, s7_pointer arg) {return(memq_3_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));}
+static s7_pointer fx_memq_tc(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, t_lookup(sc, cadr(arg), arg), opt2_con(cdr(arg))));}
+static s7_pointer fx_leq_sc(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));}
+static s7_pointer fx_lt_sc(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));}
+static s7_pointer fx_gt_sc(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));}
+static s7_pointer fx_geq_sc(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));}
+static s7_pointer fx_list_sc(s7_scheme *sc, s7_pointer arg) {return(list_2(sc, lookup(sc, cadr(arg)), opt2_con(cdr(arg))));}
+
+#define fx_char_eq_sc_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer c = Lookup(sc, cadr(arg), arg); \
+ if (c == opt2_con(cdr(arg))) return(sc->T); \
+ if (is_character(c)) return(sc->F); \
+ return(method_or_bust(sc, cadr(arg), sc->char_eq_symbol, cdr(arg), sc->type_names[T_CHARACTER], 1)); \
+ }
+
+fx_char_eq_sc_any(fx_char_eq_sc, s_lookup)
+fx_char_eq_sc_any(fx_char_eq_tc, t_lookup)
+
+
+#define fx_c_cs_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t2_1, opt1_con(cdr(arg))); /* cadr(arg) or cadadr */ \
+ set_car(sc->t2_2, Lookup(sc, opt2_sym(cdr(arg)), arg)); /* caddr(arg) */ \
+ return(fn_proc(arg)(sc, sc->t2_1)); \
+ }
+
+fx_c_cs_any(fx_c_cs, s_lookup)
+fx_c_cs_any(fx_c_ct, t_lookup)
+fx_c_cs_any(fx_c_cu, u_lookup)
+
+
+static s7_pointer fx_c_ct_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, opt1_con(cdr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));
+}
+
+static s7_pointer fx_cons_cs(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt1_con(cdr(arg)), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_cons_ct(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt1_con(cdr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+
+
+#define fx_c_ss_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \
+ set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(arg)), arg)); \
+ return(fn_proc(arg)(sc, sc->t2_1)); \
+}
+
+fx_c_ss_any(fx_c_ss, s_lookup, s_lookup)
+fx_c_ss_any(fx_c_st, s_lookup, t_lookup)
+fx_c_ss_any(fx_c_ts, t_lookup, s_lookup)
+fx_c_ss_any(fx_c_tu, t_lookup, u_lookup)
+fx_c_ss_any(fx_c_uv, u_lookup, v_lookup)
+fx_c_ss_any(fx_c_tU, t_lookup, U_lookup)
+
+static s7_pointer fx_memq_ss(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_memq_tu(s7_scheme *sc, s7_pointer arg) {return(memq_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_assq_ss(s7_scheme *sc, s7_pointer arg) {return(assq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_vref_ss(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_vref_st(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_vref_ts(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, t_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_vref_tu(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_vref_ot(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, o_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_vref_gt(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_sref_ss(s7_scheme *sc, s7_pointer arg) {return(string_ref_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_sref_su(s7_scheme *sc, s7_pointer arg) {return(string_ref_p_pp(sc, lookup(sc, cadr(arg)), u_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_cons_ss(s7_scheme *sc, s7_pointer arg) {return(cons(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_cons_st(s7_scheme *sc, s7_pointer arg) {return(cons(sc, s_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_cons_ts(s7_scheme *sc, s7_pointer arg) {return(cons(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_cons_tu(s7_scheme *sc, s7_pointer arg) {return(cons(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_cons_tU(s7_scheme *sc, s7_pointer arg) {return(cons(sc, t_lookup(sc, cadr(arg), arg), U_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+/* static s7_pointer fx_cons_Ts(s7_scheme *sc, s7_pointer arg) {return(cons(sc, T_lookup(sc, cadr(arg), arg), s_lookup(sc, opt2_sym(cdr((arg)), arg)));} */
+
+#define fx_c_ss_direct_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, cadr(arg), arg), Lookup2(sc, opt2_sym(cdr(arg)), arg))); \
+ }
+
+fx_c_ss_direct_any(fx_c_ss_direct, s_lookup, s_lookup)
+fx_c_ss_direct_any(fx_c_ts_direct, t_lookup, s_lookup)
+fx_c_ss_direct_any(fx_c_tu_direct, t_lookup, u_lookup)
+fx_c_ss_direct_any(fx_c_st_direct, s_lookup, t_lookup)
+fx_c_ss_direct_any(fx_c_gt_direct, g_lookup, t_lookup)
+fx_c_ss_direct_any(fx_c_tU_direct, t_lookup, U_lookup)
+
+static s7_pointer fx_multiply_ss(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_multiply_ts(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));}
+/* static s7_pointer fx_multiply_Ts(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, T_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));} */
+static s7_pointer fx_multiply_fs(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, lookup(sc, opt2_sym(cdr(arg))), real(cadr(arg)), 2));}
+static s7_pointer fx_multiply_sf(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, lookup(sc, cadr(arg)), real(opt2_con(cdr(arg))), 1));}
+static s7_pointer fx_multiply_tf(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, t_lookup(sc, cadr(arg), arg), real(opt2_con(cdr(arg))), 1));}
+static s7_pointer fx_multiply_si(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, cadr(arg)), integer(opt2_con(cdr(arg))), 1));}
+static s7_pointer fx_multiply_ti(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, t_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg))), 1));}
+static s7_pointer fx_multiply_ui(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, u_lookup(sc, cadr(arg), arg), integer(opt2_con(cdr(arg))), 1));}
+static s7_pointer fx_multiply_is(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, opt2_sym(cdr(arg))), integer(cadr(arg)), 2));}
+static s7_pointer fx_multiply_it(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, t_lookup(sc, opt2_sym(cdr(arg)), arg), integer(cadr(arg)), 2));}
+static s7_pointer fx_multiply_tu(s7_scheme *sc, s7_pointer arg) {return(multiply_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+
+static inline s7_pointer fx_sqr_1(s7_scheme *sc, s7_pointer x)
+{
+ if (is_t_real(x)) return(make_real(sc, real(x) * real(x)));
+
+#if WITH_GMP
+ return(multiply_p_pp(sc, x, x));
+#else
+ switch (type(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));
+ }
+ 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));
+ }
+#else
+ case T_INTEGER: return(make_integer(sc, integer(x) * integer(x)));
+ case T_RATIO: return(make_ratio(sc, numerator(x) * numerator(x), denominator(x) * denominator(x)));
+#endif
+ case T_REAL: return(make_real(sc, real(x) * real(x)));
+ case T_COMPLEX: return(make_complex(sc, real_part(x) * real_part(x) - imag_part(x) * imag_part(x), 2.0 * real_part(x) * imag_part(x)));
+ default: return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, x, a_number_string, 1));
+ }
+ return(x);
+#endif
+}
+
+static s7_pointer fx_sqr_s(s7_scheme *sc, s7_pointer arg) {return(fx_sqr_1(sc, lookup(sc, cadr(arg))));}
+static s7_pointer fx_sqr_t(s7_scheme *sc, s7_pointer arg) {return(fx_sqr_1(sc, t_lookup(sc, cadr(arg), arg)));}
+
+static s7_pointer fx_add_sqr_sqr(s7_scheme *sc, s7_pointer arg) /* tbig -- need t case here */
+{
+ sc->temp5 = fx_sqr_1(sc, lookup(sc, car(opt1_pair(cdr(arg))))); /* cadadr(arg) */
+ return(add_p_pp(sc, sc->temp5, fx_sqr_1(sc, lookup(sc, car(opt3_pair(arg)))))); /* cadaddr(arg) */
+}
+
+static s7_pointer fx_c_s_sqr(s7_scheme *sc, s7_pointer arg) /* call */
+{
+ set_car(sc->t2_1, lookup(sc, cadr(arg)));
+ set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, opt2_sym(cdr(arg))))); /* cadaddr(arg) */
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_c_sqr(s7_scheme *sc, s7_pointer arg) /* fb */
+{
+ set_car(sc->t2_2, fx_sqr_1(sc, lookup(sc, opt1_sym(cdr(arg))))); /* cadaddr(arg) */
+ set_car(sc->t2_1, cadr(arg));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_geq_ss(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_geq_ts(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_geq_st(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_geq_us(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, u_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_geq_vs(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, v_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_geq_tT(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), T_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_geq_tu(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_geq_TU(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, T_lookup(sc, cadr(arg), arg), U_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_geq_to(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, t_lookup(sc, cadr(arg), arg), o_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_geq_vo(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, v_lookup(sc, cadr(arg), arg), o_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_geq_ot(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, o_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+
+static s7_pointer fx_gt_ss(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_gt_ts(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_gt_to(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), o_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_gt_tu(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_gt_ut(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, u_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_gt_tg(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, t_lookup(sc, cadr(arg), arg), global_value(opt2_sym(cdr(arg)))));}
+
+static s7_pointer fx_gt_tT(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p1 = t_lookup(sc, cadr(arg), arg);
+ s7_pointer p2 = T_lookup(sc, opt2_sym(cdr(arg)), arg);
+ return(((is_t_integer(p1)) && (is_t_integer(p2))) ? make_boolean(sc, integer(p1) > integer(p2)) : gt_p_pp(sc, p1, p2));
+}
+
+#define fx_gt_si_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer x = Lookup(sc, cadr(arg), arg); \
+ if (is_t_integer(x)) return(make_boolean(sc, integer(x) > integer(opt2_con(cdr(arg))))); \
+ if (is_t_real(x)) return(make_boolean(sc, real(x) > integer(opt2_con(cdr(arg))))); \
+ return(g_greater_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \
+ }
+
+fx_gt_si_any(fx_gt_si, s_lookup)
+fx_gt_si_any(fx_gt_ti, t_lookup)
+fx_gt_si_any(fx_gt_ui, u_lookup)
+
+static s7_pointer fx_leq_ss(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_leq_ts(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_leq_tu(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+
+#define fx_leq_si_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer x = Lookup(sc, cadr(arg), arg); \
+ if (is_t_integer(x)) return(make_boolean(sc, integer(x) <= integer(opt2_con(cdr(arg))))); \
+ return(g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \
+ }
+
+fx_leq_si_any(fx_leq_si, s_lookup)
+fx_leq_si_any(fx_leq_ti, t_lookup)
+fx_leq_si_any(fx_leq_ui, u_lookup)
+fx_leq_si_any(fx_leq_vi, v_lookup)
+
+static s7_pointer fx_lt_ss(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_lt_sg(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, lookup(sc, cadr(arg)), lookup_global(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_lt_tg(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup_global(sc, opt2_sym(cdr(arg)))));}
+
+static s7_pointer fx_lt_gsg(s7_scheme *sc, s7_pointer arg) /* gsg is much faster than sss */
+{
+ s7_pointer v1 = lookup_global(sc, cadr(arg));
+ s7_pointer v2 = lookup(sc, opt1_sym(cdr(arg))); /* caddr(arg) */
+ s7_pointer v3 = lookup_global(sc, opt2_sym(cdr(arg))); /* cadddr(arg) */
+ if ((is_t_integer(v1)) && (is_t_integer(v2)) && (is_t_integer(v3)))
+ return(make_boolean(sc, ((integer(v1) < integer(v2)) && (integer(v2) < integer(v3)))));
+ if (!is_real(v3))
+ wrong_type_error_nr(sc, sc->lt_symbol, 3, v3, sc->type_names[T_REAL]); /* else (< 2 1 1+i) returns #f */
+ return(make_boolean(sc, (lt_b_7pp(sc, v1, v2)) && (lt_b_7pp(sc, v2, v3))));
+}
+
+static s7_pointer fx_lt_ts(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_lt_tT(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), T_lookup(sc, opt2_sym(cdr(arg)), cadr(arg))));}
+static s7_pointer fx_lt_tu(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_lt_tU(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, t_lookup(sc, cadr(arg), arg), U_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_lt_ut(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, u_lookup(sc, cadr(arg), arg), t_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+
+static s7_pointer fx_lt_tf(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = t_lookup(sc, cadr(arg), arg);
+ if (is_t_real(x)) return(make_boolean(sc, real(x) < real(opt2_con(cdr(arg)))));
+ return(g_less_xf(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */
+}
+
+#define fx_lt_si_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer x = Lookup(sc, cadr(arg), arg); \
+ if (is_t_integer(x)) return(make_boolean(sc, integer(x) < integer(opt2_con(cdr(arg))))); \
+ return(g_less_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \
+ }
+
+fx_lt_si_any(fx_lt_si, s_lookup)
+fx_lt_si_any(fx_lt_ti, t_lookup)
+
+static s7_pointer fx_lt_t0(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = t_lookup(sc, cadr(arg), arg);
+ if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 0));
+ return(g_less_xi(sc, set_plist_2(sc, x, int_zero)));
+}
+
+static s7_pointer fx_lt_t1(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = t_lookup(sc, cadr(arg), arg);
+ if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 1));
+ return(g_less_xi(sc, set_plist_2(sc, x, int_one)));
+}
+
+static s7_pointer fx_lt_t2(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = t_lookup(sc, cadr(arg), arg);
+ if (is_t_integer(x)) return(make_boolean(sc, integer(x) < 2));
+ return(g_less_xi(sc, set_plist_2(sc, x, int_two)));
+}
+
+static s7_pointer fx_geq_tf(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = t_lookup(sc, cadr(arg), arg);
+ if (is_t_real(x)) return(make_boolean(sc, real(x) >= real(opt2_con(cdr(arg)))));
+ return(g_geq_xf(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */
+}
+
+#define fx_geq_si_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer x = Lookup(sc, cadr(arg), arg); \
+ if (is_t_integer(x)) return(make_boolean(sc, integer(x) >= integer(opt2_con(cdr(arg))))); \
+ return(g_geq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(arg))))); /* caddr(arg) */ \
+ }
+
+fx_geq_si_any(fx_geq_si, s_lookup)
+fx_geq_si_any(fx_geq_ti, t_lookup)
+
+static s7_pointer fx_geq_t0(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = t_lookup(sc, cadr(arg), arg);
+ if (is_t_integer(x)) return(make_boolean(sc, integer(x) >= 0));
+ return(g_geq_xi(sc, set_plist_2(sc, x, int_zero)));
+}
+
+#define fx_num_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 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))); \
+ }
+
+fx_num_eq_ss_any(fx_num_eq_ss, s_lookup, s_lookup)
+fx_num_eq_ss_any(fx_num_eq_ts, t_lookup, s_lookup)
+fx_num_eq_ss_any(fx_num_eq_to, t_lookup, o_lookup)
+fx_num_eq_ss_any(fx_num_eq_tg, t_lookup, g_lookup)
+fx_num_eq_ss_any(fx_num_eq_tT, t_lookup, T_lookup)
+fx_num_eq_ss_any(fx_num_eq_tu, t_lookup, u_lookup)
+fx_num_eq_ss_any(fx_num_eq_tv, t_lookup, v_lookup)
+fx_num_eq_ss_any(fx_num_eq_ut, u_lookup, t_lookup)
+fx_num_eq_ss_any(fx_num_eq_us, u_lookup, s_lookup)
+fx_num_eq_ss_any(fx_num_eq_vs, v_lookup, s_lookup)
+fx_num_eq_ss_any(fx_num_eq_uU, u_lookup, U_lookup)
+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 y = Lookup2(sc, opt2_sym(cdr(arg)), arg); \
+ return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y))))); \
+ }
+
+fx_is_eq_ss_any(fx_is_eq_ss, s_lookup, s_lookup)
+fx_is_eq_ss_any(fx_is_eq_ts, t_lookup, s_lookup)
+fx_is_eq_ss_any(fx_is_eq_tu, t_lookup, u_lookup)
+fx_is_eq_ss_any(fx_is_eq_to, t_lookup, o_lookup)
+
+
+static s7_pointer fx_not_is_eq_ss(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = lookup(sc, opt3_sym(arg));
+ s7_pointer y = lookup(sc, opt1_sym(cdr(arg)));
+ return(make_boolean(sc, (x != y) && ((!is_unspecified(x)) || (!is_unspecified(y)))));
+}
+
+static s7_pointer fx_not_is_eq_sq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = lookup(sc, opt3_sym(arg));
+ s7_pointer y = opt3_con(cdr(arg));
+ return(make_boolean(sc, (x != y) && ((!is_unspecified(x)) || (!is_unspecified(y)))));
+}
+
+static s7_pointer x_hash_table_ref_ss(s7_scheme *sc, s7_pointer table, s7_pointer key)
+{
+ return((is_hash_table(table)) ? hash_entry_value((*hash_table_checker(table))(sc, table, key)) : g_hash_table_ref(sc, set_plist_2(sc, table, key)));
+}
+
+static s7_pointer fx_hash_table_ref_ss(s7_scheme *sc, s7_pointer arg) {return(x_hash_table_ref_ss(sc, lookup(sc, cadr(arg)), lookup(sc, opt2_sym(cdr(arg)))));}
+static s7_pointer fx_hash_table_ref_st(s7_scheme *sc, s7_pointer arg) {return(x_hash_table_ref_ss(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+static s7_pointer fx_hash_table_ref_TV(s7_scheme *sc, s7_pointer arg) {return(x_hash_table_ref_ss(sc, T_lookup(sc, cadr(arg), arg), V_lookup(sc, opt2_sym(cdr(arg)), arg)));}
+
+static s7_pointer fx_hash_table_ref_car(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer table = lookup(sc, cadr(arg));
+ s7_pointer lst = lookup(sc, opt2_sym(cdr(arg)));
+ if (!is_pair(lst))
+ sole_arg_wrong_type_error_nr(sc, sc->car_symbol, lst, sc->type_names[T_PAIR]);
+ return((is_hash_table(table)) ? hash_entry_value((*hash_table_checker(table))(sc, table, car(lst))) : g_hash_table_ref(sc, set_plist_2(sc, table, car(lst))));
+}
+
+
+static inline s7_pointer fx_hash_table_increment_1(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer arg)
+{
+ hash_entry_t *val;
+ if (!is_hash_table(table))
+ return(mutable_method_or_bust_ppp(sc, table, sc->hash_table_set_symbol, table, key, fx_call(sc, cdddr(arg)), sc->type_names[T_HASH_TABLE], 1));
+ val = (*hash_table_checker(table))(sc, table, key);
+ 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]);
+ hash_entry_set_value(val, make_integer(sc, integer(hash_entry_value(val)) + 1));
+ return(hash_entry_value(val));
+ }
+ s7_hash_table_set(sc, table, key, int_one);
+ return(int_one);
+}
+
+static s7_pointer fx_hash_table_increment(s7_scheme *sc, s7_pointer arg)
+{
+ return(fx_hash_table_increment_1(sc, lookup(sc, cadr(arg)), lookup(sc, caddr(arg)), arg));
+}
+
+
+static s7_pointer fx_simple_let_ref_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer sym;
+ 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));
+ 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)))); */
+ for (s7_pointer y = let_slots(lt); tis_slot(y); y = next_slot(y))
+ if (slot_symbol(y) == sym)
+ return(slot_value(y));
+ return(let_ref_p_pp(sc, let_outlet(lt), sym));
+}
+
+static s7_pointer fx_memq_sq_2(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = opt2_con(cdr(arg));
+ s7_pointer obj = lookup(sc, cadr(arg));
+ if (obj == car(p)) return(p);
+ return((obj == cadr(p)) ? cdr(p) : sc->F);
+}
+
+static s7_pointer fx_c_cq(s7_scheme *sc, s7_pointer arg) {return(fn_proc(arg)(sc, with_list_t2(cadr(arg), opt2_con(cdr(arg)))));}
+
+#define fx_c_sss_any(Name, Lookup1, Lookup2, Lookup3) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \
+ set_car(sc->t3_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \
+ set_car(sc->t3_3, Lookup3(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \
+ return(fn_proc(arg)(sc, sc->t3_1)); \
+ }
+
+fx_c_sss_any(fx_c_sss, s_lookup, s_lookup, s_lookup)
+fx_c_sss_any(fx_c_sts, s_lookup, t_lookup, s_lookup)
+fx_c_sss_any(fx_c_tus, t_lookup, u_lookup, s_lookup)
+fx_c_sss_any(fx_c_tuv, t_lookup, u_lookup, v_lookup)
+
+
+static s7_pointer fx_c_sss_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), lookup(sc, opt1_sym(cdr(arg))), lookup(sc, opt2_sym(cdr(arg)))));
+}
+
+static s7_pointer fx_c_tuv_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, cadr(arg), arg), u_lookup(sc, opt1_sym(cdr(arg)), arg), v_lookup(sc, opt2_sym(cdr(arg)), arg)));
+}
+
+static s7_pointer fx_vset_sts(s7_scheme *sc, s7_pointer arg)
+{
+ return(vector_set_p_ppp(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt1_sym(cdr(arg)), arg), lookup(sc, opt2_sym(cdr(arg)))));
+}
+
+static s7_pointer fx_vset_oto(s7_scheme *sc, s7_pointer arg)
+{
+ return(vector_set_p_ppp(sc, o_lookup(sc, cadr(arg), arg), t_lookup(sc, opt1_sym(cdr(arg)), arg), o_lookup(sc, opt2_sym(cdr(arg)), arg)));
+}
+
+#define fx_c_scs_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \
+ set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \
+ set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) */ \
+ return(fn_proc(arg)(sc, sc->t3_1)); \
+ }
+
+fx_c_scs_any(fx_c_scs, s_lookup, s_lookup)
+fx_c_scs_any(fx_c_tcs, t_lookup, s_lookup)
+
+
+#define fx_c_scs_direct_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ return(((s7_p_ppp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, cadr(arg), arg), opt1_con(cdr(arg)), Lookup2(sc, opt2_sym(cdr(arg)), arg))); \
+ }
+
+fx_c_scs_direct_any(fx_c_scs_direct, s_lookup, s_lookup)
+fx_c_scs_direct_any(fx_c_tcu_direct, t_lookup, u_lookup)
+fx_c_scs_direct_any(fx_c_tcs_direct, t_lookup, s_lookup)
+fx_c_scs_direct_any(fx_c_TcU_direct, T_lookup, U_lookup)
+
+
+static s7_pointer fx_c_scc(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t3_1, lookup(sc, cadr(arg)));
+ set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) */
+ set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */
+ return(fn_proc(arg)(sc, sc->t3_1));
+}
+
+#define fx_c_css_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t3_2, Lookup1(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \
+ set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg) */ \
+ set_car(sc->t3_1, cadr(arg)); \
+ return(fn_proc(arg)(sc, sc->t3_1)); \
+ }
+
+fx_c_css_any(fx_c_css, s_lookup, s_lookup)
+fx_c_css_any(fx_c_ctv, t_lookup, v_lookup)
+
+static s7_pointer fx_c_csc(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t3_2, lookup(sc, opt1_sym(cdr(arg)))); /* caddr(arg) */
+ set_car(sc->t3_1, opt3_con(cdr(arg))); /* cadr(arg) or maybe cadadr if quoted? */
+ set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */
+ return(fn_proc(arg)(sc, sc->t3_1));
+}
+
+static s7_pointer fx_c_ccs(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t3_3, lookup(sc, opt1_sym(cdr(arg)))); /* cadddr(arg) */
+ set_car(sc->t3_1, cadr(arg)); /* maybe opt3_con? */
+ set_car(sc->t3_2, opt2_con(cdr(arg))); /* caddr(arg) */
+ return(fn_proc(arg)(sc, sc->t3_1));
+}
+
+#define fx_c_ssc_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg)); \
+ set_car(sc->t3_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* caddr(arg) */ \
+ set_car(sc->t3_3, opt2_con(cdr(arg))); /* cadddr(arg) */ \
+ return(fn_proc(arg)(sc, sc->t3_1)); \
+ }
+
+fx_c_ssc_any(fx_c_ssc, s_lookup, s_lookup)
+fx_c_ssc_any(fx_c_tuc, t_lookup, u_lookup)
+
+static s7_pointer fx_c_opncq(s7_scheme *sc, s7_pointer arg)
+{
+ return(fn_proc(arg)(sc, with_list_t1(fn_call(sc, cadr(arg)))));
+}
+
+#define fx_c_opsq_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer largs = cadr(arg); \
+ set_car(sc->t1_1, fn_proc(largs)(sc, with_list_t1(Lookup(sc, cadr(largs), largs)))); \
+ return(fn_proc(arg)(sc, sc->t1_1)); \
+ }
+
+fx_c_opsq_any(fx_c_opsq, s_lookup)
+fx_c_opsq_any(fx_c_optq, t_lookup)
+
+static s7_pointer fx_c_optq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg))));
+}
+
+#define fx_c_car_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer val = Lookup(sc, opt3_sym(arg), arg); \
+ set_car(sc->t1_1, (is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \
+ return(fn_proc(arg)(sc, sc->t1_1)); \
+ }
+
+fx_c_car_s_any(fx_c_car_s, s_lookup)
+fx_c_car_s_any(fx_c_car_t, t_lookup)
+fx_c_car_s_any(fx_c_car_u, u_lookup)
+
+#define fx_c_cdr_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer val = Lookup(sc, opt3_sym(arg), arg); \
+ set_car(sc->t1_1, (is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val))); \
+ return(fn_proc(arg)(sc, sc->t1_1)); \
+ }
+
+fx_c_cdr_s_any(fx_c_cdr_s, s_lookup)
+fx_c_cdr_s_any(fx_c_cdr_t, t_lookup)
+
+#define fx_is_type_opsq_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t1_1, Lookup(sc, opt3_sym(arg), arg)); \
+ return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(fn_proc(cadr(arg))(sc, sc->t1_1)))); \
+ }
+
+fx_is_type_opsq_any(fx_is_type_opsq, s_lookup)
+fx_is_type_opsq_any(fx_is_type_optq, t_lookup)
+
+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))))));
+}
+
+static s7_pointer fx_is_type_car_t(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer func, val = t_lookup(sc, opt3_sym(arg), arg);
+ if (is_pair(val))
+ return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(car(val))));
+ if (!has_active_methods(sc, val)) /* this verbosity saves 1/3 total compute time (overhead!) */
+ wrong_type_error_nr(sc, sc->car_symbol, 1, val, sc->type_names[T_PAIR]);
+ func = find_method_with_let(sc, val, sc->car_symbol);
+ if (func == sc->undefined)
+ wrong_type_error_nr(sc, sc->car_symbol, 1, val, sc->type_names[T_PAIR]);
+ return(make_boolean(sc, type(s7_apply_function(sc, func, set_plist_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg))));
+}
+
+static s7_pointer fx_eq_weak1_type_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer func, val = lookup(sc, opt3_sym(arg));
+ if (is_c_pointer(val)) /* (let? (c-pointer-weak1 val)) etc */
+ return(make_boolean(sc, (uint8_t)(opt3_byte(cdr(arg))) == type(c_pointer_weak1(val))));
+ if (!has_active_methods(sc, val)) /* calling g_c_pointer_weak1 here instead is much slower, error by itself is much faster! splitting out does not help */
+ wrong_type_error_nr(sc, sc->c_pointer_weak1_symbol, 1, val, sc->type_names[T_C_POINTER]);
+ func = find_method_with_let(sc, val, sc->c_pointer_weak1_symbol);
+ if (func == sc->undefined)
+ wrong_type_error_nr(sc, sc->c_pointer_weak1_symbol, 1, val, sc->type_names[T_C_POINTER]);
+ return(make_boolean(sc, type(s7_apply_function(sc, func, set_plist_1(sc, val))) == (uint8_t)opt3_byte(cdr(arg))));
+}
+
+#define fx_not_opsq_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer largs = cadr(arg); \
+ set_car(sc->t1_1, Lookup(sc, cadr(largs), arg)); \
+ return((fn_proc(largs)(sc, sc->t1_1) == sc->F) ? sc->T : sc->F); \
+ }
+
+fx_not_opsq_any(fx_not_opsq, s_lookup)
+fx_not_opsq_any(fx_not_optq, t_lookup)
+
+static s7_pointer fx_not_car_t(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = t_lookup(sc, opt3_sym(arg), arg); /* cadadr */
+ s7_pointer res = (is_pair(p)) ? car(p) : g_car(sc, set_plist_1(sc, p));
+ return((res == sc->F) ? sc->T : sc->F);
+}
+
+
+#define fx_c_opssq_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t2_1, Lookup1(sc, opt3_sym(arg), arg)); \
+ set_car(sc->t2_2, Lookup2(sc, opt1_sym(cdr(arg)), arg)); /* or opt2_sym */ \
+ return(fn_proc(arg)(sc, with_list_t1(fn_proc(cadr(arg))(sc, sc->t2_1)))); \
+ }
+
+fx_c_opssq_any(fx_c_opssq, s_lookup, s_lookup)
+fx_c_opssq_any(fx_c_optuq, t_lookup, u_lookup)
+fx_c_opssq_any(fx_c_opstq, s_lookup, t_lookup)
+
+
+#define fx_c_opssq_direct_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ return(((s7_p_p_t)opt2_direct(cdr(arg)))(sc, \
+ ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup1(sc, opt3_sym(arg), arg), Lookup2(sc, opt1_sym(cdr(arg)), arg)))); \
+ }
+
+fx_c_opssq_direct_any(fx_c_opssq_direct, s_lookup, s_lookup)
+fx_c_opssq_direct_any(fx_c_opstq_direct, s_lookup, t_lookup)
+fx_c_opssq_direct_any(fx_c_optuq_direct, t_lookup, u_lookup)
+
+
+#define fx_not_opssq_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer larg = cadr(arg); \
+ set_car(sc->t2_1, Lookup1(sc, cadr(larg), larg)); \
+ set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(larg)), larg)); \
+ return((fn_proc(larg)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); \
+ }
+
+fx_not_opssq_any(fx_not_opssq, s_lookup, s_lookup)
+fx_not_opssq_any(fx_not_oputq, u_lookup, t_lookup)
+
+
+static s7_pointer fx_not_lt_ut(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer y = u_lookup(sc, opt3_sym(arg), arg);
+ s7_pointer x = t_lookup(sc, opt1_sym(cdr(arg)), arg);
+ return(make_boolean(sc, ((is_t_integer(x)) && (is_t_integer(y))) ? (integer(y) >= integer(x)) : geq_b_7pp(sc, y, x)));
+}
+
+static s7_pointer fx_is_zero_remainder_car(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer t = t_lookup(sc, opt1_sym(cdr(arg)), arg);
+ s7_pointer u = u_lookup(sc, opt3_sym(arg), arg);
+ u = (is_pair(u)) ? car(u) : g_car(sc, set_plist_1(sc, u)); /* g_car much less overhead than car_p_p or simple_error(?) */
+ if ((is_t_integer(u)) && (is_t_integer(t)))
+ return(make_boolean(sc, remainder_i_7ii(sc, integer(u), integer(t)) == 0));
+ return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, u, t))));
+}
+
+static s7_pointer fx_is_zero_remainder_o(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer s = o_lookup(sc, opt3_sym(arg), arg);
+ s7_pointer t = t_lookup(sc, opt1_sym(cdr(arg)), arg);
+ if ((is_t_integer(s)) && (is_t_integer(t)))
+ return(make_boolean(sc, remainder_i_7ii(sc, integer(s), integer(t)) == 0));
+ return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pp(sc, s, t))));
+}
+
+#define fx_c_opscq_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer largs = cadr(arg); \
+ set_car(sc->t2_1, Lookup(sc, cadr(largs), largs)); \
+ set_car(sc->t2_2, opt2_con(cdr(largs))); \
+ return(fn_proc(arg)(sc, with_list_t1(fn_proc(largs)(sc, sc->t2_1)))); \
+ }
+
+fx_c_opscq_any(fx_c_opscq, s_lookup)
+fx_c_opscq_any(fx_c_optcq, t_lookup)
+
+static s7_pointer fx_is_zero_remainder_ti(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer larg = cdadr(arg);
+ s7_pointer t = t_lookup(sc, car(larg), arg);
+ s7_int u = integer(cadr(larg));
+ if (is_t_integer(t)) return(make_boolean(sc, (integer(t) % u) == 0));
+ return(make_boolean(sc, is_zero_b_7p(sc, remainder_p_pi(sc, t, u))));
+}
+
+static s7_pointer fx_not_opscq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = cadr(arg);
+ set_car(sc->t2_1, lookup(sc, cadr(largs)));
+ set_car(sc->t2_2, opt2_con(cdr(largs)));
+ return((fn_proc(largs)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F);
+}
+
+static s7_pointer fx_c_opcsq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = cadr(arg);
+ set_car(sc->t2_2, lookup(sc, caddr(largs)));
+ set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */
+ return(fn_proc(arg)(sc, with_list_t1(fn_proc(largs)(sc, sc->t2_1))));
+}
+
+static s7_pointer fx_c_opcsq_c(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = cadr(arg);
+ set_car(sc->t2_2, lookup(sc, caddr(largs)));
+ set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */
+ set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1));
+ set_car(sc->t2_2, caddr(arg));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_opcsq_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = cadr(arg);
+ set_car(sc->t2_2, lookup(sc, caddr(largs)));
+ set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */
+ set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1));
+ set_car(sc->t2_2, lookup(sc, caddr(arg)));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_opssq_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = cadr(arg);
+ set_car(sc->t2_1, lookup(sc, cadr(largs)));
+ set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs))));
+ set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1));
+ set_car(sc->t2_2, lookup(sc, caddr(arg)));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+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))));
+}
+
+static s7_pointer fx_add_mul_opssq_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */
+ s7_pointer a = lookup(sc, car(largs));
+ s7_pointer b = lookup(sc, opt2_sym(largs));
+ s7_pointer c = lookup(sc, caddr(arg));
+ if ((is_t_integer(a)) && (is_t_integer(b)) && (is_t_integer(c)))
+#if HAVE_OVERFLOW_CHECKS
+ {
+ 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)));
+ }
+ return(make_integer(sc, val));
+ }
+#else
+ return(make_integer(sc, (integer(a) * integer(b)) + integer(c)));
+#endif
+ return(add_p_pp(sc, multiply_p_pp(sc, a, b), c));
+}
+
+static s7_pointer fx_add_vref_s(s7_scheme *sc, s7_pointer arg)
+{
+ return(add_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))), lookup(sc, caddr(arg))));
+}
+
+static s7_pointer fx_add_s_vref(s7_scheme *sc, s7_pointer arg)
+{
+ return(add_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg))))));
+}
+
+static s7_pointer fx_subtract_vref_s(s7_scheme *sc, s7_pointer arg)
+{
+ return(subtract_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))), lookup(sc, caddr(arg))));
+}
+
+static s7_pointer fx_subtract_s_vref(s7_scheme *sc, s7_pointer arg)
+{
+ return(subtract_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg))))));
+}
+
+static s7_pointer fx_multiply_s_vref(s7_scheme *sc, s7_pointer arg)
+{
+ return(multiply_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg))))));
+}
+
+static s7_pointer fx_cons_cons_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */
+ return(cons_unchecked(sc, cons(sc, lookup(sc, car(largs)), lookup(sc, opt2_sym(largs))), lookup(sc, caddr(arg))));
+}
+
+#define fx_add_sqr_s_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer p1 = Lookup(sc, car(opt3_pair(arg)), arg); \
+ s7_pointer p3 = lookup(sc, caddr(arg)); \
+ if ((is_t_complex(p1)) && (is_t_complex(p3))) \
+ { \
+ s7_double r = real_part(p1), i = imag_part(p1); \
+ return(make_complex(sc, real_part(p3) + r * r - i * i, imag_part(p3) + 2.0 * r * i)); \
+ } \
+ return(add_p_pp(sc, fx_sqr_1(sc, p1), p3)); \
+ }
+
+fx_add_sqr_s_any(fx_add_sqr_s, s_lookup)
+fx_add_sqr_s_any(fx_add_sqr_T, T_lookup)
+
+static s7_pointer fx_add_sub_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */
+ s7_pointer p1 = lookup(sc, car(largs));
+ s7_pointer p2 = lookup(sc, opt2_sym(largs));
+ s7_pointer p3 = lookup(sc, caddr(arg));
+ if ((is_t_real(p1)) && (is_t_real(p2)) && (is_t_real(p3))) return(make_real(sc, real(p3) + real(p1) - real(p2)));
+ return(add_p_pp(sc, subtract_p_pp(sc, p1, p2), p3));
+}
+
+static s7_pointer fx_add_sub_tu_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p1 = t_lookup(sc, car(cdadr(arg)), arg);
+ s7_pointer p2 = u_lookup(sc, cadr(cdadr(arg)), arg);
+ s7_pointer p3 = lookup(sc, caddr(arg));
+ if ((is_t_real(p1)) && (is_t_real(p2)) && (is_t_real(p3))) return(make_real(sc, real(p3) + real(p1) - real(p2)));
+ return(add_p_pp(sc, subtract_p_pp(sc, p1, p2), p3));
+}
+
+static s7_pointer fx_gt_add_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = opt3_pair(arg); /* cdadr(arg) */
+ s7_pointer x1 = lookup(sc, car(largs));
+ s7_pointer x2 = lookup(sc, opt2_sym(largs));
+ s7_pointer x3 = lookup(sc, caddr(arg));
+ if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3))) return(make_boolean(sc, (real(x1) + real(x2)) > real(x3)));
+ return(gt_p_pp(sc, add_p_pp(sc, x1, x2), x3));
+}
+
+static s7_pointer fx_gt_add_tu_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x1 = t_lookup(sc, car(cdadr(arg)), arg);
+ s7_pointer x2 = u_lookup(sc, cadr(cdadr(arg)), arg);
+ s7_pointer x3 = lookup(sc, caddr(arg));
+ if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3))) return(make_boolean(sc, (real(x1) + real(x2)) > real(x3)));
+ return(gt_p_pp(sc, add_p_pp(sc, x1, x2), x3));
+}
+
+static s7_pointer fx_gt_vref_s(s7_scheme *sc, s7_pointer arg)
+{
+ return(gt_p_pp(sc, vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg)))), lookup(sc, caddr(arg))));
+}
+
+static s7_pointer fx_geq_s_vref(s7_scheme *sc, s7_pointer arg)
+{
+ return(geq_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg))))));
+}
+
+static s7_pointer fx_is_eq_s_vref(s7_scheme *sc, s7_pointer arg)
+{
+ return(make_boolean(sc, lookup(sc, cadr(arg)) == vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg))))));
+}
+
+static s7_pointer fx_href_s_vref(s7_scheme *sc, s7_pointer arg)
+{
+ return(hash_table_ref_p_pp(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg))))));
+}
+
+static s7_pointer fx_lref_s_vref(s7_scheme *sc, s7_pointer arg) /* tbig */
+{
+ return(let_ref(sc, lookup(sc, cadr(arg)), vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg))))));
+}
+
+static s7_pointer fx_vref_s_add(s7_scheme *sc, s7_pointer arg)
+{
+ return(vector_ref_p_pp(sc, lookup(sc, cadr(arg)), add_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt2_sym(opt3_pair(arg))))));
+}
+
+static inline s7_pointer fx_vref_vref_3(s7_scheme *sc, s7_pointer v1, s7_pointer p1, s7_pointer p2)
+{
+ if ((is_t_integer(p1)) && (is_t_integer(p2)) && ((is_t_vector(v1)) && (vector_rank(v1) == 1)))
+ {
+ 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));
+ }}
+ return(vector_ref_p_pp(sc, vector_ref_p_pp(sc, v1, p1), p2));
+}
+
+#define fx_vref_vref_ss_s_any(Name, Lookup1, Lookup2, Lookup3) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ return(fx_vref_vref_3(sc, Lookup1(sc, car(opt3_pair(arg)), arg), Lookup2(sc, opt2_sym(opt3_pair(arg)), arg), Lookup3(sc, caddr(arg), arg))); \
+ }
+
+fx_vref_vref_ss_s_any(fx_vref_vref_ss_s, s_lookup, s_lookup, s_lookup)
+fx_vref_vref_ss_s_any(fx_vref_vref_gs_t, g_lookup, s_lookup, t_lookup)
+fx_vref_vref_ss_s_any(fx_vref_vref_go_t, g_lookup, o_lookup, t_lookup)
+fx_vref_vref_ss_s_any(fx_vref_vref_tu_v, t_lookup, u_lookup, v_lookup)
+
+static s7_pointer fx_vref_vref_3_no_let(s7_scheme *sc, s7_pointer code) /* out one level from vref_vref_tu_v */
+{
+ return(fx_vref_vref_3(sc, lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code))));
+}
+
+static s7_pointer fx_c_opscq_c(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = cadr(arg);
+ set_car(sc->t2_1, lookup(sc, cadr(largs)));
+ set_car(sc->t2_2, opt2_con(cdr(largs)));
+ set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1));
+ set_car(sc->t2_2, caddr(arg));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+#define fx_c_opssq_c_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer largs = cadr(arg); \
+ set_car(sc->t2_1, Lookup1(sc, cadr(largs), largs)); \
+ set_car(sc->t2_2, Lookup2(sc, opt2_sym(cdr(largs)), largs)); \
+ set_car(sc->t2_1, fn_proc(largs)(sc, sc->t2_1)); \
+ set_car(sc->t2_2, opt3_con(cdr(arg))); /* caddr */ \
+ return(fn_proc(arg)(sc, sc->t2_1)); \
+ }
+
+fx_c_opssq_c_any(fx_c_opssq_c, s_lookup, s_lookup)
+fx_c_opssq_c_any(fx_c_opstq_c, s_lookup, t_lookup)
+
+
+static s7_pointer fx_c_opstq_c_direct(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = cadr(arg);
+ return(((s7_p_pp_t)opt3_direct(arg))(sc, fn_proc(largs)(sc, set_plist_2(sc, lookup(sc, cadr(largs)), t_lookup(sc, caddr(largs), arg))), opt3_con(cdr(arg))));
+}
+
+static s7_pointer fx_is_eq_vref_opotq_c(s7_scheme *sc, s7_pointer arg) /* experiment, (eqv? <> char) is <>==char without error checks? */
+{
+ s7_pointer largs = cdadr(arg);
+ return(make_boolean(sc, vector_ref_p_pp(sc, o_lookup(sc, car(largs), largs), t_lookup(sc, cadr(largs), arg)) == opt3_con(cdr(arg))));
+}
+
+#define fx_c_opsq_s_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer largs = cadr(arg); \
+ set_car(sc->t2_1, fn_proc(largs)(sc, with_list_t1(Lookup1(sc, cadr(largs), arg)))); /* also opt1_sym(cdr(arg)) */ \
+ set_car(sc->t2_2, Lookup2(sc, opt3_sym(arg), arg)); /* caddr(arg) */ \
+ return(fn_proc(arg)(sc, sc->t2_1)); \
+ }
+
+fx_c_opsq_s_any(fx_c_opsq_s, s_lookup, s_lookup)
+fx_c_opsq_s_any(fx_c_optq_s, t_lookup, s_lookup)
+fx_c_opsq_s_any(fx_c_opuq_t, u_lookup, t_lookup)
+
+
+#define fx_c_opsq_s_direct_any(Name, Lookup1, Lookup2) \
+ 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))); \
+ }
+
+fx_c_opsq_s_direct_any(fx_c_opsq_s_direct, s_lookup, s_lookup)
+fx_c_opsq_s_direct_any(fx_c_optq_s_direct, t_lookup, s_lookup)
+fx_c_opsq_s_direct_any(fx_c_opuq_t_direct, u_lookup, t_lookup)
+
+#define fx_cons_car_s_s_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer p = Lookup1(sc, opt1_sym(cdr(arg)), arg); \
+ if (is_pair(p)) return(cons(sc, car(p), Lookup2(sc, opt3_sym(arg), arg))); \
+ return(cons(sc, car_p_p(sc, p), Lookup2(sc, opt3_sym(arg), arg))); \
+ }
+
+fx_cons_car_s_s_any(fx_cons_car_s_s, s_lookup, s_lookup)
+fx_cons_car_s_s_any(fx_cons_car_t_s, t_lookup, s_lookup)
+fx_cons_car_s_s_any(fx_cons_car_t_v, t_lookup, v_lookup)
+fx_cons_car_s_s_any(fx_cons_car_u_t, u_lookup, t_lookup)
+
+
+static s7_pointer fx_cons_opuq_t(s7_scheme *sc, s7_pointer arg)
+{
+ return(cons(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, u_lookup(sc, opt1_sym(cdr(arg)), arg)), t_lookup(sc, opt3_sym(arg), arg)));
+}
+
+#define fx_c_opsq_cs_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t3_1, fn_proc(cadr(arg))(sc, with_list_t1(Lookup1(sc, opt3_sym(cdr(arg)), arg)))); /* cadadr(arg); */ \
+ set_car(sc->t3_2, opt1_con(cdr(arg))); /* caddr(arg) or cadaddr(arg) */ \
+ set_car(sc->t3_3, Lookup2(sc, opt2_sym(cdr(arg)), arg)); /* cadddr(arg); */ \
+ return(fn_proc(arg)(sc, sc->t3_1)); \
+ }
+
+fx_c_opsq_cs_any(fx_c_opsq_cs, s_lookup, s_lookup)
+fx_c_opsq_cs_any(fx_c_optq_cu, t_lookup, u_lookup)
+
+
+#define fx_c_opsq_c_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t2_1, fn_proc(cadr(arg))(sc, with_list_t1(Lookup(sc, opt1_sym(cdr(arg)), arg)))); /* cadadr */ \
+ set_car(sc->t2_2, opt2_con(cdr(arg))); \
+ return(fn_proc(arg)(sc, sc->t2_1)); \
+ }
+
+fx_c_opsq_c_any(fx_c_opsq_c, s_lookup)
+fx_c_opsq_c_any(fx_c_optq_c, t_lookup)
+
+
+static s7_pointer fx_c_optq_c_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt3_direct(arg))(sc, ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)), opt2_con(cdr(arg))));
+}
+
+static s7_pointer fx_c_optq_i_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_ii_t)opt3_direct(arg))(sc, ((s7_i_7p_t)opt3_direct(cdr(arg)))(sc, t_lookup(sc, opt1_sym(cdr(arg)), arg)), integer(opt2_con(cdr(arg)))));
+}
+
+static s7_pointer fx_memq_car_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = opt2_con(cdr(arg));
+ s7_pointer obj = lookup(sc, opt1_sym(cdr(arg)));
+ obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj));
+ while (true) LOOP_4(if (obj == car(x)) return(x); x = cdr(x); if (!is_pair(x)) return(sc->F));
+ return(sc->F);
+}
+
+static s7_pointer fx_memq_car_s_2(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = opt2_con(cdr(arg));
+ s7_pointer obj = lookup(sc, opt1_sym(cdr(arg)));
+ obj = (is_pair(obj)) ? car(obj) : g_car(sc, set_plist_1(sc, obj));
+ if (obj == car(x)) return(x);
+ return((obj == cadr(x)) ? cdr(x) : sc->F);
+}
+
+static s7_pointer fx_c_s_opssq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = caddr(arg);
+ set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t2(lookup(sc, cadr(largs)), lookup(sc, opt2_sym(cdr(largs))))));
+ set_car(sc->t2_1, lookup(sc, cadr(arg)));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+#define fx_c_s_opssq_direct_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(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)))); \
+ }
+
+fx_c_s_opssq_direct_any(fx_c_s_opssq_direct, s_lookup, s_lookup)
+fx_c_s_opssq_direct_any(fx_c_s_opstq_direct, s_lookup, t_lookup)
+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))))));
+}
+
+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))));
+}
+
+static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = caddr(arg);
+ set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t2(lookup(sc, cadr(largs)), lookup(sc, opt2_sym(cdr(largs))))));
+ set_car(sc->t2_1, cadr(arg)); /* currently (<safe-f> 'a <opssq>) goes to safe_c_ca so this works by inadvertence */
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_c_opssq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, cadr(arg), /* see above */
+ ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), lookup(sc, opt1_sym(cdr(arg))))));
+}
+
+static s7_pointer fx_c_nc_opssq_direct(s7_scheme *sc, s7_pointer arg) /* clm2xen (* 1.0 (oscil g2 x2)) */
+{
+ s7_double x2 = ((s7_d_pd_t)opt3_direct(cdr(arg)))(lookup(sc, opt3_sym(arg)), real_to_double(sc, lookup(sc, opt1_sym(cdr(arg))), __func__));
+ return(((s7_p_dd_t)opt2_direct(cdr(arg)))(sc, real_to_double(sc, cadr(arg), __func__), x2));
+}
+
+static s7_pointer fx_multiply_c_opssq(s7_scheme *sc, s7_pointer arg) /* (* c=float (* x1 x2))! */
+{
+ s7_pointer x1 = lookup(sc, opt3_sym(arg));
+ s7_pointer x2 = lookup(sc, opt1_sym(cdr(arg)));
+ if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(cadr(arg)) * real(x1) * real(x2)));
+ 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)); \
+ }
+
+fx_c_s_opscq_any(fx_c_s_opscq, s_lookup, s_lookup)
+fx_c_s_opscq_any(fx_c_u_optcq, u_lookup, t_lookup)
+/* also fx_c_T_optcq */
+
+static s7_pointer fx_c_s_opscq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), ((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), opt1_con(cdr(arg)))));
+}
+
+static s7_pointer fx_c_s_opsiq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)),
+ ((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt3_sym(arg)), integer(opt1_con(cdr(arg))))));
+}
+
+static s7_pointer fx_c_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))))));
+}
+
+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))))));
+}
+
+static s7_pointer fx_vref_p1(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer i = lookup(sc, opt3_sym(arg));
+ s7_pointer v = lookup(sc, cadr(arg));
+ if ((is_t_integer(i)) && (is_t_vector(v)) && (vector_rank(v) == 1))
+ {
+ s7_int index = integer(i) + 1;
+ if ((index >= 0) && (vector_length(v) > index))
+ return(vector_element(v, index));
+ }
+ return(vector_ref_p_pp(sc, v, g_add_xi(sc, i, 1, 2)));
+}
+
+static s7_pointer fx_num_eq_add_s_si(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer i1 = lookup(sc, cadr(arg));
+ s7_pointer i2 = lookup(sc, opt3_sym(arg));
+ if ((is_t_integer(i1)) && (is_t_integer(i2)))
+ return(make_boolean(sc, integer(i1) == (integer(i2) + integer(opt1_con(cdr(arg))))));
+ return(make_boolean(sc, num_eq_b_7pp(sc, i1, g_add_xi(sc, i2, integer(opt1_con(cdr(arg))), 2))));
+}
+
+static s7_pointer fx_num_eq_subtract_s_si(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer i1 = lookup(sc, cadr(arg));
+ s7_pointer i2 = lookup(sc, opt3_sym(arg));
+ if ((is_t_integer(i1)) && (is_t_integer(i2)))
+ return(make_boolean(sc, integer(i1) == (integer(i2) - integer(opt1_con(cdr(arg))))));
+ return(make_boolean(sc, num_eq_b_7pp(sc, i1, g_sub_xi(sc, i2, integer(opt1_con(cdr(arg)))))));
+}
+
+#define fx_c_t_opscq_direct_any(Name, Lookup) \
+ 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))))); \
+ }
+
+fx_c_t_opscq_direct_any(fx_c_t_opscq_direct, s_lookup)
+fx_c_t_opscq_direct_any(fx_c_t_opucq_direct, u_lookup)
+
+
+static s7_pointer fx_c_s_opsq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = caddr(arg);
+ set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs)))));
+ set_car(sc->t2_1, lookup(sc, cadr(arg)));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+#define fx_c_s_opsq_direct_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ arg = cdr(arg); \
+ return(((s7_p_pp_t)opt2_direct(arg))(sc, Lookup1(sc, car(arg), arg), ((s7_p_p_t)opt3_direct(arg))(sc, Lookup2(sc, opt1_sym(arg), arg)))); /* cadadr */ \
+ }
+
+fx_c_s_opsq_direct_any(fx_c_s_opsq_direct, s_lookup, s_lookup)
+fx_c_s_opsq_direct_any(fx_c_t_opsq_direct, t_lookup, s_lookup)
+fx_c_s_opsq_direct_any(fx_c_t_opuq_direct, t_lookup, u_lookup)
+fx_c_s_opsq_direct_any(fx_c_u_opvq_direct, u_lookup, v_lookup)
+
+#define fx_c_s_car_s_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer val = Lookup2(sc, opt2_sym(cdr(arg)), arg); \
+ set_car(sc->t2_2, (is_pair(val)) ? car(val) : g_car(sc, set_plist_1(sc, val))); \
+ set_car(sc->t2_1, Lookup1(sc, cadr(arg), arg)); \
+ return(fn_proc(arg)(sc, sc->t2_1)); \
+ }
+
+fx_c_s_car_s_any(fx_c_s_car_s, s_lookup, s_lookup)
+fx_c_s_car_s_any(fx_c_s_car_t, s_lookup, t_lookup)
+fx_c_s_car_s_any(fx_c_t_car_u, t_lookup, u_lookup)
+fx_c_s_car_s_any(fx_c_t_car_v, t_lookup, v_lookup)
+
+
+#define fx_add_s_car_s_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer val1 = Lookup1(sc, cadr(arg), arg); \
+ s7_pointer val2 = Lookup2(sc, opt2_sym(cdr(arg)), arg); \
+ val2 = (is_pair(val2)) ? car(val2) : g_car(sc, set_plist_1(sc, val2)); \
+ return(((is_t_integer(val1)) && (is_t_integer(val2))) ? make_integer(sc, integer(val1) + integer(val2)) : add_p_pp(sc, val1, val2)); \
+ }
+
+fx_add_s_car_s_any(fx_add_s_car_s, s_lookup, s_lookup)
+fx_add_s_car_s_any(fx_add_u_car_t, u_lookup, t_lookup)
+fx_add_s_car_s_any(fx_add_t_car_v, t_lookup, v_lookup)
+
+
+static s7_pointer fx_cons_s_cdr_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer val = lookup(sc, opt2_sym(cdr(arg)));
+ val = (is_pair(val)) ? cdr(val) : g_cdr(sc, set_plist_1(sc, val));
+ return(cons(sc, lookup(sc, cadr(arg)), val));
+}
+
+static s7_pointer fx_c_op_s_opsqq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer outer = cadr(arg);
+ s7_pointer args = caddr(outer);
+ set_car(sc->t2_2, fn_proc(args)(sc, with_list_t1(lookup(sc, cadr(args)))));
+ set_car(sc->t2_1, lookup(sc, cadr(outer)));
+ return(fn_proc(arg)(sc, with_list_t1(fn_proc(outer)(sc, sc->t2_1))));
+}
+
+static s7_pointer fx_not_op_s_opsqq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer outer = cadr(arg);
+ s7_pointer args = caddr(outer);
+ set_car(sc->t2_2, fn_proc(args)(sc, with_list_t1(lookup(sc, cadr(args)))));
+ set_car(sc->t2_1, lookup(sc, cadr(outer)));
+ return(((fn_proc(outer)(sc, sc->t2_1)) == sc->F) ? sc->T : sc->F);
+}
+
+static s7_pointer fx_c_op_opsq_sq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer outer = cadr(arg);
+ s7_pointer args = cadr(outer);
+ set_car(sc->t2_1, fn_proc(args)(sc, with_list_t1(lookup(sc, cadr(args)))));
+ set_car(sc->t2_2, lookup(sc, caddr(outer)));
+ return(fn_proc(arg)(sc, with_list_t1(fn_proc(outer)(sc, sc->t2_1))));
+}
+
+static s7_pointer fx_not_op_optq_sq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer outer = cadr(arg);
+ s7_pointer args = cadr(outer);
+ set_car(sc->t2_1, fn_proc(args)(sc, with_list_t1(t_lookup(sc, cadr(args), arg))));
+ set_car(sc->t2_2, lookup(sc, caddr(outer)));
+ return((fn_proc(outer)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F);
+}
+
+static s7_pointer fx_c_c_opsq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = opt3_pair(arg); /* caddr(arg); */
+ set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs)))));
+ set_car(sc->t2_1, cadr(arg));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_c_opsq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt2_direct(cdr(arg)))(sc, cadr(arg), ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, lookup(sc, opt1_sym(cdr(arg))))));
+}
+
+/* perhaps fx_c_c_opt|T|Vq_direct tlet/tmisc */
+
+static s7_pointer fx_c_opsq_opsq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = cdr(arg);
+ gc_protect_via_stack(sc, fn_proc(car(largs))(sc, with_list_t1(lookup(sc, cadar(largs)))));
+ largs = cadr(largs);
+ set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs)))));
+ set_car(sc->t2_1, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+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)opt3_direct(cdr(arg)))(sc, lookup(sc, opt1_sym(cdr(arg)))))); /* cadaddr(arg) */
+}
+
+static s7_pointer fx_c_optq_optq_direct(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* cadadr and cadaddr */
+ return(((s7_p_pp_t)opt3_direct(arg))(sc, ((s7_p_p_t)opt2_direct(cdr(arg)))(sc, x), ((s7_p_p_t)opt3_direct(cdr(arg)))(sc, x)));
+}
+
+#define fx_car_s_car_s_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ s7_pointer p1 = Lookup1(sc, opt1_sym(cdr(arg)), arg); \
+ s7_pointer p2 = Lookup2(sc, opt2_sym(cdr(arg)), arg); /* cadaddr(arg) */ \
+ return(((s7_p_pp_t)opt3_direct(arg))(sc, (is_pair(p1)) ? car(p1) : g_car(sc, set_plist_1(sc, p1)), \
+ (is_pair(p2)) ? car(p2) : g_car(sc, set_plist_1(sc, p2)))); \
+ }
+
+fx_car_s_car_s_any(fx_car_s_car_s, s_lookup, s_lookup)
+fx_car_s_car_s_any(fx_car_t_car_u, t_lookup, u_lookup)
+
+
+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))));
+}
+
+static s7_pointer fx_is_eq_car_car_tu(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p1 = t_lookup(sc, opt1_sym(cdr(arg)), arg);
+ s7_pointer p2 = u_lookup(sc, opt2_sym(cdr(arg)), arg);
+ p1 = (is_pair(p1)) ? car(p1) : g_car(sc, set_plist_1(sc, p1));
+ p2 = (is_pair(p2)) ? car(p2) : g_car(sc, set_plist_1(sc, p2));
+ return(make_boolean(sc, (p1 == p2) || ((is_unspecified(p1)) && (is_unspecified(p2)))));
+}
+
+static s7_pointer fx_c_opsq_opssq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = cdr(arg);
+ gc_protect_via_stack(sc, fn_proc(car(largs))(sc, with_list_t1(lookup(sc, cadar(largs)))));
+ largs = cadr(largs);
+ set_car(sc->t2_1, lookup(sc, cadr(largs)));
+ set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs)))); /* caddr(largs) */
+ set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1));
+ set_car(sc->t2_1, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+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_pp_t)opt3_direct(largs))(sc, t_lookup(sc, opt2_sym(cdr(largs)), arg), u_lookup(sc, opt1_sym(largs), arg))));
+}
+
+static s7_pointer fx_num_eq_car_v_add_tu(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg));
+ s7_pointer p2 = t_lookup(sc, opt2_sym(cddr(arg)), arg);
+ s7_pointer p3 = u_lookup(sc, opt1_sym(cdr(arg)), arg);
+ if ((is_t_integer(p1)) && (is_t_integer(p2)) && (is_t_integer(p3)))
+ return(make_boolean(sc, integer(p1) == (integer(p2) + integer(p3))));
+ return(make_boolean(sc, num_eq_b_7pp(sc, p1, add_p_pp(sc, p2, p3))));
+}
+
+static s7_pointer fx_num_eq_car_v_subtract_tu(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg));
+ s7_pointer p2 = t_lookup(sc, opt2_sym(cddr(arg)), arg);
+ s7_pointer p3 = u_lookup(sc, opt1_sym(cdr(arg)), arg);
+ if ((is_t_integer(p1)) && (is_t_integer(p2)) && (is_t_integer(p3)))
+ return(make_boolean(sc, integer(p1) == (integer(p2) - integer(p3))));
+ return(make_boolean(sc, num_eq_b_7pp(sc, p1, subtract_p_pp(sc, p2, p3))));
+}
+
+static s7_pointer fx_c_opssq_opsq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = cdr(arg);
+ set_car(sc->t2_1, lookup(sc, cadar(largs)));
+ set_car(sc->t2_2, lookup(sc, opt2_sym(cdar(largs))));
+ gc_protect_via_stack(sc, fn_proc(car(largs))(sc, sc->t2_1));
+ largs = cadr(largs);
+ set_car(sc->t2_2, fn_proc(largs)(sc, with_list_t1(lookup(sc, cadr(largs)))));
+ set_car(sc->t2_1, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_opssq_opssq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = cdr(arg);
+ set_car(sc->t2_1, lookup(sc, cadar(largs)));
+ set_car(sc->t2_2, lookup(sc, opt2_sym(cdar(largs))));
+ gc_protect_via_stack(sc, fn_proc(car(largs))(sc, sc->t2_1));
+ largs = cadr(largs);
+ set_car(sc->t2_1, lookup(sc, cadr(largs)));
+ set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(largs))));
+ set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1));
+ set_car(sc->t2_1, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_sub_mul_mul(s7_scheme *sc, s7_pointer arg) /* (- (* s1 s2) (* s3 s4)) */
+{
+ s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */
+ s7_pointer s1 = lookup(sc, car(a1));
+ s7_pointer s2 = lookup(sc, cadr(a1));
+ s7_pointer a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ /* here and elsewhere this should be GC safe -- opssq->* (no methods?) etc */
+ s7_pointer s3 = lookup(sc, car(a2));
+ s7_pointer s4 = lookup(sc, cadr(a2));
+ if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3)) && (is_t_real(s4)))
+ return(make_real(sc, (real(s3) * real(s4)) - (real(s1) * real(s2))));
+ sc->temp5 = multiply_p_pp(sc, s1, s2);
+ return(subtract_p_pp(sc, multiply_p_pp(sc, s3, s4), sc->temp5));
+}
+
+static s7_pointer fx_add_mul_mul(s7_scheme *sc, s7_pointer arg) /* (+ (* s1 s2) (* s3 s4)) */
+{
+ s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */
+ s7_pointer s1 = lookup(sc, car(a1));
+ s7_pointer s2 = lookup(sc, cadr(a1));
+ s7_pointer a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */
+ s7_pointer s3 = lookup(sc, car(a2));
+ s7_pointer s4 = lookup(sc, cadr(a2));
+ if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3)) && (is_t_real(s4)))
+ return(make_real(sc, (real(s3) * real(s4)) + (real(s1) * real(s2))));
+ sc->temp5 = multiply_p_pp(sc, s1, s2);
+ return(add_p_pp(sc, multiply_p_pp(sc, s3, s4), sc->temp5));
+}
+
+static s7_pointer fx_mul_sub_sub(s7_scheme *sc, s7_pointer arg) /* (* (- s1 s2) (- s3 s4)) */
+{
+ s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */
+ s7_pointer s1 = lookup(sc, car(a1));
+ s7_pointer s2 = lookup(sc, cadr(a1));
+ s7_pointer a2 = opt1_pair(cdr(arg)); /* cdadr(arg) */
+ s7_pointer s3 = lookup(sc, car(a2));
+ s7_pointer s4 = lookup(sc, cadr(a2));
+ if ((is_t_real(s1)) && (is_t_real(s2)) && (is_t_real(s3)) && (is_t_real(s4)))
+ return(make_real(sc, (real(s3) - real(s4)) * (real(s1) - real(s2))));
+ sc->temp5 = subtract_p_pp(sc, s1, s2);
+ return(multiply_p_pp(sc, subtract_p_pp(sc, s3, s4), sc->temp5));
+}
+
+static s7_pointer fx_lt_sub2(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer a1 = opt3_pair(arg); /* cdaddr(arg); */
+ sc->temp5 = subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1)));
+ a1 = opt1_pair(cdr(arg)); /* cdadr(arg) */
+ return(lt_p_pp(sc, subtract_p_pp(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))), sc->temp5));
+}
+
+static s7_pointer fx_sub_vref2(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer a1 = cdadr(arg);
+ s7_pointer v1 = lookup(sc, car(a1));
+ s7_pointer p1 = lookup(sc, cadr(a1));
+ s7_pointer p2 = lookup(sc, opt3_sym(arg)); /* caddaddr(arg)); */
+ if ((is_t_integer(p1)) && (is_t_integer(p2)) && ((is_t_vector(v1)) && (vector_rank(v1) == 1)))
+ {
+ 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_pp(sc, v1, p1), vector_ref_p_pp(sc, v1, p2)));
+}
+
+static s7_pointer fx_c_op_opsqq(s7_scheme *sc, s7_pointer code)
+{
+ set_car(sc->t1_1, fn_proc(opt3_pair(code))(sc, with_list_t1(lookup(sc, opt3_sym(cdr(code))))));
+ set_car(sc->t1_1, fn_proc(cadr(code))(sc, sc->t1_1));
+ return(fn_proc(code)(sc, sc->t1_1));
+}
+
+static s7_pointer fx_not_op_opsqq(s7_scheme *sc, s7_pointer code)
+{
+ set_car(sc->t1_1, fn_proc(opt3_pair(code))(sc, with_list_t1(lookup(sc, opt3_sym(cdr(code))))));
+ return((fn_proc(cadr(code))(sc, sc->t1_1) == sc->F) ? sc->T : sc->F);
+}
+
+static s7_pointer fx_not_is_pair_opsq(s7_scheme *sc, s7_pointer code)
+{
+ return(make_boolean(sc, !is_pair(fn_proc(opt3_pair(code))(sc, set_plist_1(sc, lookup(sc, opt3_sym(cdr(code))))))));
+}
+
+static s7_pointer fx_sref_t_last(s7_scheme *sc, s7_pointer arg) {return(string_ref_p_plast(sc, t_lookup(sc, cadr(arg), arg), int_zero));} /* both syms are t_lookup */
+
+static s7_pointer fx_c_a(s7_scheme *sc, s7_pointer arg)
+{
+ return(fn_proc(arg)(sc, with_list_t1(fx_call(sc, cdr(arg)))));
+}
+
+static s7_pointer fx_c_a_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_p_t)opt3_direct(arg))(sc, fx_call(sc, cdr(arg))));}
+static s7_pointer fx_not_a(s7_scheme *sc, s7_pointer arg) {return((fx_call(sc, cdr(arg)) == sc->F) ? sc->T : sc->F);}
+
+static s7_pointer fx_c_saa(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer res;
+ gc_protect_via_stack(sc, fx_call(sc, opt3_pair(arg))); /* opt3_pair=cddr */
+ set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
+ set_car(sc->t3_1, lookup(sc, cadr(arg)));
+ set_car(sc->t3_2, stack_protected1(sc));
+ res = fn_proc(arg)(sc, sc->t3_1);
+ unstack_gc_protect(sc);
+ return(res);
+}
+
+#define fx_c_ssa_any(Name, Lookup1, Lookup2) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg)))); \
+ set_car(sc->t3_1, Lookup1(sc, cadr(arg), arg));\
+ set_car(sc->t3_2, Lookup2(sc, car(opt3_pair(arg)), arg)); \
+ return(fn_proc(arg)(sc, sc->t3_1));\
+ }
+
+fx_c_ssa_any(fx_c_ssa, s_lookup, s_lookup)
+fx_c_ssa_any(fx_c_tsa, t_lookup, s_lookup)
+fx_c_ssa_any(fx_c_sta, s_lookup, t_lookup)
+
+static s7_pointer fx_c_ssa_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_ppp_t)opt2_direct(cdr(arg)))(sc, lookup(sc, cadr(arg)), lookup(sc, car(opt3_pair(arg))), fx_call(sc, cdr(opt3_pair(arg)))));
+}
+
+static s7_pointer fx_c_ass(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t3_1, fx_call(sc, cdr(arg)));
+ set_car(sc->t3_2, lookup(sc, car(opt3_pair(arg))));
+ set_car(sc->t3_3, lookup(sc, cadr(opt3_pair(arg))));
+ return(fn_proc(arg)(sc, sc->t3_1));
+}
+
+static s7_pointer fx_c_agg(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t3_1, fx_call(sc, cdr(arg)));
+ set_car(sc->t3_2, fx_call(sc, opt3_pair(arg)));
+ set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
+ return(fn_proc(arg)(sc, sc->t3_1));
+}
+
+static s7_pointer fx_c_sas(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t3_2, fx_call(sc, opt3_pair(arg)));
+ set_car(sc->t3_1, lookup(sc, cadr(arg)));
+ set_car(sc->t3_3, lookup(sc, cadr(opt3_pair(arg))));
+ return(fn_proc(arg)(sc, sc->t3_1));
+}
+
+static s7_pointer fx_c_sca(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
+ set_car(sc->t3_1, lookup(sc, cadr(arg)));
+ set_car(sc->t3_2, car(opt3_pair(arg)));
+ return(fn_proc(arg)(sc, sc->t3_1));
+}
+
+static s7_pointer fx_c_Tca(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
+ set_car(sc->t3_1, T_lookup(sc, cadr(arg), arg));
+ set_car(sc->t3_2, car(opt3_pair(arg)));
+ return(fn_proc(arg)(sc, sc->t3_1));
+}
+
+static s7_pointer fx_c_csa(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
+ set_car(sc->t3_1, cadr(arg));
+ set_car(sc->t3_2, lookup(sc, car(opt3_pair(arg))));
+ return(fn_proc(arg)(sc, sc->t3_1));
+}
+
+static s7_pointer fx_c_cac(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t3_2, fx_call(sc, opt3_pair(arg)));
+ set_car(sc->t3_1, cadr(arg));
+ set_car(sc->t3_3, cadr(opt3_pair(arg)));
+ return(fn_proc(arg)(sc, sc->t3_1));
+}
+
+static s7_pointer fx_c_aa(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer res;
+ /* check_stack_size(sc); */
+ gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* opt3_pair = cddr(arg) */
+ set_car(sc->t2_1, T_Ext(stack_protected1(sc)));
+ set_car(sc->t2_2, stack_protected2(sc));
+ res = fn_proc(arg)(sc, sc->t2_1);
+ unstack_gc_protect(sc);
+ return(res);
+}
+
+static s7_pointer fx_c_ca(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t2_2, fx_call(sc, cddr(arg)));
+ set_car(sc->t2_1, opt3_con(arg));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_ac(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t2_1, fx_call(sc, cdr(arg)));
+ set_car(sc->t2_2, opt3_con(arg));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_ac_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, fx_call(sc, cdr(arg)), opt3_con(arg)));}
+static s7_pointer fx_c_ai_direct(s7_scheme *sc, s7_pointer arg) {return(((s7_p_pi_t)opt3_direct(cdr(arg)))(sc, fx_call(sc, cdr(arg)), integer(opt3_con(arg))));}
+
+static s7_pointer fx_sub_a1(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = fx_call(sc, cdr(arg));
+ if (is_t_integer(p)) return(subtract_if_overflow_to_real_or_big_integer(sc, integer(p), 1));
+ if (is_t_real(p)) return(make_real(sc, real(p) - 1.0));
+ return(subtract_p_pp(sc, p, int_one));
+}
+
+static s7_pointer fx_add_a1(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = fx_call(sc, cdr(arg));
+ if (is_t_integer(p)) return(add_if_overflow_to_real_or_big_integer(sc, integer(p), 1));
+ if (is_t_real(p)) return(make_real(sc, real(p) + 1.0));
+ return(add_p_pp(sc, p, int_one));
+}
+
+static s7_pointer fx_lt_ad(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = fx_call(sc, cdr(arg));
+ if (is_t_real(p)) return(make_boolean(sc, real(p) < real(opt3_con(arg))));
+ if (is_t_integer(p)) return(make_boolean(sc, integer(p) < real(opt3_con(arg))));
+ return(make_boolean(sc, lt_b_7pp(sc, p, opt3_con(arg))));
+}
+
+static s7_pointer fx_is_eq_ac(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer y = opt3_con(arg);
+ s7_pointer x = fx_call(sc, cdr(arg));
+ return(make_boolean(sc, (x == y) || ((is_unspecified(x)) && (is_unspecified(y)))));
+}
+
+#define fx_c_sa_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t2_2, fx_call(sc, cddr(arg))); \
+ set_car(sc->t2_1, Lookup(sc, opt3_sym(arg), arg)); \
+ return(fn_proc(arg)(sc, sc->t2_1)); \
+ }
+
+fx_c_sa_any(fx_c_sa, s_lookup)
+fx_c_sa_any(fx_c_ta, t_lookup)
+fx_c_sa_any(fx_c_ua, u_lookup)
+
+#define fx_c_sa_direct_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, Lookup(sc, opt3_sym(arg), arg), fx_call(sc, cddr(arg)))); \
+ }
+
+fx_c_sa_direct_any(fx_c_sa_direct, s_lookup)
+fx_c_sa_direct_any(fx_c_ua_direct, u_lookup)
+
+static s7_pointer fx_cons_ca(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt3_con(arg), fx_call(sc, cddr(arg))));}
+static s7_pointer fx_cons_ac(s7_scheme *sc, s7_pointer arg) {return(cons(sc, sc->temp3 = fx_call(sc, cdr(arg)), opt3_con(arg)));}
+static s7_pointer fx_cons_sa(s7_scheme *sc, s7_pointer arg) {return(cons(sc, lookup(sc, opt3_sym(arg)), fx_call(sc, cddr(arg))));}
+static s7_pointer fx_cons_as(s7_scheme *sc, s7_pointer arg) {return(cons(sc, sc->temp3 = fx_call(sc, cdr(arg)), lookup(sc, opt3_sym(arg))));}
+static s7_pointer fx_cons_aa(s7_scheme *sc, s7_pointer arg) {return(cons(sc, sc->temp3 = fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))));}
+
+#define fx_c_as_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ set_car(sc->t2_1, fx_call(sc, cdr(arg))); \
+ set_car(sc->t2_2, Lookup(sc, opt3_sym(arg), arg)); \
+ return(fn_proc(arg)(sc, sc->t2_1)); \
+ }
+
+fx_c_as_any(fx_c_as, s_lookup)
+fx_c_as_any(fx_c_at, t_lookup)
+
+static s7_pointer fx_c_as_direct(s7_scheme *sc, s7_pointer arg)
+{
+ return(((s7_p_pp_t)opt3_direct(cdr(arg)))(sc, fx_call(sc, cdr(arg)), lookup(sc, opt3_sym(arg))));
+}
+
+static s7_pointer fx_add_as(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x1 = fx_call(sc, cdr(arg));
+ s7_pointer x2 = lookup(sc, opt3_sym(arg));
+ if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) + real(x2)));
+ return(add_p_pp(sc, x1, x2));
+}
+
+static s7_pointer fx_multiply_sa(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x1 = lookup(sc, cadr(arg));
+ s7_pointer x2 = fx_call(sc, cddr(arg));
+ if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) * real(x2)));
+ return(multiply_p_pp(sc, x1, x2));
+}
+
+static s7_pointer fx_subtract_aa(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x2;
+ s7_pointer x1 = fx_call(sc, cdr(arg));
+ sc->value = x1;
+ x2 = fx_call(sc, opt3_pair(arg));
+ if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) - real(x2)));
+ return(subtract_p_pp(sc, x1, x2));
+}
+
+static s7_pointer fx_add_aa(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x2;
+ s7_pointer x1 = fx_call(sc, cdr(arg));
+ sc->value = x1;
+ x2 = fx_call(sc, opt3_pair(arg));
+ if (is_t_real(x1)) {if (is_t_real(x2)) return(make_real(sc, real(x1) + real(x2)));}
+ else if ((is_t_integer(x1)) && (is_t_integer(x2))) return(make_integer(sc, integer(x1) + integer(x2)));
+ /* maybe use add_if_overflow_to_real_or_big_integer, but that seems unnecessary currently */
+ return(add_p_pp(sc, x1, x2));
+}
+
+static s7_pointer fx_multiply_aa(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x2;
+ s7_pointer x1 = fx_call(sc, cdr(arg));
+ sc->value = x1;
+ x2 = fx_call(sc, opt3_pair(arg));
+ if ((is_t_real(x1)) && (is_t_real(x2))) return(make_real(sc, real(x1) * real(x2)));
+ return(multiply_p_pp(sc, x1, x2));
+}
+
+static s7_pointer fx_add_sa(s7_scheme *sc, s7_pointer arg) {return(add_p_pp(sc, lookup(sc, opt3_sym(arg)), fx_call(sc, cddr(arg))));}
+static s7_pointer fx_number_to_string_aa(s7_scheme *sc, s7_pointer arg) {return(number_to_string_p_pp(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))));}
+
+static s7_pointer fx_c_3g(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t3_1, fx_call(sc, cdr(arg)));
+ set_car(sc->t3_2, fx_call(sc, opt3_pair(arg)));
+ set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
+ return(fn_proc(arg)(sc, sc->t3_1));
+}
+
+static s7_pointer fx_c_aaa(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer res;
+ /* check_stack_size(sc); */
+ gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg)));
+ set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
+ set_car(sc->t3_2, stack_protected2(sc));
+ set_car(sc->t3_1, stack_protected1(sc));
+ res = fn_proc(arg)(sc, sc->t3_1);
+ unstack_gc_protect(sc);
+ return(res);
+}
+
+static s7_pointer fx_c_gac(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t3_2, fx_call(sc, opt3_pair(arg)));
+ set_car(sc->t3_3, cadr(opt3_pair(arg)));
+ set_car(sc->t3_1, lookup_global(sc, cadr(arg)));
+ return(fn_proc(arg)(sc, sc->t3_1));
+}
+
+static s7_pointer fx_c_opaq_s(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t2_1, fn_proc(cadr(arg))(sc, with_list_t1(fx_call(sc, cdadr(arg)))));
+ set_car(sc->t2_2, lookup_checked(sc, caddr(arg)));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_s_opaq(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t2_2, fn_proc(caddr(arg))(sc, with_list_t1(fx_call(sc, opt3_pair(arg))))); /* cdaddr(arg); */
+ set_car(sc->t2_1, lookup_checked(sc, cadr(arg)));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_opaq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = cadr(arg);
+ set_car(sc->t1_1, fx_call(sc, cdr(p)));
+ return(fn_proc(arg)(sc, with_list_t1(fn_proc(p)(sc, sc->t1_1))));
+}
+
+static s7_pointer fx_c_opaaq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = cadr(arg), res;
+ /* check_stack_size(sc); */
+ gc_protect_via_stack(sc, fx_call(sc, cdr(p)));
+ set_car(sc->t2_2, fx_call(sc, cddr(p)));
+ set_car(sc->t2_1, stack_protected1(sc));
+ res = fn_proc(p)(sc, sc->t2_1);
+ set_stack_protected2(sc, res); /* might be a big list etc (see s7test.scm fx_c_opaaq test) */
+ res = fn_proc(arg)(sc, with_list_t1(res));
+ unstack_gc_protect(sc);
+ return(res);
+}
+
+static s7_pointer fx_c_opsaq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = cadr(arg);
+ set_car(sc->t2_2, fx_call(sc, cddr(p)));
+ set_car(sc->t2_1, lookup(sc, cadr(p)));
+ return(fn_proc(arg)(sc, with_list_t1(fn_proc(p)(sc, sc->t2_1))));
+}
+
+static s7_pointer fx_c_opaaaq(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer arg = cadr(code), res;
+ gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg)), fx_call(sc, opt3_pair(arg))); /* cddr(arg) */
+ set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg))));
+ set_car(sc->t3_1, stack_protected1(sc));
+ set_car(sc->t3_2, stack_protected2(sc));
+ res = fn_proc(code)(sc, with_list_t1(fn_proc(arg)(sc, sc->t3_1)));
+ unstack_gc_protect(sc);
+ return(res);
+}
+
+static s7_pointer fx_c_s_opaaq(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer arg = caddr(code), res;
+ gc_protect_via_stack(sc, fx_call(sc, cdr(arg)));
+ set_car(sc->t2_2, fx_call(sc, cddr(arg)));
+ set_car(sc->t2_1, stack_protected1(sc));
+ set_car(sc->t2_2, fn_proc(arg)(sc, sc->t2_1));
+ set_car(sc->t2_1, lookup(sc, cadr(code)));
+ res = fn_proc(code)(sc, sc->t2_1);
+ unstack_gc_protect(sc);
+ return(res);
+}
+
+static s7_pointer fx_c_4a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer res = cdr(code);
+ check_stack_size(sc); /* t718 pp cycles #f */
+ gc_protect_2_via_stack(sc, fx_call(sc, res), fx_call(sc, cdr(res)));
+ res = cddr(res);
+ set_stack_protected3(sc, fx_call(sc, res));
+ set_car(sc->t3_3, fx_call(sc, cdr(res)));
+ set_car(sc->t3_2, stack_protected3(sc));
+ set_car(sc->t3_1, stack_protected2(sc));
+ set_car(sc->t4_1, stack_protected1(sc));
+ res = fn_proc(code)(sc, sc->t4_1);
+ unstack_gc_protect(sc);
+ set_car(sc->t4_1, sc->F);
+ return(res);
+}
+
+static s7_pointer fx_c_4g(s7_scheme *sc, s7_pointer code)
+{ /* all opts in use for code, opt1 free cdr(code), code opt3 is line_number, cdr(code) opt3 is arglen?? */
+ s7_pointer res = cdr(code);
+ set_car(sc->t4_1, fx_call(sc, res));
+ set_car(sc->t3_1, fx_call(sc, cdr(res)));
+ set_car(sc->t3_2, fx_call(sc, opt3_pair(code))); /* cddr(res) */
+ set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(code)))); /* cdddr(res) */
+ res = fn_proc(code)(sc, sc->t4_1);
+ set_car(sc->t4_1, sc->F);
+ return(res);
+}
+
+static s7_pointer fx_c_c_opscq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = caddr(arg);
+ set_car(sc->t2_1, lookup(sc, cadr(largs)));
+ 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, cadr(arg));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_s_opcsq(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer largs = caddr(arg);
+ set_car(sc->t2_2, lookup(sc, caddr(largs)));
+ set_car(sc->t2_1, opt1_con(cdr(largs))); /* cadr(largs) or cadadr */
+ set_car(sc->t2_2, fn_proc(largs)(sc, sc->t2_1));
+ set_car(sc->t2_1, lookup(sc, cadr(arg)));
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_op_opssqq_s(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer arg = opt1_pair(cdr(code));
+ set_car(sc->t2_1, lookup(sc, cadr(arg)));
+ set_car(sc->t2_2, lookup(sc, opt2_sym(cdr(arg))));
+ set_car(sc->t2_1, fn_proc(cadr(code))(sc, with_list_t1(fn_proc(arg)(sc, sc->t2_1))));
+ set_car(sc->t2_2, lookup(sc, caddr(code)));
+ return(fn_proc(code)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_c_op_opssqq_s_direct(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer arg = opt1_pair(cdr(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))));
+}
+
+static s7_pointer fx_c_ns(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p1, lst = safe_list_if_possible(sc, opt3_arglen(cdr(arg)));
+ if (in_heap(lst)) gc_protect_via_stack(sc, lst);
+ for (s7_pointer args = cdr(arg), p = lst; is_pair(args); args = cdr(args), p = cdr(p))
+ set_car(p, lookup(sc, car(args)));
+ p1 = fn_proc(arg)(sc, lst);
+ if (in_heap(lst)) unstack_gc_protect(sc);
+ else clear_list_in_use(lst);
+ return(p1);
+}
+
+static s7_pointer fx_list_ns(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer lst = make_list(sc, opt3_arglen(cdr(arg)), sc->unused);
+ for (s7_pointer args = cdr(arg), p = lst; is_pair(args); args = cdr(args), p = cdr(p))
+ set_car(p, lookup(sc, car(args)));
+ return(lst);
+}
+
+static s7_pointer fx_c_all_ca(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer p1, lst = safe_list_if_possible(sc, opt3_arglen(cdr(code)));
+ if (in_heap(lst)) gc_protect_via_stack(sc, lst);
+ for (s7_pointer args = cdr(code), p = lst; is_pair(args); args = cdr(args), p = cddr(p))
+ {
+ set_car(p, opt2_con(args));
+ args = cdr(args);
+ set_car(cdr(p), fx_call(sc, args));
+ }
+ p1 = fn_proc(code)(sc, lst);
+ if (in_heap(lst)) unstack_gc_protect(sc);
+ else clear_list_in_use(lst);
+ return(p1);
+}
+
+static s7_pointer fx_inlet_ca(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer new_e, sp = NULL;
+ int64_t id;
+
+ new_cell(sc, new_e, T_LET | T_SAFE_PROCEDURE);
+ let_set_slots(new_e, slot_end); /* needed by add_slot_unchecked */
+ let_set_outlet(new_e, sc->rootlet);
+ gc_protect_via_stack(sc, new_e);
+
+ /* as in let, we need to call the var inits before making the new let, but a simpler equivalent is to make the new let
+ * but don't set its id yet, and don't set local_slot until end either because fx_call might refer to same-name symbol in outer let.
+ * That is, symbol_id=outer_let_id so lookup->local_slot, so we better not set local_slot ahead of time here.
+ * As far as I can tell, this is the only place we do fx_call at the time of new_slot with new let id unset.
+ */
+ for (s7_pointer x = cdr(code); is_pair(x); x = cddr(x))
+ {
+ 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);
+ }
+ 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);
+ }
+ else sp = add_slot_at_end_no_local(sc, sp, symbol, value);
+ }
+ id = ++sc->let_number;
+ let_set_id(new_e, id);
+ for (s7_pointer x = let_slots(new_e); tis_slot(x); x = next_slot(x))
+ symbol_set_local_slot_unincremented(slot_symbol(x), id, x); /* was symbol_set_id(slot_symbol(x), id) */
+ unstack_gc_protect(sc);
+ return(new_e);
+}
+
+static s7_pointer fx_c_na(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer args, p, val = safe_list_if_possible(sc, opt3_arglen(cdr(arg)));
+ if (in_heap(val)) gc_protect_via_stack(sc, val);
+ for (args = cdr(arg), p = val; is_pair(args); args = cdr(args), p = cdr(p))
+ set_car(p, fx_call(sc, args));
+ p = fn_proc(arg)(sc, val);
+ if (in_heap(val)) unstack_gc_protect(sc);
+ else clear_list_in_use(val);
+ return(p);
+}
+
+static s7_pointer fx_vector_ns(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer args = cdr(arg);
+ s7_pointer vec = make_simple_vector(sc, opt3_arglen(cdr(arg)));
+ s7_pointer *els = (s7_pointer *)vector_elements(vec);
+ for (s7_int i = 0; is_pair(args); args = cdr(args), i++)
+ els[i] = lookup(sc, car(args));
+ return(vec);
+}
+
+static s7_pointer fx_vector_na(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer args = cdr(arg);
+ s7_pointer v = make_simple_vector(sc, opt3_arglen(cdr(arg))); /* was s7_make_vector */
+ s7_pointer *els = vector_elements(v);
+ gc_protect_via_stack(sc, v);
+ t_vector_fill(v, sc->nil); /* fx_calls below can trigger GC, so all elements of v must be legit */
+ for (s7_int i = 0; is_pair(args); args = cdr(args), i++)
+ els[i] = fx_call(sc, args);
+ sc->value = v; /* full-s7test 12262 list_p_p case */
+ unstack_gc_protect(sc);
+ return(v);
+}
+
+static s7_pointer fx_if_a_a(s7_scheme *sc, s7_pointer arg)
+{
+ return((is_true(sc, fx_call(sc, cdr(arg)))) ? fx_call(sc, opt1_pair(arg)) : sc->unspecified);
+}
+
+static s7_pointer fx_if_not_a_a(s7_scheme *sc, s7_pointer arg)
+{
+ return((is_false(sc, fx_call(sc, opt1_pair(arg)))) ? fx_call(sc, opt2_pair(arg)) : sc->unspecified);
+}
+
+static s7_pointer fx_if_a_a_a(s7_scheme *sc, s7_pointer arg)
+{
+ return((is_true(sc, fx_call(sc, cdr(arg)))) ? fx_call(sc, opt1_pair(arg)) : fx_call(sc, opt2_pair(arg)));
+}
+
+#define fx_if_s_a_a_any(Name, Lookup) \
+ static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \
+ { \
+ return((Lookup(sc, cadr(arg), arg) != sc->F) ? fx_call(sc, opt1_pair(arg)) : fx_call(sc, opt2_pair(arg))); \
+ }
+
+fx_if_s_a_a_any(fx_if_s_a_a, s_lookup)
+fx_if_s_a_a_any(fx_if_o_a_a, o_lookup) /* diff s->o of ca 3 */
+
+
+static s7_pointer fx_if_and2_s_a(s7_scheme *sc, s7_pointer arg)
+{
+ return(((fx_call(sc, opt1_pair(arg)) == sc->F) || (fx_call(sc, opt2_pair(arg)) == sc->F)) ? fx_call(sc, cdddr(arg)) : lookup(sc, opt3_sym(arg)));
+}
+
+static s7_pointer fx_if_not_a_a_a(s7_scheme *sc, s7_pointer arg)
+{
+ return((is_false(sc, fx_call(sc, opt1_pair(arg)))) ? fx_call(sc, opt2_pair(arg)) : fx_call(sc, opt3_pair(arg)));
+}
+
+static s7_pointer fx_if_a_c_c(s7_scheme *sc, s7_pointer arg) {return((is_true(sc, fx_call(sc, cdr(arg)))) ? opt1_con(arg) : opt2_con(arg));}
+
+static s7_pointer fx_if_is_type_s_a_a(s7_scheme *sc, s7_pointer arg)
+{
+ if (gen_type_match(sc, lookup(sc, opt2_sym(cdr(arg))), opt3_byte(cdr(arg))))
+ return(fx_call(sc, cddr(arg)));
+ return(fx_call(sc, opt2_pair(arg))); /* cdddr(arg) */
+}
+
+static inline s7_pointer fx_and_2a(s7_scheme *sc, s7_pointer arg) /* arg is the full expr: (and ...) */
+{
+ return((fx_call(sc, cdr(arg)) == sc->F) ? sc->F : fx_call(sc, cddr(arg)));
+}
+
+static inline s7_pointer fx_and_s_2(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t1_1, lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg) */
+ return((fn_proc(cadr(arg))(sc, sc->t1_1) == sc->F) ? sc->F : fn_proc(caddr(arg))(sc, sc->t1_1));
+}
+
+static s7_pointer fx_and_or_2a_vref(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer or1 = cadr(arg);
+ s7_pointer arg11 = cdadr(or1);
+ s7_pointer v = lookup(sc, cadar(arg11));
+ if ((is_t_vector(v)) && (vector_rank(v) == 1))
+ {
+ 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))));
+ }}}}
+ return(fx_and_2a(sc, arg));
+}
+
+static s7_pointer fx_len2_t(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer val = t_lookup(sc, opt1_sym(cdr(arg)), arg); /* isn't this unprotected from mock pair? */ /* opt1_sym == cadadr(arg) */
+ return(make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) && (is_null(cddr(val)))));
+}
+
+static s7_pointer fx_len3_t(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer val = t_lookup(sc, opt1_sym(cdr(arg)), arg);
+ return(make_boolean(sc, is_pair(val) && (is_pair(cdr(val))) && (is_pair(cddr(val)))));
+}
+
+static s7_pointer fx_and_3a(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = cdr(arg);
+ if (fx_call(sc, p) == sc->F) return(sc->F);
+ p = cdr(p);
+ return((fx_call(sc, p) == sc->F) ? sc->F : fx_call(sc, cdr(p)));
+}
+
+static s7_pointer fx_and_n(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = sc->T;
+ for (s7_pointer p = cdr(arg); (is_pair(p)) && (x != sc->F); p = cdr(p)) /* in lg, 5/6 args appears to predominate */
+ x = fx_call(sc, p);
+ return(x);
+}
+
+static s7_pointer fx_or_2a(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = cdr(arg);
+ s7_pointer val = fx_call(sc, p);
+ return((val != sc->F) ? val : fx_call(sc, cdr(p)));
+}
+
+static s7_pointer fx_or_s_2(s7_scheme *sc, s7_pointer arg)
+{
+ /* the "s" is looked up once here -- not obvious how to use fx_call anyway */
+ s7_pointer x = fn_proc(cadr(arg))(sc, with_list_t1(lookup(sc, opt3_sym(cdr(arg))))); /* cadadr(arg); */
+ return((x != sc->F) ? x : fn_proc(caddr(arg))(sc, sc->t1_1));
+}
+
+static s7_pointer fx_or_s_type_2(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg)); */
+ return(make_boolean(sc, (type(x) == opt3_int(arg)) || (type(x) == opt2_int(cdr(arg)))));
+}
+
+static s7_pointer fx_not_symbol_or_keyword(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer val = lookup(sc, opt3_sym(arg));
+ return(make_boolean(sc, (!is_symbol(val)) || (is_keyword(val))));
+}
+
+static s7_pointer fx_or_and_2a(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = cdr(arg);
+ s7_pointer val = fx_call(sc, p);
+ if (val != sc->F) return(val);
+ p = opt3_pair(arg); /* cdadr(p); */
+ val = fx_call(sc, p);
+ return((val == sc->F) ? val : fx_call(sc, cdr(p)));
+}
+
+static s7_pointer fx_or_and_3a(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = cdr(arg);
+ s7_pointer val = fx_call(sc, p);
+ if (val != sc->F) return(val);
+ p = opt3_pair(arg); /* cdadr(p); */
+ val = fx_call(sc, p);
+ if (val == sc->F) return(val);
+ p = cdr(p);
+ val = fx_call(sc, p);
+ return((val == sc->F) ? val : fx_call(sc, cdr(p)));
+}
+
+static s7_pointer fx_or_3a(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = cdr(arg);
+ s7_pointer val = fx_call(sc, p);
+ if (val != sc->F) return(val);
+ p = cdr(p);
+ val = fx_call(sc, p);
+ return((val != sc->F) ? val : fx_call(sc, cdr(p)));
+}
+
+static s7_pointer fx_or_n(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x = sc->F;
+ for (s7_pointer p = cdr(arg); (is_pair(p)) && (x == sc->F); p = cdr(p))
+ x = fx_call(sc, p);
+ return(x);
+}
+
+static s7_pointer fx_begin_aa(s7_scheme *sc, s7_pointer arg)
+{
+ fx_call(sc, cdr(arg));
+ return(fx_call(sc, cddr(arg)));
+}
+
+static s7_pointer fx_begin_na(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p;
+ for (p = cdr(arg); is_pair(cdr(p)); p = cdr(p))
+ fx_call(sc, p);
+ return(fx_call(sc, p));
+}
+
+static s7_pointer fx_safe_thunk_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer f = opt1_lambda(code), result;
+ gc_protect_via_stack(sc, sc->curlet); /* we do need to GC protect curlet here and below (not just remember it) */
+ set_curlet(sc, closure_let(f));
+ result = fx_call(sc, closure_body(f));
+ set_curlet(sc, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static s7_pointer fx_safe_closure_s_a(s7_scheme *sc, s7_pointer code) /* also called from h_safe_closure_s_a in eval */
+{
+ s7_pointer result;
+ gc_protect_via_stack(sc, sc->curlet);
+ set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))));
+ result = fx_call(sc, closure_body(opt1_lambda(code)));
+ set_curlet(sc, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static s7_pointer op_safe_closure_s_a(s7_scheme *sc, s7_pointer code) /* also called from h_safe_closure_s_a in eval */
+{
+ set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))));
+ return(fx_call(sc, closure_body(opt1_lambda(code))));
+}
+
+static s7_pointer fx_safe_closure_t_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer result;
+ gc_protect_via_stack(sc, sc->curlet);
+ set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), t_lookup(sc, opt2_sym(code), code)));
+ result = fx_call(sc, closure_body(opt1_lambda(code)));
+ set_curlet(sc, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static s7_pointer fx_safe_closure_s_to_s(s7_scheme *sc, s7_pointer arg)
+{
+ return(fn_proc(car(closure_body(opt1_lambda(arg))))(sc, with_list_t1(lookup(sc, opt2_sym(arg)))));
+}
+
+static s7_pointer fx_safe_closure_s_to_sc(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t2_2, opt3_con(cdr(arg)));
+ set_car(sc->t2_1, lookup(sc, opt2_sym(arg)));
+ return(fn_proc(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1));
+}
+
+static s7_pointer fx_safe_closure_s_to_vref(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, lookup(sc, opt2_sym(arg)), opt3_con(cdr(arg))));}
+static s7_pointer fx_safe_closure_s_to_sub1(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = lookup(sc, opt2_sym(arg));
+ if ((!WITH_GMP) && (is_t_integer(p))) return(make_integer(sc, integer(p) - 1));
+ return(minus_c1(sc, p));
+}
+
+static s7_pointer fx_safe_closure_s_to_add1(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = lookup(sc, opt2_sym(arg));
+ if ((!WITH_GMP) && (is_t_integer(p))) return(make_integer(sc, integer(p) + 1));
+ return(g_add_x1_1(sc, p, 1));
+}
+
+static s7_pointer fx_c_ff(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer p = cdr(arg);
+ s7_pointer x = fx_proc(cdar(p))(sc, car(p));
+ sc->value = x;
+ set_car(sc->t2_2, fx_proc(cdadr(p))(sc, cadr(p)));
+ set_car(sc->t2_1, x);
+ return(fn_proc(arg)(sc, sc->t2_1));
+}
+
+static s7_pointer fx_safe_closure_a_to_sc(s7_scheme *sc, s7_pointer arg)
+{
+ set_car(sc->t2_1, fx_call(sc, cdr(arg)));
+ set_car(sc->t2_2, opt3_con(cdr(arg)));
+ return(fn_proc(car(closure_body(opt1_lambda(arg))))(sc, sc->t2_1));
+}
+
+static s7_pointer fx_safe_closure_a_to_vref(s7_scheme *sc, s7_pointer arg) {return(vector_ref_p_pp(sc, fx_call(sc, cdr(arg)), opt3_con(cdr(arg))));}
+
+static s7_pointer fx_safe_closure_s_and_2a(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is fx_and_2a */
+{
+ s7_pointer result;
+ gc_protect_via_stack(sc, sc->curlet);
+ set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))));
+ code = cdar(closure_body(opt1_lambda(code)));
+ result = fx_call(sc, code); /* have to unwind the stack so this can't return */
+ if (result != sc->F)
+ result = fx_call(sc, cdr(code));
+ set_curlet(sc, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static s7_pointer fx_safe_closure_s_and_pair(s7_scheme *sc, s7_pointer code) /* safe_closure_s_a where "a" is fx_and_2a with is_pair as first clause */
+{
+ s7_pointer result;
+ gc_protect_via_stack(sc, sc->curlet);
+ set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), lookup(sc, opt2_sym(code))));
+ code = cdar(closure_body(opt1_lambda(code)));
+ result = (is_pair(t_lookup(sc, cadar(code), code))) ? fx_call(sc, cdr(code)) : sc->F; /* pair? arg = func par, pair? is global, symbol_id=0 */
+ set_curlet(sc, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static s7_pointer fx_safe_closure_a_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer result;
+ gc_protect_via_stack(sc, sc->curlet);
+ set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), fx_call(sc, cdr(code))));
+ result = fx_call(sc, closure_body(opt1_lambda(code)));
+ set_curlet(sc, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static s7_pointer op_safe_closure_a_a(s7_scheme *sc, s7_pointer code)
+{
+ set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), fx_call(sc, cdr(code))));
+ return(fx_call(sc, closure_body(opt1_lambda(code))));
+}
+
+static s7_pointer fx_safe_closure_a_sqr(s7_scheme *sc, s7_pointer code) {return(fx_sqr_1(sc, fx_call(sc, cdr(code))));}
+static s7_pointer fx_safe_closure_s_sqr(s7_scheme *sc, s7_pointer code) {return(fx_sqr_1(sc, lookup(sc, opt2_sym(code))));}
+
+static s7_pointer fx_safe_closure_a_and_2a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer and_arg = cdar(closure_body(opt1_lambda(code)));
+ s7_pointer result;
+ gc_protect_via_stack(sc, sc->curlet);
+ set_curlet(sc, update_let_with_slot(sc, closure_let(opt1_lambda(code)), fx_call(sc, cdr(code))));
+ result = fx_call(sc, and_arg);
+ if (result != sc->F) result = fx_call(sc, cdr(and_arg));
+ set_curlet(sc, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static s7_pointer fx_safe_closure_ss_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer result;
+ gc_protect_via_stack(sc, sc->curlet);
+ set_curlet(sc, update_let_with_two_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code))));
+ result = fx_call(sc, closure_body(opt1_lambda(code)));
+ set_curlet(sc, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static s7_pointer op_safe_closure_ss_a(s7_scheme *sc, s7_pointer code)
+{
+ set_curlet(sc, update_let_with_two_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code))));
+ return(fx_call(sc, closure_body(opt1_lambda(code))));
+}
+
+static s7_pointer fx_safe_closure_3s_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer result;
+ gc_protect_via_stack(sc, sc->curlet);
+ set_curlet(sc, update_let_with_three_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code))));
+ result = fx_call(sc, closure_body(opt1_lambda(code)));
+ set_curlet(sc, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static s7_pointer op_safe_closure_3s_a(s7_scheme *sc, s7_pointer code)
+{
+ set_curlet(sc, update_let_with_three_slots(sc, closure_let(opt1_lambda(code)), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code))));
+ return(fx_call(sc, closure_body(opt1_lambda(code))));
+}
+
+static s7_pointer fx_safe_closure_aa_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer p = cdr(code);
+ s7_pointer f = opt1_lambda(code);
+ check_stack_size(sc); /* lint+s7test.scm can overflow here */
+ gc_protect_2_via_stack(sc, sc->curlet, fx_call(sc, cdr(p))); /* this is needed even if one of the args is a symbol */
+ set_curlet(sc, update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), stack_protected2(sc)));
+ p = fx_call(sc, closure_body(f));
+ set_curlet(sc, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ return(p);
+}
+
+static inline s7_pointer fx_cond_na_na(s7_scheme *sc, s7_pointer code) /* all tests are fxable, results are all fx, no =>, no missing results */
+{
+ 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));
+ }
+ return(sc->unspecified);
+}
+
+static s7_pointer s7_starlet(s7_scheme *sc, s7_int choice);
+
+static s7_pointer fx_implicit_s7_starlet_ref_s(s7_scheme *sc, s7_pointer arg) {return(s7_starlet(sc, opt3_int(arg)));}
+static s7_pointer fx_implicit_s7_starlet_print_length(s7_scheme *sc, s7_pointer arg) {return(make_integer(sc, sc->print_length));}
+static s7_pointer fx_implicit_s7_starlet_safety(s7_scheme *sc, s7_pointer arg) {return(make_integer(sc, sc->safety));}
+
+static s7_function *fx_function = NULL;
+
+static bool is_fxable(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_pair(p)) return(true);
+ if ((is_optimized(p)) && /* this is needed. In check_tc, for example, is_fxable can be confused by early optimize_op */
+ (fx_function[optimize_op(p)]))
+ return(true);
+ return(is_proper_quote(sc, p));
+}
+
+static int32_t fx_count(s7_scheme *sc, s7_pointer x)
+{
+ int32_t count = 0;
+ for (s7_pointer p = cdr(x); is_pair(p); p = cdr(p))
+ if (is_fxable(sc, car(p)))
+ count++;
+ return(count);
+}
+
+static bool is_code_constant(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) ? (is_quote(car(p))) : is_constant(sc, p));}
+
+static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code);
+
+static s7_p_dd_t s7_p_dd_function(s7_pointer f);
+static s7_p_pi_t s7_p_pi_function(s7_pointer f);
+static s7_p_ii_t s7_p_ii_function(s7_pointer f);
+
+#define is_unchanged_global(P) \
+ ((is_symbol(P)) && (is_global(P)) && (symbol_id(P) == 0) && \
+ (is_slot(initial_slot(P))) && \
+ (initial_value(P) == global_value(P)))
+
+#define is_global_and_has_func(P, Func) ((is_unchanged_global(P)) && (Func(global_value(P)))) /* Func = s7_p_pp_function and friends */
+
+static bool fx_matches(s7_pointer symbol, const s7_pointer target_symbol) {return((symbol == target_symbol) && (is_unchanged_global(symbol)));}
+
+typedef bool (safe_sym_t)(s7_scheme *sc, s7_pointer sym, s7_pointer e);
+
+/* #define fx_choose(Sc, Holder, E, Checker) fx_choose_1(Sc, Holder, E, Checker, __func__, __LINE__) */
+static s7_function fx_choose(s7_scheme *sc, s7_pointer holder, s7_pointer cur_env, safe_sym_t *checker) /* , const char *func, int32_t line) */
+{
+ s7_pointer arg = car(holder);
+ 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));
+ }
+ 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);
+#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);
+
+ 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 (is_safe_quote(car(arg)))
+ {
+ check_quote(sc, arg);
+ return(fx_q);
+ }
+ return(NULL);
+}
+
+#if S7_DEBUGGING
+#define with_fx(P, F) with_fx_1(sc, P, F)
+static bool with_fx_1(s7_scheme *sc, s7_pointer p, s7_function f) /* sc needed for set_opt2 under debugger = set_opt2_1(sc,...) */
+#else
+static bool with_fx(s7_pointer p, s7_function f)
+#endif
+{
+ set_fx_direct(p, f);
+ return(true);
+}
+
+static bool o_var_ok(const s7_pointer p, const s7_pointer var1, const s7_pointer var2, const s7_pointer var3) {return((p != var1) && (p != var2) && (p != var3));}
+
+static bool fx_tree_out(s7_scheme *sc, s7_pointer tree, const s7_pointer var1, const s7_pointer var2, const s7_pointer var3, bool unused_more_vars)
+{
+ s7_pointer p = car(tree);
+ 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));
+ }
+ 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));
+ }
+ 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));
+ }}
+ return(false);
+}
+
+static void fx_tree_outer(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars)
+{
+ if ((!is_pair(tree)) ||
+ ((is_symbol(car(tree))) && (is_definer_or_binder(car(tree)))) ||
+ (is_syntax(car(tree))))
+ return;
+ if ((!has_fx(tree)) ||
+ (!fx_tree_out(sc, tree, var1, var2, var3, more_vars)))
+ fx_tree_outer(sc, car(tree), var1, var2, var3, more_vars);
+ fx_tree_outer(sc, cdr(tree), var1, var2, var3, more_vars);
+}
+
+static bool fx_tree_in(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars)
+{
+ s7_pointer p = car(tree);
+ 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));
+ }
+ return(false);
+ }
+ if ((!is_pair(p)) || (is_fx_treed(tree)) || (!has_fx(tree))) return(false);
+ set_fx_treed(tree);
+ switch (optimize_op(p))
+ {
+ 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 (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 (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 (!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));
+ }
+ 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 (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 (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 (!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));
+ }
+ 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 ((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 (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 (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 ((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));
+ }
+ break;
+
+ case HOP_SAFE_C_AS:
+ if (caddr(p) == var1) return(with_fx(tree, fx_c_at));
+ break;
+
+ 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 (!WITH_PURE_S7)
+ ((caadr(caddr(p)) == sc->string_length_symbol) || (caadr(caddr(p)) == sc->length_symbol)))
+#else
+ (caadr(caddr(p)) == sc->length_symbol))
+#endif
+ 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));
+ }
+ break;
+
+ case HOP_SAFE_C_SSC:
+ if ((cadr(p) == var1) && (caddr(p) == var2)) return(with_fx(tree, fx_c_tuc));
+ break;
+
+ case HOP_SAFE_C_CSS:
+ if ((caddr(p) == var1) && (cadddr(p) == var3)) return(with_fx(tree, fx_c_ctv));
+ break;
+
+ 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));
+ 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));
+ }
+ break;
+
+ case HOP_SAFE_C_SSA:
+ if (cadr(p) == var1) return(with_fx(tree, fx_c_tsa)); /* tua is hit but not called much */
+ if (caddr(p) == var1) return(with_fx(tree, fx_c_sta));
+ break;
+
+ 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 (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 (cadadr(p) == var3)
+ {
+ 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 (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));
+ }
+ 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 (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 ((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 */
+ }
+ 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));
+ }
+ 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);
+ }}
+ 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 (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) == 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);
+ }
+ 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 */
+ }
+ 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));
+ }
+ 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));
+ }
+ 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));
+ }
+ break;
+
+ case HOP_SAFE_C_opSq_CS:
+ if ((cadadr(p) == var1) && (fx_proc(tree) == fx_c_opsq_cs) && (cadddr(p) == var2)) return(with_fx(tree, fx_c_optq_cu));
+ break;
+
+ 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));
+ }
+ 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 ((fx_proc(tree) == fx_gt_add_s) && (cadadr(p) == var1) && (caddadr(p) == var2))
+ 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));
+ 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 ((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));
+ 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));
+ }
+ break;
+
+ case HOP_SAFE_CLOSURE_S_A:
+ if ((cadr(p) == var1) && (fx_proc(tree) == fx_safe_closure_s_a)) return(with_fx(tree, fx_safe_closure_t_a));
+ break;
+
+ case OP_IF_S_A_A:
+ if ((!more_vars) && (o_var_ok(cadr(p), var1, var2, var3))) return(with_fx(tree, fx_if_o_a_a));
+ break;
+
+ 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));
+ }
+ break;
+ }
+ return(false);
+}
+
+static void fx_tree(s7_scheme *sc, s7_pointer tree, s7_pointer var1, s7_pointer var2, s7_pointer var3, bool more_vars)
+{
+ /* if (is_pair(tree)) fprintf(stderr, "fx_tree %s %d %d\n", display(tree), has_fx(tree), is_syntax(car(tree))); */
+ if (!is_pair(tree)) return;
+ if ((is_symbol(car(tree))) &&
+ (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);
+ return;
+ }
+ if (is_syntax(car(tree))) return; /* someday let #_when/#_if etc through -- the symbol 'if, for example, is not syntax */
+
+ if ((!has_fx(tree)) ||
+ (!fx_tree_in(sc, tree, var1, var2, var3, more_vars)))
+ fx_tree(sc, car(tree), var1, var2, var3, more_vars);
+ fx_tree(sc, cdr(tree), var1, var2, var3, more_vars);
+}
+
+/* -------------------------------------------------------------------------------- */
+static opt_funcs_t *alloc_semipermanent_opt_func(s7_scheme *sc)
+{
+ if (sc->alloc_opt_func_k == ALLOC_FUNCTION_SIZE)
+ {
+ sc->alloc_opt_func_cells = (opt_funcs_t *)Malloc(ALLOC_FUNCTION_SIZE * sizeof(opt_funcs_t));
+ add_saved_pointer(sc, sc->alloc_opt_func_cells);
+ sc->alloc_opt_func_k = 0;
+ }
+ return(&(sc->alloc_opt_func_cells[sc->alloc_opt_func_k++]));
+}
+
+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"};
+ if (!is_c_function(f))
+ {
+ fprintf(stderr, "%s[%d]: %s is not a c_function\n", __func__, __LINE__, display(f));
+ if (sc->stop_at_error) abort();
+ }
+ 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]);
+ }
+#endif
+ op = alloc_semipermanent_opt_func(sc);
+ op->typ = typ;
+ op->func = func;
+ op->next = c_function_opt_data(f);
+ c_function_opt_data(f) = op;
+}
+
+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(NULL);
+}
+
+/* clm2xen.c */
+void s7_set_d_function(s7_scheme *sc, s7_pointer f, s7_d_t df) {add_opt_func(sc, f, o_d, (void *)df);}
+s7_d_t s7_d_function(s7_pointer f) {return((s7_d_t)opt_func(f, o_d));}
+
+void s7_set_d_d_function(s7_scheme *sc, s7_pointer f, s7_d_d_t df) {add_opt_func(sc, f, o_d_d, (void *)df);}
+s7_d_d_t s7_d_d_function(s7_pointer f) {return((s7_d_d_t)opt_func(f, o_d_d));}
+
+void s7_set_d_dd_function(s7_scheme *sc, s7_pointer f, s7_d_dd_t df) {add_opt_func(sc, f, o_d_dd, (void *)df);}
+s7_d_dd_t s7_d_dd_function(s7_pointer f) {return((s7_d_dd_t)opt_func(f, o_d_dd));}
+
+void s7_set_d_v_function(s7_scheme *sc, s7_pointer f, s7_d_v_t df) {add_opt_func(sc, f, o_d_v, (void *)df);}
+s7_d_v_t s7_d_v_function(s7_pointer f) {return((s7_d_v_t)opt_func(f, o_d_v));}
+
+void s7_set_d_vd_function(s7_scheme *sc, s7_pointer f, s7_d_vd_t df) {add_opt_func(sc, f, o_d_vd, (void *)df);}
+s7_d_vd_t s7_d_vd_function(s7_pointer f) {return((s7_d_vd_t)opt_func(f, o_d_vd));}
+
+void s7_set_d_vdd_function(s7_scheme *sc, s7_pointer f, s7_d_vdd_t df) {add_opt_func(sc, f, o_d_vdd, (void *)df);}
+s7_d_vdd_t s7_d_vdd_function(s7_pointer f) {return((s7_d_vdd_t)opt_func(f, o_d_vdd));}
+
+void s7_set_d_vid_function(s7_scheme *sc, s7_pointer f, s7_d_vid_t df) {add_opt_func(sc, f, o_d_vid, (void *)df);}
+s7_d_vid_t s7_d_vid_function(s7_pointer f) {return((s7_d_vid_t)opt_func(f, o_d_vid));}
+
+void s7_set_d_id_function(s7_scheme *sc, s7_pointer f, s7_d_id_t df) {add_opt_func(sc, f, o_d_id, (void *)df);}
+s7_d_id_t s7_d_id_function(s7_pointer f) {return((s7_d_id_t)opt_func(f, o_d_id));}
+
+void s7_set_d_7pid_function(s7_scheme *sc, s7_pointer f, s7_d_7pid_t df) {add_opt_func(sc, f, o_d_7pid, (void *)df);}
+s7_d_7pid_t s7_d_7pid_function(s7_pointer f) {return((s7_d_7pid_t)opt_func(f, o_d_7pid));}
+
+void s7_set_d_ip_function(s7_scheme *sc, s7_pointer f, s7_d_ip_t df) {add_opt_func(sc, f, o_d_ip, (void *)df);}
+s7_d_ip_t s7_d_ip_function(s7_pointer f) {return((s7_d_ip_t)opt_func(f, o_d_ip));}
+
+void s7_set_d_pd_function(s7_scheme *sc, s7_pointer f, s7_d_pd_t df) {add_opt_func(sc, f, o_d_pd, (void *)df);}
+s7_d_pd_t s7_d_pd_function(s7_pointer f) {return((s7_d_pd_t)opt_func(f, o_d_pd));}
+
+void s7_set_d_p_function(s7_scheme *sc, s7_pointer f, s7_d_p_t df) {add_opt_func(sc, f, o_d_p, (void *)df);}
+s7_d_p_t s7_d_p_function(s7_pointer f) {return((s7_d_p_t)opt_func(f, o_d_p));}
+
+void s7_set_b_p_function(s7_scheme *sc, s7_pointer f, s7_b_p_t df) {add_opt_func(sc, f, o_b_p, (void *)df);}
+s7_b_p_t s7_b_p_function(s7_pointer f) {return((s7_b_p_t)opt_func(f, o_b_p));}
+
+void s7_set_d_7pi_function(s7_scheme *sc, s7_pointer f, s7_d_7pi_t df) {add_opt_func(sc, f, o_d_7pi, (void *)df);}
+s7_d_7pi_t s7_d_7pi_function(s7_pointer f) {return((s7_d_7pi_t)opt_func(f, o_d_7pi));}
+
+static void s7_set_d_7pii_function(s7_scheme *sc, s7_pointer f, s7_d_7pii_t df) {add_opt_func(sc, f, o_d_7pii, (void *)df);}
+static s7_d_7pii_t s7_d_7pii_function(s7_pointer f) {return((s7_d_7pii_t)opt_func(f, o_d_7pii));}
+
+static void s7_set_d_7piii_function(s7_scheme *sc, s7_pointer f, s7_d_7piii_t df) {add_opt_func(sc, f, o_d_7piii, (void *)df);}
+static s7_d_7piii_t s7_d_7piii_function(s7_pointer f) {return((s7_d_7piii_t)opt_func(f, o_d_7piii));}
+
+void s7_set_i_7p_function(s7_scheme *sc, s7_pointer f, s7_i_7p_t df) {add_opt_func(sc, f, o_i_7p, (void *)df);}
+s7_i_7p_t s7_i_7p_function(s7_pointer f) {return((s7_i_7p_t)opt_func(f, o_i_7p));}
+
+/* cload.scm */
+void s7_set_d_ddd_function(s7_scheme *sc, s7_pointer f, s7_d_ddd_t df) {add_opt_func(sc, f, o_d_ddd, (void *)df);}
+s7_d_ddd_t s7_d_ddd_function(s7_pointer f) {return((s7_d_ddd_t)opt_func(f, o_d_ddd));}
+
+void s7_set_d_dddd_function(s7_scheme *sc, s7_pointer f, s7_d_dddd_t df) {add_opt_func(sc, f, o_d_dddd, (void *)df);}
+s7_d_dddd_t s7_d_dddd_function(s7_pointer f) {return((s7_d_dddd_t)opt_func(f, o_d_dddd));}
+
+void s7_set_i_i_function(s7_scheme *sc, s7_pointer f, s7_i_i_t df) {add_opt_func(sc, f, o_i_i, (void *)df);}
+s7_i_i_t s7_i_i_function(s7_pointer f) {return((s7_i_i_t)opt_func(f, o_i_i));}
+
+void s7_set_i_ii_function(s7_scheme *sc, s7_pointer f, s7_i_ii_t df) {add_opt_func(sc, f, o_i_ii, (void *)df);}
+s7_i_ii_t s7_i_ii_function(s7_pointer f) {return((s7_i_ii_t)opt_func(f, o_i_ii));}
+
+void s7_set_i_7d_function(s7_scheme *sc, s7_pointer f, s7_i_7d_t df) {add_opt_func(sc, f, o_i_7d, (void *)df);}
+s7_i_7d_t s7_i_7d_function(s7_pointer f) {return((s7_i_7d_t)opt_func(f, o_i_7d));}
+
+/* s7test.scm */
+void s7_set_p_d_function(s7_scheme *sc, s7_pointer f, s7_p_d_t df) {add_opt_func(sc, f, o_p_d, (void *)df);}
+s7_p_d_t s7_p_d_function(s7_pointer f) {return((s7_p_d_t)opt_func(f, o_p_d));}
+
+static void s7_set_d_7dd_function(s7_scheme *sc, s7_pointer f, s7_d_7dd_t df) {add_opt_func(sc, f, o_d_7dd, (void *)df);}
+static s7_d_7dd_t s7_d_7dd_function(s7_pointer f) {return((s7_d_7dd_t)opt_func(f, o_d_7dd));}
+
+static void s7_set_i_7i_function(s7_scheme *sc, s7_pointer f, s7_i_7i_t df) {add_opt_func(sc, f, o_i_7i, (void *)df);}
+static s7_i_7i_t s7_i_7i_function(s7_pointer f) {return((s7_i_7i_t)opt_func(f, o_i_7i));}
+
+static void s7_set_i_7ii_function(s7_scheme *sc, s7_pointer f, s7_i_7ii_t df) {add_opt_func(sc, f, o_i_7ii, (void *)df);}
+static s7_i_7ii_t s7_i_7ii_function(s7_pointer f) {return((s7_i_7ii_t)opt_func(f, o_i_7ii));}
+
+static void s7_set_i_iii_function(s7_scheme *sc, s7_pointer f, s7_i_iii_t df) {add_opt_func(sc, f, o_i_iii, (void *)df);}
+static s7_i_iii_t s7_i_iii_function(s7_pointer f) {return((s7_i_iii_t)opt_func(f, o_i_iii));}
+
+static void s7_set_p_pi_function(s7_scheme *sc, s7_pointer f, s7_p_pi_t df) {add_opt_func(sc, f, o_p_pi, (void *)df);}
+static s7_p_pi_t s7_p_pi_function(s7_pointer f) {return((s7_p_pi_t)opt_func(f, o_p_pi));}
+
+static void s7_set_p_ppi_function(s7_scheme *sc, s7_pointer f, s7_p_ppi_t df) {add_opt_func(sc, f, o_p_ppi, (void *)df);}
+static s7_p_ppi_t s7_p_ppi_function(s7_pointer f) {return((s7_p_ppi_t)opt_func(f, o_p_ppi));}
+
+static void s7_set_i_7pi_function(s7_scheme *sc, s7_pointer f, s7_i_7pi_t df) {add_opt_func(sc, f, o_i_7pi, (void *)df);}
+static s7_i_7pi_t s7_i_7pi_function(s7_pointer f) {return((s7_i_7pi_t)opt_func(f, o_i_7pi));}
+
+static void s7_set_i_7pii_function(s7_scheme *sc, s7_pointer f, s7_i_7pii_t df) {add_opt_func(sc, f, o_i_7pii, (void *)df);}
+static s7_i_7pii_t s7_i_7pii_function(s7_pointer f) {return((s7_i_7pii_t)opt_func(f, o_i_7pii));}
+
+static void s7_set_i_7piii_function(s7_scheme *sc, s7_pointer f, s7_i_7piii_t df) {add_opt_func(sc, f, o_i_7piii, (void *)df);}
+static s7_i_7piii_t s7_i_7piii_function(s7_pointer f) {return((s7_i_7piii_t)opt_func(f, o_i_7piii));}
+
+static void s7_set_b_d_function(s7_scheme *sc, s7_pointer f, s7_b_d_t df) {add_opt_func(sc, f, o_b_d, (void *)df);}
+static s7_b_d_t s7_b_d_function(s7_pointer f) {return((s7_b_d_t)opt_func(f, o_b_d));}
+
+static void s7_set_b_i_function(s7_scheme *sc, s7_pointer f, s7_b_i_t df) {add_opt_func(sc, f, o_b_i, (void *)df);}
+static s7_b_i_t s7_b_i_function(s7_pointer f) {return((s7_b_i_t)opt_func(f, o_b_i));}
+
+static void s7_set_b_7p_function(s7_scheme *sc, s7_pointer f, s7_b_7p_t df) {add_opt_func(sc, f, o_b_7p, (void *)df);}
+static s7_b_7p_t s7_b_7p_function(s7_pointer f) {return((s7_b_7p_t)opt_func(f, o_b_7p));}
+
+static void s7_set_b_pp_function(s7_scheme *sc, s7_pointer f, s7_b_pp_t df) {add_opt_func(sc, f, o_b_pp, (void *)df);}
+static s7_b_pp_t s7_b_pp_function(s7_pointer f) {return((s7_b_pp_t)opt_func(f, o_b_pp));}
+
+static void s7_set_b_7pp_function(s7_scheme *sc, s7_pointer f, s7_b_7pp_t df) {add_opt_func(sc, f, o_b_7pp, (void *)df);}
+static s7_b_7pp_t s7_b_7pp_function(s7_pointer f) {return((s7_b_7pp_t)opt_func(f, o_b_7pp));}
+
+static void s7_set_d_7d_function(s7_scheme *sc, s7_pointer f, s7_d_7d_t df) {add_opt_func(sc, f, o_d_7d, (void *)df);}
+static s7_d_7d_t s7_d_7d_function(s7_pointer f) {return((s7_d_7d_t)opt_func(f, o_d_7d));}
+
+static void s7_set_b_pi_function(s7_scheme *sc, s7_pointer f, s7_b_pi_t df) {add_opt_func(sc, f, o_b_pi, (void *)df);}
+static s7_b_pi_t s7_b_pi_function(s7_pointer f) {return((s7_b_pi_t)opt_func(f, o_b_pi));}
+
+static void s7_set_b_ii_function(s7_scheme *sc, s7_pointer f, s7_b_ii_t df) {add_opt_func(sc, f, o_b_ii, (void *)df);}
+static s7_b_ii_t s7_b_ii_function(s7_pointer f) {return((s7_b_ii_t)opt_func(f, o_b_ii));}
+
+static void s7_set_b_7ii_function(s7_scheme *sc, s7_pointer f, s7_b_7ii_t df) {add_opt_func(sc, f, o_b_7ii, (void *)df);}
+static s7_b_7ii_t s7_b_7ii_function(s7_pointer f) {return((s7_b_7ii_t)opt_func(f, o_b_7ii));}
+
+static void s7_set_b_dd_function(s7_scheme *sc, s7_pointer f, s7_b_dd_t df) {add_opt_func(sc, f, o_b_dd, (void *)df);}
+static s7_b_dd_t s7_b_dd_function(s7_pointer f) {return((s7_b_dd_t)opt_func(f, o_b_dd));}
+
+void s7_set_p_p_function(s7_scheme *sc, s7_pointer f, s7_p_p_t df) {add_opt_func(sc, f, o_p_p, (void *)df);}
+s7_p_p_t s7_p_p_function(s7_pointer f) {return((s7_p_p_t)opt_func(f, o_p_p));}
+
+static void s7_set_p_function(s7_scheme *sc, s7_pointer f, s7_p_t df) {add_opt_func(sc, f, o_p, (void *)df);}
+static s7_p_t s7_p_function(s7_pointer f) {return((s7_p_t)opt_func(f, o_p));}
+
+void s7_set_p_pp_function(s7_scheme *sc, s7_pointer f, s7_p_pp_t df) {add_opt_func(sc, f, o_p_pp, (void *)df);}
+s7_p_pp_t s7_p_pp_function(s7_pointer f) {return((s7_p_pp_t)opt_func(f, o_p_pp));}
+
+void s7_set_p_ppp_function(s7_scheme *sc, s7_pointer f, s7_p_ppp_t df) {add_opt_func(sc, f, o_p_ppp, (void *)df);}
+s7_p_ppp_t s7_p_ppp_function(s7_pointer f) {return((s7_p_ppp_t)opt_func(f, o_p_ppp));}
+
+static void s7_set_p_pip_function(s7_scheme *sc, s7_pointer f, s7_p_pip_t df) {add_opt_func(sc, f, o_p_pip, (void *)df);}
+static s7_p_pip_t s7_p_pip_function(s7_pointer f) {return((s7_p_pip_t)opt_func(f, o_p_pip));}
+
+static void s7_set_p_pii_function(s7_scheme *sc, s7_pointer f, s7_p_pii_t df) {add_opt_func(sc, f, o_p_pii, (void *)df);}
+static s7_p_pii_t s7_p_pii_function(s7_pointer f) {return((s7_p_pii_t)opt_func(f, o_p_pii));}
+
+static void s7_set_p_piip_function(s7_scheme *sc, s7_pointer f, s7_p_piip_t df) {add_opt_func(sc, f, o_p_piip, (void *)df);}
+static s7_p_piip_t s7_p_piip_function(s7_pointer f) {return((s7_p_piip_t)opt_func(f, o_p_piip));}
+
+static void s7_set_p_pi_unchecked_function(s7_scheme *sc, s7_pointer f, s7_p_pi_t df) {add_opt_func(sc, f, o_p_pi_unchecked, (void *)df);}
+static s7_p_pi_t s7_p_pi_unchecked_function(s7_pointer f) {return((s7_p_pi_t)opt_func(f, o_p_pi_unchecked));}
+
+static void s7_set_p_pip_unchecked_function(s7_scheme *sc, s7_pointer f, s7_p_pip_t df) {add_opt_func(sc, f, o_p_pip_unchecked, (void *)df);}
+static s7_p_pip_t s7_p_pip_unchecked_function(s7_pointer f) {return((s7_p_pip_t)opt_func(f, o_p_pip_unchecked));}
+
+static void s7_set_b_pp_unchecked_function(s7_scheme *sc, s7_pointer f, s7_b_pp_t df) {add_opt_func(sc, f, o_b_pp_unchecked, (void *)df);}
+static s7_b_pp_t s7_b_pp_unchecked_function(s7_pointer f) {return((s7_b_pp_t)opt_func(f, o_b_pp_unchecked));}
+
+static void s7_set_p_i_function(s7_scheme *sc, s7_pointer f, s7_p_i_t df) {add_opt_func(sc, f, o_p_i, (void *)df);}
+static s7_p_i_t s7_p_i_function(s7_pointer f) {return((s7_p_i_t)opt_func(f, o_p_i));}
+
+static void s7_set_p_ii_function(s7_scheme *sc, s7_pointer f, s7_p_ii_t df) {add_opt_func(sc, f, o_p_ii, (void *)df);}
+static s7_p_ii_t s7_p_ii_function(s7_pointer f) {return((s7_p_ii_t)opt_func(f, o_p_ii));}
+
+static void s7_set_d_7piid_function(s7_scheme *sc, s7_pointer f, s7_d_7piid_t df) {add_opt_func(sc, f, o_d_7piid, (void *)df);}
+static s7_d_7piid_t s7_d_7piid_function(s7_pointer f) {return((s7_d_7piid_t)opt_func(f, o_d_7piid));}
+
+static void s7_set_d_7piiid_function(s7_scheme *sc, s7_pointer f, s7_d_7piiid_t df) {add_opt_func(sc, f, o_d_7piiid, (void *)df);}
+static s7_d_7piiid_t s7_d_7piiid_function(s7_pointer f) {return((s7_d_7piiid_t)opt_func(f, o_d_7piiid));}
+
+static void s7_set_p_dd_function(s7_scheme *sc, s7_pointer f, s7_p_dd_t df) {add_opt_func(sc, f, o_p_dd, (void *)df);}
+static s7_p_dd_t s7_p_dd_function(s7_pointer f) {return((s7_p_dd_t)opt_func(f, o_p_dd));}
+
+static opt_info *alloc_opt_info(s7_scheme *sc)
+{
+ opt_info *o;
+ if (sc->pc >= OPTS_SIZE)
+ sc->pc = OPTS_SIZE - 1;
+ o = sc->opts[sc->pc++];
+ o->v[O_WRAP].fd = NULL; /* see bool_optimize -- this is a kludge */
+ return(o);
+}
+
+#define backup_pc(sc) sc->pc--
+
+#define OPT_PRINT 0 /* print out info about the opt_* optimizations */
+#if OPT_PRINT
+
+#define return_false(Sc, Expr) return(return_false_1(Sc, Expr, __func__, __LINE__))
+static bool return_false_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line)
+{
+ if (expr)
+ fprintf(stderr, " %s[%d]: %s\n", func, line, display_truncated(expr));
+ else fprintf(stderr, " %s[%d]: false\n", func, line);
+ return(false);
+}
+
+#define return_true(Sc, Expr) return(return_true_1(Sc, Expr, __func__, __LINE__))
+static bool return_true_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line)
+{
+ if (expr)
+ fprintf(stderr, " %s%s[%d]%s: %s\n", bold_text blue_text, func, line, unbold_text uncolor_text, display_truncated(expr));
+ else fprintf(stderr, " %s%s[%d]%s: true\n", blue_text, func, line, uncolor_text);
+ return(true);
+}
+
+#define return_success(Sc, P, Expr) return(return_success_1(Sc, P, Expr, __func__, __LINE__))
+static s7_pfunc return_success_1(s7_scheme *sc, s7_pfunc p, s7_pointer expr, const char *func, int32_t line)
+{
+ fprintf(stderr, " %s%s[%d]%s: %s\n", bold_text green_text, func, line, unbold_text uncolor_text, display(expr));
+ return(p);
+}
+
+#define return_null(Sc, Expr) return(return_null_1(Sc, Expr, __func__, __LINE__))
+static s7_pfunc return_null_1(s7_scheme *sc, s7_pointer expr, const char *func, int32_t line)
+{
+ fprintf(stderr, " %s%s[%d]%s: %s\n %sfailure%s\n", bold_text, func, line, unbold_text, display_truncated(expr), bold_text red_text, unbold_text uncolor_text);
+ return(NULL);
+}
+#else
+#define return_false(Sc, Expr) return(false)
+#define return_true(Sc, Expr) return(true)
+#define return_success(Sc, P, Expr) return(P)
+#define return_null(Sc, Expr) return(NULL)
+#endif
+
+static s7_pointer opt_integer_symbol(s7_scheme *sc, s7_pointer sym)
+{
+ if (is_symbol(sym))
+ {
+ s7_pointer p = s7_slot(sc, sym);
+ if ((is_slot(p)) &&
+ (is_t_integer(slot_value(p))))
+ return(p);
+ }
+ return(NULL);
+}
+
+static s7_pointer opt_real_symbol(s7_scheme *sc, s7_pointer sym)
+{
+ if (is_symbol(sym))
+ {
+ s7_pointer p = s7_slot(sc, sym);
+ if ((is_slot(p)) &&
+ (is_small_real(slot_value(p))))
+ return(p);
+ }
+ return(NULL);
+}
+
+static s7_pointer opt_float_symbol(s7_scheme *sc, s7_pointer sym)
+{
+ if (is_symbol(sym))
+ {
+ s7_pointer p = s7_slot(sc, sym);
+ if ((is_slot(p)) &&
+ (is_t_real(slot_value(p))))
+ return(p);
+ }
+ return(NULL);
+}
+
+static s7_pointer opt_simple_symbol(s7_scheme *sc, s7_pointer sym)
+{
+ s7_pointer p = s7_slot(sc, sym);
+ if ((is_slot(p)) &&
+ (!has_methods(slot_value(p))))
+ return(p);
+ return(NULL);
+}
+
+static s7_pointer opt_types_match(s7_scheme *sc, s7_pointer check, s7_pointer sym)
+{
+ s7_pointer checker = s7_symbol_value(sc, check);
+ s7_pointer slot = s7_slot(sc, sym);
+ if (is_slot(slot))
+ {
+ s7_pointer obj = slot_value(slot);
+ if (s7_apply_function(sc, checker, set_plist_1(sc, obj)) == sc->T)
+ return(slot);
+ }
+ return(NULL);
+}
+
+static s7_pointer opt_bool_any(s7_scheme *sc) {return((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);}
+static s7_pointer opt_float_any_nv(s7_scheme *sc) {sc->opts[0]->v[0].fd(sc->opts[0]); return(NULL);}
+static s7_pointer opt_int_any_nv(s7_scheme *sc) {sc->opts[0]->v[0].fi(sc->opts[0]); return(NULL);}
+static s7_pointer opt_bool_any_nv(s7_scheme *sc) {sc->opts[0]->v[0].fb(sc->opts[0]); return(NULL);}
+static s7_pointer opt_cell_any_nv(s7_scheme *sc) {return(sc->opts[0]->v[0].fp(sc->opts[0]));} /* this is faster than returning null */
+
+static s7_pointer opt_make_float(s7_scheme *sc) {return(make_real(sc, sc->opts[0]->v[0].fd(sc->opts[0])));}
+static s7_pointer opt_make_int(s7_scheme *sc) {return(make_integer(sc, sc->opts[0]->v[0].fi(sc->opts[0])));}
+static s7_pointer opt_wrap_cell(s7_scheme *sc) {return(sc->opts[0]->v[0].fp(sc->opts[0]));}
+static s7_pointer opt_wrap_bool(s7_scheme *sc) {return((sc->opts[0]->v[0].fb(sc->opts[0])) ? sc->T : sc->F);}
+
+static bool p_to_b(opt_info *o) {return(o->v[O_WRAP].fp(o) != o->sc->F);}
+static s7_pointer d_to_p(opt_info *o) {return(make_real(o->sc, o->v[O_WRAP].fd(o)));}
+static s7_pointer d_to_p_nr(opt_info *o) {o->v[O_WRAP].fd(o); return(NULL);}
+static s7_pointer i_to_p(opt_info *o) {return(make_integer(o->sc, o->v[O_WRAP].fi(o)));}
+static s7_pointer i_to_p_nr(opt_info *o) {o->v[O_WRAP].fi(o); return(NULL);}
+
+
+/* -------------------------------- int opts -------------------------------- */
+static s7_int opt_i_c(opt_info *o) {return(o->v[1].i);}
+static s7_int opt_i_s(opt_info *o) {return(integer(slot_value(o->v[1].p)));}
+
+static bool opt_int_not_pair(s7_scheme *sc, s7_pointer car_x)
+{
+ opt_info *opc;
+ s7_pointer p;
+ if (is_t_integer(car_x))
+ {
+ opc = alloc_opt_info(sc);
+ opc->v[1].i = integer(car_x);
+ opc->v[0].fi = opt_i_c;
+ return_true(sc, car_x);
+ }
+ p = opt_integer_symbol(sc, car_x);
+ if (!p)
+ return_false(sc, car_x);
+ opc = alloc_opt_info(sc);
+ opc->v[1].p = p;
+ opc->v[0].fi = opt_i_s;
+ return_true(sc, car_x);
+}
+
+/* -------- i_i|d|p -------- */
+static s7_int opt_i_i_c(opt_info *o) {return(o->v[2].i_i_f(o->v[1].i));}
+static s7_int opt_i_i_s(opt_info *o) {return(o->v[2].i_i_f(integer(slot_value(o->v[1].p))));}
+static s7_int opt_i_7i_c(opt_info *o) {return(o->v[2].i_7i_f(o->sc, o->v[1].i));}
+static s7_int opt_i_7i_s(opt_info *o) {return(o->v[2].i_7i_f(o->sc, integer(slot_value(o->v[1].p))));}
+static s7_int opt_i_7i_s_rand(opt_info *o) {return(random_i_7i(o->sc, integer(slot_value(o->v[1].p))));}
+static s7_int opt_i_d_c(opt_info *o) {return(o->v[2].i_7d_f(o->sc, o->v[1].x));}
+static s7_int opt_i_d_s(opt_info *o) {return(o->v[2].i_7d_f(o->sc, real(slot_value(o->v[1].p))));}
+
+static s7_int opt_i_i_f(opt_info *o) {return(o->v[2].i_i_f(o->v[4].fi(o->v[3].o1)));}
+static s7_int opt_i_7i_f(opt_info *o) {return(o->v[2].i_7i_f(o->sc, o->v[4].fi(o->v[3].o1)));}
+static s7_int opt_i_7d_f(opt_info *o) {return(o->v[2].i_7d_f(o->sc, o->v[4].fd(o->v[3].o1)));}
+static s7_int opt_i_7p_f(opt_info *o) {return(o->v[2].i_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));}
+static s7_int opt_i_7p_f_cint(opt_info *o) {return(char_to_integer_i_7p(o->sc, o->v[4].fp(o->v[3].o1)));}
+
+static s7_int opt_i_i_s_abs(opt_info *o) {return(abs_i_i(integer(slot_value(o->v[1].p))));}
+static s7_int opt_i_i_f_abs(opt_info *o) {return(abs_i_i(o->v[4].fi(o->v[3].o1)));}
+
+static bool int_optimize(s7_scheme *sc, s7_pointer expr);
+static bool float_optimize(s7_scheme *sc, s7_pointer expr);
+
+static bool i_idp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_i_i_t func = s7_i_i_function(s_func);
+ s7_i_7i_t func7 = NULL;
+ s7_i_7p_t ipf;
+ s7_pointer p, arg1 = cadr(car_x);
+ int32_t start = sc->pc;
+ opc->v[3].o1 = sc->opts[start];
+ if (!func)
+ func7 = s7_i_7i_function(s_func);
+ if ((func) || (func7))
+ {
+ if (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);
+ }
+ 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);
+ }
+ 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);
+ }
+ 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;
+ }}
+ 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);
+ }
+ sc->pc = start;
+ }
+ return_false(sc, car_x);
+}
+
+
+/* -------- i_pi -------- */
+
+static s7_int opt_i_7pi_ss(opt_info *o) {return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_int opt_i_pi_ss_ivref(opt_info *o) {return(int_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_int opt_i_pi_ss_bvref(opt_info *o) {return(byte_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_int opt_i_7pi_sf(opt_info *o) {return(o->v[3].i_7pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));}
+
+static bool i_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_pointer sig;
+ s7_i_7pi_t pfunc = s7_i_7pi_function(s_func);
+ 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);
+ }}}
+ if (!pfunc) return_false(sc, car_x);
+ }
+ sig = c_function_signature(s_func);
+ if (is_pair(sig))
+ {
+ 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;
+ }}
+ return_false(sc, car_x);
+}
+
+/* -------- i_ii -------- */
+static s7_int opt_i_ii_cc(opt_info *o) {return(o->v[3].i_ii_f(o->v[1].i, o->v[2].i));}
+static s7_int opt_i_ii_cs(opt_info *o) {return(o->v[3].i_ii_f(o->v[1].i, integer(slot_value(o->v[2].p))));}
+static s7_int opt_i_ii_cs_mul(opt_info *o) {return(o->v[1].i * integer(slot_value(o->v[2].p)));}
+static s7_int opt_i_ii_sc(opt_info *o) {return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));}
+static s7_int opt_i_ii_sc_add(opt_info *o) {return(integer(slot_value(o->v[1].p)) + o->v[2].i);} /* +1 is not faster */
+static s7_int opt_i_ii_sc_sub(opt_info *o) {return(integer(slot_value(o->v[1].p)) - o->v[2].i);} /* -1 is not faster */
+static s7_int opt_i_ii_ss(opt_info *o) {return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));}
+static s7_int opt_i_ii_ss_add(opt_info *o) {return(integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p)));}
+static s7_pointer opt_p_ii_ss_add(opt_info *o) {return(make_integer(o->sc, integer(slot_value(o->v[1].p)) + integer(slot_value(o->v[2].p))));}
+static s7_int opt_i_ii_cf(opt_info *o) {return(o->v[3].i_ii_f(o->v[1].i, o->v[5].fi(o->v[4].o1)));}
+static s7_int opt_i_ii_cf_mul(opt_info *o) {return(o->v[1].i * o->v[5].fi(o->v[4].o1));}
+static s7_int opt_i_ii_sf(opt_info *o) {return(o->v[3].i_ii_f(integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));}
+static s7_int opt_i_ii_sf_add(opt_info *o) {return(integer(slot_value(o->v[1].p)) + o->v[5].fi(o->v[4].o1));}
+static s7_int opt_i_ii_ff(opt_info *o) {return(o->v[3].i_ii_f(o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1)));}
+static s7_int opt_i_7ii_ff_quo(opt_info *o){return(quotient_i_7ii(o->sc,o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1)));}
+static s7_int opt_i_ii_fc(opt_info *o) {return(o->v[3].i_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));}
+static s7_int opt_i_ii_fc_add(opt_info *o) {return(o->v[11].fi(o->v[10].o1) + o->v[2].i);}
+static s7_int opt_i_ii_fc_mul(opt_info *o) {return(o->v[11].fi(o->v[10].o1) * o->v[2].i);}
+/* returning s7_int so overflow->real is not doable here, so
+ * (define (func) (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (* (lognot 4294967297) 4294967297)))) (func) (func)
+ * will return -12884901890 rather than -18446744086594454000.0, 4294967297 > sqrt(fixmost)
+ * This affects all the opt arithmetical functions. Unfortunately the gmp version also gets -12884901890!
+ * We need to make sure none of these are available in the gmp version.
+ */
+static s7_int opt_i_7ii_fc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[11].fi(o->v[10].o1), o->v[2].i));}
+static s7_int opt_i_ii_fco(opt_info *o) {return(o->v[3].i_ii_f(o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));}
+static s7_int opt_i_ii_fco_ivref_add(opt_info *o){return(int_vector_ref_i_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))) + o->v[5].i);} /* tref */
+static s7_int opt_i_7ii_fco(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[4].i_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))), o->v[5].i));}
+
+static bool i_ii_fc_combinable(s7_scheme *sc, opt_info *opc, s7_i_ii_t func)
+{
+ if ((sc->pc > 1) &&
+ (opc == sc->opts[sc->pc - 2]))
+ {
+ 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);
+ }}
+ return_false(sc, NULL);
+}
+
+static s7_int opt_i_7ii_cc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[2].i));}
+static s7_int opt_i_7ii_cs(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, integer(slot_value(o->v[2].p))));}
+static s7_int opt_i_7ii_sc(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[2].i));}
+static s7_int opt_i_7ii_ss(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));}
+static s7_int opt_i_7ii_cf(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, o->v[1].i, o->v[5].fi(o->v[4].o1)));}
+static s7_int opt_i_7ii_sf(opt_info *o) {return(o->v[3].i_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[5].fi(o->v[4].o1)));}
+
+static s7_int opt_i_7ii_ff(opt_info *o)
+{
+ s7_int i1 = o->v[11].fi(o->v[10].o1);
+ s7_int i2 = o->v[9].fi(o->v[8].o1);
+ return(o->v[3].i_7ii_f(o->sc, i1, i2));
+}
+
+#if WITH_GMP
+static s7_int opt_add_i_random_i(opt_info *o) {return(o->v[1].i + (s7_int)(o->v[2].i * next_random(o->sc)));}
+static s7_int opt_subtract_random_i_i(opt_info *o) {return((s7_int)(o->v[1].i * next_random(o->sc)) - o->v[2].i);}
+#else
+static s7_int opt_add_i_random_i(opt_info *o) {return(o->v[1].i + (s7_int)(o->v[2].i * next_random(o->sc->default_random_state)));}
+static s7_int opt_subtract_random_i_i(opt_info *o) {return((s7_int)(o->v[1].i * next_random(o->sc->default_random_state)) - o->v[2].i);}
+#endif
+
+static bool i_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_i_ii_t ifunc = s7_i_ii_function(s_func);
+ s7_i_7ii_t ifunc7 = NULL;
+ s7_pointer sig;
+
+ if (!ifunc)
+ {
+ ifunc7 = s7_i_7ii_function(s_func);
+ if (!ifunc7)
+ return_false(sc, car_x);
+ }
+ sig = c_function_signature(s_func);
+ if (is_pair(sig))
+ {
+ s7_pointer arg1 = cadr(car_x);
+ s7_pointer arg2 = caddr(car_x);
+ int32_t start = sc->pc;
+ s7_pointer p;
+ if (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);
+ }
+
+ /* 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);
+ }
+
+ /* 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);
+ }
+
+ /* 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;
+ }}
+ return_false(sc, car_x);
+}
+
+/* -------- i_iii -------- */
+static s7_int opt_i_iii_fff(opt_info *o)
+{
+ s7_int i1 = o->v[11].fi(o->v[10].o1);
+ s7_int i2 = o->v[9].fi(o->v[8].o1);
+ s7_int i3 = o->v[5].fi(o->v[4].o1);
+ return(o->v[3].i_iii_f(i1, i2, i3));
+}
+
+static bool i_iii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ int32_t start = sc->pc;
+ s7_i_iii_t ifunc = s7_i_iii_function(s_func);
+ if (!ifunc)
+ return_false(sc, car_x);
+ opc->v[10].o1 = sc->opts[start];
+ if (int_optimize(sc, cdr(car_x)))
+ {
+ 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);
+ }}}
+ sc->pc = start;
+ return_false(sc, car_x);
+}
+
+/* -------- i_7pii -------- */
+static s7_int opt_i_7pii_ssf(opt_info *o) {return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fi(o->v[4].o1)));}
+static s7_int opt_i_7pii_ssf_vset(opt_info *o) {return(int_vector_set_i_7pii_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fi(o->v[4].o1)));}
+static s7_int opt_i_7pii_ssc(opt_info *o) {return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].i));}
+static s7_int opt_i_7pii_sss(opt_info *o) {return(o->v[4].i_7pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p))));}
+static s7_int opt_i_7pii_sif(opt_info *o) {return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), o->v[12].i, o->v[9].fi(o->v[8].o1)));}
+
+static s7_int opt_i_pii_sss_ivref_unchecked(opt_info *o)
+{
+ s7_pointer v = slot_value(o->v[1].p);
+ return(int_vector(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p)))));
+}
+
+static s7_int opt_i_7pii_sff(opt_info *o)
+{
+ s7_int i1 = o->v[11].fi(o->v[10].o1);
+ s7_int i2 = o->v[9].fi(o->v[8].o1);
+ return(o->v[3].i_7pii_f(o->sc, slot_value(o->v[1].p), i1, i2));
+}
+
+/* -------- i_7piii -------- */
+static s7_int opt_i_7piii_sssf(opt_info *o)
+{
+ return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[11].fi(o->v[10].o1)));
+}
+
+static s7_int opt_i_piii_sssf_ivset_unchecked(opt_info *o)
+{
+ s7_pointer v = slot_value(o->v[1].p);
+ s7_int val = o->v[11].fi(o->v[10].o1);
+ int_vector(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p)))) = val;
+ return(val);
+}
+
+static s7_int opt_i_7piii_sssc(opt_info *o)
+{
+ return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[4].i));
+}
+
+static s7_int opt_i_7piii_ssss(opt_info *o)
+{
+ return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), integer(slot_value(o->v[4].p))));
+}
+
+static s7_int opt_i_7piii_sfff(opt_info *o)
+{
+ s7_int i1 = o->v[11].fi(o->v[10].o1);
+ s7_int i2 = o->v[9].fi(o->v[8].o1);
+ s7_int i3 = o->v[6].fi(o->v[4].o1);
+ return(o->v[5].i_7piii_f(o->sc, slot_value(o->v[1].p), i1, i2, i3));
+}
+
+static bool opt_i_7piii_args(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp)
+{
+ /* opc->v[5] is the called function (int-vector-set! etc) */
+ s7_pointer 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 (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];
+ if (int_optimize(sc, indexp1))
+ {
+ 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);
+ }}}
+ return_false(sc, indexp1);
+}
+
+static bool opt_int_vector_set(s7_scheme *sc, int32_t otype, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp)
+{
+ s7_pointer settee = s7_slot(sc, v);
+ if ((is_slot(settee)) &&
+ (!is_immutable(slot_value(settee))))
+ {
+ s7_pointer slot, vect = slot_value(settee);
+ 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));
+ }}}
+ return_false(sc, v);
+}
+
+static bool is_target_or_its_alias(const s7_pointer symbol, const s7_pointer symfunc, s7_pointer target)
+{
+ return((symbol == target) || (symfunc == initial_value(target)));
+}
+
+static bool i_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_pointer sig;
+ s7_i_7pii_t pfunc = s7_i_7pii_function(s_func);
+ if (!pfunc)
+ return_false(sc, car_x);
+ sig = c_function_signature(s_func);
+ if ((is_pair(sig)) &&
+ (is_symbol(cadr(car_x))))
+ {
+ 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)));
+
+ 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;
+ }}
+ return_false(sc, car_x);
+}
+
+static bool i_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_i_7piii_t f = s7_i_7piii_function(s_func);
+ if ((f) &&
+ (is_symbol(cadr(car_x))))
+ {
+ 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)));
+
+ 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)));
+ }}}
+ return_false(sc, car_x);
+}
+
+/* -------- i_add|multiply_any -------- */
+static s7_int opt_i_add_any_f(opt_info *o)
+{
+ s7_int sum = 0;
+ for (s7_int i = 0; i < o->v[1].i; i++)
+ {
+ opt_info *o1 = o->v[i + 2].o1;
+ sum += o1->v[0].fi(o1);
+ }
+ return(sum);
+}
+
+static s7_int opt_i_add2(opt_info *o)
+{
+ s7_int sum = o->v[6].fi(o->v[2].o1);
+ return(sum + o->v[7].fi(o->v[3].o1));
+}
+
+static s7_int opt_i_mul2(opt_info *o)
+{
+ s7_int sum = o->v[6].fi(o->v[2].o1);
+ return(sum * o->v[7].fi(o->v[3].o1));
+}
+
+static s7_int opt_i_add3(opt_info *o)
+{
+ s7_int sum = o->v[6].fi(o->v[2].o1);
+ sum += o->v[7].fi(o->v[3].o1);
+ return(sum + o->v[8].fi(o->v[4].o1));
+}
+
+static s7_int opt_i_mul3(opt_info *o)
+{
+ s7_int sum = o->v[6].fi(o->v[2].o1);
+ sum *= o->v[7].fi(o->v[3].o1);
+ return(sum * o->v[8].fi(o->v[4].o1));
+}
+
+static s7_int opt_i_add4(opt_info *o)
+{
+ s7_int sum = o->v[6].fi(o->v[2].o1);
+ sum += o->v[7].fi(o->v[3].o1);
+ sum += o->v[8].fi(o->v[4].o1);
+ return(sum + o->v[9].fi(o->v[5].o1));
+}
+
+static s7_int opt_i_mul4(opt_info *o)
+{
+ s7_int sum = o->v[6].fi(o->v[2].o1);
+ sum *= o->v[7].fi(o->v[3].o1);
+ sum *= o->v[8].fi(o->v[4].o1);
+ return(sum * o->v[9].fi(o->v[5].o1));
+}
+
+static s7_int opt_i_multiply_any_f(opt_info *o)
+{
+ s7_int sum = 1;
+ for (s7_int i = 0; i < o->v[1].i; i++)
+ {
+ opt_info *o1 = o->v[i + 2].o1;
+ sum *= o1->v[0].fi(o1);
+ }
+ return(sum);
+}
+
+static bool i_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x)
+{
+ s7_pointer p, head = car(car_x);
+ int32_t cur_len, start = sc->pc;
+ 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 (!int_optimize(sc, p))
+ 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;
+ if (cur_len == 2)
+ 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;
+ return_true(sc, car_x);
+ }
+ sc->pc = start;
+ return_false(sc, car_x);
+}
+
+
+/* -------- set_i_i -------- */
+static s7_int opt_set_i_i_f(opt_info *o)
+{
+ s7_int x = o->v[3].fi(o->v[2].o1);
+ slot_set_value(o->v[1].p, make_integer(o->sc, x));
+ return(x);
+}
+
+#if S7_DEBUGGING
+static void check_mutability(s7_scheme *sc, opt_info *o, const char *func, int line)
+{
+ if (!is_mutable_number(slot_value(o->v[1].p)))
+ {
+ fprintf(stderr, "%s[%d]: %s value is not mutable", func, line, display(o->v[1].p));
+ if (sc->stop_at_error) abort();
+ }
+}
+#else
+#define check_mutability(Sc, O, Func, Line)
+#endif
+
+static s7_int opt_set_i_i_fm(opt_info *o) /* called in increment: (set! sum (+ sum (...))) where all are ints */
+{
+ s7_int x = o->v[3].fi(o->v[2].o1);
+ check_mutability(o->sc, o, __func__, __LINE__);
+ set_integer(slot_value(o->v[1].p), x);
+ return(x);
+}
+
+static s7_int opt_set_i_i_fo(opt_info *o)
+{
+ s7_int x = integer(slot_value(o->v[3].p)) + o->v[2].i;
+ slot_set_value(o->v[1].p, make_integer(o->sc, x));
+ return(x);
+}
+
+static s7_int opt_set_i_i_fom(opt_info *o)
+{
+ s7_int x = integer(slot_value(o->v[3].p)) + o->v[2].i;
+ check_mutability(o->sc, o, __func__, __LINE__);
+ set_integer(slot_value(o->v[1].p), x);
+ return(x);
+}
+
+static bool set_i_i_f_combinable(s7_scheme *sc, opt_info *opc)
+{
+ if ((sc->pc > 1) &&
+ (opc == sc->opts[sc->pc - 2]))
+ {
+ 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 */
+ }}
+ return_false(sc, NULL);
+}
+
+static bool i_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
+{
+ if ((car(car_x) == sc->set_symbol) &&
+ (len == 3))
+ {
+ 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);
+ }}}
+ 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)));
+ }}
+ return_false(sc, car_x);
+}
+
+static bool i_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, int32_t len)
+{
+ s7_pointer obj = slot_value(s_slot);
+ if ((is_int_vector(obj)) || (is_byte_vector(obj)))
+ {
+ bool int_case = is_int_vector(obj);
+ 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);
+ }
+ 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);
+ }}}}
+ return_false(sc, car_x);
+}
+
+
+/* ------------------------------------- float opts ------------------------------------------- */
+static s7_double opt_d_c(opt_info *o) {return(o->v[1].x);}
+static s7_double opt_d_s(opt_info *o) {return(real(slot_value(o->v[1].p)));}
+
+static s7_double opt_D_s(opt_info *o)
+{
+ s7_pointer x = slot_value(o->v[1].p);
+ return((is_t_integer(x)) ? (s7_double)(integer(x)) : s7_number_to_real(o->sc, x));
+}
+
+static bool opt_float_not_pair(s7_scheme *sc, s7_pointer car_x)
+{
+ s7_pointer p;
+ if (is_small_real(car_x))
+ {
+ opt_info *opc = alloc_opt_info(sc);
+ opc->v[1].x = s7_number_to_real(sc, car_x);
+ opc->v[0].fd = opt_d_c;
+ return_true(sc, car_x);
+ }
+ p = opt_real_symbol(sc, car_x);
+ if (p)
+ {
+ opt_info *opc = alloc_opt_info(sc);
+ opc->v[1].p = p;
+ opc->v[0].fd = (is_t_real(slot_value(p))) ? opt_d_s : opt_D_s;
+ return_true(sc, car_x);
+ }
+ return_false(sc, car_x);
+}
+
+/* -------- d -------- */
+static s7_double opt_d_f(opt_info *o) {return(o->v[1].d_f());}
+
+static bool d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func) /* (f): (mus-srate), ignored damned ccpcheck! */
+{
+ s7_d_t func = s7_d_function(s_func);
+ if (!func)
+ return_false(sc, NULL);
+ opc->v[0].fd = opt_d_f;
+ opc->v[1].d_f = func;
+ return_true(sc, NULL);
+}
+
+/* -------- d_d -------- */
+static s7_double opt_d_d_c(opt_info *o) {return(o->v[3].d_d_f(o->v[1].x));}
+static s7_double opt_d_d_s(opt_info *o) {return(o->v[3].d_d_f(real(slot_value(o->v[1].p))));}
+static s7_double opt_d_d_s_abs(opt_info *o) {return(abs_d_d(real(slot_value(o->v[1].p))));}
+static s7_double opt_d_7d_c(opt_info *o) {return(o->v[3].d_7d_f(o->sc, o->v[1].x));}
+static s7_double opt_d_7d_s(opt_info *o) {return(o->v[3].d_7d_f(o->sc, real(slot_value(o->v[1].p))));}
+static s7_double opt_d_d_f(opt_info *o) {return(o->v[3].d_d_f(o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_d_f_abs(opt_info *o) {return(abs_d_d(o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_d_f_sin(opt_info *o) {return(sin_d_d(o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_d_f_cos(opt_info *o) {return(cos_d_d(o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_7d_f(opt_info *o) {return(o->v[3].d_7d_f(o->sc, o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_7d_f_divide(opt_info *o) {return(divide_d_7d(o->sc, o->v[5].fd(o->v[4].o1)));}
+
+static s7_double opt_d_7pi_ss_fvref_direct(opt_info *o);
+static s7_double opt_abs_d_ss_fvref(opt_info *o)
+{
+ opt_info *o1 = o->v[4].o1;
+ return(abs_d_d(float_vector(slot_value(o1->v[1].p), integer(slot_value(o1->v[2].p)))));
+}
+
+static bool d_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_d_7d_t func7 = NULL;
+ int32_t start = sc->pc;
+ s7_d_d_t func = s7_d_d_function(s_func);
+ if (!func) func7 = s7_d_7d_function(s_func);
+ if ((func) || (func7))
+ {
+ s7_pointer p, arg1 = cadr(car_x);
+ if (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);
+ }
+ 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);
+ }
+ 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);
+ }
+ sc->pc = start;
+ }
+ return_false(sc, car_x);
+}
+
+/* -------- d_v -------- */
+static s7_double opt_d_v(opt_info *o) {return(o->v[3].d_v_f(o->v[5].obj));}
+
+static bool d_v_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_pointer sig;
+ s7_d_v_t flt_func = s7_d_v_function(s_func);
+ if (!flt_func)
+ return_false(sc, car_x);
+ sig = c_function_signature(s_func);
+ if ((is_pair(sig)) &&
+ (is_symbol(cadr(sig))) &&
+ (is_symbol(cadr(car_x)))) /* look for (oscil g) */
+ {
+ 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);
+ }}
+ return_false(sc, car_x);
+}
+
+/* -------- d_p -------- */
+static s7_double opt_d_p_s(opt_info *o) {return(o->v[3].d_p_f(slot_value(o->v[1].p)));}
+static s7_double opt_d_p_f(opt_info *o) {return(o->v[3].d_p_f(o->v[5].fp(o->v[4].o1)));}
+
+static bool d_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ int32_t start = sc->pc;
+ s7_d_p_t dpf = s7_d_p_function(s_func); /* mostly clm gens */
+ if (!dpf)
+ return_false(sc, car_x);
+ opc->v[3].d_p_f = dpf;
+ if (is_symbol(cadr(car_x)))
+ {
+ s7_pointer slot = opt_simple_symbol(sc, cadr(car_x));
+ if (!slot)
+ return_false(sc, car_x);
+ opc->v[1].p = slot;
+ opc->v[0].fd = opt_d_p_s;
+ return_true(sc, car_x);
+ }
+ opc->v[4].o1 = sc->opts[sc->pc];
+ if (cell_optimize(sc, cdr(car_x)))
+ {
+ opc->v[0].fd = opt_d_p_f;
+ opc->v[5].fp = opc->v[4].o1->v[0].fp;
+ return_true(sc, car_x);
+ }
+ sc->pc = start;
+ return_false(sc, car_x);
+}
+
+/* -------- d_7pi -------- */
+
+static s7_double opt_d_7pi_sc(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[2].i));}
+static s7_double opt_d_7pi_ss(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_double opt_d_7pi_sf(opt_info *o) {return(o->v[3].d_7pi_f(o->sc, slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1)));}
+static s7_double opt_d_7pi_ss_fvref(opt_info *o) {return(float_vector_ref_d_7pi(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_double opt_d_7pi_ss_fvref_direct(opt_info *o) {return(float_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+
+static s7_double opt_d_7pi_ff(opt_info *o)
+{
+ s7_pointer seq = o->v[5].fp(o->v[4].o1);
+ return(o->v[3].d_7pi_f(o->sc, seq, o->v[9].fi(o->v[8].o1)));
+}
+
+static bool d_7pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ /* float-vector-ref is checked for a 1D float-vector arg, but other callers should do type checking */
+ int32_t start = sc->pc;
+ s7_d_7pi_t ifunc = s7_d_7pi_function(s_func); /* ifunc: float_vector_ref_d_7pi, s_func: global_value(sc->float_vector_ref_symbol) */
+ 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);
+ }}}
+ if (!ifunc) return_false(sc, car_x);
+ }
+ opc->v[3].d_7pi_f = ifunc;
+ if (is_symbol(cadr(car_x))) /* (float-vector-ref v i) */
+ {
+ 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);
+
+ 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 */
+
+ 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 (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);
+ }
+ sc->pc = start;
+ return_false(sc, car_x);
+ }
+
+ if ((is_target_or_its_alias(car(car_x), s_func, sc->float_vector_ref_symbol)) &&
+ ((!is_float_vector(cadr(car_x))) ||
+ (vector_rank(cadr(car_x)) > 1))) /* (float-vector-ref #r2d((.1 .2) (.3 .4)) 3) */
+ return_false(sc, car_x);
+
+ if (cell_optimize(sc, cdr(car_x)))
+ {
+ 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);
+ }}
+ sc->pc = start;
+ return_false(sc, car_x);
+}
+
+/* -------- d_ip -------- */
+static s7_double opt_d_ip_ss(opt_info *o) {return(o->v[3].d_ip_f(integer(slot_value(o->v[1].p)), slot_value(o->v[2].p)));}
+
+static bool d_ip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_d_ip_t pfunc = s7_d_ip_function(s_func);
+ if ((pfunc) &&
+ (is_symbol(caddr(car_x))))
+ {
+ 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);
+ }}}
+ return_false(sc, car_x);
+}
+
+/* -------- d_pd -------- */
+static s7_double opt_d_pd_sf(opt_info *o) {return(o->v[3].d_pd_f(slot_value(o->v[1].p), o->v[11].fd(o->v[10].o1)));}
+static s7_double opt_d_pd_ss(opt_info *o) {return(o->v[3].d_pd_f(slot_value(o->v[1].p), real(slot_value(o->v[2].p))));}
+
+static bool d_pd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ if (is_symbol(cadr(car_x)))
+ {
+ 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;
+ }}
+ return_false(sc, car_x);
+}
+
+/* -------- d_vd -------- */
+static s7_double opt_d_vd_c(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].x));}
+static s7_double opt_d_vd_s(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p))));}
+static s7_double opt_d_vd_f(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[9].fd(o->v[8].o1)));}
+static s7_double opt_d_vd_o(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)));}
+static s7_double opt_d_vd_o1_mul(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, real(slot_value(o->v[2].p)) * o->v[11].fd(o->v[10].o1)));}
+static s7_double opt_d_vd_o1(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(real(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1))));}
+static s7_double opt_d_vd_o2(opt_info *o) {return(o->v[4].d_vd_f(o->v[6].obj, o->v[5].d_vd_f(o->v[2].obj, real(slot_value(o->v[3].p)))));}
+static s7_double opt_d_vd_o3(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[4].d_dd_f(o->v[6].x, real(slot_value(o->v[2].p)))));}
+static s7_double opt_d_vd_ff(opt_info *o) {return(o->v[3].d_vd_f(o->v[5].obj, o->v[2].d_vd_f(o->v[4].obj, o->v[11].fd(o->v[10].o1))));}
+
+static s7_double opt_d_dd_cs(opt_info *o);
+static s7_double opt_d_dd_sf_mul(opt_info *o);
+static s7_double opt_d_dd_sf_add(opt_info *o);
+static s7_double opt_d_dd_sf(opt_info *o);
+
+static bool d_vd_f_combinable(s7_scheme *sc, int32_t start)
+{
+ opt_info *opc = sc->opts[start - 1], *o1 = sc->opts[start];
+ if (o1->v[0].fd == opt_d_v)
+ {
+ opc->v[2].p = o1->v[1].p;
+ opc->v[6].obj = o1->v[5].obj;
+ opc->v[4].d_v_f = o1->v[3].d_v_f;
+ opc->v[0].fd = opt_d_vd_o;
+ backup_pc(sc);
+ return_true(sc, NULL);
+ }
+ if (o1->v[0].fd == opt_d_vd_s)
+ {
+ opc->v[6].obj = opc->v[5].obj;
+ opc->v[4].d_vd_f = opc->v[3].d_vd_f; /* room for symbols */
+ opc->v[2].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[7].p = o1->v[1].p;
+ opc->v[0].fd = opt_d_vd_o2;
+ backup_pc(sc);
+ return_true(sc, NULL);
+ }
+ if (o1->v[0].fd == opt_d_dd_cs)
+ {
+ opc->v[4].d_dd_f = o1->v[3].d_dd_f;
+ opc->v[6].x = o1->v[2].x;
+ opc->v[2].p = o1->v[1].p;
+ opc->v[0].fd = opt_d_vd_o3;
+ backup_pc(sc);
+ return_true(sc, NULL);
+ }
+ if ((o1->v[0].fd == opt_d_dd_sf_mul) || (o1->v[0].fd == opt_d_dd_sf) || (o1->v[0].fd == opt_d_dd_sf_add))
+ {
+ opc->v[2].p = o1->v[1].p;
+ opc->v[4].d_dd_f = o1->v[3].d_dd_f;
+ opc->v[0].fd = (o1->v[0].fd == opt_d_dd_sf_mul) ? opt_d_vd_o1_mul : opt_d_vd_o1;
+ opc->v[11].fd = o1->v[5].fd;
+ opc->v[10].o1 = o1->v[4].o1;
+ return_true(sc, NULL);
+ }
+ if (o1->v[0].fd == opt_d_vd_f)
+ {
+ opc->v[2].d_vd_f = o1->v[3].d_vd_f;
+ opc->v[4].obj = o1->v[5].obj;
+ opc->v[6].p = o1->v[1].p;
+ opc->v[0].fd = opt_d_vd_ff;
+ opc->v[11].fd = o1->v[9].fd;
+ opc->v[10].o1 = o1->v[8].o1;
+ return_true(sc, NULL);
+ }
+ return_false(sc, NULL);
+}
+
+static bool d_vd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_pointer sig;
+ s7_d_vd_t vfunc;
+ if (!is_symbol(cadr(car_x)))
+ return_false(sc, car_x);
+ vfunc = s7_d_vd_function(s_func);
+ if (!vfunc)
+ return_false(sc, car_x);
+ sig = c_function_signature(s_func);
+ if ((is_pair(sig)) &&
+ (is_symbol(cadr(sig))))
+ {
+ 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;
+ }}}
+ return_false(sc, car_x);
+}
+
+/* -------- d_id -------- */
+static s7_double opt_d_id_ss(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));}
+static s7_double opt_d_i2_mul(opt_info *o) {s7_int p = integer(slot_value(o->v[1].p)); return(p * p);}
+static s7_double opt_d_id_sf(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_id_sc(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[2].x));}
+static s7_double opt_d_id_sfo1(opt_info *o) {return(o->v[3].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].d_v_f(o->v[2].obj)));}
+static s7_double opt_d_id_sfo(opt_info *o) {return(o->v[4].d_id_f(integer(slot_value(o->v[1].p)), o->v[5].d_vd_f(o->v[6].obj, real(slot_value(o->v[3].p)))));}
+static s7_double opt_d_id_cf(opt_info *o) {return(o->v[3].d_id_f(o->v[1].i, o->v[5].fd(o->v[4].o1)));}
+
+static s7_double opt_d_id_ff(opt_info *o)
+{
+ s7_int x1 = o->v[9].fi(o->v[8].o1);
+ return(o->v[3].d_id_f(x1, o->v[11].fd(o->v[10].o1)));
+}
+
+static bool d_id_sf_combinable(s7_scheme *sc, opt_info *opc)
+{
+ if ((sc->pc > 1) &&
+ (opc == sc->opts[sc->pc - 2]))
+ {
+ 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);
+ }
+ 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);
+ }}
+ return_false(sc, NULL);
+}
+
+static bool d_id_ok_1(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, bool expr_case)
+{
+ s7_pointer p;
+ int32_t start = sc->pc;
+ s7_d_id_t flt_func = s7_d_id_function(s_func);
+ if (!flt_func)
+ return_false(sc, car_x);
+ opc->v[3].d_id_f = flt_func;
+ p = opt_integer_symbol(sc, cadr(car_x));
+ if (p)
+ {
+ 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);
+ }
+ if ((cadr(car_x) == arg2) && (flt_func == multiply_d_id))
+ {
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }
+ sc->pc = start;
+ }
+ if (!expr_case) return_false(sc, car_x);
+ opc->v[8].o1 = sc->opts[sc->pc];
+ if (int_optimize(sc, cdr(car_x)))
+ {
+ 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);
+ }
+ sc->pc = start;
+ }
+ return_false(sc, car_x);
+}
+
+static bool d_id_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ return(d_id_ok_1(sc, opc, s_func, car_x, true));
+}
+
+
+/* -------- d_dd -------- */
+
+static s7_double opt_d_dd_cc(opt_info *o) {return(o->v[3].d_dd_f(o->v[1].x, o->v[2].x));}
+static s7_double opt_d_dd_cs(opt_info *o) {return(o->v[3].d_dd_f(o->v[2].x, real(slot_value(o->v[1].p))));}
+static s7_double opt_d_dd_sc(opt_info *o) {return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[2].x));}
+static s7_double opt_d_dd_sc_sub(opt_info *o) {return(real(slot_value(o->v[1].p)) - o->v[2].x);}
+static s7_double opt_d_dd_ss(opt_info *o) {return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));}
+static s7_double opt_d_dd_ss_add(opt_info *o) {return(real(slot_value(o->v[1].p)) + real(slot_value(o->v[2].p)));}
+static s7_double opt_d_dd_ss_mul(opt_info *o) {return(real(slot_value(o->v[1].p)) * real(slot_value(o->v[2].p)));}
+
+static s7_double opt_d_dd_cf(opt_info *o) {return(o->v[3].d_dd_f(o->v[1].x, o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_dd_1f_subtract(opt_info *o) {return(1.0 - o->v[5].fd(o->v[4].o1));}
+static s7_double opt_d_dd_fc(opt_info *o) {return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), o->v[2].x));}
+
+#if WITH_GMP
+static s7_double opt_subtract_random_f_f(opt_info *o) {return(o->v[1].x * next_random(o->sc) - o->v[2].x);}
+#else
+static s7_double opt_subtract_random_f_f(opt_info *o) {return(o->v[1].x * next_random(o->sc->default_random_state) - o->v[2].x);}
+#endif
+
+static s7_double opt_d_dd_fc_add(opt_info *o) {return(o->v[5].fd(o->v[4].o1) + o->v[2].x);}
+static s7_double opt_d_dd_fc_fvref_add(opt_info *o) {return(o->v[2].x + float_vector(slot_value(o->v[4].o1->v[1].p), integer(slot_value(o->v[4].o1->v[2].p))));}
+static s7_double opt_d_dd_fc_subtract(opt_info *o) {return(o->v[5].fd(o->v[4].o1) - o->v[2].x);}
+static s7_double opt_d_dd_sf(opt_info *o) {return(o->v[3].d_dd_f(real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_dd_sf_mul(opt_info *o) {return(real(slot_value(o->v[1].p)) * o->v[5].fd(o->v[4].o1));}
+static s7_double opt_d_dd_sf_add(opt_info *o) {return(real(slot_value(o->v[1].p)) + o->v[5].fd(o->v[4].o1));}
+static s7_double opt_d_dd_sf_sub(opt_info *o) {return(real(slot_value(o->v[1].p)) - o->v[5].fd(o->v[4].o1));}
+
+static s7_double opt_d_7dd_cc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[2].x));}
+static s7_double opt_d_7dd_cs(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[2].x, real(slot_value(o->v[1].p))));}
+static s7_double opt_d_7dd_sc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[2].x));}
+static s7_double opt_d_7dd_ss(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));}
+static s7_double opt_d_7dd_cf(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[1].x, o->v[5].fd(o->v[4].o1)));}
+static s7_double opt_d_7dd_fc(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), o->v[2].x));}
+static s7_double opt_d_7dd_sf(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[5].fd(o->v[4].o1)));}
+
+static s7_double opt_d_dd_sf_mul_fvref(opt_info *o)
+{
+ opt_info *o1 = o->v[4].o1;
+ return(real(slot_value(o->v[1].p)) * float_vector_ref_d_7pii(o1->sc, slot_value(o1->v[1].p), o1->v[2].i, integer(slot_value(o1->v[3].p))));
+}
+
+static s7_double opt_d_dd_sfo(opt_info *o)
+{
+ return(o->v[4].d_dd_f(real(slot_value(o->v[1].p)), o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p)))));
+}
+
+static s7_double opt_d_7dd_sfo(opt_info *o)
+{
+ return(o->v[4].d_7dd_f(o->sc, real(slot_value(o->v[1].p)), o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p)))));
+}
+
+static bool d_dd_sf_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func)
+{
+ if ((sc->pc > 1) &&
+ (opc == sc->opts[sc->pc - 2]))
+ {
+ 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);
+ }}
+ return_false(sc, NULL);
+}
+
+static s7_double opt_d_dd_fs(opt_info *o) {return(o->v[3].d_dd_f(o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));}
+static s7_double opt_d_dd_fs_mul(opt_info *o) {return(o->v[5].fd(o->v[4].o1) * real(slot_value(o->v[1].p)));}
+static s7_double opt_d_dd_fs_add(opt_info *o) {return(o->v[5].fd(o->v[4].o1) + real(slot_value(o->v[1].p)));}
+static s7_double opt_d_dd_fs_sub(opt_info *o) {return(o->v[5].fd(o->v[4].o1) - real(slot_value(o->v[1].p)));}
+static s7_double opt_d_7dd_fs(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[5].fd(o->v[4].o1), real(slot_value(o->v[1].p))));}
+
+static s7_double opt_d_dd_fs_add_fvref(opt_info *o)
+{
+ opt_info *o1 = o->v[4].o1;
+ return(real(slot_value(o->v[1].p)) + float_vector_ref_d_7pii(o1->sc, slot_value(o1->v[1].p), o1->v[2].i, integer(slot_value(o1->v[3].p))));
+}
+
+static s7_double opt_d_dd_fso(opt_info *o)
+{
+ return(o->v[4].d_dd_f(o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p))));
+}
+
+static s7_double opt_d_7dd_fso(opt_info *o)
+{
+ return(o->v[4].d_7dd_f(o->sc, o->v[5].d_7pi_f(o->sc, slot_value(o->v[2].p), integer(slot_value(o->v[3].p))), real(slot_value(o->v[1].p))));
+}
+
+static bool d_dd_fs_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func)
+{
+ if ((sc->pc > 1) &&
+ (opc == sc->opts[sc->pc - 2]))
+ {
+ 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);
+ }}
+ return_false(sc, NULL);
+}
+
+static s7_double opt_d_dd_ff(opt_info *o)
+{
+ s7_double x1 = o->v[9].fd(o->v[8].o1);
+ return(o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1)));
+}
+
+static s7_double opt_d_dd_ff_mul(opt_info *o)
+{
+ s7_double x1 = o->v[9].fd(o->v[8].o1);
+ return(x1 * o->v[11].fd(o->v[10].o1));
+}
+
+static s7_double opt_d_dd_ff_square(opt_info *o)
+{
+ s7_double x1 = o->v[9].fd(o->v[8].o1);
+ return(x1 * x1);
+}
+
+static s7_double opt_d_dd_ff_add(opt_info *o)
+{
+ s7_double x1 = o->v[5].fd(o->v[4].o1);
+ return(x1 + o->v[11].fd(o->v[10].o1));
+}
+
+static s7_double opt_d_dd_ff_add_mul(opt_info *o)
+{
+ s7_double x1 = o->v[5].fd(o->v[4].o1);
+ s7_double x2 = o->v[9].fd(o->v[8].o1);
+ return(x1 + (x2 * o->v[11].fd(o->v[10].o1)));
+}
+
+static s7_double opt_d_dd_ff_add_fv_ref(opt_info *o)
+{
+ s7_double x1 = o->v[5].fd(o->v[4].o1);
+ return(x1 + float_vector_ref_d_7pi(o->sc, slot_value(o->v[6].p), o->v[9].fi(o->v[8].o1)));
+}
+
+static s7_double opt_d_dd_ff_sub(opt_info *o)
+{
+ s7_double x1 = o->v[5].fd(o->v[4].o1);
+ return(x1 - o->v[11].fd(o->v[10].o1));
+}
+
+static s7_double opt_d_7dd_ff(opt_info *o)
+{
+ s7_double x1 = o->v[9].fd(o->v[8].o1);
+ return(o->v[3].d_7dd_f(o->sc, x1, o->v[11].fd(o->v[10].o1)));
+}
+
+static s7_double opt_d_7dd_ff_add_fv_ref_direct(opt_info *o)
+{
+ s7_double x1 = opt_d_7pi_ss_fvref_direct(o->v[4].o1);
+ return(x1 + opt_d_7dd_ff(o->v[10].o1));
+}
+
+static s7_double opt_d_7dd_ff_add_div(opt_info *o)
+{
+ s7_double x1 = opt_d_7pi_ss_fvref_direct(o->v[4].o1);
+ s7_double x2 = opt_d_7pi_ss_fvref_direct(o->v[8].o1);
+ return(x1 + divide_d_7dd(o->sc, x2, opt_d_id_sf(o->v[10].o1)));
+}
+
+static s7_double opt_d_dd_ff_o1(opt_info *o)
+{
+ s7_double x1 = o->v[2].d_v_f(o->v[1].obj);
+ return(o->v[3].d_dd_f(x1, o->v[11].fd(o->v[10].o1)));
+}
+
+static s7_double opt_d_dd_ff_mul1(opt_info *o) {return(o->v[2].d_v_f(o->v[1].obj) * o->v[11].fd(o->v[10].o1));}
+
+static s7_double opt_d_dd_ff_o2(opt_info *o)
+{
+ s7_double x1 = o->v[4].d_v_f(o->v[1].obj);
+ return(o->v[3].d_dd_f(x1, o->v[5].d_v_f(o->v[2].obj)));
+}
+
+static s7_double opt_d_dd_ff_mul2(opt_info *o) {return(o->v[4].d_v_f(o->v[1].obj) * o->v[5].d_v_f(o->v[2].obj));}
+
+static s7_double opt_d_dd_ff_o3(opt_info *o)
+{
+ s7_double x1 = o->v[5].d_v_f(o->v[1].obj);
+ return(o->v[4].d_dd_f(x1, o->v[6].d_vd_f(o->v[2].obj, real(slot_value(o->v[3].p)))));
+}
+
+static s7_double opt_d_dd_fff(opt_info *o)
+{
+ s7_double x1 = o->v[3+4].d_dd_f(o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))), real(slot_value(o->v[3+1].p))); /* dd_fso */
+ s7_double x2 = o->v[8+4].d_dd_f(o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))), real(slot_value(o->v[8+1].p))); /* dd_fso */
+ return(o->v[3].d_dd_f(x1, x2));
+}
+
+static s7_double opt_d_mm_fff(opt_info *o)
+{
+ s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))) * real(slot_value(o->v[3+1].p));
+ s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))) * real(slot_value(o->v[8+1].p));
+ return(o->v[3].d_dd_f(x1, x2));
+}
+
+static s7_double opt_d_dd_fff_rev(opt_info *o) /* faster with o->sc? */
+{
+ s7_double x1 = o->v[3+4].d_dd_f(real(slot_value(o->v[3+1].p)), o->v[3+5].d_7pi_f(o->sc, slot_value(o->v[3+2].p), integer(slot_value(o->v[3+3].p))));
+ s7_double x2 = o->v[8+4].d_dd_f(real(slot_value(o->v[8+1].p)), o->v[8+5].d_7pi_f(o->sc, slot_value(o->v[8+2].p), integer(slot_value(o->v[8+3].p))));
+ return(o->v[3].d_dd_f(x1, x2));
+}
+
+static s7_double opt_d_dd_ff_o4(opt_info *o)
+{
+ s7_double x1 = o->v[2].d_v_f(o->v[1].obj);
+ return(o->v[3].d_dd_f(x1, o->v[7].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj))));
+}
+
+static s7_double opt_d_dd_ff_mul4(opt_info *o) {return(o->v[2].d_v_f(o->v[1].obj) * o->v[7].d_vd_f(o->v[5].obj, o->v[4].d_v_f(o->v[6].obj)));}
+
+static s7_double opt_d_dd_ff_mul_sss_unchecked(opt_info *o)
+{
+ opt_info *o1 = o->v[8].o1;
+ s7_pointer v = slot_value(o1->v[1].p);
+ s7_int i1 = integer(slot_value(o1->v[2].p));
+ s7_int i2 = integer(slot_value(o1->v[3].p));
+ s7_double x1 = float_vector(v, (i1 * vector_offset(v, 0)) + i2);
+ o1 = o->v[10].o1;
+ v = slot_value(o1->v[1].p);
+ i1 = integer(slot_value(o1->v[2].p)); /* in (* (A i j) (B j k)) we could reuse i2->i1 (flipping args below) */
+ i2 = integer(slot_value(o1->v[3].p));
+ return(x1 * float_vector(v, (i1 * vector_offset(v, 0)) + i2));
+}
+
+static bool finish_dd_fso(opt_info *opc, opt_info *o1, opt_info *o2)
+{
+ opc->v[3+1].p = o1->v[1].p;
+ opc->v[3+2].p = o1->v[2].p;
+ opc->v[3+3].p = o1->v[3].p;
+ opc->v[3+4].d_dd_f = o1->v[4].d_dd_f;
+ opc->v[3+5].d_7pi_f = o1->v[5].d_7pi_f;
+ opc->v[8+1].p = o2->v[1].p;
+ opc->v[8+2].p = o2->v[2].p;
+ opc->v[8+3].p = o2->v[3].p;
+ opc->v[8+4].d_dd_f = o2->v[4].d_dd_f;
+ opc->v[8+5].d_7pi_f = o2->v[5].d_7pi_f;
+ return(true);
+}
+
+static s7_double opt_d_7dd_ff_div_add(opt_info *o)
+{
+ opt_info *o2 = o->v[10].o1;
+ s7_double x1 = o->v[9].fd(o->v[8].o1);
+ s7_double x2 = o2->v[5].fd(o2->v[4].o1);
+ x2 += float_vector_ref_d_7pi(o2->sc, slot_value(o2->v[6].p), o2->v[9].fi(o2->v[8].o1));
+ return(divide_d_7dd(o->sc, x1, x2));
+}
+
+static bool d_dd_ff_combinable(s7_scheme *sc, opt_info *opc, int32_t start)
+{
+ opt_info *o1 = opc->v[8].o1, *o2 = opc->v[10].o1;
+ if (o1->v[0].fd == opt_d_v)
+ {
+ /* 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);
+ }
+ 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);
+ }
+ 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);
+ }
+ 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;
+ opc->v[0].fd = (opc->v[3].d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul1 : opt_d_dd_ff_o1;
+ return_true(sc, NULL);
+ }
+ 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[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));
+ }}
+ return_false(sc, NULL);
+}
+
+static s7_double opt_d_dd_cfo(opt_info *o) {return(o->v[3].d_dd_f(o->v[2].x, o->v[4].d_v_f(o->v[1].obj)));}
+static s7_double opt_d_7dd_cfo(opt_info *o) {return(o->v[3].d_7dd_f(o->sc, o->v[2].x, o->v[4].d_v_f(o->v[1].obj)));}
+static s7_double opt_d_dd_cfo1(opt_info *o) {return(o->v[3].d_dd_f(o->v[4].x, o->v[5].d_vd_f(o->v[6].obj, real(slot_value(o->v[2].p)))));}
+static s7_double opt_d_7dd_cfo1(opt_info *o){return(o->v[3].d_7dd_f(o->sc, o->v[4].x, o->v[5].d_vd_f(o->v[6].obj, real(slot_value(o->v[2].p)))));}
+
+static bool d_dd_call_combinable(s7_scheme *sc, opt_info *opc, s7_d_dd_t func)
+{
+ if ((sc->pc > 1) &&
+ (opc == sc->opts[sc->pc - 2]))
+ {
+ 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);
+ }
+ 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);
+ }}
+ return_false(sc, NULL);
+}
+
+static s7_double opt_d_7pii_scs(opt_info *o);
+static s7_double opt_d_7pii_sss(opt_info *o);
+static s7_double opt_d_7pii_sss_unchecked(opt_info *o);
+
+static bool d_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x);
+ int32_t start = sc->pc;
+ opt_info *o1;
+ s7_d_7dd_t func7 = NULL;
+ s7_d_dd_t func = s7_d_dd_function(s_func);
+ if (!func)
+ {
+ func7 = s7_d_7dd_function(s_func);
+ if (!func7) return_false(sc, car_x);
+ }
+ if (func)
+ opc->v[3].d_dd_f = func;
+ else opc->v[3].d_7dd_f = func7;
+
+ /* arg1 = real constant */
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }
+ sc->pc = start;
+ return_false(sc, car_x);
+ }
+
+ /* arg1 = float symbol */
+ slot = opt_float_symbol(sc, arg1);
+ if (slot)
+ {
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }
+ sc->pc = start;
+ return_false(sc, car_x);
+ }
+
+ /* arg1 = float expr or non-float */
+
+ /* first check for obvious d_id cases */
+ if (((is_t_integer(arg1)) || (opt_integer_symbol(sc, arg1))) &&
+ (s7_d_id_function(s_func)))
+ return(d_id_ok_1(sc, opc, s_func, car_x, false));
+
+ o1 = sc->opts[sc->pc];
+ if (float_optimize(sc, cdr(car_x)))
+ {
+ 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);
+ }
+ 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[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);
+ }}
+ sc->pc = start;
+ return_false(sc, car_x);
+}
+
+/* -------- d_ddd -------- */
+static s7_double opt_d_ddd_sss(opt_info *o) {return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p)), real(slot_value(o->v[3].p))));}
+static s7_double opt_d_ddd_ssf(opt_info *o) {return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)));}
+
+static s7_double opt_d_ddd_sff(opt_info *o)
+{
+ s7_double x1 = o->v[11].fd(o->v[10].o1);
+ s7_double x2 = o->v[9].fd(o->v[8].o1);
+ return(o->v[4].d_ddd_f(real(slot_value(o->v[1].p)), x1, x2));
+}
+
+static s7_double opt_d_ddd_fff(opt_info *o)
+{
+ s7_double x1 = o->v[11].fd(o->v[10].o1);
+ s7_double x2 = o->v[9].fd(o->v[8].o1);
+ s7_double x3 = o->v[6].fd(o->v[5].o1);
+ return(o->v[4].d_ddd_f(x1, x2, x3));
+}
+
+static s7_double opt_d_ddd_fff1(opt_info *o)
+{
+ s7_double x1 = o->v[1].d_v_f(o->v[2].obj);
+ s7_double x2 = o->v[3].d_v_f(o->v[4].obj);
+ s7_double x3 = o->v[5].d_v_f(o->v[6].obj);
+ return(o->v[7].d_ddd_f(x1, x2, x3));
+}
+
+static s7_double opt_d_ddd_fff2(opt_info *o)
+{
+ s7_double x1 = o->v[1].d_v_f(o->v[2].obj);
+ s7_double x2 = o->v[9].fd(o->v[12].o1);
+ s7_double x3 = o->v[6].fd(o->v[5].o1);
+ return(o->v[7].d_ddd_f(x1, x2, x3));
+}
+
+static s7_double opt_d_ddd_fff_mul(opt_info *o)
+{
+ s7_double x1 = opt_D_s(o->v[10].o1);
+ s7_double x2 = opt_D_s(o->v[8].o1);
+ s7_double x3 = opt_d_s(o->v[5].o1);
+ return(multiply_d_ddd(x1, x2, x3));
+}
+
+static bool d_ddd_fff_combinable(s7_scheme *sc, opt_info *opc, int32_t start)
+{
+ opt_info *o1;
+ if (sc->opts[start]->v[0].fd != opt_d_v)
+ return_false(sc, NULL);
+ opc->v[12].o1 = opc->v[8].o1;
+ opc->v[7].d_ddd_f = opc->v[4].d_ddd_f;
+ o1 = sc->opts[start];
+ opc->v[1].d_v_f = o1->v[3].d_v_f;
+ opc->v[2].obj = o1->v[5].obj;
+ opc->v[8].p = o1->v[1].p;
+ if ((sc->opts[start + 1]->v[0].fd == opt_d_v) &&
+ (sc->opts[start + 2]->v[0].fd == opt_d_v))
+ {
+ opc->v[0].fd = opt_d_ddd_fff1;
+ o1 = sc->opts[start + 1];
+ opc->v[3].d_v_f = o1->v[3].d_v_f;
+ opc->v[4].obj = o1->v[5].obj;
+ opc->v[9].p = o1->v[1].p;
+ o1 = sc->opts[start + 2];
+ opc->v[5].d_v_f = o1->v[3].d_v_f;
+ opc->v[6].obj = o1->v[5].obj;
+ opc->v[10].p = o1->v[1].p;
+ sc->pc -= 3;
+ return_true(sc, NULL);
+ }
+ opc->v[0].fd = opt_d_ddd_fff2;
+ opc->v[9].fd = opc->v[12].o1->v[0].fd;
+ opc->v[6].fd = opc->v[5].o1->v[0].fd;
+ return_true(sc, NULL);
+}
+
+static bool d_ddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ int32_t start = sc->pc;
+ s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x);
+ s7_d_ddd_t f = s7_d_ddd_function(s_func);
+ if (!f)
+ return_false(sc, car_x);
+ opc->v[4].d_ddd_f = f;
+ slot = opt_float_symbol(sc, arg1);
+ opc->v[10].o1 = sc->opts[start];
+ if (slot)
+ {
+ 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;
+ }
+ 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);
+ }}
+ 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);
+ }}}
+ sc->pc = start;
+ return_false(sc, car_x);
+}
+
+/* -------- d_7pid -------- */
+static s7_double opt_d_7pid_ssf(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[11].fd(o->v[10].o1)));
+}
+
+static s7_pointer opt_d_7pid_ssf_nr(opt_info *o)
+{
+ o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1));
+ return(NULL);
+}
+
+static s7_double opt_d_7pid_sss(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)), real(slot_value(o->v[3].p))));
+}
+
+static s7_double opt_d_7pid_ssc(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].x));
+}
+
+static s7_double opt_d_7pid_sff(opt_info *o)
+{
+ s7_int pos = o->v[11].fi(o->v[10].o1);
+ return(o->v[4].d_7pid_f(o->sc, slot_value(o->v[1].p), pos, o->v[9].fd(o->v[8].o1)));
+}
+
+static s7_double opt_d_7pid_sff_fvset(opt_info *o)
+{
+ s7_int pos = o->v[11].fi(o->v[10].o1);
+ return(float_vector_set_d_7pid(o->sc, slot_value(o->v[1].p), pos, o->v[9].fd(o->v[8].o1)));
+}
+
+static s7_double opt_d_7pid_sso(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[5].d_v_f(o->v[3].obj)));
+}
+
+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)))));
+}
+
+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)))));
+}
+
+static s7_double opt_d_7pid_ssfo_fv(opt_info *o)
+{
+ s7_double *els = float_vector_floats(slot_value(o->v[1].p));
+ s7_double val = o->v[6].d_dd_f(els[integer(slot_value(o->v[3].p))], real(slot_value(o->v[8].p)));
+ els[integer(slot_value(o->v[2].p))] = val;
+ return(val);
+}
+
+static s7_pointer opt_d_7pid_ssfo_fv_nr(opt_info *o) /* these next are variations on (float-vector-set! s (float-vector-ref s...)) */
+{
+ s7_double *els = float_vector_floats(slot_value(o->v[1].p));
+ els[integer(slot_value(o->v[2].p))] = o->v[6].d_dd_f(els[integer(slot_value(o->v[3].p))], real(slot_value(o->v[8].p)));
+ return(NULL);
+}
+
+static s7_pointer opt_d_7pid_ssfo_fv_add_nr(opt_info *o)
+{
+ s7_double *els = float_vector_floats(slot_value(o->v[1].p));
+ els[integer(slot_value(o->v[2].p))] = els[integer(slot_value(o->v[3].p))] + real(slot_value(o->v[8].p));
+ return(NULL);
+}
+
+static s7_pointer opt_d_7pid_ssfo_fv_sub_nr(opt_info *o)
+{
+ s7_double *els = float_vector_floats(slot_value(o->v[1].p));
+ els[integer(slot_value(o->v[2].p))] = els[integer(slot_value(o->v[3].p))] - real(slot_value(o->v[8].p));
+ return(NULL);
+}
+
+static bool d_7pid_ssf_combinable(s7_scheme *sc, opt_info *opc)
+{
+ if ((sc->pc > 1) &&
+ (opc == sc->opts[sc->pc - 2]))
+ {
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }}
+ return_false(sc, NULL);
+}
+
+static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer indexp3, s7_pointer valp);
+
+static bool d_7pid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_d_7pid_t f = s7_d_7pid_function(s_func);
+ if ((f) &&
+ (is_symbol(cadr(car_x))))
+ {
+ s7_pointer slot, head = car(car_x);
+ int32_t start = sc->pc;
+ 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)));
+
+ 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;
+ }}
+ return_false(sc, car_x);
+}
+
+/* -------- d_7pii -------- */
+/* currently this can only be float_vector_ref_d_7pii (d_7pii is not exported at this time) */
+
+static s7_double opt_d_7pii_sss(opt_info *o)
+{ /* o->v[4].d_7pii_f */
+ return(float_vector_ref_d_7pii(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p))));
+}
+
+static s7_double opt_d_7pii_sss_unchecked(opt_info *o)
+{
+ s7_pointer v = slot_value(o->v[1].p);
+ return(float_vector(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p)))));
+}
+
+static s7_double opt_d_7pii_scs(opt_info *o)
+{
+ return(float_vector_ref_d_7pii(o->sc, slot_value(o->v[1].p), o->v[2].i, integer(slot_value(o->v[3].p))));
+}
+
+static s7_double opt_d_7pii_sff(opt_info *o)
+{
+ return(float_vector_ref_d_7pii(o->sc, slot_value(o->v[1].p), o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1)));
+}
+
+static bool d_7pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_d_7pii_t ifunc = s7_d_7pii_function(s_func);
+ if ((ifunc == float_vector_ref_d_7pii) &&
+ (is_symbol(cadr(car_x))))
+ {
+ s7_pointer slot;
+ 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);
+
+ 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[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);
+ }}
+ sc->pc = start;
+ }
+ return_false(sc, car_x);
+}
+
+/* -------- d_7piid -------- */
+/* currently only float_vector_set */
+
+static s7_double opt_d_7piid_sssf(opt_info *o)
+{ /* o->v[5].d_7piid_f and below */
+ return(float_vector_set_d_7piid(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[9].fd(o->v[8].o1)));
+}
+
+static s7_double opt_d_7piid_sssc(opt_info *o)
+{
+ return(float_vector_set_d_7piid(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[4].x));
+}
+
+static s7_double opt_d_7piid_scsf(opt_info *o)
+{
+ return(float_vector_set_d_7piid(o->sc, slot_value(o->v[1].p), o->v[2].i, integer(slot_value(o->v[3].p)), o->v[11].fd(o->v[10].o1)));
+}
+
+static s7_double opt_d_7piid_sfff(opt_info *o)
+{
+ s7_int i1 = o->v[11].fi(o->v[10].o1);
+ s7_int i2 = o->v[9].fi(o->v[8].o1);
+ return(float_vector_set_d_7piid(o->sc, slot_value(o->v[1].p), i1, i2, o->v[4].fd(o->v[3].o1)));
+}
+
+static s7_double opt_d_7piid_sssf_unchecked(opt_info *o) /* this could be subsumed by the call above if we were using o->v[5] or o->v[0].fd */
+{
+ s7_int i1 = integer(slot_value(o->v[2].p)), i2 = integer(slot_value(o->v[3].p));
+ s7_pointer vect = slot_value(o->v[1].p);
+ s7_double val = o->v[9].fd(o->v[8].o1);
+ float_vector(vect, (i1 * (vector_offset(vect, 0)) + i2)) = val;
+ return(val);
+}
+
+static bool d_7piid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_d_7piid_t f = s7_d_7piid_function(s_func);
+ if ((f) &&
+ (is_symbol(cadr(car_x))))
+ {
+ 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_false(sc, car_x);
+}
+
+/* -------- d_7piii -------- */
+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))));
+}
+
+static s7_double opt_d_7piii_ssss_unchecked(opt_info *o)
+{
+ s7_pointer v = slot_value(o->v[1].p);
+ s7_int i1 = integer(slot_value(o->v[2].p)) * vector_offset(v, 0);
+ s7_int i2 = integer(slot_value(o->v[3].p)) * vector_offset(v, 1); /* offsets accumulate */
+ return(float_vector(v, (i1 + i2 + integer(slot_value(o->v[5].p)))));
+}
+
+static bool d_7piii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_d_7piii_t ifunc = s7_d_7piii_function(s_func);
+ if ((ifunc == float_vector_ref_d_7piii) &&
+ (is_symbol(cadr(car_x))))
+ {
+ 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);
+
+ 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);
+ }}}}
+ return_false(sc, car_x);
+}
+
+/* -------- d_7piiid -------- */
+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)));
+}
+
+static s7_double opt_d_7piiid_ssssf_unchecked(opt_info *o)
+{
+ s7_pointer vect = slot_value(o->v[1].p);
+ s7_int i1 = integer(slot_value(o->v[2].p)) * vector_offset(vect, 0);
+ s7_int i2 = integer(slot_value(o->v[3].p)) * vector_offset(vect, 1);
+ s7_int i3 = integer(slot_value(o->v[5].p));
+ s7_double val = o->v[11].fd(o->v[10].o1);
+ float_vector(vect, (i1 + i2 + i3)) = val;
+ return(val);
+}
+
+static bool d_7piiid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_d_7piiid_t f = s7_d_7piiid_function(s_func);
+ if ((f == float_vector_set_d_7piiid) &&
+ (is_symbol(cadr(car_x))))
+ {
+ 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_false(sc, car_x);
+}
+
+static bool opt_float_vector_set(s7_scheme *sc, opt_info *opc, s7_pointer v, s7_pointer indexp1, s7_pointer indexp2, s7_pointer indexp3, s7_pointer valp)
+{
+ s7_pointer settee = s7_slot(sc, v);
+ if ((is_slot(settee)) &&
+ (!is_immutable(slot_value(settee))))
+ {
+ s7_pointer slot, vect = slot_value(settee);
+ int32_t start = sc->pc;
+ opc->v[1].p = settee;
+ if (!is_float_vector(vect))
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }}}}}}
+ return_false(sc, NULL);
+}
+
+
+/* -------- d_vid -------- */
+static s7_double opt_d_vid_ssf(opt_info *o) {return(o->v[4].d_vid_f(o->v[5].obj, integer(slot_value(o->v[2].p)), o->v[11].fd(o->v[10].o1)));}
+
+static inline s7_double opt_fmv(opt_info *o)
+{
+ /* d_vid_ssf -> d_dd_ff_o1 -> d_vd_o1 -> d_dd_ff_o3, this is a placeholder */
+ opt_info *o1 = o->v[12].o1;
+ opt_info *o2 = o->v[13].o1;
+ opt_info *o3 = o->v[14].o1;
+ s7_double amp_env = o1->v[2].d_v_f(o1->v[1].obj);
+ 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)))));
+}
+
+static bool d_vid_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ if ((is_symbol(cadr(car_x))) &&
+ (is_symbol(caddr(car_x))))
+ {
+ s7_pointer sig;
+ s7_d_vid_t flt = s7_d_vid_function(s_func);
+ if (!flt)
+ 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;
+ }}
+ return_false(sc, car_x);
+}
+
+/* -------- d_vdd -------- */
+static s7_double opt_d_vdd_ff(opt_info *o)
+{
+ s7_double x1 = o->v[11].fd(o->v[10].o1);
+ s7_double x2 = o->v[9].fd(o->v[8].o1);
+ return(o->v[4].d_vdd_f(o->v[5].obj, x1, x2));
+}
+
+static bool d_vdd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_d_vdd_t flt = s7_d_vdd_function(s_func);
+ if (flt)
+ {
+ 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;
+ }}}
+ return_false(sc, car_x);
+}
+
+
+/* -------- d_dddd -------- */
+static s7_double opt_d_dddd_ffff(opt_info *o)
+{
+ s7_double x1 = o->v[11].fd(o->v[10].o1);
+ s7_double x2 = o->v[9].fd(o->v[8].o1);
+ s7_double x3 = o->v[5].fd(o->v[4].o1);
+ s7_double x4 = o->v[3].fd(o->v[2].o1);
+ return(o->v[1].d_dddd_f(x1, x2, x3, x4));
+}
+
+static bool d_dddd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_d_dddd_t f = s7_d_dddd_function(s_func);
+ if (!f)
+ return_false(sc, car_x);
+ opc->v[10].o1 = sc->opts[sc->pc];
+ if (float_optimize(sc, cdr(car_x)))
+ {
+ 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);
+ }}}}
+ return_false(sc, car_x);
+}
+
+/* -------- d_add|multiply|subtract_any ------- */
+static s7_double opt_d_add_any_f(opt_info *o)
+{
+ s7_double sum = 0.0;
+ for (s7_int i = 0; i < o->v[1].i; i++)
+ {
+ opt_info *o1 = o->v[i + 2].o1;
+ sum += o1->v[0].fd(o1);
+ }
+ return(sum);
+}
+
+static s7_double opt_d_multiply_any_f(opt_info *o)
+{
+ s7_double sum = 1.0;
+ for (s7_int i = 0; i < o->v[1].i; i++)
+ {
+ opt_info *o1 = o->v[i + 2].o1;
+ sum *= o1->v[0].fd(o1);
+ }
+ return(sum);
+}
+
+static bool d_add_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer car_x)
+{
+ s7_pointer head = car(car_x);
+ int32_t start = sc->pc;
+ if ((head == sc->add_symbol) ||
+ (head == sc->multiply_symbol))
+ {
+ 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;
+ }
+ 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);
+ }}
+ sc->pc = start;
+ return_false(sc, car_x);
+}
+
+
+/* -------- d_syntax -------- */
+static s7_double opt_set_d_d_f(opt_info *o)
+{
+ s7_double x = o->v[3].fd(o->v[2].o1);
+ slot_set_value(o->v[1].p, make_real(o->sc, x));
+ return(x);
+}
+
+static s7_double opt_set_d_d_fm(opt_info *o)
+{
+ s7_double x = o->v[3].fd(o->v[2].o1);
+ check_mutability(o->sc, o, __func__, __LINE__);
+ set_real(slot_value(o->v[1].p), x);
+ return(x);
+}
+
+static bool d_syntax_ok(s7_scheme *sc, s7_pointer car_x, int32_t len)
+{
+ if ((len == 3) &&
+ (car(car_x) == sc->set_symbol))
+ {
+ 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);
+ }}}
+ 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)));
+ }}
+ return_false(sc, car_x);
+}
+
+static bool d_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, int32_t len)
+{
+ s7_pointer slot, obj = slot_value(s_slot);
+ if (is_float_vector(obj))
+ {
+ /* 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);
+ }
+ 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);
+ }}}
+ 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);
+ }}}}}
+ 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);
+ }}}}
+ return_false(sc, car_x);
+}
+
+
+/* -------------------------------- bool opts -------------------------------- */
+static bool opt_b_s(opt_info *o) {return(slot_value(o->v[1].p) != o->sc->F);}
+
+static bool opt_bool_not_pair(s7_scheme *sc, s7_pointer car_x)
+{
+ s7_pointer p;
+ if (!is_symbol(car_x))
+ return_false(sc, car_x); /* i.e. use cell_optimize */
+ p = opt_simple_symbol(sc, car_x);
+ if ((p) &&
+ (is_boolean(slot_value(p))))
+ {
+ opt_info *opc = alloc_opt_info(sc);
+ opc->v[1].p = p;
+ opc->v[0].fb = opt_b_s;
+ return_true(sc, car_x);
+ }
+ return_false(sc, car_x);
+}
+
+/* -------- b_idp -------- */
+static bool opt_b_i_s(opt_info *o) {return(o->v[2].b_i_f(integer(slot_value(o->v[1].p))));}
+static bool opt_b_i_f(opt_info *o) {return(o->v[2].b_i_f(o->v[11].fi(o->v[10].o1)));}
+static bool opt_b_d_s(opt_info *o) {return(o->v[2].b_d_f(real(slot_value(o->v[1].p))));}
+static bool opt_b_d_f(opt_info *o) {return(o->v[2].b_d_f(o->v[11].fd(o->v[10].o1)));}
+static bool opt_b_p_s(opt_info *o) {return(o->v[2].b_p_f(slot_value(o->v[1].p)));}
+static bool opt_b_p_f(opt_info *o) {return(o->v[2].b_p_f(o->v[4].fp(o->v[3].o1)));}
+static bool opt_b_7p_s(opt_info *o) {return(o->v[2].b_7p_f(o->sc, slot_value(o->v[1].p)));}
+static bool opt_b_7p_s_not(opt_info *o) {return(slot_value(o->v[1].p) == o->sc->F);}
+static bool opt_b_7p_f(opt_info *o) {return(o->v[2].b_7p_f(o->sc, o->v[4].fp(o->v[3].o1)));}
+static bool opt_b_d_s_is_positive(opt_info *o) {return(real(slot_value(o->v[1].p)) > 0.0);}
+static bool opt_b_p_s_is_integer(opt_info *o) {return(s7_is_integer(slot_value(o->v[1].p)));}
+static bool opt_b_p_s_is_pair(opt_info *o) {return(is_pair(slot_value(o->v[1].p)));}
+static bool opt_b_p_f_is_string(opt_info *o) {return(s7_is_string(o->v[4].fp(o->v[3].o1)));}
+static bool opt_b_7p_s_iter_at_end(opt_info *o) {return(iterator_is_at_end(slot_value(o->v[1].p)));}
+static bool opt_b_7p_f_not(opt_info *o) {return((o->v[4].fp(o->v[3].o1)) == o->sc->F);}
+
+static bool opt_zero_mod(opt_info *o)
+{
+ s7_int x = integer(slot_value(o->v[1].p));
+ return((x % o->v[2].i) == 0);
+}
+
+static bool b_idp_ok(s7_scheme *sc, s7_pointer s_func, s7_pointer car_x, const s7_pointer arg_type)
+{
+ s7_b_p_t bpf = NULL;
+ s7_b_7p_t bpf7 = NULL;
+ opt_info *opc = alloc_opt_info(sc);
+ int32_t cur_index = sc->pc;
+
+ if ((arg_type == sc->is_integer_symbol) || (arg_type == sc->is_byte_symbol))
+ {
+ 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);
+ }}}
+ 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);
+ }}}
+ sc->pc = cur_index;
+
+ bpf = s7_b_p_function(s_func);
+ if (!bpf) bpf7 = s7_b_7p_function(s_func);
+ if ((bpf) || (bpf7))
+ {
+ if (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);
+ }
+ 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);
+ }}
+ return_false(sc, car_x);
+}
+
+
+/* -------- b_pp -------- */
+static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp)
+{
+ s7_pointer slot, arg = car(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));
+ }}
+ 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));
+ }
+ return(sc->T);
+ }
+ if (is_symbol(arg))
+ {
+ slot = opt_simple_symbol(sc, arg);
+ if (!slot) return(sc->T);
+#if WITH_GMP
+ if (is_big_number(slot_value(slot)))
+ return(sc->T);
+ if ((is_t_integer(slot_value(slot))) &&
+ (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);
+#endif
+ return(s7_type_of(sc, slot_value(slot)));
+ }
+ return(s7_type_of(sc, arg));
+}
+
+static bool opt_b_pp_sf(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));}
+static bool opt_b_pp_fs(opt_info *o) {return(o->v[3].b_pp_f(o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));}
+static bool opt_b_pp_ss(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), slot_value(o->v[2].p)));}
+static bool opt_b_pp_sc(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[2].p));}
+static bool opt_b_pp_sfo(opt_info *o) {return(o->v[3].b_pp_f(slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));}
+static bool opt_b_7pp_sf(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[11].fp(o->v[10].o1)));}
+static bool opt_b_7pp_fs(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, o->v[11].fp(o->v[10].o1), slot_value(o->v[1].p)));}
+static bool opt_b_7pp_ss(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));}
+static bool opt_b_7pp_ss_lt(opt_info *o) {return(lt_b_7pp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));}
+static bool opt_b_7pp_ss_gt(opt_info *o) {return(gt_b_7pp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));}
+static bool opt_b_7pp_ss_char_lt(opt_info *o) {return(char_lt_b_7pp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));}
+static bool opt_b_7pp_sc(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));}
+static bool opt_b_7pp_sfo(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));}
+static bool opt_is_equal_sfo(opt_info *o) {return(s7_is_equal(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p))));}
+static bool opt_is_equivalent_sfo(opt_info *o) {return(is_equivalent_1(o->sc, slot_value(o->v[1].p), o->v[4].p_p_f(o->sc, slot_value(o->v[2].p)), NULL));}
+static bool opt_b_pp_sf_char_eq(opt_info *o) {return(slot_value(o->v[1].p) == o->v[11].fp(o->v[10].o1));} /* lt above checks for char args */
+static bool opt_b_7pp_ff(opt_info *o) {s7_pointer p1 = o->v[9].fp(o->v[8].o1); return(o->v[3].b_7pp_f(o->sc, p1, o->v[11].fp(o->v[10].o1)));}
+static bool opt_b_pp_ff(opt_info *o) {s7_pointer p1 = o->v[9].fp(o->v[8].o1); return(o->v[3].b_pp_f(p1, o->v[11].fp(o->v[10].o1)));}
+static bool opt_b_pp_ff_char_eq(opt_info *o) {return(o->v[9].fp(o->v[8].o1) == o->v[11].fp(o->v[10].o1));}
+static bool opt_b_pp_fc_char_eq(opt_info *o) {return(o->v[9].fp(o->v[8].o1) == o->v[11].p);}
+static bool opt_b_pp_fc(opt_info *o) {return(o->v[3].b_pp_f(o->v[9].fp(o->v[8].o1), o->v[11].p));}
+static bool opt_b_7pp_fc(opt_info *o) {return(o->v[3].b_7pp_f(o->sc, o->v[9].fp(o->v[8].o1), o->v[11].p));}
+
+static bool opt_car_equal_sf(opt_info *o)
+{
+ s7_pointer p = slot_value(o->v[2].p);
+ return(s7_is_equal(o->sc, slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(o->sc, set_plist_1(o->sc, p))));
+}
+
+static bool opt_car_equivalent_sf(opt_info *o)
+{
+ s7_pointer p = slot_value(o->v[2].p);
+ return(is_equivalent_1(o->sc, slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(o->sc, set_plist_1(o->sc, p)), NULL));
+}
+
+static bool opt_b_7pp_car_sf(opt_info *o)
+{
+ s7_pointer p = slot_value(o->v[2].p);
+ return(o->v[3].b_7pp_f(o->sc, slot_value(o->v[1].p), (is_pair(p)) ? car(p) : g_car(o->sc, set_plist_1(o->sc, p))));
+}
+
+static s7_pointer opt_p_substring_uncopied_ssf(opt_info *o) /* "inline" here rather than copying below is much slower? */
+{
+ return(substring_uncopied_p_pii(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[6].fi(o->v[5].o1)));
+}
+
+static bool opt_substring_equal_sf(opt_info *o) {return(scheme_strings_are_equal(slot_value(o->v[1].p), opt_p_substring_uncopied_ssf(o->v[10].o1)));}
+
+static s7_pointer opt_p_p_s(opt_info *o);
+
+static bool b_pp_sf_combinable(s7_scheme *sc, opt_info *opc, bool bpf_case)
+{
+ if ((sc->pc > 1) &&
+ (opc == sc->opts[sc->pc - 2]))
+ {
+ 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);
+ }}
+ return_false(sc, NULL);
+}
+
+static bool opt_b_pp_ffo(opt_info *o)
+{
+ s7_pointer b1 = o->v[4].p_p_f(o->sc, slot_value(o->v[1].p));
+ return(o->v[3].b_pp_f(b1, o->v[5].p_p_f(o->sc, slot_value(o->v[2].p))));
+}
+
+static bool opt_b_pp_ffo_is_eq(opt_info *o)
+{
+ s7_pointer b1 = o->v[4].p_p_f(o->sc, slot_value(o->v[1].p));
+ s7_pointer b2 = o->v[5].p_p_f(o->sc, slot_value(o->v[2].p));
+ return((b1 == b2) || ((is_unspecified(b1)) && (is_unspecified(b2))));
+}
+
+static bool opt_b_7pp_ffo(opt_info *o)
+{
+ s7_pointer b1 = o->v[4].p_p_f(o->sc, slot_value(o->v[1].p));
+ return(o->v[3].b_7pp_f(o->sc, b1, o->v[5].p_p_f(o->sc, slot_value(o->v[2].p))));
+}
+
+static bool opt_b_cadr_cadr(opt_info *o)
+{
+ s7_pointer p1 = slot_value(o->v[1].p);
+ s7_pointer p2 = slot_value(o->v[2].p);
+ p1 = ((is_pair(p1)) && (is_pair(cdr(p1)))) ? cadr(p1) : g_cadr(o->sc, set_plist_1(o->sc, p1));
+ p2 = ((is_pair(p2)) && (is_pair(cdr(p2)))) ? cadr(p2) : g_cadr(o->sc, set_plist_1(o->sc, p2));
+ return(o->v[3].b_7pp_f(o->sc, p1, p2));
+}
+
+static bool b_pp_ff_combinable(s7_scheme *sc, opt_info *opc, bool bpf_case)
+{
+ if ((sc->pc > 2) &&
+ (opc == sc->opts[sc->pc - 3]))
+ {
+ 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);
+ }}
+ return_false(sc, NULL);
+}
+
+static void check_b_types(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, bool (*fb)(opt_info *o))
+{
+ if (s7_b_pp_unchecked_function(s_func))
+ {
+ s7_pointer call_sig = c_function_signature(s_func);
+ 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);
+ }}
+}
+
+static s7_pointer opt_p_c(opt_info *o);
+
+static bool b_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg1, s7_pointer arg2, bool bpf_case)
+{
+ int32_t cur_index = sc->pc;
+ opt_info *o1;
+ /* v[3] is set when we get here */
+ if ((is_symbol(arg1)) &&
+ (is_symbol(arg2)))
+ {
+ 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 :
+ ((b7f == char_lt_b_7pp) ? opt_b_7pp_ss_char_lt : opt_b_7pp_ss)));
+ 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);
+ 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);
+ }
+ 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);
+ }
+ sc->pc = cur_index;
+ }
+ else
+ if ((is_symbol(arg2)) &&
+ (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;
+ }
+ 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);
+ }}
+ return_false(sc, car_x);
+}
+
+/* -------- b_pi -------- */
+static bool opt_b_pi_fs(opt_info *o) {return(o->v[2].b_pi_f(o->sc, o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p))));}
+static bool opt_b_pi_fs_num_eq(opt_info *o) {return(num_eq_b_pi(o->sc, o->v[11].fp(o->v[10].o1), integer(slot_value(o->v[1].p))));}
+static bool opt_b_pi_fi(opt_info *o) {return(o->v[2].b_pi_f(o->sc, o->v[11].fp(o->v[10].o1), o->v[1].i));}
+static bool opt_b_pi_ff(opt_info *o) {s7_pointer p1 = o->v[11].fp(o->v[10].o1); return(o->v[2].b_pi_f(o->sc, p1, o->v[9].fi(o->v[8].o1)));}
+
+static bool b_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg2)
+{
+ s7_b_pi_t bpif = s7_b_pi_function(s_func); /* perhaps add vector-ref/equal? */
+ if (bpif)
+ {
+ 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);
+ }}}
+ return_false(sc, car_x);
+}
+
+
+/* -------- b_dd -------- */
+static bool opt_b_dd_ss(opt_info *o) {return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), real(slot_value(o->v[2].p))));}
+static bool opt_b_dd_ss_lt(opt_info *o) {return(real(slot_value(o->v[1].p)) < real(slot_value(o->v[2].p)));}
+static bool opt_b_dd_ss_gt(opt_info *o) {return(real(slot_value(o->v[1].p)) > real(slot_value(o->v[2].p)));}
+
+static bool opt_b_dd_sc(opt_info *o) {return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[2].x));}
+static bool opt_b_dd_sc_lt(opt_info *o) {return(real(slot_value(o->v[1].p)) < o->v[2].x);}
+static bool opt_b_dd_sc_geq(opt_info *o) {return(real(slot_value(o->v[1].p)) >= o->v[2].x);}
+static bool opt_b_dd_sc_eq(opt_info *o) {return(real(slot_value(o->v[1].p)) == o->v[2].x);}
+
+static bool opt_b_dd_sf(opt_info *o) {return(o->v[3].b_dd_f(real(slot_value(o->v[1].p)), o->v[11].fd(o->v[10].o1)));}
+static bool opt_b_dd_fs(opt_info *o) {return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), real(slot_value(o->v[1].p))));}
+static bool opt_b_dd_fs_gt(opt_info *o) {return(o->v[11].fd(o->v[10].o1) > real(slot_value(o->v[1].p)));}
+static bool opt_b_dd_fc(opt_info *o) {return(o->v[3].b_dd_f(o->v[11].fd(o->v[10].o1), o->v[1].x));}
+static bool opt_b_dd_fc_gt(opt_info *o) {return(o->v[11].fd(o->v[10].o1) > o->v[1].x);}
+
+static bool opt_b_dd_ff(opt_info *o)
+{
+ s7_double x1 = o->v[11].fd(o->v[10].o1);
+ s7_double x2 = o->v[9].fd(o->v[8].o1);
+ return(o->v[3].b_dd_f(x1, x2));
+}
+
+static bool b_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg1, s7_pointer arg2)
+{
+ s7_b_dd_t bif = s7_b_dd_function(s_func);
+ int32_t cur_index = sc->pc;
+ if (!bif)
+ return_false(sc, car_x);
+ opc->v[3].b_dd_f = bif;
+ 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_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[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);
+ }}
+ 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);
+ }
+ 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[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);
+ }}
+ sc->pc = cur_index;
+ return_false(sc, car_x);
+}
+
+
+/* -------- b_ii -------- */
+static bool opt_b_ii_ss(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));}
+static bool opt_b_ii_ss_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < integer(slot_value(o->v[2].p)));}
+static bool opt_b_ii_ss_gt(opt_info *o) {return(integer(slot_value(o->v[1].p)) > integer(slot_value(o->v[2].p)));}
+static bool opt_b_ii_ss_leq(opt_info *o) {return(integer(slot_value(o->v[1].p)) <= integer(slot_value(o->v[2].p)));}
+static bool opt_b_ii_ss_geq(opt_info *o) {return(integer(slot_value(o->v[1].p)) >= integer(slot_value(o->v[2].p)));}
+static bool opt_b_ii_ss_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == integer(slot_value(o->v[2].p)));}
+static bool opt_b_ii_sc(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[2].i));}
+static bool opt_b_ii_sc_lt(opt_info *o) {return(integer(slot_value(o->v[1].p)) < o->v[2].i);}
+static bool opt_b_ii_sc_leq(opt_info *o) {return(integer(slot_value(o->v[1].p)) <= o->v[2].i);}
+static bool opt_b_ii_sc_gt(opt_info *o) {return(integer(slot_value(o->v[1].p)) > o->v[2].i);}
+static bool opt_b_ii_sc_geq(opt_info *o) {return(integer(slot_value(o->v[1].p)) >= o->v[2].i);}
+static bool opt_b_ii_sc_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == o->v[2].i);}
+static bool opt_b_ii_sc_lt_2(opt_info *o) {return(integer(slot_value(o->v[1].p)) < 2);}
+static bool opt_b_ii_sc_lt_1(opt_info *o) {return(integer(slot_value(o->v[1].p)) < 1);}
+static bool opt_b_ii_sc_lt_0(opt_info *o) {return(integer(slot_value(o->v[1].p)) < 0);}
+static bool opt_b_ii_sc_leq_0(opt_info *o){return(integer(slot_value(o->v[1].p)) <= 0);}
+static bool opt_b_ii_sc_gt_0(opt_info *o) {return(integer(slot_value(o->v[1].p)) > 0);}
+static bool opt_b_ii_sc_geq_0(opt_info *o){return(integer(slot_value(o->v[1].p)) >= 0);}
+static bool opt_b_ii_sc_eq_0(opt_info *o) {return(integer(slot_value(o->v[1].p)) == 0);}
+static bool opt_b_ii_sc_eq_1(opt_info *o) {return(integer(slot_value(o->v[1].p)) == 1);}
+
+static bool opt_b_7ii_ss(opt_info *o) {return(o->v[3].b_7ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));}
+static bool opt_b_7ii_sc(opt_info *o) {return(o->v[3].b_7ii_f(o->sc, integer(slot_value(o->v[1].p)), o->v[2].i));}
+static bool opt_b_7ii_sc_bit(opt_info *o) {return((integer(slot_value(o->v[1].p)) & ((int64_t)(1LL << o->v[2].i))) != 0);}
+
+static bool opt_b_ii_ff(opt_info *o)
+{
+ s7_int i1 = o->v[11].fi(o->v[10].o1);
+ s7_int i2 = o->v[9].fi(o->v[8].o1);
+ return(o->v[3].b_ii_f(i1, i2));
+}
+
+static bool opt_b_ii_fs(opt_info *o) {return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));}
+static bool opt_b_ii_sf(opt_info *o) {return(o->v[3].b_ii_f(integer(slot_value(o->v[1].p)), o->v[11].fi(o->v[10].o1)));}
+static bool opt_b_ii_sf_eq(opt_info *o) {return(integer(slot_value(o->v[1].p)) == o->v[11].fi(o->v[10].o1));}
+static bool opt_b_ii_fc(opt_info *o) {return(o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i));}
+static bool opt_b_ii_fc_eq(opt_info *o) {return(o->v[11].fi(o->v[10].o1) == o->v[2].i);}
+
+static bool b_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, s7_pointer arg1, s7_pointer arg2)
+{
+ s7_b_ii_t bif = s7_b_ii_function(s_func);
+ s7_b_7ii_t b7if = NULL;
+ if (!bif)
+ {
+ b7if = s7_b_7ii_function(s_func);
+ if (!b7if)
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }
+ return_false(sc, car_x);
+ }
+ if (!bif) return_false(sc, car_x);
+
+ if (is_symbol(arg2))
+ {
+ 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[2].p = s7_slot(sc, arg2);
+ opc->v[0].fb = opt_b_ii_fs;
+ 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;
+ 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[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);
+ }}
+ return_false(sc, car_x);
+}
+
+/* -------- b_or|and -------- */
+static bool opt_and_bb(opt_info *o) {return((o->v[3].fb(o->v[2].o1)) && (o->v[11].fb(o->v[10].o1)));}
+
+static bool opt_and_any_b(opt_info *o)
+{
+ for (s7_int i = 0; i < o->v[1].i; i++)
+ {
+ opt_info *o1 = o->v[i + 3].o1;
+ if (!o1->v[0].fb(o1))
+ return(false);
+ }
+ return(true);
+}
+
+static bool opt_or_bb(opt_info *o) {return((o->v[3].fb(o->v[2].o1)) || o->v[11].fb(o->v[10].o1));}
+
+static bool opt_or_any_b(opt_info *o)
+{
+ for (s7_int i = 0; i < o->v[1].i; i++)
+ {
+ opt_info *o1 = o->v[i + 3].o1;
+ if (o1->v[0].fb(o1))
+ return(true);
+ }
+ return(false);
+}
+
+static bool opt_b_or_and(s7_scheme *sc, s7_pointer car_x, int32_t len, int32_t is_and)
+{
+ opt_info *opc = alloc_opt_info(sc);
+ s7_pointer p = cdr(car_x);
+ if (len == 3)
+ {
+ 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);
+ }}
+ return_false(sc, car_x);
+ }
+ opc->v[1].i = (len - 1);
+ for (int32_t i = 0; (is_pair(p)) && (i < 12); i++, p = cdr(p))
+ {
+ opc->v[i + 3].o1 = sc->opts[sc->pc];
+ if (!bool_optimize_nw(sc, p))
+ break;
+ }
+ if (!is_null(p))
+ return_false(sc, car_x);
+ opc->v[0].fb = (is_and) ? opt_and_any_b : opt_or_any_b;
+ return_true(sc, car_x);
+}
+
+static bool opt_b_and(s7_scheme *sc, s7_pointer car_x, int32_t len) {return(opt_b_or_and(sc, car_x, len, true));}
+static bool opt_b_or(s7_scheme *sc, s7_pointer car_x, int32_t len) {return(opt_b_or_and(sc, car_x, len, false));}
+
+
+/* ---------------------------------------- cell opts ---------------------------------------- */
+static s7_pointer opt_p_c(opt_info *o) {return(o->v[1].p);}
+static s7_pointer opt_p_s(opt_info *o) {return(slot_value(o->v[1].p));}
+
+static bool opt_cell_not_pair(s7_scheme *sc, s7_pointer car_x)
+{
+ s7_pointer p;
+ opt_info *opc;
+ if (!is_symbol(car_x))
+ {
+ opc = alloc_opt_info(sc);
+ opc->v[1].p = car_x;
+ opc->v[0].fp = opt_p_c;
+ return_true(sc, car_x);
+ }
+ p = opt_simple_symbol(sc, car_x);
+ if (!p)
+ return_false(sc, car_x);
+ opc = alloc_opt_info(sc);
+ opc->v[1].p = p;
+ opc->v[0].fp = opt_p_s;
+ return_true(sc, car_x);
+}
+
+/* -------- p -------- */
+#define is_opt_safe(P) ((optimize_op(P) >= OP_SAFE_C_S) && (!is_unknown_op(optimize_op(P))))
+
+#define cf_call(Sc, Car_x, S_func, Num) \
+ (((is_optimized(Car_x)) && (is_opt_safe(Car_x))) ? fn_proc(Car_x) : c_function_call(c_function_chooser(S_func)(Sc, S_func, Num, Car_x))) /* was ops=false 19-Mar-24 */
+
+static s7_pointer opt_p_f(opt_info *o) {return(o->v[1].p_f(o->sc));}
+static s7_pointer opt_p_call(opt_info *o) {return(o->v[1].call(o->sc, o->sc->nil));}
+
+static bool p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_p_t func = s7_p_function(s_func);
+ if (func)
+ {
+ opc->v[1].p_f = func;
+ opc->v[0].fp = opt_p_f;
+ return_true(sc, car_x);
+ }
+ if ((is_safe_procedure(s_func)) &&
+ (c_function_min_args(s_func) == 0))
+ {
+ opc->v[1].call = cf_call(sc, car_x, s_func, 0);
+ opc->v[0].fp = opt_p_call;
+ return_true(sc, car_x);
+ }
+ return_false(sc, car_x);
+}
+
+/* -------- p_p -------- */
+static s7_pointer opt_p_p_c(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[1].p));}
+static s7_pointer opt_p_i_c(opt_info *o) {return(make_integer(o->sc, o->v[2].i_i_f(o->v[1].i)));}
+static s7_pointer opt_p_7i_c(opt_info *o) {return(make_integer(o->sc, o->v[2].i_7i_f(o->sc, o->v[1].i)));}
+static s7_pointer opt_p_d_c(opt_info *o) {return(make_real(o->sc, o->v[2].d_d_f(o->v[1].x)));}
+static s7_pointer opt_p_7d_c(opt_info *o) {return(make_real(o->sc, o->v[2].d_7d_f(o->sc, o->v[1].x)));}
+static s7_pointer opt_p_p_s(opt_info *o) {return(o->v[2].p_p_f(o->sc, slot_value(o->v[1].p)));}
+static s7_pointer opt_p_p_s_abs(opt_info *o) {return(abs_p_p(o->sc, slot_value(o->v[1].p)));}
+static s7_pointer opt_p_p_s_cdr(opt_info *o) {s7_pointer p = slot_value(o->v[1].p); return((is_pair(p)) ? cdr(p) : cdr_p_p(o->sc, p));}
+static s7_pointer opt_p_p_f(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[4].fp(o->v[3].o1)));}
+static s7_pointer opt_p_p_f1(opt_info *o) {return(o->v[2].p_p_f(o->sc, o->v[3].p_p_f(o->sc, slot_value(o->v[1].p))));}
+static s7_pointer opt_p_p_f_exp(opt_info *o) {return(exp_p_p(o->sc, o->v[4].fp(o->v[3].o1)));}
+static s7_pointer opt_p_7d_c_random(opt_info *o) {return(make_real(o->sc, random_d_7d(o->sc, o->v[1].x)));}
+static s7_pointer opt_p_p_s_iterate(opt_info *o) {return(iterate_p_p(o->sc, slot_value(o->v[1].p)));}
+static s7_pointer opt_p_p_f_iterate(opt_info *o) {return(iterate_p_p(o->sc, o->v[4].fp(o->v[3].o1)));}
+static s7_pointer opt_p_p_f_string_to_number(opt_info *o) {return(string_to_number_p_p(o->sc, o->v[4].fp(o->v[3].o1)));}
+static s7_pointer opt_p_p_s_iterate_unchecked(opt_info *o) {s7_pointer iter = slot_value(o->v[1].p); return(iterator_next(iter)(o->sc, iter));}
+/* string_iterate built-in here if iterator_sequence is a string is about 12% faster, but currently we can have an unchecked iterator
+ * that changes sequence type (via (set! L1 L2) where L1 and L2 are both iterators)
+ */
+
+static s7_pointer opt_p_pi_ss_vref_direct(opt_info *o);
+static s7_pointer opt_p_pi_ss_fvref_direct(opt_info *o);
+static s7_pointer opt_p_pi_ss_ivref_direct(opt_info *o);
+static s7_pointer opt_p_pi_ss_fvref_direct_wrapped(opt_info *o);
+static s7_pointer opt_p_pi_ss_ivref_direct_wrapped(opt_info *o);
+static s7_pointer opt_p_p_fvref(opt_info *o) {return(o->v[2].p_p_f(o->sc, opt_p_pi_ss_fvref_direct_wrapped(o->v[3].o1)));} /* unwrap to fvref is not faster */
+static s7_pointer opt_p_p_ivref(opt_info *o) {return(o->v[2].p_p_f(o->sc, opt_p_pi_ss_ivref_direct_wrapped(o->v[3].o1)));} /* unwrap to ivref is not faster */
+static s7_pointer opt_p_p_vref(opt_info *o) {return(o->v[2].p_p_f(o->sc, opt_p_pi_ss_vref_direct(o->v[3].o1)));}
+
+static bool p_p_f_combinable(s7_scheme *sc, opt_info *opc)
+{
+ if ((sc->pc > 1) &&
+ (opc == sc->opts[sc->pc - 2]))
+ {
+ 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);
+ }}
+ return_false(sc, NULL);
+}
+
+static s7_pointer opt_p_call_f(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[5].fp(o->v[4].o1))));}
+static s7_pointer opt_p_call_s(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, slot_value(o->v[1].p))));}
+static s7_pointer opt_p_call_c(opt_info *o) {return(o->v[2].call(o->sc, set_plist_1(o->sc, o->v[1].p)));}
+
+static bool p_p_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_p_p_t ppf;
+ int32_t start = sc->pc;
+ s7_pointer arg1 = cadr(car_x);
+ if (is_t_integer(arg1))
+ {
+ s7_i_i_t iif = s7_i_i_function(s_func);
+ 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);
+ }
+ 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);
+ }}
+ 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);
+ }
+ 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);
+ }}
+ 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;
+
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }}
+
+ 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);
+ }}
+ 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);
+ }}}
+ return_false(sc, car_x);
+}
+
+/* -------- p_i -------- */
+static s7_pointer opt_p_i_s(opt_info *o) {return(o->v[2].p_i_f(o->sc, integer(slot_value(o->v[1].p))));} /* number_to_string_p_i expanded here doesn't gain much */
+static s7_pointer opt_p_i_f(opt_info *o) {return(o->v[2].p_i_f(o->sc, o->v[4].fi(o->v[3].o1)));}
+static s7_pointer opt_p_i_f_intc(opt_info *o) {return(integer_to_char_p_i(o->sc, o->v[4].fi(o->v[3].o1)));}
+
+static bool p_i_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart)
+{
+ s7_pointer p;
+ s7_p_i_t ifunc = s7_p_i_function(s_func);
+ if (!ifunc)
+ return_false(sc, car_x);
+ p = opt_integer_symbol(sc, cadr(car_x));
+ if (p)
+ {
+ opc->v[1].p = p;
+ opc->v[2].p_i_f = ifunc;
+ opc->v[0].fp = opt_p_i_s;
+ return_true(sc, car_x);
+ }
+ if (int_optimize(sc, cdr(car_x)))
+ {
+ opc->v[2].p_i_f = ifunc;
+ opc->v[0].fp = (ifunc == integer_to_char_p_i) ? opt_p_i_f_intc : opt_p_i_f;
+ opc->v[3].o1 = sc->opts[pstart];
+ opc->v[4].fi = sc->opts[pstart]->v[0].fi;
+ return_true(sc, car_x);
+ }
+ sc->pc = pstart;
+ return_false(sc, car_x);
+}
+
+/* -------- p_ii -------- */
+static s7_pointer opt_p_ii_ss(opt_info *o) {return(o->v[3].p_ii_f(o->sc, integer(slot_value(o->v[1].p)), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_ii_fs(opt_info *o) {return(o->v[3].p_ii_f(o->sc, o->v[11].fi(o->v[10].o1), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_ii_ff_divide(opt_info *o) {return(make_ratio_with_div_check(o->sc, o->sc->divide_symbol, o->v[11].fi(o->v[10].o1), o->v[9].fi(o->v[8].o1)));}
+
+static s7_pointer opt_p_ii_ff(opt_info *o)
+{
+ s7_int i1 = o->v[11].fi(o->v[10].o1);
+ return(o->v[3].p_ii_f(o->sc, i1, o->v[9].fi(o->v[8].o1)));
+}
+
+static bool p_ii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart)
+{
+ s7_pointer p2;
+ s7_p_ii_t ifunc = s7_p_ii_function(s_func);
+ if (!ifunc)
+ return_false(sc, car_x);
+ p2 = opt_integer_symbol(sc, caddr(car_x));
+ if (p2)
+ {
+ 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[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);
+ }
+ sc->pc = pstart;
+ return_false(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[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);
+}
+
+/* -------- p_d -------- */
+static s7_pointer opt_p_d_s(opt_info *o) {return(o->v[2].p_d_f(o->sc, real_to_double(o->sc, slot_value(o->v[1].p), __func__)));}
+static s7_pointer opt_p_d_f(opt_info *o) {return(o->v[2].p_d_f(o->sc, o->v[4].fd(o->v[3].o1)));}
+/* static s7_pointer opt_p_d_fvref(opt_info *o) {return(o->v[2].p_d_f(o->sc, float_vector(slot_value(o->v[1].p), integer(slot_value(o->v[2].p)))));} */
+
+static bool p_d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart)
+{
+ s7_pointer p;
+ opt_info *o1;
+ s7_p_d_t ifunc = s7_p_d_function(s_func);
+
+ if (!ifunc)
+ return_false(sc, car_x);
+ p = opt_float_symbol(sc, cadr(car_x));
+ if (p)
+ {
+ opc->v[1].p = p;
+ opc->v[2].p_d_f = ifunc;
+ opc->v[0].fp = opt_p_d_s;
+ return_true(sc, car_x);
+ }
+ if ((is_number(cadr(car_x))) && (!is_t_real(cadr(car_x))))
+ return_false(sc, car_x);
+ o1 = sc->opts[sc->pc];
+ if (float_optimize(sc, cdr(car_x)))
+ {
+ opc->v[2].p_d_f = ifunc;
+ opc->v[0].fp = opt_p_d_f;
+ opc->v[3].o1 = o1;
+ opc->v[4].fd = o1->v[0].fd;
+ return_true(sc, car_x);
+ }
+ sc->pc = pstart;
+ return_false(sc, car_x);
+}
+
+/* -------- p_dd -------- */
+static s7_pointer opt_p_dd_sc(opt_info *o) {return(o->v[3].p_dd_f(o->sc, real_to_double(o->sc, slot_value(o->v[1].p), __func__), o->v[2].x));}
+static s7_pointer opt_p_dd_cs(opt_info *o) {return(o->v[3].p_dd_f(o->sc, o->v[2].x, real_to_double(o->sc, slot_value(o->v[1].p), __func__)));}
+static s7_pointer opt_p_dd_cc(opt_info *o) {return(o->v[3].p_dd_f(o->sc, o->v[1].x, o->v[2].x));}
+
+static bool p_dd_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart)
+{
+ s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x);
+ s7_p_dd_t ifunc = s7_p_dd_function(s_func);
+ if (!ifunc)
+ return_false(sc, car_x);
+ 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);
+ }
+ 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);
+ }}
+ 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);
+ }}
+ sc->pc = pstart;
+ return_false(sc, car_x);
+}
+
+/* -------- p_pi -------- */
+static s7_pointer opt_p_pi_ss(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_pi_ss_sref(opt_info *o) {return(string_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_pi_ss_sref_direct(opt_info *o) {return(string_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_pi_ss_vref(opt_info *o) {return(t_vector_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_pi_ss_vref_direct(opt_info *o) {return(t_vector_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_pi_ss_fvref_direct(opt_info *o) {return(float_vector_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_pi_ss_ivref_direct(opt_info *o) {return(int_vector_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_pi_ss_fvref_direct_wrapped(opt_info *o) {return(float_vector_ref_p_pi_direct_wrapped(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_pi_ss_ivref_direct_wrapped(opt_info *o) {return(int_vector_ref_p_pi_direct_wrapped(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_pi_ss_pref(opt_info *o) {return(list_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p))));}
+static s7_pointer opt_p_pi_sc(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[2].i));}
+static s7_pointer opt_p_pi_sc_pref(opt_info *o) {return(list_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), o->v[2].i));}
+static s7_pointer opt_p_pi_sf(opt_info *o) {return(o->v[3].p_pi_f(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));}
+static s7_pointer opt_p_pi_sf_sref(opt_info *o) {return(string_ref_p_pi_unchecked(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));}
+static s7_pointer opt_p_pi_sf_sref_direct(opt_info *o) {return(string_ref_p_pi_direct(o->sc, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));}
+static s7_pointer opt_p_pi_fc(opt_info *o) {return(o->v[3].p_pi_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].i));}
+
+/* use a unique name (in this code) for this use of denominator -- this is a kludge -- we don't have anywhere in the slot
+ * to store the loop end, but the slot_value can be a small_int (or any unheaped integer), so we're assuming there
+ * aren't collisions? Each use is a single (uncomplicated) do loop, set up before each call?
+ */
+#if S7_DEBUGGING
+static s7_pointer check_loop_end_ref(s7_pointer p, const char *func, int32_t line)
+{
+ uint8_t typ = unchecked_type(T_Slt(p));
+ if (!has_loop_end(p)) complain("%s%s[%d]: loop_end not set, %s (%s)%s\n", p, func, line, typ);
+ return(T_Int(slot_value(p)));
+}
+#define loop_end(A) denominator(check_loop_end_ref(A, __func__, __LINE__))
+#else
+#define loop_end(A) denominator(T_Int(slot_value(A)))
+#endif
+#define set_loop_end(A, B) set_denominator(T_Int(slot_value(A)), B)
+
+static void check_unchecked(s7_scheme *sc, s7_pointer obj, s7_pointer slot, opt_info *opc, s7_pointer expr)
+{
+ switch (type(obj)) /* can't use funcs here (opc->v[3].p_pi_f et al) because there are so many, and copy depends on this choice */
+ {
+ 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;
+ 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;
+ 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;
+ 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;
+ 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;
+ break;
+ }
+}
+
+static void fixup_p_pi_ss(opt_info *opc)
+{
+ opc->v[0].fp = (opc->v[3].p_pi_f == string_ref_p_pi_unchecked) ? opt_p_pi_ss_sref :
+ ((opc->v[3].p_pi_f == string_ref_p_pi_direct) ? opt_p_pi_ss_sref_direct :
+ ((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))))));
+}
+
+static bool p_pi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer sig, s7_pointer car_x)
+{
+ s7_pointer obj = NULL, slot1, checker = NULL;
+ opt_info *o1;
+ s7_p_pi_t func = s7_p_pi_function(s_func);
+ if (!func)
+ return_false(sc, car_x);
+ /* here we know cadr is a symbol */
+ slot1 = opt_simple_symbol(sc, cadr(car_x));
+ if (!slot1)
+ return_false(sc, car_x);
+ if ((is_any_vector(slot_value(slot1))) &&
+ (vector_rank(slot_value(slot1)) > 1))
+ return_false(sc, car_x);
+
+ opc->v[3].p_pi_f = func;
+ opc->v[1].p = slot1;
+
+ if (is_symbol(cadr(sig)))
+ checker = cadr(sig);
+
+ if ((s7_p_pi_unchecked_function(s_func)) &&
+ (checker))
+ {
+ 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);
+ }}
+ 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);
+ fixup_p_pi_ss(opc);
+ return_true(sc, car_x);
+ }
+ if (is_t_integer(caddr(car_x)))
+ {
+ opc->v[2].i = integer(caddr(car_x));
+ opc->v[0].fp = (opc->v[3].p_pi_f == list_ref_p_pi_unchecked) ? opt_p_pi_sc_pref : opt_p_pi_sc;
+ return_true(sc, car_x);
+ }
+ o1 = sc->opts[sc->pc];
+ 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[4].o1 = o1;
+ opc->v[5].fi = o1->v[0].fi;
+ return_true(sc, car_x);
+ }
+ return_false(sc, car_x);
+}
+
+static s7_pointer opt_p_pi_fco(opt_info *o) {return(o->v[3].p_pi_f(o->sc, o->v[4].p_p_f(o->sc, slot_value(o->v[1].p)), o->v[2].i));}
+
+static bool p_pi_fc_combinable(s7_scheme *sc, opt_info *opc)
+{
+ if ((sc->pc > 1) &&
+ (opc == sc->opts[sc->pc - 2]))
+ {
+ 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);
+ }}
+ return_false(sc, NULL);
+}
+
+/* -------- p_pp -------- */
+static s7_pointer opt_p_pp_ss(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));}
+static s7_pointer opt_p_pp_sc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[2].p));}
+static s7_pointer opt_p_pp_slot_ref(opt_info *o) {return(slot_value(o->v[2].p));}
+static s7_pointer opt_p_pp_cs(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[2].p, slot_value(o->v[1].p)));}
+static s7_pointer opt_p_pp_sf(opt_info *o) {return(o->v[3].p_pp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pp_fs(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));}
+static s7_pointer opt_p_pp_fc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[5].fp(o->v[4].o1), o->v[2].p));}
+static s7_pointer opt_p_pp_cc(opt_info *o) {return(o->v[3].p_pp_f(o->sc, o->v[1].p, o->v[2].p));}
+static s7_pointer opt_p_pp_cc_make_list(opt_info *o) {return(make_list(o->sc, o->v[1].i, o->v[2].p));}
+static s7_pointer opt_set_car_pp_ss(opt_info *o) {return(inline_set_car(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));}
+static s7_pointer opt_p_pp_ss_href(opt_info *o) {return(s7_hash_table_ref(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p)));}
+static s7_pointer opt_p_pp_sf_add(opt_info *o) {return(add_p_pp(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pp_sf_sub(opt_info *o) {return(subtract_p_pp(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pp_sf_mul(opt_info *o) {return(multiply_p_pp(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pp_sf_set_car(opt_info *o) {return(inline_set_car(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pp_sf_set_cdr(opt_info *o) {return(inline_set_cdr(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pp_sf_href(opt_info *o) {return(s7_hash_table_ref(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pp_fs_vref(opt_info *o) {return(vector_ref_p_pp(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));}
+static s7_pointer opt_p_pp_fs_cons(opt_info *o) {return(cons(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));}
+static s7_pointer opt_p_pp_fs_add(opt_info *o) {return(add_p_pp(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));}
+static s7_pointer opt_p_pp_fs_sub(opt_info *o) {return(subtract_p_pp(o->sc, o->v[5].fp(o->v[4].o1), slot_value(o->v[1].p)));}
+
+static s7_pointer opt_p_pp_ss_lref(opt_info *o)
+{
+ s7_pointer sym = slot_value(o->v[2].p);
+ if (is_symbol(sym))
+ return(let_ref_p_pp(o->sc, slot_value(o->v[1].p), (is_keyword(sym)) ? keyword_symbol(sym) : sym));
+ return(let_ref(o->sc, slot_value(o->v[1].p), sym));
+}
+
+static s7_pointer opt_p_pp_sf_lref(opt_info *o)
+{
+ s7_pointer sym = o->v[5].fp(o->v[4].o1);
+ if (is_symbol(sym))
+ return(let_ref_p_pp(o->sc, slot_value(o->v[1].p), (is_keyword(sym)) ? keyword_symbol(sym) : sym));
+ return(let_ref(o->sc, slot_value(o->v[1].p), sym));
+}
+
+static s7_pointer opt_p_pp_ff(opt_info *o)
+{
+ s7_scheme *sc = o->sc;
+ s7_pointer result;
+ gc_protect_2_via_stack_no_let(sc, o->v[11].fp(o->v[10].o1), o->v[9].fp(o->v[8].o1)); /* we do need to protect both */
+ result = o->v[3].p_pp_f(sc, stack_protected1(sc), stack_protected2(sc));
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static s7_pointer opt_p_pp_ff_add_mul_mul_1(opt_info *o, bool add_case) /* (+|- (* s1 f2) (* s3 f4)) */
+{
+ opt_info *o1 = o->v[10].o1, *o2 = o->v[8].o1;
+ s7_pointer f4;
+ s7_scheme *sc = o->sc;
+ s7_pointer s1 = slot_value(o1->v[1].p);
+ s7_pointer s3 = slot_value(o2->v[1].p);
+ s7_pointer f2 = o1->v[5].fp(o1->v[4].o1);
+ if ((is_t_real(f2)) && (is_t_real(s1)) && (is_t_real(s3)))
+ {
+ 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)))));
+ gc_protect_via_stack_no_let(sc, f2);
+ }
+ else
+ {
+ gc_protect_via_stack_no_let(sc, f2);
+ f4 = o2->v[5].fp(o2->v[4].o1);
+ }
+ set_stack_protected2(sc, f4);
+ set_stack_protected2(sc, multiply_p_pp(sc, s3, f4));
+ set_stack_protected1(sc, multiply_p_pp(sc, s1, f2));
+ s3 = (add_case) ? add_p_pp(sc, stack_protected1(sc), stack_protected2(sc)) : subtract_p_pp(sc, stack_protected1(sc), stack_protected2(sc));
+ unstack_gc_protect(sc);
+ return(s3);
+}
+
+static s7_pointer opt_p_pp_ff_add_mul_mul(opt_info *o) {return(opt_p_pp_ff_add_mul_mul_1(o, true));}
+static s7_pointer opt_p_pp_ff_sub_mul_mul(opt_info *o) {return(opt_p_pp_ff_add_mul_mul_1(o, false));}
+
+static void check_opc_vector_wraps(opt_info *opc)
+{
+ if (opc->v[9].fp == opt_p_pi_ss_ivref_direct) opc->v[9].fp = opt_p_pi_ss_ivref_direct_wrapped;
+ if (opc->v[9].fp == opt_p_pi_ss_fvref_direct) opc->v[9].fp = opt_p_pi_ss_fvref_direct_wrapped;
+ if (opc->v[11].fp == opt_p_pi_ss_ivref_direct) opc->v[11].fp = opt_p_pi_ss_ivref_direct_wrapped;
+ if (opc->v[11].fp == opt_p_pi_ss_fvref_direct) opc->v[11].fp = opt_p_pi_ss_fvref_direct_wrapped;
+}
+
+static void use_slot_ref(s7_scheme *sc, opt_info *opc, s7_pointer let, s7_pointer symbol)
+{
+ s7_pointer slot = symbol_to_local_slot(sc, symbol, let);
+ if (is_slot(slot))
+ {
+ opc->v[2].p = slot;
+ opc->v[0].fp = opt_p_pp_slot_ref;
+ }
+}
+
+static bool p_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart)
+{
+ s7_pointer slot, arg1, arg2;
+ s7_p_pp_t func = s7_p_pp_function(s_func);
+ if (!func)
+ return_false(sc, car_x);
+
+ opc->v[3].p_pp_f = func;
+ arg1 = cadr(car_x);
+ arg2 = caddr(car_x);
+ if (is_symbol(arg1))
+ {
+ s7_pointer obj;
+ slot = opt_simple_symbol(sc, arg1);
+ if (!slot)
+ {
+ 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);
+ }
+ 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;
+
+ 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);
+ }
+ 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);
+ }
+ 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 :
+ ((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);
+ }}
+ 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);
+ }}
+ 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 :
+ ((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);
+ }}}
+ sc->pc = pstart;
+ return_false(sc, car_x);
+}
+
+/* -------- p_call_pp -------- */
+static s7_pointer opt_p_call_ff(opt_info *o)
+{
+ s7_pointer po2;
+ s7_scheme *sc = o->sc;
+ gc_protect_via_stack_no_let(sc, o->v[11].fp(o->v[10].o1));
+ po2 = o->v[9].fp(o->v[8].o1);
+ po2 = o->v[3].call(sc, set_plist_2(sc, stack_protected1(sc), po2));
+ unstack_gc_protect(sc);
+ return(po2);
+}
+
+static s7_pointer opt_p_call_fs(opt_info *o)
+{
+ s7_pointer po1 = o->v[11].fp(o->v[10].o1);
+ return(o->v[3].call(o->sc, set_plist_2(o->sc, po1, slot_value(o->v[1].p))));
+}
+
+static s7_pointer opt_p_call_sf(opt_info *o)
+{
+ s7_pointer po1 = o->v[11].fp(o->v[10].o1);
+ return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), po1)));
+}
+
+static s7_pointer opt_p_call_fc(opt_info *o)
+{
+ s7_pointer po1 = o->v[11].fp(o->v[10].o1);
+ return(o->v[3].call(o->sc, set_plist_2(o->sc, po1, o->v[2].p)));
+}
+
+static s7_pointer opt_p_call_cc(opt_info *o) {return(o->v[3].call(o->sc, set_plist_2(o->sc, o->v[1].p, o->v[2].p)));}
+static s7_pointer opt_p_call_sc(opt_info *o) {return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), o->v[2].p)));}
+static s7_pointer opt_p_call_ss(opt_info *o) {return(o->v[3].call(o->sc, set_plist_2(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p))));}
+
+static bool p_call_pp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart)
+{
+ if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 2)))
+ {
+ s7_pointer arg1 = cadr(car_x);
+ 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);
+ }
+ 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[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);
+ }}}
+ sc->pc = pstart;
+ return_false(sc, car_x);
+}
+
+
+/* -------- p_pip --------*/
+
+static s7_pointer opt_p_pip_ssf(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pip_ssf_sset(opt_info *o) {return(string_set_p_pip_direct(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pip_ssf_vset(opt_info *o) {return(vector_set_p_pip_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_pip_sss(opt_info *o) {return(o->v[4].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), slot_value(o->v[3].p)));}
+static s7_pointer opt_p_pip_sss_vset(opt_info *o) {return(vector_set_p_pip_unchecked(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), slot_value(o->v[3].p)));}
+static s7_pointer opt_p_pip_ssc(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p));}
+static s7_pointer opt_p_pip_c(opt_info *o) {return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[5].p_p_f(o->sc, o->v[4].p)));}
+
+static s7_pointer opt_p_pip_sff(opt_info *o)
+{
+ s7_int i1 = o->v[11].fi(o->v[10].o1);
+ return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), i1, o->v[9].fp(o->v[8].o1)));
+}
+
+static s7_pointer opt_p_pip_sff_lset(opt_info *o)
+{
+ s7_int i1 = o->v[11].fi(o->v[10].o1);
+ return(list_set_p_pip_unchecked(o->sc, slot_value(o->v[1].p), i1, o->v[9].fp(o->v[8].o1)));
+}
+
+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)))));
+}
+
+static s7_pointer opt_p_pip_ssf1(opt_info *o)
+{
+ return(o->v[3].p_pip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), o->v[4].p_p_f(o->sc, o->v[6].fp(o->v[5].o1))));
+}
+
+static bool p_pip_ssf_combinable(s7_scheme *sc, opt_info *opc, int32_t start)
+{
+ opt_info *o1;
+ if ((sc->pc > 1) &&
+ (opc == sc->opts[sc->pc - 2]))
+ {
+ 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);
+ }
+ 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);
+ }}
+ o1 = sc->opts[start];
+ if (o1->v[0].fp != opt_p_p_f)
+ return_false(sc, NULL);
+ opc->v[4].p_p_f = o1->v[2].p_p_f;
+ opc->v[5].o1 = sc->opts[start + 1];
+ opc->v[6].fp = sc->opts[start + 1]->v[0].fp;
+ opc->v[0].fp = opt_p_pip_ssf1;
+ return_true(sc, NULL);
+}
+
+static bool p_pip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_pointer obj, slot1, obj1, sig, checker = NULL, val_type;
+ s7_p_pip_t func = s7_p_pip_function(s_func);
+ if (!func)
+ return_false(sc, car_x);
+
+ sig = c_function_signature(s_func);
+ if ((is_pair(sig)) &&
+ (is_pair(cdr(sig))) &&
+ (is_symbol(cadr(sig))))
+ checker = cadr(sig);
+
+ /* here we know cadr is a symbol */
+ slot1 = s7_slot(sc, cadr(car_x));
+ if (!is_slot(slot1))
+ return_false(sc, car_x);
+ obj1 = slot_value(slot1);
+ if ((has_methods(obj1)) || (is_immutable(obj1)))
+ return_false(sc, car_x);
+ if ((is_any_vector(obj1)) && (vector_rank(obj1) > 1))
+ return_false(sc, car_x);
+
+ val_type = opt_arg_type(sc, cdddr(car_x));
+ opc->v[1].p = slot1;
+ obj = slot_value(opc->v[1].p);
+ opc->v[3].p_pip_f = func;
+ if ((s7_p_pip_unchecked_function(s_func)) &&
+ (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;
+ 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_symbol(caddr(car_x)))
+ {
+ int32_t start = sc->pc;
+ 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[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);
+ }}}
+ 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);
+ }}}
+ return_false(sc, car_x);
+}
+
+/* -------- p_piip -------- */
+static s7_pointer opt_p_piip_sssf(opt_info *o)
+{
+ return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[11].fp(o->v[10].o1)));
+}
+
+static s7_pointer vector_set_piip_sssf_unchecked(opt_info *o)
+{
+ s7_pointer v = slot_value(o->v[1].p);
+ s7_pointer val = o->v[11].fp(o->v[10].o1);
+ vector_element(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p)))) = val;
+ return(val);
+}
+
+static s7_pointer opt_p_piip_sssc(opt_info *o)
+{
+ return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)), o->v[4].p));
+}
+
+static s7_pointer opt_p_piip_sfff(opt_info *o)
+{
+ s7_int i1 = o->v[11].fi(o->v[10].o1);
+ s7_int i2 = o->v[9].fi(o->v[8].o1);
+ return(o->v[5].p_piip_f(o->sc, slot_value(o->v[1].p), i1, i2, o->v[3].fp(o->v[4].o1))); /* v[3] because v[5] is already in use */
+}
+
+static bool p_piip_to_sx(s7_scheme *sc, opt_info *opc, s7_pointer indexp1, s7_pointer indexp2, s7_pointer valp, s7_pointer obj)
+{
+ s7_pointer slot = opt_integer_symbol(sc, car(indexp2));
+ if (!slot)
+ return_false(sc, indexp1);
+ opc->v[3].p = slot;
+ slot = opt_integer_symbol(sc, car(indexp1));
+ if (slot)
+ {
+ 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);
+ }
+ opc->v[0].fp = opt_p_piip_sssc;
+ opc->v[4].p = (is_pair(car(valp))) ? cadar(valp) : car(valp);
+ 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, 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);
+ }}}
+ return_false(sc, NULL);
+}
+
+static bool p_piip_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_p_piip_t func = s7_p_piip_function(s_func);
+ if ((func) && (s_func == global_value(sc->vector_set_symbol)) && (is_symbol(cadr(car_x))))
+ {
+ s7_pointer obj;
+ s7_pointer slot1 = s7_slot(sc, cadr(car_x));
+ if (!is_slot(slot1))
+ return_false(sc, car_x);
+ obj = slot_value(slot1);
+ if ((has_methods(obj)) || (is_immutable(obj)))
+ 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));
+ }}
+ return_false(sc, car_x);
+}
+
+/* -------- p_pii -------- */
+static s7_pointer opt_p_pii_sss(opt_info *o)
+{
+ return(o->v[4].p_pii_f(o->sc, slot_value(o->v[1].p), integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p))));
+}
+
+static s7_pointer opt_p_pii_sff(opt_info *o)
+{
+ s7_int i1 = o->v[11].fi(o->v[10].o1);
+ s7_int i2 = o->v[9].fi(o->v[8].o1);
+ return(o->v[4].p_pii_f(o->sc, slot_value(o->v[1].p), i1, i2));
+}
+
+static s7_pointer vector_ref_pii_sss_unchecked(opt_info *o)
+{
+ s7_pointer v = slot_value(o->v[1].p);
+ return(vector_element(v, ((integer(slot_value(o->v[2].p)) * vector_offset(v, 0)) + integer(slot_value(o->v[3].p)))));
+}
+
+static bool p_pii_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_p_pii_t func = s7_p_pii_function(s_func);
+ if ((func) &&
+ (is_symbol(cadr(car_x))))
+ {
+ s7_pointer obj;
+ s7_pointer slot1 = s7_slot(sc, cadr(car_x));
+ if (!is_slot(slot1))
+ return_false(sc, car_x);
+ obj = slot_value(slot1);
+ if ((has_methods(obj)) || (is_immutable(obj)))
+ 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);
+ }}}}
+ return_false(sc, car_x);
+}
+
+/* -------- p_ppi -------- */
+static s7_pointer opt_p_ppi_psf(opt_info *o) {return(o->v[3].p_ppi_f(o->sc, o->v[2].p, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));}
+static s7_pointer opt_p_ppi_psf_cpos(opt_info *o) {return(char_position_p_ppi(o->sc, o->v[2].p, slot_value(o->v[1].p), o->v[5].fi(o->v[4].o1)));}
+
+static bool p_ppi_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ int32_t start = sc->pc;
+ s7_p_ppi_t ifunc = s7_p_ppi_function(s_func);
+ if (!ifunc)
+ return_false(sc, car_x);
+ opc->v[3].p_ppi_f = ifunc;
+ if ((is_character(cadr(car_x))) &&
+ (is_symbol(caddr(car_x))) &&
+ (int_optimize(sc, cdddr(car_x))))
+ {
+ 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);
+ }}
+ sc->pc = start;
+ return_false(sc, car_x);
+}
+
+/* -------- p_ppp -------- */
+static s7_pointer opt_p_ppp_ssf(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].fp(o->v[4].o1)));}
+static s7_pointer opt_p_ppp_hash_table_increment(opt_info *o) {return(fx_hash_table_increment_1(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[5].p));}
+static s7_pointer opt_p_ppp_sfs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[5].fp(o->v[4].o1), slot_value(o->v[2].p)));}
+static s7_pointer opt_p_ppp_scs(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), o->v[2].p, slot_value(o->v[4].p)));}
+static s7_pointer opt_p_ppp_sss(opt_info *o) {return(o->v[4].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));}
+static s7_pointer opt_p_ppp_sss_mul(opt_info *o) {return(multiply_p_ppp(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));}
+static s7_pointer opt_p_ppp_sss_hset(opt_info *o) {return(s7_hash_table_set(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p)));}
+static s7_pointer opt_p_ppp_ssc(opt_info *o) {return(o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[4].p));}
+static s7_pointer opt_list_3c(opt_info *o) {s7_scheme *sc = o->sc; return(list_3(sc, o->v[10].p, o->v[8].p, o->v[4].p));}
+
+static s7_pointer opt_p_ppp_sff(opt_info *o)
+{
+ s7_pointer res;
+ s7_scheme *sc = o->sc;
+ gc_protect_2_via_stack_no_let(sc, T_Ext(o->v[11].fp(o->v[10].o1)), T_Ext(o->v[9].fp(o->v[8].o1)));
+ res = o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), stack_protected1(sc), stack_protected2(sc));
+ unstack_gc_protect(sc);
+ return(res);
+}
+
+static s7_pointer opt_p_ppp_fff(opt_info *o)
+{
+ s7_pointer res;
+ s7_scheme *sc = o->sc;
+ gc_protect_2_via_stack_no_let(sc, T_Ext(o->v[11].fp(o->v[10].o1)), T_Ext(o->v[9].fp(o->v[8].o1)));
+ res = o->v[3].p_ppp_f(sc, stack_protected1(sc), stack_protected2(sc), o->v[5].fp(o->v[4].o1));
+ unstack_gc_protect(sc);
+ return(res);
+}
+
+static s7_pointer opt_p_ppc_slot_set(opt_info *o) {slot_set_value(o->v[2].p, o->v[4].p); return(o->v[4].p);}
+static s7_pointer opt_p_pps_slot_set(opt_info *o) {slot_set_value(o->v[2].p, slot_value(o->v[4].p)); return(slot_value(o->v[4].p));}
+static s7_pointer opt_p_ppf_slot_set(opt_info *o) {slot_set_value(o->v[2].p, o->v[5].fp(o->v[4].o1)); return(slot_value(o->v[2].p));}
+
+static bool use_ppc_slot_set(s7_scheme *sc, opt_info *opc, s7_pointer let, s7_pointer symbol, s7_pointer value)
+{
+ s7_pointer slot = symbol_to_local_slot(sc, symbol, let);
+ if ((is_slot(slot)) && (!is_immutable(slot)))
+ {
+ opc->v[2].p = slot;
+ opc->v[4].p = value;
+ opc->v[0].fp = opt_p_ppc_slot_set;
+ return(true);
+ }
+ return(false);
+}
+
+static bool use_pps_slot_set(s7_scheme *sc, opt_info *opc, s7_pointer let, s7_pointer symbol, s7_pointer val_slot)
+{
+ s7_pointer slot = symbol_to_local_slot(sc, symbol, let);
+ if ((is_slot(slot)) && (!is_immutable(slot)))
+ {
+ opc->v[2].p = slot;
+ opc->v[4].p = val_slot;
+ opc->v[0].fp = opt_p_pps_slot_set;
+ return(true);
+ }
+ return(false);
+}
+
+static bool use_ppf_slot_set(s7_scheme *sc, opt_info *opc, s7_pointer let, s7_pointer symbol)
+{
+ s7_pointer slot = symbol_to_local_slot(sc, symbol, let);
+ if ((is_slot(slot)) && (!is_immutable(slot)))
+ {
+ opc->v[2].p = slot;
+ opc->v[0].fp = opt_p_ppf_slot_set;
+ return(true);
+ }
+ return(false);
+}
+
+static bool p_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ s7_pointer arg1 = cadr(car_x);
+ s7_pointer arg2 = caddr(car_x);
+ s7_pointer arg3 = cadddr(car_x);
+ int32_t start = sc->pc;
+ s7_p_ppp_t func = s7_p_ppp_function(s_func);
+ if (!func)
+ return_false(sc, car_x);
+ opc->v[3].p_ppp_f = func;
+ if (is_symbol(arg1))
+ {
+ s7_pointer obj;
+ opt_info *o1;
+ s7_pointer slot = s7_slot(sc, arg1);
+ if ((!is_slot(slot)) ||
+ (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);
+
+ 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);
+ }
+ 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);
+
+ 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;
+
+ 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_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);
+ }}
+ 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);
+ }}}
+ 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);
+ }}}}
+ sc->pc = start;
+ return_false(sc, car_x);
+}
+
+
+/* -------- p_call_ppp -------- */
+static s7_pointer opt_p_call_sss(opt_info *o)
+{
+ return(o->v[4].call(o->sc, set_plist_3(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), slot_value(o->v[3].p))));
+}
+
+static s7_pointer opt_p_call_ccs(opt_info *o)
+{
+ return(o->v[4].call(o->sc, set_plist_3(o->sc, o->v[1].p, o->v[2].p, slot_value(o->v[3].p))));
+}
+
+static s7_pointer opt_p_call_css(opt_info *o)
+{
+ return(o->v[4].call(o->sc, set_plist_3(o->sc, o->v[1].p, slot_value(o->v[2].p), slot_value(o->v[3].p))));
+}
+
+static s7_pointer opt_p_call_ssf(opt_info *o)
+{
+ return(o->v[4].call(o->sc, set_plist_3(o->sc, slot_value(o->v[1].p), slot_value(o->v[2].p), o->v[6].fp(o->v[5].o1))));
+}
+
+static s7_pointer opt_p_call_ppp(opt_info *o)
+{
+ s7_pointer res;
+ s7_scheme *sc = o->sc;
+ gc_protect_2_via_stack_no_let(sc, o->v[4].fp(o->v[3].o1), o->v[6].fp(o->v[5].o1));
+ res = o->v[11].fp(o->v[10].o1); /* not combinable into next */
+ res = o->v[2].call(sc, set_plist_3(sc, stack_protected1(sc), stack_protected2(sc), res));
+ unstack_gc_protect(sc);
+ return(res);
+}
+
+static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x)
+{
+ int32_t start = sc->pc;
+ if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 3)) &&
+ (s_func != global_value(sc->hash_table_ref_symbol)) && (s_func != global_value(sc->list_ref_symbol)))
+ {
+ s7_pointer slot, arg1 = cadr(car_x), arg2 = caddr(car_x), arg3 = cadddr(car_x);
+ 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 (s_func == global_value(sc->vector_ref_symbol))
+ 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);
+ }}}}
+ sc->pc = start;
+ return_false(sc, car_x);
+}
+
+
+/* -------- p_call_any -------- */
+#define P_CALL_O1 3
+
+static s7_pointer opt_p_call_any(opt_info *o)
+{
+ s7_scheme *sc = o->sc;
+ s7_pointer val = safe_list_if_possible(sc, o->v[1].i);
+ s7_pointer arg = val;
+ if (in_heap(val)) gc_protect_via_stack_no_let(sc, val);
+ for (s7_int i = 0; i < o->v[1].i; i++, arg = cdr(arg))
+ {
+ opt_info *o1 = o->v[i + P_CALL_O1].o1;
+ set_car(arg, o1->v[0].fp(o1));
+ }
+ arg = o->v[2].call(sc, val);
+ if (in_heap(val)) unstack_gc_protect(sc);
+ else clear_list_in_use(val);
+ return(arg);
+}
+
+static bool p_call_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t len)
+{
+ if ((len < (NUM_VUNIONS - P_CALL_O1)) &&
+ (is_safe_procedure(s_func)) &&
+ (c_function_is_aritable(s_func, len - 1)))
+ {
+ 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;
+ }
+ 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);
+ }}
+ return_false(sc, car_x);
+}
+
+
+/* -------- p_fx_any -------- */
+
+static s7_pointer opt_p_fx_any(opt_info *o) {return(o->v[1].call(o->sc, o->v[2].p));}
+
+static bool p_fx_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer x)
+{
+ s7_function f = (has_fx(x)) ? fx_proc(x) : fx_choose(sc, x, sc->curlet, let_symbol_is_safe);
+ if (!f)
+ return_false(sc, x);
+ opc->v[0].fp = opt_p_fx_any;
+ opc->v[1].call = f;
+ opc->v[2].p = car(x);
+ return_true(sc, x);
+}
+
+
+/* -------- p_implicit -------- */
+
+static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer car_x, int32_t len)
+{
+ s7_pointer obj = slot_value(s_slot);
+ s7_pointer arg1 = (len > 1) ? cadr(car_x) : sc->F;
+ opt_info *opc;
+ int32_t start;
+
+ if ((!is_simple_sequence(obj)) || (len < 2)) /* was is_sequence? */
+ return_false(sc, car_x);
+
+ opc = alloc_opt_info(sc);
+ opc->v[1].p = s_slot;
+ start = sc->pc;
+ 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);
+ }
+ /* 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);
+ }}
+ 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 */
+ 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;
+ }
+
+ #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);
+ }}}
+ return_false(sc, car_x);
+}
+
+/* -------- cell_quote -------- */
+static bool opt_cell_quote(s7_scheme *sc, s7_pointer car_x)
+{
+ opt_info *opc;
+ if (!is_null(cddr(car_x)))
+ return_false(sc, car_x);
+ opc = alloc_opt_info(sc);
+ opc->v[1].p = cadr(car_x);
+ opc->v[0].fp = opt_p_c;
+ return_true(sc, car_x);
+}
+
+/* -------- cell_set -------- */
+static s7_pointer opt_set_p_p_f(opt_info *o)
+{
+ s7_pointer x = o->v[4].fp(o->v[3].o1);
+ slot_set_value(o->v[1].p, x);
+ return(x);
+}
+
+static s7_pointer opt_set_p_p_f_with_setter(opt_info *o)
+{
+ s7_pointer x = o->v[4].fp(o->v[3].o1);
+ call_c_function_setter(o->sc, slot_setter(o->v[1].p), slot_symbol(o->v[1].p), x);
+ slot_set_value(o->v[1].p, x); /* symbol_increment?? */
+ return(x);
+}
+
+static s7_pointer opt_set_p_i_s(opt_info *o)
+{
+ s7_pointer val = slot_value(o->v[2].p);
+ if (is_mutable_integer(val))
+ val = make_integer(o->sc, integer(val));
+ slot_set_value(o->v[1].p, val);
+ return(val);
+}
+
+static s7_pointer opt_set_p_i_f(opt_info *o)
+{
+ s7_pointer x = make_integer(o->sc, o->v[6].fi(o->v[5].o1));
+ slot_set_value(o->v[1].p, x);
+ return(x);
+}
+/* here and below (opt_set_p_d_f), the mutable versions are not safe, and are very tricky to make safe. First if a variable is set twice,
+ * in the body, as in (do (...) (... (set! buffix (+ 1 buffix)) (if (>= buffix fftsize) (set! buffix 0)))) from pvoc.scm,
+ * if the first set! is opt_set_p_i_fm (buffix is assumed mutable), the second sets it to built-in immutable zero, so the next time around loop,
+ * the set_integer is direct so now built-in 0 == 128 (yet still prints itself as "0"). Also if a mutable variable is stored,
+ * (define (f2) (let ((v (vector 0 0 0)) (y 1.0)) (do ((i 0 (+ i 1))) ((= i 3) v) (set! y (+ y 1.0)) (vector-set! v i y))))
+ * (f2) -> #(4.0 4.0 4.0). Maybe safe if body has just one statement?
+ */
+
+#if 0
+static s7_pointer opt_set_p_i_fm(opt_info *o)
+{
+ s7_int x = o->v[6].fi(o->v[5].o1);
+ check_mutability(o->sc, o, __func__, __LINE__);
+ set_integer(slot_value(o->v[1].p), x);
+ return(slot_value(o->v[1].p));
+}
+#endif
+
+static s7_pointer opt_set_p_d_s(opt_info *o)
+{
+ s7_pointer val = slot_value(o->v[2].p);
+ if (is_mutable_number(val))
+ val = make_real(o->sc, real(val));
+ slot_set_value(o->v[1].p, val);
+ return(val);
+}
+
+static s7_pointer opt_set_p_d_f(opt_info *o)
+{
+ s7_pointer x = make_real(o->sc, o->v[5].fd(o->v[4].o1));
+ slot_set_value(o->v[1].p, x);
+ return(x);
+}
+
+#if 0
+static s7_pointer opt_set_p_d_fm(opt_info *o)
+{
+ s7_double x = o->v[5].fd(o->v[4].o1);
+ check_mutability(o->sc, o, __func__, __LINE__);
+ set_real(slot_value(o->v[1].p), x);
+ return(slot_value(o->v[1].p));
+}
+#endif
+
+static s7_pointer opt_set_p_d_f_sf_add(opt_info *o)
+{
+ s7_pointer x = make_real(o->sc, opt_d_dd_sf_add(o->v[4].o1));
+ slot_set_value(o->v[1].p, x);
+ return(x);
+}
+
+static s7_pointer opt_set_p_d_fm_sf_add(opt_info *o)
+{
+ s7_double x = opt_d_dd_sf_add(o->v[4].o1);
+ check_mutability(o->sc, o, __func__, __LINE__);
+ set_real(slot_value(o->v[1].p), x);
+ return(slot_value(o->v[1].p));
+}
+
+static s7_pointer opt_set_p_d_f_mm_add(opt_info *o)
+{
+ s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[4].p), integer(slot_value(o->v[5].p))) * real(slot_value(o->v[3].p));
+ s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[10].p), integer(slot_value(o->v[11].p))) * real(slot_value(o->v[9].p));
+ slot_set_value(o->v[1].p, make_real(o->sc, x1 + x2));
+ return(slot_value(o->v[1].p));
+}
+
+static s7_pointer opt_set_p_d_f_mm_subtract(opt_info *o)
+{
+ s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[4].p), integer(slot_value(o->v[5].p))) * real(slot_value(o->v[3].p));
+ s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(o->v[10].p), integer(slot_value(o->v[11].p))) * real(slot_value(o->v[9].p));
+ slot_set_value(o->v[1].p, make_real(o->sc, x1 - x2));
+ return(slot_value(o->v[1].p));
+}
+
+static s7_pointer opt_set_p_c(opt_info *o)
+{
+ slot_set_value(o->v[1].p, o->v[2].p);
+ return(o->v[2].p);
+}
+
+static s7_pointer opt_set_p_i_fo(opt_info *o)
+{
+ s7_int i = o->v[4].i_ii_f(integer(slot_value(o->v[2].p)), integer(slot_value(o->v[3].p)));
+ s7_pointer x = make_integer(o->sc, i);
+ slot_set_value(o->v[1].p, x);
+ return(x);
+}
+
+static s7_pointer opt_set_p_i_fo_add(opt_info *o)
+{
+ s7_int i = integer(slot_value(o->v[2].p)) + integer(slot_value(o->v[3].p));
+ s7_pointer x = make_integer(o->sc, i);
+ slot_set_value(o->v[1].p, x);
+ return(x);
+}
+
+static s7_pointer opt_set_p_i_fo1(opt_info *o)
+{
+ s7_int i = o->v[4].i_ii_f(integer(slot_value(o->v[2].p)), o->v[3].i);
+ s7_pointer x = make_integer(o->sc, i);
+ slot_set_value(o->v[1].p, x);
+ return(x);
+}
+
+static s7_pointer opt_set_p_i_fo1_add(opt_info *o)
+{
+ s7_int i = integer(slot_value(o->v[2].p)) + o->v[3].i;
+ s7_pointer x = make_integer(o->sc, i);
+ slot_set_value(o->v[1].p, x);
+ return(x);
+}
+
+static bool set_p_i_f_combinable(s7_scheme *sc, opt_info *opc)
+{
+ if ((sc->pc > 1) &&
+ (opc == sc->opts[sc->pc - 2]))
+ {
+ 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);
+ }
+ 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);
+ }}
+ return_false(sc, NULL);
+}
+
+static bool set_p_d_f_combinable(s7_scheme *sc, opt_info *opc)
+{
+ if ((sc->pc > 3) &&
+ (opc == sc->opts[sc->pc - 4]))
+ {
+ 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);
+ }}
+ 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));
+}
+
+static bool check_type_uncertainty(s7_scheme *sc, s7_pointer target, s7_pointer car_x, opt_info *opc, int32_t start_pc)
+{
+ s7_pointer code = sc->code;
+ /* if we're optimizing do, sc->code is (sometimes) ((vars...) (end...) car_x) where car_x is the do body, but it can also be for-each etc */
+
+ /* maybe the type uncertainty is not a problem */
+ if ((is_pair(code)) && /* t101-aux-14: (vector-set! !v! 0 (do ((x (list 1 2 3) (cdr x)) (j -1)) ((null? x) j) (set! j (car x)))) */
+ (is_pair(car(code))) &&
+ (is_pair(cdr(code))) && /* weird that code sometimes has nothing to do with car_x -- tree_memq below for reality check */
+ (is_pair(cadr(code))))
+ {
+ 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);
+ }
+ 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);
+ }}}
+ return_false(sc, car_x);
+}
+
+static bool opt_cell_set(s7_scheme *sc, s7_pointer car_x) /* len == 3 here (p_syntax) */
+{
+ opt_info *opc = alloc_opt_info(sc);
+ s7_pointer target = cadr(car_x);
+ s7_pointer value = caddr(car_x);
+ if (is_symbol(target))
+ {
+ 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);
+
+ 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);
+ }}
+ return_false(sc, car_x);
+ }
+ if ((is_pair(target)) &&
+ (is_symbol(car(target))) &&
+ (is_pair(cdr(target))) &&
+ ((is_null(cddr(target))) || (is_null(cdddr(target))) || (is_null(cddddr(target)))))
+ {
+ s7_pointer obj, index, index_type, s_slot = s7_slot(sc, car(target));
+ if (!is_slot(s_slot))
+ 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);
+
+ 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);
+ }
+ 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);
+ }}}
+ 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);
+ }}}}
+ return_false(sc, car_x);
+}
+
+
+/* -------- cell_begin -------- */
+static s7_pointer opt_begin_p(opt_info *o)
+{
+ opt_info *o1;
+ s7_int i, len = o->v[1].i; /* len = 1 if 2 exprs, etc */
+ for (i = 0; i < len; i++)
+ {
+ o1 = o->v[i + 2].o1;
+ o1->v[0].fp(o1);
+ }
+ o1 = o->v[i + 2].o1;
+ return(o1->v[0].fp(o1));
+}
+
+static s7_pointer opt_begin_p_1(opt_info *o)
+{
+ o->v[3].fp(o->v[2].o1);
+ return(o->v[5].fp(o->v[4].o1));
+}
+
+static void oo_idp_nr_fixup(opt_info *start)
+{
+ if (start->v[0].fp == d_to_p)
+ {
+ 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;
+ 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;
+ }}
+ else
+ if (start->v[0].fp == i_to_p)
+ start->v[0].fp = i_to_p_nr;
+}
+
+static bool opt_cell_begin(s7_scheme *sc, s7_pointer car_x, int32_t len)
+{
+ int32_t i;
+ opt_info *opc;
+ s7_pointer p;
+ if (len > (NUM_VUNIONS - 3))
+ return_false(sc, car_x);
+ opc = alloc_opt_info(sc);
+ for (i = 2, p = cdr(car_x); is_pair(p); i++, p = cdr(p))
+ {
+ opt_info *start = sc->opts[sc->pc];
+ if (!cell_optimize(sc, p))
+ return_false(sc, car_x);
+ if (is_pair(cdr(p)))
+ oo_idp_nr_fixup(start);
+ opc->v[i].o1 = start;
+ }
+ opc->v[1].i = len - 2;
+ if (len == 3)
+ {
+ opc->v[0].fp = opt_begin_p_1;
+ opc->v[4].o1 = opc->v[3].o1;
+ opc->v[5].fp = opc->v[4].o1->v[0].fp;
+ opc->v[3].fp = opc->v[2].o1->v[0].fp;
+ }
+ else opc->v[0].fp = opt_begin_p;
+ return_true(sc, car_x);
+}
+
+/* -------- cell_when|unless -------- */
+static s7_pointer opt_when_p_2(opt_info *o)
+{
+ if (o->v[4].fb(o->v[3].o1))
+ {
+ o->v[6].fp(o->v[5].o1);
+ return(o->v[8].fp(o->v[7].o1));
+ }
+ return(o->sc->unspecified);
+}
+
+static s7_pointer opt_when_p(opt_info *o)
+{
+ if (o->v[4].fb(o->v[3].o1))
+ {
+ 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;
+ return(o1->v[0].fp(o1));
+ }
+ return(o->sc->unspecified);
+}
+
+static s7_pointer opt_when_p_1(opt_info *o)
+{
+ opt_info *o1;
+ if (!o->v[4].fb(o->v[3].o1))
+ return(o->sc->unspecified);
+ o1 = o->v[5].o1;
+ return(o1->v[0].fp(o1));
+}
+
+static s7_pointer opt_unless_p(opt_info *o)
+{
+ opt_info *o1;
+ s7_int i, len;
+ if (o->v[4].fb(o->v[3].o1))
+ return(o->sc->unspecified);
+ len = o->v[1].i - 1;
+ for (i = 0; i < len; i++)
+ {
+ o1 = o->v[i + 5].o1;
+ o1->v[0].fp(o1);
+ }
+ o1 = o->v[i + 5].o1;
+ return(o1->v[0].fp(o1));
+}
+
+static s7_pointer opt_unless_p_1(opt_info *o)
+{
+ opt_info *o1;
+ if (o->v[4].fb(o->v[3].o1))
+ return(o->sc->unspecified);
+ o1 = o->v[5].o1;
+ return(o1->v[0].fp(o1));
+}
+
+static bool opt_cell_when(s7_scheme *sc, s7_pointer car_x, int32_t len)
+{
+ s7_pointer p;
+ int32_t k;
+ opt_info *opc;
+ if (len > (NUM_VUNIONS - 6))
+ return_false(sc, car_x);
+ opc = alloc_opt_info(sc);
+ opc->v[3].o1 = sc->opts[sc->pc];
+ if (!bool_optimize(sc, cdr(car_x)))
+ return_false(sc, car_x);
+ for (k = 5, p = cddr(car_x); is_pair(p); k++, p = cdr(p))
+ {
+ opt_info *start = sc->opts[sc->pc];
+ if (!cell_optimize(sc, p))
+ return_false(sc, car_x);
+ if (is_pair(cdr(p)))
+ oo_idp_nr_fixup(start);
+ opc->v[k].o1 = start;
+ }
+ opc->v[4].fb = opc->v[3].o1->v[0].fb;
+ opc->v[1].i = len - 2;
+ if (car(car_x) == sc->when_symbol)
+ {
+ if (len == 3)
+ 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;
+ }
+ else opc->v[0].fp = (len == 3) ? opt_unless_p_1 : opt_unless_p;
+ return_true(sc, car_x);
+}
+
+/* -------- cell_cond -------- */
+
+#define COND_O1 3
+#define COND_CLAUSE_O1 5
+
+static s7_pointer cond_value(opt_info *o)
+{
+ opt_info *o1;
+ s7_int i, len = o->v[1].i - 1;
+ for (i = 0; i < len; i++)
+ {
+ o1 = o->v[i + COND_CLAUSE_O1].o1;
+ o1->v[0].fp(o1);
+ }
+ o1 = o->v[i + COND_CLAUSE_O1].o1;
+ return(o1->v[0].fp(o1));
+}
+
+static s7_pointer opt_cond(opt_info *top)
+{
+ s7_int len = top->v[2].i;
+ for (s7_int clause = 0; clause < len; clause++)
+ {
+ 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);
+ }}
+ return(top->sc->unspecified);
+}
+
+static s7_pointer opt_cond_1(opt_info *o) {return((o->v[5].fb(o->v[4].o1)) ? cond_value(o->v[6].o1) : o->sc->unspecified);} /* cond as when */
+static s7_pointer opt_cond_1b(opt_info *o) {return((o->v[4].o1->v[O_WRAP].fp(o->v[4].o1) != o->sc->F) ? cond_value(o->v[6].o1) : o->sc->unspecified);}
+
+static s7_pointer opt_cond_2(opt_info *o) /* 2 branches, results 1 expr, else */
+{
+ opt_info *o1 = (o->v[5].fb(o->v[4].o1)) ? o->v[6].o1 : o->v[7].o1;
+ s7_pointer res = o1->v[0].fp(o1);
+ return(res);
+}
+
+static bool opt_cell_cond(s7_scheme *sc, s7_pointer car_x)
+{
+ /* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */
+ s7_pointer last_clause = NULL;
+ int32_t branches = 0, max_blen = 0;
+ opt_info *top = alloc_opt_info(sc);
+ int32_t start_pc = sc->pc;
+ for (s7_pointer p = cdr(car_x); is_pair(p); p = cdr(p), branches++)
+ {
+ opt_info *opc;
+ 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);
+
+ 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);
+
+ 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 (!is_null(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 */
+ }
+ if (branches == 1)
+ {
+ opt_info *o1 = sc->opts[start_pc + 1];
+ top->v[0].fp = (o1->v[0].fb == p_to_b) ? opt_cond_1b : opt_cond_1;
+ top->v[4].o1 = o1;
+ top->v[5].fb = o1->v[0].fb;
+ top->v[6].o1 = sc->opts[start_pc];
+ return_true(sc, 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);
+ }}
+ top->v[2].i = branches;
+ top->v[0].fp = opt_cond;
+ return_true(sc, car_x);
+}
+
+/* -------- cell_and|or -------- */
+static s7_pointer opt_and_pp(opt_info *o) {return((o->v[11].fp(o->v[10].o1) == o->sc->F) ? o->sc->F : o->v[9].fp(o->v[8].o1));}
+
+static s7_pointer opt_and_any_p(opt_info *o)
+{
+ s7_pointer val = o->sc->T; /* (and) -> #t */
+ for (s7_int i = 0; i < o->v[1].i; i++)
+ {
+ opt_info *o1 = o->v[i + 3].o1;
+ val = o1->v[0].fp(o1);
+ if (val == o->sc->F)
+ return(o->sc->F);
+ }
+ return(val);
+}
+
+static s7_pointer opt_or_pp(opt_info *o)
+{
+ s7_pointer val = o->v[11].fp(o->v[10].o1);
+ return((val != o->sc->F) ? val : o->v[9].fp(o->v[8].o1));
+}
+
+static s7_pointer opt_or_any_p(opt_info *o)
+{
+ for (s7_int i = 0; i < o->v[1].i; i++)
+ {
+ opt_info *o1 = o->v[i + 3].o1;
+ s7_pointer val = o1->v[0].fp(o1);
+ if (val != o->sc->F)
+ return(val);
+ }
+ return(o->sc->F);
+}
+
+static bool opt_cell_and(s7_scheme *sc, s7_pointer car_x, int32_t len)
+{
+ opt_info *opc = alloc_opt_info(sc);
+ if (len == 3)
+ {
+ 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);
+ 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);
+ opc->v[9].fp = opc->v[8].o1->v[0].fp;
+ return_true(sc, car_x);
+ }
+ if ((len > 1) && (len < (NUM_VUNIONS - 4)))
+ {
+ s7_pointer p = cdr(car_x);
+ 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);
+ }
+ return_true(sc, car_x);
+ }
+ return_false(sc, car_x);
+}
+
+/* -------- cell_if -------- */
+static s7_pointer opt_if_bp(opt_info *o) {return((o->v[3].fb(o->v[2].o1)) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified);}
+static s7_pointer opt_if_b7p(opt_info *o) {return((opt_b_7p_f(o->v[2].o1)) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified);} /* expanded not faster */
+static s7_pointer opt_if_nbp(opt_info *o) {return((o->v[5].fb(o->v[4].o1)) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1));}
+static s7_pointer opt_if_bp_and(opt_info *o) {return((opt_and_bb(o->v[2].o1)) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified);}
+
+static s7_pointer opt_if_bp_pb(opt_info *o) /* p_to_b at outer, p_to_b expanded and moved to o[3] */
+{
+ return((o->v[3].fp(o->v[2].o1) != o->sc->F) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified);
+}
+
+static s7_pointer opt_if_bp_ii_fc(opt_info *o)
+{
+ return((o->v[3].b_ii_f(o->v[11].fi(o->v[10].o1), o->v[2].i)) ? o->v[5].fp(o->v[4].o1) : o->sc->unspecified);
+}
+
+static s7_pointer opt_if_nbp_s(opt_info *o)
+{
+ return((o->v[2].b_p_f(slot_value(o->v[3].p))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1));
+}
+
+static s7_pointer opt_if_nbp_sc(opt_info *o) /* b_pp_sc */
+{
+ return((o->v[3].b_pp_f(slot_value(o->v[2].p), o->v[4].p)) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1));
+}
+
+static s7_pointer opt_if_nbp_7sc(opt_info *o) /* b_7pp_sc */
+{
+ return((o->v[3].b_7pp_f(o->sc, slot_value(o->v[2].p), o->v[4].p)) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1));
+}
+
+static s7_pointer opt_if_nbp_ss(opt_info *o) /* b_ii_ss */
+{
+ return((o->v[3].b_ii_f(integer(slot_value(o->v[2].p)), integer(slot_value(o->v[4].p)))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1));
+}
+
+static s7_pointer opt_if_num_eq_ii_ss(opt_info *o) /* b_ii_ss */
+{
+ return((integer(slot_value(o->v[2].p)) == integer(slot_value(o->v[4].p))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1));
+}
+
+static s7_pointer opt_if_nbp_fs(opt_info *o) /* b_pi_fs */
+{
+ return((o->v[2].b_pi_f(o->sc, o->v[5].fp(o->v[4].o1), integer(slot_value(o->v[3].p)))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1));
+}
+
+static s7_pointer opt_if_nbp_sf(opt_info *o) /* b_pp_sf */
+{
+ return((o->v[2].b_pp_f(slot_value(o->v[3].p), o->v[5].fp(o->v[4].o1))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1));
+}
+
+static s7_pointer opt_if_nbp_7sf(opt_info *o) /* b_7pp_sf */
+{
+ return((o->v[2].b_7pp_f(o->sc, slot_value(o->v[3].p), o->v[5].fp(o->v[4].o1))) ? o->sc->unspecified : o->v[11].fp(o->v[10].o1));
+}
+
+static s7_pointer opt_if_bpp(opt_info *o) {return((o->v[5].fb(o->v[4].o1)) ? o->v[9].fp(o->v[8].o1) : o->v[11].fp(o->v[10].o1));}
+static s7_pointer opt_if_bpp_bit(opt_info *o) {return((opt_b_7ii_sc_bit(o->v[4].o1)) ? o->v[9].fp(o->v[8].o1) : o->v[11].fp(o->v[10].o1));}
+
+static bool opt_cell_if(s7_scheme *sc, s7_pointer car_x, int32_t len)
+{
+ opt_info *opc = alloc_opt_info(sc);
+ opt_info *bop = sc->opts[sc->pc];
+ 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);
+ }}}
+ 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);
+ }}
+ 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);
+ }}}}
+ return_false(sc, car_x);
+}
+
+/* -------- cell_case -------- */
+#define CASE_O1 3
+#define CASE_SEL 2
+#define CASE_CLAUSE_O1 4
+#define CASE_CLAUSE_KEYS 2
+
+static s7_pointer case_value(opt_info *o)
+{
+ opt_info *o1;
+ int32_t i, len = o->v[1].i - 1; /* int32_t here and below seems to be faster than s7_int (tleft.scm) */
+ for (i = 0; i < len; i++)
+ {
+ o1 = o->v[i + CASE_CLAUSE_O1].o1;
+ o1->v[0].fp(o1);
+ }
+ o1 = o->v[i + CASE_CLAUSE_O1].o1;
+ return(o1->v[0].fp(o1));
+}
+
+static s7_pointer opt_case(opt_info *o)
+{
+ opt_info *o1 = o->v[CASE_SEL].o1;
+ int32_t lim = o->v[1].i;
+ s7_scheme *sc = o->sc;
+ s7_pointer selector = o1->v[0].fp(o1);
+
+ 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));
+ }}
+ 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));
+ }
+ return(sc->unspecified);
+}
+
+static bool opt_cell_case(s7_scheme *sc, s7_pointer car_x)
+{
+ /* top->v[1].i is end index, clause->v[3].i is end of current clause, clause->v[1].i = clause result len */
+ s7_pointer p;
+ int32_t ctr;
+ opt_info *top = alloc_opt_info(sc);
+ top->v[CASE_SEL].o1 = sc->opts[sc->pc];
+ if (!cell_optimize(sc, cdr(car_x))) /* selector */
+ return_false(sc, car_x);
+ for (ctr = CASE_O1, p = cddr(car_x); (is_pair(p)) && (ctr < NUM_VUNIONS); ctr++, p = cdr(p))
+ {
+ opt_info *opc;
+ 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);
+
+ 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;
+ }
+ else
+ {
+ 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);
+ }
+ if (!is_null(cp))
+ return_false(sc, cp);
+ opc->v[1].i = blen;
+ opc->v[0].fp = opt_case; /* just a placeholder I hope */
+ }
+ if (!is_null(p))
+ return_false(sc, p);
+ top->v[1].i = ctr;
+ top->v[0].fp = opt_case;
+ return_true(sc, car_x);
+}
+
+/* -------- cell_let_temporarily -------- */
+
+#define LET_TEMP_O1 5
+
+static s7_pointer opt_let_temporarily(opt_info *o)
+{
+ opt_info *o1 = o->v[4].o1;
+ s7_int i, len;
+ s7_pointer result;
+ s7_scheme *sc = o->sc;
+
+ if (is_immutable_slot(o->v[1].p))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, slot_symbol(o->v[1].p)));
+
+ o->v[3].p = slot_value(o->v[1].p); /* save and protect old value */
+ gc_protect_via_stack(sc, o->v[3].p);
+ slot_set_value(o->v[1].p, o1->v[0].fp(o1)); /* set new value */
+ len = o->v[2].i - 1;
+ for (i = 0; i < len; i++)
+ {
+ o1 = o->v[i + LET_TEMP_O1].o1;
+ o1->v[0].fp(o1);
+ }
+ o1 = o->v[i + LET_TEMP_O1].o1;
+ result = o1->v[0].fp(o1);
+ slot_set_value(o->v[1].p, o->v[3].p); /* restore old */
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static bool opt_cell_let_temporarily(s7_scheme *sc, s7_pointer car_x, int32_t len)
+{
+ s7_pointer vars;
+ if (len <= 2)
+ return_false(sc, car_x);
+
+ vars = cadr(car_x);
+ if ((len < (NUM_VUNIONS - LET_TEMP_O1)) &&
+ (is_proper_list_1(sc, vars)) && /* just one var for now */
+ (is_proper_list_2(sc, car(vars))) && /* and var is (sym val) */
+ (is_symbol(caar(vars))) &&
+ (!is_immutable_symbol(caar(vars))) &&
+ (!is_syntactic_symbol(caar(vars))))
+ {
+ int32_t i;
+ s7_pointer p;
+ 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);
+
+ opc->v[4].o1 = sc->opts[sc->pc];
+ if (!cell_optimize(sc, cdaadr(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[2].i = len - 2;
+ opc->v[0].fp = opt_let_temporarily;
+ return_true(sc, car_x);
+ }
+ return_false(sc, car_x);
+}
+
+/* -------- cell_do -------- */
+
+#define do_curlet(o) T_Let(o->v[2].p)
+#define do_curlet_unchecked(o) o->v[2].p
+#define do_body_length(o) o->v[3].i
+#define do_result_length(o) o->v[4].i
+#define do_any_inits(o) o->v[7].o1
+#define do_any_body(o) o->v[10].o1
+#define do_any_results(o) o->v[11].o1
+#define do_any_test(o) o->v[12].o1
+#define do_any_steps(o) o->v[13].o1
+
+static void let_set_has_pending_value(s7_pointer lt)
+{
+ for (s7_pointer vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp))
+ slot_set_pending_value(vp, eof_object); /* gc needs a legit value here */
+}
+
+static void let_clear_has_pending_value(s7_scheme *sc, s7_pointer lt)
+{
+ for (s7_pointer vp = let_slots(lt); tis_slot(vp); vp = next_slot(vp))
+ slot_clear_has_pending_value(vp);
+}
+
+typedef s7_pointer (*opt_info_fp)(opt_info *o);
+
+static s7_pointer opt_do_any(opt_info *o)
+{
+ opt_info *o1;
+ opt_info *ostart = do_any_test(o);
+ opt_info *body = do_any_body(o);
+ opt_info *inits = do_any_inits(o);
+ opt_info *steps = do_any_steps(o);
+ opt_info *results = do_any_results(o);
+ int32_t i, k, len = do_body_length(o); /* len=6 tlist, 6|7 tbig, 0 tvect */
+ s7_pointer vp, result;
+ s7_scheme *sc = o->sc;
+ opt_info *os[NUM_VUNIONS];
+ opt_info_fp fp[NUM_VUNIONS];
+ s7_pointer old_e = sc->curlet;
+ gc_protect_via_stack(sc, old_e);
+ set_curlet(sc, do_curlet(o));
+ /* init */
+ for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); k++, vp = next_slot(vp))
+ {
+ o1 = inits->v[k].o1;
+ slot_set_value(vp, o1->v[0].fp(o1));
+ }
+ let_set_has_pending_value(sc->curlet);
+ for (i = 0; i < len; i++)
+ {
+ os[i] = body->v[i].o1;
+ fp[i] = os[i]->v[0].fp;
+ }
+ while (true)
+ {
+ /* end */
+ if (ostart->v[0].fb(ostart))
+ 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]);}
+ 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]);
+ /* 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));
+ }
+ 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));
+ }
+ /* result */
+ result = sc->T;
+ for (i = 0; i < do_result_length(o); i++)
+ {
+ o1 = results->v[i].o1;
+ result = o1->v[0].fp(o1);
+ }
+ let_clear_has_pending_value(sc, sc->curlet);
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return(result);
+}
+
+static s7_pointer opt_do_step_1(opt_info *o)
+{
+ /* 1 stepper (multi inits perhaps), 1 body, 1 rtn */
+ opt_info *o1;
+ opt_info *ostart = do_any_test(o);
+ opt_info *ostep = o->v[9].o1;
+ opt_info *inits = do_any_inits(o);
+ opt_info *body = do_any_body(o);
+ int32_t k;
+ s7_pointer vp, result, stepper = NULL;
+ s7_scheme *sc = o->sc;
+ s7_pointer old_e = sc->curlet;
+ gc_protect_via_stack(sc, old_e);
+ set_curlet(sc, do_curlet(o));
+ for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); k++, vp = next_slot(vp))
+ {
+ o1 = inits->v[k].o1;
+ slot_set_value(vp, o1->v[0].fp(o1));
+ if (has_stepper(vp)) stepper = vp;
+ }
+ while (!(ostart->v[0].fb(ostart)))
+ {
+ body->v[0].fp(body);
+ slot_set_value(stepper, ostep->v[0].fp(ostep));
+ }
+ o1 = do_any_results(o);
+ result = o1->v[0].fp(o1);
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return(result);
+}
+
+static s7_pointer opt_do_step_i(opt_info *o)
+{
+ /* 1 stepper (multi inits perhaps), 1 body expr, 1 rtn expr */
+ /* (do ((sum 0.0) (k 0 (+ k 1))) ((= k size) (set! (C i j) sum)) (set! sum (+ sum (* (A i k) (B k j))))) */
+ opt_info *o1;
+ opt_info *ostart = do_any_test(o);
+ opt_info *ostep = o->v[9].o1;
+ opt_info *inits = do_any_inits(o);
+ opt_info *body = do_any_body(o);
+ s7_pointer (*fp)(opt_info *o) = body->v[0].fp;
+ int32_t k;
+ s7_pointer vp, result, stepper = NULL, si;
+ s7_scheme *sc = o->sc;
+ s7_int end, incr;
+ s7_pointer old_e = sc->curlet;
+ gc_protect_via_stack(sc, old_e);
+ set_curlet(sc, do_curlet(o));
+ for (k = 0, vp = let_slots(sc->curlet); tis_slot(vp); k++, vp = next_slot(vp))
+ {
+ o1 = inits->v[k].o1;
+ slot_set_value(vp, o1->v[0].fp(o1));
+ if (has_stepper(vp)) stepper = vp;
+ }
+ end = integer(slot_value(ostart->v[2].p));
+ incr = ostep->v[2].i;
+ si = make_mutable_integer(sc, integer(slot_value(ostart->v[1].p)));
+ if (stepper) slot_set_value(stepper, si);
+ if (fp == opt_set_p_d_f_sf_add) /* ok since used only if body has one expr */
+ {
+ fp = opt_set_p_d_fm_sf_add;
+ slot_set_value(body->v[1].p, make_mutable_real(sc, real(slot_value(body->v[1].p))));
+ }
+ while (integer(si) != end)
+ {
+ fp(body);
+ integer(si) += incr;
+ }
+ clear_mutable_integer(si);
+ if (fp == opt_set_p_d_fm_sf_add)
+ clear_mutable_number(slot_value(body->v[1].p));
+ o1 = do_any_results(o);
+ result = o1->v[0].fp(o1);
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return(result);
+}
+
+#define do_no_vars_test(o) o->v[6].o1
+#define do_no_vars_body(o) o->v[7].o1
+
+static s7_pointer opt_do_no_vars(opt_info *o)
+{
+ /* no vars, no return, o->v[2].p=let, o->v[3].i=body length, o->v[4].i=return length=0, o->v[6]=end test */
+ opt_info *ostart = do_no_vars_test(o);
+ int32_t len = do_body_length(o);
+ s7_scheme *sc = o->sc;
+ bool (*fb)(opt_info *o) = ostart->v[0].fb;
+ s7_pointer old_e = sc->curlet;
+ gc_protect_via_stack(sc, old_e);
+ set_curlet(sc, do_curlet(o));
+ if (len == 0) /* titer */
+ while (!(fb(ostart)));
+ else
+ {
+ 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);
+ }}
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return(sc->T);
+}
+
+#define do_stepper_init(o) o->v[11].o1
+
+static s7_pointer opt_do_1(opt_info *o)
+{
+ /* 1 var, 1 expr, no return */
+ opt_info *o1 = do_stepper_init(o);
+ opt_info *ostart = do_any_test(o);
+ opt_info *ostep = o->v[9].o1;
+ opt_info *body = do_any_body(o);
+ s7_pointer vp = let_slots(do_curlet(o));
+ s7_scheme *sc = o->sc;
+ s7_pointer old_e = sc->curlet;
+ gc_protect_via_stack(sc, old_e);
+ set_curlet(sc, do_curlet(o));
+ slot_set_value(vp, o1->v[0].fp(o1));
+ if ((o->v[8].i == 1) &&
+ (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);
+ }
+ o->v[8].i = 2;
+ }
+ while (!(ostart->v[0].fb(ostart))) /* s7test tref */
+ {
+ body->v[0].fp(body);
+ slot_set_value(vp, ostep->v[0].fp(ostep));
+ }
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return(sc->T);
+}
+
+#define do_n_body(o) o->v[7].o1
+
+static s7_pointer opt_do_n(opt_info *o)
+{
+ /* 1 var, no return */
+ opt_info *o1 = do_stepper_init(o);
+ opt_info *ostart = do_any_test(o);
+ opt_info *ostep = o->v[9].o1;
+ opt_info *body = do_n_body(o);
+ int32_t len = do_body_length(o);
+ s7_pointer vp = let_slots(do_curlet(o));
+ s7_scheme *sc = o->sc;
+ s7_pointer old_e = sc->curlet;
+ gc_protect_via_stack(sc, old_e);
+ set_curlet(sc, do_curlet(o));
+ slot_set_value(vp, o1->v[0].fp(o1));
+ if (len == 2) /* tmac tshoot */
+ {
+ 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));
+ }}
+ 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;
+ }
+ 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));
+ }
+ 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));
+ }}
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return(sc->T);
+}
+
+static s7_pointer opt_do_times(opt_info *o)
+{
+ /* 1 var, no return */
+ opt_info *o1 = do_stepper_init(o);
+ opt_info *body = do_n_body(o);
+ int32_t len = do_body_length(o);
+ s7_int end = (is_slot(let_dox_slot2_unchecked(do_curlet(o)))) ? integer(slot_value(let_dox_slot2(do_curlet(o)))) : o->v[6].i;
+ s7_pointer vp = let_dox1_value(do_curlet(o));
+ s7_scheme *sc = o->sc;
+ s7_pointer old_e = sc->curlet;
+ gc_protect_via_stack(sc, old_e);
+ set_curlet(sc, do_curlet(o));
+ set_integer(vp, integer(o1->v[0].fp(o1)));
+ if (len == 2) /* tmac tmisc */
+ {
+ 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)++;
+ }}
+ 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)++;
+ }
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return(sc->T);
+}
+
+static s7_pointer opt_do_list_simple(opt_info *o)
+{
+ opt_info *o1 = do_stepper_init(o);
+ s7_pointer vp = let_slots(do_curlet(o));
+ s7_scheme *sc = o->sc;
+ s7_pointer (*fp)(opt_info *o);
+ s7_pointer old_e = sc->curlet;
+ gc_protect_via_stack(sc, old_e);
+ set_curlet(sc, do_curlet(o));
+ slot_set_value(vp, o1->v[0].fp(o1));
+ o1 = do_any_body(o);
+ fp = o1->v[0].fp;
+ 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)));
+ }
+ else
+ while (!is_null(slot_value(vp)))
+ {
+ fp(o1);
+ slot_set_value(vp, cdr(slot_value(vp)));
+ }
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return(sc->T);
+}
+
+static s7_pointer opt_do_very_simple(opt_info *o)
+{
+ /* like simple but step can be direct, v[2].p is a let, v[3].i=end? */
+ opt_info *o1 = do_stepper_init(o);
+ s7_int end = (is_slot(let_dox_slot2_unchecked(do_curlet_unchecked(o)))) ? integer(slot_value(let_dox_slot2(do_curlet(o)))) : o->v[3].i;
+ s7_pointer vp = let_dox1_value(do_curlet(o));
+ s7_pointer (*f)(opt_info *o);
+ s7_scheme *sc = o->sc;
+ s7_pointer old_e = sc->curlet;
+ gc_protect_via_stack(sc, old_e);
+ set_curlet(sc, do_curlet(o));
+ set_integer(vp, integer(o1->v[0].fp(o1)));
+ o1 = do_any_body(o);
+ f = o1->v[0].fp;
+ if (f == opt_p_pip_ssf) /* tref.scm */
+ {
+ 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)++;
+ }}
+ 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)++;
+ }}
+ 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)++;
+ }}
+ 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)++;}}
+ /* 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);
+ return(sc->T);
+}
+
+#define do_prepack_end(o) o->v[1].i
+#define do_prepack_stepper(o) o->v[6].p
+
+static s7_pointer opt_do_prepackaged(opt_info *o)
+{
+ opt_info *o1 = do_stepper_init(o);
+ s7_int end = (is_slot(let_dox_slot2_unchecked(do_curlet_unchecked(o)))) ? integer(slot_value(let_dox_slot2(do_curlet(o)))) : o->v[3].i;
+ s7_pointer vp = let_dox1_value(do_curlet(o));
+ s7_scheme *sc = o->sc;
+ s7_pointer old_e = sc->curlet;
+ gc_protect_via_stack(sc, old_e);
+ set_curlet(sc, do_curlet(o));
+ set_integer(vp, integer(o1->v[0].fp(o1)));
+
+ do_prepack_stepper(o) = vp;
+ do_prepack_end(o) = end;
+ o->v[7].fp(o); /* call opt_do_i|dpnr below */
+
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return(sc->T);
+}
+
+static s7_pointer opt_do_dpnr(opt_info *o)
+{
+ opt_info *o1 = do_any_body(o);
+ s7_pointer vp = do_prepack_stepper(o);
+ s7_int end = do_prepack_end(o);
+ s7_double (*f)(opt_info *o) = o1->v[O_WRAP].fd;
+ while (integer(vp) < end) {f(o1); integer(vp)++;}
+ return(NULL);
+}
+
+static s7_pointer opt_do_ipnr(opt_info *o)
+{
+ opt_info *o1 = do_any_body(o);
+ s7_pointer vp = do_prepack_stepper(o);
+ s7_int end = do_prepack_end(o);
+ s7_int (*f)(opt_info *o) = o1->v[O_WRAP].fi;
+ while (integer(vp) < end) {f(o1); integer(vp)++;}
+ return(NULL);
+}
+
+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))
+ return(!s7_tree_memq(sc, stop, cdr(p)));
+ return(true);
+}
+
+static bool tree_has_setters(s7_scheme *sc, s7_pointer tree)
+{
+ if (is_quote(car(tree))) return(false);
+ clear_symbol_list(sc);
+ add_symbol_to_list(sc, sc->set_symbol);
+ add_symbol_to_list(sc, sc->vector_set_symbol);
+ add_symbol_to_list(sc, sc->list_set_symbol);
+ add_symbol_to_list(sc, sc->let_set_symbol);
+ add_symbol_to_list(sc, sc->hash_table_set_symbol);
+ add_symbol_to_list(sc, sc->set_car_symbol);
+ add_symbol_to_list(sc, sc->set_cdr_symbol);
+ return(pair_set_memq(sc, tree));
+}
+
+static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, s7_pointer step_vars, bool *has_set);
+
+static bool do_passes_safety_check(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer step_vars, bool *has_set)
+{
+ if (!is_pair(body)) return(true);
+ if (!is_safety_checked(body))
+ {
+ set_safety_checked(body);
+ if (!(do_is_safe(sc, body, stepper, sc->nil, step_vars, has_set)))
+ set_unsafe_do(body);
+ }
+ return(!is_unsafe_do(body));
+}
+
+#define SIZE_O NUM_VUNIONS
+
+static bool all_integers(s7_scheme *sc, s7_pointer expr)
+{
+ if ((is_symbol(car(expr))) && (is_all_integer(car(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;
+ return(is_null(p));
+ }
+ return(false);
+}
+
+static bool all_floats(s7_scheme *sc, s7_pointer expr)
+{
+ if ((is_symbol(car(expr))) && (is_all_float(car(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;
+ return(is_null(p));
+ }
+ return(false);
+}
+
+static bool opt_cell_do(s7_scheme *sc, s7_pointer car_x, int32_t len)
+{
+ opt_info *opc;
+ s7_pointer p, end, let = NULL, old_e = sc->curlet, stop, ind, ind_step;
+ int32_t i, k, var_len, body_len = len - 3, body_index, step_len, rtn_len, step_pc, init_pc, end_test_pc;
+ bool has_set = false;
+ opt_info *init_o[SIZE_O], *step_o[SIZE_O], *body_o[SIZE_O], *return_o[SIZE_O];
+
+ if (len < 3)
+ return_false(sc, car_x);
+
+ if (!s7_is_proper_list(sc, cadr(car_x)))
+ return_false(sc, car_x);
+ var_len = proper_list_length(cadr(car_x));
+ step_len = var_len;
+ if (body_len > SIZE_O)
+ return_false(sc, car_x);
+ end = caddr(car_x);
+ if (!is_pair(end))
+ return_false(sc, car_x);
+
+ opc = alloc_opt_info(sc);
+ let = inline_make_let(sc, sc->curlet);
+ push_stack(sc, OP_GC_PROTECT, old_e, let);
+
+ /* the vars have to be added to the let before evaluating the inits
+ * else symbol_id can be > let_id (see "(test (do ((i (do ((i (do ((i 0 (+ i 1)))...")
+ */
+ clear_symbol_list(sc);
+ for (p = cadr(car_x); is_pair(p); p = cdr(p))
+ {
+ 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);
+ }
+ else return_false(sc, car_x);
+ }
+ if (tis_slot(let_slots(let)))
+ let_set_slots(let, reverse_slots(let_slots(let)));
+
+ /* inits */
+ {
+ s7_pointer slot;
+ 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 */
+ }}}}
+ 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);
+ }}}}
+
+ /* end test */
+ end_test_pc = sc->pc;
+ if (!bool_optimize_nw(sc, end))
+ {
+ unstack_gc_protect(sc); /* not pop_stack! */
+ set_curlet(sc, old_e);
+ return_false(sc, car_x);
+ }
+
+ stop = car(end);
+ if ((is_proper_list_3(sc, stop)) &&
+ ((car(stop) == sc->num_eq_symbol) || (car(stop) == sc->geq_symbol) || (car(stop) == sc->gt_symbol)) &&
+ (is_symbol(cadr(stop))) &&
+ ((is_t_integer(caddr(stop))) || (is_symbol(caddr(stop)))))
+ {
+ 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);
+ }}}}
+
+ /* body */
+ body_index = sc->pc;
+ for (k = 0, i = 3, p = cdddr(car_x); i < len; k++, i++, p = cdr(p))
+ {
+ opt_info *start = sc->opts[sc->pc];
+ body_o[k] = start;
+ if (i < 5) opc->v[i + 7].o1 = start;
+ if (!cell_optimize(sc, p))
+ break;
+ oo_idp_nr_fixup(start);
+ }
+ if (!is_null(p))
+ {
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return_false(sc, car_x);
+ }
+
+ /* we faked up sc->curlet above, so s7_optimize_1 (float_optimize) isn't safe here
+ * this means if clm nested loops get here, they aren't fully optimized -- fallback into dox would be better
+ */
+ /* steps */
+ step_pc = sc->pc;
+ for (k = 0, p = cadr(car_x); is_pair(p); k++, p = cdr(p))
+ {
+ s7_pointer var = car(p);
+ step_o[k] = sc->opts[sc->pc];
+ if ((is_pair(cddr(var))) &&
+ (!cell_optimize(sc, cddr(var))))
+ break;
+ }
+ if (!is_null(p))
+ {
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return_false(sc, car_x);
+ }
+
+ /* result */
+ if (!is_list(cdr(end)))
+ {
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return_false(sc, car_x);
+ }
+ for (rtn_len = 0, p = cdr(end); (is_pair(p)) && (rtn_len < SIZE_O); p = cdr(p), rtn_len++)
+ {
+ return_o[rtn_len] = sc->opts[sc->pc];
+ if (!cell_optimize(sc, p))
+ break;
+ }
+ if (!is_null(p))
+ {
+ unstack_gc_protect(sc);
+ set_curlet(sc, old_e);
+ return_false(sc, car_x);
+ }
+
+ do_curlet_unchecked(opc) = T_Let(let);
+ do_body_length(opc) = len - 3;
+ do_result_length(opc) = rtn_len;
+ opc->v[9].o1 = sc->opts[step_pc];
+ set_curlet(sc, old_e);
+
+ if ((var_len == 0) && (rtn_len == 0))
+ {
+ opt_info *body;
+ 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;
+ }
+ return_true(sc, car_x);
+ }
+ opc->v[8].i = 0;
+ if (body_len == 1)
+ {
+ 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;
+ }
+ if ((var_len != 1) || (step_len != 1) || (rtn_len != 0))
+ {
+ opt_info *inits;
+
+ opc->v[0].fp = ((step_len == 1) && (body_len == 1) && (rtn_len == 1)) ? opt_do_step_1 : opt_do_any;
+ /* (do ((sum 0.0) (k 0 (+ k 1))) ((= k size) (set! (C i j) sum)) (set! sum (+ sum (* (A i k) (B k j))))) tmat */
+
+ 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;
+
+ inits = alloc_opt_info(sc);
+ for (k = 0; k < var_len; 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;
+ }
+ else
+ {
+ do_any_body(opc) = sc->opts[body_index];
+ do_any_results(opc) = return_o[0];
+ }
+ return_true(sc, car_x);
+ }
+
+ opc->v[0].fp = (body_len == 1) ? opt_do_1 : opt_do_n;
+ p = caadr(car_x);
+ ind = car(p);
+ ind_step = caddr(p);
+ end = caaddr(car_x);
+
+ if (body_len == 1) /* opt_do_1 */
+ do_any_body(opc) = sc->opts[body_index];
+ else
+ {
+ opt_info *body = alloc_opt_info(sc);
+ for (k = 0; k < body_len; k++)
+ body->v[k].o1 = body_o[k];
+ do_n_body(opc) = body;
+ }
+ do_stepper_init(opc) = sc->opts[init_pc];
+ do_any_test(opc) = sc->opts[end_test_pc];
+ do_any_steps(opc) = sc->opts[step_pc];
+
+ if ((is_pair(end)) && /* (= i len|100) */
+ (cadr(end) == ind) &&
+ (is_pair(ind_step))) /* (+ i 1) */
+ {
+ /* 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));
+ }}
+ 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;
+ }
+ return_true(sc, car_x);
+}
+
+static bool p_syntax(s7_scheme *sc, s7_pointer car_x, int32_t len)
+{
+ s7_pointer func = lookup_global(sc, car(car_x));
+ opcode_t op;
+ if (!is_syntax(func)) {clear_syntactic(car_x); return_false(sc, car_x);}
+ /* I think this is the only case where we don't precede syntax_opcode with syntactic_symbol checks */
+ op = syntax_opcode(func);
+ switch (op)
+ {
+ case OP_QUOTE: if ((is_pair(cdr(car_x))) && (is_null(cddr(car_x)))) return(opt_cell_quote(sc, car_x)); break;
+ case OP_SET: if (len == 3) return(opt_cell_set(sc, car_x)); break;
+ case OP_BEGIN: if (len > 1) return(opt_cell_begin(sc, car_x, len)); break;
+ case OP_WHEN:
+ case OP_UNLESS: if (len > 2) return(opt_cell_when(sc, car_x, len)); break;
+ case OP_COND: if (len > 1) return(opt_cell_cond(sc, car_x)); break;
+ case OP_CASE: if (len > 2) return(opt_cell_case(sc, car_x)); break;
+ case OP_AND:
+ case OP_OR: return(opt_cell_and(sc, car_x, len));
+ case OP_IF: return(opt_cell_if(sc, car_x, len));
+ case OP_DO: return(opt_cell_do(sc, car_x, len));
+ case OP_LET_TEMPORARILY: return(opt_cell_let_temporarily(sc, car_x, len));
+ default:
+ /* for lambda et al we'd return the new closure, but if unsafe?
+ * let(*) -> make the let -> body (let=99% of cases), could we use do (i.e. do+no steppers+no end!) or let-temp?
+ * with-let -> establish car(args)=let, then body
+ * macroexpand -> return the expansion
+ * define et al -> define + return value
+ * map and for-each are not syntax, also call-with*(=exit)
+ * also let-temp for vars>1
+ */
+ break;
+ }
+ return_false(sc, car_x);
+}
+
+
+/* -------------------------------------------------------------------------------- */
+static bool float_optimize_1(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer car_x = car(expr), head, s_func, s_slot = NULL;
+ s7_int len;
+ if (OPT_PRINT) fprintf(stderr, " float_optimize %s\n", display(expr));
+ if (WITH_GMP) return(false);
+ if (!is_pair(car_x)) /* wrap constants/symbols */
+ return(opt_float_not_pair(sc, car_x));
+
+ head = car(car_x);
+ len = s7_list_length(sc, car_x);
+ if (is_symbol(head))
+ {
+ if ((is_syntactic_symbol(head)) ||
+ (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);
+ s_func = slot_value(s_slot);
+ }
+ else
+ if (is_c_function(head))
+ s_func = head;
+ else return_false(sc, car_x);
+
+ if (is_c_function(s_func))
+ {
+ 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));
+ }}
+ 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)));
+ }}
+ if (!s_slot) return_false(sc, car_x);
+ return(d_implicit_ok(sc, s_slot, car_x, len));
+ }
+ return_false(sc, car_x);
+}
+
+static bool float_optimize(s7_scheme *sc, s7_pointer expr) {return((float_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));}
+/* combining the sc->pc check into float_optimize_1 (and similarly for the other 3 cases) does not given any speedup */
+
+static bool int_optimize_1(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer car_x = car(expr), head, s_func, s_slot = NULL;
+ s7_int len;
+ if (OPT_PRINT) fprintf(stderr, " int_optimize %s\n", display(expr));
+ if (WITH_GMP) return(false);
+ if (!is_pair(car_x)) /* wrap constants/symbols */
+ return(opt_int_not_pair(sc, car_x));
+
+ head = car(car_x);
+ len = s7_list_length(sc, car_x);
+ if (is_symbol(head))
+ {
+ if ((is_syntactic_symbol(head)) ||
+ (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);
+ }
+ else
+ if (is_c_function(head))
+ s_func = head;
+ else return_false(sc, car_x);
+
+ if (is_c_function(s_func))
+ {
+ 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)));
+ }}
+ 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)));
+ }}
+ if (!s_slot) return_false(sc, car_x);
+ return(i_implicit_ok(sc, s_slot, car_x, len));
+ }
+ return_false(sc, car_x);
+}
+
+static bool int_optimize(s7_scheme *sc, s7_pointer expr) {return((int_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));}
+
+/* cell_optimize... */
+static bool p_2x_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart, s7_pointer expr)
+{
+ s7_pointer sig = c_function_signature(s_func);
+ 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;
+ }}
+ {
+ s7_i_ii_t ifunc = s7_i_ii_function(s_func);
+ sc->pc = pstart - 1;
+ if ((ifunc) &&
+ (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);
+ }}
+ 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)));
+}
+
+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)
+{
+ s7_pointer sig = c_function_signature(s_func);
+ 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;
+ }}
+ 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)));
+}
+
+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)
+{
+ s7_pointer head = car(car_x);
+ s7_int len = s7_list_length(sc, car_x);
+
+ if ((is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) &&
+ (d_7piid_ok(sc, opc, s_func, car_x)))
+ {
+ opc->v[O_WRAP].fd = opc->v[0].fd;
+ opc->v[0].fp = d_to_p; /* as above, if d_7piid is ok, we need d_to_p for cell_optimize */
+ return_true(sc, car_x);
+ }
+ if ((is_target_or_its_alias(head, s_func, sc->float_vector_ref_symbol)) &&
+ (d_7piii_ok(sc, opc, s_func, car_x)))
+ {
+ opc->v[O_WRAP].fd = opc->v[0].fd;
+ opc->v[0].fp = d_to_p;
+ return_true(sc, car_x);
+ }
+ if (i_7piii_ok(sc, opc, 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);
+ }
+ if (is_target_or_its_alias(head, s_func, sc->int_vector_set_symbol))
+ return_false(sc, car_x);
+ if (p_piip_ok(sc, opc, s_func, car_x))
+ return_true(sc, car_x);
+ sc->pc = pstart;
+ if (s_func == global_value(sc->vector_ref_symbol))
+ {
+ s7_pointer obj;
+ 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(p_call_any_ok(sc, opc, s_func, car_x, len));
+}
+
+static bool p_5x_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func, s7_pointer car_x, int32_t pstart, s7_pointer expr)
+{
+ s7_pointer head = car(car_x);
+ if ((is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) &&
+ (d_7piiid_ok(sc, opc, s_func, 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);
+}
+
+static bool cell_optimize_1(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer car_x = car(expr), head, s_func, s_slot = NULL;
+ s7_int len;
+ if (OPT_PRINT) fprintf(stderr, " cell_optimize %s\n", display(expr));
+ if (WITH_GMP) return(false);
+ if (!is_pair(car_x)) /* wrap constants/symbols */
+ return(opt_cell_not_pair(sc, car_x));
+
+ head = car(car_x);
+ len = s7_list_length(sc, car_x);
+ 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));
+
+ s_slot = s7_slot(sc, head);
+ if (!is_slot(s_slot)) return_false(sc, car_x);
+ s_func = slot_value(s_slot);
+ }
+ else
+ if (is_c_function(head)) /* (#_abs -1) I think */
+ 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);
+ }
+ 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 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 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 */
+ }}
+ 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);
+ }
+ if (is_macro(s_func))
+ 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);
+ }
+#else
+ return(p_implicit_ok(sc, s_slot, car_x, len));
+#endif
+ }
+ return_false(sc, car_x);
+}
+
+static bool cell_optimize(s7_scheme *sc, s7_pointer expr) {return((cell_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));}
+
+static bool bool_optimize_nw_1(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer car_x = car(expr), head, s_func = NULL;
+ s7_int len;
+ if (!is_pair(car_x)) /* wrap constants/symbols */
+ return(opt_bool_not_pair(sc, car_x));
+
+ head = car(car_x);
+ len = s7_list_length(sc, car_x);
+ 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);
+ }
+ s_func = lookup_unexamined(sc, head);
+ }
+ else
+ if (is_c_function(head))
+ s_func = head;
+ else return_false(sc, car_x);
+
+ if (!s_func) return_false(sc, car_x);
+ 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);
+ 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;
+ }}
+ return_false(sc, car_x);
+}
+
+static bool bool_optimize_nw(s7_scheme *sc, s7_pointer expr) {return((bool_optimize_nw_1(sc, expr)) && (sc->pc < OPTS_SIZE));}
+
+static bool bool_optimize(s7_scheme *sc, s7_pointer expr)
+{
+ int32_t start = sc->pc;
+ opt_info *wrapper;
+ if (OPT_PRINT) fprintf(stderr, " bool_optimize %s\n", display(expr));
+ if (WITH_GMP) return(false);
+ if (bool_optimize_nw(sc, expr))
+ return_true(sc, expr);
+ sc->pc = start;
+ wrapper = sc->opts[start];
+ if (!cell_optimize(sc, expr))
+ return_false(sc, NULL);
+ if (wrapper->v[O_WRAP].fp) /* (when (+ i 1) ...) */
+ return_false(sc, NULL);
+ wrapper->v[O_WRAP].fp = wrapper->v[0].fp;
+ wrapper->v[0].fb = p_to_b;
+ return_true(sc, expr);
+}
+
+static s7_pfunc s7_bool_optimize(s7_scheme *sc, s7_pointer expr)
+{
+ sc->pc = 0;
+ if ((bool_optimize(sc, expr)) && (sc->pc < OPTS_SIZE))
+ return_success(sc, opt_bool_any, expr);
+ return_null(sc, expr);
+}
+
+static s7_double opt_float_any(s7_scheme *sc) {return(sc->opts[0]->v[0].fd(sc->opts[0]));} /* for snd-sig.c */
+
+s7_float_function s7_float_optimize(s7_scheme *sc, s7_pointer expr)
+{
+ sc->pc = 0;
+ if ((float_optimize(sc, expr)) && (sc->pc < OPTS_SIZE))
+ return(opt_float_any);
+ return(NULL); /* can't return_null(sc, expr) here due to type mismatch (s7_pfunc vs s7_float_function) */
+}
+
+static s7_pfunc s7_optimize_1(s7_scheme *sc, s7_pointer expr, bool nv)
+{
+ if (WITH_GMP) return(NULL);
+ if ((!is_pair(expr)) || (no_cell_opt(expr)) || (sc->debug != 0))
+ return_null(sc, expr);
+ sc->pc = 0;
+ if (!no_int_opt(expr))
+ {
+ if (int_optimize(sc, 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);
+ 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);
+ sc->pc = 0;
+ set_no_bool_opt(expr);
+ }
+ if (cell_optimize(sc, expr))
+ return_success(sc, (nv) ? opt_cell_any_nv : opt_wrap_cell, expr);
+ set_no_cell_opt(expr); /* checked above */
+ return_null(sc, expr);
+}
+
+s7_pfunc s7_optimize(s7_scheme *sc, s7_pointer expr) {return(s7_optimize_1(sc, expr, false));}
+static s7_pfunc s7_optimize_nv(s7_scheme *sc, s7_pointer expr) {return(s7_optimize_1(sc, expr, true));}
+
+static s7_pointer g_optimize(s7_scheme *sc, s7_pointer args)
+{
+ s7_pfunc f;
+ s7_pointer code = car(args), result = sc->undefined;
+ gc_protect_via_stack(sc, code);
+ f = s7_optimize(sc, code);
+ if (f) result = f(sc);
+ if (stack_top_op(sc) == OP_GC_PROTECT) unstack_gc_protect(sc);
+ return(result);
+}
+
+static s7_pfunc s7_cell_optimize(s7_scheme *sc, s7_pointer expr, bool nv)
+{
+ sc->pc = 0;
+ if ((cell_optimize(sc, expr)) && (sc->pc < OPTS_SIZE))
+ return((nv) ? opt_cell_any_nv : opt_wrap_cell);
+ return_null(sc, expr);
+}
+
+
+/* ---------------- bool funcs (an experiment) ---------------- */
+static void fx_curlet_tree(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer slot1 = let_slots(sc->curlet), slot3 = NULL, outer_e;
+ bool more_vars;
+ s7_pointer slot2 = next_slot(slot1);
+ if (tis_slot(slot2)) slot3 = next_slot(slot2);
+
+ 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);
+
+ outer_e = let_outlet(sc->curlet);
+ if ((!more_vars) &&
+ (is_let(outer_e)) &&
+ (!is_funclet(outer_e)) &&
+ (tis_slot(let_slots(outer_e))) &&
+ (slot_symbol(let_slots(outer_e)) != slot_symbol(slot1)))
+ {
+ slot1 = let_slots(outer_e);
+ 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))));
+ }
+}
+
+static void fx_curlet_tree_in(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer slot1 = let_slots(sc->curlet), slot3 = NULL;
+ 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))));
+}
+
+typedef bool (*s7_bfunc)(s7_scheme *sc, s7_pointer expr); /* used in eval */
+
+static bool fb_lt_ss(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer x = lookup(sc, cadr(expr));
+ s7_pointer y = lookup(sc, opt2_sym(cdr(expr)));
+ return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) < integer(y)) : lt_b_7pp(sc, x, y));
+}
+
+static bool fb_lt_ts(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer x = t_lookup(sc, cadr(expr), expr);
+ s7_pointer y = lookup(sc, opt2_sym(cdr(expr)));
+ return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) < integer(y)) : lt_b_7pp(sc, x, y));
+}
+
+static bool fb_num_eq_ss(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer x = lookup(sc, cadr(expr));
+ s7_pointer y = lookup(sc, opt2_sym(cdr(expr)));
+ return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) == integer(y)) : num_eq_b_7pp(sc, x, y));
+}
+
+static bool fb_num_eq_s0(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer x = lookup(sc, cadr(expr));
+ return((is_t_integer(x)) ? (integer(x) == 0) : num_eq_b_7pp(sc, x, int_zero));
+}
+
+static bool fb_num_eq_s0f(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer x = lookup(sc, cadr(expr));
+ return((is_t_real(x)) ? (real(x) == 0.0) : num_eq_b_7pp(sc, x, real_zero));
+}
+
+static bool fb_gt_tu(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer x = t_lookup(sc, cadr(expr), expr), y = u_lookup(sc, opt2_sym(cdr(expr)), expr);
+ return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) > integer(y)) : gt_b_7pp(sc, x, y));
+}
+
+static bool fb_gt_ss(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer x = s_lookup(sc, cadr(expr), expr);
+ s7_pointer y = s_lookup(sc, opt2_sym(cdr(expr)), expr);
+ return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) > integer(y)) : gt_b_7pp(sc, x, y));
+}
+
+static bool fb_geq_ss(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer x = s_lookup(sc, cadr(expr), expr);
+ s7_pointer y = s_lookup(sc, opt2_sym(cdr(expr)), expr);
+ return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) >= integer(y)) : geq_b_7pp(sc, x, y));
+}
+
+static bool fb_leq_ss(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer x = s_lookup(sc, cadr(expr), expr);
+ s7_pointer y = s_lookup(sc, opt2_sym(cdr(expr)), expr);
+ return(((is_t_integer(x)) && (is_t_integer(y))) ? (integer(x) <= integer(y)) : leq_b_7pp(sc, x, y));
+}
+
+static bool fb_leq_ti(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer x = t_lookup(sc, cadr(expr), expr);
+ if (is_t_integer(x)) return(integer(x) <= integer(opt2_con(cdr(expr))));
+ return(g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(expr)))));
+}
+
+static bool fb_leq_ui(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer x = u_lookup(sc, cadr(expr), expr);
+ if (is_t_integer(x)) return(integer(x) <= integer(opt2_con(cdr(expr))));
+ return(g_leq_xi(sc, set_plist_2(sc, x, opt2_con(cdr(expr)))));
+}
+
+static s7_pointer fx_to_fb(s7_scheme *sc, s7_function fx) /* eventually parallel arrays? */
+{
+ if (fx == fx_num_eq_ss) return((s7_pointer)fb_num_eq_ss);
+ if (fx == fx_lt_ss) return((s7_pointer)fb_lt_ss);
+ if (fx == fx_lt_ts) return((s7_pointer)fb_lt_ts);
+ if (fx == fx_gt_ss) return((s7_pointer)fb_gt_ss);
+ if (fx == fx_leq_ss) return((s7_pointer)fb_leq_ss);
+ if (fx == fx_leq_ti) return((s7_pointer)fb_leq_ti);
+ if (fx == fx_leq_ui) return((s7_pointer)fb_leq_ui);
+ if (fx == fx_geq_ss) return((s7_pointer)fb_geq_ss);
+ if (fx == fx_gt_tu) return((s7_pointer)fb_gt_tu);
+ if (fx == fx_num_eq_s0) return((s7_pointer)fb_num_eq_s0);
+ if (fx == fx_num_eq_s0f) return((s7_pointer)fb_num_eq_s0f);
+ return(NULL);
+}
+
+static void fb_annotate(s7_scheme *sc, s7_pointer form, s7_pointer fx_expr, opcode_t op)
+{
+ s7_pointer bfunc;
+ if ((is_fx_treeable(cdr(form))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(form)); /* and not already treed? just the one expr? */
+ bfunc = fx_to_fb(sc, fx_proc(fx_expr));
+ if (bfunc)
+ {
+ set_opt3_any(cdr(form), bfunc);
+ pair_set_syntax_op(form, op);
+ }
+#if 0
+ /* fb_annotate additions? [these currently require new "B" ops] */
+ else
+ {
+ fprintf(stderr, "fx: %s %s\n", ((is_pair(fx_expr)) && (is_pair(car(fx_expr)))) ? op_names[optimize_op(car(fx_expr))] : "", display_truncated(fx_expr));
+ if (caar(fx_expr) == sc->num_eq_symbol) abort();
+ /* [fx_leq_ti] fx_lt_t0 fx_gt_ti fx_num_eq_u0 */
+ }
+#endif
+}
+
+/* when_b cond? do end-test? num_eq_vs|us */
+
+
+/* ---------------------------------------- for-each ---------------------------------------- */
+static Inline s7_pointer inline_make_counter(s7_scheme *sc, s7_pointer iter) /* all calls are hit about the same: lg/sg */
+{
+ s7_pointer x;
+ new_cell(sc, x, T_COUNTER);
+ counter_set_result(x, sc->nil);
+ if ((S7_DEBUGGING) && (!is_iterator(iter)) && (!is_pair(iter))) fprintf(stderr, "%s[%d]: %s?\n", __func__, __LINE__, display(iter));
+ counter_set_list(x, iter); /* iterator -- here it's always either an iterator or a pair */
+ counter_set_capture(x, 0); /* will be capture_let_counter */
+ counter_set_let(x, sc->rootlet); /* will be the saved let */
+ counter_set_slots(x, sc->nil); /* local let slots before body is evalled */
+ stack_set_has_counters(sc->stack);
+ return(x);
+}
+
+static s7_pointer make_iterators(s7_scheme *sc, s7_pointer caller, s7_pointer args)
+{
+ s7_pointer p = cdr(args);
+ sc->temp3 = args;
+ sc->z = sc->nil; /* don't use sc->args here -- it needs GC protection until we get the iterators */
+ for (s7_int i = 2; is_pair(p); p = cdr(p), i++)
+ {
+ 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);
+ }
+ sc->z = cons(sc, iter, sc->z);
+ }
+ sc->temp3 = sc->unused;
+ return(proper_list_reverse_in_place(sc, sc->z));
+}
+
+static s7_pointer seq_init(s7_scheme *sc, s7_pointer seq)
+{
+ if (is_float_vector(seq)) return(real_zero);
+ if (is_string(seq)) return(chars[65]);
+ if ((is_int_vector(seq)) || (is_byte_vector(seq))) return(int_zero);
+ return(sc->F);
+}
+
+#define MUTLIM 32 /* was 1000, sets when (in vector-length) to start using a mutated real, rather than make_real during the loop through the vector */
+
+static s7_pointer clear_for_each(s7_scheme *sc)
+{
+ sc->map_call_ctr--;
+ unstack_with(sc, OP_MAP_UNWIND);
+ return(sc->unspecified);
+}
+
+static s7_pointer g_for_each_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) /* one sequence arg */
+{
+ s7_pointer body = closure_body(f);
+ if (!no_cell_opt(body)) /* if at top level we often get an unoptimized (not safe) function here that can be cell_optimized below */
+ {
+ s7_pfunc func = NULL;
+ s7_pointer old_e = sc->curlet, pars = closure_args(f), val, slot, res = NULL;
+
+ val = seq_init(sc, seq);
+ set_curlet(sc, inline_make_let_with_slot(sc, closure_let(f), (is_pair(car(pars))) ? caar(pars) : car(pars), val));
+ 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 (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> */
+ else /* not func -- unneeded "else" but otherwise confusing code */
+ {
+ 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)))
+ {
+ s7_pointer c = inline_make_counter(sc, seq);
+ counter_set_result(c, seq);
+ push_stack(sc, OP_FOR_EACH_2, c, f);
+ return(sc->unspecified);
+ }
+
+ if (!is_iterator(seq))
+ {
+ if (!is_mappable(seq))
+ 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;
+ push_stack(sc, OP_FOR_EACH_1, inline_make_counter(sc, sc->z), f);
+ sc->z = sc->unused;
+ return(sc->unspecified);
+}
+
+static void map_or_for_each_closure_pair_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case)
+{
+ for (s7_pointer fast1 = seq1, slow1 = seq1, fast2 = seq2, slow2 = seq2; (is_pair(fast1)) && (is_pair(fast2));
+ fast1 = cdr(fast1), slow1 = cdr(slow1), fast2 = cdr(fast2), slow2 = cdr(slow2))
+ {
+ 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); /* 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);
+ }}}
+}
+
+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)
+{
+ s7_int len = vector_length(seq1);
+ if (len > vector_length(seq2)) len = vector_length(seq2);
+ for (s7_int i = 0; i < len; i++)
+ {
+ 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);
+ 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_string_2(s7_scheme *sc, s7_pfunc func, s7_pointer seq1, s7_pointer seq2, s7_pointer slot1, s7_pointer slot2, bool for_each_case)
+{
+ s7_int len = string_length(seq1);
+ const char *s1 = string_value(seq1), *s2 = string_value(seq2);
+ if (len > string_length(seq2)) len = string_length(seq2);
+ for (s7_int i = 0; i < len; i++)
+ {
+ slot_set_value(slot1, chars[(uint8_t)(s1[i])]);
+ slot_set_value(slot2, chars[(uint8_t)(s2[i])]);
+ 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 s7_pointer g_for_each_closure_2(s7_scheme *sc, s7_pointer f, s7_pointer seq1, s7_pointer seq2)
+{
+ s7_pointer body = closure_body(f);
+ if (!no_cell_opt(body))
+ {
+ s7_pfunc func = NULL;
+ s7_pointer olde = sc->curlet, pars = closure_args(f), slot1, slot2;
+ 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));
+ 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 (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);
+ }
+ else /* not func */
+ {
+ 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);
+ 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);
+ sc->z = list_2(sc, sc->z, s7_make_iterator(sc, seq2));
+ }
+ else sc->z = list_2(sc, sc->z, seq2);
+ push_stack(sc, OP_FOR_EACH, cons_unchecked(sc, sc->z, make_list(sc, 2, sc->nil)), f);
+ sc->z = sc->unused;
+ return(sc->unspecified);
+}
+
+static inline bool for_each_arg_is_null(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p = args;
+ bool got_nil = false;
+ for (s7_int i = 2; is_pair(p); p = cdr(p), i++)
+ {
+ 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);
+ }}
+ return(got_nil);
+}
+
+static s7_pointer g_for_each(s7_scheme *sc, s7_pointer args)
+{
+ #define H_for_each "(for-each proc object . objects) applies proc to each element of the objects traversed in parallel. \
+Each object can be a list, string, vector, hash-table, or any other sequence."
+ #define Q_for_each s7_make_circular_signature(sc, 2, 3, sc->is_unspecified_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol)
+
+ s7_pointer f = car(args);
+ s7_int len = proper_list_length(cdr(args));
+ bool arity_ok = false;
+
+ /* try the normal case first */
+ sc->value = f;
+ 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;
+ }
+ 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));
+
+ 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)));
+
+ if (for_each_arg_is_null(sc, cdr(args))) return(sc->unspecified);
+
+ /* if function is safe c func, do the for-each locally */
+ if (is_safe_c_function(f))
+ {
+ s7_function func;
+ s7_pointer iters;
+
+ 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);
+ }}
+ 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);
+ }}
+ 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));
+ }}
+
+ /* 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))))) ||
+ ((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)))))))
+ 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);
+ sc->z = sc->unused;
+ return(sc->unspecified);
+}
+
+static bool op_for_each(s7_scheme *sc)
+{
+ s7_pointer iterators = car(sc->args);
+ s7_pointer saved_args = cdr(sc->args);
+ for (s7_pointer x = saved_args, y = iterators; is_pair(x); x = cdr(x), y = cdr(y))
+ {
+ 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);
+ }}
+ push_stack_direct(sc, OP_FOR_EACH);
+ sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, saved_args) : saved_args;
+ return(false);
+}
+
+/* for-each et al remake the local let, but that's only needed if the local let is exported,
+ * and that can only happen through make-closure in various guises and curlet.
+ * owlet captures, but it would require a deliberate error to use it in this context.
+ * c_objects call object_set_let but that requires a prior curlet or sublet. So we have
+ * sc->capture_let_counter that is incremented every time an environment is captured, then
+ * here we save that ctr, call body, on rerun check ctr, if it has not changed we are safe and
+ * can reuse let. But that reuse assumes no new slots were added (by define etc), because
+ * update_let* only update the symbol_id's they expect, and that can happen even in op_for_each_2.
+ */
+
+static Inline bool inline_op_for_each_1(s7_scheme *sc) /* called once in eval, case fb gc iter */
+{
+ s7_pointer counter = sc->args, code;
+ s7_pointer p = counter_list(counter);
+ s7_pointer arg = s7_iterate(sc, p);
+ if (iterator_is_at_end(p))
+ {
+ sc->value = sc->unspecified;
+ /* free_cell(sc, counter); */ /* unsafe? */
+ return(true);
+ }
+ code = T_Clo(sc->code);
+ if (counter_capture(counter) != sc->capture_let_counter)
+ {
+ s7_pointer sym = car(closure_args(code));
+ set_curlet(sc, inline_make_let_with_slot(sc, closure_let(code), (is_symbol(sym)) ? sym : car(sym), arg));
+ counter_set_let(counter, sc->curlet);
+ counter_set_slots(counter, let_slots(sc->curlet));
+ counter_set_capture(counter, sc->capture_let_counter);
+ }
+ else
+ {
+ let_set_slots(counter_let(counter), counter_slots(counter)); /* this is needed (unless safe_closure but that costs more to check than this set) */
+ set_curlet(sc, update_let_with_slot(sc, counter_let(counter), arg));
+ }
+ push_stack(sc, OP_FOR_EACH_1, counter, code);
+ sc->code = T_Pair(closure_body(code));
+ return(false);
+}
+
+static Inline bool inline_op_for_each_2(s7_scheme *sc) /* called once in eval, lg set */
+{
+ s7_pointer c = sc->args;
+ s7_pointer lst = counter_list(c);
+ if (!is_pair(lst)) /* '(1 2 . 3) as arg? -- counter_list can be anything here */
+ {
+ sc->value = sc->unspecified;
+ /* free_cell(sc, c); */ /* unsafe? t101-aux-2|4|6|7|9|18|26|34|38 */ /* not sc->args = sc->nil; */
+ return(true);
+ }
+ counter_set_list(c, cdr(lst));
+ if (sc->cur_op == OP_FOR_EACH_3)
+ {
+ 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);
+ }
+ push_stack_direct(sc, OP_FOR_EACH_2);
+ }
+ else push_stack_direct(sc, OP_FOR_EACH_3);
+ if (counter_capture(c) != sc->capture_let_counter)
+ {
+ set_curlet(sc, inline_make_let_with_slot(sc, closure_let(sc->code), car(closure_args(sc->code)), car(lst)));
+ counter_set_let(c, sc->curlet);
+ counter_set_slots(c, let_slots(sc->curlet));
+ counter_set_capture(c, sc->capture_let_counter);
+ }
+ else
+ {
+ let_set_slots(counter_let(c), counter_slots(c));
+ set_curlet(sc, update_let_with_slot(sc, counter_let(c), car(lst)));
+ }
+ sc->code = car(closure_body(sc->code));
+ return(false);
+}
+
+
+/* ---------------------------------------- map ---------------------------------------- */
+
+static s7_pointer g_map_closure(s7_scheme *sc, s7_pointer f, s7_pointer seq) /* one sequence argument */
+{
+ s7_pointer body = closure_body(f);
+ sc->value = f;
+
+ if (!no_cell_opt(body))
+ {
+ s7_pfunc func = NULL;
+ s7_pointer old_e = sc->curlet, pars = closure_args(f), slot;
+ s7_pointer val = seq_init(sc, seq);
+ set_curlet(sc, inline_make_let_with_slot(sc, closure_let(f), (is_pair(car(pars))) ? caar(pars) : car(pars), val));
+ 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 (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);
+ }
+ set_no_cell_opt(body);
+ set_curlet(sc, old_e);
+ }
+ if (is_closure_star(f))
+ {
+ sc->z = make_iterators(sc, sc->map_symbol, set_plist_2(sc, sc->nil, seq));
+ push_stack(sc, OP_MAP, inline_make_counter(sc, sc->z), f);
+ sc->z = sc->unused;
+ return(sc->nil);
+ }
+ if ((is_null(cdr(body))) &&
+ (is_pair(seq)))
+ {
+ closure_set_map_list(f, seq);
+ push_stack(sc, OP_MAP_2, inline_make_counter(sc, seq), f);
+ return(sc->unspecified);
+ }
+ if (!is_iterator(seq))
+ {
+ if (!is_mappable(seq))
+ wrong_type_error_nr(sc, sc->map_symbol, 2, seq, a_sequence_string);
+ sc->z = s7_make_iterator(sc, seq);
+ }
+ else sc->z = seq;
+ push_stack(sc, OP_MAP_1, inline_make_counter(sc, sc->z), f);
+ sc->z = sc->unused;
+ return(sc->nil);
+}
+
+static s7_pointer g_map_closure_2(s7_scheme *sc, s7_pointer f, s7_pointer seq1, s7_pointer seq2) /* two sequences */
+{
+ s7_pointer body = closure_body(f);
+ if (!no_cell_opt(body))
+ {
+ s7_pfunc func = NULL;
+ s7_pointer old_e = sc->curlet, pars = closure_args(f), slot1, slot2;
+ 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));
+ 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 (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);
+ }
+ else /* not func */
+ {
+ 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);
+ 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);
+ sc->z = list_2(sc, sc->z, s7_make_iterator(sc, seq2));
+ }
+ else sc->z = list_2(sc, sc->z, seq2);
+
+ push_stack(sc, OP_MAP, inline_make_counter(sc, sc->z), f);
+ sc->z = sc->unused;
+ return(sc->unspecified);
+}
+
+static s7_pointer g_map(s7_scheme *sc, s7_pointer args)
+{
+ #define H_map "(map proc object . objects) applies proc to a list made up of the next element of each of its arguments, returning \
+a list of the results. Its arguments can be lists, vectors, strings, hash-tables, or any applicable objects."
+ #define Q_map s7_make_circular_signature(sc, 2, 3, sc->is_proper_list_symbol, sc->is_procedure_symbol, sc->is_sequence_symbol)
+
+ /* (apply f (map <safe f> ...)) e.g. f=append -> use safe_list for map output list here? also for (<safe-func> (map...))
+ * but less savings if mapped func would have used the same safe_list?
+ */
+ s7_pointer p, f = car(args);
+ s7_int len;
+ bool got_nil = false;
+
+ 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);
+ }
+
+ 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)));
+ 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)));
+ }}
+
+ 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);
+ }
+ 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);
+ }
+ break;
+
+ case T_C_OBJECT:
+ /* args if sc->args (plist + c_object) can be clobbered here by s7_is_aritable, so we need to protect it */
+ args = copy_proper_list(sc, args);
+ sc->temp10 = args;
+
+ default:
+ if (!is_applicable(f))
+ 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));
+ if (got_nil) return(sc->nil);
+ break;
+ }
+
+ sc->z = make_iterators(sc, sc->map_symbol, args);
+ push_stack(sc, OP_MAP, inline_make_counter(sc, sc->z), f);
+ sc->z = sc->unused;
+ return(sc->nil);
+}
+
+static bool op_map(s7_scheme *sc)
+{
+ s7_pointer iterators = counter_list(sc->args);
+ sc->x = sc->nil; /* can't use preset args list here (as in for-each): (map list '(a b c)) */
+ for (s7_pointer y = iterators; is_pair(y); y = cdr(y))
+ {
+ 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->x = cons(sc, x, sc->x);
+ }
+ sc->x = proper_list_reverse_in_place(sc, sc->x);
+ push_stack_direct(sc, OP_MAP_GATHER);
+ sc->args = sc->x;
+ sc->x = sc->unused;
+ if (needs_copied_args(sc->code))
+ sc->args = copy_proper_list(sc, sc->args);
+ return(false);
+}
+
+static bool op_map_1(s7_scheme *sc)
+{
+ s7_pointer args = sc->args, code = sc->code;
+ s7_pointer p = counter_list(args);
+ s7_pointer x = s7_iterate(sc, p);
+
+ if (iterator_is_at_end(p))
+ {
+ sc->value = proper_list_reverse_in_place(sc, counter_result(args));
+ free_cell(sc, sc->args); /* unsafe? */ /* not sc->args = sc->nil; */
+ return(true);
+ }
+ push_stack_direct(sc, OP_MAP_GATHER_1);
+ if (counter_capture(args) != sc->capture_let_counter)
+ {
+ set_curlet(sc, inline_make_let_with_slot(sc, closure_let(code), car(closure_args(code)), x));
+ counter_set_let(args, sc->curlet);
+ counter_set_slots(args, let_slots(sc->curlet));
+ counter_set_capture(args, sc->capture_let_counter);
+ }
+ else
+ {
+ /* the counter_slots field saves the original local let slot(s) representing the function
+ * argument. If the function has internal defines, they get added to the front of the
+ * slots list, but update_let_with_slot (maybe stupidly) assumes only the one original
+ * slot exists when it updates its symbol_id from the (possibly changed) let_id. So,
+ * a subsequent reference to the parameter name causes "unbound variable", or a segfault
+ * if the check has been optimized away. I think each function call should start with
+ * the original let slots, so counter_slots saves that pointer, and resets it here.
+ */
+ let_set_slots(counter_let(args), counter_slots(args));
+ set_curlet(sc, update_let_with_slot(sc, counter_let(args), x));
+ }
+ sc->code = T_Pair(closure_body(code));
+ return(false);
+}
+
+static bool op_map_2(s7_scheme *sc) /* possibly inline lg */
+{
+ s7_pointer x, c = sc->args, code = sc->code;
+ s7_pointer p = counter_list(c);
+ if (!is_pair(p))
+ {
+ sc->value = proper_list_reverse_in_place(sc, counter_result(c));
+ free_cell(sc, c); /* unsafe? */ /* not sc->args = sc->nil; */
+ return(true);
+ }
+ x = car(p);
+ counter_set_list(c, cdr(p));
+
+ if (sc->cur_op == OP_MAP_GATHER_3)
+ {
+ 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);
+ }
+ push_stack_direct(sc, OP_MAP_GATHER_2);
+ }
+ else push_stack_direct(sc, OP_MAP_GATHER_3);
+
+ if (counter_capture(c) != sc->capture_let_counter)
+ {
+ set_curlet(sc, inline_make_let_with_slot(sc, closure_let(code), car(closure_args(code)), x));
+ counter_set_let(c, sc->curlet);
+ counter_set_slots(c, let_slots(sc->curlet));
+ counter_set_capture(c, sc->capture_let_counter);
+ }
+ else
+ {
+ let_set_slots(counter_let(c), counter_slots(c)); /* needed -- see comment under for-each above */
+ set_curlet(sc, update_let_with_slot(sc, counter_let(c), x));
+ }
+ sc->code = car(closure_body(code));
+ return(false);
+}
+
+static s7_pointer revappend(s7_scheme *sc, s7_pointer a, s7_pointer b)
+{
+ /* (map (lambda (x) (if (odd? x) (apply values '(1 2 3)) (values))) (list 1 2 3 4)) is a bad case -- we have to copy the incoming list (in op_map_gather) */
+ s7_pointer p = b;
+ if (is_not_null(a))
+ {
+ a = copy_proper_list(sc, a);
+ do {
+ s7_pointer q = cdr(a);
+ set_cdr(a, p);
+ p = a;
+ a = q;
+ } while (is_pair(a));
+ }
+ return(p);
+}
+
+static Inline void inline_op_map_gather(s7_scheme *sc) /* called thrice in eval, cb lg map */
+{
+ 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)));
+ else counter_set_result(sc->args, cons(sc, sc->value, counter_result(sc->args)));
+ }
+}
+
+
+/* -------------------------------- multiple-values -------------------------------- */
+
+#define stack_top4_op(Sc) ((opcode_t)T_Op(Sc->stack_end[-5])) /* top4 == top - 4 */
+#define stack_top4_args(Sc) (Sc->stack_end[-6])
+/* #define stack_top4_let(Sc) (Sc->stack_end[-7]) */
+/* #define stack_top4_code(Sc) (Sc->stack_end[-8]) */
+
+static void apply_c_rst_no_req_function(s7_scheme *sc);
+
+static s7_pointer op_safe_c_p_mv(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer p;
+ bool use_safe = false;
+ sc->value = args;
+ pop_stack_no_op(sc);
+ p = cddr(sc->value);
+ if (is_null(p))
+ sc->args = set_plist_2(sc, car(sc->value), cadr(sc->value));
+ else
+ if (is_null(cdr(p)))
+ 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));
+ }
+ 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);
+ else apply_c_rst_no_req_function(sc);
+ if (use_safe) clear_list_in_use(sc->args);
+ return(sc->value);
+}
+
+static s7_pointer op_safe_c_pc_mv(s7_scheme *sc, s7_pointer args)
+{
+ /* sc->value = mv vals from e.g. safe_c_pc_1 below, fn_proc = splice_in_values via values chooser synonym sc->values_uncopied */
+ /* sc->args is the trailing constant arg (the "c" in "pc") */
+ s7_pointer p;
+ bool use_safe = false;
+ sc->value = args;
+ pop_stack_no_op(sc);
+ p = cddr(sc->value);
+ if (is_null(p))
+ sc->args = set_plist_3(sc, car(sc->value), cadr(sc->value), sc->args);
+ else
+ {
+ if (is_null(cdr(p)))
+ 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);
+ }}
+ 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);
+ else apply_c_rst_no_req_function(sc);
+ if (use_safe) clear_list_in_use(sc->args);
+ return(sc->value);
+}
+
+static s7_pointer op_safe_c_ps_mv(s7_scheme *sc, s7_pointer args) /* (define (hi a) (+ (values 1 2) a)) from safe_c_ps_1 */
+{
+ /* old form: sc->args = pair_append(sc, sc->value, list_1(sc, lookup(sc, caddr(sc->code)))); */ /* don't assume sc->value can be used as sc->args here! */
+ s7_pointer p, val;
+ bool use_safe = false;
+ sc->value = args;
+ pop_stack_no_op(sc);
+ p = cddr(sc->value);
+ val = lookup(sc, caddr(sc->code));
+ if (is_null(p))
+ sc->args = set_plist_3(sc, car(sc->value), cadr(sc->value), val);
+ else
+ {
+ if (is_null(cdr(p)))
+ 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);
+ }}
+ 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);
+ else apply_c_rst_no_req_function(sc);
+ if (use_safe) clear_list_in_use(sc->args);
+ return(sc->value);
+}
+
+static s7_pointer op_safe_c_pa_mv(s7_scheme *sc, s7_pointer args)
+{ /* (let () (define (func) (do ((x 0.0 (+ x 0.1)) (i 0 (+ i 1))) ((>= x 0.1) (#_with-baffle (inlet (values 1 2) (symbol? x)))))) (func)) */
+ s7_pointer p;
+ bool use_safe = false;
+ sc->value = args;
+ pop_stack_no_op(sc);
+ p = cddr(sc->value);
+ if (is_null(p))
+ {
+ s7_pointer val1 = car(sc->value), val2 = cadr(sc->value);
+ s7_pointer val3 = fx_call(sc, cddr(sc->code)); /* is plist3 ever clobbered by fx_call? plist_1|2 are set */
+ sc->args = set_plist_3(sc, val1, val2, val3);
+ }
+ 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);
+ }
+ 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)));
+ }}
+ 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);
+ else apply_c_rst_no_req_function(sc);
+ if (use_safe) clear_list_in_use(sc->args);
+ return(sc->value);
+}
+
+static s7_pointer op_safe_c_sp_mv(s7_scheme *sc, s7_pointer args)
+{ /* (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (values 3 4))) (hi)) safe_add_sp_1 */
+ s7_pointer p;
+ sc->value = args;
+ clear_multiple_value(args); /* see op_safe_c_sp_mv in s7test */
+ pop_stack_no_op(sc);
+ p = cddr(sc->value);
+ if (is_null(p))
+ sc->args = set_plist_3(sc, sc->args, car(sc->value), cadr(sc->value));
+ else
+ if (is_null(cdr(p)))
+ sc->args = set_plist_4(sc, sc->args, car(sc->value), cadr(sc->value), car(p));
+ else sc->args = cons(sc, sc->args, sc->value); /* not ulist */
+ 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);
+ else apply_c_rst_no_req_function(sc);
+ return(sc->value);
+}
+
+static s7_pointer op_safe_c_ssp_mv(s7_scheme *sc, s7_pointer args) /*sc->code: (+ pi pi (values 1 2)) sc->value: '(1 2) */
+{
+ sc->value = args;
+ pop_stack_no_op(sc);
+ if (is_null(cddr(sc->value)))
+ sc->args = set_plist_4(sc, lookup(sc, cadr(sc->code)), lookup(sc, caddr(sc->code)), car(sc->value), cadr(sc->value));
+ else sc->args = cons_unchecked(sc, lookup(sc, cadr(sc->code)), cons(sc, lookup(sc, caddr(sc->code)), sc->value)); /* not ulist here */
+ 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);
+ else apply_c_rst_no_req_function(sc);
+ return(sc->value);
+}
+
+static s7_pointer op_safe_c_3p_mv(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer res;
+ sc->temp8 = copy_proper_list(sc, args);
+ res = cons(sc, sc->unused, sc->temp8);
+ sc->temp8 = sc->unused;
+ return(res);
+}
+
+static s7_pointer op_c_p_mv(s7_scheme *sc, s7_pointer args) /* (values (values 1 2)) or (apply (values + '(2))) */
+{
+ sc->value = args;
+ pop_stack_no_op(sc);
+ sc->code = c_function_base(opt1_cfunc(sc->code));
+ sc->args = copy_proper_list(sc, sc->value);
+ if (type(sc->code) == T_C_FUNCTION)
+ sc->value = apply_c_function_unopt(sc, sc->code, sc->args);
+ else apply_c_rst_no_req_function(sc);
+ return(sc->value);
+}
+
+static s7_pointer op_c_ap_mv(s7_scheme *sc, s7_pointer args) /* (values 2 (values 3 4)) or (apply + (values 5 '(1 2))) */
+{
+ sc->value = args;
+ pop_stack_no_op(sc);
+ clear_multiple_value(sc->value); /* sc->value not copied? */
+ sc->args = cons(sc, sc->args, sc->value);
+ 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);
+ else apply_c_rst_no_req_function(sc);
+ return(sc->value);
+}
+
+static s7_pointer op_safe_c_pp_6_mv(s7_scheme *sc, s7_pointer args) /* both args mv */
+{
+ s7_pointer p;
+ sc->value = args;
+ pop_stack_no_op(sc);
+ for (p = cdr(sc->args); is_pair(cdr(p)); p = cdr(p)); /* we used to copy here: sc->args = pair_append(sc, sc->args, sc->value); */
+ set_cdr(p, sc->value);
+ /* fn_proc(sc->code) here is g_add_2, but we have any number of args from a values call
+ * the original (unoptimized) function is c_function_base(opt1_cfunc(sc->code))
+ * (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) -> 10
+ */
+ 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);
+ else apply_c_rst_no_req_function(sc);
+ return(sc->value);
+}
+
+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)));
+ 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 */
+ {
+ /* the normal case -- splice values into caller's args */
+ case OP_EVAL_ARGS1: case OP_EVAL_ARGS2: case OP_EVAL_ARGS3: case OP_EVAL_ARGS4:
+ /* code = args yet to eval in order, args = evalled args reversed.
+ * it is not safe to simply reverse args and tack the current stacked args onto its (new) end,
+ * setting stacked args to cdr of reversed-args and returning car because the list (args)
+ * can be some variable's value in a macro expansion via ,@ and reversing it in place
+ * (all this to avoid consing), clobbers the variable's value.
+ * (let ((g-1 (lambda (x a b c) (x (+ a 1) (- b 1) (values c 2))))) (g-1 (lambda (b c d e) (+ b c d e)) 2 3 5)) eval_args2
+ */
+ 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)));
+ sc->w = sc->unused;
+ return(car(x));
+
+ case OP_EVAL_ARGS5:
+ /* (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);
+ if (is_null(cdr(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_code(sc, car(x));
+ return(cadr(x));
+
+ /* handle implicit set! */
+ case OP_EVAL_SET1_NO_MV: /* (set! (fnc) <val>) where evaluation of <val> returned multiple values */
+ case OP_EVAL_SET2_NO_MV: /* (set! (fnc <ind...>) <val>), <val> = mv */
+ case OP_EVAL_SET3_NO_MV: /* (define f (dilambda (lambda () 1) (lambda (x) x))) (define (f2) (values 1 2 3)) (set! (f) (f2)) */
+ syntax_error_nr(sc, "too many arguments to set!: ~S", 30, set_ulist_1(sc, sc->values_symbol, args));
+ case OP_EVAL_SET2: /* here <ind> = args is mv */
+ set_stack_top_op(sc, OP_EVAL_SET2_MV);
+ return(args); /* ?? */
+ case OP_EVAL_SET3: /* here <ind> = args is mv */
+ set_stack_top_op(sc, OP_EVAL_SET3_MV);
+ return(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)));
+
+ case OP_ANY_C_NP_2:
+ set_stack_top_op(sc, OP_ANY_C_NP_MV);
+ goto FP_MV;
+
+ case OP_ANY_C_NP_1: /* ((eval-string (object->string mac5 :readable)) 1 5 3 4) */
+ set_stack_top_op(sc, OP_ANY_C_NP_MV); /* ?? */
+ 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);
+ }
+ set_multiple_value(args);
+ return(args);
+
+ /* in the next set, the main evaluator branches blithely assume no multiple-values, and if it happens anyway, we go to a different branch here */
+ case OP_SAFE_C_SP_1: case OP_SAFE_CONS_SP_1: case OP_SAFE_ADD_SP_1: case OP_SAFE_MULTIPLY_SP_1:
+ /* (let () (define (ho a) (+ a 2)) (define (hi) (+ (ho 1) (values 3 4))) (hi)) from safe_c_pp->h_c_aa? */
+ return(op_safe_c_sp_mv(sc, args));
+
+ case OP_SAFE_C_PS_1: return(op_safe_c_ps_mv(sc, args)); /* (define (f) (let ((d #\d)) (string (values #\a #\b #\c) d))) (f) */
+ case OP_SAFE_C_PC_1: return(op_safe_c_pc_mv(sc, args)); /* (define (f) (string (values #\a #\b #\c) #\d)) (f) */
+ case OP_SAFE_C_PA_1: return(op_safe_c_pa_mv(sc, args));
+ case OP_SAFE_C_SSP_1: return(op_safe_c_ssp_mv(sc, args));
+ case OP_SAFE_C_P_1: return(op_safe_c_p_mv(sc, args)); /* (string (values #\a #\b #\c)) */
+ case OP_C_P_1: return(op_c_p_mv(sc, args)); /* (let () (define (ho a) (values a 1)) (define (hi) (- (ho 2))) (hi)) */
+ case OP_C_AP_1: return(op_c_ap_mv(sc, args));
+ case OP_SAFE_C_PP_5: return(op_safe_c_pp_6_mv(sc, args)); /* (let () (define (hi) (+ (values 1 2) (values 3 4))) (hi)) (also safe_c_pp_1) */
+
+ case OP_SAFE_C_PP_1: /* (define (f) (list (values 1 2) (values 3 4))) (f): args='(1 2), top_args=#<unused> */
+ set_stack_top_op(sc, OP_SAFE_C_PP_3_MV);
+ return(args);
+
+ case OP_SAFE_C_3P_1: case OP_SAFE_C_3P_2: case OP_SAFE_C_3P_3: /* (let ((g-1 (lambda (x a b c) (x (+ a 1) (- b 1) (values c 2))))) (g-1 + 2 3 5)) */
+ set_stack_top_op(sc, stack_top_op(sc) + 3); /* change op to parallel mv case */
+ case OP_SAFE_C_3P_1_MV: case OP_SAFE_C_3P_2_MV: case OP_SAFE_C_3P_3_MV: /* (list-values '+ 1 (apply-values (list 2 3))) */
+ return(op_safe_c_3p_mv(sc, args));
+
+ case OP_SAFE_CLOSURE_P_1: case OP_CLOSURE_P_1: case OP_SAFE_CLOSURE_P_A_1:
+ case OP_SAFE_CLOSURE_AP_1: case OP_CLOSURE_AP_1:
+ case OP_SAFE_CLOSURE_PP_1: case OP_CLOSURE_PP_1:
+ case OP_SAFE_CLOSURE_PA_1: case OP_CLOSURE_PA_1: /* arity is 2, we have 2 args, this has to be an error (see optimize_closure_sym) */
+ case OP_ANY_CLOSURE_3P_1: case OP_ANY_CLOSURE_3P_2: case OP_ANY_CLOSURE_3P_3:
+ case OP_ANY_CLOSURE_4P_1: case OP_ANY_CLOSURE_4P_2: case OP_ANY_CLOSURE_4P_3: case OP_ANY_CLOSURE_4P_4:
+ /* (let () (define (func) (do ((x 0.0 (+ x 0.1)) (i 0 (+ i 1))) ((>= x 0.1) (#_with-baffle (inlet (values 1 2) (symbol? x)))))) (func)) */
+ if (is_multiple_value(sc->value)) clear_multiple_value(sc->value);
+ error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, stack_top_code(sc), sc->value));
+
+ /* look for errors here rather than glomming up the set! and let code */
+ case OP_SET_SAFE: /* symbol is sc->code after pop */
+ case OP_SET1:
+ 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));
+
+ 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...)
+ * (define (a3 x) x)
+ * (set! (setter a3) (lambda (x y z) (list x y z)))
+ * <11> (set! (a3 1) 2)
+ * error: <10>: not enough arguments: ((lambda (x y z) ...) 1 2)
+ * <12> (set! (a3 1) 2 3)
+ * error: (set! (a3 1) 2 3): too many arguments to set!
+ * <13> (set! (a3 1) (values 2 3))
+ * (set! (a3 1) (values 2 3)): too many arguments to set!
+ * but (set! (a3 1 2) 3) is ok, also (set! (a3 (values 1 2)) 3)
+ */
+ syntax_error_nr(sc, "too many arguments to set! ~S", 29, set_ulist_1(sc, sc->values_symbol, 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)
+ */
+ }
+
+ 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));
+
+ 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));
+
+ 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));
+
+ 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));
+
+ 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));
+
+ 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);
+ 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));
+ 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) */
+ case OP_IF_PP: case OP_IF_PPP: case OP_IF_PR: case OP_IF_PRR:
+ case OP_WHEN_PP: case OP_UNLESS_PP: case OP_WITH_LET1:
+ case OP_CASE_G_G: case OP_CASE_G_S: case OP_CASE_E_G: case OP_CASE_E_S: case OP_CASE_I_S:
+ case OP_COND1: case OP_COND1_SIMPLE:
+ /* (if (values 1 2) 3) */
+ return(car(args));
+
+ case OP_IF_PN: /* (if|when (not (values...)) ...) as opposed to (if|unless (values...)...) which follows CL and drops trailing values */
+ /* doesn't this error check happen elsewhere? */
+ syntax_error_nr(sc, "too many arguments to not: ~S", 29, set_ulist_1(sc, sc->values_symbol, 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));
+ }
+
+ case OP_DEACTIVATE_GOTO: /* (+ (call-with-exit (lambda (ret) (values 1 2 3)))) */
+ call_exit_active(stack_top_args(sc)) = false; /* stack_top_args(sc) is the goto */
+ /* fall through */
+ case OP_CATCH: case OP_CATCH_1: case OP_CATCH_2: case OP_CATCH_ALL: /* (+ (catch #t (lambda () (values 3 4)) (lambda args args))) */
+ case OP_BARRIER:
+ pop_stack_no_op(sc);
+ return(splice_in_values(sc, args));
+
+ case OP_GC_PROTECT:
+ sc->stack_end -= 4;
+ return(splice_in_values(sc, args));
+
+ case OP_BEGIN_HOOK: case OP_BEGIN_NO_HOOK: case OP_BEGIN_2_UNCHECKED:
+ case OP_SIMPLE_DO_STEP: case OP_DOX_STEP_O: case OP_DOX_STEP:
+ /* here we have a values call with nothing to splice into. So flush it...
+ * otherwise the multiple-values bit gets set in some innocent list and never unset:
+ * (let ((x '((1 2)))) (eval `(apply apply values x)) x) -> ((values 1 2))
+ * other cases: (+ 1 (begin (values 5 6) (values 2 3)) 4) -> 10 -- the (5 6) is dropped
+ * (let () (values 1 2 3) 4) but (+ (let () (values 1 2))) -> 3
+ */
+ return(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
+ * (+ (((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)
+ */
+ }
+
+ case OP_EXPANSION:
+ /* we get here if a reader-macro (define-expansion) returns multiple values.
+ * these need to be read in order into the current reader lists (we'll assume OP_READ_LIST is next in the stack.
+ * and that it will be expecting the next arg entry in sc->value; but it could be OP_LOAD_RETURN_IF_EOF if the expansion is at top level).
+ * (+ (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));
+ 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);
+ }
+ for (x = args; is_not_null(cdr(x)); x = cdr(x))
+ 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)));
+ 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);
+ return(args);
+
+ default:
+ /* (let () (define (f1) (do ((i 0 (+ i 1))) ((= i 1)) (values (append "" (block)) 1))) (f1)) safe_dotimes_step_o */
+ /* ((values memq (values #\a '(#\A 97 #\a)))) eval_args */
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: splice punts: %s\n", __func__, __LINE__, op_names[stack_top_op(sc)]);
+ break;
+ }
+
+ /* let it meander back up the call chain until someone knows where to splice it
+ * the is_immutable check protects against setting the multiple value bit on (say) sc->hash_table_signature
+ */
+ if (is_immutable(args))
+ args = copy_proper_list(sc, args); /* copy needed else (apply values x) where x is a list can leave the mv bit on for x's value */
+ if (needs_copied_args(args))
+ {
+ clear_needs_copied_args(args);
+ args = copy_proper_list(sc, args);
+ }
+ set_multiple_value(args);
+ return(args);
+}
+
+
+/* -------------------------------- values -------------------------------- */
+s7_pointer s7_values(s7_scheme *sc, s7_pointer args)
+{
+ #define H_values "(values obj ...) splices its arguments into whatever list holds it (its 'continuation')"
+ #define Q_values s7_make_circular_signature(sc, 1, 2, sc->values_symbol, sc->T)
+
+ if (is_null(args)) /* ((lambda () (let ((x 1)) (set! x (boolean? (values)))))) */
+ return(sc->no_value);
+ if (is_null(cdr(args)))
+ return(car(args));
+ set_needs_copied_args(args);
+ /* copy needed: see s7test (test `(,x ,@y ,x) '(3 a b c 3)) -> (append (list-values x (#_apply-values y)) x), and #_apply_values calls s7_values directly */
+ return(splice_in_values(sc, args));
+}
+
+#define g_values s7_values
+
+static s7_pointer values_p(s7_scheme *sc) {return(sc->no_value);}
+static s7_pointer values_p_p(s7_scheme *unused_sc, s7_pointer p) {return(p);}
+
+static s7_pointer values_chooser(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer unused_expr)
+{
+ if (args > 1) return(sc->values_uncopied); /* splice_in_values */
+ return(f);
+}
+
+bool s7_is_multiple_value(s7_pointer obj) {return(is_multiple_value(obj));}
+
+
+/* -------------------------------- list-values -------------------------------- */
+static s7_pointer splice_out_values(s7_scheme *sc, s7_pointer args)
+{ /* (list-values ... (values) ... ) removes the (values) */
+ s7_pointer tp;
+ while (car(args) == sc->no_value) {args = cdr(args); if (is_null(args)) return(sc->nil);}
+ tp = list_1(sc, car(args));
+ if (is_null(cdr(args))) return(tp);
+ sc->temp8 = tp;
+ 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);
+ }
+ sc->temp8 = sc->unused;
+ return(tp);
+}
+
+static s7_pointer g_list_values(s7_scheme *sc, s7_pointer args)
+{
+ #define H_list_values "(list-values ...) returns its arguments in a list (internal to quasiquote)"
+ #define Q_list_values s7_make_circular_signature(sc, 1, 2, sc->is_list_symbol, sc->T)
+
+ /* list-values can't be replaced by list(-n) because (list-values (values)) -> () and anything can be #<no-values> (see s7test) */
+ /* but (list-values <circular-list>) will complain or get into an infinite recursion in copy_tree, so it should not use copy_tree */
+
+ s7_pointer x;
+ bool checked = false;
+ for (x = args; is_pair(x); x = cdr(x))
+ if (is_pair(car(x)))
+ {
+ if (is_checked(car(x)))
+ checked = true;
+ }
+ else
+ if (car(x) == sc->no_value) /* unchecked_car|cdr unrolled here is not faster */
+ 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);
+ }
+ 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));
+ }
+ else args = copy_tree(sc, args); /* not copy_any_list here -- see comment below */
+ sc->temp5 = sc->unused;
+ return(args);
+ }
+ /* if a macro expands into a recursive function with a macro argument as its body (or reasonable facsimile thereof),
+ * and the safety (as in safe_closure) of the body changes from safe to unsafe, then (due to the checked bits
+ * protecting against cycles in optimize_expression|syntax), the possible safe_closure call will not be fixed,
+ * the safe_closure's assumption about the saved local let will be violated, and we'll get "<arg> unbound" (see tgen.scm).
+ * clear_all_optimizations assumes its argument has no cycles, and automatically calling copy_tree slows
+ * everything down intolerably, so if the checked bit is on in a macro expansion, that means we're re-expanding this macro,
+ * and therefore have to copy the tree. But isn't that only the case if the macro expands into closures?
+ */
+ return(splice_out_values(sc, args));
+}
+
+static s7_pointer g_simple_list_values(s7_scheme *sc, s7_pointer args)
+{
+ /* if just (code-)constant/symbol, symbol->pair won't be checked (not optimized/re-expanded code), but might be no-values */
+ for (s7_pointer p = args; is_pair(p); p = cdr(p))
+ if (car(p) == sc->no_value)
+ return(splice_out_values(sc, args));
+ if (is_immutable(args))
+ return(copy_proper_list(sc, args));
+ return(args);
+}
+
+static s7_pointer list_values_chooser(s7_scheme *sc, s7_pointer f, int32_t unused_args, s7_pointer expr)
+{
+ for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p))
+ if (is_unquoted_pair(car(p)))
+ return(f);
+ return(sc->simple_list_values);
+}
+
+
+/* -------------------------------- apply-values -------------------------------- */
+static s7_pointer g_apply_values(s7_scheme *sc, s7_pointer args)
+{
+ #define H_apply_values "(apply-values var) applies values to var. This is an internal function."
+ #define Q_apply_values s7_make_signature(sc, 2, sc->T, sc->is_list_symbol)
+ s7_pointer x; /* apply-values takes 1 arg: ,@a -> (apply-values a) */
+ if (is_null(args)) return(sc->no_value);
+ x = car(args);
+ if (is_null(x)) return(sc->no_value);
+ if (!s7_is_proper_list(sc, x)) apply_list_error_nr(sc, x);
+ if (is_null(cdr(x))) return(car(x)); /* needs to follow previous because it might not be a pair: (apply-values 2) */
+ set_needs_copied_args(x);
+ return(splice_in_values(sc, x));
+ /* return(s7_values(sc, x)); *//* g_values == s7_values */
+}
+
+/* (apply values ...) replaces (unquote_splicing ...)
+ * (define-macro (hi a) `(+ 1 ,a) == (list '+ 1 a)
+ * (define-macro (hi a) `(+ 1 ,@a) == (list '+ 1 (apply values a))
+ * this is not the same as CL's quasiquote; for example:
+ * [1]> (let ((a 1) (b 2)) `(,a ,@b)) -> '(1 . 2) but in s7 this is an error.
+ * also in CL the target of ,@ can apparently be a circular list
+ */
+
+
+/* -------------------------------- quasiquote -------------------------------- */
+static bool is_simple_code(s7_scheme *sc, s7_pointer form)
+{
+ /* if nested with quasiquotes say 20 levels, this is really slow, but to tag intermediate results burns up 2 type bits */
+ s7_pointer tmp, slow;
+ 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);
+ }
+ else
+ 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);
+ }
+ else
+ if (car(tmp) == sc->unquote_symbol)
+ return(false);
+ }
+ return(is_null(tmp));
+}
+
+/* since the reader expands unquote et al, and the printer does not unexpand them, the standard scheme quine in s7 is:
+ * ((lambda (x) (list-values x (list-values 'quote x))) '(lambda (x) (list-values x (list-values 'quote x))))
+ * but that depends on the "p" in repl...
+ */
+
+static s7_pointer g_quasiquote_1(s7_scheme *sc, s7_pointer form, bool check_cycles)
+{
+ #define H_quasiquote "(quasiquote arg) is the same as `arg. If arg is a list, it can contain \
+comma (\"unquote\") and comma-atsign (\"apply values\") to pre-evaluate portions of the list. \
+unquoted expressions are evaluated and plugged into the list, apply-values evaluates the expression \
+and splices the resultant list into the outer list. `(1 ,(+ 1 1) ,@(list 3 4)) -> (1 2 3 4)."
+
+ if (!is_pair(form))
+ {
+ if (is_normal_symbol(form))
+ return(list_2(sc, sc->quote_function, form));
+ /* things that evaluate to themselves don't need to be quoted */
+ return(form);
+ }
+ 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_not_null(cddr(form)))
+ syntax_error_nr(sc, "unquote: too many arguments, ~S", 31, form);
+ return(cadr(form));
+ }
+
+ /* it's a list, so return the list with each element handled as above.
+ * we try to support dotted lists which makes the code much messier.
+ * if no element of the list is a list or unquote, just return the original quoted
+ */
+ if (((check_cycles) && (tree_is_cyclic(sc, form))) ||
+ (is_simple_code(sc, form)))
+ return(list_2(sc, sc->quote_function, form));
+
+ {
+ s7_int i;
+ s7_pointer orig, bq, old_scw = sc->w; /* very often, sc->w is in use here */
+ bool dotted = false;
+ s7_int len = s7_list_length(sc, form);
+ if (len < 0)
+ {
+ len = -len;
+ dotted = true;
+ }
+ gc_protect_via_stack(sc, sc->w);
+
+ check_free_heap_size(sc, len + 1);
+ sc->w = sc->nil;
+ for (i = 0; i <= len; i++)
+ sc->w = cons_unchecked(sc, sc->nil, sc->w);
+
+ 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));
+ }
+ 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 */
+ }
+ bq = sc->w;
+ sc->w = old_scw;
+ unstack_gc_protect(sc);
+ return(bq);
+ }
+}
+
+static s7_pointer g_quasiquote(s7_scheme *sc, s7_pointer args) /* this is for explicit quasiquote support, not the backquote stuff in macros */
+{
+ return(g_quasiquote_1(sc, car(args), true));
+}
+
+static s7_pointer g_qq_append(s7_scheme *sc, s7_pointer args)
+{
+ #define H_qq_append "<list*>: CL list* (I think) for quasiquote's internal use"
+ #define Q_qq_append s7_make_signature(sc, 3, sc->is_list_symbol, sc->is_list_symbol, sc->T)
+ s7_pointer a = T_Lst(car(args)), b = cadr(args);
+ s7_pointer p, tp, np;
+ if (is_null(a)) return(b);
+ p = cdr(a);
+ if (is_null(p)) return(cons(sc, car(a), b));
+ tp = list_1(sc, car(a));
+ gc_protect_via_stack(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, b);
+ unstack_gc_protect(sc);
+ return(tp);
+}
+
+
+/* -------------------------------- 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)
+{
+ s7_pointer uf = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, NULL);
+ s7_function_set_class(sc, uf, cls);
+ c_function_signature(uf) = c_function_signature(cls);
+ return(uf);
+}
+
+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)
+{
+ 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);
+ c_function_signature(uf) = c_function_signature(cls);
+ return(uf);
+}
+
+static s7_pointer set_function_chooser(s7_pointer sym, s7_pointer (*chooser)(s7_scheme *sc, s7_pointer f, int32_t args, s7_pointer expr))
+{
+ s7_pointer f = global_value(sym);
+ c_function_chooser(f) = chooser;
+ return(f);
+}
+
+static void init_choosers(s7_scheme *sc)
+{
+ s7_pointer f;
+
+ /* + */
+ f = set_function_chooser(sc->add_symbol, add_chooser);
+ sc->add_class = c_function_class(f);
+ sc->add_2 = make_function_with_class(sc, f, "+", g_add_2, 2, 0, false);
+ sc->add_3 = make_function_with_class(sc, f, "+", g_add_3, 3, 0, false);
+ sc->add_1x = make_function_with_class(sc, f, "+", g_add_1x, 2, 0, false);
+ sc->add_x1 = make_function_with_class(sc, f, "+", g_add_x1, 2, 0, false);
+ sc->add_i_random = make_function_with_class(sc, f, "+", g_add_i_random, 2, 0, false);
+ sc->add_2_ff = make_function_with_class(sc, f, "+", g_add_2_ff, 2, 0, false);
+ sc->add_2_ii = make_function_with_class(sc, f, "+", g_add_2_ii, 2, 0, false);
+ sc->add_2_if = make_function_with_class(sc, f, "+", g_add_2_if, 2, 0, false);
+ sc->add_2_fi = make_function_with_class(sc, f, "+", g_add_2_fi, 2, 0, false);
+ sc->add_2_xi = make_function_with_class(sc, f, "+", g_add_2_xi, 2, 0, false);
+ sc->add_2_ix = make_function_with_class(sc, f, "+", g_add_2_ix, 2, 0, false);
+ sc->add_2_fx = make_function_with_class(sc, f, "+", g_add_2_fx, 2, 0, false);
+ sc->add_2_xf = make_function_with_class(sc, f, "+", g_add_2_xf, 2, 0, false);
+
+ /* - */
+ f = set_function_chooser(sc->subtract_symbol, subtract_chooser);
+ sc->subtract_class = c_function_class(f);
+ sc->subtract_1 = make_function_with_class(sc, f, "-", g_subtract_1, 1, 0, false);
+ sc->subtract_2 = make_function_with_class(sc, f, "-", g_subtract_2, 2, 0, false);
+ sc->subtract_3 = make_function_with_class(sc, f, "-", g_subtract_3, 3, 0, false);
+ sc->subtract_x1 = make_function_with_class(sc, f, "-", g_subtract_x1, 2, 0, false);
+ sc->subtract_2f = make_function_with_class(sc, f, "-", g_subtract_2f, 2, 0, false);
+ sc->subtract_f2 = make_function_with_class(sc, f, "-", g_subtract_f2, 2, 0, false);
+
+ /* * */
+ f = set_function_chooser(sc->multiply_symbol, multiply_chooser);
+ sc->multiply_class = c_function_class(f);
+ sc->multiply_2 = make_function_with_class(sc, f, "*", g_multiply_2, 2, 0, false);
+ sc->mul_2_ff = make_function_with_class(sc, f, "*", g_mul_2_ff, 2, 0, false);
+ sc->mul_2_ii = make_function_with_class(sc, f, "*", g_mul_2_ii, 2, 0, false);
+ sc->mul_2_if = make_function_with_class(sc, f, "*", g_mul_2_if, 2, 0, false);
+ sc->mul_2_fi = make_function_with_class(sc, f, "*", g_mul_2_fi, 2, 0, false);
+ sc->mul_2_xi = make_function_with_class(sc, f, "*", g_mul_2_xi, 2, 0, false);
+ sc->mul_2_ix = make_function_with_class(sc, f, "*", g_mul_2_ix, 2, 0, false);
+ sc->mul_2_fx = make_function_with_class(sc, f, "*", g_mul_2_fx, 2, 0, false);
+ sc->mul_2_xf = make_function_with_class(sc, f, "*", g_mul_2_xf, 2, 0, false);
+
+ /* / */
+ f = set_function_chooser(sc->divide_symbol, divide_chooser);
+ sc->invert_1 = make_function_with_class(sc, f, "/", g_invert_1, 1, 0, false);
+ sc->divide_2 = make_function_with_class(sc, f, "/", g_divide_2, 2, 0, false);
+ sc->invert_x = make_function_with_class(sc, f, "/", g_invert_x, 2, 0, false);
+ sc->divide_by_2 = make_function_with_class(sc, f, "/", g_divide_by_2, 2, 0, false);
+
+ /* = */
+ f = set_function_chooser(sc->num_eq_symbol, num_eq_chooser);
+ sc->num_eq_class = c_function_class(f);
+ sc->num_eq_2 = make_function_with_class(sc, f, "=", g_num_eq_2, 2, 0, false);
+ sc->num_eq_xi = make_function_with_class(sc, f, "=", g_num_eq_xi, 2, 0, false);
+ sc->num_eq_ix = make_function_with_class(sc, f, "=", g_num_eq_ix, 2, 0, false);
+
+ /* min */
+ f = set_function_chooser(sc->min_symbol, min_chooser);
+ sc->min_2 = make_function_with_class(sc, f, "min", g_min_2, 2, 0, false);
+ sc->min_3 = make_function_with_class(sc, f, "min", g_min_3, 3, 0, false);
+
+ /* max */
+ f = set_function_chooser(sc->max_symbol, max_chooser);
+ sc->max_2 = make_function_with_class(sc, f, "max", g_max_2, 2, 0, false);
+ sc->max_3 = make_function_with_class(sc, f, "max", g_max_3, 3, 0, false);
+
+ /* < */
+ f = set_function_chooser(sc->lt_symbol, less_chooser);
+ sc->less_xi = make_function_with_class(sc, f, "<", g_less_xi, 2, 0, false);
+ sc->less_x0 = make_function_with_class(sc, f, "<", g_less_x0, 2, 0, false);
+ sc->less_xf = make_function_with_class(sc, f, "<", g_less_xf, 2, 0, false);
+ sc->less_2 = make_function_with_class(sc, f, "<", g_less_2, 2, 0, false);
+
+ /* > */
+ f = set_function_chooser(sc->gt_symbol, greater_chooser);
+ sc->greater_xi = make_function_with_class(sc, f, ">", g_greater_xi, 2, 0, false);
+ sc->greater_xf = make_function_with_class(sc, f, ">", g_greater_xf, 2, 0, false);
+ sc->greater_2 = make_function_with_class(sc, f, ">", g_greater_2, 2, 0, false);
+
+ /* <= */
+ f = set_function_chooser(sc->leq_symbol, leq_chooser);
+ sc->leq_xi = make_function_with_class(sc, f, "<=", g_leq_xi, 2, 0, false);
+ sc->leq_2 = make_function_with_class(sc, f, "<=", g_leq_2, 2, 0, false);
+ sc->leq_ixx = make_function_with_class(sc, f, "<=", g_leq_ixx, 3, 0, false);
+
+ /* >= */
+ f = set_function_chooser(sc->geq_symbol, geq_chooser);
+ sc->geq_xi = make_function_with_class(sc, f, ">=", g_geq_xi, 2, 0, false);
+ sc->geq_xf = make_function_with_class(sc, f, ">=", g_geq_xf, 2, 0, false);
+ sc->geq_2 = make_function_with_class(sc, f, ">=", g_geq_2, 2, 0, false);
+
+ /* log */
+ f = set_function_chooser(sc->log_symbol, log_chooser);
+ sc->int_log2 = make_function_with_class(sc, f, "log", g_int_log2, 2, 0, false);
+
+ /* random */
+ f = set_function_chooser(sc->random_symbol, random_chooser);
+ sc->random_1 = make_function_with_class(sc, f, "random", g_random_1, 1, 0, false);
+ sc->random_i = make_function_with_class(sc, f, "random", g_random_i, 1, 0, false);
+ sc->random_f = make_function_with_class(sc, f, "random", g_random_f, 1, 0, false);
+
+ /* defined? */
+ f = set_function_chooser(sc->is_defined_symbol, is_defined_chooser);
+ sc->is_defined_in_rootlet = make_function_with_class(sc, f, "defined?", g_is_defined_in_rootlet, 2, 0, false);
+
+ /* char=? */
+ f = set_function_chooser(sc->char_eq_symbol, char_equal_chooser);
+ sc->simple_char_eq = make_function_with_class(sc, f, "char=?", g_simple_char_eq, 2, 0, false);
+ sc->char_equal_2 = make_function_with_class(sc, f, "char=?", g_char_equal_2, 2, 0, false);
+
+ /* char>? */
+ f = set_function_chooser(sc->char_gt_symbol, char_greater_chooser);
+ sc->char_greater_2 = make_function_with_class(sc, f, "char>?", g_char_greater_2, 2, 0, false);
+
+ /* char<? */
+ f = set_function_chooser(sc->char_lt_symbol, char_less_chooser);
+ sc->char_less_2 = make_function_with_class(sc, f, "char<?", g_char_less_2, 2, 0, false);
+
+ /* read-char */
+ f = set_function_chooser(sc->read_char_symbol, read_char_chooser);
+ sc->read_char_1 = make_function_with_class(sc, f, "read-char", g_read_char_1, 1, 0, false);
+
+ /* char-position */
+ f = set_function_chooser(sc->char_position_symbol, char_position_chooser);
+ sc->char_position_csi = make_function_with_class(sc, f, "char-position", g_char_position_csi, 2, 1, false);
+
+ /* string=? */
+ f = set_function_chooser(sc->string_eq_symbol, string_equal_chooser);
+ sc->string_equal_2 = make_function_with_class(sc, f, "string=?", g_string_equal_2, 2, 0, false);
+ sc->string_equal_2c = make_function_with_class(sc, f, "string=?", g_string_equal_2c, 2, 0, false);
+
+ /* substring */
+ sc->substring_uncopied = s7_make_safe_function(sc, "substring", g_substring_uncopied, 2, 1, false, NULL);
+ s7_function_set_class(sc, sc->substring_uncopied, global_value(sc->substring_symbol));
+
+ /* string>? */
+ f = set_function_chooser(sc->string_gt_symbol, string_greater_chooser);
+ sc->string_greater_2 = make_function_with_class(sc, f, "string>?", g_string_greater_2, 2, 0, false);
+
+ /* string<? */
+ f = set_function_chooser(sc->string_lt_symbol, string_less_chooser);
+ sc->string_less_2 = make_function_with_class(sc, f, "string<?", g_string_less_2, 2, 0, false);
+
+ /* string */
+ f = set_function_chooser(sc->string_symbol, string_chooser);
+ sc->string_c1 = make_function_with_class(sc, f, "string", g_string_c1, 1, 0, false);
+
+ /* string-append */
+ f = set_function_chooser(sc->string_append_symbol, string_append_chooser);
+ sc->string_append_2 = make_function_with_class(sc, f, "string-append", g_string_append_2, 2, 0, false);
+
+ /* string-ref et al */
+ set_function_chooser(sc->string_ref_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_to_symbol_symbol, string_substring_chooser); /* not string_to_number here (not const char*??) */
+ set_function_chooser(sc->string_to_keyword_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_downcase_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_upcase_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_position_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_geq_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_leq_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_copy_symbol, string_copy_chooser);
+ set_function_chooser(sc->eval_string_symbol, string_substring_chooser);
+ set_function_chooser(sc->symbol_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_to_byte_vector_symbol, string_substring_chooser);
+ /* if the function assumes a null-terminated string, substring needs to return a copy (which assume this?) */
+#if (!WITH_PURE_S7)
+ set_function_chooser(sc->string_length_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_to_list_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_ci_eq_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_ci_geq_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_ci_leq_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_ci_gt_symbol, string_substring_chooser);
+ set_function_chooser(sc->string_ci_lt_symbol, string_substring_chooser);
+#endif
+#if WITH_SYSTEM_EXTRAS
+ set_function_chooser(sc->file_exists_symbol, string_substring_chooser);
+#endif
+
+ /* also: directory->list substring with-input-from-file with-input-from-string with-output-to-file open-output-file open-input-file
+ * system load getenv file-mtime gensym directory? call-with-output-file delete-file call-with-input-file call-with-input-string open-input-string
+ */
+
+ /* symbol->string */
+ f = global_value(sc->symbol_to_string_symbol);
+ sc->symbol_to_string_uncopied = s7_make_safe_function(sc, "symbol->string", g_symbol_to_string_uncopied, 1, 0, false, NULL);
+ s7_function_set_class(sc, sc->symbol_to_string_uncopied, f);
+
+ /* display */
+ f = set_function_chooser(sc->display_symbol, display_chooser);
+ sc->display_f = make_function_with_class(sc, f, "display", g_display_f, 2, 0, false);
+ sc->display_2 = make_function_with_class(sc, f, "display", g_display_2, 2, 0, false);
+
+ /* vector */
+ f = set_function_chooser(sc->vector_symbol, vector_chooser);
+ sc->vector_2 = make_function_with_class(sc, f, "vector", g_vector_2, 2, 0, false);
+ sc->vector_3 = make_function_with_class(sc, f, "vector", g_vector_3, 3, 0, false);
+
+ /* vector-ref */
+ f = set_function_chooser(sc->vector_ref_symbol, vector_ref_chooser);
+ sc->vector_ref_2 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_2, 2, 0, false);
+ sc->vector_ref_3 = make_function_with_class(sc, f, "vector-ref", g_vector_ref_3, 3, 0, false);
+
+ /* vector-set! */
+ f = set_function_chooser(sc->vector_set_symbol, vector_set_chooser);
+ sc->vector_set_3 = make_function_with_class(sc, f, "vector-set!", g_vector_set_3, 3, 0, false);
+ sc->vector_set_4 = make_function_with_class(sc, f, "vector-set!", g_vector_set_4, 4, 0, false);
+
+ /* float-vector-ref */
+ f = set_function_chooser(sc->float_vector_ref_symbol, float_vector_ref_chooser);
+ sc->fv_ref_2 = make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_2, 2, 0, false);
+ sc->fv_ref_3 = make_function_with_class(sc, f, "float-vector-ref", g_fv_ref_3, 3, 0, false);
+
+ /* float-vector-set */
+ f = set_function_chooser(sc->float_vector_set_symbol, float_vector_set_chooser);
+ sc->fv_set_3 = make_function_with_class(sc, f, "float-vector-set!", g_fv_set_3, 3, 0, false);
+ sc->fv_set_unchecked = make_function_with_class(sc, f, "float-vector-set!", g_fv_set_unchecked, 3, 0, false);
+
+ /* int-vector-ref */
+ f = set_function_chooser(sc->int_vector_ref_symbol, int_vector_ref_chooser);
+ sc->iv_ref_2 = make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_2, 2, 0, false);
+ sc->iv_ref_3 = make_function_with_class(sc, f, "int-vector-ref", g_iv_ref_3, 3, 0, false);
+
+ /* int-vector-set */
+ f = set_function_chooser(sc->int_vector_set_symbol, int_vector_set_chooser);
+ sc->iv_set_3 = make_function_with_class(sc, f, "int-vector-set!", g_iv_set_3, 3, 0, false);
+
+ /* byte-vector-ref */
+ f = set_function_chooser(sc->byte_vector_ref_symbol, byte_vector_ref_chooser);
+ sc->bv_ref_2 = make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_2, 2, 0, false);
+ sc->bv_ref_3 = make_function_with_class(sc, f, "byte-vector-ref", g_bv_ref_3, 3, 0, false);
+
+ /* byte-vector-set */
+ f = set_function_chooser(sc->byte_vector_set_symbol, byte_vector_set_chooser);
+ sc->bv_set_3 = make_function_with_class(sc, f, "byte-vector-set!", g_bv_set_3, 3, 0, false);
+
+ /* list-set! */
+ f = set_function_chooser(sc->list_set_symbol, list_set_chooser);
+ sc->list_set_i = make_function_with_class(sc, f, "list-set!", g_list_set_i, 3, 0, false);
+
+ /* hash-table-ref */
+ f = set_function_chooser(sc->hash_table_ref_symbol, hash_table_ref_chooser);
+ sc->hash_table_ref_2 = make_function_with_class(sc, f, "hash-table-ref", g_hash_table_ref_2, 2, 0, false);
+
+ /* hash-table-set! */
+ set_function_chooser(sc->hash_table_set_symbol, hash_table_set_chooser);
+
+ /* hash-table */
+ f = set_function_chooser(sc->hash_table_symbol, hash_table_chooser);
+ sc->hash_table_2 = make_function_with_class(sc, f, "hash-table", g_hash_table_2, 2, 0, false);
+
+ /* format */
+ f = set_function_chooser(sc->format_symbol, format_chooser);
+ sc->format_f = make_function_with_class(sc, f, "format", g_format_f, 1, 0, true);
+ sc->format_no_column = make_function_with_class(sc, f, "format", g_format_no_column, 1, 0, true);
+ sc->format_just_control_string = make_function_with_class(sc, f, "format", g_format_just_control_string, 2, 0, false);
+ sc->format_as_objstr = make_function_with_class(sc, f, "format", g_format_as_objstr, 3, 0, true);
+
+ /* list */
+ f = set_function_chooser(sc->list_symbol, list_chooser);
+ sc->list_0 = make_function_with_class(sc, f, "list", g_list_0, 0, 0, false);
+ sc->list_1 = make_function_with_class(sc, f, "list", g_list_1, 1, 0, false);
+ sc->list_2 = make_function_with_class(sc, f, "list", g_list_2, 2, 0, false);
+ sc->list_3 = make_function_with_class(sc, f, "list", g_list_3, 3, 0, false);
+ sc->list_4 = make_function_with_class(sc, f, "list", g_list_4, 4, 0, false);
+
+ /* append */
+ f = set_function_chooser(sc->append_symbol, append_chooser);
+ sc->append_2 = make_function_with_class(sc, f, "append", g_append_2, 2, 0, false);
+
+ /* list-ref */
+ f = set_function_chooser(sc->list_ref_symbol, list_ref_chooser);
+ sc->list_ref_at_0 = make_function_with_class(sc, f, "list", g_list_ref_at_0, 2, 0, false);
+ sc->list_ref_at_1 = make_function_with_class(sc, f, "list", g_list_ref_at_1, 2, 0, false);
+ sc->list_ref_at_2 = make_function_with_class(sc, f, "list", g_list_ref_at_2, 2, 0, false);
+
+ /* assoc */
+ set_function_chooser(sc->assoc_symbol, assoc_chooser);
+
+ /* member */
+ set_function_chooser(sc->member_symbol, member_chooser);
+
+ /* memq */
+ f = set_function_chooser(sc->memq_symbol, memq_chooser); /* is pure-s7, use member here */
+ sc->memq_2 = make_function_with_class(sc, f, "memq", g_memq_2, 2, 0, false);
+ sc->memq_3 = make_function_with_class(sc, f, "memq", g_memq_3, 2, 0, false);
+ sc->memq_4 = make_function_with_class(sc, f, "memq", g_memq_4, 2, 0, false);
+ sc->memq_any = make_function_with_class(sc, f, "memq", g_memq_any, 2, 0, false);
+
+ /* tree-set-memq */
+ f = set_function_chooser(sc->tree_set_memq_symbol, tree_set_memq_chooser);
+ sc->tree_set_memq_syms = make_function_with_class(sc, f, "tree-set-memq", g_tree_set_memq_syms, 2, 0, false);
+
+ /* dynamic-wind */
+ f = set_function_chooser(sc->dynamic_wind_symbol, dynamic_wind_chooser);
+ sc->dynamic_wind_unchecked = make_unsafe_function_with_class(sc, f, "dynamic-wind", g_dynamic_wind_unchecked, 3, 0, false);
+ sc->dynamic_wind_body = make_unsafe_function_with_class(sc, f, "dynamic-wind", g_dynamic_wind_body, 3, 0, false);
+ sc->dynamic_wind_init = make_unsafe_function_with_class(sc, f, "dynamic-wind", g_dynamic_wind_init, 3, 0, false);
+
+ /* inlet */
+ f = set_function_chooser(sc->inlet_symbol, inlet_chooser);
+ sc->simple_inlet = make_function_with_class(sc, f, "inlet", g_simple_inlet, 0, 0, true);
+
+ /* sublet */
+ f = set_function_chooser(sc->sublet_symbol, sublet_chooser);
+ sc->sublet_curlet = make_function_with_class(sc, f, "sublet", g_sublet_curlet, 3, 0, false);
+
+ /* let-ref */
+ f = set_function_chooser(sc->let_ref_symbol, let_ref_chooser);
+ sc->simple_let_ref = make_function_with_class(sc, f, "let-ref", g_simple_let_ref, 2, 0, false);
+
+ /* let-set */
+ f = set_function_chooser(sc->let_set_symbol, let_set_chooser);
+ sc->simple_let_set = make_function_with_class(sc, f, "let-set!", g_simple_let_set, 3, 0, false);
+
+ /* values */
+ f = set_function_chooser(sc->values_symbol, values_chooser);
+ sc->values_uncopied = make_unsafe_function_with_class(sc, f, "values", splice_in_values, 0, 0, true);
+
+ /* list-values */
+ f = set_function_chooser(sc->list_values_symbol, list_values_chooser);
+ sc->simple_list_values = make_function_with_class(sc, f, "list-values", g_simple_list_values, 0, 0, true);
+}
+
+
+/* ---------------- *unbound-variable-hook* ---------------- */
+static s7_pointer loaded_library(s7_scheme *sc, const char *file)
+{
+ for (s7_pointer p = global_value(sc->libraries_symbol); is_pair(p); p = cdr(p))
+ if (local_strcmp(file, string_value(caar(p))))
+ return(cdar(p));
+ return(sc->nil);
+}
+
+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 */
+ }
+}
+
+static noreturn void unbound_variable_error_nr(s7_scheme *sc, s7_pointer sym)
+{
+ s7_pointer err_code = NULL;
+ if ((is_pair(current_code(sc))) && (s7_tree_memq(sc, sym, current_code(sc))))
+ err_code = current_code(sc);
+ else
+ if ((is_pair(sc->code)) && (s7_tree_memq(sc, sym, sc->code)))
+ err_code = sc->code;
+#if WITH_HISTORY
+ else
+ {
+ s7_pointer p;
+ for (p = cdr(sc->cur_code); cdr(p) != sc->cur_code; p = cdr(p));
+ if ((is_pair(car(p))) && (s7_tree_memq(sc, sym, car(p)))) err_code = car(p);
+ }
+#endif
+ if (err_code) /* these cases look ok */
+ error_nr(sc, sc->unbound_variable_symbol, set_elist_3(sc, wrap_string(sc, "unbound variable ~S in ~S", 25), sym, err_code));
+ if ((symbol_name(sym)[symbol_name_length(sym) - 1] == ',') &&
+ (lookup_unexamined(sc, make_symbol(sc, symbol_name(sym), symbol_name_length(sym) - 1))))
+ error_nr(sc, sc->unbound_variable_symbol, set_elist_2(sc, wrap_string(sc, "unbound variable ~S (perhaps a stray comma?)", 44), sym));
+ error_nr(sc, sc->unbound_variable_symbol, set_elist_2(sc, wrap_string(sc, "unbound variable ~S", 19), sym));
+}
+
+static s7_pointer check_autoload_and_error_hook(s7_scheme *sc, s7_pointer sym)
+{
+ /* this always occurs in a context where we're trying to find anything, so I'll move a couple of those checks here */
+ if ((sc->curlet != sc->nil) &&
+ (has_let_ref_fallback(sc->curlet))) /* an experiment -- see s7test (with-let *db* (+ int32_t (length str))) */
+ return(call_let_ref_fallback(sc, sc->curlet, sym));
+ /* but if the thing we want to hit this fallback happens to exist at a higher level, oops... */
+
+ if (sym == sc->unquote_symbol)
+ syntax_error_nr(sc, "unquote (',') occurred outside quasiquote: ~S", 45, current_code(sc));
+
+ if (safe_strcmp(symbol_name(sym), "|#"))
+ read_error_nr(sc, "unmatched |#");
+
+ /* check *autoload*, autoload_names, then *unbound-variable-hook* */
+ if ((sc->autoload_names) ||
+ (is_hash_table(sc->autoload_table)) ||
+ ((is_procedure(sc->unbound_variable_hook)) &&
+ (hook_has_functions(sc->unbound_variable_hook))))
+ {
+ s7_pointer cur_code = current_code(sc);
+ s7_pointer value = sc->value;
+ s7_pointer code = sc->code;
+ s7_pointer current_let = sc->curlet;
+ s7_pointer x = sc->x;
+ s7_pointer z = sc->z;
+ /* sc->args and sc->code are pushed on the stack by s7_call, then
+ * restored by eval, so they are normally protected, but sc->value and current_code(sc) are
+ * not protected. We need current_code(sc) so that the possible eventual error
+ * call can tell where the error occurred, and we need sc->value because it might
+ * be awaiting addition to sc->args in e.g. OP_EVAL_ARGS5, and then be clobbered
+ * by the hook function. (+ 1 asdf) will end up evaluating (+ asdf asdf) if sc->value
+ * is not protected. We also need to save/restore sc->curlet in case s7_load is called.
+ */
+ s7_pointer args = (sc->args) ? sc->args : sc->nil;
+ s7_pointer result = sc->undefined;
+ 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);
+ }
+#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);
+ }}}
+#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);
+ }}
+ sc->value = T_Ext(value);
+ sc->args = T_Pos(args); /* can be #<unused> or #<counter>! */
+ sc->code = code;
+ set_curlet(sc, current_let);
+ sc->x = x;
+ sc->z = z;
+ sc->temp7 = sc->unused;
+ return(result);
+ }
+ return(sc->undefined);
+}
+
+static s7_pointer unbound_variable(s7_scheme *sc, s7_pointer sym)
+{
+ s7_pointer result = check_autoload_and_error_hook(sc, sym);
+ if (result != sc->undefined) return(result);
+ unbound_variable_error_nr(sc, sym);
+ return(sc->unbound_variable_symbol);
+}
+
+#define choose_c_function(Sc, Expr, Func, Args) set_c_function(Expr, c_function_chooser(Func)(Sc, Func, Args, Expr))
+
+static void fx_annotate_arg(s7_scheme *sc, s7_pointer arg, s7_pointer e)
+{
+#if S7_DEBUGGING
+ s7_function fx;
+ if (has_fx(arg)) return;
+ fx = fx_choose(sc, arg, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe);
+ if (fx) set_fx_direct(arg, fx);
+ /* else fprintf(stderr, "%s[%d]: no fx for %s in %s\n", __func__, __LINE__, display(arg), display(e)); */
+#else
+ if (has_fx(arg)) return;
+ set_fx(arg, fx_choose(sc, arg, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe));
+#endif
+}
+
+static void fx_annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer e)
+{
+ for (s7_pointer p = args; is_pair(p); p = cdr(p))
+#if S7_DEBUGGING
+ fx_annotate_arg(sc, p, e); /* checks has_fx */
+#else
+ if (!has_fx(p))
+ set_fx(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe));
+#endif
+}
+
+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));
+ if ((hop != 1) && (is_constant_symbol(sc, car(expr)))) hop = 1;
+
+ if ((is_closure(func)) || (is_closure_star(func)))
+ {
+ bool safe_case = is_safe_closure(func);
+ s7_pointer body = closure_body(func);
+ bool one_form = is_null(cdr(body));
+
+ 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);
+ }
+
+ 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);
+ }
+ 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));
+ }
+ return(OPT_F);
+ }
+ if (is_c_function(func))
+ {
+ if (c_function_min_args(func) != 0)
+ 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_unsafe_optimize_op(expr, hop + OP_C);
+ choose_c_function(sc, expr, func, 0);
+ return(OPT_F);
+ }
+ if (is_c_function_star(func))
+ {
+ set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR);
+ set_c_function(expr, func);
+ return(OPT_T);
+ }
+ return(OPT_F);
+}
+
+static int32_t combine_ops(s7_scheme *sc, s7_pointer expr, combine_op_t cop, s7_pointer e1, s7_pointer e2) /* sc needed for debugger stuff */
+{ /* sc arg is used if debugging (hidden in set_op2_con for example) */
+ switch (cop)
+ {
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }
+ 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;
+ }
+ return(OP_SAFE_C_PP);
+
+ default: break;
+ }
+ return(OP_UNOPT);
+}
+
+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))));
+}
+
+static bool safe_c_aa_to_ag_ga(s7_scheme *sc, s7_pointer arg, int32_t hop)
+{
+ if (fx_proc(cddr(arg)) == fx_s) {set_opt3_sym(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AS); return(true);}
+ if (fx_proc(cdr(arg)) == fx_s) {set_opt3_sym(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_SA); return(true);}
+ if (fx_proc(cddr(arg)) == fx_c) {set_opt3_con(arg, caddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);}
+ if (fx_proc(cdr(arg)) == fx_c) {set_opt3_con(arg, cadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);}
+ if (fx_proc(cddr(arg)) == fx_q) {set_opt3_con(arg, cadaddr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);}
+ if (fx_proc(cdr(arg)) == fx_q) {set_opt3_con(arg, cadadr(arg)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);}
+ return(false);
+}
+
+static opt_t check_c_aa(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e)
+{
+ fx_annotate_args(sc, cdr(expr), e);
+ if (!safe_c_aa_to_ag_ga(sc, expr, hop))
+ {
+ set_optimize_op(expr, hop + OP_SAFE_C_AA);
+ set_opt3_pair(expr, cddr(expr));
+ }
+ choose_c_function(sc, expr, func, 2);
+ return(OPT_T);
+}
+
+static opt_t wrap_bad_args(s7_scheme *sc, s7_pointer func, s7_pointer expr, int32_t n_args, int32_t hop, s7_pointer e)
+{
+ set_opt3_arglen(cdr(expr), n_args);
+ 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))));
+ 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_c_function(expr, func);
+ return(OPT_T);
+ }
+ if ((is_closure(func)) &&
+ (!arglist_has_rest(sc, closure_args(func))))
+ {
+ s7_pointer body = closure_body(func);
+ bool one_form = is_null(cdr(body)), safe_case = is_safe_closure(func);
+ 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)));
+ 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)));
+ return(OPT_F);
+ }
+ if ((is_closure_star(func)) &&
+ (lambda_has_simple_defaults(func)) &&
+ (closure_star_arity_to_int(sc, func) >= n_args) &&
+ (!arglist_has_rest(sc, closure_args(func))))
+ {
+ 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));
+ 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));
+ set_opt1_lambda_add(expr, func);
+ }
+ return(OPT_F);
+}
+
+static inline s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer symbol, s7_pointer e)
+{
+ s7_pointer x;
+ int64_t id;
+
+ if ((symbol_is_in_list(sc, symbol)) &&
+ (direct_memq(symbol, e))) /* it's probably a local variable reference */
+ return(sc->nil);
+ /* ((!symbol_is_in_list(sc, symbol)) && (direct_memq(symbol, e))) can happen if there's an intervening lambda:
+ * (let loop () (with-let (for-each (lambda (a) a) (list))) (loop))
+ * misses 'loop (it's not in symbol_list when recursive call is encountered) -- tricky to fix
+ */
+
+ if (is_global(symbol))
+ return(global_slot(symbol));
+
+ /* see 59108 (OP_DEFINE_* in optimize_syntax) -- keyword version of name is used if a definition is
+ * contingent on some run-time decision, so we're looking here for local defines that might not happen.
+ * s7test.scm has a test case using acos.
+ */
+ if ((has_keyword(symbol)) &&
+ (symbol_is_in_list(sc, symbol_to_keyword(sc, symbol))))
+ return(sc->nil);
+
+ for (x = sc->curlet, id = symbol_id(symbol); let_id(x) > id; x = let_outlet(x));
+ for (; x; x = let_outlet(x))
+ {
+ if (let_id(x) == id)
+ 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);
+ }
+ return(global_slot(symbol)); /* it's no longer global perhaps (local definition now inaccessible) */
+}
+
+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))));
+}
+
+static bool hop_if_constant(s7_scheme *sc, s7_pointer sym)
+{
+ return(((!sc->in_with_let) && (symbol_id(sym) == 0)) ? 1 : 0); /* for with-let, see s7test atanh (77261) */
+}
+
+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)
+{
+ s7_pointer arg1 = cadr(expr);
+ bool func_is_safe = is_safe_procedure(func);
+ if (hop == 0) hop = hop_if_constant(sc, car(expr));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %d %d\n", __func__, __LINE__, display_truncated(expr), func_is_safe, pairs);
+ 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);
+ }
+ /* 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);
+ }
+ 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));
+ }
+ choose_c_function(sc, expr, func, 1);
+ return(OPT_F);
+ }
+ /* pairs == 1 */
+ 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);
+ }
+ 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);
+ }}
+ 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);
+ }
+ /* 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);
+ }}}}
+ 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);
+}
+
+static bool walk_fxable(s7_scheme *sc, s7_pointer tree)
+{
+ for (s7_pointer p = cdr(tree); is_pair(p); p = cdr(p))
+ {
+ 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);
+ }}
+ return(true);
+}
+
+static bool is_safe_fxable(s7_scheme *sc, s7_pointer p)
+{
+ if (!is_pair(p)) return(true);
+ if (is_optimized(p))
+ {
+ if ((fx_function[optimize_op(p)]) &&
+ (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));
+ return(false);
+}
+
+static opt_t fxify_closure_s(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t hop)
+{
+ s7_pointer body = closure_body(func);
+ fx_annotate_arg(sc, body, e);
+ /* we can't currently fx_annotate_arg(sc, cdr(expr), e) here because that opt2 field is in use elsewhere (opt2_sym, not sure where it's set) */
+ set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_A);
+ if ((is_pair(car(body))) && (is_pair(cdar(body))) && (car(closure_args(func)) == cadar(body)))
+ {
+ if (optimize_op(car(body)) == HOP_SAFE_C_S)
+ set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_S_TO_S);
+ else
+ if (optimize_op(car(body)) == HOP_SAFE_C_SC)
+ {
+ s7_pointer body_arg2 = 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);
+}
+
+static bool fxify_closure_a(s7_scheme *sc, s7_pointer func, bool one_form, bool safe_case, int32_t hop, s7_pointer expr, s7_pointer e)
+{
+ if (!one_form)
+ set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_A : OP_CLOSURE_A));
+ else
+ if (!safe_case)
+ 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);
+ }}
+ return(false);
+}
+
+static opt_t optimize_closure_sym(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, s7_pointer e)
+{
+ if (fx_count(sc, expr) != args) /* fx_count starts at cdr, args here is the number of exprs in cdr(expr) -- so this means "are all args fxable" */
+ return(OPT_F);
+ set_opt3_arglen(cdr(expr), args);
+ set_opt1_lambda_add(expr, func);
+ fx_annotate_args(sc, cdr(expr), e);
+ if (is_safe_closure(func))
+ {
+ 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);
+ }
+ set_safe_optimize_op(expr, hop + OP_ANY_CLOSURE_SYM);
+ return(OPT_T);
+ }
+ set_unsafe_optimize_op(expr, hop + OP_ANY_CLOSURE_SYM);
+ return(OPT_F);
+}
+
+static opt_t optimize_closure_a_sym(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t args, s7_pointer e)
+{
+ if (fx_count(sc, expr) != args) return(OPT_F);
+ set_opt3_arglen(cdr(expr), args);
+ set_opt1_lambda_add(expr, func);
+ fx_annotate_args(sc, cdr(expr), e);
+ if (is_safe_closure(func))
+ {
+ 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);
+ }
+ set_safe_optimize_op(expr, hop + OP_ANY_CLOSURE_A_SYM);
+ return(OPT_T);
+ }
+ set_unsafe_optimize_op(expr, hop + OP_ANY_CLOSURE_A_SYM);
+ return(OPT_F);
+}
+
+static opt_t optimize_closure_one_arg(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t symbols, s7_pointer e)
+{
+ bool one_form, safe_case;
+ s7_pointer body, arg1 = cadr(expr);
+ int32_t arit = closure_arity_to_int(sc, func);
+ 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));
+ if ((arit == -1) && (is_symbol(cdr(closure_args(func)))))
+ return(optimize_closure_a_sym(sc, expr, func, hop, 1, e));
+ return(OPT_F);
+ }
+ safe_case = is_safe_closure(func);
+ body = closure_body(func);
+ one_form = is_null(cdr(body));
+ if (is_immutable(func)) hop = 1;
+
+ if (symbols == 1)
+ {
+ 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);
+ }
+ else set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_S : OP_CLOSURE_S));
+ set_unsafely_optimized(expr);
+ return(OPT_F);
+ }
+ if (fx_count(sc, expr) == 1)
+ {
+ set_unsafely_optimized(expr);
+ set_opt1_lambda_add(expr, func);
+ fx_annotate_arg(sc, cdr(expr), e);
+ set_opt3_arglen(cdr(expr), 1);
+ if (fxify_closure_a(sc, func, one_form, safe_case, hop, expr, e)) return(OPT_T);
+ set_unsafely_optimized(expr);
+ return(OPT_F);
+ }
+ set_optimize_op(expr, hop + ((safe_case) ? OP_SAFE_CLOSURE_P : OP_CLOSURE_P));
+ set_opt1_lambda_add(expr, func);
+ set_opt3_arglen(cdr(expr), 1);
+ set_unsafely_optimized(expr);
+ if ((safe_case) && (one_form) && (is_fxable(sc, car(closure_body(func)))))
+ {
+ set_optimize_op(expr, hop + OP_SAFE_CLOSURE_P_A); /* other possibilities: 3p fp (ap|pa only get a few hits), but none of these matter much */
+ fx_annotate_arg(sc, closure_body(func), e);
+ }
+ return(OPT_F); /* don't check is_optimized here for OPT_T */
+}
+
+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)
+{
+ 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));
+ /* 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);
+ if ((bad_pairs == quotes) &&
+ (is_symbol(car(expr))) &&
+ (is_constant_symbol(sc, car(expr))))
+ hop = 1;
+ }
+ arg1 = cadr(expr);
+ /* need in_with_let -> search only rootlet not lookup */
+ if ((symbols == 1) &&
+ ((!arg_findable(sc, arg1, e)) || (sc->in_with_let))) /* (set! (with-let ...) ...) can involve an unbound variable otherwise bound */
+ {
+ /* 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));
+ }
+ return(OPT_F);
+ }
+
+ switch (type(func))
+ {
+ case T_C_FUNCTION: /* these two happen much more than everything else put together, but splitting them out to avoid the switch doesn't gain much */
+ if (!c_function_is_aritable(func, 1)) return(OPT_F);
+ case T_C_RST_NO_REQ_FUNCTION:
+ return(optimize_c_function_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, e));
+
+ case T_CLOSURE:
+ return(optimize_closure_one_arg(sc, expr, func, hop, symbols, e));
+
+ case T_CLOSURE_STAR:
+ if (is_null(closure_args(func)))
+ 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));
+ }
+ 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;
+
+ 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);
+ }
+ 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);
+ }
+ /* 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);
+ }
+ break;
+
+ default:
+ break;
+ }
+ return((is_optimized(expr)) ? OPT_T : OPT_F);
+}
+
+static bool unsafe_is_safe(s7_scheme *sc, s7_pointer f, s7_pointer e)
+{
+ if (!is_symbol(f)) return(false);
+ f = find_uncomplicated_symbol(sc, f, e); /* how to catch local c-funcs here? */
+ if (!is_slot(f)) return(false);
+ return(is_safe_c_function(slot_value(f)));
+}
+
+static opt_t set_any_closure_np(s7_scheme *sc, s7_pointer func, s7_pointer expr, s7_pointer e, int32_t num_args, opcode_t op)
+{
+ for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p))
+ set_fx(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe));
+ set_opt3_arglen(cdr(expr), num_args);
+ set_unsafe_optimize_op(expr, op);
+ set_opt1_lambda_add(expr, func);
+ return(OPT_F);
+}
+
+static bool two_args_ok(s7_scheme *sc, s7_pointer expr, s7_pointer e)
+{
+ if ((is_symbol(car(expr))) && ((car(expr) == sc->member_symbol) || (car(expr) == sc->assoc_symbol))) return(true);
+ return(unsafe_is_safe(sc, cadr(expr), 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)))));
+}
+
+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)
+{
+ /* we get semisafe funcs here of 2 args and up, very few more than 5 */
+ /* would safe_c_pp work for cl? or should unknown_* deal with op_cl_*? why aren't unknown* used in op_safe_c and op_c?
+ * or use op_stack? error clears this? op-any-c-fp: op_any_c_2p|3p|fp? -- mimic clo_3p|4p?
+ */
+ for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p))
+ set_fx(p, fx_choose(sc, p, e, (is_list(e)) ? pair_symbol_is_safe : let_symbol_is_safe));
+ set_opt3_arglen(cdr(expr), num_args); /* for op_unknown_np */
+ set_unsafe_optimize_op(expr, op);
+ choose_c_function(sc, expr, func, num_args); /* we can use num_args -- mv will redirect to generic call */
+ return(OPT_F);
+}
+
+static s7_function io_function(s7_function func)
+{
+ if (func == g_with_input_from_string) return(with_string_in);
+ if (func == g_with_input_from_file) return(with_file_in);
+ if (func == g_with_output_to_file) return(with_file_out);
+ if (func == g_call_with_input_string) return(call_string_in);
+ if (func == g_call_with_input_file) return(call_file_in);
+ return(call_file_out); /* call_with_output_to_file */
+}
+
+static void fixup_closure_star_aa(s7_scheme *sc, s7_pointer f, s7_pointer code, int32_t hop)
+{
+ int32_t arity = closure_star_arity_to_int(sc, f);
+ bool safe_case = is_safe_closure(f);
+ s7_pointer arg1 = cadr(code), par1 = car(closure_args(f));
+
+ if (is_pair(par1)) par1 = car(par1);
+ set_opt3_arglen(cdr(code), 2);
+ set_unsafely_optimized(code);
+
+ if ((arity == 1) && (is_symbol_and_keyword(arg1)) && (keyword_symbol(arg1) == par1))
+ set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_KA : OP_CLOSURE_STAR_KA));
+ 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));
+ 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)
+{
+ 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));
+ if (quotes > 0)
+ {
+ if (direct_memq(sc->quote_symbol, e))
+ return(OPT_OOPS);
+ if ((bad_pairs == quotes) &&
+ (is_symbol(car(expr))) &&
+ (is_constant_symbol(sc, car(expr))))
+ hop = 1;
+ }
+ if (((is_symbol(arg1)) &&
+ (!arg_findable(sc, arg1, e))) ||
+ ((is_symbol(arg2)) &&
+ (!arg_findable(sc, arg2, e))))
+ {
+ /* 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));
+ }
+ return(OPT_F);
+ }
+ /* end of bad symbol wrappers */
+
+ if (is_c_function(func) && (c_function_is_aritable(func, 2)))
+ {
+ /* this is a mess */
+ bool func_is_safe = is_safe_procedure(func);
+ 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);
+ }
+
+ /* 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);
+ }}
+
+ 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);
+ }}
+
+ 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 (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 ((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);
+ }}
+
+ 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);
+ }}
+
+ if (func_is_safe)
+ {
+ 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);
+ }}
+ 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? */
+ }
+
+ if (is_closure(func))
+ {
+ bool one_form, safe_case;
+ s7_pointer body;
+ 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_immutable(func)) hop = 1;
+
+ body = closure_body(func);
+ one_form = is_null(cdr(body));
+ 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);
+ }}
+
+ 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);
+ }
+
+ 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);
+ }
+
+ 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);
+ }
+
+ 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);
+ }
+
+ if (is_safe_closure(func)) /* clo* too */
+ 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);
+ set_opt1_lambda_add(expr, func);
+ set_opt3_arglen(cdr(expr), 2); /* for op_unknown_np */
+ return(OPT_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 ?? */
+ 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);
+ }}
+
+ if ((is_c_function_star(func)) &&
+ (fx_count(sc, expr) == 2) &&
+ (c_function_max_args(func) >= 1) &&
+ (!is_symbol_and_keyword(arg2)))
+ {
+ if ((hop == 0) && ((is_immutable(func)) || ((!sc->in_with_let) && (symbol_id(car(expr)) == 0)))) hop = 1;
+ set_optimized(expr);
+ set_optimize_op(expr, hop + OP_SAFE_C_STAR_AA); /* k+c? = cc */
+ fx_annotate_args(sc, cdr(expr), e);
+ set_opt3_arglen(cdr(expr), 2);
+ set_c_function(expr, func);
+ return(OPT_T);
+ }
+
+ if ((((is_any_vector(func)) && (vector_rank(func) == 2)) || (is_pair(func))) &&
+ (is_fxable(sc, arg1)) && (is_fxable(sc, arg2)))
+ {
+ set_unsafe_optimize_op(expr, ((is_pair(func)) ? OP_IMPLICIT_PAIR_REF_AA : OP_IMPLICIT_VECTOR_REF_AA));
+ fx_annotate_args(sc, cdr(expr), e);
+ set_opt3_arglen(cdr(expr), 2);
+ return(OPT_T);
+ }
+ return((is_optimized(expr)) ? OPT_T : OPT_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)
+{
+ 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);
+ 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);
+ }}
+ choose_c_function(sc, expr, func, 3);
+ return(OPT_T);
+ }
+
+ /* pairs != 0 */
+ if (fx_count(sc, expr) == 3)
+ {
+ 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);
+ }}}
+
+ fx_annotate_args(sc, cdr(expr), e);
+ set_opt3_arglen(cdr(expr), 3);
+ set_opt3_pair(expr, cddr(expr));
+ 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);
+ }}}}
+ else
+ 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);
+ }
+ return(OPT_F); /* tell caller to try something else */
+}
+
+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)
+{
+ s7_pointer arg1, arg2, arg3;
+ if ((quotes > 0) &&
+ (direct_memq(sc->quote_symbol, e)))
+ return(OPT_OOPS);
+
+ arg1 = cadr(expr);
+ arg2 = caddr(expr);
+ arg3 = cadddr(expr);
+ if (((is_symbol(arg1)) &&
+ (!arg_findable(sc, arg1, e))) ||
+ ((is_symbol(arg2)) &&
+ (!arg_findable(sc, arg2, e))) ||
+ ((is_symbol(arg3)) &&
+ (!arg_findable(sc, arg3, e))))
+ {
+ /* 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);
+ }}
+ return(OPT_F);
+ } /* end of bad symbol wrappers */
+
+ if ((bad_pairs == quotes) &&
+ (is_symbol(car(expr))) &&
+ (is_constant_symbol(sc, car(expr))))
+ hop = 1;
+
+ if (is_c_function(func) && (c_function_is_aritable(func, 3)))
+ {
+ 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));
+ }
+ /* 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);
+ }
+
+ /* (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 ((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);
+ }}
+
+ 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));
+ return(set_any_c_np(sc, func, expr, e, 3, hop + OP_ANY_C_NP));
+ }
+
+ /* not c func */
+ if (is_closure(func))
+ {
+ 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_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);
+ }
+
+ 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);
+ }
+ 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);
+ 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_c_function_star(func)) &&
+ (fx_count(sc, expr) == 3) &&
+ (c_function_max_args(func) >= 2))
+ {
+ set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_NA);
+ fx_annotate_args(sc, cdr(expr), e);
+ set_opt3_arglen(cdr(expr), 3);
+ set_c_function(expr, func);
+ return(OPT_T);
+ }
+ /* implicit_vector_3a doesn't happen */
+
+ if (bad_pairs > quotes) return(OPT_F);
+ return((is_optimized(expr)) ? OPT_T : OPT_F);
+}
+
+static bool symbols_are_safe(s7_scheme *sc, s7_pointer args, s7_pointer e)
+{
+ for (s7_pointer p = args; is_pair(p); p = cdr(p))
+ {
+ s7_pointer arg = car(p);
+ if ((is_normal_symbol(arg)) &&
+ (!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)
+{
+ bool func_is_closure;
+ if (quotes > 0)
+ {
+ if (direct_memq(sc->quote_symbol, e))
+ return(OPT_OOPS);
+ if ((bad_pairs == quotes) &&
+ (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));
+ }
+ /* 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);
+ }
+ return(set_any_c_np(sc, func, expr, e, args, hop + OP_ANY_C_NP)); /* was num_args=3! 2-Sep-20 */
+ }
+
+ func_is_closure = is_closure(func);
+ if (func_is_closure)
+ {
+ 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_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);
+ }
+ 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, args, hop + OP_ANY_CLOSURE_NP));
+ }
+
+ 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)))
+ return(OPT_F);
+
+ if ((is_c_function_star(func)) &&
+ (fx_count(sc, expr) == args) &&
+ (c_function_max_args(func) >= (args / 2)))
+ {
+ if (is_immutable(func)) hop = 1;
+ set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR_NA);
+ fx_annotate_args(sc, cdr(expr), e);
+ set_opt3_arglen(cdr(expr), args);
+ set_c_function(expr, func);
+ return(OPT_T);
+ }
+ if (((func_is_closure) ||
+ (is_closure_star(func))) &&
+ (fx_count(sc, expr) == args))
+ {
+ 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)));
+ 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);
+ set_opt1_lambda_add(expr, func);
+ return(OPT_F);
+ }
+ return((is_optimized(expr)) ? OPT_T : OPT_F);
+}
+
+static bool vars_syntax_ok(s7_pointer vars)
+{
+ 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))) ||
+ (is_pair(cddr(var))))
+ return(false);
+ }
+ return(true);
+}
+
+static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7_pointer e, bool export_ok);
+
+static bool vars_opt_ok(s7_scheme *sc, s7_pointer vars, int32_t hop, s7_pointer e)
+{
+ for (s7_pointer p = vars; is_pair(p); p = cdr(p))
+ {
+#if 0
+ s7_pointer var = car(p);
+ 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);
+ }
+ /* 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
+ */
+#else
+ s7_pointer init = cadar(p);
+#endif
+ if ((is_pair(init)) &&
+ (!is_checked(init)) &&
+ (optimize_expression(sc, init, hop, e, false) == OPT_OOPS))
+ return(false);
+ }
+ return(true);
+}
+
+static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e, bool export_ok)
+{
+ opcode_t op = syntax_opcode(func);
+ s7_pointer body = cdr(expr), vars;
+ bool body_export_ok = true;
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s\n", __func__, __LINE__, display_truncated(expr));
+
+ sc->w = e;
+ switch (op)
+ {
+ case OP_QUOTE:
+ case OP_MACROEXPAND:
+ return((is_proper_list_1(sc, body)) ? OPT_F : OPT_OOPS);
+
+ 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);
+ }
+ 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);
+ }
+ if (!is_pair(body)) return(OPT_OOPS);
+
+ if (!vars_syntax_ok(vars))
+ 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);
+ }
+ 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 (is_symbol(cadr(expr)))
+ {
+ e = cons(sc, add_symbol_to_list(sc, cadr(expr)), e);
+ sc->w = e;
+ }
+ break;
+
+ case OP_LET_TEMPORARILY:
+ vars = cadr(expr);
+ 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);
+ }
+ /* 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;
+
+ case OP_DO:
+ vars = cadr(expr);
+ if (is_null(vars))
+ e = cons(sc, sc->nil, e);
+ else
+ 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);
+ }
+ 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);
+ }
+ break;
+
+ case OP_BEGIN:
+ body_export_ok = export_ok; /* (list x (begin (define x 0))) */
+ break;
+
+ case OP_WITH_BAFFLE:
+ e = cons(sc, sc->nil, e);
+ break;
+
+ case OP_DEFINE_BACRO: case OP_DEFINE_BACRO_STAR:
+ case OP_BACRO: case OP_BACRO_STAR:
+ return(OPT_F);
+
+ case OP_DEFINE_MACRO: case OP_DEFINE_MACRO_STAR:
+ case OP_DEFINE_CONSTANT: case OP_DEFINE_EXPANSION: case OP_DEFINE_EXPANSION_STAR:
+ case OP_DEFINE: case OP_DEFINE_STAR:
+ /* define adds a name to the incoming let (e), the added name is inserted into e after the first, so the caller
+ * can flush added symbols by maintaining its own pointer into the list if blockers set the car.
+ * the list is used both to see local symbols and to catch "complicated" functions (find_uncomplicated_symbol).
+ * In cases like (if expr (define...)) we can't tell at this level whether the define takes place, so
+ * its name should not be in "e", but it needs to be marked for find_uncomplicated_symbol in a way
+ * that can be distinguished from members of "e". So in that (rare) case, we use the associated keyword.
+ * Then find_uncomplicated_symbol can use has_keyword to tell if the keyword search is needed.
+ * export_ok is trying to protect against optimizing (list x (define x 0)) as op_safe_c_sp and all related cases
+ */
+ 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;
+ }
+ 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;
+ }
+ 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);
+ else
+ 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);
+ if (!is_pair(cddr(expr)))
+ 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;
+ }
+ if ((is_pair(caddr(expr))) &&
+ (!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_F);
+
+ case OP_WITH_LET:
+ /* we usually can't trust anything here, so hop ought to be off. For example,
+ * (define (hi) (let ((e (sublet (curlet) :abs (lambda (a) (- a 1))))) (with-let e (abs -1))))
+ * 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);
+ }
+
+ 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);
+ 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);
+ 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);
+ }
+ {
+ 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));
+ }
+ return(OPT_T);
+
+ case OP_IF: case OP_WHEN: case OP_UNLESS:
+ if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr))))
+ return(OPT_OOPS);
+ case OP_OR: case OP_AND:
+ e = cons(sc, sc->if_keyword, e);
+ break;
+
+ default: break;
+ }
+
+ 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))
+ {
+ sc->temp9 = sc->unused;
+ return(OPT_OOPS);
+ }
+ sc->temp9 = sc->unused;
+
+ if ((hop == 1) &&
+ ((is_syntax(car(expr))) ||
+ (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);
+ }
+ 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 */
+ return(OPT_F);
+}
+
+static opt_t optimize_funcs(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, int32_t orig_hop, s7_pointer e)
+{
+ int32_t pairs = 0, symbols = 0, args = 0, bad_pairs = 0, quotes = 0;
+ s7_pointer p;
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s, func: %s\n", __func__, __LINE__, display_truncated(expr), display(func));
+ for (p = cdr(expr); is_pair(p); p = cdr(p), args++) /* check the args (the calling expression) */
+ {
+ s7_pointer car_p = car(p);
+ if (is_normal_symbol(car_p)) /* for opt func */
+ 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_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));
+ }}
+ return(OPT_OOPS); /* was OPT_F, but this is always an error */
+}
+
+static opt_t optimize_expression(s7_scheme *sc, s7_pointer expr, int32_t hop, s7_pointer e, bool export_ok)
+{
+ s7_pointer car_expr = car(expr);
+ int32_t orig_hop = hop;
+ set_checked(expr);
+
+ if (is_symbol(car_expr))
+ {
+ 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));
+ }
+ 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));
+ }}
+ 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 */
+ }
+
+ /* 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
+ {
+ /* car(expr) is not a symbol, but there might be interesting stuff here */
+ /* (define (hi a) (case 1 ((1) (if (> a 2) a 2)))) */
+ 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));
+
+ if (is_c_function(car_expr)) /* (#_abs x) etc */
+ 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_any_macro(car_expr))
+ 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);
+ /* 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
+ * ((if (input-port? port) call-with-input-file call-with-output-file) port proc) ; not safe I guess
+ */
+ }
+ return(OPT_F);
+}
+
+static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e)
+{
+ s7_pointer x;
+ for (x = code; (is_pair(x)) && (!is_checked(x)); x = cdr(x))
+ {
+ 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);
+ }}
+ 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_list(x))
+ syntax_error_nr(sc, "stray dot in function body: ~S", 30, code);
+ return(OPT_F);
+}
+
+
+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))))
+ return(true);
+ return(sym == x);
+}
+
+static void check_lambda_args(s7_scheme *sc, s7_pointer args, int32_t *arity, s7_pointer form)
+{
+ s7_pointer x;
+ int32_t i;
+
+ 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)));
+ /* 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.
+ */
+ if (is_symbol(args)) set_local(args);
+ if (arity) (*arity) = -1;
+ return;
+ }
+ for (i = 0, x = args; is_pair(x); i++, x = cdr(x))
+ {
+ 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 (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)));
+ 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)));
+ i = -i - 1;
+ }
+ if (arity) (*arity) = i;
+}
+
+static s7_pointer check_lambda_star_args(s7_scheme *sc, s7_pointer args, s7_pointer body, s7_pointer form) /* checks closure*, macro*, and bacro* */
+{
+ s7_pointer top, v, w;
+ bool has_defaults;
+
+ 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)));
+ if (is_symbol(args)) set_local(args);
+ return(args);
+ }
+
+ has_defaults = false;
+ top = args;
+ for (v = args, w = args; is_pair(w); v = w, w = cdr(w))
+ {
+ 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));
+ }
+ 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 (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)));
+ if (is_symbol(w))
+ set_local(w);
+ }
+ else
+ if ((body) && (!has_defaults) && (is_pair(args)))
+ set_has_no_defaults(body);
+ return(top);
+}
+
+static void set_rec_tc_args(s7_scheme *sc, s7_int args)
+{
+ if (sc->rec_tc_args == -1)
+ sc->rec_tc_args = args;
+ else
+ if (sc->rec_tc_args != args)
+ sc->rec_tc_args = -2;
+}
+
+typedef enum {UNSAFE_BODY=0, RECUR_BODY, SAFE_BODY, VERY_SAFE_BODY} body_t;
+static body_t min_body(body_t b1, body_t b2) {return((b1 < b2) ? b1 : b2);}
+static body_t body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool at_end);
+
+static body_t form_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer x, bool at_end) /* called only from body_is_safe */
+{
+ s7_pointer expr = car(x);
+ body_t result = VERY_SAFE_BODY;
+
+ if (is_symbol_and_syntactic(expr))
+ {
+ 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);
+ }}
+ 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);
+ }
+
+ 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);
+ }}
+ 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 */
+
+ return(UNSAFE_BODY); /* not recur_body here if at_end -- possible defines in body etc */
+ }
+ return(result);
+}
+
+static body_t body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool at_end)
+{
+ bool follow = false;
+ s7_pointer p = body;
+ body_t result = VERY_SAFE_BODY;
+ 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);
+ }
+ if (p != body)
+ {
+ if (follow) {sp = cdr(sp); if (p == sp) return(UNSAFE_BODY);}
+ follow = (!follow);
+ }}
+ return((is_null(p)) ? result : UNSAFE_BODY);
+}
+
+static bool tree_has_definers_or_binders(s7_scheme *sc, s7_pointer tree)
+{
+ for (s7_pointer p = tree; is_pair(p); p = cdr(p))
+ if (tree_has_definers_or_binders(sc, car(p)))
+ return(true);
+ return((is_symbol(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)
+{
+ s7_pointer test = cadr(body);
+ if (is_fxable(sc, test)) /* if_(A)... */
+ {
+ s7_pointer obody = cddr(body), orig = NULL;
+ s7_pointer true_p = car(obody); /* if_a_(A)... */
+ 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);
+ }}}
+
+ 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;
+ 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 (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 ((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);
+ }}}
+ return(false);
+}
+
+static bool check_recur(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body)
+{
+ if ((car(body) == sc->if_symbol) &&
+ (proper_list_length(body) == 4))
+ return(check_recur_if(sc, name, vars, args, body));
+
+ if ((car(body) == sc->and_symbol) &&
+ (vars == 2) &&
+ (proper_list_length(body) == 3) &&
+ (proper_list_length(caddr(body)) == 4) &&
+ (caaddr(body) == sc->or_symbol) &&
+ (is_fxable(sc, cadr(body))))
+ {
+ s7_pointer or_p = caddr(body);
+ 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);
+ }}
+
+ 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);
+ }}}}}}}}
+ return(false);
+}
+
+static bool check_tc_when(s7_scheme *sc, const s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body)
+{
+ s7_pointer test_expr = cadr(body);
+ if (is_fxable(sc, test_expr))
+ {
+ s7_pointer p;
+ for (p = cddr(body); is_pair(cdr(p)); p = cdr(p))
+ 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);
+ }}}
+ return(false);
+}
+
+static bool check_tc_case(s7_scheme *sc, s7_pointer name, s7_pointer args, s7_pointer body)
+{
+ /* vars == 1, opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */
+ s7_pointer clauses;
+ s7_int len;
+ bool got_else = false, results_fxable = true;
+ for (clauses = cddr(body), len = 0; is_pair(clauses); clauses = cdr(clauses), len++)
+ {
+ 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));
+ }
+ else
+ {
+ 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);
+ 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;
+ }
+ 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 ((!got_else) || (!is_null(clauses)))
+ return(false);
+ set_optimize_op(body, OP_TC_CASE_LA);
+ set_opt3_arglen(cdr(body), (len < 6) ? len : 0);
+ fx_annotate_arg(sc, cdr(body), args);
+ fx_tree(sc, cdr(body), car(args), NULL, NULL, true);
+ if (results_fxable) set_optimized(body);
+ return(results_fxable);
+}
+
+static bool check_tc_cond(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body)
+{
+ s7_pointer p = cdr(body), clause1 = car(p);
+ if ((is_proper_list_2(sc, clause1)) && (is_fxable(sc, car(clause1)))) /* cond_a... */
+ {
+ 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);
+ }
+ 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);
+ }}}}}
+ return(false);
+}
+
+static bool check_tc_let(s7_scheme *sc, const s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body)
+{
+ s7_pointer let_body = caddr(body); /* body: (let ((x (- y 1))) (if (<= x 0) 0 (f1 (- x 1)))) etc */
+ if (((vars == 2) && ((car(let_body) == sc->if_symbol) || (car(let_body) == sc->when_symbol) || (car(let_body) == sc->unless_symbol))) ||
+ ((vars == 1) && (car(let_body) == sc->if_symbol)))
+ {
+ 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);
+ }}}}}
+ 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);
+ }}
+ return(false);
+}
+
+/* tc lets can be let* or let+vars that don't refer to previous names, and there are more cond/if choices */
+
+static bool check_tc(s7_scheme *sc, s7_pointer name, int32_t vars, s7_pointer args, s7_pointer body)
+{
+ if (!is_pair(body)) return(false);
+
+ if (((vars == 1) || (vars == 2) || (vars == 3)) &&
+ ((car(body) == sc->and_symbol) || (car(body) == sc->or_symbol)) &&
+ (is_pair(cdr(body))) &&
+ (is_fxable(sc, cadr(body))) &&
+ (is_pair(cddr(body))))
+ {
+ 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);
+ }}}
+ 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 == 3) &&
+ (((car(body) == sc->or_symbol) && (is_proper_list_2(sc, cdr(body)))) ||
+ ((car(body) == sc->if_symbol) && (is_proper_list_3(sc, cdr(body))) && (caddr(body) == sc->T))) &&
+ (is_fxable(sc, cadr(body))))
+ {
+ 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);
+ }}}
+
+ if (((vars >= 1) && (vars <= 3)) &&
+ (car(body) == sc->if_symbol) &&
+ (proper_list_length(body) == 4))
+ {
+ 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);
+ }}}}}
+
+ /* let */
+ if ((is_proper_list_3(sc, body)) &&
+ (car(body) == sc->let_symbol) &&
+ (is_proper_list_1(sc, cadr(body))) &&
+ (is_fxable(sc, cadr(caadr(body)))) && /* let one var is fxable */
+ (is_pair(caddr(body))))
+ return(check_tc_let(sc, name, vars, args, body));
+
+ /* cond */
+ if ((car(body) == sc->cond_symbol) &&
+ (vars <= 2))
+ return(check_tc_cond(sc, name, vars, args, body));
+
+ /* case */
+ if ((vars == 1) &&
+ (car(body) == sc->case_symbol) &&
+ (is_pair(cdr(body))) &&
+ (is_fxable(sc, cadr(body))))
+ return(check_tc_case(sc, name, args, body));
+
+ /* when */
+ if ((vars >= 1) && (vars <= 3) &&
+ (car(body) == sc->when_symbol) &&
+ (is_fxable(sc, cadr(body))))
+ return(check_tc_when(sc, name, vars, args, body));
+ return(false);
+}
+
+static void mark_fx_treeable(s7_scheme *sc, s7_pointer body)
+{ /* it is possible to encounter a cyclic body here -- should we protect against that if safety>0? */
+ 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));
+ }
+ mark_fx_treeable(sc, cdr(body));
+ }
+}
+
+static void optimize_lambda(s7_scheme *sc, bool unstarred_lambda, s7_pointer func, s7_pointer args, s7_pointer body)
+{ /* func is either sc->unused or a symbol */
+ s7_int len = s7_list_length(sc, body);
+ 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));
+ if (len > 0) /* i.e. not circular */
+ {
+ body_t result;
+ s7_pointer p, lst, cleared_args;
+
+ 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));
+ if (!is_null(p))
+ add_symbol_to_list(sc, p);
+ sc->got_tc = false;
+ sc->not_tc = false;
+ sc->got_rec = false;
+ sc->rec_tc_args = -1;
+ result = ((is_symbol(func)) && (symbol_is_in_list(sc, func))) ? UNSAFE_BODY : body_is_safe(sc, func, body, true); /* (define (f f)...) */
+ clear_symbol_list(sc);
+
+ /* 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);
+ }
+ 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);
+ }
+ if (is_symbol(func))
+ {
+ 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);
+ 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 (is_symbol(func))
+ {
+ sc->temp1 = sc->unused;
+ free_cell(sc, lst);
+ }
+ sc->got_tc = false;
+ sc->not_tc = false;
+ sc->got_rec = false;
+ }
+}
+
+static int32_t check_lambda(s7_scheme *sc, s7_pointer form, bool opt)
+{
+ /* code is a lambda form: (lambda (a b) (+ a b)) */
+ /* this includes unevaluated symbols (direct symbol table refs) in macro arg list */
+ s7_pointer code, body;
+ int32_t arity = 0;
+
+ if ((sc->safety > NO_SAFETY) &&
+ (tree_is_cyclic(sc, form)))
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "lambda: body is cyclic: ~S", 26), form));
+
+ code = cdr(form);
+ if (!is_pair(code)) /* (lambda) or (lambda . 1) */
+ syntax_error_nr(sc, "lambda: no arguments? ~A", 24, form);
+
+ body = cdr(code);
+ if (!is_pair(body)) /* (lambda #f) */
+ syntax_error_nr(sc, "lambda: no body? ~A", 19, form);
+
+ /* in many cases, this is a no-op -- we already checked at define */
+ check_lambda_args(sc, car(code), &arity, sc->code);
+ /* clear_symbol_list(sc); */ /* not used in check_lambda_args and clobbers optimize_expression find_uncomplicated_symbol check */
+
+ /* look for (define f (let (...) (lambda ...))) and treat as equivalent to (define (f ...)...)
+ * one problem the hop=0 fixes is that safe closures assume the old let exists, so we need to check for define below
+ * I wonder about apply define...
+ */
+ /* OP_LET1 should work here also, (let ((f (lambda...)))), but subsequent calls assume a saved let if safe
+ * to mimic define, we need to parallel op_define_with_setter + make_funclet, I think
+ */
+ if ((opt) ||
+ (stack_top_op(sc) == OP_DEFINE1) ||
+ (((sc->stack_end - sc->stack_start) > 4) &&
+ (stack_top4_op(sc) == OP_DEFINE1) && /* surely if define is ok, so is define dilambda? 16-Apr-16 */
+ (sc->op_stack_now > sc->op_stack) &&
+ ((*(sc->op_stack_now - 1)) == (s7_pointer)global_value(sc->dilambda_symbol))))
+ 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)
+ 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)...)? */
+ set_opt3_any(code, (s7_pointer)((intptr_t)arity));
+ return(arity);
+}
+
+static s7_pointer op_lambda(s7_scheme *sc, s7_pointer code)
+{
+ int32_t arity = check_lambda(sc, code, false);
+ code = cdr(code);
+ set_opt3_any(code, (s7_pointer)((intptr_t)arity));
+ return(make_closure(sc, car(code), cdr(code), T_CLOSURE | ((arity < 0) ? T_COPY_ARGS : 0), arity));
+}
+
+static inline s7_pointer op_lambda_unchecked(s7_scheme *sc, s7_pointer code)
+{
+ int32_t arity = (int32_t)((intptr_t)opt3_any(cdr(code)));
+ return(make_closure_gc_checked(sc, cadr(code), cddr(code), T_CLOSURE | ((arity < 0) ? T_COPY_ARGS : 0), arity));
+}
+
+static void check_lambda_star(s7_scheme *sc)
+{
+ s7_pointer code = cdr(sc->code);
+ if ((sc->safety > NO_SAFETY) &&
+ (tree_is_cyclic(sc, sc->code)))
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "lambda*: body is cyclic: ~S", 27), sc->code));
+
+ if ((!is_pair(code)) ||
+ (!is_pair(cdr(code)))) /* (lambda*) or (lambda* #f) */
+ syntax_error_nr(sc, "lambda*: no arguments or no body? ~A", 36, sc->code);
+
+ set_car(code, check_lambda_star_args(sc, car(code), NULL, sc->code));
+ if ((sc->safety > NO_SAFETY) ||
+ (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));
+ }
+ else optimize_lambda(sc, false, sc->unused, car(code), cdr(code));
+
+ pair_set_syntax_op(sc->code, OP_LAMBDA_STAR_UNCHECKED);
+ sc->code = code;
+}
+
+
+/* -------------------------------- case -------------------------------- */
+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)));
+}
+
+static bool is_all_fxable(s7_scheme *sc, s7_pointer x)
+{
+ for (s7_pointer p = x; is_pair(p); p = cdr(p))
+ if (!is_fxable(sc, car(p)))
+ return(false);
+ return(true);
+}
+
+static s7_pointer check_case(s7_scheme *sc)
+{
+ /* we're not checking repeated or ridiculous (non-eqv?) keys here because they aren't errors */
+ bool keys_simple = true, has_feed_to = false, keys_single = true, bodies_simple = true, has_else = false, use_fx = true;
+ int32_t key_type = T_FREE;
+ s7_pointer x, carc, code = cdr(sc->code), form = sc->code;
+
+ if (!is_pair(code)) /* (case) or (case . 1) */
+ syntax_error_nr(sc, "case has no selector: ~S", 25, form);
+ if (!is_pair(cdr(code))) /* (case 1) or (case 1 . 1) */
+ syntax_error_nr(sc, "case has no clauses?: ~S", 25, form);
+ if (!is_pair(cadr(code))) /* (case 1 1) */
+ syntax_error_nr(sc, "case clause is not a pair? ~S", 29, form);
+ set_opt3_any(code, sc->unspecified);
+
+ for (x = cdr(code); is_pair(x); x = cdr(x))
+ {
+ 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)));
+ 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)));
+ if ((bodies_simple) &&
+ ((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));
+ }}}
+ 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)));
+ }
+ 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)));
+ 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)));
+ }}
+ if (is_not_null(x)) /* (case x ((1 2)) . 1) */
+ syntax_error_nr(sc, "case: stray dot? ~S", 19, form);
+
+ if ((keys_single) &&
+ (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));
+ }}}
+ 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));
+ }
+ if (key_type == T_INTEGER)
+ set_has_integer_keys(form);
+
+ /* X_Y_Z: X (selector): S=symbol, A=fxable, P=any, Y: E(keys simple) G(any keys) I(integer keys) , Z: S: no =>, bodies simple, keys single G: all else, -- ?? */
+ pair_set_syntax_op(form, OP_CASE_P_G_G); /* fallback on this */
+ if ((has_feed_to) ||
+ (!bodies_simple) || /* x_x_g g=general keys or bodies */
+ (!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);
+ }
+ 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);
+ }}
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }}}
+ carc = cadr(form);
+ if (!is_pair(carc))
+ {
+ sc->value = (is_symbol(carc)) ? lookup_checked(sc, carc) : carc;
+ return(NULL);
+ }
+ push_stack_no_args_direct(sc, OP_CASE_G_G);
+ sc->code = carc;
+ return(carc);
+}
+
+#if (!WITH_GMP)
+static bool op_case_i_s(s7_scheme *sc)
+{
+ s7_pointer selector = sc->value;
+ s7_pointer else_clause = opt3_any(cdr(sc->code));
+ 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);
+ }}
+ sc->code = else_clause;
+ return(false);
+ }
+ if (is_t_integer(selector))
+ {
+ 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);
+ }}
+ sc->value = sc->unspecified;
+ return(true);
+}
+
+static inline s7_pointer fx_case_a_i_s_a(s7_scheme *sc, s7_pointer code) /* inline saves about 30 in tleft */
+{
+ s7_pointer selector = fx_call(sc, cdr(code));
+ 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)
+ return(fx_call(sc, cdar(x)));
+ }
+ return(fx_call(sc, opt3_any(cdr(code))));
+}
+#endif
+
+static bool op_case_e_g_1(s7_scheme *sc, const s7_pointer selector, bool ok)
+{
+ s7_pointer x;
+ 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));
+ }
+ sc->value = sc->unspecified;
+ pop_stack(sc);
+ return(true);
+ }
+
+ sc->code = opt3_any(cdr(sc->code));
+ if (sc->code == sc->unused) /* set in check_case if no else clause */
+ sc->value = sc->unspecified;
+ else
+ if (is_pair(sc->code))
+ goto ELSE_CASE_2;
+ pop_stack(sc);
+ return(true);
+
+ ELSE_CASE_1:
+ /* x is the entire matching clause, (case 2 ((2) 3)), x: (((2) 3)) */
+ sc->code = T_Lst(cdar(x));
+ if (is_null(sc->code)) /* sc->value is already the selector */
+ {
+ pop_stack(sc);
+ return(true);
+ }
+
+ ELSE_CASE_2:
+ if (is_null(cdr(sc->code)))
+ {
+ sc->code = car(sc->code);
+ sc->cur_op = optimize_op(sc->code);
+ return(true);
+ }
+
+ if (is_undefined_feed_to(sc, car(sc->code)))
+ return(false);
+
+ 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);
+}
+
+static inline s7_pointer fx_call_all(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer p;
+ for (p = code; is_pair(cdr(p)); p = cdr(p))
+ fx_call(sc, p);
+ return(fx_call(sc, p));
+}
+
+static s7_pointer fx_case_a_s_g_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer selector = fx_call(sc, cdr(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));
+ }
+ return(fx_call_all(sc, opt3_any(cdr(code)))); /* selector is not a case-key */
+}
+
+#define if_pair_set_up_begin(Sc) if (is_pair(cdr(Sc->code))) {check_stack_size(Sc); push_stack_no_args(Sc, Sc->begin_op, cdr(Sc->code));} Sc->code = car(Sc->code);
+#define if_pair_set_up_begin_unchecked(Sc) if (is_pair(cdr(Sc->code))) push_stack_no_args(Sc, Sc->begin_op, cdr(Sc->code)); Sc->code = car(Sc->code);
+/* using the one_form bit here was slower */
+
+static bool op_case_g_g(s7_scheme *sc)
+{
+ s7_pointer x;
+ if (has_integer_keys(sc->code))
+ {
+ s7_int selector;
+ sc->code = cddr(sc->code);
+ if (is_t_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);
+ }}
+ 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;
+ }
+ sc->value = sc->unspecified;
+ pop_stack(sc);
+ return(true);
+ }
+ sc->code = cddr(sc->code);
+ 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));
+ }
+ 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 (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);
+ return(true);
+
+ ELSE_CASE:
+ /* x is the entire matching clause, (case 2 ((2) 3)), x: (((2) 3)) */
+ sc->code = T_Lst(cdar(x));
+ if (is_null(sc->code)) /* sc->value is already the selector */
+ {
+ pop_stack(sc);
+ return(true);
+ }
+ if (is_null(cdr(sc->code)))
+ {
+ sc->code = car(sc->code);
+ sc->cur_op = optimize_op(sc->code);
+ return(true);
+ }
+ if (is_undefined_feed_to(sc, car(sc->code)))
+ return(false);
+ if_pair_set_up_begin_unchecked(sc);
+ sc->cur_op = optimize_op(sc->code);
+ return(true);
+}
+
+static void op_case_e_s(s7_scheme *sc)
+{
+ s7_pointer selector = sc->value;
+ 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 = opt3_any(cdr(sc->code));
+}
+
+static s7_pointer fx_case_a_e_s_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer selector = fx_call(sc, cdr(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, opt3_any(cdr(code))));
+}
+
+static void op_case_g_s(s7_scheme *sc)
+{
+ s7_pointer selector = sc->value;
+ 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 = opt3_any(cdr(sc->code));
+}
+
+static inline s7_pointer fx_case_a_g_s_a(s7_scheme *sc, s7_pointer code) /* split into int/any cases in g_g, via has_integer_keys(sc->code) */
+{
+ s7_pointer selector = fx_call(sc, cdr(code));
+ for (s7_pointer x = cddr(code); is_pair(x); x = cdr(x))
+ if (s7_is_eqv(sc, opt2_any(x), selector))
+ return(fx_call(sc, cdar(x)));
+ return(fx_call(sc, opt3_any(cdr(code))));
+}
+
+
+/* -------------------------------- let -------------------------------- */
+static void check_let_a_body(s7_scheme *sc, s7_pointer form)
+{
+ s7_pointer code = cdr(form);
+ if (is_fxable(sc, cadr(code)))
+ {
+ fx_annotate_arg(sc, cdr(code), set_plist_1(sc, caaar(code))); /* was sc->curlet) ? */
+ fx_tree(sc, cdr(code), caaar(code), NULL, NULL, false);
+ pair_set_syntax_op(form, OP_LET_A_A_OLD);
+ }
+ 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);
+ }
+}
+
+static void check_let_one_var(s7_scheme *sc, s7_pointer form, s7_pointer start)
+{
+ s7_pointer binding = car(start), code = cdr(form);
+ if (is_pair(cadr(binding)))
+ {
+ /* this is not a named let */
+ pair_set_syntax_op(form, ((is_pair(cdr(code))) && (is_null(cddr(code)))) ? OP_LET_ONE_P_OLD : OP_LET_ONE_OLD);
+ 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);
+ }}}}
+ 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);
+ 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);
+ }}
+ 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);
+}
+
+static s7_pointer check_named_let(s7_scheme *sc, int32_t vars)
+{
+ s7_pointer code = cdr(sc->code);
+ set_opt2_int(code, vars);
+ if (vars == 0)
+ {
+ pair_set_syntax_op(sc->code, OP_NAMED_LET_NO_VARS);
+ set_opt1_pair(sc->code, cddr(code));
+ optimize_lambda(sc, true, car(code), sc->nil, cddr(code));
+ }
+ else
+ {
+ bool fx_ok = true;
+ pair_set_syntax_op(sc->code, OP_NAMED_LET);
+ /* this is (let name ...) so the initial values need to be removed from the closure arg list */
+
+ 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));
+ }
+ 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));
+ }
+ 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;
+ }
+ return(code);
+}
+
+static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */
+{
+ s7_pointer x, start, code = cdr(sc->code), form = sc->code;
+ bool named_let;
+ int32_t vars;
+
+ 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 form is an improper list? ~A", 32, form);
+ }
+
+ if (!is_pair(cdr(code))) /* (let () ) or (let () . 1) */
+ syntax_error_nr(sc, "let has no body: ~A", 19, form);
+
+ if ((!is_list(car(code))) && /* (let 1 ...) */
+ (!is_normal_symbol(car(code))))
+ syntax_error_nr(sc, "let variable list is messed up or missing: ~A", 45, form);
+
+ named_let = (is_symbol(car(code)));
+ if (named_let)
+ {
+ if (!is_list(cadr(code))) /* (let hi #t) */
+ 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_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));
+ set_local(car(code));
+ start = cadr(code);
+ }
+ else start = car(code);
+
+ clear_symbol_list(sc);
+ for (vars = 0, x = start; is_pair(x); vars++, x = cdr(x))
+ {
+ 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)));
+
+ 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)));
+
+ 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)));
+ 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_constant_symbol(sc, y))
+ 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));
+ add_symbol_to_list(sc, y);
+ set_local(y);
+ }
+ /* (let ('1) quote) -> 1 */
+
+ if (is_not_null(x)) /* (let* ((a 1) . b) a) */
+ syntax_error_nr(sc, "let variable list improper?: ~A", 31, form);
+
+ if (!s7_is_proper_list(sc, cdr(code))) /* (let ((a 1)) a . 1) */
+ syntax_error_nr(sc, "stray dot in let body: ~S", 25, cdr(code));
+
+ if (named_let)
+ return(check_named_let(sc, vars));
+
+ if (vars == 0) /* !in_heap does not happen much here */
+ pair_set_syntax_op(form, OP_LET_NO_VARS);
+ else
+ {
+ pair_set_syntax_op(form, OP_LET_UNCHECKED);
+ if (vars == 1)
+ 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));
+ }}}}
+
+ /* if safe_c or safe_closure as car(body), null cdr(body), see if only vars as args
+ * symbol_list is intact??
+ */
+ 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)));
+ else
+ {
+ set_optimize_op(form, optimize_op(form) + 1); /* *_old -> *_new */
+ set_opt3_let(code, sc->rootlet);
+ }}
+
+ /* fx_tree inits */
+ if ((is_pair(code)) &&
+ /* (is_let(sc->curlet)) && */ /* not rootlet=() but treeable is only in functions */
+ (is_fx_treeable(code)) && /* was is_funclet(sc->curlet) 27-Sep-21, but that seems too restrictive */
+ (tis_slot(let_slots(sc->curlet))))
+ {
+ 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);
+ }
+ 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);
+ }}
+ return(code);
+}
+
+static bool op_named_let_1(s7_scheme *sc, s7_pointer args) /* args = vals in decl order */
+{
+ s7_pointer body = cddr(sc->code), x;
+ s7_int n = opt2_int(sc->code);
+ for (x = cadr(sc->code), sc->w = sc->nil; is_pair(x); x = cdr(x))
+ {
+ sc->w = cons(sc, caar(x), sc->w);
+ x = cdr(x);
+ if (!is_pair(x)) break;
+ sc->w = cons_unchecked(sc, caar(x), sc->w);
+ }
+ sc->w = proper_list_reverse_in_place(sc, sc->w); /* init values (args) are also in "reversed" order */
+ set_curlet(sc, make_let(sc, sc->curlet));
+ sc->x = make_closure_unchecked(sc, sc->w, body, T_CLOSURE, n);
+ add_slot(sc, sc->curlet, car(sc->code), sc->x);
+ set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */
+
+ for (x = sc->w; is_not_null(args); x = cdr(x)) /* reuse the value cells as the new let slots */
+ {
+ s7_pointer sym = car(x), new_args = cdr(args);
+ reuse_as_slot(args, sym, unchecked_car(args)); /* args=slot, sym=symbol, car(args)=value */
+ slot_set_next(args, let_slots(sc->curlet));
+ let_set_slots(sc->curlet, args);
+ symbol_set_local_slot(sym, let_id(sc->curlet), args);
+ args = new_args;
+ }
+ closure_set_let(sc->x, sc->curlet);
+ let_set_slots(sc->curlet, reverse_slots(let_slots(sc->curlet)));
+ sc->x = sc->unused;
+ sc->code = T_Pair(body);
+ sc->w = sc->unused;
+ return(true);
+}
+
+static bool op_let1(s7_scheme *sc)
+{
+ s7_pointer x, y, e;
+ uint64_t id;
+ /* building a list, then reusing it below as the let/slots seems stupid, but if we make the let first, and
+ * add slots, there are other problems. The let/slot ids (and symbol_set_local_slot) need to wait
+ * until the args are evaluated, if an arg invokes call/cc, the let on the stack needs to be copied
+ * including let_dox_code if it is used to save sc->code (there are 3 things that need to be protected),
+ * (we win currently because copy_stack copies the list), and make-circular-iterator if called twice (s7test)
+ * hangs -- I can't see why! Otherwise, the let/slots approach is slightly faster (less than 1% however).
+ */
+ while (true)
+ {
+ sc->args = cons(sc, sc->value, sc->args);
+ if (is_pair(sc->code))
+ {
+ x = cdar(sc->code);
+ if (has_fx(x))
+ {
+#if S7_DEBUGGING
+ s7_pointer old_args = sc->args;
+#endif
+ 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);
+ }
+ else break;
+ }
+ x = proper_list_reverse_in_place(sc, sc->args);
+ sc->code = car(x); /* restore the original form */
+ y = cdr(x); /* use sc->args as the new let */
+ sc->temp8 = y;
+ set_curlet(sc, reuse_as_let(sc, x, T_Let(sc->curlet)));
+
+ if (is_symbol(car(sc->code)))
+ return(op_named_let_1(sc, y)); /* inner let here */
+
+ e = sc->curlet;
+ id = let_id(e);
+ if (is_pair(y))
+ {
+ s7_pointer sym, args = cdr(y), sp;
+ x = car(sc->code);
+ sym = caar(x);
+ reuse_as_slot(y, sym, unchecked_car(y)); /* if car(y) is a multiple value, should we clear it? How did it get there? */
+ symbol_set_local_slot(sym, id, y);
+ let_set_slots(e, y);
+ sp = y;
+ 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;
+ }
+ slot_set_next(sp, slot_end);
+ }
+ sc->code = T_Pair(cdr(sc->code));
+ sc->temp8 = sc->unused;
+ return(true);
+}
+
+static bool op_let(s7_scheme *sc)
+{
+ /* sc->code is everything after the let: (let ((a 1)) a) so sc->code is (((a 1)) a) */
+ /* car can be either a list or a symbol ("named let") */
+ bool named_let;
+
+ sc->code = check_let(sc);
+ sc->value = sc->code;
+ named_let = is_symbol(car(sc->code));
+ sc->code = (named_let) ? cadr(sc->code) : car(sc->code);
+ if (is_null(sc->code)) /* (let [name] () ...): no bindings, so skip that step */
+ {
+ 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;
+ }
+ else sc->code = T_Pair(cdr(sc->code));
+ return(true);
+ }
+ sc->args = sc->nil;
+ return(op_let1(sc));
+}
+
+static bool op_let_unchecked(s7_scheme *sc) /* not named, but has vars */
+{
+ s7_pointer code = cadr(sc->code);
+ s7_pointer x = cdar(code);
+ sc->args = list_1(sc, cdr(sc->code));
+ if (has_fx(x))
+ sc->value = fx_call(sc, x);
+ else
+ {
+ push_stack(sc, OP_LET1, sc->args, cdr(code));
+ sc->code = car(x);
+ return(false); /* goto EVAL */
+ }
+ sc->code = cdr(code);
+ return(op_let1(sc));
+}
+
+static bool op_named_let(s7_scheme *sc)
+{
+ sc->args = sc->nil;
+ sc->value = cdr(sc->code);
+ sc->code = cadr(sc->value);
+ return(op_let1(sc));
+}
+
+static void op_named_let_no_vars(s7_scheme *sc)
+{
+ s7_pointer arg = cadr(sc->code);
+ sc->code = opt1_pair(sc->code); /* cdddr(sc->code) */
+ set_curlet(sc, inline_make_let(sc, sc->curlet));
+ sc->args = make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE, 0); /* sc->args is a temp here */
+ add_slot_checked(sc, sc->curlet, arg, sc->args);
+ set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */
+}
+
+static void op_named_let_a(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ sc->code = cddr(args);
+ sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) */
+ set_curlet(sc, make_let(sc, sc->curlet));
+ sc->w = list_1_unchecked(sc, car(opt1_pair(args))); /* caaadr(args), subsequent calls will need a normal list of pars in closure_args */
+ sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 1); /* picks up curlet (this is the funclet?) */
+ add_slot(sc, sc->curlet, car(args), sc->x); /* the function */
+ set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(sc->w), sc->args)); /* inner let */
+ closure_set_let(sc->x, sc->curlet);
+ sc->x = sc->unused;
+ sc->w = sc->unused;
+}
+
+static void op_named_let_aa(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ sc->code = cddr(args);
+ sc->args = fx_call(sc, cdr(opt1_pair(args))); /* cdaadr(args) == init val of first par */
+ sc->value = fx_call(sc, cdr(opt3_pair(args))); /* cdadadr = init val of second */
+ set_curlet(sc, make_let(sc, sc->curlet));
+ sc->w = list_2_unchecked(sc, car(opt1_pair(args)), car(opt3_pair(args))); /* subsequent calls will need a normal list of pars in closure_args */
+ sc->x = make_closure_unchecked(sc, sc->w, sc->code, T_CLOSURE, 2); /* picks up curlet (this is the funclet?) */
+ add_slot(sc, sc->curlet, car(args), sc->x); /* the function */
+ set_curlet(sc, inline_make_let_with_two_slots(sc, sc->curlet, car(sc->w), sc->args, cadr(sc->w), sc->value)); /* inner let */
+ closure_set_let(sc->x, sc->curlet);
+ sc->x = sc->unused;
+ sc->w = sc->unused;
+}
+
+static bool op_named_let_na(s7_scheme *sc)
+{
+ sc->code = cdr(sc->code);
+ sc->args = sc->nil;
+ for (s7_pointer p = cadr(sc->code); is_pair(p); p = cdr(p))
+ {
+ sc->args = cons(sc, sc->value = fx_call(sc, cdar(p)), sc->args);
+ p = cdr(p);
+ if (!is_pair(p)) break;
+ sc->args = cons_unchecked(sc, sc->value = fx_call(sc, cdar(p)), sc->args);
+ }
+ sc->args = proper_list_reverse_in_place(sc, sc->args);
+ return(op_named_let_1(sc, sc->args)); /* sc->code = (name vars . body), args = vals in decl order, op_named_let_1 handles inner let */
+}
+
+static void op_let_no_vars(s7_scheme *sc)
+{
+ set_curlet(sc, inline_make_let(sc, sc->curlet));
+ sc->code = T_Pair(cddr(sc->code)); /* ignore the () */
+}
+
+static void op_let_one_new(s7_scheme *sc)
+{
+ sc->code = cdr(sc->code);
+ /* check_stack_size(sc) -- needed if we're in an infinite loop -- maybe let it trigger "stack too big" instead */
+ /* e.g. (let ((set! let*)) (let* set! ((x 1234) (y 1/2)) (let ((<1> (list 1 #f))) (set! (<1> 1) ...)))) */
+ push_stack_no_args(sc, OP_LET_ONE_NEW_1, cdr(sc->code));
+ sc->code = opt2_pair(sc->code);
+}
+
+static void op_let_one_p_new(s7_scheme *sc)
+{
+ sc->code = cdr(sc->code);
+ check_stack_size(sc); /* hit in (lint "s7test.scm") */
+ push_stack_no_args(sc, OP_LET_ONE_P_NEW_1, cdr(sc->code));
+ sc->code = T_Pair(opt2_pair(sc->code));
+}
+
+static void op_let_one_old(s7_scheme *sc)
+{
+ sc->code = cdr(sc->code);
+ push_stack_no_args_direct(sc, OP_LET_ONE_OLD_1);
+ sc->code = opt2_pair(sc->code);
+}
+
+static void op_let_one_old_1(s7_scheme *sc)
+{
+ s7_pointer let = update_let_with_slot(sc, opt3_let(sc->code), sc->value);
+ let_set_outlet(let, sc->curlet);
+ set_curlet(sc, let);
+ sc->code = cdr(sc->code);
+}
+
+static void op_let_one_p_old(s7_scheme *sc)
+{
+ sc->code = cdr(sc->code);
+ push_stack_no_args_direct(sc, OP_LET_ONE_P_OLD_1);
+ sc->code = T_Pair(opt2_pair(sc->code));
+}
+
+static void op_let_one_p_old_1(s7_scheme *sc)
+{
+ s7_pointer let = update_let_with_slot(sc, opt3_let(sc->code), sc->value);
+ let_set_outlet(let, sc->curlet);
+ set_curlet(sc, let);
+ sc->code = cadr(sc->code);
+}
+
+static Inline void inline_op_let_a_new(s7_scheme *sc) /* three calls in eval, all get hits */
+{
+ sc->code = cdr(sc->code);
+ set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(opt2_pair(sc->code)), fx_call(sc, cdr(opt2_pair(sc->code)))));
+}
+
+static Inline void inline_op_let_a_old(s7_scheme *sc) /* tset(2) fb(0) cb(4) left(2) */
+{
+ s7_pointer let;
+ sc->code = cdr(sc->code);
+ let = update_let_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code))));
+ let_set_outlet(let, sc->curlet);
+ set_curlet(sc, let);
+}
+
+static inline void op_let_a_old(s7_scheme *sc) {return(inline_op_let_a_old(sc));}
+
+static void op_let_a_a_new(s7_scheme *sc)
+{
+ s7_pointer binding;
+ sc->code = cdr(sc->code);
+ binding = opt2_pair(sc->code);
+ set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(binding), fx_call(sc, cdr(binding))));
+ sc->value = fx_call(sc, cdr(sc->code));
+ /* free_cell(sc, sc->curlet); *//* t101-aux-3 and t725+unlet */ /* don't free let_slots here unless checked first (can be null after fx_call above?) */
+ /* upon return, we continue, so sc->curlet should be ok */
+}
+
+static void op_let_a_a_old(s7_scheme *sc) /* these are not called as fx*, and restoring sc->curlet has noticeable cost (e.g. 8 in thash) */
+{
+ s7_pointer let;
+ sc->code = cdr(sc->code);
+ let = update_let_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code))));
+ let_set_outlet(let, sc->curlet);
+ set_curlet(sc, let);
+ sc->value = fx_call(sc, cdr(sc->code));
+}
+
+static void op_let_a_na_new(s7_scheme *sc)
+{
+ s7_pointer binding, p;
+ sc->code = cdr(sc->code);
+ binding = opt2_pair(sc->code);
+ set_curlet(sc, make_let_with_slot(sc, sc->curlet, car(binding), fx_call(sc, cdr(binding))));
+ for (p = cdr(sc->code); is_pair(cdr(p)); p = cdr(p)) fx_call(sc, p);
+ sc->value = fx_call(sc, p);
+ free_cell(sc, sc->curlet); /* possibly unsafe */ /* see above */
+}
+
+/* this and others like it could easily be fx funcs, but check_let is called too late, so it's never seen as fxable */
+static void op_let_a_na_old(s7_scheme *sc)
+{
+ s7_pointer let, p;
+ sc->code = cdr(sc->code);
+ let = update_let_with_slot(sc, opt3_let(sc->code), fx_call(sc, cdr(opt2_pair(sc->code))));
+ let_set_outlet(let, sc->curlet);
+ set_curlet(sc, let);
+ for (p = cdr(sc->code); is_pair(cdr(p)); p = cdr(p)) fx_call(sc, p);
+ sc->value = fx_call(sc, p);
+}
+
+static inline void op_let_opassq(s7_scheme *sc)
+{
+ s7_pointer in_val, lst;
+ sc->code = cdr(sc->code);
+ in_val = lookup(sc, opt2_sym(sc->code)); /* cadadr(caar(sc->code)); */
+ lst = lookup(sc, opt3_sym(cdr(sc->code)));
+ if (is_pair(lst))
+ sc->value = s7_assq(sc, in_val, lst);
+ else sc->value = (is_null(lst)) ? sc->F : g_assq(sc, set_plist_2(sc, in_val, lst));
+}
+
+static inline void op_let_opassq_old(s7_scheme *sc)
+{
+ s7_pointer let;
+ op_let_opassq(sc);
+ let = update_let_with_slot(sc, opt3_let(sc->code), sc->value);
+ let_set_outlet(let, sc->curlet);
+ set_curlet(sc, let);
+ sc->code = T_Pair(cdr(sc->code));
+}
+
+static inline void op_let_opassq_new(s7_scheme *sc)
+{
+ op_let_opassq(sc);
+ set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt1_sym(sc->code), sc->value));
+ sc->code = T_Pair(cdr(sc->code));
+}
+
+static Inline void inline_op_let_na_new(s7_scheme *sc) /* called once in eval, case gsl lg mock */
+{
+ s7_pointer let, sp = NULL;
+ new_cell(sc, let, T_LET | T_SAFE_PROCEDURE);
+ let_set_id(let, sc->let_number + 1);
+ let_set_slots(let, slot_end);
+ let_set_outlet(let, T_Let(sc->curlet));
+ sc->args = let;
+ for (s7_pointer p = cadr(sc->code); is_pair(p); p = cdr(p))
+ {
+ 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);
+ }
+ else sp = inline_add_slot_at_end(sc, let_id(let), sp, caar(p), sc->value);
+ }
+ sc->let_number++;
+ set_curlet(sc, let);
+ sc->code = T_Pair(cddr(sc->code));
+}
+
+static void op_let_na_old(s7_scheme *sc)
+{
+ s7_pointer let = opt3_let(cdr(sc->code));
+ s7_pointer slot = let_slots(let);
+ uint64_t id = ++sc->let_number;
+ sc->args = let;
+ let_set_id(let, id);
+ let_set_outlet(let, sc->curlet);
+ for (s7_pointer p = cadr(sc->code); is_pair(p); p = cdr(p), slot = next_slot(slot))
+ {
+ /* GC protected because it's a semipermanent let? or perhaps use sc->args? */
+ slot_set_value(slot, fx_call(sc, cdar(p)));
+ symbol_set_local_slot_unincremented(slot_symbol(slot), id, slot);
+ }
+ set_curlet(sc, let);
+ sc->code = T_Pair(cddr(sc->code));
+}
+
+static void op_let_2a_new(s7_scheme *sc) /* 2 vars, 1 expr in body */
+{
+ s7_pointer code = cdr(sc->code);
+ s7_pointer a1 = opt1_pair(code); /* caar(code) */
+ s7_pointer a2 = opt2_pair(code); /* cadar(code) */
+ set_curlet(sc, inline_make_let_with_two_slots(sc, sc->curlet, car(a1), fx_call(sc, cdr(a1)), car(a2), fx_call(sc, cdr(a2))));
+ sc->code = cadr(code);
+}
+
+static inline void op_let_2a_old(s7_scheme *sc) /* 2 vars, 1 expr in body */
+{
+ s7_pointer code = cdr(sc->code);
+ s7_pointer let = update_let_with_two_slots(sc, opt3_let(code), fx_call(sc, cdr(opt1_pair(code))), fx_call(sc, cdr(opt2_pair(code))));
+ let_set_outlet(let, sc->curlet);
+ set_curlet(sc, let);
+ sc->code = cadr(code);
+}
+
+static void op_let_3a_new(s7_scheme *sc) /* 3 vars, 1 expr in body */
+{
+ s7_pointer code = cdr(sc->code);
+ s7_pointer a1 = caar(code);
+ s7_pointer a2 = opt1_pair(code); /* cadar */
+ s7_pointer a3 = opt2_pair(code); /* caddar */
+ gc_protect_via_stack(sc, fx_call(sc, cdr(a1))); /* fx_call might be fx_car_t (etc) so it needs to precede the new let */
+ set_stack_protected2(sc, fx_call(sc, cdr(a2)));
+ set_curlet(sc, inline_make_let_with_two_slots(sc, sc->curlet, car(a2), stack_protected2(sc), car(a3), fx_call(sc, cdr(a3))));
+ add_slot(sc, sc->curlet, car(a1), stack_protected1(sc));
+ unstack_gc_protect(sc);
+ sc->code = cadr(code);
+}
+
+static void op_let_3a_old(s7_scheme *sc) /* 3 vars, 1 expr in body */
+{
+ s7_pointer code = cdr(sc->code);
+ s7_pointer let = update_let_with_three_slots(sc, opt3_let(code), fx_call(sc, cdr(caar(code))), fx_call(sc, cdr(opt1_pair(code))), fx_call(sc, cdr(opt2_pair(code))));
+ let_set_outlet(let, sc->curlet);
+ set_curlet(sc, let);
+ sc->code = cadr(code);
+}
+
+
+/* -------------------------------- let* -------------------------------- */
+static bool check_let_star(s7_scheme *sc)
+{
+ s7_pointer vars, form = sc->code, code = cdr(sc->code);
+ bool named_let, fxable = true, shadowing = false;
+
+ if (!is_pair(code)) /* (let* . 1) */
+ syntax_error_nr(sc, "let* variable list is messed up: ~A", 35, form);
+ if (!is_pair(cdr(code))) /* (let* ()) */
+ syntax_error_nr(sc, "let* has no body: ~A", 20, form);
+
+ named_let = (is_symbol(car(code)));
+
+ if (named_let)
+ {
+ if (!is_list(cadr(code))) /* (let* hi #t) */
+ 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_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));
+ set_local(car(code));
+ }
+ else
+ if (!is_list(car(code))) /* (let* x ... ) */
+ syntax_error_nr(sc, "let* variable declaration value is missing: ~A", 46, form);
+
+ clear_symbol_list(sc);
+ for (vars = ((named_let) ? cadr(code) : car(code)); is_pair(vars); vars = cdr(vars))
+ {
+ 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)));
+
+ 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(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)));
+
+ 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)));
+
+ 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));
+
+ 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)));
+ /* currently (let* ((a 1) (a (+ a 1))) a) is 2, not an error */
+
+ if (symbol_is_in_list(sc, var)) shadowing = true;
+ add_symbol_to_list(sc, var);
+ set_local(var);
+ }
+ 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)));
+
+ if (!s7_is_proper_list(sc, cdr(code)))
+ syntax_error_nr(sc, "stray dot in let* body: ~S", 26, cdr(code));
+
+ if (shadowing)
+ fxable = false;
+ 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));
+ 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));
+ }
+ else
+ {
+ 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);
+ }
+ 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 */
+ return(true);
+ }
+ if (is_null(car(code)))
+ {
+ pair_set_syntax_op(form, OP_LET_NO_VARS); /* (let* () ...) */
+ set_curlet(sc, make_let(sc, sc->curlet));
+ sc->code = T_Pair(cdr(code));
+ return(false);
+ }
+ 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);
+ }}}
+ 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));
+ }
+ 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 */
+ sc->code = cadr(caar(code));
+ /* caar(code) = first var/val pair, we've checked that all these guys are legit, so cadr of that is the value */
+ return(true);
+}
+
+static bool op_let_star_shadowed(s7_scheme *sc)
+{
+ while (true)
+ {
+ 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);
+ }}
+ else break;
+ }
+ sc->code = cdr(sc->args); /* original sc->code set in push_stack above */
+ return(false);
+}
+
+static inline bool op_let_star1(s7_scheme *sc)
+{
+ uint64_t let_counter = S7_INT64_MAX;
+ s7_pointer sp = NULL;
+ 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);
+ }
+ 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;
+ }
+ 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);
+ }}
+ else break;
+ }
+ sc->code = sc->args; /* original sc->code set in push_stack above */
+ if (is_symbol(car(sc->code)))
+ {
+ s7_pointer name = car(sc->code), body = cddr(sc->code), args = cadr(sc->code);
+ /* 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);
+ }
+ 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));
+
+ sc->code = body;
+ }
+ else sc->code = T_Pair(cdr(sc->code));
+ return(false);
+}
+
+static void op_let_star_na(s7_scheme *sc)
+{
+ /* fx safe does not mean we can dispense with the inner lets (curlet is safe for example) */
+ s7_pointer sp = NULL;
+ uint64_t let_counter = S7_INT64_MAX;
+ sc->code = cdr(sc->code);
+ for (s7_pointer p = car(sc->code); is_pair(p); p = cdr(p))
+ {
+ 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);
+ }
+ 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;
+ }}
+ sc->code = T_Pair(cdr(sc->code));
+}
+
+static void op_let_star_na_a(s7_scheme *sc)
+{
+ s7_pointer sp = NULL;
+ uint64_t let_counter = S7_INT64_MAX;
+ sc->code = cdr(sc->code);
+ for (s7_pointer p = car(sc->code); is_pair(p); p = cdr(p))
+ {
+ 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);
+ }
+ 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;
+ }}
+ sc->value = fx_call(sc, cdr(sc->code));
+}
+
+static void op_named_let_star(s7_scheme *sc)
+{
+ s7_pointer code = cdr(sc->code); /* code: (name vars ...) */
+ set_curlet(sc, make_let(sc, sc->curlet));
+ push_stack(sc, OP_LET_STAR1, code, cadr(code));
+ sc->code = opt2_con(code);
+}
+
+static void op_let_star2(s7_scheme *sc)
+{
+ s7_pointer code = cdr(sc->code);
+ push_stack(sc, OP_LET_STAR1, code, car(code));
+ sc->code = opt2_con(code);
+}
+
+
+/* -------------------------------- letrec, letrec* -------------------------------- */
+static void check_letrec(s7_scheme *sc, bool letrec)
+{
+ s7_pointer x, code = cdr(sc->code);
+ s7_pointer caller = (letrec) ? sc->letrec_symbol : sc->letrec_star_symbol;
+
+ if ((!is_pair(code)) || /* (letrec . 1) */
+ (!is_list(car(code)))) /* (letrec 1 ...) */
+ syntax_error_with_caller_nr(sc, "~A: variable list is messed up: ~A", 34, caller, sc->code);
+
+ if (!is_pair(cdr(code))) /* (letrec ()) */
+ syntax_error_with_caller_nr(sc, "~A has no body: ~A", 18, caller, sc->code);
+
+ clear_symbol_list(sc);
+ for (x = car(code); is_not_null(x); x = cdr(x))
+ {
+ 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);
+
+ 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);
+
+ 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)));
+ if (is_constant_symbol(sc, y))
+ 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_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);
+
+ /* 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);
+ add_symbol_to_list(sc, y);
+ set_local(y);
+ }
+
+ if (!s7_is_proper_list(sc, cdr(code)))
+ syntax_error_with_caller_nr(sc, "stray dot in ~A body: ~S", 24, caller, cdr(code));
+
+ for (x = car(code); is_pair(x); x = cdr(x))
+ if (is_fxable(sc, cadar(x)))
+ set_fx_direct(cdar(x), fx_choose(sc, cdar(x), sc->curlet, let_symbol_is_safe_or_listed));
+
+ pair_set_syntax_op(sc->code, (letrec) ? OP_LETREC_UNCHECKED : OP_LETREC_STAR_UNCHECKED);
+}
+
+static s7_pointer make_funclet(s7_scheme *sc, s7_pointer new_func, s7_pointer func_name, s7_pointer outer_let);
+
+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));
+ }
+}
+
+static void op_letrec2(s7_scheme *sc)
+{
+ for (s7_pointer slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot))
+ if (is_checked_slot(slot))
+ slot_set_value(slot, slot_pending_value(slot));
+ letrec_setup_closures(sc);
+}
+
+static bool op_letrec_unchecked(s7_scheme *sc)
+{
+ s7_pointer code = cdr(sc->code);
+ /* get all local vars and set to #<undefined>
+ * get parallel list of values
+ * eval each member of values list with let still full of #<undefined>'s
+ * assign each value to its variable
+ * eval body
+ * which means that (letrec ((x x)) x) is not an error!
+ * but this assumes the environment is not changed by evaluating the exprs?
+ * (letrec ((a (define b 1))) b) -- if let, the define takes place in the calling let, not the current let
+ * (letrec ((f1 (lambda (x) (f2 (* 2 x))))) (define (f2 y) (- y 1)) (f1 3)) -> 5 (Guile says unbound f2)
+ * I think I need to check here that slot_pending_value is set (using the is_checked bit below):
+ * (letrec ((i (begin (define xyz 37) 0))) (curlet)): (inlet 'i 0 'xyz 37) -- is this correct?
+ */
+ set_curlet(sc, make_let(sc, sc->curlet));
+ if (is_pair(car(code)))
+ {
+ 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);
+ }
+ 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)));
+ if (tis_slot(slot))
+ {
+ push_stack(sc, OP_LETREC1, slot, code);
+ sc->code = car(slot_expression(slot));
+ return(true);
+ }
+ op_letrec2(sc);
+ }
+ sc->code = T_Pair(cdr(code));
+ return(false);
+}
+
+static bool op_letrec1(s7_scheme *sc)
+{
+ s7_pointer slot;
+ slot_set_pending_value(sc->args, sc->value);
+ for (slot = next_slot(sc->args); tis_slot(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot))
+ slot_set_pending_value(slot, fx_call(sc, slot_expression(slot)));
+ if (tis_slot(slot))
+ {
+ push_stack(sc, OP_LETREC1, slot, sc->code);
+ sc->code = car(slot_expression(slot));
+ return(true);
+ }
+ op_letrec2(sc);
+ sc->code = T_Pair(cdr(sc->code));
+ return(false);
+}
+
+
+static bool op_letrec_star_unchecked(s7_scheme *sc)
+{
+ s7_pointer code = cdr(sc->code);
+ /* get all local vars and set to #<undefined>
+ * eval each member of values list and assign immediately, as in let*
+ * eval body
+ */
+ set_curlet(sc, make_let(sc, sc->curlet));
+ if (is_pair(car(code)))
+ {
+ 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));
+ }
+ 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)));
+ if (tis_slot(slot))
+ {
+ push_stack(sc, OP_LETREC_STAR1, slot, code);
+ sc->code = car(slot_expression(slot));
+ return(true);
+ }}
+ sc->code = T_Pair(cdr(code));
+ return(false);
+}
+
+static bool op_letrec_star1(s7_scheme *sc)
+{
+ s7_pointer slot = sc->args;
+ slot_set_value(slot, sc->value);
+
+ for (slot = next_slot(slot); tis_slot(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot))
+ slot_set_value(slot, fx_call(sc, slot_expression(slot)));
+ if (tis_slot(slot))
+ {
+ push_stack(sc, OP_LETREC_STAR1, slot, sc->code);
+ sc->code = car(slot_expression(slot));
+ return(true);
+ }
+ letrec_setup_closures(sc);
+ sc->code = T_Pair(cdr(sc->code));
+ return(false);
+}
+
+
+/* -------------------------------- let-temporarily -------------------------------- */
+static void check_let_temporarily(s7_scheme *sc)
+{
+ s7_pointer x, form = sc->code, code = cdr(sc->code);
+ bool all_fx, all_s7;
+
+ if ((!is_pair(code)) || /* (let-temporarily . 1) */
+ (!is_list(car(code)))) /* (let-temporarily 1 ...) */
+ syntax_error_nr(sc, "let-temporarily: variable list is messed up: ~A", 47, form);
+ /* cdr(code) = body can be nil */
+
+ all_fx = is_pair(car(code));
+ all_s7 = all_fx;
+
+ for (x = car(code); is_not_null(x); x = cdr(x))
+ {
+ 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);
+
+ 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);
+
+ 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));
+ }
+ 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(cdr(carx))) /* (let-temporarily ((x . 1))...) */
+ 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);
+
+ if ((all_fx) &&
+ ((!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;
+ }
+ if (!s7_is_proper_list(sc, cdr(code)))
+ syntax_error_nr(sc, "stray dot in let-temporarily body: ~S", 37, cdr(code));
+
+ if ((all_fx) || (all_s7))
+ {
+ 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);
+
+ 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);
+ }
+ 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 ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) {fx_curlet_tree(sc, code); fx_curlet_tree_in(sc, code);}
+ }
+ else
+ {
+ 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);
+ }}}}
+}
+
+static void op_let_temp_unchecked(s7_scheme *sc)
+{
+ sc->code = cdr(sc->code); /* step past let-temporarily */
+ sc->args = list_4(sc, car(sc->code), sc->nil, sc->nil, sc->nil);
+ push_stack_direct(sc, OP_GC_PROTECT);
+ /* sc->args: varlist, settees, old_values, new_values */
+}
+
+static void op_let_temp_init1_1(s7_scheme *sc)
+{
+ if ((is_symbol(sc->value)) && (is_symbol_from_symbol(sc->value))) /* (let-temporarily (((symbol ...))) ..) */
+ {
+ 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));
+ sc->value = s7_symbol_value(sc, sc->value);
+ }
+ set_caddr(sc->args, cons(sc, sc->value, caddr(sc->args)));
+}
+
+static bool op_let_temp_init1(s7_scheme *sc)
+{
+ while (is_pair(car(sc->args)))
+ {
+ /* eval car, add result to old-vals list, if any vars undefined, error */
+ s7_pointer binding = caar(sc->args);
+ s7_pointer settee = car(binding);
+ s7_pointer new_value = cadr(binding);
+ set_cadr(sc->args, cons(sc, settee, cadr(sc->args)));
+ binding = cdddr(sc->args);
+ 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)));
+ 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)));
+ }}
+ 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;
+
+static goto_t op_let_temp_init2(s7_scheme *sc)
+{
+ /* now eval set car new-val, cadr=settees, cadddr=new_values */
+ while (is_pair(car(sc->args)))
+ {
+ s7_pointer settee = caar(sc->args), slot, p = cdddr(sc->args);
+ s7_pointer new_value = caar(p);
+ 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);
+ }
+ slot = s7_slot(sc, settee);
+ if (!is_slot(slot))
+ 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));
+ if (is_symbol(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));
+ /* pop_stack(sc); */ /* this clobbers sc->args! 7-May-22 */
+ unstack_gc_protect(sc); /* pop_stack_no_args(sc) in effect */
+ sc->code = cdr(stack_end_code(sc));
+ if (is_pair(sc->code))
+ {
+ push_stack_direct(sc, OP_LET_TEMP_DONE);
+ return(goto_begin);
+ }
+ sc->value = sc->nil; /* so (let-temporarily (<vars)) -> () like begin I guess */
+ return(fall_through);
+}
+
+static bool op_let_temp_done1(s7_scheme *sc)
+{
+ while (is_pair(car(sc->args)))
+ {
+ s7_pointer settee = caar(sc->args), p = cddr(sc->args);
+ sc->value = caar(p);
+ set_car(p, cdar(p));
+ 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);
+ }
+ 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);
+ }}
+ pop_stack(sc); /* not unstack */
+ sc->value = sc->code;
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+ return(true); /* goto start */
+}
+
+static bool *s7_starlet_immutable_field = NULL;
+
+static bool op_let_temp_s7(s7_scheme *sc) /* all entries are of the form ((*s7* 'field) fx-able-value) */
+{
+ s7_pointer p, code = cdr(sc->code); /* don't use sc->code here -- it can be changed */
+ s7_pointer *end = sc->stack_end;
+ for (p = car(code); is_pair(p); p = cdr(p))
+ {
+ 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));
+ old_value = s7_starlet(sc, s7_starlet_symbol(field));
+ push_stack(sc, OP_LET_TEMP_S7_UNWIND, old_value, field);
+ }
+ for (p = car(code); is_pair(p); p = cdr(p), end += 4)
+ s7_starlet_set_1(sc, T_Sym(end[0]), fx_call(sc, cdar(p)));
+ sc->code = cdr(code);
+ return(is_pair(sc->code)); /* sc->code can be null if no body */
+}
+
+static void op_let_temp_s7_unwind(s7_scheme *sc)
+{
+ s7_starlet_set_1(sc, T_Sym(sc->code), sc->args);
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+}
+
+static bool op_let_temp_s7_direct(s7_scheme *sc)
+{
+ s7_pointer new_val;
+ push_stack_no_code(sc, OP_LET_TEMP_S7_DIRECT_UNWIND, (sc->has_openlets) ? sc->T : sc->F);
+ new_val = fx_call(sc, opt1_pair(sc->code));
+ sc->has_openlets = (new_val != sc->F);
+ sc->code = cddr(sc->code); /* cddr is body of let-temp */
+ return(is_pair(sc->code));
+}
+
+static void op_let_temp_s7_direct_unwind(s7_scheme *sc)
+{
+ sc->has_openlets = (sc->args != sc->F);
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+}
+
+static void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer let)
+{
+ /* called in call/cc, call-with-exit and, catch (unwind to catch) */
+ check_stack_size(sc);
+ push_stack_direct(sc, OP_GC_PROTECT);
+ sc->args = T_Ext(args);
+ set_curlet(sc, let);
+ op_let_temp_done1(sc);
+}
+
+static void let_temp_unwind(s7_scheme *sc, s7_pointer slot, s7_pointer new_value)
+{
+ if (slot_has_setter(slot)) /* setter has to be called because it might affect other vars (*clm-srate* -> mus-srate etc), but it should not change sc->value */
+ {
+ s7_pointer old_value = sc->value;
+ slot_set_value(slot, call_setter(sc, slot, new_value)); /* s7_apply_function(sc, slot_setter(slot), set_plist_2(sc, slot_symbol(slot), new_value))); */
+ sc->value = old_value;
+ }
+ else slot_set_value(slot, new_value);
+}
+
+static void op_let_temp_unwind(s7_scheme *sc)
+{
+ let_temp_unwind(sc, sc->code, sc->args);
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+}
+
+static bool op_let_temp_na(s7_scheme *sc) /* all entries are of the form (symbol fx-able-value) */
+{
+ s7_pointer p, slot;
+ s7_pointer *end = sc->stack_end;
+ sc->code = cdr(sc->code);
+
+ for (p = car(sc->code); is_pair(p); p = cdr(p))
+ {
+ s7_pointer var = car(p);
+ s7_pointer settee = car(var);
+ slot = s7_slot(sc, settee);
+ if (!is_slot(slot))
+ 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));
+ push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot);
+ }
+ for (p = car(sc->code); is_pair(p); p = cdr(p), end += 4)
+ {
+ s7_pointer var = car(p);
+ 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))); */
+ else slot_set_value(slot, new_val);
+ }
+ sc->code = cdr(sc->code);
+ return(is_pair(sc->code)); /* sc->code can be null if no body */
+}
+
+static bool op_let_temp_a(s7_scheme *sc) /* one entry */
+{
+ s7_pointer var, settee, new_val, slot;
+ sc->code = cdr(sc->code);
+ var = caar(sc->code);
+ settee = car(var);
+ slot = s7_slot(sc, settee);
+ if (!is_slot(slot))
+ 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));
+ push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot);
+ new_val = fx_call(sc, cdr(var));
+ 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))); */
+ else slot_set_value(slot, new_val);
+ sc->code = cdr(sc->code);
+ return(is_pair(sc->code)); /* sc->code can be null if no body */
+}
+
+static s7_pointer fx_let_temp_a_a(s7_scheme *sc, s7_pointer code) /* one entry, body is fx'd */
+{
+ s7_pointer result;
+ op_let_temp_a(sc);
+ result = fx_call(sc, sc->code);
+ pop_stack(sc);
+ let_temp_unwind(sc, sc->code, sc->args);
+ return(result);
+}
+
+static bool op_let_temp_setter(s7_scheme *sc)
+{
+ s7_pointer var, slot, sym, e = sc->curlet;
+ sc->code = cdr(sc->code);
+ var = caaar(sc->code);
+ sym = fx_call(sc, cdr(var));
+ set_curlet(sc, fx_call(sc, cddr(var)));
+ slot = s7_slot(sc, sym);
+ set_curlet(sc, e);
+ push_stack(sc, OP_LET_TEMP_SETTER_UNWIND, slot_setter(slot), slot);
+ slot_set_setter(slot, sc->F);
+ sc->code = cdr(sc->code);
+ return(is_pair(sc->code)); /* sc->code can be null if no body */
+}
+
+static void op_let_temp_setter_unwind(s7_scheme *sc)
+{
+ slot_set_setter(sc->code, sc->args);
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+}
+
+
+/* -------------------------------- quote -------------------------------- */
+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: stray dot?: ~A", 21, code);
+ }
+ if (is_not_null(cddr(code))) /* (quote . (1 2)) or (quote 1 1) */
+ syntax_error_nr(sc, "quote: too many arguments ~A", 28, code);
+ pair_set_syntax_op(code, OP_QUOTE_UNCHECKED);
+ return(cadr(code));
+}
+
+
+/* -------------------------------- and -------------------------------- */
+static bool check_and(s7_scheme *sc, s7_pointer expr)
+{
+ /* this, check_or and check_if might not be called -- optimize_syntax can short-circuit it to return fx* choices */
+ s7_pointer p, code = cdr(expr);
+ int32_t any_nils = 0, len;
+
+ if (is_null(code))
+ {
+ sc->value = sc->T;
+ return(true);
+ }
+ for (len = 0, p = code; is_pair(p); p = cdr(p), len++)
+ {
+ s7_function callee = (has_fx(p)) ? fx_proc(p) : fx_choose(sc, p, sc->curlet, let_symbol_is_safe); /* fx_proc can be nil! */
+ if (!callee) any_nils++;
+ set_fx(p, callee);
+ }
+ if (is_not_null(p)) /* (and . 1) (and #t . 1) */
+ syntax_error_nr(sc, "and: stray dot?: ~A", 19, expr);
+
+ if ((fx_proc(code)) &&
+ (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));
+ }
+ 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 ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code);
+ set_current_code(sc, sc->code);
+ return(false);
+}
+
+static bool op_and_pair_p(s7_scheme *sc)
+{
+ if (!is_pair(lookup(sc, opt3_sym(sc->code)))) /* cadadr(sc->code) */
+ {
+ sc->value = sc->F;
+ return(true);
+ }
+ sc->code = opt2_con(sc->code); /* caddr(sc->code); */
+ return(false);
+}
+
+static bool op_and_ap(s7_scheme *sc)
+{
+ /* we know fx_proc is set on sc->code, and there are only two branches */
+ if (is_false(sc, fx_call(sc, cdr(sc->code))))
+ {
+ sc->value = sc->F;
+ return(true);
+ }
+ sc->code = caddr(sc->code);
+ return(false);
+}
+
+static void op_and_safe_p1(s7_scheme *sc) /* sc->code: (and (func...) (fx...)...) */
+{
+ sc->code = cdr(sc->code); /* new value will be pushed below */
+ push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST);
+ sc->code = car(sc->code);
+}
+
+static bool op_and_safe_p2(s7_scheme *sc)
+{
+ sc->value = fx_call(sc, cdr(sc->code));
+ if (is_false(sc, sc->value)) return(true);
+ sc->code = cddr(sc->code);
+ push_stack_no_args_direct(sc, OP_AND_SAFE_P_REST);
+ sc->code = car(sc->code);
+ return(false);
+}
+
+static bool op_and_safe_p3(s7_scheme *sc)
+{
+ sc->value = fx_call(sc, cdr(sc->code));
+ if (is_false(sc, sc->value)) return(true);
+ sc->code = cddr(sc->code);
+ sc->value = fx_call(sc, sc->code);
+ if (is_false(sc, sc->value)) return(true);
+ sc->code = cadr(sc->code);
+ return(false);
+}
+
+
+/* -------------------------------- or -------------------------------- */
+static bool check_or(s7_scheme *sc, s7_pointer expr)
+{
+ s7_pointer p, code = cdr(expr);
+ bool any_nils = false;
+ if (is_null(code))
+ {
+ sc->value = sc->F;
+ return(true);
+ }
+ for (p = code; is_pair(p); p = cdr(p))
+ {
+ s7_function callee = (has_fx(p)) ? fx_proc(p) : fx_choose(sc, p, sc->curlet, let_symbol_is_safe);
+ if (!callee) any_nils = true;
+ set_fx(p, callee);
+ }
+ if (is_not_null(p))
+ syntax_error_nr(sc, "or: stray dot?: ~A", 18, expr);
+
+ if ((fx_proc(code)) &&
+ (is_proper_list_1(sc, cdr(code)))) /* list_1 of cdr so there are 2 exprs */
+ pair_set_syntax_op(expr, (any_nils) ? OP_OR_AP : OP_OR_2A);
+ else pair_set_syntax_op(expr, (any_nils) ? OP_OR_P : OP_OR_N);
+
+ if ((is_fx_treeable(code)) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, code);
+ set_current_code(sc, sc->code);
+ return(false);
+}
+
+static bool op_or_ap(s7_scheme *sc)
+{
+ /* we know fx_proc is set on sc->code, and there are only two branches */
+ sc->value = fx_call(sc, cdr(sc->code));
+ if (is_true(sc, sc->value))
+ return(true);
+ sc->code = caddr(sc->code);
+ return(false);
+}
+
+
+/* -------------------------------- if -------------------------------- */
+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);
+ }
+ else fb_annotate(sc, form, code, OP_IF_B_P);
+ }
+ if (optimize_op(form) == OP_IF_A_R)
+ fb_annotate(sc, form, code, OP_IF_B_R);
+ if (optimize_op(form) == OP_IF_A_N_N)
+ fb_annotate(sc, form, cdar(code), OP_IF_B_N_N);
+ 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);
+ }
+ 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);
+ }
+}
+
+#define choose_if_optc(Opc, One, Reversed, Not) \
+ ((One) ? ((Reversed) ? OP_ ## Opc ## _R : \
+ ((Not) ? OP_ ## Opc ## _N : OP_ ## Opc ## _P)) : \
+ ((Not) ? OP_ ## Opc ## _N_N : OP_ ## Opc ## _P_P))
+
+static void set_if_opts(s7_scheme *sc, s7_pointer form, bool one_branch, bool reversed) /* cdr(form) == sc->code */
+{
+ s7_pointer code = cdr(form);
+ s7_pointer test = car(code);
+ bool not_case = false;
+
+ if ((!reversed) &&
+ (is_pair(test)) &&
+ (car(test) == sc->not_symbol))
+ {
+ if (!is_proper_list_1(sc, cdr(test))) return; /* (not) or (not a b) */
+ not_case = true;
+ test = cadr(test);
+ }
+
+ set_opt1_any(form, cadr(code));
+ if (!one_branch) set_opt2_any(form, caddr(code));
+
+ 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);
+ }
+ 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));
+ }}}}}
+ 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));
+ }}}
+}
+
+/* (cond <> (else <>)) only happens in old-fashioned code, so set_if_opts covers if/when/unless but not cond */
+
+static s7_pointer check_if(s7_scheme *sc, s7_pointer form)
+{
+ s7_pointer cdr_code, code = cdr(form);
+ if (!is_pair(code)) /* (if) or (if . 1) */
+ syntax_error_nr(sc, "(if): if needs at least 2 expressions: ~A", 41, form);
+
+ cdr_code = cdr(code);
+ 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: 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);
+ }
+ else
+ if (is_not_null(cdr(cdr_code))) /* (if 1 2 . 3) */
+ syntax_error_nr(sc, "if: ~A has improper list?", 25, form);
+
+ pair_set_syntax_op(form, OP_IF_UNCHECKED);
+ set_if_opts(sc, form, is_null(cdr(cdr_code)), false);
+ set_current_code(sc, sc->code);
+ return(code);
+}
+
+static void op_if(s7_scheme *sc)
+{
+ sc->code = check_if(sc, sc->code);
+ push_stack_no_args(sc, OP_IF1, cdr(sc->code));
+ sc->code = car(sc->code);
+}
+
+static void op_if_unchecked(s7_scheme *sc)
+{
+ push_stack_no_args(sc, OP_IF1, cddr(sc->code));
+ sc->code = cadr(sc->code);
+}
+
+static bool op_if1(s7_scheme *sc)
+{
+ sc->code = (is_true(sc, sc->value)) ? T_Pos(car(sc->code)) : T_Pos(unchecked_car(cdr(sc->code)));
+ /* even pre-optimization, (if #f #f) ==> #<unspecified> because unique_car(sc->nil) = sc->unspecified */
+ if (is_pair(sc->code))
+ return(true);
+ sc->value = (is_symbol(sc->code)) ? lookup_checked(sc, sc->code) : sc->code;
+ return(false);
+}
+
+
+/* -------------------------------- when -------------------------------- */
+static void check_when(s7_scheme *sc)
+{
+ s7_pointer form = sc->code, code = cdr(sc->code);
+
+ if (!is_pair(code)) /* (when) or (when . 1) */
+ syntax_error_nr(sc, "when has no expression or body: ~A", 35, form);
+ if (!is_pair(cdr(code))) /* (when 1) or (when 1 . 1) */
+ syntax_error_nr(sc, "when has no body?: ~A", 22, form);
+ if (!s7_is_proper_list(sc, cddr(code)))
+ syntax_error_nr(sc, "when: stray dot? ~A", 19, form);
+
+ pair_set_syntax_op(form, OP_WHEN_P);
+ if (is_null(cddr(code)))
+ set_if_opts(sc, form, true, false); /* use if where possible */
+ else
+ {
+ 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));
+ }
+ 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);
+ }}
+ push_stack_no_args(sc, OP_WHEN_PP, cdr(code));
+ set_current_code(sc, sc->code);
+ sc->code = car(code);
+}
+
+static bool op_when_s(s7_scheme *sc)
+{
+ if (is_true(sc, lookup(sc, cadr(sc->code))))
+ {
+ push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */
+ sc->code = opt2_con(sc->code); /* caddr(sc->code) */
+ return(false);
+ }
+ sc->value = sc->unspecified;
+ return(true);
+}
+
+static bool op_when_a(s7_scheme *sc)
+{
+ if (is_true(sc, fx_call(sc, cdr(sc->code))))
+ {
+ push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */
+ sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */
+ return(false);
+ }
+ sc->value = sc->unspecified;
+ return(true);
+}
+
+static bool op_when_and_2a(s7_scheme *sc)
+{
+ if ((is_true(sc, fx_call(sc, opt2_pair(sc->code)))) && (is_true(sc, fx_call(sc, cdr(opt2_pair(sc->code))))))
+ {
+ push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */
+ sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */
+ return(false);
+ }
+ sc->value = sc->unspecified;
+ return(true);
+}
+
+static bool op_when_and_3a(s7_scheme *sc)
+{
+ if ((is_true(sc, fx_call(sc, opt2_pair(sc->code)))) &&
+ (is_true(sc, fx_call(sc, cdr(opt2_pair(sc->code))))) &&
+ (is_true(sc, fx_call(sc, cddr(opt2_pair(sc->code))))))
+ {
+ push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(opt3_pair(sc->code)))); /* cdddr(sc->code) */
+ sc->code = car(opt3_pair(sc->code)); /* caddr(sc->code) */
+ return(false);
+ }
+ sc->value = sc->unspecified;
+ return(true);
+}
+
+static void op_when_p(s7_scheme *sc)
+{
+ push_stack_no_args(sc, OP_WHEN_PP, cddr(sc->code));
+ sc->code = cadr(sc->code);
+}
+
+static bool op_when_and_ap(s7_scheme *sc)
+{
+ s7_pointer andp = cdadr(sc->code);
+ if (is_true(sc, fx_call(sc, andp)))
+ {
+ push_stack_no_args(sc, OP_WHEN_PP, cddr(sc->code));
+ sc->code = cadr(andp);
+ return(false);
+ }
+ sc->value = sc->unspecified;
+ return(true);
+}
+
+static bool op_when_pp(s7_scheme *sc)
+{
+ if (is_true(sc, sc->value))
+ {
+ if_pair_set_up_begin_unchecked(sc);
+ return(false);
+ }
+ sc->value = sc->unspecified;
+ return(true);
+}
+
+
+/* -------------------------------- unless -------------------------------- */
+static void check_unless(s7_scheme *sc)
+{
+ s7_pointer form = sc->code, code = cdr(sc->code);
+
+ if (!is_pair(code)) /* (unless) or (unless . 1) */
+ syntax_error_nr(sc, "unless has no expression or body: ~A", 37, form);
+ if (!is_pair(cdr(code))) /* (unless 1) or (unless 1 . 1) */
+ syntax_error_nr(sc, "unless has no body?: ~A", 24, form);
+ if (!s7_is_proper_list(sc, cddr(code)))
+ syntax_error_nr(sc, "unless: stray dot? ~A", 21, form);
+
+ pair_set_syntax_op(form, OP_UNLESS_P);
+ if (is_null(cddr(code)))
+ set_if_opts(sc, form, true, true);
+ 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));
+ }
+ 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));
+ }
+ push_stack_no_args(sc, OP_UNLESS_PP, cdr(code));
+ set_current_code(sc, sc->code);
+ sc->code = car(code);
+}
+
+static bool op_unless_s(s7_scheme *sc)
+{
+ if (is_false(sc, lookup(sc, cadr(sc->code))))
+ {
+ push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */
+ sc->code = opt2_con(sc->code); /* caddr(sc->code) */
+ return(false);
+ }
+ sc->value = sc->unspecified;
+ return(true);
+}
+
+static bool op_unless_a(s7_scheme *sc)
+{
+ if (is_false(sc, fx_call(sc, cdr(sc->code))))
+ {
+ push_stack_no_args(sc, sc->begin_op, opt3_pair(sc->code)); /* cdddr(sc->code) */
+ sc->code = opt2_con(sc->code); /* caddr(sc->code) */
+ return(false);
+ }
+ sc->value = sc->unspecified;
+ return(true);
+}
+
+static void op_unless_p(s7_scheme *sc)
+{
+ push_stack_no_args(sc, OP_UNLESS_PP, cddr(sc->code));
+ sc->code = cadr(sc->code);
+}
+
+static bool op_unless_pp(s7_scheme *sc)
+{
+ if (is_false(sc, sc->value))
+ {
+ if_pair_set_up_begin_unchecked(sc);
+ return(false);
+ }
+ sc->value = sc->unspecified;
+ return(true);
+}
+
+
+/* -------------------------------- begin -------------------------------- */
+static bool op_begin(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer form = cdr(code);
+ if (!s7_is_proper_list(sc, form)) /* proper list includes () */
+ syntax_error_nr(sc, "unexpected dot? ~A", 18, code);
+ if (is_null(form)) /* (begin) -> () */
+ {
+ sc->value = sc->nil;
+ return(true);
+ }
+ pair_set_syntax_op(sc->code, ((is_pair(cdr(form))) && (is_null(cddr(form)))) ? OP_BEGIN_2_UNCHECKED : OP_BEGIN_UNCHECKED); /* begin_1 doesn't happen much */
+ return(false);
+}
+
+
+/* -------------------------------- define -------------------------------- */
+static s7_pointer print_truncate(s7_scheme *sc, s7_pointer code)
+{
+ if (tree_len(sc, code) > sc->print_length)
+ {
+ s7_pointer obj;
+ s7_int old_len;
+ old_len = sc->print_length;
+ sc->print_length = old_len * 10;
+ obj = object_to_string_truncated(sc, code);
+ sc->print_length = old_len;
+ return(obj);
+ }
+ return(code);
+}
+
+static void check_define(s7_scheme *sc)
+{
+ s7_pointer func, caller, code = cdr(sc->code);
+ bool starred = (sc->cur_op == OP_DEFINE_STAR);
+ if (starred)
+ {
+ caller = sc->define_star_symbol;
+ sc->cur_op = OP_DEFINE_STAR_UNCHECKED;
+ }
+ else caller = (sc->cur_op == OP_DEFINE) ? sc->define_symbol : sc->define_constant_symbol;
+
+ if (!is_pair(code))
+ syntax_error_with_caller_nr(sc, "~A: nothing to define? ~A", 25, caller, sc->code); /* (define) */
+
+ 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: 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)));
+ if (starred)
+ 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));
+ if (is_keyword(func)) /* (define :hi 1) */
+ 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 ((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)));
+ }}
+ 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));
+ 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 ((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));
+ if (starred)
+ 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));
+ }
+
+ if (sc->cur_op == OP_DEFINE)
+ {
+ if ((is_pair(car(code))) &&
+ (!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);
+}
+
+static bool op_define_unchecked(s7_scheme *sc)
+{
+ s7_pointer code = cdr(sc->code), locp;
+
+ if ((is_pair(car(code))) && (has_location(car(code))))
+ locp = car(code);
+ else locp = ((is_pair(cadr(code))) && (has_location(cadr(code)))) ? cadr(code) : sc->nil;
+
+ if ((sc->cur_op == OP_DEFINE_STAR_UNCHECKED) && /* sc->cur_op changed above if define* */
+ (is_pair(cdar(code))))
+ {
+ 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));
+ }
+ sc->code = caar(code);
+ return(false);
+ }
+
+ if (!is_pair(car(code)))
+ {
+ 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);
+ }
+ sc->value = (is_symbol(sc->code)) ? lookup_global(sc, sc->code) : sc->code;
+ sc->code = x;
+ }
+ else
+ {
+ s7_pointer args = cdar(code);
+ /* a closure. If we called this same code earlier (a local define), the only thing
+ * that is new here is the environment -- we can't blithely save the closure object
+ * in opt2 somewhere, and pick it up the next time around (since call/cc might take
+ * us back to the previous case). We also can't re-use opt2(sc->code) because opt2
+ * is not cleared in the gc.
+ */
+ 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));
+ }
+ sc->value = T_Ext(x);
+ sc->code = caar(code);
+ }
+ return(false);
+}
+
+static s7_pointer make_funclet(s7_scheme *sc, s7_pointer new_func, s7_pointer func_name, s7_pointer outer_let)
+{
+ s7_pointer new_let, arg;
+ new_cell_no_check(sc, new_let, T_LET | T_FUNCLET);
+ let_set_id(new_let, ++sc->let_number);
+ let_set_outlet(new_let, outer_let);
+ closure_set_let(new_func, new_let);
+ funclet_set_function(new_let, func_name); /* *function* returns at least funclet_function */
+ let_set_slots(new_let, slot_end);
+
+ arg = closure_args(new_func);
+ if (is_null(arg))
+ {
+ let_set_slots(new_let, slot_end);
+ return(new_let);
+ }
+
+ if (is_safe_closure(new_func))
+ {
+ 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);
+ }}
+ 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);
+ }}
+ 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 */
+ return(new_let);
+}
+
+static bool op_define_constant(s7_scheme *sc)
+{
+ s7_pointer code = cdr(sc->code);
+ if ((!is_pair(code)) || (!is_pair(cdr(code)))) /* (define-constant) */
+ syntax_error_nr(sc, "define-constant: not enough arguments: ~S", 41, sc->code);
+
+ 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);
+ }
+ 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" */
+ (car(code) == cadr(code)) &&
+ (symbol_id(car(code)) == 0) && /* else (let iter ... (define-constant iter iter) ...) -> segfault on later calls */
+ (is_null(cddr(code))))
+ {
+ s7_pointer sym = car(code);
+ set_immutable_slot(global_slot(sym)); /* id == 0 so its global */
+ set_possibly_constant(sym);
+ sc->value = lookup_checked(sc, car(code));
+ return(true);
+ }
+ push_stack_no_args(sc, OP_DEFINE_CONSTANT1, car(code));
+ return(false);
+}
+
+static void op_define_constant1(s7_scheme *sc)
+{
+ if (is_pair(sc->code))
+ sc->code = car(sc->code); /* (define-constant (ex3 a)...) */
+ if (is_symbol(sc->code))
+ {
+ s7_pointer slot = s7_slot(sc, sc->code);
+ 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 */
+ }
+}
+
+static inline void define_funchecked(s7_scheme *sc)
+{
+ s7_pointer new_func, code = cdr(sc->code);
+ sc->value = caar(code); /* func name */
+
+ new_cell(sc, new_func, T_CLOSURE | ((!s7_is_proper_list(sc, cdar(code))) ? T_COPY_ARGS : 0));
+ closure_set_args(new_func, cdar(code));
+ closure_set_body(new_func, cdr(code));
+ if (is_pair(cddr(code))) set_closure_has_multiform(new_func); else set_closure_has_one_form(new_func);
+ closure_set_setter(new_func, sc->F);
+ closure_set_arity(new_func, CLOSURE_ARITY_NOT_SET);
+ sc->capture_let_counter++;
+
+ if (is_safe_closure_body(cdr(code)))
+ {
+ set_safe_closure(new_func);
+ if (is_very_safe_closure_body(cdr(code)))
+ 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* */
+
+ if (let_id(sc->curlet) < symbol_id(sc->value))
+ sc->let_number++; /* dummy let, force symbol lookup */
+ add_slot_unchecked(sc, sc->curlet, sc->value, new_func, sc->let_number);
+ sc->value = new_func;
+}
+
+static s7_pointer check_define_macro(s7_scheme *sc, opcode_t op, s7_pointer form)
+{
+ s7_pointer mac_name, args, caller = cur_op_to_caller(sc, op);
+
+ if (!is_pair(sc->code)) /* (define-macro . 1) */
+ syntax_error_with_caller_nr(sc, "~A name missing (stray dot?): ~A", 32, caller, sc->code);
+ if (!is_pair(car(sc->code))) /* (define-macro a ...) */
+ wrong_type_error_nr(sc, caller, 1, car(sc->code), wrap_string(sc, "a list: (name ...)", 18));
+
+ mac_name = caar(sc->code);
+ if (!is_symbol(mac_name))
+ syntax_error_with_caller_nr(sc, "~A: ~S is not a symbol?", 23, caller, mac_name);
+ 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));
+ set_local(mac_name);
+ }
+ if (is_constant_symbol(sc, mac_name))
+ syntax_error_with_caller_nr(sc, "~A: ~S is constant", 18, caller, mac_name);
+
+ if (!is_pair(cdr(sc->code))) /* (define-macro (...)) */
+ syntax_error_with_caller_nr(sc, "~A ~A, but no body?", 19, caller, mac_name);
+
+ 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));
+
+ 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));
+
+ 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)));
+ check_lambda_args(sc, cdar(sc->code), NULL, form);
+ }
+ else set_cdar(sc->code, check_lambda_star_args(sc, args, NULL, form));
+ return(sc->code);
+}
+
+static s7_pointer check_macro(s7_scheme *sc, opcode_t op, s7_pointer form)
+{
+ s7_pointer args, caller = cur_op_to_caller(sc, op);
+
+ if (!is_pair(sc->code)) /* sc->code = cdr(form) */ /* (macro) or (macro . 1) */
+ syntax_error_with_caller_nr(sc, "~S: ~S has no parameters or body?", 33, caller, form);
+ if (!is_pair(cdr(sc->code))) /* (macro (a)) */
+ syntax_error_with_caller_nr(sc, "~S: ~S has no body?", 19, caller, form);
+
+ args = car(sc->code);
+ 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));
+
+ 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)));
+ 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));
+
+ return(sc->code);
+}
+
+static void op_macro(s7_scheme *sc) /* (macro (x) `(+ ,x 1)) */
+{
+ s7_pointer form = sc->code;
+ sc->code = cdr(sc->code);
+ if ((!is_pair(sc->code)) || (!mac_is_ok(sc->code))) /* (macro)? or (macro . #\a)? */
+ {
+ check_macro(sc, sc->cur_op, form);
+ set_mac_is_ok(sc->code);
+ }
+ sc->value = make_macro(sc, sc->cur_op, false);
+}
+
+static void op_define_macro(s7_scheme *sc)
+{
+ s7_pointer form = sc->code;
+ sc->code = cdr(sc->code);
+ check_define_macro(sc, sc->cur_op, form);
+ if ((is_immutable(sc->curlet)) &&
+ (is_let(sc->curlet)))
+ syntax_error_nr(sc, "define-macro ~S: let is immutable", 33, caar(sc->code)); /* need syntax_error_any_with_caller? */
+ sc->value = make_macro(sc, sc->cur_op, true);
+}
+
+static bool unknown_any(s7_scheme *sc, s7_pointer f, s7_pointer code);
+
+static opcode_t fixup_macro_d(s7_scheme *sc, opcode_t op, s7_pointer mac)
+{
+ if (closure_arity_unknown(mac))
+ closure_set_arity(mac, s7_list_length(sc, closure_args(mac)));
+ return(op);
+}
+
+static inline bool op_macro_d(s7_scheme *sc, uint8_t typ)
+{
+ sc->value = lookup(sc, car(sc->code));
+ if (type(sc->value) != typ) /* for-each (etc) called a macro before, now it's something else -- a very rare case */
+ return(unknown_any(sc, sc->value, sc->code));
+
+ /* it's probably safer to always copy the list here, but that costs 4-5% in tmac, whereas this costs 3% -- maybe not worth the code? */
+ if (closure_arity(sc->value) <= 0)
+ sc->args = copy_proper_list(sc, cdr(sc->code));
+ else sc->args = cdr(sc->code);
+
+ sc->code = sc->value; /* the macro */
+ check_stack_size(sc); /* (define-macro (f) (f)) (f) */
+ push_stack_op_let(sc, OP_EVAL_MACRO);
+ set_curlet(sc, inline_make_let(sc, closure_let(sc->code)));
+ return(false); /* fall into apply_lambda */
+}
+
+static void apply_macro_star_1(s7_scheme *sc);
+
+static bool op_macro_star_d(s7_scheme *sc)
+{
+ if (op_macro_d(sc, T_MACRO_STAR)) return(true);
+ apply_macro_star_1(sc);
+ return(false);
+}
+
+static void transfer_macro_info(s7_scheme *sc, s7_pointer mac)
+{
+ s7_pointer body = closure_body(mac);
+ if (has_pair_macro(mac))
+ {
+ set_maclet(sc->curlet);
+ funclet_set_function(sc->curlet, pair_macro(body));
+ }
+ if (has_location(body))
+ {
+ let_set_file(sc->curlet, pair_file_number(body));
+ let_set_line(sc->curlet, pair_line_number(body));
+ set_has_let_file(sc->curlet);
+ }
+}
+
+static goto_t op_expansion(s7_scheme *sc)
+{
+ s7_pointer caller = (is_pair(stack_top_args(sc))) ? car(stack_top_args(sc)) : sc->F; /* this can be garbage */
+ if ((sc->stack_end > sc->stack_start) && /* there is a stack... */
+ (stack_top_op(sc) != OP_READ_QUOTE) && /* '(expansion ...) */
+ (stack_top_op(sc) != OP_READ_VECTOR) && /* #(expansion ...) */
+ (!is_quote(caller)) && /* (#_quote ...) */
+ (caller != sc->macroexpand_symbol) && /* (macroexpand (expansion ...)) */
+ (caller != sc->define_expansion_symbol) && /* (define-expansion ...) being reloaded/redefined */
+ (caller != sc->define_expansion_star_symbol)) /* (define-expansion* ...) being reloaded/redefined */
+ {
+ s7_pointer symbol = car(sc->value), slot;
+ /* we're playing fast and loose with sc->curlet in the reader, so here we need a disaster check */
+ if (!is_let(sc->curlet)) set_curlet(sc, sc->rootlet);
+
+ if ((symbol_id(symbol) == 0) ||
+ (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);
+ 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
+ */
+ }}
+ return(fall_through);
+}
+
+static void macroexpand_c_macro(s7_scheme *sc) /* callgrind shows this when it's actually calling apply_c_function (code is identical) */
+{
+ 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_3(sc, not_enough_arguments_string, sc->code, sc->args));
+ if (c_macro_max_args(sc->code) < len)
+ error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, too_many_arguments_string, sc->code, sc->args));
+ sc->value = c_macro_call(sc->code)(sc, sc->args);
+}
+
+static goto_t macroexpand(s7_scheme *sc)
+{
+ switch (type(sc->code))
+ {
+ case T_MACRO:
+ set_curlet(sc, make_let(sc, closure_let(sc->code)));
+ return(goto_apply_lambda);
+ case T_BACRO:
+ set_curlet(sc, make_let(sc, sc->curlet));
+ return(goto_apply_lambda);
+ case T_MACRO_STAR:
+ set_curlet(sc, make_let(sc, closure_let(sc->code)));
+ apply_macro_star_1(sc);
+ return(goto_begin);
+ case T_BACRO_STAR:
+ set_curlet(sc, make_let(sc, sc->curlet));
+ apply_macro_star_1(sc);
+ return(goto_begin);
+ case T_C_MACRO:
+ macroexpand_c_macro(sc);
+ return(goto_start);
+ default:
+ syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, sc->args); /* maybe car(sc->args)? */
+ }
+ return(fall_through); /* for the compiler */
+}
+
+static goto_t op_macroexpand(s7_scheme *sc)
+{
+ s7_pointer form = sc->code;
+ sc->code = cdr(sc->code);
+ /* mimic APPLY, but don't push OP_EVAL_MACRO or OP_EXPANSION
+ * (define-macro (mac a) `(+ ,a 1)) (macroexpand (mac 3)), sc->code: ((mac 3))
+ */
+ if ((!is_pair(sc->code)) ||
+ (!is_pair(car(sc->code))))
+ syntax_error_nr(sc, "macroexpand argument is not a macro call: ~A", 44, form);
+
+ if (!is_null(cdr(sc->code)))
+ syntax_error_nr(sc, "macroexpand: too many arguments: ~A", 35, form);
+
+ if (is_pair(caar(sc->code))) /* (macroexpand ((symbol->value 'mac) (+ 1 2))) */
+ {
+ push_stack_no_args_direct(sc, OP_MACROEXPAND_1);
+ sc->code = caar(sc->code);
+ return(goto_eval);
+ }
+
+ sc->args = cdar(sc->code);
+ if (!is_list(sc->args)) /* (macroexpand (mac . 7)) */
+ syntax_error_nr(sc, "can't macroexpand ~S: the macro's argument list is not a list", 61, car(sc->code));
+
+ 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);
+ sc->code = caar(sc->code);
+ return(macroexpand(sc));
+ }
+ sc->code = lookup_checked(sc, caar(sc->code));
+ return(macroexpand(sc));
+}
+
+static goto_t op_macroexpand_1(s7_scheme *sc)
+{
+ sc->args = cdar(sc->code);
+ sc->code = sc->value;
+ return(macroexpand(sc));
+}
+
+static void op_eval_macro(s7_scheme *sc) /* after (scheme-side) macroexpansion, evaluate the resulting expression */
+{
+ /* (define-macro (hi a) `(+ ,a 1)), (hi 2), here with value: (+ 2 1) */
+ if (is_multiple_value(sc->value))
+ {
+ /* a normal macro's result is evaluated (below) and its value replaces the macro invocation,
+ * so if a macro returns multiple values, evaluate each one, then replace the macro
+ * invocation with (apply values evaluated-results-in-a-list). We need to save the
+ * new list of results, and where we are in the macro's output list, so code=macro output,
+ * args=new list. If it returns (values), should we use #<unspecified>? I think that
+ * happens now without generating a multiple_value object:
+ * (define-macro (hi) (values)) (hi) -> #<unspecified>
+ * (define-macro (ho) (values '(+ 1 2) '(* 3 4))) (+ 1 (ho) 3) -> 19
+ * (define-macro (ha) (values '(define a 1) '(define b 2))) (let () (ha) (+ a b)) -> 3
+ */
+ push_stack(sc, OP_EVAL_MACRO_MV, sc->nil, cdr(sc->value));
+ sc->code = car(sc->value);
+ }
+ else sc->code = sc->value;
+}
+
+static bool op_eval_macro_mv(s7_scheme *sc)
+{
+ if (is_null(sc->code)) /* end of values list */
+ {
+ sc->value = splice_in_values(sc, multiple_value(proper_list_reverse_in_place(sc, cons(sc, sc->value, sc->args))));
+ return(true);
+ }
+ push_stack(sc, OP_EVAL_MACRO_MV, cons(sc, sc->value, sc->args), cdr(sc->code));
+ sc->code = car(sc->code);
+ return(false);
+}
+
+static void op_finish_expansion(s7_scheme *sc)
+{
+ /* after the expander has finished, if a list was returned, we need to add some annotations.
+ * if the expander returned (values), the list-in-progress vanishes! (This mimics map and *#readers*).
+ */
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: op: %s, value: %s\n", __func__, __LINE__, op_names[stack_top_op(sc)], display_truncated(sc->value));
+ 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))) */
+ }}
+ else
+ if (is_pair(sc->value))
+ sc->value = copy_body(sc, sc->value);
+}
+
+
+/* -------------------------------- with-let -------------------------------- */
+static void check_with_let(s7_scheme *sc)
+{
+ s7_pointer form = cdr(sc->code);
+
+ if (!is_pair(form)) /* (with-let . "hi") */
+ syntax_error_nr(sc, "with-let takes an environment argument: ~A", 42, sc->code);
+ if (is_null(cdr(form))) /* (with-let e) */
+ syntax_error_nr(sc, "with-let has no body: ~A", 24, sc->code);
+ if (!s7_is_proper_list(sc, cdr(form))) /* (with-let e . 3) */
+ 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);
+ set_current_code(sc, sc->code);
+}
+
+static bool op_with_let_unchecked(s7_scheme *sc)
+{
+ sc->code = cdr(sc->code);
+ sc->value = car(sc->code);
+ if (!is_pair(sc->value))
+ {
+ if (is_symbol(sc->value))
+ sc->value = lookup_checked(sc, sc->value);
+ sc->code = cdr(sc->code);
+ return(false);
+ }
+ push_stack_no_args(sc, OP_WITH_LET1, cdr(sc->code));
+ sc->code = sc->value; /* eval let arg */
+ return(true);
+}
+
+static s7_pointer fx_with_let_s(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer code = cdr(arg);
+ s7_pointer e = lookup_checked(sc, car(code));
+ s7_pointer sym = cadr(code);
+ s7_pointer val;
+ if (!is_let(e))
+ {
+ 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)));
+ }
+ 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 */
+ if (is_slot(lookup_slot_with_let(sc, sym, e)))
+ return(sc->undefined);
+ unbound_variable_error_nr(sc, sym);
+ }
+ return(val);
+}
+
+static void activate_with_let(s7_scheme *sc, s7_pointer e)
+{
+ if (!is_let(e)) /* (with-let . "hi") */
+ {
+ 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));
+ e = new_e;
+ }
+ if (e == sc->rootlet)
+ set_curlet(sc, e); /* (with-let (rootlet) ...) */
+ else
+ {
+ set_with_let_let(e);
+ let_set_id(e, ++sc->let_number);
+ set_curlet(sc, e);
+ update_symbol_ids(sc, e);
+ }
+}
+
+
+/* -------------------------------- cond -------------------------------- */
+static void check_cond(s7_scheme *sc)
+{
+ bool has_feed_to = false, result_fx = true, result_single = true;
+ s7_pointer x, code = cdr(sc->code), form = sc->code;
+
+ if (!is_pair(code)) /* (cond) or (cond . 1) */
+ syntax_error_nr(sc, "cond, but no body: ~A", 21, form);
+
+ 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)));
+ 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;
+ }
+ 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));
+
+ for (x = code; is_pair(x); x = cdr(x))
+ {
+ 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);
+ 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 ((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);
+ }}}}
+ else
+ {
+ s7_pointer p;
+ bool xopt = true;
+ int32_t i;
+
+ 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))));
+ if (xopt)
+ {
+ 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);
+ }}}
+ else
+ if (result_single)
+ pair_set_syntax_op(form, OP_COND_SIMPLE_O);
+ }
+ set_opt3_any(code, caar(code));
+}
+
+static bool op_cond_unchecked(s7_scheme *sc)
+{
+ sc->code = cdr(sc->code);
+ if (has_fx(car(sc->code)))
+ {
+ sc->value = fx_call(sc, car(sc->code)); /* false -> fall through into cond1 */
+ return(false);
+ }
+ push_stack_no_args_direct(sc, OP_COND1); /* true -> push cond1, goto eval */
+ sc->code = opt3_any(sc->code); /* caar */
+ return(true);
+}
+
+static bool op_cond_simple(s7_scheme *sc) /* no => */
+{
+ sc->code = cdr(sc->code);
+ if (has_fx(car(sc->code)))
+ {
+ sc->value = fx_call(sc, car(sc->code));
+ return(false);
+ }
+ push_stack_no_args_direct(sc, OP_COND1_SIMPLE);
+ sc->code = opt3_any(sc->code); /* caar */
+ return(true);
+}
+
+static bool op_cond_simple_o(s7_scheme *sc) /* no =>, no null or multiform consequent */
+{
+ sc->code = cdr(sc->code);
+ if (has_fx(car(sc->code)))
+ {
+ sc->value = fx_call(sc, car(sc->code));
+ return(false);
+ }
+ push_stack_no_args_direct(sc, OP_COND1_SIMPLE_O);
+ sc->code = opt3_any(sc->code); /* caar */
+ return(true);
+}
+
+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 = cdr(sc->code); /* go to next clause */
+ if (is_null(sc->code))
+ {
+ sc->value = sc->unspecified;
+ pop_stack(sc);
+ return(true);
+ }
+ if (has_fx(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);
+ }}
+ return(true); /* make the compiler happy */
+}
+
+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 = cdr(sc->code);
+ if (is_null(sc->code))
+ {
+ sc->value = sc->unspecified;
+ pop_stack(sc);
+ return(true);
+ }
+ if (has_fx(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);
+ }}
+}
+
+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 = cdr(sc->code);
+ if (is_null(sc->code))
+ {
+ sc->value = sc->unspecified;
+ return(true);
+ }
+ if (has_fx(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);
+ }}
+}
+
+static bool op_cond_na_np(s7_scheme *sc) /* all tests are fxable, results may be a mixture, no =>, no missing results */
+{
+ 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);
+ }
+ sc->value = sc->unspecified;
+ return(true);
+}
+
+static bool op_cond_na_np_1(s7_scheme *sc) /* continuing to handle a multi-statement result from cond_na_np */
+{
+ for (s7_pointer p = sc->code; 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);
+}
+
+static Inline bool inline_op_cond_na_np_o(s7_scheme *sc) /* all tests are fxable, results may be a mixture, no =>, no missing results, all result one expr */
+{ /* called once in eval, b case cb lg rclo str */
+ 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);
+ }
+ sc->value = sc->unspecified;
+ return(true);
+}
+
+static inline bool fx_cond_value(s7_scheme *sc, s7_pointer p)
+{
+ if (has_fx(p))
+ {
+ sc->value = fx_call(sc, p);
+ return(true);
+ }
+ sc->code = car(p);
+ return(false);
+}
+
+static bool op_cond_na_2e(s7_scheme *sc)
+{
+ s7_pointer p = cdr(sc->code);
+ return(fx_cond_value(sc, (is_true(sc, fx_call(sc, car(p)))) ? cdar(p) : cdadr(p)));
+}
+
+static bool op_cond_na_3e(s7_scheme *sc)
+{
+ s7_pointer p = cdr(sc->code);
+ if (is_true(sc, fx_call(sc, car(p))))
+ return(fx_cond_value(sc, cdar(p)));
+ p = cdr(p);
+ return(fx_cond_value(sc, (is_true(sc, fx_call(sc, car(p)))) ? cdar(p) : cdadr(p)));
+}
+
+static bool op_cond_feed(s7_scheme *sc)
+{
+ /* (cond (expr => p)) where p is (lambda (s) ...) -- see check_cond */
+ sc->code = cdr(sc->code);
+ if (has_fx(car(sc->code)))
+ sc->value = fx_call(sc, car(sc->code));
+ else
+ {
+ push_stack_no_args_direct(sc, OP_COND_FEED_1);
+ sc->code = caar(sc->code);
+ return(true);
+ }
+ return(false);
+}
+
+static void op_cond_feed_1(s7_scheme *sc)
+{
+ if ((S7_DEBUGGING) && (is_multiple_value(sc->value))) fprintf(stderr, "%s %s unexpected mv\n", __func__, display(sc->value));
+ set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caadr(opt2_lambda(sc->code)), sc->value));
+ sc->code = caddr(opt2_lambda(sc->code));
+}
+
+static bool feed_to(s7_scheme *sc)
+{
+ if (is_multiple_value(sc->value)) /* (... ((values 1 2) => +)) more or less s7test.scm 29539 */
+ {
+ 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);
+ }}
+ 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->args = list_1(sc, sc->value); /* not plist here */
+ }
+ push_stack_direct(sc, OP_FEED_TO_1);
+ sc->code = cadr(sc->code); /* need to evaluate the target function */
+ return(false);
+}
+
+
+/* -------------------------------- set! -------------------------------- */
+static void check_set(s7_scheme *sc)
+{
+ s7_pointer form = sc->code, code = cdr(sc->code), settee, value;
+ 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!: stray dot? ~A", 19, form); /* (set! . 1) */
+ }
+ settee = car(code);
+
+ 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!: stray dot? ~A", 19, form); /* (set! var . 1) */
+ }
+ value = cadr(code); /* the value has not yet been evaluated */
+
+ if ((is_not_null(cddr(code))) || /* (set! var 1 2) */
+ ((is_pair(value)) &&
+ (car(value) == sc->values_symbol) && /* (set! var (values...) but 0 or 1 arg is ok */
+ (is_pair(cdr(value))) && /* this can be fooled if we rename values, etc */
+ (is_pair(cddr(value)))))
+ syntax_error_nr(sc, "~A: too many arguments to set!", 30, form);
+
+ 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);
+ 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);
+ }
+ 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));
+
+ 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));
+
+ 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
+ */
+ 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) :
+ ((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) */
+ }}}
+ return;
+ }
+ pair_set_syntax_op(form, OP_SET_NORMAL);
+ if (is_symbol(settee))
+ {
+ 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));
+ }}}}}}
+}
+
+static void op_set_s_c(s7_scheme *sc)
+{
+ s7_pointer slot = T_Slt(s7_slot(sc, cadr(sc->code)));
+ if (is_immutable(slot))
+ immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code)));
+ slot_set_value(slot, sc->value = opt2_con(cdr(sc->code)));
+}
+
+static inline void op_set_s_s(s7_scheme *sc)
+{
+ s7_pointer slot = T_Slt(s7_slot(sc, cadr(sc->code)));
+ if (is_immutable(slot))
+ immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code)));
+ slot_set_value(slot, sc->value = lookup(sc, opt2_sym(cdr(sc->code))));
+}
+
+static Inline void op_set_s_a(s7_scheme *sc)
+{
+ s7_pointer slot = T_Slt(s7_slot(sc, cadr(sc->code)));
+ if (is_immutable(slot))
+ immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "~S, but ~S is immutable", 23), sc->code, cadr(sc->code)));
+ slot_set_value(slot, sc->value = fx_call(sc, cddr(sc->code)));
+}
+
+static void op_set_s_p(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack_no_args(sc, OP_SET_SAFE, cadr(sc->code)); /* only path to op_set_safe, but we're not safe! cadr(sc->code) might be immutable */
+ sc->code = caddr(sc->code);
+}
+
+static void op_set_safe(s7_scheme *sc) /* name is misleading -- we need to check for immutable slot */
+{
+ s7_pointer slot = s7_slot(sc, sc->code);
+ 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));
+ slot_set_value(slot, sc->value);
+ }
+ else
+ if ((is_let(sc->curlet)) && (has_let_set_fallback(sc->curlet)))
+ sc->value = call_let_set_fallback(sc, sc->curlet, sc->code, sc->value);
+ else unbound_variable_error_nr(sc, sc->code);
+}
+
+static void op_set_from_let_temp(s7_scheme *sc)
+{
+ s7_pointer settee = sc->code;
+ s7_pointer slot = s7_slot(sc, settee);
+ if (!is_slot(slot))
+ unbound_variable_error_nr(sc, settee);
+ if (is_immutable_slot(slot))
+ immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "let-temporarily can't reset ~S: it is immutable!", 48), settee));
+ slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, sc->value) : sc->value);
+}
+
+static inline void op_set_cons(s7_scheme *sc)
+{
+ s7_pointer slot = s7_slot(sc, cadr(sc->code));
+ slot_set_value(slot, sc->value = cons(sc, lookup(sc, opt2_sym(cdr(sc->code))), slot_value(slot))); /* ([set!] bindings (cons v bindings)) */
+}
+
+static void op_increment_saa(s7_scheme *sc)
+{
+ s7_pointer slot, arg, val;
+ sc->code = cdr(sc->code);
+ slot = s7_slot(sc, car(sc->code));
+ arg = opt2_pair(sc->code); /* cddr(value) */
+ val = fx_call(sc, cdr(arg));
+ set_car(sc->t3_2, fx_call(sc, arg));
+ set_car(sc->t3_3, val);
+ set_car(sc->t3_1, slot_value(slot));
+ slot_set_value(slot, sc->value = fn_proc(cadr(sc->code))(sc, sc->t3_1));
+}
+
+static void op_increment_sa(s7_scheme *sc)
+{
+ s7_pointer slot, arg;
+ sc->code = cdr(sc->code);
+ slot = s7_slot(sc, car(sc->code));
+ arg = opt2_pair(sc->code);
+ set_car(sc->t2_2, fx_call(sc, arg));
+ set_car(sc->t2_1, slot_value(slot));
+ slot_set_value(slot, sc->value = fn_proc(cadr(sc->code))(sc, sc->t2_1));
+}
+
+static noreturn void no_setter_error_nr(s7_scheme *sc, s7_pointer obj)
+{
+ /* sc->code here is form without set!: ((abs 1) 2) from (set! (abs 1) 2)
+ * but in implicit case, (let ((L (list 0))) (set! (L 0 0) 2)), code is ((0 0) 2)
+ * at entry to s7_error: ((0 0 2)?? but we print something from define-hook-function if in the repl
+ * add indices and new-value args, is unevaluated code always available?
+ */
+ int32_t typ = type(obj);
+ if (!is_pair(car(sc->code))) sc->code = cdr(sc->code);
+
+ 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)));
+ 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)));
+ /* 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)))
+ */
+}
+
+static bool pair3_cfunc(s7_scheme *sc, s7_pointer obj, s7_pointer setf, s7_pointer arg, s7_pointer value)
+{
+ 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));
+ if (!is_safe_procedure(setf)) /* if unsafe, we can't call c_function_call(setf) directly (need drop into eval+apply) */
+ {
+ sc->code = setf;
+ sc->args = list_2(sc, arg, value);
+ return(true); /* goto APPLY */
+ }
+ sc->value = c_function_call(setf)(sc, with_list_t2(arg, value));
+ return(false);
+}
+
+static bool set_pair3(s7_scheme *sc, s7_pointer obj, s7_pointer arg, s7_pointer value)
+{
+ switch (type(obj))
+ {
+ case T_C_OBJECT:
+ sc->value = (*(c_object_set(sc, obj)))(sc, with_list_t3(obj, arg, value));
+ break;
+
+ case T_FLOAT_VECTOR:
+ sc->value = g_fv_set_3(sc, with_list_t3(obj, arg, value));
+ break;
+ case T_INT_VECTOR:
+ sc->value = g_iv_set_3(sc, with_list_t3(obj, arg, value));
+ break;
+ case T_BYTE_VECTOR:
+ sc->value = g_bv_set_3(sc, with_list_t3(obj, arg, value));
+ break;
+ case T_VECTOR:
+#if WITH_GMP
+ 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));
+ 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);
+ }
+#endif
+ break;
+
+ case T_STRING:
+#if WITH_GMP
+ 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;
+ }
+#endif
+ break;
+
+ case T_PAIR:
+ sc->value = g_list_set(sc, with_list_t3(obj, arg, value));
+ break;
+
+ 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));
+ sc->value = s7_hash_table_set(sc, obj, arg, value);
+ break;
+
+ case T_LET:
+ sc->value = let_set_2(sc, obj, arg, value); /* this checks immutable */
+ break;
+
+ 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));
+ 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));
+ 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; */
+
+ case T_MACRO: case T_MACRO_STAR:
+ 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));
+ 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; */
+
+ default:
+ no_setter_error_nr(sc, obj); /* possibly a continuation/goto? */
+ }
+ return(false);
+}
+
+static bool op_set_opsq_a(s7_scheme *sc) /* (set! (symbol) fxable) */
+{
+ s7_pointer setf, value, code = cdr(sc->code);
+ s7_pointer obj = lookup_checked(sc, caar(code));
+
+ 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));
+
+ setf = setter_p_pp(sc, obj, sc->curlet);
+ if (is_any_macro(setf))
+ {
+ sc->code = setf;
+ sc->args = cdr(code);
+ return(true);
+ }
+ value = fx_call(sc, cdr(code));
+ 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));
+ sc->value = c_function_call(setf)(sc, with_list_t1(value));
+ return(false);
+ }
+ sc->code = setf;
+ sc->args = list_1(sc, value);
+ return(true);
+}
+
+static bool op_set_opsaq_a(s7_scheme *sc) /* (set! (symbol fxable) fxable) */
+{
+ s7_pointer index, value, code = cdr(sc->code);
+ s7_pointer obj = lookup_checked(sc, caar(code));
+ bool result;
+ if (could_be_macro_setter(obj))
+ {
+ 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);
+ }}
+ 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 */
+ index = cadar(code); /* if obj is a c_macro, surely we don't want to evaluate cdar(code)? */
+ else index = fx_call(sc, cdar(code));
+ set_stack_protected2(sc, index);
+ result = set_pair3(sc, obj, index, value);
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static inline bool op_set_opsaq_p(s7_scheme *sc)
+{
+ s7_pointer code = cdr(sc->code);
+ /* ([set!] (car a) (cadr a)) */
+ /* here the pair can't generate multiple values, or if it does, it's an error (caught below)
+ * splice_in_values will notice the OP_SET_opSAq_P_1 and complain.
+ * (let () (define (hi) (let ((str "123")) (set! (str 0) (values #\a)) str)) (hi) (hi)) is "a23"
+ * (let ((v (make-vector '(2 3) 0))) (set! (v (values 0 1)) 23) v) -> #2D((0 23 0) (0 0 0))
+ */
+ s7_pointer obj = lookup_checked(sc, caar(code));
+ if (could_be_macro_setter(obj))
+ {
+ 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);
+ }}
+ push_stack(sc, OP_SET_opSAq_P_1, obj, code);
+ sc->code = cadr(code);
+ return(false);
+}
+
+static inline bool op_set_opsaq_p_1(s7_scheme *sc)
+{
+ s7_pointer value = sc->value;
+ s7_pointer index;
+ if (dont_eval_args(sc->args)) /* see above */
+ index = cadar(sc->code);
+ else index = fx_call(sc, cdar(sc->code));
+ return(set_pair3(sc, sc->args, index, value)); /* not lookup, (set! (_!asdf!_ 3) 'a) -> unbound_variable */
+}
+
+static bool pair4_cfunc(s7_scheme *sc, s7_pointer obj, s7_pointer setf, s7_pointer index1, s7_pointer index2, s7_pointer value)
+{
+ 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));
+ if (!is_safe_procedure(setf))
+ {
+ sc->code = setf;
+ sc->args = list_3(sc, index1, index2, value);
+ return(true);
+ }
+ sc->value = c_function_call(setf)(sc, with_list_t3(index1, index2, value));
+ return(false);
+}
+
+static bool set_pair4(s7_scheme *sc, s7_pointer obj, s7_pointer index1, s7_pointer index2, s7_pointer value)
+{
+ switch (type(obj))
+ {
+ case T_C_OBJECT:
+ sc->value = (*(c_object_ref(sc, obj)))(sc, with_list_t2(obj, index1));
+ return(set_pair3(sc, sc->value, index2, value));
+
+ case T_FLOAT_VECTOR:
+ sc->value = g_float_vector_set(sc, set_plist_4(sc, obj, index1, index2, value)); /* fv_unchecked_set_4? */
+ break;
+ case T_INT_VECTOR:
+ sc->value = g_int_vector_set(sc, set_plist_4(sc, obj, index1, index2, value));
+ break;
+ case T_BYTE_VECTOR:
+ sc->value = g_byte_vector_set(sc, set_plist_4(sc, obj, index1, index2, value));
+ break;
+ case T_VECTOR:
+ if (vector_rank(obj) == 2)
+ 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));
+ }
+ break;
+
+ case T_PAIR:
+ sc->value = g_list_ref(sc, with_list_t2(obj, index1));
+ return(set_pair3(sc, sc->value, index2, value));
+
+ case T_HASH_TABLE:
+ sc->value = s7_hash_table_ref(sc, obj, index1);
+ return(set_pair3(sc, sc->value, index2, value));
+
+ case T_LET:
+ sc->value = let_ref(sc, obj, index1);
+ return(set_pair3(sc, sc->value, index2, value));
+
+ 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));
+ 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));
+ 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; */
+
+ case T_MACRO: case T_MACRO_STAR:
+ 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));
+ 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; */
+
+ default:
+ no_setter_error_nr(sc, obj); /* possibly a continuation/goto or string */
+ }
+ return(false); /* goto start */
+}
+
+static bool op_set_opsaaq_a(s7_scheme *sc) /* (set! (symbol fxable fxable) fxable) */
+{
+ s7_pointer index1, value, code = cdr(sc->code);
+ s7_pointer obj = lookup_checked(sc, caar(code));
+ bool result;
+ if (could_be_macro_setter(obj))
+ {
+ 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);
+ }}
+ value = fx_call(sc, cdr(code));
+ gc_protect_via_stack(sc, value);
+ index1 = fx_call(sc, cdar(code));
+ set_stack_protected2(sc, index1);
+ result = set_pair4(sc, obj, index1, fx_call(sc, cddar(code)), value);
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static bool op_set_opsaaq_p(s7_scheme *sc)
+{
+ s7_pointer code = cdr(sc->code);
+ s7_pointer obj = lookup_checked(sc, caar(code));
+ if (could_be_macro_setter(obj))
+ {
+ 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);
+ }}
+ push_stack(sc, OP_SET_opSAAq_P_1, obj, code);
+ sc->code = cadr(code);
+ return(false);
+}
+
+static bool op_set_opsaaq_p_1(s7_scheme *sc)
+{
+ s7_pointer value = sc->value;
+ bool result;
+ s7_pointer index1 = fx_call(sc, cdar(sc->code));
+ gc_protect_via_stack(sc, index1);
+ result = set_pair4(sc, sc->args, index1, fx_call(sc, cddar(sc->code)), value);
+ unstack_gc_protect(sc);
+ return(result);
+}
+
+static bool op_set1(s7_scheme *sc)
+{
+ s7_pointer sym = T_Sym(sc->code); /* protect from sc->code possible change in call_c_function_setter below */
+ s7_pointer lx = s7_slot(sc, sym); /* if unbound variable hook here, we need the binding, not the current value */
+ 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 (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 */
+ }}
+ 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 */
+ }
+ if ((!is_let(sc->curlet)) || /* (with-let (rootlet) (set! undef 3)) */
+ (!has_let_set_fallback(sc->curlet))) /* (with-let (mock-hash-table 'b 2) (set! b 3)) */
+ error_nr(sc, sc->unbound_variable_symbol, set_elist_4(sc, wrap_string(sc, "~S is unbound in (set! ~S ~S)", 29), sym, sym, sc->value));
+ sc->value = call_let_set_fallback(sc, sc->curlet, sym, sc->value);
+ return(true);
+}
+
+static bool op_set_with_let_1(s7_scheme *sc)
+{
+ s7_pointer e, b, x = sc->value;
+ /* from the T_SYNTAX branch of op_set_pair: (set! (with-let e b) x) as in let-temporarily
+ * here sc->value is the new value for the settee = x, args has the (as yet unevaluated) let and settee-expression.
+ * 'b above can be a pair = generalized set in the 'e environment.
+ */
+ if (!is_pair(sc->args)) /* (set! (with-let) ...) */
+ 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));
+
+ 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));
+
+ 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);
+ }
+ 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) */
+ return(false); /* goto SET_WITH_LET */
+ }
+ sc->code = e; /* 'e above, an expression we need to evaluate */
+ sc->args = set_plist_2(sc, b, x); /* can't reuse sc->args here via set-car! etc */
+ push_stack_direct(sc, OP_SET_WITH_LET_2);
+ sc->cur_op = optimize_op(sc->code);
+ return(true); /* goto top_no_pop */
+}
+
+static bool op_set_with_let_2(s7_scheme *sc)
+{
+ s7_pointer b, x;
+ /* here sc->value = let = 'e, args = '(b x) where 'b might be a pair */
+ if (!is_let(sc->value))
+ wrong_type_error_nr(sc, sc->let_set_symbol, 1, sc->value, a_let_string);
+ 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)));
+ x = cadr(sc->args);
+ if (is_symbol(b)) /* b is a symbol -- everything else is ready so call let-set! */
+ {
+ sc->value = let_set_1(sc, sc->value, b, x);
+ return(true); /* continue */
+ }
+ 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);
+ 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 */
+}
+
+static bool op_set_normal(s7_scheme *sc)
+{
+ s7_pointer x;
+ sc->code = cdr(sc->code);
+ x = cadr(sc->code);
+ if (is_pair(x))
+ {
+ push_stack_no_args(sc, OP_SET1, car(sc->code));
+ sc->code = x;
+ return(true);
+ }
+ sc->value = (is_symbol(x)) ? lookup_checked(sc, x) : T_Ext(x);
+ sc->code = car(sc->code);
+ return(false);
+}
+
+static Inline void inline_op_increment_by_1(s7_scheme *sc) /* ([set!] ctr (+ ctr 1)) -- why is this always inlined? saves 22 in concordance */
+{
+ s7_pointer val, y = T_Slt(s7_slot(sc, cadr(sc->code)));
+ val = slot_value(y);
+ if (is_t_integer(val))
+ sc->value = make_integer(sc, integer(val) + 1);
+ else
+ 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;
+ case T_REAL:
+ 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;
+ default:
+ sc->value = add_p_pp(sc, val, int_one);
+ break;
+ }
+ slot_set_value(y, sc->value);
+}
+
+static void op_decrement_by_1(s7_scheme *sc) /* ([set!] ctr (- ctr 1)) */
+{
+ s7_pointer val, y = T_Slt(s7_slot(sc, cadr(sc->code)));
+ val = slot_value(y);
+ if (is_t_integer(val))
+ sc->value = make_integer(sc, integer(val) - 1); /* increment (set!) returns the new value in sc->value */
+ else
+ 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;
+ case T_REAL:
+ 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;
+ default:
+ sc->value = g_subtract(sc, set_plist_2(sc, val, int_one));
+ break;
+ }
+ slot_set_value(y, sc->value);
+}
+
+
+/* ---------------- implicit ref/set ---------------- */
+static Inline bool inline_op_implicit_vector_ref_a(s7_scheme *sc) /* called once in eval */
+{
+ s7_pointer x, v = lookup_checked(sc, car(sc->code));
+ if (!is_any_vector(v)) {sc->last_function = v; return(false);}
+ x = fx_call(sc, cdr(sc->code));
+ if ((s7_is_integer(x)) &&
+ (vector_rank(v) == 1))
+ {
+ 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 = vector_ref_1(sc, v, set_plist_1(sc, x));
+ return(true);
+}
+
+static s7_pointer fx_implicit_vector_ref_a(s7_scheme *sc, s7_pointer arg)
+{
+ s7_pointer x, v = lookup_checked(sc, car(arg));
+ if (!is_any_vector(v))
+ return(s7_apply_function(sc, v, list_1(sc, fx_call(sc, cdr(arg)))));
+ x = fx_call(sc, cdr(arg));
+ if ((s7_is_integer(x)) &&
+ (vector_rank(v) == 1))
+ {
+ 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_ref_1(sc, v, set_plist_1(sc, x)));
+}
+
+static bool op_implicit_vector_ref_aa(s7_scheme *sc) /* if Inline 70 in concordance */
+{
+ s7_pointer x, y, code;
+ s7_pointer v = lookup_checked(sc, car(sc->code));
+ if ((!is_any_vector(v)) || (vector_rank(v) != 2))
+ {
+ sc->last_function = v;
+ return(false);
+ }
+ code = cdr(sc->code);
+ x = fx_call(sc, code);
+ gc_protect_via_stack(sc, x);
+ y = fx_call(sc, cdr(code));
+ set_stack_protected2(sc, y);
+ if ((s7_is_integer(x)) && (s7_is_integer(y)) &&
+ (vector_rank(v) == 2))
+ {
+ 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);
+ }}
+ sc->value = vector_ref_1(sc, v, set_plist_2(sc, x, y));
+ unstack_gc_protect(sc);
+ return(true);
+}
+
+static /* inline */ bool op_implicit_vector_set_3(s7_scheme *sc) /* inline no diffs? */
+{
+ s7_pointer i1, code = cdr(sc->code);
+ s7_pointer v = lookup(sc, caar(code));
+ if (!is_any_vector(v))
+ {
+ /* this could be improved -- set_pair3 perhaps: pair3 set opt3? but this calls g_vector_set_3 */
+ pair_set_syntax_op(sc->code, OP_SET_UNCHECKED);
+ return(true);
+ }
+ i1 = fx_call(sc, cdar(code)); /* gc protect? */
+ set_car(sc->t3_3, fx_call(sc, cdr(code)));
+ set_car(sc->t3_1, v);
+ set_car(sc->t3_2, i1);
+ sc->value = g_vector_set_3(sc, sc->t3_1); /* calls vector_setter handling any vector type whereas vector_set_p_ppp wants a normal vector */
+ /* sc->value = vector_set_p_ppp(sc, v, i1, fx_call(sc, cdr(code))); */
+ return(false);
+}
+
+static bool op_implicit_vector_set_4(s7_scheme *sc)
+{
+ s7_pointer i1, i2, code = cdr(sc->code);
+ s7_pointer v = lookup(sc, caar(code));
+ if (!is_any_vector(v))
+ {
+ pair_set_syntax_op(sc->code, OP_SET_UNCHECKED);
+ return(true);
+ }
+ i1 = fx_call(sc, cdar(code));
+ i2 = fx_call(sc, opt3_pair(sc->code)); /* cddar(code) */
+ set_car(sc->t3_3, fx_call(sc, cdr(code)));
+ set_car(sc->t4_1, v);
+ set_car(sc->t3_1, i1);
+ set_car(sc->t3_2, i2);
+ sc->value = g_vector_set_4(sc, sc->t4_1);
+ set_car(sc->t4_1, sc->F);
+ return(false);
+}
+
+static goto_t call_set_implicit(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val, s7_pointer form);
+
+static goto_t set_implicit_vector(s7_scheme *sc, s7_pointer vect, s7_pointer inds, s7_pointer val, s7_pointer form)
+{
+ /* vect is the vector, sc->code is expr without the set!, form is the full expr, args have not been evaluated! */
+ s7_pointer index;
+ s7_int argnum;
+
+ if (!is_pair(inds))
+ wrong_number_of_arguments_error_nr(sc, "no index for implicit vector-set!: ~S", 37, form);
+ if (is_immutable_vector(vect))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->vector_set_symbol, vect));
+
+ argnum = proper_list_length(inds);
+ if ((argnum > 1) &&
+ (is_t_vector(vect)) &&
+ (argnum != vector_rank(vect)))
+ {
+ /* this block needs to be first to handle (eg):
+ * (let ((v (vector (inlet 'a 0)))) (set! (v 0 'a) 32) v): #((inlet 'a 32))
+ * 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));
+ }}
+ push_stack(sc, OP_SET2, cdr(inds), val);
+ sc->code = list_2(sc, vect, car(inds));
+ return(goto_unopt);
+ }
+
+ 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);
+ }
+ 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);
+ }}
+ 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);
+ sc->code = car(inds);
+ sc->cur_op = optimize_op(sc->code);
+ return(goto_top_no_pop);
+ }
+
+ /* one index, rank == 1 */
+ index = car(inds);
+ if ((is_symbol(car(sc->code))) && /* not (set! (#(a 0 (3)) 1) 0) -- implicit_vector_set_3 assumes symbol vect ref */
+ (cdr(form) == sc->code) &&
+ (is_fxable(sc, index)) &&
+ (is_fxable(sc, car(val))))
+ {
+ fx_annotate_arg(sc, inds, sc->curlet);
+ fx_annotate_arg(sc, val, sc->curlet);
+ pair_set_syntax_op(form, OP_IMPLICIT_VECTOR_SET_3);
+ }
+ if (!is_pair(index))
+ {
+ s7_int ind;
+ s7_pointer value;
+
+ if (is_symbol(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));
+ 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);
+ 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);
+ }
+ push_op_stack(sc, sc->vector_set_function);
+ sc->args = list_2(sc, index, vect);
+ sc->code = val;
+ return(goto_eval_args);
+ }
+ /* here the index calc might be trivial -- (+ i 1) or (- j 1) but this branch hardly ever happens */
+ push_stack(sc, OP_EVAL_ARGS4, list_1(sc, vect), val);
+ push_op_stack(sc, sc->vector_set_function);
+ sc->code = car(inds);
+ sc->cur_op = optimize_op(sc->code);
+ return(goto_top_no_pop);
+}
+
+static goto_t set_implicit_c_object(s7_scheme *sc, s7_pointer c_obj, s7_pointer inds, s7_pointer val, s7_pointer form)
+{
+ s7_pointer index;
+ /* c_obj's set! method needs to provide error checks */
+
+ if ((!is_pair(inds)) || (!is_null(cdr(inds))))
+ {
+ 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);
+ }
+ 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->cur_op = optimize_op(sc->code);
+ return(goto_top_no_pop);
+ }
+ index = car(inds);
+ if (!is_pair(index))
+ {
+ s7_pointer value = car(val);
+ if (is_symbol(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);
+ }
+ push_op_stack(sc, sc->c_object_set_function);
+ sc->args = list_2(sc, index, c_obj);
+ sc->code = val;
+ return(goto_eval_args);
+ }
+ push_stack(sc, OP_EVAL_ARGS4, list_1(sc, c_obj), val);
+ push_op_stack(sc, sc->c_object_set_function);
+ sc->code = car(inds);
+ sc->cur_op = optimize_op(sc->code);
+ return(goto_top_no_pop);
+}
+
+static bool op_implicit_string_ref_a(s7_scheme *sc)
+{
+ s7_int index;
+ s7_pointer s = lookup_checked(sc, car(sc->code));
+ s7_pointer x = fx_call(sc, cdr(sc->code));
+ if (!is_string(s))
+ {
+ sc->last_function = s;
+ return(false);
+ }
+ if (!s7_is_integer(x))
+ {
+ sc->value = string_ref_1(sc, s, set_plist_1(sc, x));
+ return(true);
+ }
+ index = s7_integer_clamped_if_gmp(sc, x);
+ if ((index < string_length(s)) && (index >= 0))
+ {
+ sc->value = chars[((uint8_t *)string_value(s))[index]];
+ return(true);
+ }
+ sc->value = string_ref_1(sc, s, x);
+ return(true);
+}
+
+static goto_t set_implicit_string(s7_scheme *sc, s7_pointer str, s7_pointer inds, s7_pointer val, s7_pointer form)
+{
+ /* here only one index makes sense and it is required, so (set! ("str") #\a), (set! ("str" . 1) #\a) and (set! ("str" 1 2) #\a) are all errors (but see below!) */
+ s7_pointer index;
+
+ if (!is_pair(inds))
+ wrong_number_of_arguments_error_nr(sc, "no index for string set!: ~S", 28, form);
+ if (!is_null(cdr(inds)))
+ wrong_number_of_arguments_error_nr(sc, "too many indices for string set!: ~S", 36, form);
+
+ index = car(inds);
+ if (!is_pair(index))
+ {
+ s7_int ind;
+ if (is_symbol(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));
+ 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);
+ if (is_immutable_string(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));
+ }
+ /* 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);
+ sc->code = cdr(sc->code);
+ return(goto_eval_args);
+ }
+ push_stack(sc, OP_EVAL_ARGS4, list_1(sc, str), val); /* args4 not 1 because we know cdr(sc->code) is a pair */
+ push_op_stack(sc, sc->string_set_function);
+ sc->code = car(inds);
+ sc->cur_op = optimize_op(sc->code);
+ return(goto_top_no_pop);
+}
+
+static goto_t set_implicit_pair(s7_scheme *sc, s7_pointer lst, s7_pointer inds, s7_pointer val, s7_pointer form)
+{
+ s7_pointer index, index_val = NULL, value = car(val);
+
+ if (!is_pair(inds)) /* (!is_pair(val)) and (!is_null(cdr(val))) are apparently caught somewhere else */
+ wrong_number_of_arguments_error_nr(sc, "no index for list-set!: ~S", 26, form);
+
+ index = car(inds);
+ if (!is_pair(index))
+ index_val = (is_normal_symbol(index)) ? lookup_checked(sc, index) : index;
+
+ if (!is_null(cdr(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));
+ }
+ 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);
+ }
+ 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);
+ }
+ 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;
+ return(goto_eval_args);
+ }
+ push_stack(sc, OP_EVAL_ARGS4, list_1(sc, lst), val); /* plist unsafe here */
+ push_op_stack(sc, sc->list_set_function);
+ sc->code = car(inds);
+ sc->cur_op = optimize_op(sc->code);
+ return(goto_top_no_pop);
+}
+
+static goto_t set_implicit_hash_table(s7_scheme *sc, s7_pointer table, s7_pointer inds, s7_pointer val, s7_pointer form)
+{
+ s7_pointer key, keyval = NULL;
+
+ if (!is_pair(inds)) /* (!is_pair(val)) and (!is_null(cdr(val))) are apparently caught elsewhere */
+ wrong_number_of_arguments_error_nr(sc, "no key for hash-table-set!: ~S", 30, form);
+ if (is_immutable_hash_table(table))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->hash_table_set_symbol, table));
+
+ key = car(inds);
+ if (is_pair(key))
+ {
+ if (is_quote(car(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));
+ }
+ 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);
+ }
+ if (keyval)
+ {
+ 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);
+ }}
+ else
+ {
+ 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;
+ return(goto_eval_args);
+ }
+ push_stack(sc, OP_EVAL_ARGS4, list_1(sc, table), val); /* plist unsafe here */
+ push_op_stack(sc, sc->hash_table_set_function);
+ sc->code = car(inds);
+ sc->cur_op = optimize_op(sc->code);
+ return(goto_top_no_pop);
+}
+
+static goto_t set_implicit_let(s7_scheme *sc, s7_pointer let, s7_pointer inds, s7_pointer val, s7_pointer form)
+{
+ s7_pointer sym, symval = NULL;
+
+ if (!is_pair(inds)) /* as above, bad val caught elsewhere */
+ wrong_number_of_arguments_error_nr(sc, "no symbol (variable name) for let-set!: ~S", 42, form);
+
+ sym = car(inds);
+ if (is_pair(sym))
+ {
+ if (is_quote(car(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));
+ }
+ push_stack(sc, OP_SET2, cdr(inds), val);
+ sc->code = list_2(sc, let, car(inds));
+ return(goto_unopt);
+ }
+ if (symval)
+ {
+ 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);
+ }
+ push_op_stack(sc, sc->let_set_function);
+ sc->args = list_2(sc, symval, let);
+ sc->code = val;
+ return(goto_eval_args);
+ }
+ push_stack(sc, OP_EVAL_ARGS4, list_1(sc, let), val);
+ push_op_stack(sc, sc->let_set_function);
+ sc->code = car(inds);
+ sc->cur_op = optimize_op(sc->code);
+ return(goto_top_no_pop);
+}
+
+static goto_t set_implicit_c_function(s7_scheme *sc, s7_pointer fnc) /* (let ((lst (list 1 2))) (set! (list-ref lst 0) 2) lst) */
+{
+ if (!is_t_procedure(c_function_setter(fnc)))
+ {
+ if (!is_any_macro(c_function_setter(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);
+ /* here multiple-values can't happen because we don't eval the new-value argument */
+ return(goto_apply);
+ }
+ /* here the setter can be anything, so we need to check the needs_copied_args bit. (set! ((dilambda / (let ((x 3)) (lambda (y) (+ x y))))) 3)! */
+ if (is_null(cdar(sc->code)))
+ {
+ push_stack(sc, OP_EVAL_SET1_NO_MV, sc->nil, c_function_setter(fnc));
+ sc->code = cadr(sc->code); /* new value */
+ }
+ else
+ {
+ if (is_null(cddar(sc->code))) /* (set! (fnc ind) val) */
+ 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 */
+ }
+ sc->code = cadar(sc->code);
+ }
+ sc->cur_op = optimize_op(sc->code);
+ return(goto_top_no_pop);
+}
+
+static goto_t set_implicit_closure(s7_scheme *sc, s7_pointer fnc)
+{
+ s7_pointer setter = closure_setter(fnc); /* (set! (fnc ind...) val), sc->code = ((fnc ind...) val) */
+ if ((setter == sc->F) && (!closure_no_setter(fnc))) /* maybe closure_setter hasn't been set yet: see fset3 in s7test.scm */
+ setter = setter_p_pp(sc, fnc, sc->curlet);
+ if (!is_t_procedure(setter))
+ {
+ if (!is_any_macro(setter))
+ 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;
+ return(goto_apply);
+ }
+ if (is_null(cdar(sc->code))) /* (set! (fnc) val) */
+ {
+ push_stack(sc, OP_EVAL_SET1_NO_MV, sc->nil, setter); /* args=(), code=setter */
+ sc->code = cadr(sc->code); /* the value */
+ }
+ else
+ {
+ if (is_null(cddar(sc->code))) /* (set! (fnc ind) val) */
+ 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 */
+ }
+ sc->code = cadar(sc->code); /* "ind" above */
+ }
+ sc->cur_op = optimize_op(sc->code);
+ return(goto_top_no_pop);
+}
+
+static goto_t set_implicit_iterator(s7_scheme *sc, s7_pointer iter)
+{
+ s7_pointer setter = iterator_sequence(iter);
+
+ if ((is_any_closure(setter)) || (is_any_macro(setter)))
+ setter = closure_setter(iterator_sequence(iter));
+ else no_setter_error_nr(sc, 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));
+
+ if (is_procedure(setter))
+ {
+ push_op_stack(sc, setter);
+ push_stack(sc, OP_EVAL_ARGS1, sc->nil, sc->nil);
+ sc->code = cadr(sc->code); /* the (as yet unevaluated) value, incoming code was ((obj) val) */
+ sc->cur_op = optimize_op(sc->code);
+ return(goto_top_no_pop);
+ }
+ sc->args = cdr(sc->code);
+ sc->code = setter;
+ return(goto_apply);
+}
+
+static goto_t set_implicit_syntax(s7_scheme *sc, s7_pointer wlet)
+{
+ if (wlet != global_value(sc->with_let_symbol))
+ no_setter_error_nr(sc, wlet);
+
+ /* (set! (with-let a b) x), wlet = with-let, sc->code = ((with-let a b) x)
+ * a and x are in the current let, b is in a, we need to evaluate a and x, then
+ * call (with-let a-value (set! b x-value))
+ */
+ sc->args = cdar(sc->code);
+ sc->code = cadr(sc->code);
+ push_stack_direct(sc, OP_SET_WITH_LET_1);
+ sc->cur_op = optimize_op(sc->code);
+ return(goto_top_no_pop);
+}
+
+static goto_t call_set_implicit(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val, s7_pointer form)
+{
+ /* these depend on sc->code making sense given obj as the sequence being set */
+ switch (type(obj))
+ {
+ case T_STRING: return(set_implicit_string(sc, obj, inds, val, form));
+ case T_PAIR: return(set_implicit_pair(sc, obj, inds, val, form));
+ case T_HASH_TABLE: return(set_implicit_hash_table(sc, obj, inds, val, form));
+ case T_LET: return(set_implicit_let(sc, obj, inds, val, form));
+ case T_C_OBJECT: return(set_implicit_c_object(sc, obj, inds, val, form));
+ case T_ITERATOR: return(set_implicit_iterator(sc, obj)); /* not sure this makes sense */
+ case T_SYNTAX: return(set_implicit_syntax(sc, obj));
+
+ case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR:
+ return(set_implicit_vector(sc, obj, inds, val, form));
+
+ case T_C_MACRO: case T_C_FUNCTION_STAR:
+ case T_C_RST_NO_REQ_FUNCTION: case T_C_FUNCTION:
+ return(set_implicit_c_function(sc, obj)); /* (set! (setter...) ...) also comes here */
+
+ case T_MACRO: case T_MACRO_STAR: case T_BACRO: case T_BACRO_STAR:
+ case T_CLOSURE: case T_CLOSURE_STAR:
+ return(set_implicit_closure(sc, obj));
+
+ 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 */
+ 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));
+ }
+ return(goto_top_no_pop);
+}
+
+static goto_t set_implicit(s7_scheme *sc) /* sc->code incoming is (set! (...) ...) */
+{
+ s7_pointer caar_code, obj, form = sc->code;
+ sc->code = cdr(sc->code);
+ caar_code = caar(sc->code);
+ if (is_symbol(caar_code))
+ {
+ obj = s7_slot(sc, caar_code);
+ obj = (is_slot(obj)) ? slot_value(obj) : unbound_variable(sc, caar_code);
+ }
+ else
+ if (!is_pair(caar_code))
+ 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);
+ }
+ /* 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 */
+ return(call_set_implicit(sc, obj, cdar(sc->code), cdr(sc->code), form));
+}
+
+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)));
+}
+
+static goto_t op_set2(s7_scheme *sc)
+{
+ if (is_pair(sc->value))
+ {
+ /* (let ((L '((1 2 3)))) (set! ((L 0) 1) 32) L), (let ((L '(((1 2 3))))) (set! ((L 0) 0 1) 32) L)
+ * any deeper nesting was handled already by the first eval
+ * set! looks at its first argument, if it's a symbol, it sets the associated value,
+ * if it's a list, it looks at the car of that list to decide which setter to call,
+ * if it's a list of lists, it passes the embedded lists to eval, then looks at the
+ * car of the result. This means that we can do crazy things like:
+ * (let ((x '(1)) (y '(2))) (set! ((if #t x y) 0) 32) x)
+ * the other args need to be evaluated (but not the list as if it were code):
+ * (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);
+ 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))
+ 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));
+ sc->code = car(sc->args);
+ return(goto_eval);
+ }
+ if ((is_any_vector(sc->value)) &&
+ (vector_rank(sc->value) == proper_list_length(sc->args))) /* sc->code == new value? */
+ {
+ /* (let ((L #(#(1 2 3) #(4 5 6)))) (set! ((L 1) 0) 32) L)
+ * 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);
+ 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));
+ sc->code = car(sc->args);
+ return(goto_eval);
+ }
+ sc->code = cons_unchecked(sc, sc->set_symbol, cons(sc, set_ulist_1(sc, sc->value, sc->args), sc->code)); /* (let ((x 32)) (set! ((curlet) 'x) 3) x) */
+ return(set_implicit(sc));
+}
+
+
+/* -------------------------------- do -------------------------------- */
+static bool safe_stepper_expr(s7_pointer expr, const s7_pointer var)
+{
+ /* for now, just look for stepper as last element of any list
+ * any embedded set is handled by do_is_safe, so we don't need to descend into the depths
+ */
+ s7_pointer p;
+ if (cadr(expr) == var) return(false);
+ for (p = cdr(expr); is_pair(cdr(p)); p = cdr(p));
+ if (is_pair(p))
+ {
+ if ((is_optimized(p)) &&
+ (op_has_hop(p)) &&
+ (is_safe_c_op(optimize_op(p))))
+ return(true);
+ if (car(p) == var) return(false);
+ }
+ else
+ if (p == var) return(false);
+ return(true);
+}
+
+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)))));
+}
+
+static bool all_ints_here(s7_scheme *sc, s7_pointer settee, s7_pointer expr, s7_pointer step_vars) /* see also all_integers above */
+{
+ /* since any type change causes false return, we can accept inits across step-vars */
+ s7_pointer func, sig;
+ if (is_number(expr))
+ return(is_t_integer(expr));
+ if (is_symbol(expr))
+ {
+ 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);
+ }
+ val = lookup_unexamined(sc, expr);
+ return((val) && (is_t_integer(val)));
+ }
+ if (!is_pair(expr)) return(false);
+ if (!is_symbol(car(expr))) return(false);
+ func = lookup_unexamined(sc, car(expr));
+ if (!func) return(false);
+ if ((is_int_vector(func)) || (is_byte_vector(func))) return(true);
+ if (!is_any_c_function(func)) return(false);
+ if ((car(expr) == sc->vector_ref_symbol) && (is_pair(cdr(expr))) && (is_symbol(cadr(expr))))
+ {
+ s7_pointer v = lookup_unexamined(sc, cadr(expr));
+ if ((v) && ((is_int_vector(v)) || (is_byte_vector(v)))) return(true);
+ }
+ sig = c_function_signature(func);
+ 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)))))))
+ 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))
+ if (!all_ints_here(sc, settee, car(p), step_vars))
+ return(false);
+ return(true);
+}
+
+static bool do_is_safe(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, s7_pointer step_vars, bool *has_set)
+{
+ /* here any (unsafe?) closure or jumping-op (call/cc) or shadowed variable is trouble
+ * we can free var_list if return(false) not after (!do_is_safe...), but it seems to make no difference, or be slightly slower
+ */
+ /* sc->code is the complete do form (do ...) */
+
+ for (s7_pointer p = body; is_pair(p); p = cdr(p))
+ {
+ 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);
+ }}}}}
+ 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));
+}
+
+static s7_pointer simple_stepper(s7_scheme *sc, s7_pointer v)
+{
+ if ((is_proper_list_3(sc, v)) &&
+ (is_fxable(sc, cadr(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);
+ }
+ return(NULL);
+}
+
+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)));
+}
+
+static s7_pointer fxify_step_exprs(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer vars = car(code);
+ s7_pointer e = collect_variables(sc, vars, sc->nil); /* only valid in step exprs, not in inits */
+
+ for (s7_pointer p = vars; is_pair(p); p = cdr(p))
+ {
+ 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);
+ }
+ 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(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));
+ }
+ return(code);
+}
+
+static bool do_vector_has_definers(s7_pointer v)
+{
+ s7_int len = vector_length(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 */
+ return(true);
+ return(false);
+}
+
+static /* inline */ bool do_tree_has_definers(s7_scheme *sc, s7_pointer tree)
+{
+ /* we can't be very fancy here because quote gloms up everything: (cond '(define x 0) ...) etc, and the tree here can
+ * be arbitrarily messed up, and we need to be reasonably fast. So we accept some false positives: (case ((define)...)...) or '(define...)
+ * but what about ((f...)...) where (f...) returns a macro that defines something? Or (for-each or ...) where for-each and or might be
+ * obfuscated and the args might contain a definer?
+ */
+ for (s7_pointer p = tree; is_pair(p); p = cdr(p))
+ {
+ 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);
+ }}
+ 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);
+ }
+ return(false);
+}
+
+static void check_do_for_obvious_errors(s7_scheme *sc, s7_pointer form)
+{
+ s7_pointer x, code = cdr(form);
+
+ if ((!is_pair(code)) || /* (do . 1) */
+ ((!is_pair(car(code))) && /* (do 123) */
+ (is_not_null(car(code))))) /* (do () ...) is ok */
+ syntax_error_nr(sc, "do: variable list is not a list: ~S", 35, form);
+
+ if (!is_pair(cdr(code))) /* (do () . 1) */
+ syntax_error_nr(sc, "do body is messed up: ~A", 24, form);
+
+ if ((!is_pair(cadr(code))) && /* (do ((i 0)) 123) */
+ (is_not_null(cadr(code)))) /* no end-test? */
+ syntax_error_nr(sc, "do: end-test and end-value list is not a list: ~A", 49, form);
+
+ if (is_pair(car(code)))
+ {
+ 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));
+ }
+ 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);
+ }
+ 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);
+ }
+ for (x = cddr(code); is_pair(x); x = cdr(x));
+ if (is_not_null(x))
+ syntax_error_nr(sc, "stray dot in do body? ~A", 24, form);
+}
+
+static s7_pointer do_end_bad(s7_scheme *sc, s7_pointer form)
+{
+ s7_pointer code = cdr(form);
+ if (is_null(cddr(code)))
+ {
+ 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));
+ }
+ 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));
+ }
+ for (p = car(code); is_pair(p); p = cdr(p)) /* clear var names */
+ 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);
+ }}
+ return(fxify_step_exprs(sc, code));
+}
+
+static s7_pointer check_do(s7_scheme *sc)
+{
+ /* returns nil if optimizable */
+ s7_pointer form = sc->code, code, vars, end, body, p;
+
+ check_do_for_obvious_errors(sc, form);
+ pair_set_syntax_op(form, OP_DO_UNCHECKED);
+ code = cdr(form);
+ end = cadr(code);
+
+ if ((!is_pair(end)) || (!is_fxable(sc, car(end))))
+ return(do_end_bad(sc, form)); /* can return code (not sc->nil) */
+
+ /* sc->curlet is the outer environment, local vars are in the symbol_list via check_do_for_obvious_error, and it's only needed for fx_unsafe_s */
+ set_fx_direct(end, fx_choose(sc, end, sc->curlet, let_symbol_is_safe_or_listed));
+ if ((is_pair(cdr(end))) &&
+ (is_fxable(sc, cadr(end))))
+ set_fx_direct(cdr(end), fx_choose(sc, cdr(end), sc->curlet, let_symbol_is_safe_or_listed));
+
+ vars = car(code);
+ if (is_null(vars))
+ {
+ 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);
+ }}
+ return(sc->nil);
+ }
+
+ if (do_tree_has_definers(sc, form)) /* we don't want definers in body, vars, or end test */
+ return(fxify_step_exprs(sc, code));
+
+ body = cddr(code);
+ if ((is_pair(end)) && (is_pair(car(end))) && /* end test is a pair */
+ (is_pair(vars)) && (is_null(cdr(vars))) && /* one stepper */
+ (is_pair(body)) && (is_pair(car(body))) && /* body is normal-looking */
+ ((is_symbol(caar(body))) || (is_safe_c_function(caar(body)))))
+ {
+ /* loop has one step variable, and normal-looking end test */
+ s7_pointer v = car(vars), step_expr;
+
+ 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);
+
+ 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);
+ }}}
+
+ /* 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));
+ }
+ 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 stepper0 = NULL, stepper1 = NULL, stepper2 = NULL, stepper3 = NULL;
+ bool got_pending = false, outer_shadowed = false;
+
+ 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);
+ }}
+
+ 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;
+ }
+ 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);
+ }}}
+ 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))))
+ {
+ 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);
+ }}}
+ return(sc->nil);
+}
+
+static bool has_safe_steppers(s7_scheme *sc, s7_pointer let)
+{
+ for (s7_pointer slot = let_slots(let); tis_slot(slot); slot = next_slot(slot))
+ {
+ 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 ?? */
+ }}
+ 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_safe_stepper(slot))
+ return(false);
+ }
+ return(true);
+}
+
+static bool copy_if_end_ok(s7_scheme *sc, s7_pointer dest, s7_pointer source, s7_int i, s7_pointer endp, s7_pointer stepper)
+{
+ if ((fn_proc(endp) == g_num_eq_2) && (is_symbol(cadr(endp))) && (is_symbol(caddr(endp))))
+ {
+ 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);
+ }}
+ return(false);
+}
+
+static bool op_dox_init(s7_scheme *sc)
+{
+ s7_pointer test, code = cdr(sc->code);
+ s7_pointer let = inline_make_let(sc, sc->curlet);
+ sc->temp1 = let;
+
+ for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars))
+ {
+ add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars)));
+ if (is_pair(cddar(vars)))
+ slot_set_expression(let_slots(let), cddar(vars));
+ else slot_just_set_expression(let_slots(let), sc->nil);
+ }
+ set_curlet(sc, let);
+ sc->temp1 = sc->unused;
+ test = cadr(code);
+ if (is_true(sc, sc->value = fx_call(sc, test)))
+ {
+ sc->code = cdr(test);
+ return(true); /* goto DO_END_CLAUSES */
+ }
+ sc->code = T_Pair(cddr(code));
+ push_stack_no_args(sc, (intptr_t)((is_null(cdr(sc->code))) ? OP_DOX_STEP_O : OP_DOX_STEP), code);
+ return(false); /* goto BEGIN */
+}
+
+static goto_t op_dox_no_body_1(s7_scheme *sc, s7_pointer slots, s7_pointer end, int32_t steppers, s7_pointer stepper)
+{
+ s7_function endf = fx_proc(end);
+ s7_pointer endp = car(end);
+ if ((endf == fx_c_nc) || (endf == fx_c_0c))
+ {
+ endf = fn_proc(endp);
+ endp = cdr(endp);
+ }
+ if (steppers == 1)
+ {
+ 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);
+ }
+ 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;
+ }
+ 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);
+
+ sc->code = cdr(end);
+ return(goto_do_end_clauses);
+ }
+ if ((steppers == 2) &&
+ (!tis_slot(next_slot(next_slot(slots)))))
+ {
+ s7_pointer step1 = slots;
+ s7_pointer expr1 = slot_expression(step1);
+ 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));
+ }
+ 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);
+ 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);
+ 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));
+ sc->value = slot_value(step1);
+ if (is_t_real(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)));
+ slt = next_slot(slt);
+ } while (tis_slot(slt));
+ } while ((sc->value = endf(sc, endp)) == sc->F);
+ sc->code = cdr(end);
+ return(goto_do_end_clauses);
+}
+
+static goto_t op_dox(s7_scheme *sc)
+{
+ /* any number of steppers using dox exprs, end also dox, body and end result arbitrary.
+ * since all these exprs are local, we don't need to jump until the body
+ */
+ int64_t id, steppers = 0;
+ s7_pointer code, end, endp, stepper = NULL, form = sc->code, slots;
+ s7_function endf;
+#if WITH_GMP
+ bool got_bignum = false;
+#endif
+ s7_pointer let = inline_make_let(sc, sc->curlet); /* new let is not tied into the symbol lookup process yet */
+ sc->temp1 = let;
+ sc->code = cdr(sc->code);
+ for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars))
+ {
+ s7_pointer expr = cdar(vars), slot;
+ s7_pointer val = fx_call(sc, expr);
+ s7_pointer stp = cdr(expr); /* cddar(vars) */
+#if WITH_GMP
+ if (!got_bignum) got_bignum = is_big_number(val);
+#endif
+ 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);
+ }
+ else slot_just_set_expression(slot, sc->nil);
+ slot_set_next(slot, let_slots(let));
+ let_set_slots(let, slot);
+ }
+ set_curlet(sc, let);
+ slots = let_slots(sc->curlet);
+ sc->temp1 = sc->unused;
+ id = let_id(let);
+
+ /* the fn_calls above could have redefined a previous stepper, so that its symbol_id is > let let_id when we get here,
+ * so we use symbol_set_local_slot_unchecked below to sidestep the debugger (see zauto.scm: i is a stepper, but then mock-vector-ref uses i as its index)
+ */
+ for (s7_pointer slot = slots; tis_slot(slot); slot = next_slot(slot))
+ symbol_set_local_slot_unchecked_and_unincremented(slot_symbol(slot), id, slot);
+
+ end = cadr(sc->code);
+ endp = car(end);
+ endf = fx_proc(end);
+
+ if ((loop_end_possible(end)) && (steppers == 1) &&
+ (is_t_integer(slot_value(stepper))))
+ {
+ 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)));
+ }}
+
+ if (is_true(sc, sc->value = endf(sc, endp)))
+ {
+ sc->code = cdr(end);
+ return(goto_do_end_clauses);
+ }
+ code = cddr(sc->code);
+ if (is_null(code)) /* no body -- how does this happen? */
+ return(op_dox_no_body_1(sc, slots, end, steppers, stepper));
+
+ if ((is_null(cdr(code))) && /* 1 expr, code is cdddr(form) here */
+ (is_pair(car(code))))
+ {
+ s7_pointer body = car(code);
+ s7_pfunc bodyf = NULL;
+ if ((!no_cell_opt(code)) &&
+#if WITH_GMP
+ (!got_bignum) &&
+#endif
+ (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))));
+
+ 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) &&
+ (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;
+ bool use_opts = false;
+ int32_t body_len = 0;
+ opt_info *body[32];
+ #define MAX_OPT_BODY_SIZE 32
+
+ 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);
+ }
+
+ if (p == code)
+ 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);
+ }}}}
+ 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);
+ }}
+ 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));
+ return(goto_begin);
+}
+
+static inline bool op_dox_step_1(s7_scheme *sc) /* inline for 50 in concordance, 30 in dup */
+{
+ s7_pointer slot = let_slots(sc->curlet);
+ do { /* every dox case has vars (else op_do_no_vars) */
+ if (slot_has_expression(slot)) /* splitting out 1-slot has_expr case is not faster (not enough hits) */
+ slot_set_value(slot, fx_call(sc, slot_expression(slot)));
+ slot = next_slot(slot);
+ } while (tis_slot(slot));
+ sc->value = fx_call(sc, cadr(sc->code));
+ if (is_true(sc, sc->value))
+ {
+ sc->code = cdadr(sc->code);
+ return(true);
+ }
+ return(false);
+}
+
+static void op_dox_step(s7_scheme *sc)
+{
+ push_stack_no_args_direct(sc, OP_DOX_STEP);
+ sc->code = T_Pair(cddr(sc->code));
+}
+
+static void op_dox_step_o(s7_scheme *sc)
+{
+ push_stack_no_args_direct(sc, OP_DOX_STEP_O);
+ sc->code = caddr(sc->code);
+}
+
+static void op_dox_no_body(s7_scheme *sc)
+{
+ s7_pointer slot, var, test, result;
+ s7_function testf;
+
+ sc->code = cdr(sc->code);
+ var = caar(sc->code);
+ testf = fx_proc(cadr(sc->code));
+ test = caadr(sc->code);
+ result = cdadr(sc->code);
+
+ if ((!in_heap(sc->code)) &&
+ (is_let(opt3_any(sc->code)))) /* (*repl* 'keymap) anything -> segfault because opt3_any here is #f. (see line 80517) */
+ {
+ s7_pointer let = update_let_with_slot(sc, opt3_any(sc->code), fx_call(sc, cdr(var)));
+ let_set_outlet(let, sc->curlet);
+ set_curlet(sc, let);
+ }
+ else set_curlet(sc, make_let_with_slot(sc, sc->curlet, car(var), fx_call(sc, cdr(var))));
+
+ slot = let_slots(sc->curlet);
+ if ((is_t_integer(slot_value(slot))) &&
+ ((integer(opt2_con(sc->code))) != 0))
+ {
+ s7_int incr = integer(opt2_con(sc->code));
+ s7_pointer istep = make_mutable_integer(sc, integer(slot_value(slot))); /* mutable integer is faster here than wrapped */
+ /* this can cause unexpected, but correct behavior: (do ((x 0) (i 0 (+ i 1))) ((= i 1) x) (set! x (memq x '(0)))) -> #f
+ * because (eq? 0 x) here is false -- memv will return '(0). tree-count is similar.
+ */
+ 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;
+ }
+ else while (testf(sc, test) == sc->F) {integer(istep) += incr;}
+ if (is_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);
+ }
+ else
+ {
+ 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));
+ }
+ else while (testf(sc, test) == sc->F) {slot_set_value(slot, stepf(sc, step));}
+ sc->value = fx_call(sc, result);
+ }
+}
+
+static void op_dox_pending_no_body(s7_scheme *sc)
+{
+ s7_pointer test, slots;
+ bool all_steps = true;
+ s7_pointer let = inline_make_let(sc, sc->curlet);
+ sc->temp1 = let;
+ sc->code = cdr(sc->code);
+ for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars))
+ {
+ add_slot(sc, let, caar(vars), fx_call(sc, cdar(vars)));
+ if (is_pair(cddar(vars)))
+ slot_set_expression(let_slots(let), cddar(vars));
+ else
+ {
+ all_steps = false;
+ slot_just_set_expression(let_slots(let), sc->nil);
+ }}
+ slots = let_slots(let);
+ set_curlet(sc, let);
+ sc->temp1 = sc->unused;
+ test = cadr(sc->code);
+
+ let_set_has_pending_value(sc->curlet);
+ if ((all_steps) &&
+ (!tis_slot(next_slot(next_slot(slots)))) &&
+ (is_pair(cdr(test))))
+ {
+ s7_pointer slot1 = slots;
+ s7_pointer expr1 = slot_expression(slot1);
+ 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));
+ }
+ sc->code = cdr(test);
+ let_clear_has_pending_value(sc, sc->curlet);
+ return;
+ }
+ while ((sc->value = fx_call(sc, test)) == sc->F)
+ {
+ 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);
+ } while (tis_slot(slt));
+ slt = slots;
+ do {
+ 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);
+ let_clear_has_pending_value(sc, sc->curlet);
+}
+
+static bool op_do_no_vars(s7_scheme *sc)
+{
+ s7_pointer p, form = sc->code;
+ int32_t i;
+ opt_info *body[32];
+ sc->code = cdr(sc->code);
+ sc->pc = 0;
+
+ for (i = 0, p = cddr(sc->code); (is_pair(p)) && (i < 32); i++, p = cdr(p))
+ {
+ body[i] = sc->opts[sc->pc];
+ if (!cell_optimize(sc, p))
+ break;
+ }
+ if (is_null(p))
+ {
+ s7_pointer end = 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 */
+ 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]);
+ sc->code = cdr(end); /* inner let still active during result */
+ return(true);
+ }
+ /* back out */
+ pair_set_syntax_op(form, OP_DO_NO_VARS_NO_OPT);
+ set_curlet(sc, make_let(sc, sc->curlet));
+ sc->value = fx_call(sc, cadr(sc->code));
+ if (is_true(sc, sc->value))
+ {
+ sc->code = cdadr(sc->code);
+ return(true);
+ }
+ push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1);
+ sc->code = T_Pair(cddr(sc->code));
+ return(false);
+}
+
+static void op_do_no_vars_no_opt(s7_scheme *sc)
+{
+ sc->code = cdr(sc->code);
+ set_curlet(sc, inline_make_let(sc, sc->curlet));
+}
+
+static bool op_do_no_vars_no_opt_1(s7_scheme *sc)
+{
+ sc->value = fx_call(sc, cadr(sc->code));
+ if (is_true(sc, sc->value))
+ {
+ sc->code = cdadr(sc->code);
+ return(true);
+ }
+ push_stack_no_args_direct(sc, OP_DO_NO_VARS_NO_OPT_1);
+ sc->code = T_Pair(cddr(sc->code));
+ return(false);
+}
+
+static void op_do_no_body_na_vars(s7_scheme *sc) /* vars fxable, end-test not */
+{
+ s7_pointer stepper = NULL;
+ s7_int steppers = 0;
+ s7_pointer let = inline_make_let(sc, sc->curlet);
+ sc->temp1 = let;
+ sc->code = cdr(sc->code);
+ for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars))
+ {
+ 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);
+ }
+ else slot_just_set_expression(let_slots(let), sc->nil);
+ }
+ if (steppers == 1) let_set_dox_slot1(let, stepper);
+ set_curlet(sc, let);
+ sc->temp1 = sc->unused;
+ push_stack_no_args_direct(sc, (intptr_t)((steppers == 1) ? OP_DO_NO_BODY_NA_VARS_STEP_1 : OP_DO_NO_BODY_NA_VARS_STEP));
+ sc->code = caadr(sc->code);
+}
+
+static bool op_do_no_body_na_vars_step(s7_scheme *sc)
+{
+ if (sc->value != sc->F)
+ {
+ sc->code = cdadr(sc->code);
+ return(true);
+ }
+ for (s7_pointer slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot))
+ if (slot_has_expression(slot))
+ slot_set_value(slot, fx_call(sc, slot_expression(slot)));
+ push_stack_no_args_direct(sc, OP_DO_NO_BODY_NA_VARS_STEP);
+ sc->code = caadr(sc->code);
+ return(false);
+}
+
+static bool op_do_no_body_na_vars_step_1(s7_scheme *sc)
+{
+ if (sc->value != sc->F)
+ {
+ sc->code = cdadr(sc->code);
+ return(true);
+ }
+ slot_set_value(let_dox_slot1(sc->curlet), fx_call(sc, slot_expression(let_dox_slot1(sc->curlet))));
+ push_stack_no_args_direct(sc, OP_DO_NO_BODY_NA_VARS_STEP_1);
+ sc->code = caadr(sc->code);
+ return(false);
+}
+
+static bool do_step1(s7_scheme *sc)
+{
+ while (true)
+ {
+ 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);
+ }
+ 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 */
+ }
+ else
+ {
+ push_stack_direct(sc, OP_DO_STEP2);
+ sc->code = car(code);
+ return(false);
+ }}
+}
+
+static bool op_do_step2(s7_scheme *sc)
+{
+ if (is_multiple_value(sc->value))
+ syntax_error_nr(sc, "do: variable step value can't be ~S", 35, set_ulist_1(sc, sc->values_symbol, sc->value));
+ slot_set_pending_value(car(sc->args), sc->value); /* save current value */
+ sc->args = cdr(sc->args); /* go to next step var */
+ return(do_step1(sc));
+}
+
+static bool op_do_step(s7_scheme *sc) /* called only in eval OP_DO_STEP via op_do_end_false */
+{
+ /* increment all vars, return to endtest
+ * these are also updated in parallel at the end, so we gather all the incremented values first
+ * here we know car(sc->args) is not null, args is the list of steppable vars,
+ * any unstepped vars in the do var section are not in this list, so
+ * (do ((i 0 (+ i 1)) (j 2)) ...) arrives here with sc->args: '(slot<((+ i 1)=expr, 0=pending_value>)) -- is this comment correct?
+ */
+ push_stack_direct(sc, OP_DO_END);
+ sc->args = car(sc->args); /* the var data lists */
+ sc->code = T_Lst(sc->args); /* save the top of the list */
+ return(do_step1(sc));
+}
+
+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);
+ /* 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);
+ return(goto_eval);
+ }
+ if (has_fx(sc->code))
+ {
+ sc->value = fx_call(sc, sc->code);
+ return(goto_start);
+ }
+ sc->code = T_Pair(car(sc->code));
+ return(goto_eval);
+}
+
+static bool do_end_clauses(s7_scheme *sc)
+{
+ if (!is_null(sc->code))
+ return(false);
+ if (is_multiple_value(sc->value))
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+ return(true);
+}
+
+static bool opt_do_copy(s7_scheme *sc, opt_info *o, s7_int start, s7_int stop)
+{
+ s7_pointer (*fp)(opt_info *o) = o->v[0].fp; /* o->v[6].p_pi_f is getter, o->v[5].p_pip_f is setter */
+ if (start >= stop) return(true);
+ if ((fp == opt_p_pip_sso) &&
+ (type(slot_value(o->v[1].p)) == type(slot_value(o->v[3].p))) &&
+ (o->v[2].p == o->v[4].p))
+ {
+ s7_pointer caller = NULL;
+ 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;
+ 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 (start < 0)
+ 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);
+ if ((caller) && (copy_to_same_type(sc, dest, source, start, stop, start)))
+ return(true);
+ }
+ return(false);
+}
+
+static bool op_simple_do_1(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer step_expr, step_var, ctr_slot, end_slot;
+ s7_function stepf, endf;
+ s7_pfunc func;
+
+ if (no_cell_opt(cddr(code)))
+ return(false);
+ func = s7_optimize_nv(sc, cddr(code));
+ if (!func)
+ {
+ set_no_cell_opt(cddr(code));
+ return(false);
+ }
+ /* func must be set */
+ step_expr = opt2_pair(code); /* caddr(caar(code)) */
+ stepf = fn_proc(step_expr);
+ endf = fn_proc(caadr(code));
+ ctr_slot = let_dox_slot1(sc->curlet);
+ end_slot = let_dox_slot2(sc->curlet);
+ step_var = caddr(step_expr);
+ /* use g* funcs (not fx) because we're passing the actual values, not the expressions */
+
+ if ((stepf == g_add_x1) &&
+ (is_t_integer(slot_value(ctr_slot))) &&
+ ((endf == g_num_eq_2) || (endf == g_num_eq_xi) || (endf == g_geq_2)) &&
+ (is_t_integer(slot_value(end_slot))))
+ {
+ s7_int i;
+ s7_int start = integer(slot_value(ctr_slot));
+ 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);
+ }}
+ 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);
+ }}
+ sc->value = sc->T;
+ sc->code = cdadr(code);
+ return(true);
+ }
+ if ((stepf == g_subtract_x1) &&
+ (is_t_integer(slot_value(ctr_slot))) &&
+ ((endf == g_less_x0) || (endf == g_less_2) || (endf == g_less_xi)) &&
+ (is_t_integer(slot_value(end_slot))))
+ {
+ 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);
+ }}}
+ 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);
+ }
+ sc->value = sc->T;
+ sc->code = cdadr(code);
+ return(true);
+ }
+ if ((stepf == g_add_2_xi) &&
+ (is_t_integer(slot_value(ctr_slot))) &&
+ ((endf == g_num_eq_2) || (endf == g_num_eq_xi) || (endf == g_geq_2)) &&
+ (is_t_integer(slot_value(end_slot))))
+ {
+ 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);
+ }}
+ else
+ 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);
+ }
+ if (func == opt_cell_any_nv)
+ {
+ 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);
+ }}
+ 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);
+ }
+ 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));
+ } while ((sc->value = endf(sc, sc->t2_1)) == sc->F);
+ sc->code = cdadr(code);
+ return(true);
+}
+
+static bool op_simple_do(s7_scheme *sc)
+{
+ /* body might not be safe in this case, but the step and end exprs are easy */
+ s7_pointer code = cdr(sc->code);
+ s7_pointer end = opt1_any(code); /* caddr(caadr(code)) */
+ s7_pointer body = cddr(code);
+
+ set_curlet(sc, make_let(sc, sc->curlet));
+ sc->value = fx_call(sc, cdaar(code));
+ let_set_dox_slot1(sc->curlet, add_slot_checked(sc, sc->curlet, caaar(code), sc->value));
+
+ if (is_symbol(end))
+ let_set_dox_slot2(sc->curlet, s7_slot(sc, end));
+ else let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end));
+ set_car(sc->t2_1, let_dox1_value(sc->curlet));
+ set_car(sc->t2_2, let_dox2_value(sc->curlet));
+ sc->value = fn_proc(caadr(code))(sc, sc->t2_1);
+ if (is_true(sc, sc->value))
+ {
+ sc->code = cdadr(code);
+ return(true); /* goto DO_END_CLAUSES */
+ }
+ if ((is_null(cdr(body))) && /* one expr in body */
+ (is_pair(car(body))) && /* and it is a pair */
+ (is_symbol(cadr(opt2_pair(code)))) && /* caddr(caar(code)), caar=(i 0 (+ i 1)), caddr=(+ i 1), so this checks that stepf is reasonable? */
+ (is_t_integer(caddr(opt2_pair(code)))) &&
+ (op_simple_do_1(sc, cdr(sc->code))))
+ return(true); /* goto DO_END_CLAUSES */
+
+ push_stack_no_args(sc, OP_SIMPLE_DO_STEP, code);
+ sc->code = body;
+ return(false); /* goto BEGIN */
+}
+
+static bool op_simple_do_step(s7_scheme *sc)
+{
+ s7_pointer ctr = let_dox_slot1(sc->curlet);
+ s7_pointer end = let_dox_slot2(sc->curlet);
+ s7_pointer code = sc->code;
+ s7_pointer step = opt2_pair(code); /* caddr(caar(code)) */
+ if (is_symbol(cadr(step)))
+ {
+ set_car(sc->t2_1, slot_value(ctr));
+ set_car(sc->t2_2, caddr(step));
+ }
+ else /* is_symbol(caddr(step)) I think: (+ 1 x) vs (+ x 1) */
+ {
+ set_car(sc->t2_2, slot_value(ctr));
+ set_car(sc->t2_1, cadr(step));
+ }
+ slot_set_value(ctr, fn_proc(step)(sc, sc->t2_1));
+ set_car(sc->t2_1, slot_value(ctr));
+ set_car(sc->t2_2, slot_value(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);
+ }
+ push_stack_direct(sc, OP_SIMPLE_DO_STEP);
+ sc->code = T_Pair(cddr(code));
+ return(false);
+}
+
+static bool op_safe_do_step(s7_scheme *sc)
+{
+ s7_int end = integer(let_dox2_value(sc->curlet));
+ s7_pointer slot = let_dox_slot1(sc->curlet);
+ s7_int step = integer(slot_value(slot)) + 1;
+ slot_set_value(slot, make_integer(sc, step));
+ if ((step == end) ||
+ ((step > end) && (opt1_cfunc(caadr(sc->code)) == sc->geq_2)))
+ {
+ sc->value = sc->T;
+ sc->code = cdadr(sc->code);
+ return(true);
+ }
+ push_stack_direct(sc, OP_SAFE_DO_STEP);
+ sc->code = T_Pair(opt2_pair(sc->code));
+ return(false);
+}
+
+static bool op_safe_dotimes_step(s7_scheme *sc)
+{
+ s7_pointer arg = slot_value(sc->args);
+ numerator(arg)++;
+ if (numerator(arg) == loop_end(sc->args))
+ {
+ sc->value = sc->T;
+ sc->code = cdadr(sc->code);
+ return(true);
+ }
+ push_stack_direct(sc, OP_SAFE_DOTIMES_STEP);
+ sc->code = opt2_pair(sc->code); /* here we know the body has more than one form */
+ push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(sc->code)));
+ sc->code = car(sc->code);
+ return(false);
+}
+
+static bool op_safe_dotimes_step_o(s7_scheme *sc)
+{
+ s7_pointer arg = slot_value(sc->args);
+ numerator(arg)++;
+ if (numerator(arg) == loop_end(sc->args))
+ {
+ sc->value = sc->T;
+ sc->code = cdadr(sc->code);
+ return(true);
+ }
+ push_stack_direct(sc, OP_SAFE_DOTIMES_STEP_O);
+ sc->code = opt2_pair(sc->code);
+ return(false);
+}
+
+static /* inline */ bool op_dotimes_step_o(s7_scheme *sc) /* called once in eval, mat(10+6), num(7+1) */
+{
+ s7_pointer ctr = let_dox_slot1(sc->curlet);
+ s7_pointer end = let_dox2_value(sc->curlet);
+ s7_pointer now = slot_value(ctr);
+ s7_pointer code = sc->code;
+ s7_pointer end_test = opt2_pair(code);
+
+ if (is_t_integer(now))
+ {
+ 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);
+ }}
+ 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);
+ }}}
+ else
+ {
+ slot_set_value(ctr, g_add_x1(sc, with_list_t1(now)));
+ /* (define (hi) (let ((x 0.0) (y 1.0)) (do ((i y (+ i 1))) ((= i 6)) (do ((i i (+ i 1))) ((>= i 7)) (set! x (+ x i)))) x)) */
+ set_car(sc->t2_1, slot_value(ctr));
+ 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);
+ }}
+ push_stack_direct(sc, OP_DOTIMES_STEP_O);
+ sc->code = caddr(code);
+ return(false);
+}
+
+static bool opt_dotimes(s7_scheme *sc, s7_pointer code, s7_pointer scc, bool loop_end_ok)
+{
+ s7_pointer step_val;
+ if (loop_end_ok)
+ set_safe_stepper(sc->args);
+ else set_safe_stepper(let_dox_slot1(sc->curlet));
+
+ if (is_null(cdr(code)))
+ {
+ s7_pfunc func;
+ if (no_cell_opt(code)) return(false);
+ func = s7_optimize_nv(sc, code);
+ if (!func)
+ {
+ 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);
+ }
+ 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 */
+ sc->value = sc->T;
+ sc->code = cdadr(scc);
+ return(true);
+ }
+
+ { /* not is_null(cdr(code)) i.e. there's more than one thing to do in the body */
+ s7_pointer p;
+ s7_int body_len = s7_list_length(sc, code);
+ opt_info *body[32];
+ int32_t k;
+
+ sc->pc = 0;
+ if (body_len >= 32) return(false);
+
+ 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);
+ }}
+
+ /* 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;
+ }
+
+ 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);
+ }}
+ return(false);
+}
+
+static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc)
+{
+ s7_pointer let_body, p = NULL, let_vars, let_code = caddr(scc), ip;
+ bool let_star;
+ s7_pointer old_e, stepper;
+ s7_int body_len, var_len, k, end;
+ #define O_SIZE 32
+ opt_info *body[O_SIZE], *vars[O_SIZE];
+ memclr((void *)body, O_SIZE * sizeof(opt_info *)); /* placate the damned compiler */
+ memclr((void *)vars, O_SIZE * sizeof(opt_info *));
+
+ /* do_let with non-float vars doesn't get many fixable hits */
+ if ((!is_pair(cdr(let_code))) || (!is_list(cadr(let_code)))) /* (do ((j 0 (+ j 1))) ((= j 1)) (let name 123)) */
+ return(false);
+ let_body = cddr(let_code);
+ body_len = s7_list_length(sc, let_body);
+ if ((body_len <= 0) || (body_len >= 32)) return(false);
+ let_star = (symbol_syntax_op_checked(let_code) == OP_LET_STAR);
+ let_vars = cadr(let_code);
+ set_safe_stepper(step_slot);
+ stepper = slot_value(step_slot);
+ old_e = sc->curlet;
+ set_curlet(sc, make_let(sc, sc->curlet));
+
+ sc->pc = 0;
+ 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);
+ 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);
+ }
+ if (let_star)
+ add_slot_checked(sc, sc->curlet, caar(p), make_mutable_real(sc, 1.5));
+ }
+
+ if (!let_star)
+ for (p = let_vars; is_pair(p); p = cdr(p))
+ add_slot_checked(sc, sc->curlet, caar(p), make_mutable_real(sc, 1.5));
+
+ for (k = 0, p = let_body; is_pair(p); k++, p = cdr(p))
+ {
+ body[k] = sc->opts[sc->pc];
+ if (!float_optimize(sc, p))
+ {
+ set_curlet(sc, old_e);
+ return(false);
+ }}
+ if (!is_null(p)) /* no hits in s7test or snd-test */
+ {
+ set_curlet(sc, old_e);
+ return(false);
+ }
+ end = loop_end(step_slot);
+ let_set_slots(sc->curlet, reverse_slots(let_slots(sc->curlet)));
+ ip = slot_value(step_slot);
+
+ 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 */
+ 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 */
+ 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]);
+ }}
+ 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]);
+ }
+ set_curlet(sc, old_e);
+ sc->value = sc->T;
+ sc->code = cdadr(scc);
+ return(true);
+}
+
+static bool do_let_or_dotimes(s7_scheme *sc, s7_pointer code, bool loop_end_ok)
+{
+ s7_pointer body = caddr(code); /* here we assume one expr in body?? */
+ if (((is_syntactic_pair(body)) ||
+ (is_symbol_and_syntactic(car(body)))) &&
+ ((symbol_syntax_op_checked(body) == OP_LET) ||
+ (symbol_syntax_op(car(body)) == OP_LET_STAR)))
+ return(do_let(sc, sc->args, code));
+ return(opt_dotimes(sc, cddr(code), code, loop_end_ok));
+}
+
+static goto_t op_safe_dotimes(s7_scheme *sc)
+{
+ s7_pointer init_val, form = sc->code;
+ sc->code = cdr(sc->code);
+
+ init_val = fx_call(sc, cdaar(sc->code));
+ if (s7_is_integer(init_val))
+ {
+ s7_pointer end_expr = caadr(sc->code);
+ s7_pointer code = sc->code;
+ s7_pointer end_val = caddr(end_expr);
+ if (is_symbol(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);
+ }}
+ pair_set_syntax_op(form, OP_SIMPLE_DO);
+ sc->code = form;
+ if (op_simple_do(sc)) return(goto_do_end_clauses);
+ return(goto_begin);
+}
+
+static goto_t op_safe_do(s7_scheme *sc)
+{
+ /* body is safe, step = +1, end is = or >=, but stepper and end might be set (or at least indirectly exported) in the body:
+ * (let ((lst ())) (do ((i 0 (+ i 1))) ((= i 10)) (let ((j (min i 100))) (set! lst (cons j lst)))) lst)
+ * however, we're very restrictive about this in check_do and do_is_safe; even this is considered trouble:
+ * (let ((x 0)) (do ((i i (+ i 1))) ((= i 7)) (set! x (+ x i))) x)
+ * but end might not be an integer -- need to catch this earlier.
+ */
+ s7_pointer end, init_val, end_val, code, form = sc->code;
+
+ /* inits, if not >= opt_dotimes else safe_do_step */
+ sc->code = cdr(sc->code);
+ code = sc->code;
+ init_val = fx_call(sc, cdaar(code));
+ end = opt1_any(code); /* caddr(caadr(code)) */
+ end_val = (is_symbol(end)) ? lookup_checked(sc, end) : end;
+
+ if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val))) /* this almost never happens */
+ {
+ pair_set_syntax_op(form, OP_DO_UNCHECKED);
+ return(goto_do_unchecked);
+ }
+ /* (let ((sum 0)) (define (hi) (do ((i 10 (+ i 1))) ((= i 10) i) (set! sum (+ sum i)))) (hi)) */
+ set_curlet(sc, make_let(sc, sc->curlet));
+ let_set_dox_slot1(sc->curlet, add_slot_checked(sc, sc->curlet, caaar(code), init_val)); /* define the step var -- might be needed in the end clauses */
+
+ if ((s7_integer_clamped_if_gmp(sc, init_val) == s7_integer_clamped_if_gmp(sc, end_val)) ||
+ ((s7_integer_clamped_if_gmp(sc, init_val) > s7_integer_clamped_if_gmp(sc, end_val)) &&
+ (opt1_cfunc(caadr(code)) == sc->geq_2)))
+ {
+ sc->value = sc->T;
+ sc->code = cdadr(code);
+ return(goto_safe_do_end_clauses);
+ }
+
+ if (is_symbol(end))
+ let_set_dox_slot2(sc->curlet, s7_slot(sc, end));
+ else let_set_dox_slot2(sc->curlet, make_slot(sc, caaar(code), end));
+ sc->args = let_dox_slot2(sc->curlet); /* the various safe steps assume sc->args is the end slot */
+
+ {
+ s7_pointer step_slot = let_dox_slot1(sc->curlet);
+ slot_set_value(step_slot, make_mutable_integer(sc, integer(slot_value(step_slot))));
+ set_loop_end(step_slot, s7_integer_clamped_if_gmp(sc, end_val));
+ set_has_loop_end(step_slot);
+ }
+
+ if (!is_unsafe_do(sc->code))
+ {
+ 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);
+ set_curlet(sc, old_let); /* apparently s7_optimize can step on sc->curlet? */
+ sc->temp7 = sc->unused;
+ }
+
+ if (is_null(cdddr(sc->code))) /* (do ((k 0 (+ k 1))) ((= k 2)) (set! sum (+ sum 1))) */
+ {
+ 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);
+ }}}
+ sc->code = cddr(code);
+ set_unsafe_do(sc->code);
+ set_opt2_pair(code, sc->code);
+ push_stack_no_args(sc, OP_SAFE_DO_STEP, code); /* (do ((i 0 (+ i 1))) ((= i 2)) (set! (str i) #\a)) */
+ return(goto_begin);
+}
+
+static goto_t op_dotimes_p(s7_scheme *sc)
+{
+ s7_pointer code = cdr(sc->code), end_val, slot, old_e;
+ s7_pointer end = opt1_any(code); /* caddr(opt2_pair(code)) */
+ /* (do ... (set! args ...)) -- one line, syntactic */
+
+ s7_pointer init_val = fx_call(sc, cdaar(code));
+ sc->value = init_val;
+ set_opt2_pair(code, caadr(code));
+ if (is_symbol(end))
+ {
+ slot = s7_slot(sc, end);
+ end_val = slot_value(slot);
+ }
+ else
+ {
+ slot = make_slot(sc, make_symbol(sc, "___end___", 9), end); /* name is ignored, but needs to be > 8 chars for gcc's benefit (version 10.2.1)! */
+ end_val = end;
+ }
+ if ((!s7_is_integer(init_val)) || (!s7_is_integer(end_val)))
+ {
+ pair_set_syntax_op(sc->code, OP_DO_UNCHECKED);
+ sc->code = cdr(sc->code);
+ return(goto_do_unchecked);
+ }
+
+ old_e = sc->curlet;
+ set_curlet(sc, make_let(sc, sc->curlet));
+ let_set_dox_slot1(sc->curlet, add_slot_checked(sc, sc->curlet, caaar(code), init_val));
+ let_set_dox_slot2(sc->curlet, slot);
+
+ set_car(sc->t2_1, let_dox1_value(sc->curlet));
+ set_car(sc->t2_2, let_dox2_value(sc->curlet));
+ if (is_true(sc, sc->value = fn_proc(caadr(code))(sc, sc->t2_1)))
+ {
+ sc->code = cdadr(code);
+ return(goto_do_end_clauses);
+ }
+ if ((!is_unsafe_do(code)) &&
+ (opt1_cfunc(caadr(code)) != sc->geq_2))
+ {
+ s7_pointer old_args = sc->args;
+ s7_pointer old_init = let_dox1_value(sc->curlet);
+ sc->args = T_Slt(let_dox_slot1(sc->curlet)); /* used in opt_dotimes */
+ slot_set_value(sc->args, make_mutable_integer(sc, integer(let_dox1_value(sc->curlet))));
+ set_loop_end(sc->args, integer(let_dox2_value(sc->curlet)));
+ 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 */
+ 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;
+ set_unsafe_do(code);
+ return(goto_do_unchecked);
+ }
+ push_stack_no_args(sc, OP_DOTIMES_STEP_O, code);
+ sc->code = caddr(code);
+ return(goto_eval);
+}
+
+static bool op_do_init_1(s7_scheme *sc)
+{
+ s7_pointer y, z;
+ while (true) /* at start, first value is the loop (for GC protection?), returning sc->value is the next value */
+ {
+ s7_pointer init;
+ sc->args = cons(sc, sc->value, sc->args); /* code will be last element (first after reverse), these cons's will be used below for the new let/slots */
+ if (!is_pair(sc->code)) break;
+ /* 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);
+ 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;
+ }
+ sc->code = cdr(sc->code);
+ }
+ /* all the initial values are now in the args list */
+ sc->args = proper_list_reverse_in_place(sc, sc->args);
+ sc->code = car(sc->args); /* saved at the start */
+ z = sc->args;
+ sc->args = cdr(sc->args); /* init values */
+
+ /* sc->args was cons'd above, so it should be safe to reuse it as the new let */
+ set_curlet(sc, reuse_as_let(sc, z, T_Let(sc->curlet))); /* set_curlet(sc, make_let(sc, sc->curlet)); */
+
+ /* run through sc->code and sc->args adding '( caar(car(code)) . car(args) ) to sc->curlet, also reuse sc->args as the new let slots */
+ sc->value = sc->nil;
+ y = sc->args;
+ for (s7_pointer x = car(sc->code); is_not_null(y); x = cdr(x))
+ {
+ s7_pointer sym = caar(x), args = cdr(y);
+ reuse_as_slot(y, sym, unchecked_car(y));
+ slot_set_next(y, let_slots(sc->curlet));
+ 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);
+ }
+ y = args;
+ }
+ sc->args = cons(sc, sc->value = proper_list_reverse_in_place(sc, sc->value), cadr(sc->code));
+ sc->code = cddr(sc->code);
+ return(false); /* fall through */
+}
+
+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)));
+ return(!op_do_init_1(sc));
+}
+
+static void op_do_unchecked(s7_scheme *sc)
+{
+ gc_protect_via_stack(sc, sc->code);
+ sc->code = cdr(sc->code);
+}
+
+static bool do_unchecked(s7_scheme *sc)
+{
+ if (is_null(car(sc->code))) /* (do () ...) -- (let ((i 0)) (do () ((= i 1)) (set! i 1))) */
+ {
+ set_curlet(sc, make_let(sc, sc->curlet));
+ sc->args = cons_unchecked(sc, sc->nil, cadr(sc->code));
+ sc->code = cddr(sc->code);
+ return(false);
+ }
+ /* eval each init value, then set up the new let (like let, not let*) */
+ sc->args = sc->nil; /* the evaluated var-data */
+ sc->value = sc->code; /* protect it */
+ sc->code = car(sc->code); /* the vars */
+ return(op_do_init_1(sc));
+}
+
+static bool op_do_end(s7_scheme *sc)
+{
+ /* car(sc->args) here is the var list used by do_end2 */
+ 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);
+ }
+ sc->value = fx_call(sc, cdr(sc->args));
+ }
+ else sc->value = sc->F; /* goto "if (is_pair(sc->code))..." below */
+ return(false);
+}
+
+static goto_t op_do_end_false(s7_scheme *sc)
+{
+ if (!is_pair(sc->code))
+ return((is_null(car(sc->args))) ? /* no steppers */ goto_do_end : fall_through);
+ if (is_null(car(sc->args)))
+ push_stack_direct(sc, OP_DO_END);
+ else push_stack_direct(sc, OP_DO_STEP);
+ return(goto_begin);
+}
+
+static goto_t op_do_end_true(s7_scheme *sc)
+{
+ /* we're done -- deal with result exprs, if there isn't an end test, there also isn't a result (they're in the same list)
+ * multiple-value end-test result is ok
+ */
+ sc->code = T_Lst(cddr(sc->args)); /* result expr (a list -- implicit begin) */
+ /* unsafe: free_cell(sc, sc->args); */ /* t101-aux-8|13 */
+ sc->args = sc->nil;
+ 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));
+ /* 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);
+ }
+ /* might be => here as in cond and case */
+ if (is_null(cdr(sc->code)))
+ {
+ if (has_fx(sc->code))
+ {
+ sc->value = fx_call(sc, sc->code);
+ return(goto_start);
+ }
+ sc->code = car(sc->code);
+ return(goto_eval);
+ }
+ if (is_undefined_feed_to(sc, car(sc->code)))
+ return(goto_feed_to);
+ push_stack_no_args(sc, sc->begin_op, cdr(sc->code));
+ sc->code = car(sc->code);
+ return(goto_eval);
+}
+
+
+/* -------------------------------- apply functions -------------------------------- */
+static inline s7_pointer apply_c_function(s7_scheme *sc, s7_pointer func, s7_pointer args) /* -------- C-based function -------- */
+{
+ 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));
+ 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));
+ 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
+ * gdb with break apply_c_function breaks at macroexpand -- confusing!
+ */
+}
+
+static s7_pointer apply_c_function_unopt(s7_scheme *sc, s7_pointer func, s7_pointer args) /* an experiment -- callgrind says this saves time */
+{
+ 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));
+ 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));
+ return(c_function_call(func)(sc, args));
+}
+
+static void apply_c_rst_no_req_function(s7_scheme *sc) /* -------- C-based function that can take any number of arguments -------- */
+{
+ if ((S7_DEBUGGING) && (type(sc->code) == T_C_FUNCTION_STAR)) fprintf(stderr, "%s: c_func*!\n", __func__);
+ sc->value = c_function_call(sc->code)(sc, sc->args);
+}
+
+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));
+ 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));
+ sc->code = c_macro_call(sc->code)(sc, sc->args);
+}
+
+static void apply_syntax(s7_scheme *sc) /* -------- syntactic keyword as applicable object -------- */
+{ /* current reader-cond macro uses this via (map quote ...) */
+ s7_int len; /* ((apply lambda '((x) (+ x 1))) 4) */
+ if (is_pair(sc->args)) /* this is ((pars) . body) */
+ {
+ len = s7_list_length(sc, sc->args);
+ if (len == 0)
+ 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));
+ }
+ 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));
+ 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));
+ 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);
+ set_current_code(sc, sc->code);
+ pair_set_syntax_op(sc->code, sc->cur_op);
+}
+
+static void apply_vector(s7_scheme *sc) /* -------- vector as applicable object -------- */
+{
+ /* sc->code is the vector, sc->args is the list of indices */
+ if (is_null(sc->args)) /* (#2d((1 2) (3 4))) */
+ wrong_number_of_arguments_error_nr(sc, "implicit vector-ref nedes an index argument: (~A)", 49, sc->code);
+ if ((is_null(cdr(sc->args))) &&
+ (s7_is_integer(car(sc->args))) &&
+ (vector_rank(sc->code) == 1))
+ {
+ 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);
+ 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);
+}
+
+static void apply_string(s7_scheme *sc) /* -------- string as applicable object -------- */
+{
+ 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));
+ 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));
+
+ 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;
+ }}
+ sc->value = string_ref_1(sc, sc->code, car(sc->args));
+}
+
+static bool apply_pair(s7_scheme *sc) /* -------- list as applicable object -------- */
+{
+ if (is_multiple_value(sc->code)) /* ((values + 2 3) 4) */
+ {
+ /* car of values can be anything, so conjure up a new expression, and apply again */
+ sc->args = pair_append(sc, cdr(sc->code), T_Lst(sc->args)); /* can't use pair_append_in_place here */
+ sc->code = car(sc->code);
+ return(false);
+ }
+ if (is_null(sc->args))
+ wrong_number_of_arguments_error_nr(sc, "implicit list-ref needs an index argument: (~S)", 47, sc->code);
+ sc->value = list_ref_1(sc, sc->code, car(sc->args)); /* (L 1) */
+ if (!is_null(cdr(sc->args)))
+ sc->value = implicit_index_checked(sc, sc->code, sc->value, sc->args);
+ return(true);
+}
+
+static void apply_hash_table(s7_scheme *sc) /* -------- hash-table as applicable object -------- */
+{
+ if (is_null(sc->args))
+ wrong_number_of_arguments_error_nr(sc, "implicit hash-table-ref needs a key to lookup: (~S)", 51, sc->code);
+ sc->value = s7_hash_table_ref(sc, sc->code, car(sc->args));
+ if (!is_null(cdr(sc->args)))
+ sc->value = implicit_index_checked(sc, sc->code, sc->value, sc->args);
+}
+
+static void apply_let(s7_scheme *sc) /* -------- environment as applicable object -------- */
+{
+ if (is_null(sc->args))
+ wrong_number_of_arguments_error_nr(sc, "implicit let-ref needs a symbol to lookup: (~S)", 47, sc->code);
+ sc->value = let_ref(sc, sc->code, car(sc->args));
+ if (is_pair(cdr(sc->args)))
+ sc->value = implicit_index_checked(sc, sc->code, sc->value, sc->args);
+ /* (let ((v #(1 2 3))) (let ((e (curlet))) ((e 'v) 1))) -> 2
+ * so (let ((v #(1 2 3))) (let ((e (curlet))) (e 'v 1))) -> 2
+ */
+}
+
+static void apply_iterator(s7_scheme *sc) /* -------- iterator as applicable object -------- */
+{
+ 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));
+ sc->value = s7_iterate(sc, sc->code);
+}
+
+static Inline void inline_apply_lambda(s7_scheme *sc) /* -------- normal function (lambda), or macro --------, called once in eval */
+{ /* load up the current args into the ((args) (lambda)) layout [via the current environment] */
+ s7_pointer x, z, e = sc->curlet, slot, last_slot = slot_end;
+ uint64_t id = let_id(sc->curlet);
+
+ for (x = closure_args(sc->code), z = T_Lst(sc->args); is_pair(x); x = cdr(x), z = cdr(z)) /* closure_args can be a symbol, for example */
+ {
+ 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));
+ 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);
+ else let_set_slots(e, slot);
+ last_slot = slot;
+ slot_set_next(slot, slot_end);
+ }
+ 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));
+ }
+ 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);
+ else let_set_slots(e, slot);
+ slot_set_next(slot, slot_end);
+ }
+ sc->code = closure_body(sc->code);
+}
+
+static void op_f(s7_scheme *sc) /* sc->code: ((lambda () 32)) -> (let () 32) */
+{
+ set_curlet(sc, make_let(sc, sc->curlet));
+ sc->code = opt3_pair(sc->code); /* cddar */
+}
+
+static void op_f_a(s7_scheme *sc) /* sc->code: ((lambda (x) (+ x 1)) i) -> (let ((x i)) (+ x 1)) */
+{
+ /* if caddar(sc->code) is fxable [(+ x 1) above], this could call fx and return to the top */
+ set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, opt3_sym(cdr(sc->code)), fx_call(sc, cdr(sc->code))));
+ sc->code = opt3_pair(sc->code);
+}
+
+static void op_f_aa(s7_scheme *sc) /* sc->code: ((lambda (x y) (+ x y)) i j) -> (let ((x i) (y j)) (+ x y)) */
+{
+ gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code)));
+ set_curlet(sc, make_let_with_two_slots(sc, sc->curlet, opt3_sym(cdr(sc->code)), stack_protected1(sc), cadadr(car(sc->code)), fx_call(sc, cddr(sc->code))));
+ unstack_gc_protect(sc);
+ sc->code = opt3_pair(sc->code);
+}
+
+static void op_f_np(s7_scheme *sc) /* sc->code: ((lambda (x y) (+ x y)) (values i j)) -> (let ((x i) (y j)) (+ x y)) after splice */
+{
+ s7_pointer pars = cadar(sc->code);
+ s7_pointer e = make_let(sc, sc->curlet);
+ if (is_pair(pars))
+ {
+ 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)));
+ 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)));
+
+ 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 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);
+ }}
+ /* 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 */
+ push_stack(sc, OP_F_NP_1, e, sc->code);
+ sc->code = cadr(sc->code);
+}
+
+static bool op_f_np_1(s7_scheme *sc)
+{
+ s7_pointer e, slot = stack_protected1(sc), arg = stack_protected2(sc);
+ if (is_multiple_value(sc->value))
+ {
+ 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_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)));
+ slot = oslot; /* snd-test 22 grani */
+ }
+ else /* not mv */
+ if (!is_rest_slot(slot))
+ slot_set_value(slot, sc->value);
+ else
+ if (slot_value(slot) == sc->undefined)
+ 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)));
+ 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 */
+ sc->code = car(arg);
+ return(true);
+ }
+ 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)));
+ if (slot_value(next_slot(slot)) == sc->undefined)
+ slot_set_value(next_slot(slot), sc->nil);
+ }
+ e = sc->args;
+ let_set_id(e, ++sc->let_number);
+ set_curlet(sc, e);
+ update_symbol_ids(sc, e);
+ sc->code = cddar(sc->code);
+ unstack_gc_protect(sc);
+ return(false);
+}
+
+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);
+ 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);
+}
+
+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);
+ 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);
+}
+
+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));
+ 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_checked_slot(slot);
+ slot_set_value(slot, val);
+ return(val);
+}
+
+static s7_pointer lambda_star_argument_set_value(s7_scheme *sc, const s7_pointer sym, s7_pointer val, s7_pointer slot, bool check_rest)
+{
+ if (val == sc->no_value) val = sc->unspecified;
+ if (sym == slot_symbol(slot))
+ return(star_set(sc, slot, val, check_rest));
+ for (s7_pointer x = let_slots(sc->curlet) /* presumably the arglist */; tis_slot(x); x = next_slot(x))
+ if (slot_symbol(x) == sym)
+ return(star_set(sc, x, val, check_rest));
+ return(sc->no_value);
+}
+
+static s7_pointer lambda_star_set_args(s7_scheme *sc)
+{
+ s7_pointer arg_vals = sc->args, rest_key = sc->nil, code = sc->code, args = sc->args;
+ s7_pointer slot = let_slots(sc->curlet);
+ s7_pointer pars = closure_args(code);
+ bool allow_other_keys = ((is_pair(pars)) && (allows_other_keys(pars)));
+
+ while ((is_pair(pars)) &&
+ (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);
+ }
+ 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);
+ }}
+ /* (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 */
+
+ /* check for trailing args with no :rest arg */
+ 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 */
+ }}
+ 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);
+ }}}
+ return(sc->nil);
+}
+
+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 */
+ }}}
+ return(false); /* goto BEGIN */
+}
+
+static bool op_lambda_star_default(s7_scheme *sc)
+{
+ /* sc->args is the current let slots position, sc->value is the default expression's value */
+ if (is_multiple_value(sc->value))
+ syntax_error_nr(sc, "lambda*: argument default value can't be ~S", 43, set_ulist_1(sc, sc->values_symbol, sc->value));
+ slot_set_value(sc->args, sc->value);
+ sc->args = next_slot(sc->args);
+ if (lambda_star_default(sc)) return(true);
+ pop_stack_no_op(sc);
+ sc->code = T_Pair(closure_body(sc->code));
+ return(false); /* goto BEGIN */
+}
+
+static inline bool set_star_args(s7_scheme *sc, s7_pointer top)
+{
+ lambda_star_set_args(sc); /* load up current arg vals */
+ sc->args = top;
+ if (is_slot(sc->args))
+ {
+ /* get default values, which may involve evaluation -- see also OP_LAMBDA_STAR_DEFAULT */
+ push_stack_direct(sc, OP_GC_PROTECT);
+ if (lambda_star_default(sc)) return(true); /* else fall_through */
+ pop_stack_no_op(sc); /* get original args and code back */
+ }
+ sc->code = closure_body(sc->code);
+ return(false); /* goto BEGIN */
+}
+
+static inline bool apply_safe_closure_star_1(s7_scheme *sc) /* -------- define* (lambda*) -------- */
+{
+ /* slots are in "reverse order" -- in the same order as the args, despite let printout (which reverses the order!) */
+ set_curlet(sc, closure_let(sc->code));
+ 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);
+ }
+ if (!is_null(sc->args))
+ lambda_star_set_args(sc); /* load up current arg vals */
+ sc->code = closure_body(sc->code);
+ return(false); /* goto BEGIN */
+ }
+ for (s7_pointer z = let_slots(sc->curlet); tis_slot(z); z = next_slot(z))
+ {
+ clear_checked_slot(z);
+ slot_set_value(z, (slot_defaults(z)) ? sc->undefined : slot_expression(z));
+ }
+ return(set_star_args(sc, slot_pending_value(let_slots(sc->curlet))));
+}
+
+static bool apply_unsafe_closure_star_1(s7_scheme *sc)
+{
+ s7_pointer z, top = sc->nil;
+ for (z = closure_args(sc->code); is_pair(z); z = cdr(z))
+ {
+ 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;
+ }
+ 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_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)));
+ return(set_star_args(sc, top));
+}
+
+static void apply_macro_star_1(s7_scheme *sc)
+{
+ /* here the defaults (if any) are not evalled, and there is not an existing let */
+ s7_pointer p;
+ for (p = closure_args(sc->code); is_pair(p); p = cdr(p))
+ {
+ s7_pointer par = car(p);
+ if (is_pair(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_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)));
+ lambda_star_set_args(sc);
+ sc->code = T_Pair(closure_body(sc->code));
+}
+
+static void clear_absolutely_all_optimizations(s7_pointer p)
+{
+ if ((is_pair(p)) && (!is_matched_pair(p)))
+ {
+ clear_has_fx(p);
+ clear_optimized(p);
+ clear_optimize_op(p);
+ set_match_pair(p);
+ clear_absolutely_all_optimizations(cdr(p));
+ clear_absolutely_all_optimizations(car(p));
+ }
+}
+
+static void clear_matches(s7_pointer p)
+{
+ if ((is_pair(p)) && (is_matched_pair(p)))
+ {
+ clear_match_pair(p);
+ clear_matches(car(p));
+ clear_matches(cdr(p));
+ }
+}
+
+static void apply_macro(s7_scheme *sc) /* this is not from the reader, so treat expansions here as normal macros */
+{
+ check_stack_size(sc);
+ if (closure_arity_to_int(sc, sc->code) < 0)
+ {
+ clear_absolutely_all_optimizations(sc->args); /* desperation... */
+ clear_matches(sc->args);
+ }
+ push_stack_op_let(sc, OP_EVAL_MACRO);
+ set_curlet(sc, inline_make_let(sc, closure_let(sc->code))); /* closure_let -> sc->curlet, sc->code is the macro */
+ transfer_macro_info(sc, sc->code);
+}
+
+static void apply_bacro(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack_op_let(sc, OP_EVAL_MACRO);
+ set_curlet(sc, make_let(sc, sc->curlet)); /* like let* -- we'll be adding macro args, so might as well sequester things here */
+ transfer_macro_info(sc, sc->code);
+}
+
+static void apply_macro_star(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack_op_let(sc, OP_EVAL_MACRO);
+ set_curlet(sc, make_let(sc, closure_let(sc->code)));
+ transfer_macro_info(sc, sc->code);
+ apply_macro_star_1(sc);
+}
+
+static void apply_bacro_star(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack_op_let(sc, OP_EVAL_MACRO);
+ set_curlet(sc, make_let(sc, sc->curlet));
+ transfer_macro_info(sc, sc->code);
+ apply_macro_star_1(sc);
+}
+
+static void apply_closure(s7_scheme *sc)
+{
+ /* we can get safe_closures here, but can't easily determine whether we have the expected saved funclet */
+ check_stack_size(sc);
+ set_curlet(sc, inline_make_let(sc, closure_let(sc->code)));
+}
+
+static bool apply_closure_star(s7_scheme *sc)
+{
+ if (is_safe_closure(sc->code))
+ return(apply_safe_closure_star_1(sc));
+ check_stack_size(sc);
+ set_curlet(sc, make_let(sc, closure_let(sc->code)));
+ return(apply_unsafe_closure_star_1(sc));
+}
+
+static inline s7_pointer op_safe_closure_star_a1(s7_scheme *sc, s7_pointer code) /* called in eval and below, tlamb */
+{
+ s7_pointer func = opt1_lambda(code);
+ s7_pointer val = fx_call(sc, cdr(code));
+ if ((is_symbol_and_keyword(val)) &&
+ (!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), val, sc->args));
+ set_curlet(sc, update_let_with_slot(sc, closure_let(func), val));
+ sc->code = T_Pair(closure_body(func));
+ return(func);
+}
+
+static void op_safe_closure_star_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer func = op_safe_closure_star_a1(sc, code);
+ s7_pointer p = cdr(closure_args(func));
+ 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);
+ }
+}
+
+static void op_safe_closure_star_ka(s7_scheme *sc, s7_pointer code) /* two args, but k=arg key, key has been checked. no trailing pars */
+{
+ s7_pointer func = opt1_lambda(code);
+ set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cddr(code))));
+ sc->code = T_Pair(closure_body(func));
+}
+
+static void op_safe_closure_star_aa(s7_scheme *sc, s7_pointer code)
+{
+ /* here closure_arity == 2 and we have 2 args and those args' defaults are simple (no eval or lookup needed) */
+ s7_pointer arg2, func = opt1_lambda(code);
+ s7_pointer arg1 = fx_call(sc, cdr(code));
+ sc->w = arg1; /* weak GC protection */
+ arg2 = fx_call(sc, cddr(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;
+ }
+ 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 */
+ }
+ else
+ if ((is_symbol_and_keyword(arg2)) &&
+ (!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));
+}
+
+static bool call_lambda_star(s7_scheme *sc, s7_pointer code, s7_pointer arglist)
+{
+ bool target;
+ sc->code = opt1_lambda(code);
+ target = apply_safe_closure_star_1(sc);
+ if (!in_heap(arglist)) clear_list_in_use(arglist);
+ return(target);
+}
+
+static bool op_safe_closure_star_aaa(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer arg2, arg3, func = opt1_lambda(code);
+ s7_pointer arg1 = fx_call(sc, cdr(code));
+ gc_protect_via_stack(sc, arg1);
+ arg2 = fx_call(sc, cddr(code));
+ set_stack_protected2(sc, arg2);
+ arg3 = fx_call(sc, cdddr(code));
+ if ((is_symbol_and_keyword(arg1)) || (is_symbol_and_keyword(arg2)) || (is_symbol_and_keyword(arg3)))
+ {
+ s7_pointer arglist = make_safe_list(sc, 3);
+ sc->args = arglist;
+ set_car(arglist, arg1);
+ set_cadr(arglist, arg2);
+ set_caddr(arglist, arg3);
+ unstack_gc_protect(sc);
+ return(call_lambda_star(sc, code, arglist)); /* this clears list_in_use */
+ }
+ set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), arg1, arg2, arg3));
+ unstack_gc_protect(sc);
+ sc->code = T_Pair(closure_body(func));
+ if_pair_set_up_begin_unchecked(sc);
+ return(true);
+}
+
+static bool op_safe_closure_star_na_0(s7_scheme *sc, s7_pointer code)
+{
+ sc->args = sc->nil;
+ sc->code = opt1_lambda(code);
+ return(apply_safe_closure_star_1(sc));
+}
+
+static bool op_safe_closure_star_na_1(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer arglist = safe_list_1(sc);
+ sc->args = arglist;
+ set_car(arglist, fx_call(sc, cdr(code)));
+ return(call_lambda_star(sc, code, arglist)); /* clears list_in_use */
+}
+
+static bool op_safe_closure_star_na_2(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer arglist = safe_list_2(sc);
+ sc->args = arglist;
+ set_car(arglist, fx_call(sc, cdr(code)));
+ set_cadr(arglist, fx_call(sc, cddr(code)));
+ return(call_lambda_star(sc, code, arglist)); /* clears list_in_use */
+}
+
+static inline bool op_safe_closure_star_na(s7_scheme *sc, s7_pointer code) /* called once in eval, clo */
+{
+ s7_pointer arglist = safe_list_if_possible(sc, opt3_arglen(cdr(code)));
+ sc->args = arglist;
+ for (s7_pointer p = arglist, old_args = cdr(code); is_pair(p); p = cdr(p), old_args = cdr(old_args))
+ set_car(p, fx_call(sc, old_args));
+ return(call_lambda_star(sc, code, arglist)); /* clears list_in_use */
+}
+
+static void op_closure_star_ka(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer func = opt1_lambda(code);
+ s7_pointer p = car(closure_args(func));
+ sc->value = fx_call(sc, cddr(code));
+ set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), (is_pair(p)) ? car(p) : p, sc->value));
+ sc->code = T_Pair(closure_body(func));
+}
+
+static void op_closure_star_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer p, func = opt1_lambda(code);
+ sc->value = fx_call(sc, cdr(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));
+ 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)
+ {
+ 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);
+ }}
+ sc->code = T_Pair(closure_body(func));
+}
+
+static inline bool op_closure_star_na(s7_scheme *sc, s7_pointer code)
+{
+ /* check_stack_size(sc); */
+ if (is_pair(cdr(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));
+ sc->w = sc->unused;
+ }
+ else sc->args = sc->nil;
+ sc->code = opt1_lambda(code);
+ set_curlet(sc, inline_make_let(sc, closure_let(sc->code)));
+ return(apply_unsafe_closure_star_1(sc));
+}
+
+static s7_pointer define1_caller(s7_scheme *sc)
+{
+ /* we can jump to op_define1, so this is not fool-proof */
+ if (sc->cur_op == OP_DEFINE_CONSTANT) return(sc->define_constant_symbol);
+ if ((sc->cur_op == OP_DEFINE_STAR) || (sc->cur_op == OP_DEFINE_STAR_UNCHECKED)) return(sc->define_star_symbol);
+ return(sc->define_symbol);
+}
+
+static bool op_define1(s7_scheme *sc)
+{
+ /* sc->code is the symbol being defined, sc->value is its value
+ * if sc->value is a closure, car is of the form ((args...) body...)
+ * it's not possible to expand and replace macros at this point without evaluating
+ * the body. Just as examples, say we have a macro "mac",
+ * (define (hi) (call/cc (lambda (mac) (mac 1))))
+ * (define (hi) (quote (mac 1))) or macroexpand etc
+ * (define (hi mac) (mac 1)) assuming mac here is a function passed as an arg, etc...
+ * the immutable constant check needs to wait until we have the actual new value because
+ * we want to ignore the rebinding (not raise an error) if it is the existing value.
+ * This happens when we reload a file that calls define-constant. But we want a
+ * warning if we got define (as opposed to the original define-constant).
+ */
+ 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));
+ 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 */
+
+ 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));
+ }
+ 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(false); /* fall through */
+}
+
+static void set_let_file_and_line(s7_scheme *sc, s7_pointer new_let, s7_pointer new_func)
+{
+ 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)));
+ }
+ 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)));
+ }
+ set_has_let_file(new_let);
+ }
+ else
+ {
+ let_set_file(new_let, 0);
+ let_set_line(new_let, 0);
+ clear_has_let_file(new_let);
+ }
+}
+
+static void op_define_with_setter(s7_scheme *sc)
+{
+ s7_pointer code = sc->code;
+ if ((is_immutable(sc->curlet)) &&
+ (is_let(sc->curlet))) /* not () */
+ immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't define ~S: curlet is immutable", 36), code));
+
+ if ((is_any_closure(sc->value)) &&
+ ((!(is_let(closure_let(sc->value)))) ||
+ (!(is_funclet(closure_let(sc->value)))))) /* otherwise it's (define f2 f1) or something similar */
+ {
+ 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);
+ }
+ 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
+ * the enclosing environment (else we can accidentally shadow something that happens
+ * to share an argument name that is being used as a default value -- kinda dumb!).
+ * I think I'll check this before setting the safe_closure bit.
+ */
+ 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);
+ }
+ 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);
+ }
+ 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);
+ }}
+ 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);
+ }}
+}
+
+
+/* -------------------------------- eval -------------------------------- */
+static void check_for_cyclic_code(s7_scheme *sc, s7_pointer code)
+{
+ if (tree_is_cyclic(sc, code))
+ {
+ sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (sc->stack_size - ((STACK_RESIZE_TRIGGER) / 2)));
+ syntax_error_nr(sc, "attempt to evaluate a circular list: ~A", 39, code);
+ }
+ resize_stack(sc); /* we've already checked that resize_stack is needed */
+}
+
+static void op_thunk(s7_scheme *sc)
+{
+ s7_pointer p = opt1_lambda(sc->code);
+ set_curlet(sc, inline_make_let(sc, closure_let(p)));
+ sc->code = T_Pair(closure_body(p));
+ if_pair_set_up_begin(sc);
+}
+
+static void op_thunk_o(s7_scheme *sc)
+{
+ s7_pointer p = opt1_lambda(sc->code);
+ set_curlet(sc, inline_make_let(sc, closure_let(p)));
+ sc->code = car(closure_body(p));
+}
+
+static void op_safe_thunk(s7_scheme *sc) /* no let needed */
+{
+ s7_pointer p = opt1_lambda(sc->code);
+ set_curlet(sc, closure_let(p));
+ sc->code = T_Pair(closure_body(p));
+ if_pair_set_up_begin_unchecked(sc);
+}
+
+static s7_pointer op_safe_thunk_a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer f = opt1_lambda(code);
+ set_curlet(sc, closure_let(f));
+ return(fx_call(sc, closure_body(f)));
+}
+
+static void op_thunk_any(s7_scheme *sc)
+{
+ s7_pointer p = opt1_lambda(sc->code);
+ set_curlet(sc, make_let_with_slot(sc, closure_let(p), closure_args(p), sc->nil));
+ sc->code = closure_body(p);
+}
+
+static void op_safe_thunk_any(s7_scheme *sc)
+{
+ s7_pointer p = opt1_lambda(sc->code);
+ set_curlet(sc, closure_let(p));
+ slot_set_value(let_slots(sc->curlet), sc->nil);
+ sc->code = T_Pair(closure_body(p));
+ if_pair_set_up_begin_unchecked(sc);
+}
+
+static void op_closure_s(s7_scheme *sc)
+{
+ s7_pointer p = opt1_lambda(sc->code);
+ check_stack_size(sc);
+ set_curlet(sc, inline_make_let_with_slot(sc, closure_let(p), car(closure_args(p)), lookup(sc, opt2_sym(sc->code))));
+ sc->code = T_Pair(closure_body(p));
+ if_pair_set_up_begin_unchecked(sc);
+}
+
+static inline void op_closure_s_o(s7_scheme *sc)
+{
+ s7_pointer f = opt1_lambda(sc->code);
+ set_curlet(sc, inline_make_let_with_slot(sc, closure_let(f), car(closure_args(f)), lookup(sc, opt2_sym(sc->code))));
+ sc->code = car(closure_body(f));
+}
+
+static void op_safe_closure_s(s7_scheme *sc)
+{
+ s7_pointer p = opt1_lambda(sc->code);
+ set_curlet(sc, update_let_with_slot(sc, closure_let(p), lookup(sc, opt2_sym(sc->code))));
+ sc->code = T_Pair(closure_body(p));
+ if_pair_set_up_begin_unchecked(sc);
+}
+
+static void op_safe_closure_s_o(s7_scheme *sc)
+{
+ s7_pointer f = opt1_lambda(sc->code);
+ set_curlet(sc, update_let_with_slot(sc, closure_let(f), lookup(sc, opt2_sym(sc->code))));
+ sc->code = car(closure_body(f));
+}
+
+static void op_safe_closure_p(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack_no_args(sc, OP_SAFE_CLOSURE_P_1, opt1_lambda(sc->code));
+ sc->code = cadr(sc->code);
+}
+
+static void op_safe_closure_p_1(s7_scheme *sc)
+{
+ set_curlet(sc, update_let_with_slot(sc, closure_let(sc->code), sc->value));
+ sc->code = T_Pair(closure_body(sc->code));
+}
+
+static void op_safe_closure_p_a(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack_no_args_direct(sc, OP_SAFE_CLOSURE_P_A_1);
+ sc->code = cadr(sc->code);
+}
+
+static void op_safe_closure_p_a_1(s7_scheme *sc)
+{
+ s7_pointer f = opt1_lambda(sc->code);
+ set_curlet(sc, update_let_with_slot(sc, closure_let(f), sc->value));
+ sc->value = fx_call(sc, closure_body(f));
+}
+
+static Inline void inline_op_closure_a(s7_scheme *sc) /* called twice in eval */
+{
+ s7_pointer f = opt1_lambda(sc->code);
+ sc->value = fx_call(sc, cdr(sc->code));
+ set_curlet(sc, inline_make_let_with_slot(sc, closure_let(f), car(closure_args(f)), sc->value));
+ sc->code = T_Pair(closure_body(f));
+}
+
+static void op_safe_closure_3s(s7_scheme *sc)
+{
+ s7_pointer args = cddr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ set_curlet(sc, update_let_with_three_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), lookup(sc, car(args)), lookup(sc, cadr(args))));
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin_unchecked(sc);
+}
+
+static void op_safe_closure_ssa(s7_scheme *sc) /* possibly inline b */
+{ /* ssa_a is hit once, but is only about 3/4% faster -- there's the fx overhead, etc */
+ s7_pointer args = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ set_curlet(sc, update_let_with_three_slots(sc, closure_let(f), lookup(sc, car(args)), lookup(sc, cadr(args)), fx_call(sc, cddr(args))));
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin_unchecked(sc);
+}
+
+static void op_safe_closure_saa(s7_scheme *sc)
+{
+ s7_pointer f = opt1_lambda(sc->code);
+ s7_pointer args = cddr(sc->code);
+ s7_pointer arg2 = lookup(sc, cadr(sc->code)); /* I don't see fx_t|u here? */
+ sc->code = fx_call(sc, args);
+ set_curlet(sc, update_let_with_three_slots(sc, closure_let(f), arg2, sc->code, fx_call(sc, cdr(args))));
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin_unchecked(sc);
+}
+
+static void op_safe_closure_agg(s7_scheme *sc) /* possibly inline tleft */
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ set_curlet(sc, update_let_with_three_slots(sc, closure_let(f), fx_call(sc, args), fx_call(sc, cdr(args)), fx_call(sc, cddr(args))));
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin_unchecked(sc);
+}
+
+static void op_closure_p(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack_no_args(sc, OP_CLOSURE_P_1, opt1_lambda(sc->code));
+ sc->code = cadr(sc->code);
+}
+
+static void op_closure_p_1(s7_scheme *sc)
+{
+ set_curlet(sc, inline_make_let_with_slot(sc, closure_let(sc->code), car(closure_args(sc->code)), sc->value));
+ sc->code = T_Pair(closure_body(sc->code));
+}
+
+static void op_safe_closure_a(s7_scheme *sc)
+{
+ s7_pointer f = opt1_lambda(sc->code);
+ set_curlet(sc, update_let_with_slot(sc, closure_let(f), fx_call(sc, cdr(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);
+}
+
+static void op_safe_closure_a_o(s7_scheme *sc)
+{
+ s7_pointer f = opt1_lambda(sc->code);
+ set_curlet(sc, update_let_with_slot(sc, closure_let(f), fx_call(sc, cdr(sc->code))));
+ sc->code = car(closure_body(f));
+}
+
+static void op_closure_ap(s7_scheme *sc)
+{
+ s7_pointer code = sc->code;
+ sc->args = fx_call(sc, cdr(code));
+ /* (hook-push (undo-hook ind 0) (lambda (hook) (set! u0 #t))) -> #<unused>
+ * g_undo_hook calls s7_eval_c_string so it obviously should be declared unsafe!
+ */
+ push_stack(sc, OP_CLOSURE_AP_1, opt1_lambda(sc->code), sc->args);
+ sc->code = caddr(code);
+}
+
+static void op_closure_ap_1(s7_scheme *sc)
+{
+ /* sc->value is presumably the "P" argument value, "A" is sc->args->sc->code above (sc->args here is opt1_lambda(original sc->code)) */
+ set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(sc->args), car(closure_args(sc->args)), sc->code, cadr(closure_args(sc->args)), sc->value));
+ sc->code = T_Pair(closure_body(sc->args));
+}
+
+static void op_closure_pa(s7_scheme *sc)
+{
+ s7_pointer code = sc->code;
+ sc->args = fx_call(sc, cddr(code));
+ check_stack_size(sc);
+ push_stack(sc, OP_CLOSURE_PA_1, sc->args, opt1_lambda(sc->code)); /* "p" can be self-call changing func locally! so pass opt1_lambda(sc->code), not sc->code */
+ sc->code = cadr(code);
+}
+
+static void op_closure_pa_1(s7_scheme *sc)
+{
+ set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(sc->code), car(closure_args(sc->code)), sc->value, cadr(closure_args(sc->code)), sc->args));
+ sc->code = T_Pair(closure_body(sc->code));
+}
+
+static void op_closure_pp(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack(sc, OP_CLOSURE_PP_1, opt1_lambda(sc->code), sc->code);
+ sc->code = cadr(sc->code);
+}
+
+static void op_closure_pp_1(s7_scheme *sc)
+{
+ push_stack(sc, OP_CLOSURE_AP_1, sc->args, sc->value);
+ sc->code = caddr(sc->code);
+}
+
+static void op_safe_closure_ap(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ sc->args = fx_call(sc, cdr(sc->code));
+ push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->args, opt1_lambda(sc->code));
+ sc->code = caddr(sc->code);
+}
+
+static void op_safe_closure_ap_1(s7_scheme *sc)
+{
+ set_curlet(sc, update_let_with_two_slots(sc, closure_let(sc->code), sc->args, sc->value));
+ sc->code = T_Pair(closure_body(sc->code));
+}
+
+static void op_safe_closure_pa(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ sc->args = fx_call(sc, cddr(sc->code));
+ push_stack(sc, OP_SAFE_CLOSURE_PA_1, sc->args, opt1_lambda(sc->code));
+ sc->code = cadr(sc->code);
+}
+
+static void op_safe_closure_pa_1(s7_scheme *sc)
+{
+ set_curlet(sc, update_let_with_two_slots(sc, closure_let(sc->code), sc->value, sc->args));
+ sc->code = T_Pair(closure_body(sc->code));
+}
+
+static void op_safe_closure_pp(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack(sc, OP_SAFE_CLOSURE_PP_1, opt1_lambda(sc->code), sc->code);
+ sc->code = cadr(sc->code);
+}
+
+static void op_safe_closure_pp_1(s7_scheme *sc)
+{
+ push_stack(sc, OP_SAFE_CLOSURE_AP_1, sc->value, sc->args);
+ sc->code = caddr(sc->code);
+}
+
+static void op_any_closure_3p(s7_scheme *sc)
+{
+ s7_pointer p = cdr(sc->code);
+ if (has_fx(p))
+ {
+ 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);
+ }
+ else
+ {
+ 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);
+ sc->code = car(p);
+ }
+}
+
+static bool closure_3p_end(s7_scheme *sc, s7_pointer p)
+{
+ if (has_fx(p))
+ {
+ s7_pointer func = opt1_lambda(sc->code);
+ 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)));
+ 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));
+ return(true);
+ }
+ push_stack_direct(sc, OP_ANY_CLOSURE_3P_3);
+ set_stack_protected3_with(sc, sc->value, OP_ANY_CLOSURE_3P_3); /* arg2 == curlet stack loc */
+ sc->code = car(p);
+ return(false);
+}
+
+static bool op_any_closure_3p_1(s7_scheme *sc)
+{
+ s7_pointer p = cddr(sc->code);
+ sc->args = sc->value; /* (arg1 of closure) sc->value can be clobbered by fx_call? */
+ if (has_fx(p))
+ {
+ sc->value = fx_call(sc, p);
+ return(closure_3p_end(sc, cdr(p)));
+ }
+ push_stack_direct(sc, OP_ANY_CLOSURE_3P_2);
+ sc->code = car(p);
+ return(false);
+}
+
+static bool op_any_closure_3p_2(s7_scheme *sc) {return(closure_3p_end(sc, cdddr(sc->code)));}
+
+static void op_any_closure_3p_3(s7_scheme *sc)
+{
+ /* display(obj) will not work here because sc->curlet is being used as arg2 of the closure3 */
+ s7_pointer func = opt1_lambda(sc->code); /* incoming args (from pop_stack): sc->args, sc->curlet, and sc->value from last evaluation */
+ if (is_safe_closure(func))
+ set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), sc->args, sc->curlet, sc->value));
+ else make_let_with_three_slots(sc, func, sc->args, sc->curlet, sc->value);
+ sc->code = T_Pair(closure_body(func));
+}
+
+static void op_any_closure_4p(s7_scheme *sc)
+{
+ s7_pointer p = cdr(sc->code);
+ check_stack_size(sc);
+ if (has_fx(p))
+ {
+ 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);
+ }}
+ 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);
+ }}
+ else
+ {
+ push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_1);
+ sc->code = car(p);
+ }
+}
+
+static bool closure_4p_end(s7_scheme *sc, s7_pointer p)
+{
+ if (has_fx(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));
+ 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);
+ return(true);
+ }
+ push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4);
+ sc->code = car(p);
+ return(false);
+}
+
+static bool op_any_closure_4p_1(s7_scheme *sc)
+{
+ s7_pointer p = cddr(sc->code);
+ gc_protect_via_stack(sc, sc->value);
+ 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));
+ return(closure_4p_end(sc, cdr(p)));
+ }
+ push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3);
+ sc->code = car(p);
+ }
+ else
+ {
+ push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2);
+ sc->code = car(p);
+ }
+ return(false);
+}
+
+static bool op_any_closure_4p_2(s7_scheme *sc)
+{
+ s7_pointer p = cdddr(sc->code);
+ set_stack_protected2(sc, sc->value);
+ if (has_fx(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);
+ return(false);
+}
+
+static bool op_any_closure_4p_3(s7_scheme *sc)
+{
+ set_stack_protected3(sc, sc->value);
+ return(closure_4p_end(sc, cddddr(sc->code)));
+}
+
+static inline void op_any_closure_4p_4(s7_scheme *sc)
+{
+ s7_pointer func = opt1_lambda(sc->code);
+ 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->value));
+ else make_let_with_four_slots(sc, func, stack_protected1(sc), stack_protected2(sc), stack_protected3(sc), sc->value);
+ sc->code = T_Pair(closure_body(func));
+ unstack_gc_protect(sc);
+}
+
+static void op_safe_closure_ss(s7_scheme *sc)
+{
+ s7_pointer f = opt1_lambda(sc->code);
+ set_curlet(sc, update_let_with_two_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), 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);
+}
+
+static void op_safe_closure_ss_o(s7_scheme *sc)
+{
+ s7_pointer f = opt1_lambda(sc->code);
+ set_curlet(sc, update_let_with_two_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), lookup(sc, opt2_sym(sc->code))));
+ sc->code = car(closure_body(f));
+}
+
+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))));
+ 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);
+}
+
+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))));
+ sc->code = car(closure_body(f));
+}
+
+static void op_safe_closure_sc(s7_scheme *sc)
+{
+ s7_pointer f = opt1_lambda(sc->code);
+ set_curlet(sc, update_let_with_two_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), opt2_con(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);
+}
+
+static void op_safe_closure_sc_o(s7_scheme *sc)
+{
+ s7_pointer f = opt1_lambda(sc->code);
+ set_curlet(sc, update_let_with_two_slots(sc, closure_let(f), lookup(sc, cadr(sc->code)), opt2_con(sc->code)));
+ sc->code = car(closure_body(f));
+}
+
+static void op_closure_sc(s7_scheme *sc)
+{
+ s7_pointer f = opt1_lambda(sc->code);
+ check_stack_size(sc);
+ set_curlet(sc, make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), lookup(sc, cadr(sc->code)), cadr(closure_args(f)), opt2_con(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);
+}
+
+static inline void op_closure_sc_o(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)), opt2_con(sc->code)));
+ sc->code = car(closure_body(f));
+}
+
+static void op_closure_3s(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer v1 = lookup(sc, car(args));
+ s7_pointer f = opt1_lambda(sc->code);
+ args = cdr(args);
+ make_let_with_three_slots(sc, f, v1, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin(sc);
+}
+
+static inline void op_closure_3s_o(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer v1 = lookup(sc, car(args));
+ s7_pointer f = opt1_lambda(sc->code);
+ args = cdr(args);
+ make_let_with_three_slots(sc, f, v1, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */
+ sc->code = car(closure_body(f));
+}
+
+static void op_closure_4s(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer v1 = lookup(sc, car(args)), v2 = lookup(sc, cadr(args));
+ s7_pointer f = opt1_lambda(sc->code);
+ args = cddr(args);
+ make_let_with_four_slots(sc, f, v1, v2, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin(sc);
+}
+
+static inline void op_closure_4s_o(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer v1 = lookup(sc, car(args)), v2 = lookup(sc, cadr(args));
+ s7_pointer f = opt1_lambda(sc->code);
+ args = cddr(args);
+ make_let_with_four_slots(sc, f, v1, v2, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */
+ sc->code = car(closure_body(f));
+}
+
+static void op_closure_5s(s7_scheme *sc) /* .1 in lg but this is marginal -- adds two ops etc */
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer v1 = lookup(sc, car(args)), v2 = lookup(sc, cadr(args));
+ s7_pointer f = opt1_lambda(sc->code);
+ args = cddr(args);
+ make_let_with_five_slots(sc, f, v1, v2, lookup(sc, car(args)), lookup(sc, cadr(args)), lookup(sc, caddr(args))); /* sets sc->curlet */
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin(sc);
+}
+
+static void op_safe_closure_aa(s7_scheme *sc)
+{
+ s7_pointer p = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ sc->code = fx_call(sc, cdr(p)); /* fx_call can affect sc->value, but not sc->code, I think */
+ set_curlet(sc, update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), sc->code));
+ p = T_Pair(closure_body(f));
+ /* check_stack_size(sc); */ /* pretty-print if cycles=#f? */
+ push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(p)));
+ sc->code = car(p);
+}
+
+static inline void op_safe_closure_aa_o(s7_scheme *sc)
+{
+ s7_pointer p = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ sc->code = fx_call(sc, cdr(p));
+ set_curlet(sc, update_let_with_two_slots(sc, closure_let(f), fx_call(sc, p), sc->code));
+ sc->code = car(closure_body(f));
+ /* (let values ((x 1) (y 2)) (values 1 2)): sc->code incoming is 0x7fffbf681c98 (values 1 2), car(closure_body) out is the same -> infinite loop! */
+}
+
+static void op_closure_aa(s7_scheme *sc)
+{
+ s7_pointer p = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ sc->code = fx_call(sc, cdr(p));
+ sc->value = fx_call(sc, p);
+ set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), sc->value, cadr(closure_args(f)), sc->code));
+ p = T_Pair(closure_body(f));
+ check_stack_size(sc);
+ push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(p)));
+ sc->code = car(p);
+}
+
+static Inline void inline_op_closure_aa_o(s7_scheme *sc) /* called once in eval, b cb left lg list */
+{
+ s7_pointer p = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ sc->code = fx_call(sc, cdr(p));
+ sc->value = fx_call(sc, p);
+ set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(f), car(closure_args(f)), sc->value, cadr(closure_args(f)), sc->code));
+ sc->code = car(closure_body(f));
+}
+
+static /* inline */ void op_closure_fa(s7_scheme *sc) /* "inline" matters perhaps in texit.scm */
+{
+ s7_pointer new_clo, code = sc->code;
+ s7_pointer farg = opt2_pair(code); /* cdadr(code), '((a . b) (cons a b)) for (lambda (a . b) (cons a b)) */
+ s7_pointer aarg = fx_call(sc, cddr(code));
+ s7_pointer func = opt1_lambda(code); /* outer func */
+ s7_pointer func_args = closure_args(func); /* outer func args (not the arglist of the applied func) */
+ sc->value = inline_make_let_with_two_slots(sc, closure_let(func), car(func_args), sc->F, cadr(func_args), aarg);
+ new_clo = make_closure_unchecked(sc, car(farg), cdr(farg), T_CLOSURE | ((!s7_is_proper_list(sc, car(farg))) ? T_COPY_ARGS : 0), CLOSURE_ARITY_NOT_SET);
+ /* this is checking the called closure arglist (see op_lambda), arity<0 probably not usable since "f" in "fa" is a parameter */
+ slot_set_value(let_slots(sc->value), new_clo); /* this order allows us to use make_closure_unchecked */
+ set_curlet(sc, sc->value);
+ sc->code = car(closure_body(func));
+}
+
+static void op_safe_closure_ns(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ s7_pointer let = closure_let(f);
+ uint64_t id = ++sc->let_number;
+ let_set_id(let, id);
+ for (s7_pointer x = let_slots(let); tis_slot(x); x = next_slot(x), args = cdr(args))
+ {
+ slot_set_value(x, lookup(sc, car(args)));
+ symbol_set_local_slot(slot_symbol(x), id, x);
+ }
+ set_curlet(sc, let);
+ sc->code = closure_body(f);
+ if_pair_set_up_begin_unchecked(sc);
+}
+
+static inline void op_safe_closure_3a(s7_scheme *sc)
+{
+ s7_pointer p = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ sc->code = fx_call(sc, cdr(p)); /* fx_call can affect sc->value, but not sc->code, I think */
+ sc->args = fx_call(sc, cddr(p)); /* is sc->args safe here? */
+ set_curlet(sc, update_let_with_three_slots(sc, closure_let(f), fx_call(sc, p), sc->code, sc->args));
+ sc->code = closure_body(f);
+ if_pair_set_up_begin_unchecked(sc);
+}
+
+static void op_safe_closure_na(s7_scheme *sc)
+{
+ s7_pointer let;
+ uint64_t id;
+
+ sc->args = safe_list_if_possible(sc, opt3_arglen(cdr(sc->code)));
+ for (s7_pointer args = cdr(sc->code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p))
+ set_car(p, fx_call(sc, args));
+ sc->code = opt1_lambda(sc->code);
+ id = ++sc->let_number;
+ let = closure_let(sc->code);
+ let_set_id(let, id);
+ for (s7_pointer x = let_slots(let), 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);
+ }
+ if (!in_heap(sc->args)) clear_list_in_use(sc->args);
+ set_curlet(sc, let);
+ sc->code = closure_body(sc->code);
+ if_pair_set_up_begin_unchecked(sc);
+}
+
+static /* inline */ void op_closure_ns(s7_scheme *sc) /* called once in eval, lg? */
+{
+ /* in this case, we have just lambda (not lambda*), and no dotted arglist,
+ * and no accessed symbols in the arglist, and we know the arglist matches the parameter list.
+ */
+ s7_pointer args = cdr(sc->code), last_slot;
+ s7_pointer f = opt1_lambda(sc->code);
+ s7_pointer p = closure_args(f);
+ s7_pointer e = inline_make_let(sc, closure_let(f));
+ s7_int id = let_id(e);
+ sc->z = e;
+ add_slot_unchecked(sc, e, car(p), lookup(sc, car(args)), id);
+ last_slot = let_slots(e);
+ for (p = cdr(p), args = cdr(args); is_pair(p); p = cdr(p), args = cdr(args))
+ last_slot = inline_add_slot_at_end(sc, id, last_slot, car(p), lookup(sc, car(args))); /* main such call in lt (fx_s is 1/2, this is 1/5 of all calls) */
+ set_curlet(sc, e);
+ sc->z = sc->unused;
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin(sc);
+}
+
+static void op_closure_ass(s7_scheme *sc) /* possibly inline b */
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ make_let_with_three_slots(sc, f, fx_call(sc, args), lookup(sc, cadr(args)), lookup(sc, caddr(args)));
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin(sc);
+}
+
+static void op_closure_aas(s7_scheme *sc) /* possibly inline b */
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ sc->z = fx_call(sc, args);
+ make_let_with_three_slots(sc, f, sc->z, fx_call(sc, cdr(args)), lookup(sc, caddr(args)));
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin(sc);
+}
+
+static void op_closure_saa(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ sc->z = fx_call(sc, cdr(args));
+ make_let_with_three_slots(sc, f, lookup(sc, car(args)), sc->z, fx_call(sc, cddr(args)));
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin(sc);
+}
+
+static void op_closure_asa(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ sc->z = fx_call(sc, args);
+ make_let_with_three_slots(sc, f, sc->z, lookup(sc, cadr(args)), fx_call(sc, cddr(args)));
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin(sc);
+}
+
+static void op_closure_sas(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ make_let_with_three_slots(sc, f, lookup(sc, car(args)), fx_call(sc, cdr(args)), lookup(sc, caddr(args)));
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin(sc);
+}
+
+static inline void op_closure_3a(s7_scheme *sc) /* if inlined, tlist -60 */
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cdr(args)));
+ make_let_with_three_slots(sc, f, stack_protected1(sc), stack_protected2(sc), fx_call(sc, cddr(args)));
+ unstack_gc_protect(sc);
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin(sc);
+}
+
+static void op_closure_4a(s7_scheme *sc) /* sass */
+{
+ s7_pointer args = cdr(sc->code);
+ s7_pointer f = opt1_lambda(sc->code);
+ gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cddr(args)));
+ args = cdr(args);
+ set_stack_protected3(sc, fx_call(sc, args));
+ make_let_with_four_slots(sc, f, stack_protected1(sc), stack_protected3(sc), stack_protected2(sc), fx_call(sc, cddr(args)));
+ unstack_gc_protect(sc);
+ sc->code = T_Pair(closure_body(f));
+ if_pair_set_up_begin(sc);
+}
+
+static void op_closure_na(s7_scheme *sc)
+{
+ s7_pointer exprs = cdr(sc->code); /* "n" = opt3_arglen(exprs), mostly 5 in lt, 6 in tlet */
+ s7_pointer func = opt1_lambda(sc->code), slot, last_slot;
+ s7_int id;
+ s7_pointer pars = closure_args(func);
+ s7_pointer e = inline_make_let(sc, closure_let(func));
+ sc->z = e;
+ sc->value = fx_call(sc, exprs);
+ new_cell_no_check(sc, last_slot, T_SLOT);
+ slot_set_symbol_and_value(last_slot, car(pars), sc->value);
+ slot_set_next(last_slot, let_slots(e)); /* i.e. slot_end */
+ let_set_slots(e, last_slot);
+ for (pars = cdr(pars), exprs = cdr(exprs); is_pair(pars); pars = cdr(pars), exprs = cdr(exprs))
+ {
+ sc->value = fx_call(sc, exprs); /* before new_cell since it might call the GC */
+ new_cell(sc, slot, T_SLOT); /* args < GC_TRIGGER checked in optimizer, but we're calling fx_call? */
+ slot_set_symbol_and_value(slot, car(pars), sc->value);
+ /* setting up the let might use unrelated-but-same-name symbols, so wait to set the symbol ids */
+ slot_set_next(slot, slot_end);
+ slot_set_next(last_slot, slot);
+ last_slot = slot;
+ }
+ set_curlet(sc, e);
+ sc->z = sc->unused;
+ let_set_id(e, ++sc->let_number);
+ for (id = let_id(e), slot = let_slots(e); tis_slot(slot); slot = next_slot(slot))
+ {
+ symbol_set_local_slot(slot_symbol(slot), id, slot);
+ set_local(slot_symbol(slot));
+ }
+ sc->code = T_Pair(closure_body(func));
+ if_pair_set_up_begin(sc);
+}
+
+static bool check_closure_sym(s7_scheme *sc, int32_t args)
+{
+ /* can't use closure_is_fine -- (lambda args 1) and (lambda (name . args) 1) are both arity -1 for the internal arity checkers! */
+ if ((symbol_ctr(car(sc->code)) != 1) ||
+ (unchecked_local_value(car(sc->code)) != opt1_lambda_unchecked(sc->code)))
+ {
+ 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);
+ }
+ set_opt1_lambda(sc->code, f);
+ }
+ return(true);
+}
+
+static void op_any_closure_sym(s7_scheme *sc) /* for (lambda a ...) */
+{
+ s7_pointer func = opt1_lambda(sc->code), old_args = cdr(sc->code); /* args aren't evaluated yet */
+ s7_int num_args = opt3_arglen(old_args);
+
+ 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))));
+ 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);
+ }
+ else
+ if (num_args == 0)
+ 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->code = T_Pair(closure_body(func));
+}
+
+static void op_any_closure_a_sym(s7_scheme *sc) /* for (lambda (a . b) ...) */
+{
+ s7_pointer func = opt1_lambda(sc->code), old_args = cdr(sc->code);
+ s7_int num_args = opt3_arglen(old_args);
+ s7_pointer func_args = closure_args(func);
+
+ if (num_args == 1)
+ set_curlet(sc, make_let_with_two_slots(sc, closure_let(func), car(func_args), sc->value = fx_call(sc, old_args), cdr(func_args), sc->nil));
+ else
+ {
+ 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)));
+ }
+ 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));
+ }
+ unstack_gc_protect(sc);
+ }
+ sc->code = T_Pair(closure_body(func));
+}
+
+
+/* -------- */
+#if S7_DEBUGGING
+#define TC_REC_SIZE NUM_OPS
+#define TC_REC_LOW_OP OP_TC_AND_A_OR_A_LA
+
+static void init_tc_rec(s7_scheme *sc)
+{
+ sc->tc_rec_calls = (int *)Calloc(TC_REC_SIZE, sizeof(int));
+ add_saved_pointer(sc, sc->tc_rec_calls);
+}
+
+static s7_pointer g_report_missed_calls(s7_scheme *sc, s7_pointer args)
+{
+ for (int32_t i = TC_REC_LOW_OP; i < NUM_OPS; i++)
+ if (sc->tc_rec_calls[i] == 0)
+ fprintf(stderr, "%s missed\n", op_names[i]);
+ return(sc->F);
+}
+
+static void tick_tc(s7_scheme *sc, int32_t op)
+{
+ sc->tc_rec_calls[op]++;
+}
+#else
+#define tick_tc(Sc, Op)
+#endif
+
+static bool op_tc_case_la(s7_scheme *sc, s7_pointer code)
+{
+ /* opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */
+ s7_pointer clauses = cddr(code), la_slot = let_slots(sc->curlet), endp, selp = cdr(code);
+ s7_int len = opt3_arglen(cdr(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;
+ }}
+ 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);
+ CASE_ALA_END:
+ if (has_tc(endp))
+ slot_set_value(la_slot, fx_call(sc, cdr(endp)));
+ else break;
+ }
+ if (has_fx(endp))
+ {
+ sc->value = fx_call(sc, endp);
+ return(true); /* continue */
+ }
+ sc->code = endp;
+ return(false); /* goto BEGIN (not like op_tc_z below) */
+}
+
+static s7_pointer fx_tc_case_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_CASE_LA);
+ op_tc_case_la(sc, arg);
+ return(sc->value);
+}
+
+static bool op_tc_z(s7_scheme *sc, s7_pointer expr)
+{
+ if (has_fx(expr))
+ {
+ sc->value = fx_call(sc, expr);
+ return(true);
+ }
+ sc->code = car(expr);
+ return(false);
+}
+
+static void op_tc_and_a_or_a_la(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet);
+ s7_pointer fx_or = cdadr(fx_and);
+ s7_pointer fx_la = cdadr(fx_or);
+ /* cell_optimize here is slower! */
+ while (true)
+ {
+ s7_pointer p;
+ if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;}
+ p = fx_call(sc, fx_or);
+ if (p != sc->F) {sc->value = p; return;}
+ slot_set_value(la_slot, fx_call(sc, fx_la));
+ }
+}
+
+static s7_pointer fx_tc_and_a_or_a_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_AND_A_OR_A_LA);
+ op_tc_and_a_or_a_la(sc, arg);
+ return(sc->value);
+}
+
+static void op_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet);
+ s7_pointer fx_and = cdadr(fx_or);
+ s7_pointer fx_la = cdadr(fx_and);
+ while (true)
+ {
+ s7_pointer p = fx_call(sc, fx_or);
+ if (p != sc->F) {sc->value = p; return;}
+ if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;}
+ slot_set_value(la_slot, fx_call(sc, fx_la));
+ }
+}
+
+static s7_pointer fx_tc_or_a_and_a_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_OR_A_AND_A_LA);
+ op_tc_or_a_and_a_la(sc, arg);
+ return(sc->value);
+}
+
+static void op_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet);
+ s7_pointer fx_or1 = cdadr(fx_and);
+ s7_pointer fx_or2 = cdr(fx_or1);
+ s7_pointer fx_la = cdadr(fx_or2);
+ while (true)
+ {
+ s7_pointer p;
+ if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;}
+ p = fx_call(sc, fx_or1);
+ if (p != sc->F) {sc->value = p; return;}
+ p = fx_call(sc, fx_or2);
+ if (p != sc->F) {sc->value = p; return;}
+ slot_set_value(la_slot, fx_call(sc, fx_la));
+ }
+}
+
+static s7_pointer fx_tc_and_a_or_a_a_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_AND_A_OR_A_A_LA);
+ op_tc_and_a_or_a_a_la(sc, arg);
+ return(sc->value);
+}
+
+static void op_tc_or_a_and_a_a_la(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet);
+ s7_pointer fx_and1 = cdadr(fx_or);
+ s7_pointer fx_and2 = cdr(fx_and1);
+ s7_pointer fx_la = cdadr(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;}
+ slot_set_value(la_slot, fx_call(sc, fx_la));
+ }
+}
+
+static s7_pointer fx_tc_or_a_and_a_a_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_OR_A_AND_A_A_LA);
+ op_tc_or_a_and_a_a_la(sc, arg);
+ return(sc->value);
+}
+
+static void op_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer fx_or1 = cdr(code), la_slot = let_slots(sc->curlet);
+ s7_pointer fx_or2 = cdr(fx_or1);
+ s7_pointer fx_and1 = cdadr(fx_or2);
+ s7_pointer fx_and2 = cdr(fx_and1);
+ s7_pointer fx_la = cdadr(fx_and2);
+ while (true)
+ {
+ s7_pointer p = fx_call(sc, fx_or1);
+ if (p != sc->F) {sc->value = p; return;}
+ p = fx_call(sc, fx_or2);
+ if (p != sc->F) {sc->value = p; return;}
+ if (fx_call(sc, fx_and1) == sc->F) {sc->value = sc->F; return;}
+ if (fx_call(sc, fx_and2) == sc->F) {sc->value = sc->F; return;}
+ slot_set_value(la_slot, fx_call(sc, fx_la));
+ }
+}
+
+static s7_pointer fx_tc_or_a_a_and_a_a_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_OR_A_A_AND_A_A_LA);
+ op_tc_or_a_a_and_a_a_la(sc, arg);
+ return(sc->value);
+}
+
+static void op_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet);
+ s7_pointer fx_or = cdadr(fx_and);
+ s7_pointer fx_la = cdadr(fx_or);
+ s7_pointer fx_laa = cdr(fx_la);
+ s7_pointer laa_slot = next_slot(la_slot);
+
+ if ((fx_proc(fx_and) == fx_not_is_null_u) && (fx_proc(fx_or) == fx_is_null_t) &&
+ (fx_proc(fx_la) == fx_cdr_t) && (fx_proc(fx_laa) == fx_cdr_u))
+ {
+ 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);
+ }}
+ while (true)
+ {
+ s7_pointer p;
+ if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;}
+ p = fx_call(sc, fx_or);
+ if (p != sc->F) {sc->value = p; return;}
+ sc->rec_p1 = fx_call(sc, fx_la);
+ slot_set_value(laa_slot, fx_call(sc, fx_laa));
+ slot_set_value(la_slot, sc->rec_p1);
+ }
+}
+
+static s7_pointer fx_tc_and_a_or_a_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_AND_A_OR_A_LAA);
+ op_tc_and_a_or_a_laa(sc, arg);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static void op_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet);
+ s7_pointer fx_and = cdadr(fx_or);
+ s7_pointer fx_la = cdadr(fx_and);
+ s7_pointer fx_laa = cdr(fx_la);
+ s7_pointer laa_slot = next_slot(la_slot);
+ while (true)
+ {
+ s7_pointer p = fx_call(sc, fx_or);
+ if (p != sc->F) {sc->value = p; return;}
+ if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;}
+ sc->rec_p1 = fx_call(sc, fx_la);
+ slot_set_value(laa_slot, fx_call(sc, fx_laa));
+ slot_set_value(la_slot, sc->rec_p1);
+ }
+}
+
+static s7_pointer fx_tc_or_a_and_a_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_OR_A_AND_A_LAA);
+ op_tc_or_a_and_a_laa(sc, arg);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static void op_tc_and_a_or_a_l3a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet);
+ s7_pointer fx_or = cdadr(fx_and);
+ s7_pointer fx_la = cdadr(fx_or);
+ s7_pointer fx_laa = cdr(fx_la);
+ s7_pointer fx_l3a = cdr(fx_laa);
+ s7_pointer laa_slot = next_slot(la_slot);
+ s7_pointer l3a_slot = next_slot(laa_slot);
+ while (true)
+ {
+ s7_pointer p;
+ if (fx_call(sc, fx_and) == sc->F) {sc->value = sc->F; return;}
+ p = fx_call(sc, fx_or);
+ if (p != sc->F) {sc->value = p; 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(laa_slot, sc->rec_p2);
+ slot_set_value(la_slot, sc->rec_p1);
+ }
+}
+
+static s7_pointer fx_tc_and_a_or_a_l3a(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_AND_A_OR_A_L3A);
+ op_tc_and_a_or_a_l3a(sc, arg);
+ sc->rec_p1 = sc->unused;
+ sc->rec_p2 = sc->unused;
+ return(sc->value);
+}
+
+static void op_tc_or_a_and_a_l3a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet);
+ s7_pointer fx_and = cdadr(fx_or);
+ s7_pointer fx_la = cdadr(fx_and);
+ s7_pointer fx_laa = cdr(fx_la);
+ s7_pointer fx_l3a = cdr(fx_laa);
+ s7_pointer laa_slot = next_slot(la_slot);
+ s7_pointer l3a_slot = next_slot(laa_slot);
+ while (true)
+ {
+ s7_pointer p = fx_call(sc, fx_or);
+ if (p != sc->F) {sc->value = p; return;}
+ if (fx_call(sc, fx_and) == 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(laa_slot, sc->rec_p2);
+ slot_set_value(la_slot, sc->rec_p1);
+ }
+}
+
+static s7_pointer fx_tc_or_a_and_a_l3a(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_OR_A_AND_A_L3A);
+ op_tc_or_a_and_a_l3a(sc, arg);
+ sc->rec_p1 = sc->unused;
+ sc->rec_p2 = sc->unused;
+ return(sc->value);
+}
+
+static void op_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet);
+ s7_pointer fx_and1 = opt3_pair(fx_or); /* (or_case) ? cdadr(fx_or) : cdaddr(fx_or); */
+ s7_pointer fx_and2 = cdr(fx_and1);
+ s7_pointer fx_la = cdadr(fx_and2);
+ s7_pointer fx_laa = cdr(fx_la);
+ s7_pointer laa_slot = next_slot(la_slot);
+ s7_pointer fx_l3a = cdr(fx_laa);
+ s7_pointer l3a_slot = next_slot(laa_slot);
+ if ((fx_proc(fx_and1) == fx_not_a) && (fx_proc(fx_and2) == fx_not_a))
+ {
+ 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);
+ }}
+ 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);
+ }
+}
+
+static s7_pointer fx_tc_or_a_and_a_a_l3a(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_OR_A_AND_A_A_L3A);
+ op_tc_or_a_and_a_a_l3a(sc, arg);
+ sc->rec_p1 = sc->unused;
+ sc->rec_p2 = sc->unused;
+ return(sc->value);
+}
+
+static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code, bool cond)
+{
+ s7_pointer la_slot = let_slots(sc->curlet);
+ s7_pointer if_test = (cond) ? cadr(code) : cdr(code);
+ s7_pointer if_true = (cond) ? opt1_pair(cdr(code)) : opt1_pair(if_test);
+ s7_pointer la = (cond) ? opt3_pair(cdr(code)) : opt3_pair(if_test);
+ if (is_t_integer(slot_value(la_slot)))
+ {
+ 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));
+ }}}
+ while (fx_call(sc, if_test) == sc->F) {slot_set_value(la_slot, fx_call(sc, la));}
+ return(op_tc_z(sc, if_true));
+}
+
+static s7_pointer fx_tc_if_a_z_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_IF_A_Z_LA);
+ op_tc_if_a_z_la(sc, arg, false);
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_cond_a_z_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_COND_A_Z_LA);
+ op_tc_if_a_z_la(sc, arg, true);
+ return(sc->value);
+}
+
+static bool op_tc_if_a_la_z(s7_scheme *sc, s7_pointer code, bool cond)
+{
+ s7_pointer la_slot = let_slots(sc->curlet);
+ s7_pointer if_test = (cond) ? cadr(code) : cdr(code);
+ s7_pointer if_false = (cond) ? opt1_pair(cdr(code)) : opt1_pair(if_test);
+ s7_pointer la = (cond) ? opt3_pair(cdr(code)) : opt3_pair(if_test);
+ if (is_t_integer(slot_value(la_slot)))
+ {
+ 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));
+ }}}
+ while (fx_call(sc, if_test) != sc->F) {slot_set_value(la_slot, fx_call(sc, la));}
+ return(op_tc_z(sc, if_false));
+}
+
+static s7_pointer fx_tc_if_a_la_z(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_IF_A_LA_Z);
+ op_tc_if_a_la_z(sc, arg, false);
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_cond_a_la_z(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_COND_A_LA_Z);
+ op_tc_if_a_la_z(sc, arg, true);
+ return(sc->value);
+}
+
+typedef enum {TC_IF, TC_COND, TC_AND} tc_choice_t;
+
+static bool op_tc_if_a_z_laa(s7_scheme *sc, s7_pointer code, bool z_first, tc_choice_t cond)
+{
+ s7_pointer if_test, if_z, la, laa, laa_slot, la_slot = let_slots(sc->curlet);
+ s7_function tf;
+ if (cond == TC_IF)
+ {
+ if_test = cdr(code);
+ if_z = opt1_pair(if_test); /* if_z = (z_first) ? cdr(if_test) : cddr(if_test) */
+ la = opt3_pair(if_test); /* la = (z_first) ? cdaddr(if_test) : cdadr(if_test) */
+ }
+ else
+ {
+ if_test = cadr(code);
+ if_z = opt1_pair(cdr(code)); /* if_z = (z_first) ? cdr(if_test) : cdr(caddr(code)) */
+ la = opt3_pair(cdr(code)); /* la = (z_first) ? cdr(cadaddr(code)) : cdadr(if_test) */
+ }
+ laa = cdr(la);
+ laa_slot = next_slot(la_slot);
+#if (!WITH_GMP)
+ if (!no_bool_opt(code))
+ {
+ 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));
+ }}}}
+ set_no_bool_opt(code);
+ }
+#endif
+ tf = fx_proc(if_test);
+ if_test = car(if_test);
+ 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);
+ }
+ 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);
+ }}
+ else
+ while (tf(sc, if_test) != sc->F)
+ {
+ sc->rec_p1 = fx_call(sc, la);
+ slot_set_value(laa_slot, fx_call(sc, laa));
+ slot_set_value(la_slot, sc->rec_p1);
+ }
+ return(op_tc_z(sc, if_z));
+}
+
+static s7_pointer fx_tc_if_a_z_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_IF_A_Z_LAA);
+ op_tc_if_a_z_laa(sc, arg, true, TC_IF);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_cond_a_z_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_COND_A_Z_LAA);
+ op_tc_if_a_z_laa(sc, arg, true, TC_COND);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_if_a_laa_z(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_IF_A_LAA_Z);
+ op_tc_if_a_z_laa(sc, arg, false, TC_IF);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_cond_a_laa_z(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_COND_A_LAA_Z);
+ op_tc_if_a_z_laa(sc, arg, false, TC_COND);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static void op_tc_when_la(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer if_test = cadr(code), body = cddr(code), la_call, la, la_slot = let_slots(sc->curlet);
+ s7_function tf = fx_proc(cdr(code));
+ /* for (la_call = body; is_pair(cdr(la_call)); la_call = cdr(la_call)); */
+ la_call = opt3_pair(code);
+ la = cdar(la_call);
+ while (tf(sc, if_test) != sc->F)
+ {
+ for (s7_pointer p = body; p != la_call; p = cdr(p)) fx_call(sc, p);
+ slot_set_value(la_slot, fx_call(sc, la));
+ }
+ sc->value = sc->unspecified;
+}
+
+static s7_pointer fx_tc_when_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_WHEN_LA);
+ op_tc_when_la(sc, arg);
+ return(sc->value);
+}
+
+static void op_tc_when_laa(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer if_test = cadr(code), body = cddr(code), la, laa, laa_slot, la_call, la_slot = let_slots(sc->curlet);
+ s7_function tf = fx_proc(cdr(code));
+ /* for (la_call = body; is_pair(cdr(la_call)); la_call = cdr(la_call)); */
+ la_call = opt3_pair(code);
+ la = cdar(la_call);
+ laa = cdr(la);
+ laa_slot = next_slot(la_slot);
+ while (tf(sc, if_test) != sc->F)
+ {
+ for (s7_pointer p = body; p != la_call; 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);
+ }
+ sc->rec_p1 = sc->unused;
+ sc->value = sc->unspecified;
+}
+
+static s7_pointer fx_tc_when_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_WHEN_LAA);
+ op_tc_when_laa(sc, arg);
+ return(sc->value);
+}
+
+static void op_tc_when_l3a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer if_test = cadr(code), body = cddr(code), la, laa, l3a, laa_slot, l3a_slot, la_call, la_slot = let_slots(sc->curlet);
+ s7_function tf = fx_proc(cdr(code));
+ /* for (la_call = body; is_pair(cdr(la_call)); la_call = cdr(la_call)); */
+ la_call = opt3_pair(code);
+ la = cdar(la_call);
+ laa = cdr(la);
+ l3a = cdr(laa);
+ laa_slot = next_slot(la_slot);
+ l3a_slot = next_slot(laa_slot);
+ while (tf(sc, if_test) != sc->F)
+ {
+ for (s7_pointer p = body; p != la_call; p = cdr(p)) fx_call(sc, p);
+ sc->rec_p1 = fx_call(sc, la);
+ sc->rec_p2 = fx_call(sc, laa);
+ slot_set_value(l3a_slot, fx_call(sc, l3a));
+ slot_set_value(laa_slot, sc->rec_p2);
+ slot_set_value(la_slot, sc->rec_p1);
+ }
+ sc->rec_p1 = sc->unused;
+ sc->value = sc->unspecified;
+}
+
+static s7_pointer fx_tc_when_l3a(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_WHEN_L3A);
+ op_tc_when_l3a(sc, arg);
+ return(sc->value);
+}
+
+static bool op_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer code, bool z_first)
+{
+ s7_pointer if_test = cdr(code), la_slot = let_slots(sc->curlet);
+ s7_pointer f_z = opt1_pair(if_test); /* if_z = (z_first) ? cdr(if_test) : cddr(if_test) */
+ s7_pointer la = opt3_pair(if_test); /* la = (z_first) ? cdaddr(if_test) : cdadr(if_test) */
+ s7_pointer laa = cdr(la);
+ s7_pointer l3a = cdr(laa);
+ s7_pointer laa_slot = next_slot(la_slot);
+ s7_pointer l3a_slot = next_slot(laa_slot);
+ s7_function tf = fx_proc(if_test);
+ if_test = car(if_test);
+ while ((tf(sc, if_test) == sc->F) == z_first)
+ {
+ sc->rec_p1 = fx_call(sc, la);
+ sc->rec_p2 = fx_call(sc, laa);
+ slot_set_value(l3a_slot, fx_call(sc, l3a));
+ slot_set_value(laa_slot, sc->rec_p2);
+ slot_set_value(la_slot, sc->rec_p1);
+ }
+ return(op_tc_z(sc, f_z));
+}
+
+static s7_pointer fx_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_IF_A_Z_L3A);
+ op_tc_if_a_z_l3a(sc, arg, true);
+ sc->rec_p1 = sc->unused;
+ sc->rec_p2 = sc->unused;
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_if_a_l3a_z(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_IF_A_L3A_Z);
+ op_tc_if_a_z_l3a(sc, arg, false);
+ sc->rec_p1 = sc->unused;
+ sc->rec_p2 = sc->unused;
+ return(sc->value);
+}
+
+static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code, bool z_first, tc_choice_t cond)
+{
+ s7_pointer if_test, if_true, if_false, f_test, f_z, la, endp, la_slot = let_slots(sc->curlet);
+ bool tc_and = (cond == TC_AND);
+ if (cond != TC_COND)
+ {
+ if_test = cdr(code);
+ if_true = (!tc_and) ? cdr(if_test) : sc->F;
+ if_false = (!tc_and) ? cadr(if_true) : cadr(if_test);
+ f_test = cdr(if_false);
+ f_z = (z_first) ? cdr(f_test) : cddr(f_test);
+ la = (z_first) ? cdaddr(f_test) : cdadr(f_test);
+ }
+ else
+ {
+ if_test = cadr(code); /* code: (cond (a1 z1) (a2 z2|la) (else la|z2)) */
+ if_true = cdr(if_test);
+ if_false = caddr(code); /* (a2 z2|la) */
+ f_test = if_false;
+ f_z = (z_first) ? cdr(f_test) : cdr(cadddr(code));
+ la = (z_first) ? cdadr(cadddr(code)) : cdadr(caddr(code));
+ }
+#if (!WITH_GMP)
+ if (is_t_integer(slot_value(la_slot)))
+ {
+ 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));
+ }}}}
+#endif
+ while (true)
+ {
+ if ((fx_call(sc, if_test) == sc->F) == tc_and) {if (tc_and) {sc->value = sc->F; return(true);} else {endp = if_true; break;}}
+ if ((fx_call(sc, f_test) == sc->F) != z_first) {endp = f_z; break;}
+ slot_set_value(la_slot, fx_call(sc, la));
+ }
+ return(op_tc_z(sc, endp));
+}
+
+static s7_pointer fx_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LA);
+ op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_IF);
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_if_a_z_if_a_la_z(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_IF_A_Z_IF_A_LA_Z);
+ op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_IF);
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_cond_a_z_a_z_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_COND_A_Z_A_Z_LA);
+ op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_COND);
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_cond_a_z_a_la_z(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_COND_A_Z_A_LA_Z);
+ op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_COND);
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_and_a_if_a_z_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_AND_A_IF_A_Z_LA);
+ op_tc_if_a_z_if_a_z_la(sc, arg, true, TC_AND);
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_and_a_if_a_la_z(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_AND_A_IF_A_LA_Z);
+ op_tc_if_a_z_if_a_z_la(sc, arg, false, TC_AND);
+ return(sc->value);
+}
+
+static bool op_tc_if_a_z_if_a_z_laa(s7_scheme *sc, bool cond, s7_pointer code)
+{
+ s7_pointer if_false, f_test, f_true, la, laa, laa_slot, endp, slot1, la_slot = let_slots(sc->curlet);
+ s7_pointer if_test = (cond) ? cadr(code) : cdr(code);
+ s7_pointer if_true = cdr(if_test);
+ if (!cond) if_false = cadr(if_true);
+ f_test = (cond) ? caddr(code) : cdr(if_false);
+ f_true = cdr(f_test);
+ la = (cond) ? opt3_pair(code) : cdadr(f_true); /* cdadr(cadddr(code)) */
+ laa = cdr(la);
+ laa_slot = next_slot(la_slot);
+ slot1 = (fx_proc(if_test) == fx_is_null_t) ? la_slot : ((fx_proc(if_test) == fx_is_null_u) ? laa_slot : NULL);
+ 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);
+ }}
+ 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);
+ }}
+ 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);
+ }
+ return(op_tc_z(sc, endp));
+}
+
+static s7_pointer fx_tc_if_a_z_if_a_z_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LAA);
+ op_tc_if_a_z_if_a_z_laa(sc, false, arg);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_cond_a_z_a_z_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_COND_A_Z_A_Z_LAA);
+ op_tc_if_a_z_if_a_z_laa(sc, true, arg);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static bool op_tc_if_a_z_if_a_laa_z(s7_scheme *sc, bool cond, s7_pointer code)
+{
+ s7_pointer if_false, f_test, f_true, f_false, la, laa, laa_slot, endp, la_slot = let_slots(sc->curlet);
+ s7_pointer if_test = (cond) ? cadr(code) : cdr(code);
+ s7_pointer if_true = cdr(if_test);
+ if (!cond) if_false = cadr(if_true);
+ f_test = (cond) ? caddr(code) : cdr(if_false);
+ f_true = cdr(f_test);
+ f_false = (cond) ? cdr(cadddr(code)) : cdr(f_true);
+ la = (cond) ? opt3_pair(code) : cdar(f_true); /* cdadr(caddr(code)) */
+ laa = cdr(la);
+ laa_slot = next_slot(la_slot);
+ while (true)
+ {
+ if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;}
+ if (fx_call(sc, f_test) == sc->F) {endp = f_false; break;}
+ 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));
+}
+
+static s7_pointer fx_tc_if_a_z_if_a_laa_z(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_IF_A_Z_IF_A_LAA_Z);
+ op_tc_if_a_z_if_a_laa_z(sc, false, arg);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_cond_a_z_a_laa_z(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_COND_A_Z_A_LAA_Z);
+ op_tc_if_a_z_if_a_laa_z(sc, true, arg);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static bool op_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer if_test = cdr(code);
+ s7_pointer endp, la_slot = let_slots(sc->curlet);
+ s7_pointer if_true = cdr(if_test);
+ s7_pointer if_false = cadr(if_true);
+ s7_pointer f_test = cdr(if_false);
+ s7_pointer f_true = cdr(f_test);
+ s7_pointer f_false = cdr(f_true);
+ s7_pointer la1 = cdar(f_true);
+ s7_pointer la2 = cdar(f_false);
+ s7_pointer laa1 = cdr(la1);
+ s7_pointer laa2 = cdr(la2);
+ s7_pointer laa_slot = next_slot(la_slot);
+ s7_pointer l3a1 = cdr(laa1);
+ s7_pointer l3a2 = cdr(laa2);
+ s7_pointer l3a_slot = next_slot(laa_slot);
+ while (true)
+ {
+ if (fx_call(sc, if_test) != sc->F) {endp = if_true; break;}
+ if (fx_call(sc, f_test) != sc->F)
+ {
+ sc->rec_p1 = fx_call(sc, la1);
+ sc->rec_p2 = fx_call(sc, laa1);
+ slot_set_value(l3a_slot, fx_call(sc, l3a1));
+ }
+ else
+ {
+ sc->rec_p1 = fx_call(sc, la2);
+ sc->rec_p2 = fx_call(sc, laa2);
+ slot_set_value(l3a_slot, fx_call(sc, l3a2));
+ }
+ slot_set_value(laa_slot, sc->rec_p2);
+ slot_set_value(la_slot, sc->rec_p1);
+ }
+ return(op_tc_z(sc, endp));
+}
+
+static s7_pointer fx_tc_if_a_z_if_a_l3a_l3a(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_IF_A_Z_IF_A_L3A_L3A);
+ op_tc_if_a_z_if_a_l3a_l3a(sc, arg);
+ sc->rec_p1 = sc->unused;
+ sc->rec_p2 = sc->unused;
+ return(sc->value);
+}
+
+static bool op_tc_let_if_a_z_la(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer body = caddr(code);
+ s7_pointer outer_let = sc->curlet;
+ s7_pointer la_slot = let_slots(outer_let);
+ s7_pointer if_test = cdr(body);
+ s7_pointer if_true = cddr(body);
+ s7_pointer if_false = cadddr(body);
+ s7_pointer la = cdr(if_false);
+ s7_pointer let_var = caadr(code);
+ s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var)));
+ s7_pointer let_slot = let_slots(inner_let);
+ set_curlet(sc, inner_let);
+ gc_protect_via_stack(sc, inner_let);
+ let_var = cdr(let_var);
+
+ while (fx_call(sc, if_test) == sc->F)
+ {
+ slot_set_value(la_slot, fx_call(sc, la));
+ set_curlet(sc, outer_let);
+ slot_set_value(let_slot, fx_call(sc, let_var));
+ set_curlet(sc, inner_let);
+ }
+ unstack_gc_protect(sc);
+ if (!op_tc_z(sc, if_true))
+ return(false);
+ free_cell(sc, let_slots(inner_let));
+ free_cell(sc, inner_let);
+ return(true);
+}
+
+static s7_pointer fx_tc_let_if_a_z_la(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_LET_IF_A_Z_LA);
+ op_tc_let_if_a_z_la(sc, arg);
+ return(sc->value);
+}
+
+static bool op_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer body = caddr(code);
+ s7_pointer outer_let = sc->curlet;
+ s7_pointer la_slot = let_slots(outer_let);
+ s7_pointer laa_slot = next_slot(la_slot);
+ s7_pointer if_test = cdr(body);
+ s7_pointer if_true = cddr(body);
+ s7_pointer if_false = cadddr(body);
+ s7_pointer la = cdr(if_false);
+ s7_pointer laa = cddr(if_false);
+ s7_pointer let_var = caadr(code);
+ s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var)));
+ s7_pointer let_slot = let_slots(inner_let);
+ set_curlet(sc, inner_let);
+ gc_protect_via_stack(sc, inner_let);
+ let_var = cdr(let_var);
+#if (!WITH_GMP)
+ if (!no_bool_opt(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);
+ }}}}}
+ set_no_bool_opt(code);
+ }
+#endif
+ while (fx_call(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);
+ set_curlet(sc, outer_let);
+ slot_set_value(let_slot, fx_call(sc, let_var));
+ set_curlet(sc, inner_let);
+ }
+ unstack_gc_protect(sc);
+ if (!op_tc_z(sc, if_true))
+ return(false);
+ free_cell(sc, let_slots(inner_let));
+ free_cell(sc, inner_let);
+ return(true);
+}
+
+static s7_pointer fx_tc_let_if_a_z_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_LET_IF_A_Z_LAA);
+ op_tc_let_if_a_z_laa(sc, arg);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static void op_tc_let_when_laa(s7_scheme *sc, bool when, s7_pointer code)
+{
+ s7_pointer p, body = caddr(code), la, laa, let_var = caadr(code), outer_let = sc->curlet;
+ s7_pointer if_test = cdr(body);
+ s7_pointer if_true = cddr(body);
+ s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var)));
+ s7_pointer let_slot = let_slots(inner_let);
+ set_curlet(sc, inner_let);
+ gc_protect_via_stack(sc, inner_let);
+ let_var = cdr(let_var);
+
+ for (p = if_true; is_pair(cdr(p)); p = cdr(p));
+ la = cdar(p);
+ laa = cddar(p);
+ if ((car(la) == slot_symbol(let_slots(outer_let))) &&
+ (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);
+ }}
+ 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);
+ }}
+ 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);
+ }}
+ unstack_gc_protect(sc);
+ free_cell(sc, let_slots(inner_let));
+ free_cell(sc, inner_let);
+ sc->value = sc->unspecified;
+}
+
+static s7_pointer fx_tc_let_when_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_LET_WHEN_LAA);
+ op_tc_let_when_laa(sc, true, arg);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static s7_pointer fx_tc_let_unless_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_LET_WHEN_LAA);
+ op_tc_let_when_laa(sc, false, arg);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+static bool op_tc_if_a_z_let_if_a_z_laa(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer if1_test = cdr(code), endp, outer_let = sc->curlet, slot, var, la_slot = let_slots(sc->curlet);
+ s7_pointer if1_true = cdr(if1_test); /* cddr(code) */
+ s7_pointer let_expr = cadr(if1_true); /* cadddr(code) */
+ s7_pointer let_vars = cadr(let_expr);
+ s7_pointer if2 = caddr(let_expr);
+ s7_pointer if2_test = cdr(if2);
+ s7_pointer if2_true = cdr(if2_test); /* cddr(if2) */
+ s7_pointer la = cdadr(if2_true); /* cdr(cadddr(if2)) */
+ s7_pointer laa = cdr(la);
+ s7_pointer laa_slot = next_slot(la_slot);
+ s7_pointer inner_let = inline_make_let(sc, sc->curlet);
+
+ gc_protect_via_stack(sc, inner_let);
+ slot = make_slot(sc, caar(let_vars), sc->F);
+ slot_set_next(slot, slot_end);
+ let_set_slots(inner_let, slot);
+ symbol_set_local_slot_unincremented(caar(let_vars), let_id(inner_let), slot);
+ for (var = cdr(let_vars); is_pair(var); var = cdr(var))
+ slot = inline_add_slot_at_end(sc, let_id(inner_let), slot, caar(var), sc->F);
+
+ while (true)
+ {
+ if (fx_call(sc, if1_test) != sc->F) {endp = if1_true; break;}
+ slot = let_slots(inner_let);
+ 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)));
+
+ if (fx_call(sc, if2_test) != sc->F) {endp = if2_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);
+ set_curlet(sc, outer_let);
+ }
+ sc->rec_p1 = sc->unused;
+ unstack_gc_protect(sc);
+ if (!op_tc_z(sc, endp)) /* might refer to inner_let slots */
+ return(false);
+ free_cell(sc, let_slots(inner_let)); /* true = has_fx, so we should be done with the let */
+ free_cell(sc, inner_let);
+ return(true);
+}
+
+static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code)
+{
+ bool read_case;
+ s7_pointer result;
+ s7_pointer outer_let = sc->curlet;
+ s7_pointer slots = let_slots(outer_let);
+ s7_pointer cond_body = cdaddr(code); /* code here == body in check_tc */
+ s7_pointer let_var = caadr(code);
+ s7_function letf = fx_proc(cdr(let_var));
+ s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var)));
+ s7_pointer let_slot = let_slots(inner_let);
+ set_curlet(sc, inner_let);
+ gc_protect_via_stack(sc, inner_let);
+ let_var = cadr(let_var);
+ if ((letf == fx_c_s_direct) &&
+ (symbol_id(cadr(let_var)) != let_id(outer_let))) /* i.e. not an argument to the recursive function, and not set! (safe closure body) */
+ {
+ letf = (s7_p_p_t)opt2_direct(cdr(let_var));
+ let_var = lookup(sc, cadr(let_var));
+ }
+ /* in the named let no-var case slots may contain the let name (it's the funclet) */
+
+ 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;
+ }}
+ 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;
+ }
+
+ 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;
+ }
+ let_clear_has_pending_value(sc, outer_let);
+
+ TC_LET_COND_DONE:
+ unstack_gc_protect(sc);
+ if (has_fx(result))
+ {
+ sc->value = fx_call(sc, result);
+ free_cell(sc, let_slots(inner_let));
+ free_cell(sc, inner_let);
+ return(true);
+ }
+ sc->code = car(result);
+ return(false);
+}
+
+static s7_pointer fx_tc_let_cond(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_LET_COND);
+ op_tc_let_cond(sc, arg);
+ return(sc->value);
+}
+
+static bool op_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer c1 = cadr(code), c2 = caddr(code), la_slot = let_slots(sc->curlet);
+ s7_pointer la1 = cdadr(c2);
+ s7_pointer laa1 = cddadr(c2);
+ s7_pointer c3 = opt3_pair(code); /* cadr(cadddr(code)) = cadr(else_clause) */
+ s7_pointer la2 = cdr(c3);
+ s7_pointer laa2 = cddr(c3);
+ s7_pointer laa_slot = next_slot(la_slot);
+ while (true)
+ {
+ 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));
+ }
+ else
+ {
+ 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));
+}
+
+static s7_pointer fx_tc_cond_a_z_a_laa_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_TC_COND_A_Z_A_LAA_LAA);
+ op_tc_cond_a_z_a_laa_laa(sc, arg);
+ sc->rec_p1 = sc->unused;
+ return(sc->value);
+}
+
+
+#define RECUR_INITIAL_STACK_SIZE 1024
+
+static void recur_resize(s7_scheme *sc)
+{
+ s7_pointer stack = sc->rec_stack;
+ block_t *ob, *nb;
+ vector_length(stack) = sc->rec_len * 2;
+ ob = vector_block(stack);
+ nb = reallocate(sc, ob, vector_length(stack) * sizeof(s7_pointer));
+ block_info(nb) = NULL;
+ vector_block(stack) = nb;
+ vector_elements(stack) = (s7_pointer *)block_data(nb); /* GC looks only at elements within sc->rec_loc */
+ sc->rec_len = vector_length(stack);
+ sc->rec_els = vector_elements(stack);
+}
+
+static inline void recur_push(s7_scheme *sc, s7_pointer value)
+{
+ if (sc->rec_loc == sc->rec_len)
+ recur_resize(sc);
+ sc->rec_els[sc->rec_loc] = value;
+ sc->rec_loc++;
+}
+
+static inline void recur_push_unchecked(s7_scheme *sc, s7_pointer value) {sc->rec_els[sc->rec_loc++] = value;}
+static s7_pointer recur_pop(s7_scheme *sc) {return(sc->rec_els[--sc->rec_loc]);}
+static s7_pointer recur_ref(s7_scheme *sc, s7_int loc) {return(sc->rec_els[sc->rec_loc - loc]);}
+
+static s7_pointer recur_pop2(s7_scheme *sc)
+{
+ sc->rec_loc -= 2;
+ return(sc->rec_els[sc->rec_loc + 1]);
+}
+
+static s7_pointer recur_swap(s7_scheme *sc, s7_pointer value)
+{
+ s7_pointer res = sc->rec_els[sc->rec_loc - 1];
+ sc->rec_els[sc->rec_loc - 1] = value;
+ return(res);
+}
+
+static s7_pointer recur_make_stack(s7_scheme *sc)
+{
+ if (!sc->rec_stack)
+ {
+ sc->rec_stack = make_simple_vector(sc, RECUR_INITIAL_STACK_SIZE);
+ sc->rec_els = vector_elements(sc->rec_stack);
+ sc->rec_len = RECUR_INITIAL_STACK_SIZE;
+ }
+ sc->rec_loc = 0;
+ return(sc->rec_stack);
+}
+
+static void rec_set_test(s7_scheme *sc, s7_pointer p)
+{
+ sc->rec_testp = p;
+ sc->rec_testf = fx_proc(sc->rec_testp);
+ sc->rec_testp = car(sc->rec_testp);
+}
+
+static void rec_set_res(s7_scheme *sc, s7_pointer p)
+{
+ sc->rec_resp = p;
+ sc->rec_resf = fx_proc(sc->rec_resp);
+ sc->rec_resp = car(sc->rec_resp);
+}
+
+static void rec_set_f1(s7_scheme *sc, s7_pointer p)
+{
+ sc->rec_f1p = p;
+ sc->rec_f1f = fx_proc(sc->rec_f1p);
+ sc->rec_f1p = car(sc->rec_f1p);
+}
+
+static void rec_set_f2(s7_scheme *sc, s7_pointer p)
+{
+ sc->rec_f2p = p;
+ sc->rec_f2f = fx_proc(sc->rec_f2p);
+ sc->rec_f2p = car(sc->rec_f2p);
+}
+
+static void rec_set_f3(s7_scheme *sc, s7_pointer p)
+{
+ sc->rec_f3p = p;
+ sc->rec_f3f = fx_proc(sc->rec_f3p);
+ sc->rec_f3p = car(sc->rec_f3p);
+}
+
+static void rec_set_f4(s7_scheme *sc, s7_pointer p)
+{
+ sc->rec_f4p = p;
+ sc->rec_f4f = fx_proc(sc->rec_f4p);
+ sc->rec_f4p = car(sc->rec_f4p);
+}
+
+static void rec_set_f5(s7_scheme *sc, s7_pointer p)
+{
+ sc->rec_f5p = p;
+ sc->rec_f5f = fx_proc(sc->rec_f5p);
+ sc->rec_f5p = car(sc->rec_f5p);
+}
+
+static void rec_set_f6(s7_scheme *sc, s7_pointer p)
+{
+ sc->rec_f6p = p;
+ sc->rec_f6f = fx_proc(sc->rec_f6p);
+ sc->rec_f6p = car(sc->rec_f6p);
+}
+
+/* -------- if_a_a_opa_laq and if_a_opa_laq_a -------- */
+typedef enum {OPT_PTR, OPT_INT, OPT_DBL, OPT_INT_0} opt_pid_t;
+
+static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op, s7_pointer code)
+{
+ s7_pointer caller = opt3_pair(code); /* false_p in check_recur */
+#if (!WITH_GMP)
+ s7_pointer c_op = car(caller);
+ 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_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);
+ }}}}}}}
+#endif
+ rec_set_test(sc, cdr(code));
+ rec_set_res(sc, (a_op) ? cddr(code) : cdddr(code));
+ rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller));
+ rec_set_f2(sc, cdr(opt3_pair(caller)));
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_fn = fn_proc(caller);
+ return(OPT_PTR);
+}
+
+static s7_int oprec_i_if_a_a_opa_laq(s7_scheme *sc)
+{
+ s7_int i1;
+ if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fi(sc->rec_result_o));
+ i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o);
+ set_integer(sc->rec_val1, sc->rec_a2_o->v[0].fi(sc->rec_a2_o));
+ return(sc->rec_i_ii_f(i1, oprec_i_if_a_a_opa_laq(sc)));
+}
+
+static s7_int oprec_i_if_a_opa_laq_a(s7_scheme *sc)
+{
+ s7_int i1;
+ if (!sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fi(sc->rec_result_o));
+ i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o);
+ set_integer(sc->rec_val1, sc->rec_a2_o->v[0].fi(sc->rec_a2_o));
+ return(sc->rec_i_ii_f(i1, oprec_i_if_a_opa_laq_a(sc)));
+}
+
+static s7_pointer oprec_if_a_a_opa_laq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
+
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
+ set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp));
+ else
+ {
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
+ set_car(sc->t2_2, oprec_if_a_a_opa_laq(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));
+}
+
+static s7_pointer oprec_if_a_a_opla_aq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
+ set_car(sc->t2_1, oprec_if_a_a_opla_aq(sc));
+ set_car(sc->t2_2, recur_pop(sc));
+ return(sc->rec_fn(sc, sc->t2_1));
+}
+
+static s7_pointer oprec_if_a_opa_laq_a(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
+
+ if (sc->rec_testf(sc, sc->rec_testp) == sc->F)
+ set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp));
+ else
+ {
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
+ set_car(sc->t2_2, oprec_if_a_opa_laq_a(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));
+}
+
+static s7_pointer oprec_if_a_opla_aq_a(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
+ set_car(sc->t2_1, oprec_if_a_opla_aq_a(sc));
+ set_car(sc->t2_2, recur_pop(sc));
+ return(sc->rec_fn(sc, sc->t2_1));
+}
+
+static void wrap_recur_if_a_a_opa_laq(s7_scheme *sc, bool a_op, bool la_op)
+{
+ opt_pid_t choice = opinit_if_a_a_opa_laq(sc, a_op, la_op, sc->code);
+ tick_tc(sc, sc->cur_op);
+ if (choice == OPT_INT)
+ sc->value = make_integer(sc, (a_op) ? oprec_i_if_a_a_opa_laq(sc) : oprec_i_if_a_opa_laq_a(sc));
+ else
+ {
+ 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);
+ else sc->value = (la_op) ? oprec_if_a_opa_laq_a(sc) : oprec_if_a_opla_aq_a(sc);
+ sc->rec_loc = 0;
+ }
+}
+
+static s7_pointer fx_recur_if_a_a_opa_laq(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_RECUR_IF_A_A_opA_LAq);
+ if (opinit_if_a_a_opa_laq(sc, true, true, arg) == OPT_INT)
+ sc->value = make_integer(sc, oprec_i_if_a_a_opa_laq(sc));
+ else
+ {
+ sc->rec_stack = recur_make_stack(sc);
+ sc->value = oprec_if_a_a_opa_laq(sc);
+ sc->rec_loc = 0;
+ }
+ return(sc->value);
+}
+
+static s7_pointer fx_recur_if_a_opa_laq_a(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_RECUR_IF_A_opA_LAq_A);
+ if (opinit_if_a_a_opa_laq(sc, false, true, arg) == OPT_INT)
+ sc->value = make_integer(sc, oprec_i_if_a_opa_laq_a(sc));
+ else
+ {
+ sc->rec_stack = recur_make_stack(sc);
+ sc->value = oprec_if_a_opa_laq_a(sc);
+ sc->rec_loc = 0;
+ }
+ return(sc->value);
+}
+
+/* -------- cond_a_a_opa_laq -------- */
+static void opinit_cond_a_a_opa_laq(s7_scheme *sc)
+{
+ s7_pointer caller = opt3_pair(sc->code);
+ rec_set_test(sc, cadr(sc->code));
+ rec_set_res(sc, cdadr(sc->code));
+ rec_set_f1(sc, cdr(caller));
+ rec_set_f2(sc, cdr(opt3_pair(caller)));
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_fn = fn_proc(caller);
+}
+
+static s7_pointer op_recur_cond_a_a_opa_laq(s7_scheme *sc)
+{
+ opinit_cond_a_a_opa_laq(sc);
+ return(oprec_if_a_a_opa_laq(sc));
+}
+
+/* -------- if_a_a_opa_laaq and if_a_opa_laaq_a and cond_a_a_opa_laaq -------- */
+typedef enum {IF1A_LA2, IF2A_LA2, COND2A_LA2} laaq_t;
+
+static void opinit_if_a_a_opa_laaq(s7_scheme *sc, laaq_t a_op)
+{
+ s7_pointer caller = opt3_pair(sc->code);
+ rec_set_test(sc, (a_op == COND2A_LA2) ? cadr(sc->code) : cdr(sc->code));
+ rec_set_res(sc, (a_op == IF2A_LA2) ? cddr(sc->code) : ((a_op == IF1A_LA2) ? cdddr(sc->code) : cdadr(sc->code)));
+ rec_set_f1(sc, cdr(caller));
+ rec_set_f2(sc, cdr(opt3_pair(caller)));
+ rec_set_f3(sc, cddr(opt3_pair(caller)));
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_slot2 = next_slot(sc->rec_slot1);
+ sc->rec_fn = fn_proc(caller);
+}
+
+static s7_pointer oprec_if_a_a_opa_laaq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
+ slot_set_value(sc->rec_slot2, sc->rec_f3f(sc, sc->rec_f3p));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
+ set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp));
+ else
+ {
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ 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_if_a_a_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));
+}
+
+static s7_pointer oprec_if_a_opa_laaq_a(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
+ 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_if_a_opa_laaq_a(sc));
+ set_car(sc->t2_1, recur_pop(sc));
+ return(sc->rec_fn(sc, sc->t2_1));
+}
+
+static s7_pointer op_recur_if_a_a_opa_laaq(s7_scheme *sc)
+{
+ opinit_if_a_a_opa_laaq(sc, IF2A_LA2);
+ return(oprec_if_a_a_opa_laaq(sc));
+}
+
+static s7_pointer op_recur_if_a_opa_laaq_a(s7_scheme *sc)
+{
+ opinit_if_a_a_opa_laaq(sc, IF1A_LA2);
+ return(oprec_if_a_opa_laaq_a(sc));
+}
+
+static s7_pointer op_recur_cond_a_a_opa_laaq(s7_scheme *sc)
+{
+ opinit_if_a_a_opa_laaq(sc, COND2A_LA2);
+ return(oprec_if_a_a_opa_laaq(sc));
+}
+
+
+/* -------- if_a_a_opa_l3aq -------- */
+static void opinit_if_a_a_opa_l3aq(s7_scheme *sc)
+{
+ s7_pointer caller = opt3_pair(sc->code), l3a = cdr(opt3_pair(caller));
+ rec_set_test(sc, cdr(sc->code));
+ rec_set_res(sc, cddr(sc->code));
+ rec_set_f1(sc, cdr(caller));
+ rec_set_f2(sc, l3a);
+ rec_set_f3(sc, cdr(l3a));
+ rec_set_f4(sc, cddr(l3a));
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_slot2 = next_slot(sc->rec_slot1);
+ sc->rec_slot3 = next_slot(sc->rec_slot2);
+ sc->rec_fn = fn_proc(caller);
+}
+
+static s7_pointer oprec_if_a_a_opa_l3aq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
+ recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
+ slot_set_value(sc->rec_slot3, sc->rec_f4f(sc, sc->rec_f4p));
+ slot_set_value(sc->rec_slot2, recur_pop(sc));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
+ set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp));
+ else
+ {
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
+ recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
+ slot_set_value(sc->rec_slot3, sc->rec_f4f(sc, sc->rec_f4p));
+ slot_set_value(sc->rec_slot2, recur_pop(sc));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ set_car(sc->t2_2, oprec_if_a_a_opa_l3aq(sc));
+ set_car(sc->t2_1, recur_pop(sc));
+ 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));
+}
+
+static s7_pointer op_recur_if_a_a_opa_l3aq(s7_scheme *sc)
+{
+ opinit_if_a_a_opa_l3aq(sc);
+ return(oprec_if_a_a_opa_l3aq(sc));
+}
+
+/* -------- if_a_a_opla_laq and if_a_opla_laq_a -------- */
+static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, bool a_op)
+{
+ s7_pointer caller = opt3_pair(sc->code);
+#if (!WITH_GMP)
+ s7_pointer c_op = car(caller);
+ 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_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);
+ }}}}}}}}
+#endif
+ rec_set_test(sc, cdr(sc->code));
+ rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code));
+ rec_set_f1(sc, cdadr(caller));
+ rec_set_f2(sc, cdr(opt3_pair(caller)));
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_fn = fn_proc(caller);
+ return(OPT_PTR);
+}
+
+static s7_int oprec_i_if_a_a_opla_laq(s7_scheme *sc)
+{
+ s7_int i1, i2;
+ if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) /* if_(A) */
+ return(sc->rec_result_o->v[0].fi(sc->rec_result_o)); /* if_a_(A) */
+ i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o); /* save a1 */
+ set_integer(sc->rec_val1, sc->rec_a2_o->v[0].fi(sc->rec_a2_o));/* slot1 = a2 */
+ i2 = oprec_i_if_a_a_opla_laq(sc); /* save la2 */
+ set_integer(sc->rec_val1, i1); /* slot1 = a1 */
+ return(sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq(sc), i2)); /* call op(la1, la2) */
+}
+
+static s7_int oprec_i_if_a_a_opla_laq_0(s7_scheme *sc)
+{
+ s7_int i1, i2;
+ if (sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o));
+ i1 = sc->rec_fi2(sc->rec_a1_o);
+ set_integer(sc->rec_val1, sc->rec_fi3(sc->rec_a2_o));
+ if (sc->rec_fb1(sc->rec_test_o))
+ i2 = sc->rec_fi1(sc->rec_result_o);
+ else
+ {
+ s7_int i3;
+ i2 = sc->rec_fi2(sc->rec_a1_o);
+ set_integer(sc->rec_val1, sc->rec_fi3(sc->rec_a2_o));
+ i3 = oprec_i_if_a_a_opla_laq_0(sc);
+ set_integer(sc->rec_val1, i2);
+ i2 = sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i3);
+ }
+ set_integer(sc->rec_val1, i1);
+ return(sc->rec_i_ii_f(oprec_i_if_a_a_opla_laq_0(sc), i2));
+}
+
+static s7_double oprec_d_if_a_a_opla_laq(s7_scheme *sc)
+{
+ s7_double x1, x2;
+ if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fd(sc->rec_result_o));
+ x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o);
+ set_real(sc->rec_val1, sc->rec_a2_o->v[0].fd(sc->rec_a2_o));
+ if (sc->rec_test_o->v[0].fb(sc->rec_test_o))
+ x2 = sc->rec_result_o->v[0].fd(sc->rec_result_o);
+ else
+ {
+ s7_double x3;
+ x2 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o);
+ set_real(sc->rec_val1, sc->rec_a2_o->v[0].fd(sc->rec_a2_o));
+ x3 = oprec_d_if_a_a_opla_laq(sc);
+ set_real(sc->rec_val1, x2);
+ x2 = sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x3);
+ }
+ set_real(sc->rec_val1, x1);
+ return(sc->rec_d_dd_f(oprec_d_if_a_a_opla_laq(sc), x2));
+}
+
+static s7_pointer oprec_if_a_a_opla_laq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
+ slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_a_opla_laq(sc)));
+ set_car(sc->t2_1, oprec_if_a_a_opla_laq(sc));
+ set_car(sc->t2_2, recur_pop(sc));
+ return(sc->rec_fn(sc, sc->t2_1));
+}
+
+static s7_int oprec_i_if_a_opla_laq_a(s7_scheme *sc)
+{
+ s7_int i1, i2;
+ if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) return(sc->rec_result_o->v[0].fi(sc->rec_result_o));
+ i1 = sc->rec_a1_o->v[0].fi(sc->rec_a1_o);
+ set_integer(sc->rec_val1, sc->rec_a2_o->v[0].fi(sc->rec_a2_o));
+ i2 = oprec_i_if_a_opla_laq_a(sc);
+ set_integer(sc->rec_val1, i1);
+ return(sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a(sc), i2));
+}
+
+static s7_int oprec_i_if_a_opla_laq_a_0(s7_scheme *sc)
+{
+ s7_int i1, i2;
+ if (!sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o));
+ i1 = sc->rec_fi2(sc->rec_a1_o);
+ set_integer(sc->rec_val1, sc->rec_fi3(sc->rec_a2_o));
+ if (!sc->rec_fb1(sc->rec_test_o))
+ i2 = sc->rec_fi1(sc->rec_result_o);
+ else
+ {
+ s7_int i3;
+ i2 = sc->rec_fi2(sc->rec_a1_o);
+ set_integer(sc->rec_val1, sc->rec_fi3(sc->rec_a2_o));
+ i3 = oprec_i_if_a_opla_laq_a_0(sc);
+ set_integer(sc->rec_val1, i2);
+ i2 = sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i3);
+ }
+ set_integer(sc->rec_val1, i1);
+ return(sc->rec_i_ii_f(oprec_i_if_a_opla_laq_a_0(sc), i2));
+}
+
+static s7_double oprec_d_if_a_opla_laq_a(s7_scheme *sc)
+{
+ s7_double x1, x2;
+ if (!(sc->rec_test_o->v[0].fb(sc->rec_test_o))) return(sc->rec_result_o->v[0].fd(sc->rec_result_o));
+ x1 = sc->rec_a1_o->v[0].fd(sc->rec_a1_o);
+ set_real(sc->rec_val1, sc->rec_a2_o->v[0].fd(sc->rec_a2_o));
+ x2 = oprec_d_if_a_opla_laq_a(sc);
+ set_real(sc->rec_val1, x1);
+ return(sc->rec_d_dd_f(oprec_d_if_a_opla_laq_a(sc), x2));
+}
+
+static s7_pointer oprec_if_a_opla_laq_a(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ slot_set_value(sc->rec_slot1, sc->rec_f2f(sc, sc->rec_f2p));
+ slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_opla_laq_a(sc)));
+ set_car(sc->t2_1, oprec_if_a_opla_laq_a(sc));
+ set_car(sc->t2_2, recur_pop(sc));
+ return(sc->rec_fn(sc, sc->t2_1));
+}
+
+static void wrap_recur_if_a_a_opla_laq(s7_scheme *sc, bool a_op)
+{
+ opt_pid_t choice = opinit_if_a_a_opla_laq(sc, a_op);
+ tick_tc(sc, sc->cur_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));
+ 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;
+ }
+ else sc->value = make_real(sc, (a_op) ? oprec_d_if_a_a_opla_laq(sc) : oprec_d_if_a_opla_laq_a(sc));
+}
+
+
+/* -------- if_a_a_opa_la_laq and if_a_opa_la_laq_a -------- */
+static void opinit_if_a_a_opa_la_laq(s7_scheme *sc, bool a_op)
+{
+ s7_pointer caller = opt3_pair(sc->code);
+ rec_set_test(sc, cdr(sc->code));
+ rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code));
+ rec_set_f1(sc, cdr(caller));
+ rec_set_f2(sc, cdaddr(caller));
+ rec_set_f3(sc, cdr(opt3_pair(caller)));
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_fn = fn_proc(caller);
+}
+
+static s7_pointer oprec_if_a_a_opa_la_laq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
+ slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p));
+ slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_a_opa_la_laq(sc)));
+ set_car(sc->t3_2, oprec_if_a_a_opa_la_laq(sc));
+ set_car(sc->t3_3, recur_pop(sc));
+ set_car(sc->t3_1, recur_pop(sc));
+ return(sc->rec_fn(sc, sc->t3_1));
+}
+
+static s7_pointer oprec_if_a_opa_la_laq_a(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
+ slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p));
+ slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_opa_la_laq_a(sc)));
+ set_car(sc->t3_2, oprec_if_a_opa_la_laq_a(sc));
+ set_car(sc->t3_3, recur_pop(sc));
+ set_car(sc->t3_1, recur_pop(sc));
+ return(sc->rec_fn(sc, sc->t3_1));
+}
+
+static s7_pointer op_recur_if_a_a_opa_la_laq(s7_scheme *sc)
+{
+ opinit_if_a_a_opa_la_laq(sc, true);
+ return(oprec_if_a_a_opa_la_laq(sc));
+}
+
+static s7_pointer op_recur_if_a_opa_la_laq_a(s7_scheme *sc)
+{
+ opinit_if_a_a_opa_la_laq(sc, false);
+ return(oprec_if_a_opa_la_laq_a(sc));
+}
+
+/* -------- if_a_a_opla_la_laq -------- */
+static void opinit_if_a_a_opla_la_laq(s7_scheme *sc, bool a_op)
+{
+ s7_pointer caller = opt3_pair(sc->code);
+ rec_set_test(sc, cdr(sc->code));
+ rec_set_res(sc, (a_op) ? cddr(sc->code) : cdddr(sc->code));
+ rec_set_f1(sc, cdadr(caller));
+ rec_set_f2(sc, cdaddr(caller));
+ rec_set_f3(sc, cdr(opt3_pair(caller)));
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_fn = fn_proc(caller);
+}
+
+static s7_pointer oprec_if_a_a_opla_la_laq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
+ slot_set_value(sc->rec_slot1, sc->rec_f3f(sc, sc->rec_f3p));
+ slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_if_a_a_opla_la_laq(sc)));
+ recur_push(sc, oprec_if_a_a_opla_la_laq(sc));
+ slot_set_value(sc->rec_slot1, recur_ref(sc, 3));
+ set_car(sc->t3_1, oprec_if_a_a_opla_la_laq(sc));
+ set_car(sc->t3_2, recur_pop(sc));
+ set_car(sc->t3_3, recur_pop2(sc));
+ return(sc->rec_fn(sc, sc->t3_1));
+}
+
+static s7_pointer op_recur_if_a_a_opla_la_laq(s7_scheme *sc)
+{
+ opinit_if_a_a_opla_la_laq(sc, true);
+ return(oprec_if_a_a_opla_la_laq(sc));
+}
+
+/* -------- if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc) --------
+ * esteemed reader, please ignore this nonsense!
+ * The opt_info version was not a lot faster -- ~/old/tak-st.c: say 10% faster. The current fx-based
+ * version has immediate lookups, and since the data is (ahem) simple, the GC is not a factor.
+ * The opt version has its own overheads, and has to do the same amount of stack manipulations.
+ */
+static s7_pointer rec_x(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot1));}
+static s7_pointer rec_y(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot2));}
+static s7_pointer rec_z(s7_scheme *sc, s7_pointer code) {return(slot_value(sc->rec_slot3));}
+static s7_pointer rec_sub_z1(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer x = slot_value(sc->rec_slot3);
+ return((is_t_integer(x)) ? make_integer(sc, integer(x) - 1) : minus_c1(sc, x));
+}
+
+static void opinit_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc)
+{
+ s7_pointer caller = opt3_pair(sc->code);
+ s7_pointer la1 = cadr(caller);
+ s7_pointer la2 = caddr(caller);
+ s7_pointer la3 = opt3_pair(caller);
+ rec_set_test(sc, cdr(sc->code));
+ rec_set_res(sc, cddr(sc->code));
+ rec_set_f1(sc, cdr(la1));
+ rec_set_f2(sc, cddr(la1));
+ if (sc->rec_f2f == fx_u) sc->rec_f2f = rec_y;
+ rec_set_f3(sc, cdddr(la1));
+ rec_set_f4(sc, cdr(la2));
+ rec_set_f5(sc, cddr(la2));
+ rec_set_f6(sc, cdddr(la2));
+ if (sc->rec_f6f == fx_t) sc->rec_f6f = rec_x;
+
+ sc->rec_f7p = cdr(la3);
+ sc->rec_f7f = fx_proc(sc->rec_f7p);
+ sc->rec_f7p = car(sc->rec_f7p);
+
+ sc->rec_f8p = cddr(la3);
+ sc->rec_f8f = fx_proc(sc->rec_f8p);
+ if (sc->rec_f8f == fx_t) sc->rec_f8f = rec_x;
+ sc->rec_f8p = car(sc->rec_f8p);
+
+ sc->rec_f9p = cdddr(la3);
+ sc->rec_f9f = fx_proc(sc->rec_f9p);
+ if (sc->rec_f9f == fx_u) sc->rec_f9f = rec_y;
+ sc->rec_f9p = car(sc->rec_f9p);
+
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_slot2 = next_slot(sc->rec_slot1);
+ sc->rec_slot3 = next_slot(sc->rec_slot2);
+ if (cadddr(la1) == slot_symbol(sc->rec_slot3)) sc->rec_f3f = rec_z;
+ if (caddr(la2) == slot_symbol(sc->rec_slot3)) sc->rec_f5f = rec_z;
+ if ((sc->rec_f7f == fx_subtract_s1) && (cadadr(la3) == slot_symbol(sc->rec_slot3))) sc->rec_f7f = rec_sub_z1;
+}
+
+static s7_pointer oprec_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ recur_push(sc, sc->rec_f2f(sc, sc->rec_f2p));
+ recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
+ recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p));
+ recur_push(sc, sc->rec_f5f(sc, sc->rec_f5p));
+ recur_push(sc, sc->rec_f6f(sc, sc->rec_f6p));
+ recur_push(sc, sc->rec_f7f(sc, sc->rec_f7p));
+ recur_push(sc, sc->rec_f8f(sc, sc->rec_f8p));
+ slot_set_value(sc->rec_slot3, sc->rec_f9f(sc, sc->rec_f9p));
+ slot_set_value(sc->rec_slot2, recur_pop(sc));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ recur_push(sc, oprec_if_a_a_lopl3a_l3a_l3aq(sc));
+ slot_set_value(sc->rec_slot3, recur_ref(sc, 2));
+ slot_set_value(sc->rec_slot2, recur_ref(sc, 3));
+ slot_set_value(sc->rec_slot1, recur_ref(sc, 4));
+ recur_push(sc, oprec_if_a_a_lopl3a_l3a_l3aq(sc));
+ slot_set_value(sc->rec_slot3, recur_ref(sc, 6));
+ slot_set_value(sc->rec_slot2, recur_ref(sc, 7));
+ slot_set_value(sc->rec_slot1, recur_ref(sc, 8));
+ slot_set_value(sc->rec_slot1, oprec_if_a_a_lopl3a_l3a_l3aq(sc));
+ slot_set_value(sc->rec_slot2, recur_pop(sc));
+ slot_set_value(sc->rec_slot3, recur_pop(sc));
+ sc->rec_loc -= 6;
+ return(oprec_if_a_a_lopl3a_l3a_l3aq(sc));
+}
+
+static s7_pointer op_recur_if_a_a_lopl3a_l3a_l3aq(s7_scheme *sc)
+{
+ opinit_if_a_a_lopl3a_l3a_l3aq(sc);
+ return(oprec_if_a_a_lopl3a_l3a_l3aq(sc));
+}
+
+/* -------- if_a_a_and_a_laa_laa -------- */
+static void opinit_if_a_a_and_a_laa_laa(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer caller = opt3_pair(code);
+ s7_pointer la1 = caddr(caller);
+ s7_pointer la2 = cadddr(caller);
+ rec_set_test(sc, cdr(code));
+ rec_set_res(sc, cddr(code));
+ rec_set_f1(sc, cdr(caller));
+ rec_set_f2(sc, cdr(la1));
+ rec_set_f3(sc, cddr(la1));
+ rec_set_f4(sc, cdr(la2));
+ rec_set_f5(sc, cddr(la2));
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_slot2 = next_slot(sc->rec_slot1);
+}
+
+static s7_pointer oprec_if_a_a_and_a_laa_laa(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ if (sc->rec_f1f(sc, sc->rec_f1p) == sc->F) return(sc->F);
+ recur_push(sc, slot_value(sc->rec_slot1));
+ recur_push(sc, slot_value(sc->rec_slot2));
+ 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));
+ if (oprec_if_a_a_and_a_laa_laa(sc) == sc->F)
+ {
+ sc->rec_loc -= 2;
+ return(sc->F);
+ }
+ slot_set_value(sc->rec_slot2, recur_pop(sc));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p));
+ slot_set_value(sc->rec_slot2, sc->rec_f5f(sc, sc->rec_f5p));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ return(oprec_if_a_a_and_a_laa_laa(sc));
+}
+
+static s7_pointer op_recur_if_a_a_and_a_laa_laa(s7_scheme *sc)
+{
+ opinit_if_a_a_and_a_laa_laa(sc, sc->code);
+ return(oprec_if_a_a_and_a_laa_laa(sc));
+}
+
+static s7_pointer fx_recur_if_a_a_and_a_laa_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_RECUR_IF_A_A_AND_A_LAA_LAA);
+ /* sc->curlet is set already and will be restored by the caller */
+ sc->rec_stack = recur_make_stack(sc);
+ opinit_if_a_a_and_a_laa_laa(sc, arg);
+ sc->value = oprec_if_a_a_and_a_laa_laa(sc);
+ sc->rec_loc = 0;
+ return(sc->value);
+}
+
+/* -------- cond_a_a_a_a_opla_laq -------- */
+static void opinit_cond_a_a_a_a_opla_laq(s7_scheme *sc, s7_pointer code, bool cond_case)
+{
+ s7_pointer caller = opt3_pair(code);
+ if (cond_case)
+ {
+ rec_set_test(sc, cadr(code));
+ rec_set_res(sc, cdadr(code));
+ rec_set_f1(sc, caddr(code));
+ rec_set_f2(sc, cdaddr(code));
+ }
+ else
+ {
+ rec_set_test(sc, cdr(code));
+ rec_set_res(sc, cddr(code)); /* (if a b...) */
+ rec_set_f1(sc, opt1_pair(code)); /* cdr(cadddr(code)), (if a b (if c d...)) */
+ rec_set_f2(sc, cdr(opt1_pair(code)));
+ }
+ rec_set_f3(sc, cdadr(caller));
+ rec_set_f4(sc, opt3_pair(caller));
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_fn = fn_proc(caller);
+}
+
+static inline s7_pointer oprec_cond_a_a_a_a_opla_laq(s7_scheme *sc) /* inline = 27 in trec */
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) return(sc->rec_f2f(sc, sc->rec_f2p));
+ recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
+ slot_set_value(sc->rec_slot1, sc->rec_f4f(sc, sc->rec_f4p));
+ slot_set_value(sc->rec_slot1, recur_swap(sc, oprec_cond_a_a_a_a_opla_laq(sc)));
+ set_car(sc->t2_1, oprec_cond_a_a_a_a_opla_laq(sc));
+ set_car(sc->t2_2, recur_pop(sc));
+ return(sc->rec_fn(sc, sc->t2_1));
+}
+
+static s7_pointer op_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc)
+{
+ opinit_cond_a_a_a_a_opla_laq(sc, sc->code, true);
+ return(oprec_cond_a_a_a_a_opla_laq(sc));
+}
+
+static s7_pointer op_recur_if_a_a_if_a_a_opla_laq(s7_scheme *sc)
+{
+ opinit_cond_a_a_a_a_opla_laq(sc, sc->code, false);
+ return(oprec_cond_a_a_a_a_opla_laq(sc));
+}
+
+static s7_pointer fx_recur_cond_a_a_a_a_opla_laq(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_RECUR_COND_A_A_A_A_opLA_LAq);
+ sc->rec_stack = recur_make_stack(sc);
+ opinit_cond_a_a_a_a_opla_laq(sc, arg, true);
+ sc->value = oprec_cond_a_a_a_a_opla_laq(sc);
+ sc->rec_loc = 0;
+ return(sc->value);
+}
+
+
+/* -------- cond_a_a_a_a_oplaa_laaq -------- */
+static void opinit_cond_a_a_a_a_oplaa_laaq(s7_scheme *sc, bool cond_case)
+{
+ s7_pointer caller = opt3_pair(sc->code); /* cadr(cadddr(sc->code)) = (cfunc laa laa) */
+ if (cond_case)
+ {
+ rec_set_test(sc, cadr(sc->code));
+ rec_set_res(sc, cdadr(sc->code));
+ rec_set_f1(sc, caddr(sc->code));
+ rec_set_f2(sc, cdaddr(sc->code));
+ }
+ else
+ {
+ rec_set_test(sc, cdr(sc->code));
+ rec_set_res(sc, cddr(sc->code)); /* (if a b...) */
+ rec_set_f1(sc, opt1_pair(sc->code)); /* cdr(cadddr(sc->code)), (if a b (if c d...)) */
+ rec_set_f2(sc, cdr(opt1_pair(sc->code)));
+ }
+ sc->rec_f3p = cdadr(caller);
+ rec_set_f4(sc, cdr(sc->rec_f3p));
+ sc->rec_f3f = fx_proc(sc->rec_f3p);
+ sc->rec_f3p = car(sc->rec_f3p);
+ sc->rec_f5p = opt3_pair(caller);
+ rec_set_f6(sc, cdr(sc->rec_f5p));
+ sc->rec_f5f = fx_proc(sc->rec_f5p);
+ sc->rec_f5p = car(sc->rec_f5p);
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_slot2 = next_slot(sc->rec_slot1);
+ sc->rec_fn = fn_proc(caller);
+}
+
+static s7_pointer oprec_cond_a_a_a_a_oplaa_laaq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) return(sc->rec_f2f(sc, sc->rec_f2p));
+ recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
+ 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));
+ sc->value = oprec_cond_a_a_a_a_oplaa_laaq(sc); /* second laa arg */
+ slot_set_value(sc->rec_slot2, recur_pop(sc));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ recur_push_unchecked(sc, sc->value);
+ set_car(sc->t2_1, oprec_cond_a_a_a_a_oplaa_laaq(sc)); /* first laa arg */
+ set_car(sc->t2_2, recur_pop(sc));
+ return(sc->rec_fn(sc, sc->t2_1));
+}
+
+static s7_pointer op_recur_cond_a_a_a_a_oplaa_laaq(s7_scheme *sc)
+{
+ opinit_cond_a_a_a_a_oplaa_laaq(sc, true);
+ return(oprec_cond_a_a_a_a_oplaa_laaq(sc));
+}
+
+static s7_pointer op_recur_if_a_a_if_a_a_oplaa_laaq(s7_scheme *sc)
+{
+ opinit_cond_a_a_a_a_oplaa_laaq(sc, false);
+ return(oprec_cond_a_a_a_a_oplaa_laaq(sc));
+}
+
+
+/* -------- cond_a_a_a_a_opa_laaq -------- */
+static void opinit_cond_a_a_a_a_opa_laaq(s7_scheme *sc)
+{
+ s7_pointer caller = opt3_pair(sc->code);
+ rec_set_test(sc, cadr(sc->code));
+ rec_set_res(sc, cdadr(sc->code));
+ sc->rec_f1p = caddr(sc->code);
+ rec_set_f2(sc, cdr(sc->rec_f1p));
+ sc->rec_f1f = fx_proc(sc->rec_f1p);
+ sc->rec_f1p = car(sc->rec_f1p);
+ rec_set_f3(sc, cdr(caller));
+ rec_set_f4(sc, opt3_pair(caller));
+ rec_set_f5(sc, cdr(opt3_pair(caller)));
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_slot2 = next_slot(sc->rec_slot1);
+ sc->rec_fn = fn_proc(caller);
+}
+
+static s7_pointer oprec_cond_a_a_a_a_opa_laaq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ if (sc->rec_f1f(sc, sc->rec_f1p) != sc->F) return(sc->rec_f2f(sc, sc->rec_f2p));
+ recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
+ recur_push(sc, sc->rec_f4f(sc, sc->rec_f4p));
+ slot_set_value(sc->rec_slot2, sc->rec_f5f(sc, sc->rec_f5p));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ set_car(sc->t2_2, oprec_cond_a_a_a_a_opa_laaq(sc));
+ set_car(sc->t2_1, recur_pop(sc));
+ return(sc->rec_fn(sc, sc->t2_1));
+}
+
+static s7_pointer op_recur_cond_a_a_a_a_opa_laaq(s7_scheme *sc)
+{
+ opinit_cond_a_a_a_a_opa_laaq(sc);
+ return(oprec_cond_a_a_a_a_opa_laaq(sc));
+}
+
+
+/* -------- cond_a_a_a_laa_opa_laaq -------- */
+static void opinit_cond_a_a_a_laa_opa_laaq(s7_scheme *sc, bool cond)
+{
+ s7_pointer caller = opt3_pair(sc->code); /* opA_LAA */
+ rec_set_test(sc, (cond) ? cadr(sc->code) : cdr(sc->code));
+ rec_set_res(sc, (cond) ? cdadr(sc->code) : cddr(sc->code));
+ sc->rec_f1p = (cond) ? caddr(sc->code) : cdr(cadddr(sc->code));
+ sc->rec_f2p = cdadr(sc->rec_f1p);
+ rec_set_f3(sc, cdr(sc->rec_f2p));
+ sc->rec_f1f = fx_proc(sc->rec_f1p);
+ sc->rec_f1p = car(sc->rec_f1p);
+ sc->rec_f2f = fx_proc(sc->rec_f2p);
+ sc->rec_f2p = car(sc->rec_f2p);
+ rec_set_f4(sc, cdr(caller));
+ sc->rec_f5p = cdr(opt3_pair(caller)); /* (L)AA */
+ rec_set_f6(sc, cdr(sc->rec_f5p));
+ sc->rec_f5f = fx_proc(sc->rec_f5p);
+ sc->rec_f5p = car(sc->rec_f5p);
+ sc->rec_fn = fn_proc(caller);
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_slot2 = next_slot(sc->rec_slot1);
+}
+
+static s7_pointer oprec_cond_a_a_a_laa_opa_laaq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ 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));
+ return(oprec_cond_a_a_a_laa_opa_laaq(sc)); /* first laa above */
+ }
+ 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));
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F)
+ set_car(sc->t2_2, sc->rec_resf(sc, sc->rec_resp));
+ 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 */
+ }
+ 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));
+ }
+ set_car(sc->t2_1, recur_pop(sc));
+ return(sc->rec_fn(sc, sc->t2_1));
+}
+
+static s7_pointer op_recur_cond_a_a_a_laa_opa_laaq(s7_scheme *sc)
+{
+ opinit_cond_a_a_a_laa_opa_laaq(sc, true);
+ return(oprec_cond_a_a_a_laa_opa_laaq(sc));
+}
+
+static s7_pointer op_recur_if_a_a_if_a_laa_opa_laaq(s7_scheme *sc) /* if version, same logic as cond above */
+{
+ opinit_cond_a_a_a_laa_opa_laaq(sc, false);
+ return(oprec_cond_a_a_a_laa_opa_laaq(sc));
+}
+
+/* -------- cond_a_a_a_laa_lopa_laaq -------- */
+
+static opt_pid_t opinit_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc)
+{
+ s7_pointer caller = opt3_pair(sc->code);
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_slot2 = next_slot(sc->rec_slot1);
+
+#if (!WITH_GMP)
+ if ((is_t_integer(slot_value(sc->rec_slot1))) &&
+ (is_t_integer(slot_value(sc->rec_slot2))))
+ {
+ 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);
+ }}}}}}}}}
+#endif
+ rec_set_test(sc, cadr(sc->code));
+ rec_set_res(sc, cdadr(sc->code));
+ sc->rec_f1p = caddr(sc->code);
+ sc->rec_f2p = cdadr(sc->rec_f1p);
+ rec_set_f3(sc, cdr(sc->rec_f2p));
+ sc->rec_f1f = fx_proc(sc->rec_f1p);
+ sc->rec_f1p = car(sc->rec_f1p);
+ sc->rec_f2f = fx_proc(sc->rec_f2p);
+ sc->rec_f2p = car(sc->rec_f2p);
+ rec_set_f4(sc, cdr(caller));
+ sc->rec_f5p = opt3_pair(caller);
+ rec_set_f6(sc, cdr(sc->rec_f5p));
+ sc->rec_f5f = fx_proc(sc->rec_f5p);
+ sc->rec_f5p = car(sc->rec_f5p);
+ return(OPT_PTR);
+}
+
+static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc)
+{
+ s7_int i1, i2;
+ if (sc->rec_test_o->v[0].fb(sc->rec_test_o)) return(sc->rec_result_o->v[0].fi(sc->rec_result_o));
+ if (sc->rec_a1_o->v[0].fb(sc->rec_a1_o))
+ {
+ i1 = sc->rec_a2_o->v[0].fi(sc->rec_a2_o);
+ set_integer(sc->rec_val2, sc->rec_a3_o->v[0].fi(sc->rec_a3_o));
+ set_integer(sc->rec_val1, i1);
+ return(oprec_i_cond_a_a_a_laa_lopa_laaq(sc));
+ }
+ i1 = sc->rec_a4_o->v[0].fi(sc->rec_a4_o);
+ i2 = sc->rec_a5_o->v[0].fi(sc->rec_a5_o);
+ set_integer(sc->rec_val2, sc->rec_a6_o->v[0].fi(sc->rec_a6_o));
+ set_integer(sc->rec_val1, i2);
+ set_integer(sc->rec_val2, oprec_i_cond_a_a_a_laa_lopa_laaq(sc));
+ set_integer(sc->rec_val1, i1);
+ return(oprec_i_cond_a_a_a_laa_lopa_laaq(sc));
+}
+
+static s7_int oprec_i_cond_a_a_a_laa_lopa_laaq_0(s7_scheme *sc)
+{
+ s7_int i1, i2;
+ if (sc->rec_fb1(sc->rec_test_o)) return(sc->rec_fi1(sc->rec_result_o));
+ if (sc->rec_fb2(sc->rec_a1_o))
+ {
+ i1 = sc->rec_fi2(sc->rec_a2_o);
+ set_integer(sc->rec_val2, sc->rec_fi3(sc->rec_a3_o));
+ set_integer(sc->rec_val1, i1);
+ return(oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc));
+ }
+ i1 = sc->rec_fi4(sc->rec_a4_o);
+ i2 = sc->rec_fi5(sc->rec_a5_o);
+ set_integer(sc->rec_val2, sc->rec_fi6(sc->rec_a6_o));
+ set_integer(sc->rec_val1, i2);
+ set_integer(sc->rec_val2, oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc));
+ set_integer(sc->rec_val1, i1);
+ return(oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc));
+}
+
+static s7_pointer oprec_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc)
+{
+ if (sc->rec_testf(sc, sc->rec_testp) != sc->F) return(sc->rec_resf(sc, sc->rec_resp));
+ 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));
+ return(oprec_cond_a_a_a_laa_lopa_laaq(sc));
+ }
+ 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));
+ slot_set_value(sc->rec_slot2, oprec_cond_a_a_a_laa_lopa_laaq(sc));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ return(oprec_cond_a_a_a_laa_lopa_laaq(sc));
+}
+
+static void wrap_recur_cond_a_a_a_laa_lopa_laaq(s7_scheme *sc)
+{
+ opt_pid_t choice = opinit_cond_a_a_a_laa_lopa_laaq(sc);
+ tick_tc(sc, sc->cur_op);
+ if (choice != OPT_PTR)
+ sc->value = make_integer(sc, (choice == OPT_INT) ? oprec_i_cond_a_a_a_laa_lopa_laaq(sc) : oprec_i_cond_a_a_a_laa_lopa_laaq_0(sc));
+ else
+ {
+ sc->rec_stack = recur_make_stack(sc);
+ sc->value = oprec_cond_a_a_a_laa_lopa_laaq(sc);
+ sc->rec_loc = 0;
+ }
+}
+
+/* -------- and_a_or_a_laa_laa -------- */
+static void opinit_and_a_or_a_laa_laa(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer orp = cdr(opt3_pair(code));
+ rec_set_test(sc, cdr(code));
+ rec_set_res(sc, orp);
+ rec_set_f1(sc, cdr(cadr(orp)));
+ rec_set_f2(sc, cddr(cadr(orp)));
+ rec_set_f3(sc, cdr(caddr(orp)));
+ rec_set_f4(sc, cddr(caddr(orp)));
+ sc->rec_slot1 = let_slots(sc->curlet);
+ sc->rec_slot2 = next_slot(sc->rec_slot1);
+}
+
+static s7_pointer oprec_and_a_or_a_laa_laa(s7_scheme *sc)
+{
+ s7_pointer p;
+ if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->F);
+ p = sc->rec_resf(sc, sc->rec_resp);
+ if (p != sc->F) return(p);
+ recur_push(sc, slot_value(sc->rec_slot1));
+ recur_push(sc, slot_value(sc->rec_slot2));
+ recur_push(sc, sc->rec_f1f(sc, sc->rec_f1p));
+ slot_set_value(sc->rec_slot2, sc->rec_f2f(sc, sc->rec_f2p));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ p = oprec_and_a_or_a_laa_laa(sc);
+ if (p != sc->F)
+ {
+ sc->rec_loc -= 2;
+ return(p);
+ }
+ slot_set_value(sc->rec_slot2, recur_pop(sc));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ recur_push(sc, sc->rec_f3f(sc, sc->rec_f3p));
+ slot_set_value(sc->rec_slot2, sc->rec_f4f(sc, sc->rec_f4p));
+ slot_set_value(sc->rec_slot1, recur_pop(sc));
+ return(oprec_and_a_or_a_laa_laa(sc));
+}
+
+static s7_pointer op_recur_and_a_or_a_laa_laa(s7_scheme *sc)
+{
+ opinit_and_a_or_a_laa_laa(sc, sc->code);
+ return(oprec_and_a_or_a_laa_laa(sc));
+}
+
+static s7_pointer fx_recur_and_a_or_a_laa_laa(s7_scheme *sc, s7_pointer arg)
+{
+ tick_tc(sc, OP_RECUR_AND_A_OR_A_LAA_LAA);
+ sc->rec_stack = recur_make_stack(sc);
+ opinit_and_a_or_a_laa_laa(sc, arg);
+ sc->value = oprec_and_a_or_a_laa_laa(sc);
+ sc->rec_loc = 0;
+ return(sc->value);
+}
+
+static void wrap_recur(s7_scheme *sc, s7_pointer (*recur)(s7_scheme *sc))
+{
+ tick_tc(sc, sc->cur_op);
+ sc->rec_stack = recur_make_stack(sc);
+ sc->value = recur(sc);
+ sc->rec_loc = 0;
+}
+
+
+/* -------------------------------- */
+static void op_safe_c_p(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack_no_args_direct(sc, OP_SAFE_C_P_1);
+ sc->code = T_Pair(cadr(sc->code));
+}
+
+static void op_safe_c_p_1(s7_scheme *sc) {sc->value = fn_proc(sc->code)(sc, with_list_t1(sc->value));}
+
+static void op_safe_c_ssp(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack_no_args_direct(sc, OP_SAFE_C_SSP_1);
+ sc->code = opt3_pair(sc->code);
+}
+
+static void op_safe_c_ssp_1(s7_scheme *sc)
+{
+ set_car(sc->t3_3, sc->value);
+ set_car(sc->t3_1, lookup(sc, cadr(sc->code)));
+ set_car(sc->t3_2, lookup(sc, caddr(sc->code)));
+ sc->value = fn_proc(sc->code)(sc, sc->t3_1);
+}
+
+static void op_s(s7_scheme *sc)
+{
+ sc->code = lookup(sc, car(sc->code));
+ if (!is_applicable(sc->code))
+ apply_error_nr(sc, sc->code, sc->nil);
+ sc->args = sc->nil; /* op_s -> apply, so we'll apply sc->code to sc->args */
+}
+
+static bool op_s_g(s7_scheme *sc)
+{
+ s7_pointer code = sc->code;
+ sc->code = lookup_checked(sc, car(code));
+ if ((is_c_function(sc->code)) &&
+ (c_function_min_args(sc->code) == 1) &&
+ (!needs_copied_args(sc->code)))
+ {
+ sc->value = c_function_call(sc->code)(sc, with_list_t1((is_symbol(cadr(code))) ? lookup_checked(sc, cadr(code)) : cadr(code)));
+ return(true); /* continue */
+ }
+ if (!is_applicable(sc->code))
+ apply_error_nr(sc, sc->code, cdr(code));
+ if (dont_eval_args(sc->code))
+ sc->args = cdr(code);
+ else
+ {
+ s7_pointer val = (is_symbol(cadr(code))) ? lookup_checked(sc, cadr(code)) : cadr(code);
+ sc->args = (needs_copied_args(sc->code)) ? list_1(sc, val) : set_plist_1(sc, val);
+ }
+ return(false);
+}
+
+static bool op_x_a(s7_scheme *sc, s7_pointer f)
+{
+ if ((((type(f) == T_C_FUNCTION) &&
+ (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)))) &&
+ (!needs_copied_args(f)))
+ {
+ sc->value = c_function_call(f)(sc, with_list_t1(fx_call(sc, cdr(sc->code))));
+ return(true);
+ }
+ if (is_any_vector(f))
+ {
+ sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code)));
+ sc->code = f;
+ apply_vector(sc);
+ return(true);
+ }
+ if (!is_applicable(f))
+ apply_error_nr(sc, f, cdr(sc->code));
+ if (dont_eval_args(f))
+ sc->args = cdr(sc->code); /* list_1(sc, cadr(sc->code)); */
+ else
+ if (!needs_copied_args(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->code = f;
+ return(false); /* goto APPLY */
+}
+
+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)))
+ { /* ((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->args = list_2(sc, lookup_checked(sc, cadr(code)), caddr(code));
+ sc->code = f;
+ return(false); /* goto APPLY */
+ }
+ if (!is_applicable(f))
+ apply_error_nr(sc, f, cdr(code));
+ if (dont_eval_args(f))
+ sc->args = list_2(sc, cadr(code), caddr(code));
+ else
+ if (!needs_copied_args(f))
+ sc->args = set_plist_2(sc, lookup_checked(sc, cadr(code)), caddr(code));
+ else sc->args = list_2(sc, lookup_checked(sc, cadr(code)), caddr(code));
+ sc->code = f;
+ return(false); /* goto APPLY */
+}
+
+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)))
+ { /* ((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->args = fx_call(sc, cddr(code));
+ sc->args = list_2(sc, sc->value = fx_call(sc, cdr(code)), sc->args);
+ sc->code = f;
+ return(false); /* goto APPLY */
+ }
+ if (!is_applicable(f))
+ apply_error_nr(sc, f, cdr(code));
+ if (dont_eval_args(f))
+ sc->args = list_2(sc, cadr(code), caddr(code));
+ else
+ {
+ 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);
+ else sc->args = list_2(sc, sc->value = fx_call(sc, cdr(code)), sc->args);
+ }
+ sc->code = f;
+ return(false); /* goto APPLY */
+}
+
+static void op_p_s_1(s7_scheme *sc)
+{
+ /* we get multiple values here (from op calc = "p" not "s") but don't need to handle it ourselves:
+ * let v be #(#_abs), so ((v 0) -2), (v 0 -2), ((values v 0) -2), and (((values v 0)) -2) are all 2
+ * or: (define (f1) (values vector-ref (vector 1 2 3))) (define arg 1) (define (f2) ((f1) arg)) (f2) (f2)
+ * so apply calls apply_pair which handles multiple values explicitly.
+ */
+ if (dont_eval_args(sc->value))
+ sc->args = cdr(sc->code);
+ else
+ {
+ sc->args = lookup_checked(sc, cadr(sc->code));
+ sc->args = (needs_copied_args(sc->value)) ? list_1(sc, sc->args) : set_plist_1(sc, sc->args);
+ }
+ sc->code = sc->value; /* goto APPLY */
+}
+
+static void op_safe_c_star_na(s7_scheme *sc)
+{
+ sc->args = safe_list_if_possible(sc, opt3_arglen(cdr(sc->code)));
+ for (s7_pointer args = cdr(sc->code), p = sc->args; is_pair(args); args = cdr(args), p = cdr(p))
+ set_car(p, fx_call(sc, args));
+ sc->code = opt1_cfunc(sc->code);
+ apply_c_function_star(sc);
+ if (!in_heap(sc->args)) clear_list_in_use(sc->args);
+}
+
+static void op_safe_c_star(s7_scheme *sc)
+{
+ sc->code = opt1_cfunc(sc->code);
+ apply_c_function_star_fill_defaults(sc, 0);
+}
+
+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));
+ /* scheme-level define* here also gives "not a parameter name" */
+ sc->args = list_1(sc, sc->args);
+ sc->code = opt1_cfunc(sc->code);
+ /* one arg, so it's not a keyword; all we need to do is fill in the defaults */
+ apply_c_function_star_fill_defaults(sc, 1);
+}
+
+static void op_safe_c_star_aa(s7_scheme *sc)
+{
+ sc->args = fx_call(sc, cdr(sc->code));
+ set_car(sc->t2_2, fx_call(sc, cddr(sc->code)));
+ set_car(sc->t2_1, sc->args);
+ sc->args = sc->t2_1;
+ sc->code = opt1_cfunc(sc->code);
+ apply_c_function_star(sc);
+}
+
+
+static void op_safe_c_ps(s7_scheme *sc)
+{
+ push_stack_no_args_direct(sc, OP_SAFE_C_PS_1); /* got to wait in this case */
+ sc->code = cadr(sc->code);
+}
+
+static void op_safe_c_ps_1(s7_scheme *sc)
+{
+ set_car(sc->t2_2, lookup(sc, caddr(sc->code)));
+ set_car(sc->t2_1, sc->value);
+ sc->value = fn_proc(sc->code)(sc, sc->t2_1);
+}
+
+static void op_safe_c_sp(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ check_stack_size(sc);
+ push_stack(sc, (opcode_t)T_Op(opt1_any(args)), lookup(sc, car(args)), sc->code);
+ sc->code = cadr(args);
+}
+
+static void op_safe_c_sp_1(s7_scheme *sc)
+{
+ /* we get here from many places (op_safe_c_sp for example), but all are safe */
+ sc->value = fn_proc(sc->code)(sc, with_list_t2(sc->args, sc->value));
+}
+
+static void op_safe_add_sp_1(s7_scheme *sc)
+{
+ if ((is_t_integer(sc->args)) && (is_t_integer(sc->value)))
+ sc->value = add_if_overflow_to_real_or_big_integer(sc, integer(sc->args), integer(sc->value));
+ else sc->value = add_p_pp(sc, sc->args, sc->value);
+}
+
+static void op_safe_multiply_sp_1(s7_scheme *sc)
+{
+ if ((is_t_real(sc->args)) && (is_t_real(sc->value)))
+ sc->value = make_real(sc, real(sc->args) * real(sc->value));
+ else sc->value = multiply_p_pp(sc, sc->args, sc->value);
+}
+
+static void op_safe_c_pc(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ check_stack_size(sc); /* b dyn */
+ push_stack(sc, OP_SAFE_C_PC_1, opt3_con(args), sc->code);
+ sc->code = car(args);
+}
+
+static void op_safe_c_pc_1(s7_scheme *sc) {sc->value = fn_proc(sc->code)(sc, with_list_t2(sc->value, sc->args));}
+
+static void op_safe_c_cp(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ /* it's possible in a case like this to overflow the stack -- s7test has a deeply
+ * nested expression involving (+ c (+ c (+ ... ))) all opt'd as safe_c_cp -- if we're close
+ * to the stack end at the start, it runs off the end. Normally the stack increase in
+ * the reader protects us, but a call/cc can replace the original stack with a much smaller one.
+ */
+ check_stack_size(sc);
+ push_stack(sc, (opcode_t)T_Op(opt1_any(args)), opt3_any(args), sc->code); /* to safe_add_sp_1 for example */
+ sc->code = cadr(args);
+}
+
+static Inline void inline_op_safe_c_s(s7_scheme *sc) /* called twice in eval c/cl_s many hits */
+{
+ sc->value = fn_proc(sc->code)(sc, with_list_t1(lookup(sc, cadr(sc->code))));
+}
+/* if op_safe_c_t added and set in fx_tree_in, we get a few hits, but nothing significant.
+ * if that had worked, it would be interesting to set opt1(cdr) to the fx_tree fx_proc, (init to fx_c_s), then call that here.
+ * opt1(cdr) is not used here, opt3_byte happens a few times, but opt2_direct clobbers opt2_fx sometimes
+ * (also need fx_annotate cdr(expr) in optimize_c_function_one_arg)
+ */
+
+static Inline void inline_op_safe_c_ss(s7_scheme *sc) /* called twice in eval c/cl_ss many hits */
+{
+ sc->value = fn_proc(sc->code)(sc, with_list_t2(lookup(sc, cadr(sc->code)), lookup(sc, opt2_sym(cdr(sc->code)))));
+}
+
+static void op_safe_c_sc(s7_scheme *sc)
+{
+ sc->value = fn_proc(sc->code)(sc, with_list_t2(lookup(sc, cadr(sc->code)), opt2_con(cdr(sc->code))));
+}
+
+static void op_cl_a(s7_scheme *sc) {sc->value = fn_proc(sc->code)(sc, with_list_t1(fx_call(sc, cdr(sc->code))));}
+
+static inline void op_cl_aa(s7_scheme *sc)
+{
+ gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code)));
+ set_car(sc->t2_2, fx_call(sc, cddr(sc->code)));
+ set_car(sc->t2_1, T_Ext(stack_protected1(sc)));
+ unstack_gc_protect(sc);
+ sc->value = fn_proc(sc->code)(sc, sc->t2_1);
+}
+
+static void op_cl_fa(s7_scheme *sc)
+{
+ s7_pointer code = cdadr(sc->code);
+ set_car(sc->t2_2, fx_call(sc, cddr(sc->code)));
+ set_car(sc->t2_1, make_closure_gc_checked(sc, car(code), cdr(code), T_CLOSURE | ((!s7_is_proper_list(sc, car(sc->code))) ? T_COPY_ARGS : 0), CLOSURE_ARITY_NOT_SET));
+ /* arg1 lambda can be any arity, but it must be applicable to one arg (the "a" above) */
+ /* was checking is_symbol(car(sc->code) i.e. is arglist a symbol, but we need T_COPY_ARGS if arglist is '(a . b) as well (can this happen here?) */
+ sc->value = fn_proc(sc->code)(sc, sc->t2_1);
+}
+
+static inline void op_map_for_each_fa(s7_scheme *sc)
+{
+ s7_pointer f = cddr(sc->code), code = sc->code;
+ sc->value = fx_call(sc, f);
+ if (is_null(sc->value))
+ sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil;
+ else
+ {
+ sc->code = opt3_pair(code); /* cdadr(code); */
+ f = make_closure_gc_checked(sc, car(sc->code), cdr(sc->code), T_CLOSURE, 1); /* arity=1 checked in optimizer */
+ sc->value = (fn_proc_unchecked(code)) ? g_for_each_closure(sc, f, sc->value) : g_map_closure(sc, f, sc->value);
+ }
+}
+
+static void op_map_for_each_faa(s7_scheme *sc)
+{
+ s7_pointer f = cddr(sc->code), code = sc->code;
+ sc->value = fx_call(sc, f);
+ sc->args = fx_call(sc, cdr(f));
+ if ((is_null(sc->value)) || (is_null(sc->args)))
+ sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil;
+ else
+ {
+ sc->code = opt3_pair(code); /* cdadr(code); */
+ f = make_closure_gc_checked(sc, car(sc->code), cdr(sc->code), T_CLOSURE, 2); /* arity=2 checked in optimizer */
+ sc->value = (fn_proc_unchecked(code)) ? g_for_each_closure_2(sc, f, sc->value, sc->args) : g_map_closure_2(sc, f, sc->value, sc->args);
+ }
+}
+
+static void op_cl_na(s7_scheme *sc)
+{
+ s7_pointer val = safe_list_if_possible(sc, opt3_arglen(cdr(sc->code)));
+ if (in_heap(val)) gc_protect_via_stack(sc, val);
+ for (s7_pointer args = cdr(sc->code), p = val; is_pair(args); args = cdr(args), p = cdr(p))
+ set_car(p, fx_call(sc, args));
+ sc->value = fn_proc(sc->code)(sc, val);
+ if (!in_heap(val))
+ clear_list_in_use(val);
+ else
+ /* the fn_proc call might push its own op (e.g. for-each/map) so we have to check for that */
+ if (stack_top_op(sc) == OP_GC_PROTECT) unstack_gc_protect(sc);
+}
+
+static void op_cl_sas(s7_scheme *sc)
+{
+ set_car(sc->t3_2, fx_call(sc, cddr(sc->code)));
+ set_car(sc->t3_1, lookup(sc, cadr(sc->code)));
+ set_car(sc->t3_3, lookup(sc, cadddr(sc->code)));
+ sc->value = fn_proc(sc->code)(sc, sc->t3_1);
+}
+
+static inline void op_safe_c_pp(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ check_stack_size(sc);
+ push_stack_no_args_direct(sc, OP_SAFE_C_PP_1); /* first arg = p, if mv -> op_safe_c_pp_3 */
+ sc->code = car(args);
+}
+
+static void op_safe_c_pp_1(s7_scheme *sc)
+{
+ push_stack(sc, (opcode_t)T_Op(opt1_any(cdr(sc->code))), sc->value, sc->code); /* args[i.e. sc->value] = first value, func(args, value) if no mv */
+ sc->code = caddr(sc->code);
+}
+
+static void op_safe_c_pp_3_mv(s7_scheme *sc)
+{
+ /* we get here if the first arg returned multiple values */
+ push_stack(sc, OP_SAFE_C_PP_5, copy_proper_list(sc, sc->value), sc->code); /* copy is needed here */
+ sc->code = caddr(sc->code);
+}
+
+static void op_safe_c_pp_5(s7_scheme *sc)
+{
+ /* 1 mv, 2 normal (else mv->6), sc->args was copied above (and this is a safe c function so its args are in no danger) */
+ if (is_null(sc->args))
+ sc->args = list_1(sc, sc->value); /* plist here and below, but this is almost never called */
+ else
+ {
+ s7_pointer p;
+ for (p = sc->args; is_pair(cdr(p)); p = cdr(p));
+ set_cdr(p, list_1(sc, sc->value));
+ }
+ 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);
+ else apply_c_rst_no_req_function(sc);
+}
+
+static void op_safe_c_3p(s7_scheme *sc)
+{
+ check_stack_size(sc);
+ push_stack_no_args_direct(sc, OP_SAFE_C_3P_1);
+ sc->code = cadr(sc->code);
+}
+
+static void op_safe_c_3p_1(s7_scheme *sc)
+{
+ sc->args = sc->value; /* possibly fx/gx? and below */
+ push_stack_direct(sc, OP_SAFE_C_3P_2);
+ sc->code = caddr(sc->code);
+}
+
+static void op_safe_c_3p_1_mv(s7_scheme *sc) /* here only if sc->value is mv */
+{
+ sc->args = sc->value;
+ push_stack_direct(sc, OP_SAFE_C_3P_2_MV);
+ sc->code = caddr(sc->code);
+}
+
+static void op_safe_c_3p_2(s7_scheme *sc)
+{
+ gc_protect_via_stack(sc, sc->value);
+ check_stack_size(sc);
+ push_stack_direct(sc, OP_SAFE_C_3P_3);
+ sc->code = cadddr(sc->code);
+}
+
+static void op_safe_c_3p_2_mv(s7_scheme *sc) /* here from 1 + 2mv, or 1_mv with 2 or 2mv */
+{
+ gc_protect_via_stack(sc, sc->value);
+ push_stack_direct(sc, OP_SAFE_C_3P_3_MV);
+ sc->code = cadddr(sc->code);
+}
+
+static void op_safe_c_3p_3(s7_scheme *sc)
+{
+ set_car(sc->t3_3, sc->value);
+ set_car(sc->t3_1, sc->args);
+ set_car(sc->t3_2, stack_protected1(sc));
+ unstack_gc_protect(sc);
+ sc->value = fn_proc(sc->code)(sc, sc->t3_1);
+}
+
+static void op_safe_c_3p_3_mv(s7_scheme *sc)
+{
+ s7_pointer p;
+ s7_pointer p1 = ((is_pair(sc->args)) && (car(sc->args) == sc->unused)) ? cdr(sc->args) : list_1(sc, sc->args);
+ s7_pointer ps1 = stack_protected1(sc);
+ s7_pointer p2 = ((is_pair(ps1)) && (car(ps1) == sc->unused)) ? cdr(ps1) : list_1(sc, ps1);
+ s7_pointer p3 = ((is_pair(sc->value)) && (car(sc->value) == sc->unused)) ? cdr(sc->value) : list_1(sc, sc->value);
+ unstack_gc_protect(sc);
+ for (p = p1; is_pair(cdr(p)); p = cdr(p));
+ set_cdr(p, p2);
+ for (p = cdr(p); is_pair(cdr(p)); p = cdr(p));
+ set_cdr(p, p3);
+ sc->args = p1;
+ 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);
+ else apply_c_rst_no_req_function(sc);
+}
+
+static Inline bool inline_collect_np_args(s7_scheme *sc, opcode_t op, s7_pointer args) /* called (all hits:)op_any_c_np_1/mv and eval, tlet (cb/set) */
+{
+ sc->args = args;
+ for (s7_pointer p = sc->code; is_pair(p); p = cdr(p))
+ if (has_fx(p))
+ 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);
+ }
+ return(false);
+}
+
+static bool collect_np_args(s7_scheme *sc, opcode_t op, s7_pointer args) {return(inline_collect_np_args(sc, op, args));}
+
+static /* inline */ bool op_any_c_np(s7_scheme *sc) /* code: (func . args) where at least one arg is not fxable */
+{
+ sc->args = sc->nil;
+ for (s7_pointer p = cdr(sc->code); is_pair(p); p = cdr(p))
+ if (has_fx(p))
+ 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);
+ }
+ sc->args = proper_list_reverse_in_place(sc, sc->args);
+ sc->value = fn_proc(sc->code)(sc, sc->args);
+ return(false);
+}
+
+static Inline bool inline_op_any_c_np_1(s7_scheme *sc) /* called once in eval, tlet (cb/set) */
+{
+ /* in-coming sc->value has the current arg value, sc->args is all previous args, sc->code is on op-stack */
+ if (inline_collect_np_args(sc, OP_ANY_C_NP_1, cons(sc, sc->value, sc->args)))
+ return(true);
+ sc->args = proper_list_reverse_in_place(sc, sc->args);
+ sc->code = pop_op_stack(sc);
+ sc->value = fn_proc(sc->code)(sc, sc->args);
+ return(false);
+}
+
+static void op_any_c_np_2(s7_scheme *sc)
+{
+ sc->args = proper_list_reverse_in_place(sc, sc->args = cons(sc, sc->value, sc->args));
+ sc->code = pop_op_stack(sc);
+ sc->value = fn_proc(sc->code)(sc, sc->args);
+}
+
+static bool op_any_c_np_mv(s7_scheme *sc)
+{
+ /* we're looping through fp cases here, so sc->value can be non-mv after the first */
+ if (collect_np_args(sc, OP_ANY_C_NP_MV, (is_multiple_value(sc->value)) ? revappend(sc, sc->value, sc->args) : cons(sc, sc->value, sc->args)))
+ return(true);
+ sc->args = proper_list_reverse_in_place(sc, sc->args);
+ sc->code = pop_op_stack(sc);
+ sc->code = c_function_base(opt1_cfunc(sc->code));
+ return(false);
+}
+
+static void op_any_closure_np(s7_scheme *sc)
+{
+ s7_pointer p = cdr(sc->code);
+ check_stack_size(sc);
+ if (sc->op_stack_now >= sc->op_stack_end)
+ resize_op_stack(sc);
+ push_op_stack(sc, sc->code);
+ if (has_fx(p))
+ {
+ 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);
+ }
+ 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));
+ sc->code = T_Pair(car(p));
+}
+
+static void op_any_closure_np_end(s7_scheme *sc)
+{
+ s7_pointer x, z, f;
+ uint64_t id;
+
+ sc->args = proper_list_reverse_in_place(sc, sc->args); /* needed in either case -- closure_args(f) is not reversed */
+ sc->code = pop_op_stack(sc);
+ f = opt1_lambda(sc->code);
+
+ if (is_safe_closure(f))
+ {
+ id = ++sc->let_number;
+ 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 */
+ }
+ 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));
+ }
+ else
+ {
+ s7_pointer p = closure_args(f), last_slot;
+ s7_pointer e = inline_make_let(sc, closure_let(f));
+ sc->z = e;
+ id = let_id(e);
+ last_slot = make_slot(sc, car(p), car(sc->args));
+ slot_set_next(last_slot, slot_end);
+ 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 */
+ 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));
+ }
+ 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));
+
+ sc->code = closure_body(f);
+ if_pair_set_up_begin(sc);
+}
+
+static bool op_safe_c_ap(s7_scheme *sc)
+{
+ s7_pointer code = cdr(sc->code);
+ s7_pointer val = cdr(code);
+ check_stack_size(sc);
+ sc->args = fx_call(sc, code);
+ push_stack_direct(sc, (opcode_t)T_Op(opt1_any(code))); /* safe_c_sp cases, mv->safe_c_sp_mv */
+ sc->code = car(val);
+ return(true);
+}
+
+static bool op_safe_c_pa(s7_scheme *sc)
+{
+ s7_pointer args = cdr(sc->code);
+ check_stack_size(sc);
+ push_stack_no_args_direct(sc, OP_SAFE_C_PA_1);
+ sc->code = car(args);
+ return(true);
+}
+
+static void op_safe_c_pa_1(s7_scheme *sc)
+{
+ sc->args = sc->value; /* fx* might change sc->value */
+ set_car(sc->t2_2, fx_call(sc, cddr(sc->code)));
+ set_car(sc->t2_1, sc->args);
+ sc->value = fn_proc(sc->code)(sc, sc->t2_1);
+}
+
+static void op_c_nc(s7_scheme *sc)
+{
+ if (car(sc->code) != sc->values_symbol) /* (define (f) (let ((val (catch #t (lambda () (error 1 2 3)) (lambda args (list 2 3 4))))) val)) (f) */
+ {
+ s7_pointer new_args = make_list(sc, opt3_arglen(cdr(sc->code)), sc->unused);
+ for (s7_pointer args = cdr(sc->code), p = new_args; is_pair(args); args = cdr(args), p = cdr(p)) set_car(p, car(args));
+ sc->temp3 = new_args; /* desperation? */
+ sc->value = fn_proc(sc->code)(sc, new_args);
+ sc->temp3 = sc->unused;
+ }
+ else
+ { /* opt2 = splice_in_values */
+ set_needs_copied_args(cdr(sc->code)); /* needed, see s7test, set_multiple_value which currently aborts if not a heap pointer */
+ sc->value = splice_in_values(sc, cdr(sc->code));
+ }
+}
+
+static void op_c_na(s7_scheme *sc) /* (set-cdr! lst ()) */
+{
+ s7_pointer new_args = make_list(sc, opt3_arglen(cdr(sc->code)), sc->unused);
+ gc_protect_via_stack(sc, new_args);
+ for (s7_pointer args = cdr(sc->code), p = new_args; is_pair(args); args = cdr(args), p = cdr(p))
+ set_car(p, fx_call(sc, args));
+ unstack_gc_protect(sc);
+ sc->temp3 = new_args; /* desperation? */
+ sc->value = fn_proc(sc->code)(sc, new_args);
+ sc->temp3 = sc->unused;
+}
+
+static void op_c_a(s7_scheme *sc)
+{
+ sc->value = fx_call(sc, cdr(sc->code)); /* gc protect result before list_1 */
+ sc->args = list_1(sc, sc->value);
+ sc->value = fn_proc(sc->code)(sc, sc->args);
+}
+
+static void op_c_p(s7_scheme *sc)
+{
+ push_stack_no_args_direct(sc, OP_C_P_1);
+ sc->code = T_Pair(cadr(sc->code));
+}
+
+static inline void op_c_ss(s7_scheme *sc)
+{
+ sc->args = list_2(sc, lookup(sc, cadr(sc->code)), lookup(sc, caddr(sc->code)));
+ sc->value = fn_proc(sc->code)(sc, sc->args);
+}
+
+static void op_c_ap(s7_scheme *sc)
+{
+ sc->args = fx_call(sc, cdr(sc->code));
+ push_stack_direct(sc, OP_C_AP_1); /* op_c_ap_1 sends us to apply which calls check_stack_size I think */
+ sc->code = caddr(sc->code);
+}
+
+static void op_c_aa(s7_scheme *sc)
+{
+ gc_protect_via_stack(sc, fx_call(sc, cdr(sc->code)));
+ set_stack_protected2(sc, fx_call(sc, cddr(sc->code)));
+ sc->value = list_2(sc, stack_protected1(sc), stack_protected2(sc));
+ unstack_gc_protect(sc); /* fn_proc here is unsafe so clear stack first */
+ sc->value = fn_proc(sc->code)(sc, sc->value);
+}
+
+static inline void op_c_s(s7_scheme *sc)
+{
+ sc->args = list_1(sc, lookup_checked(sc, cadr(sc->code)));
+ sc->value = fn_proc(sc->code)(sc, sc->args);
+}
+
+static Inline void inline_op_apply_ss(s7_scheme *sc) /* called once in eval, sg: all time spent in proper_list check */
+{
+ sc->args = lookup(sc, opt2_sym(sc->code));
+ if (!s7_is_proper_list(sc, sc->args))
+ error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "apply: improper list of arguments: ~S", 37), sc->args));
+ sc->code = lookup(sc, cadr(sc->code)); /* global search here was slower (e.g. tauto) */
+ if (needs_copied_args(sc->code))
+ sc->args = copy_proper_list(sc, sc->args);
+}
+
+static void op_apply_sa(s7_scheme *sc)
+{
+ s7_pointer p = cdr(sc->code);
+ sc->args = fx_call(sc, cdr(p));
+ if (!s7_is_proper_list(sc, sc->args))
+ error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "apply: improper list of arguments: ~S", 37), sc->args));
+ sc->code = lookup_global(sc, car(p));
+ if (needs_copied_args(sc->code))
+ sc->args = copy_proper_list(sc, sc->args);
+}
+
+static void op_apply_sl(s7_scheme *sc)
+{
+ s7_pointer p = cdr(sc->code);
+ sc->args = fx_call(sc, cdr(p));
+ sc->code = lookup_global(sc, car(p));
+}
+
+static bool op_pair_pair(s7_scheme *sc)
+{
+ if (!is_pair(car(sc->code))) /* (for-each (macro* (a . b) `(cons ,a ,b)) #(0 1) (list '(values +) -1)) sc->code is (-1) */
+ {
+ clear_optimize_op(sc->code);
+ return(false);
+ }
+ if (sc->stack_end >= (sc->stack_resize_trigger - 8))
+ check_for_cyclic_code(sc, sc->code); /* calls resize_stack */
+ push_stack_no_args_direct(sc, OP_EVAL_ARGS); /* eval args goes immediately to cdr(sc->code) */
+ /* don't put check_stack_size here! */
+ push_stack_no_args(sc, OP_EVAL_ARGS, car(sc->code));
+ sc->code = caar(sc->code);
+ return(true);
+}
+
+static bool op_pair_sym(s7_scheme *sc)
+{
+ if (!is_symbol(car(sc->code))) /* (for-each (macro* (a . b) `(cons ,a ,b)) #(0 1) (list `+ -1)) ! sc->code is (-1) */
+ {
+ clear_optimize_op(sc->code);
+ return(false);
+ }
+ sc->value = lookup_global(sc, car(sc->code));
+ return(true);
+}
+
+static void op_eval_set3(s7_scheme *sc)
+{
+ push_stack(sc, is_null(cdr(sc->code)) ? OP_EVAL_SET3_NO_MV : OP_EVAL_SET3, sc->args, cdr(sc->code));
+ sc->code = car(sc->code);
+ sc->cur_op = optimize_op(sc->code);
+}
+
+static void op_eval_set3_no_mv(s7_scheme *sc)
+{
+ sc->args = pair_append(sc, sc->args, list_1(sc, sc->value));
+ sc->code = pop_op_stack(sc); /* args = (ind... val), code = setter */
+}
+
+static void op_eval_args2(s7_scheme *sc)
+{
+ sc->code = pop_op_stack(sc);
+ sc->args = (is_null(sc->args)) ? list_1(sc, sc->value) : proper_list_reverse_in_place(sc, cons(sc, sc->value, sc->args));
+}
+
+static void op_eval_args3(s7_scheme *sc)
+{
+ s7_pointer val = sc->code;
+ if (is_symbol(val))
+ val = lookup_checked(sc, val);
+ sc->args = proper_list_reverse_in_place(sc, cons_unchecked(sc, val, cons(sc, sc->value, sc->args)));
+ sc->code = pop_op_stack(sc);
+}
+
+static void op_eval_args5(s7_scheme *sc) /* sc->value is the last arg, sc->code is the previous */
+{
+ sc->args = proper_list_reverse_in_place(sc, cons_unchecked(sc, sc->value, cons(sc, sc->code, sc->args)));
+ sc->code = pop_op_stack(sc);
+}
+
+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));
+ 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));
+ }
+ sc->code = sc->value;
+ return(true);
+ }
+ if (is_syntactic_pair(sc->code)) /* (define progn begin) (progn (display "hi") (+ 1 23)) */
+ sc->cur_op = optimize_op(sc->code);
+ else
+ {
+ 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);
+ /* weird that sc->cur_op setting above seems ok, but OP_PAIR_PAIR hangs?? */
+ }
+ return(false);
+}
+
+static s7_pointer unbound_last_arg(s7_scheme *sc, s7_pointer car_code)
+{
+ /* save call-state before autoload/error-hook invocations */
+ s7_int loc = port_location(current_input_port(sc));
+ s7_pointer ops = op_stack_entry(sc);
+ s7_pointer args = sc->args; /* maybe GC protect? */
+ s7_pointer val = check_autoload_and_error_hook(sc, car_code);
+ if (val == sc->undefined)
+ {
+ bool probably_in_repl = ((location_to_line(loc) == 0) || (safe_strcmp("*stdin*", string_value(sc->file_names[location_to_file(loc)]))));
+ 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))));
+ }
+ return(val);
+}
+
+static inline void eval_last_arg(s7_scheme *sc, s7_pointer car_code) /* one call, eval 91557 */
+{
+ /* here we've reached the last arg (sc->code == nil), it is not a pair */
+ if (!is_null(cdr(sc->code)))
+ improper_arglist_error_nr(sc);
+ if (is_symbol(car_code))
+ {
+ s7_pointer val = lookup_unexamined(sc, car_code);
+ sc->code = (val) ? val : unbound_last_arg(sc, car_code);
+ }
+ else sc->code = car_code;
+ sc->args = (is_null(sc->args)) ? list_1(sc, sc->code) : proper_list_reverse_in_place(sc, cons(sc, sc->code, sc->args));
+ sc->code = pop_op_stack(sc);
+}
+
+static s7_pointer unbound_args_last_arg(s7_scheme *sc, s7_pointer car_code)
+{
+ /* save call-state before autoload/error-hook invocations */
+ s7_int loc = port_location(current_input_port(sc));
+ s7_pointer ops = op_stack_entry(sc);
+ s7_pointer args = sc->args; /* maybe GC protect? */
+ s7_pointer value = sc->value;
+ s7_pointer val = check_autoload_and_error_hook(sc, car_code);
+ if (val == sc->undefined)
+ {
+ bool probably_in_repl = ((location_to_line(loc) == 0) || (safe_strcmp("*stdin*", string_value(sc->file_names[location_to_file(loc)]))));
+ sc->w = cons(sc, value, args); /* GC protect this info */
+ 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))));
+ }
+ return(val);
+}
+
+
+static /* inline */ bool eval_args_last_arg(s7_scheme *sc) /* inline: no diff tmisc, small diff tmac (3) */
+{
+ s7_pointer car_code = car(sc->code); /* we're at the last arg, sc->value is the previous one, not yet saved in the args list */
+ if (is_pair(car_code))
+ {
+ if (sc->stack_end >= sc->stack_resize_trigger)
+ check_for_cyclic_code(sc, sc->code);
+ push_stack(sc, OP_EVAL_ARGS5, sc->args, sc->value);
+ sc->code = car_code;
+ return(true);
+ }
+ /* get the last arg */
+ if (is_symbol(car_code))
+ {
+ s7_pointer val = lookup_unexamined(sc, car_code);
+ sc->code = (val) ? val : unbound_args_last_arg(sc, car_code);
+ }
+ else sc->code = car_code;
+ /* get the current arg, which is not a list */
+ sc->args = proper_list_reverse_in_place(sc, cons_unchecked(sc, sc->code, cons(sc, sc->value, sc->args)));
+ sc->code = pop_op_stack(sc);
+ return(false);
+}
+
+static inline void eval_args_pair_car(s7_scheme *sc)
+{
+ s7_pointer code = cdr(sc->code);
+ if (sc->stack_end >= sc->stack_resize_trigger)
+ check_for_cyclic_code(sc, sc->code); /* calls resize_stack */
+ if (is_null(code))
+ push_stack_no_code(sc, OP_EVAL_ARGS2, sc->args);
+ else
+ {
+ if (!is_pair(code)) /* (= 0 '(1 . 2) . 3) */
+ improper_arglist_error_nr(sc);
+ if ((is_null(cdr(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);
+}
+
+static bool eval_car_pair(s7_scheme *sc)
+{
+ s7_pointer code = sc->code, carc = car(sc->code);
+
+ /* evaluate the inner list but that list can be circular: carc: #1=(#1# #1#)! and the cycle can be well-hidden -- #1=((#1 2) . 2) and other such stuff */
+ if (sc->stack_end >= sc->stack_resize_trigger)
+ check_for_cyclic_code(sc, code);
+
+ if (is_symbol_and_syntactic(car(carc)))
+ /* 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);
+ }
+ /* ((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);
+ }
+ sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code);
+ pair_set_syntax_op(sc->code, sc->cur_op);
+ return(true);
+ }
+
+ push_stack_no_args(sc, OP_EVAL_ARGS, code);
+ 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 */
+ }
+ if ((is_null(cddr(code))) && (is_symbol(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);
+ }
+ else set_optimize_op(code, OP_PAIR_PAIR);
+ push_stack_no_args(sc, OP_EVAL_ARGS, carc);
+ sc->code = car(carc);
+ return(false);
+}
+
+static goto_t trailers(s7_scheme *sc)
+{
+ s7_pointer code = T_Ext(sc->code);
+ if (SHOW_EVAL_OPS) fprintf(stderr, " trailers %s\n", display_truncated(code));
+ set_current_code(sc, code);
+ if (is_pair(code))
+ {
+ 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);
+ }
+ if (is_pair(carc)) /* ((if x y z) a b) etc */
+ 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);
+ }
+ /* 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;
+ return(goto_eval_args_top);
+ }
+ if (is_normal_symbol(code))
+ {
+ sc->value = lookup_checked(sc, code);
+ set_optimize_op(code, OP_SYMBOL);
+ }
+ else
+ {
+ sc->value = code;
+ set_optimize_op(code, OP_CONSTANT);
+ }
+ return(goto_start);
+}
+
+
+/* ---------------- reader funcs for eval ---------------- */
+static void back_up_stack(s7_scheme *sc)
+{
+ opcode_t top_op = stack_top_op(sc);
+ if (top_op == OP_READ_DOT)
+ {
+ pop_stack(sc);
+ top_op = stack_top_op(sc);
+ }
+ if ((top_op == OP_READ_VECTOR) ||
+ (top_op == OP_READ_BYTE_VECTOR) ||
+ (top_op == OP_READ_INT_VECTOR) ||
+ (top_op == OP_READ_FLOAT_VECTOR))
+ {
+ pop_stack(sc);
+ top_op = stack_top_op(sc);
+ }
+ if (top_op == OP_READ_QUOTE)
+ pop_stack(sc);
+}
+
+static token_t read_block_comment(s7_scheme *sc, s7_pointer pt)
+{
+ /* block comments in #| ... |#
+ * since we ignore everything until the |#, internal semicolon comments are ignored,
+ * meaning that ;|# is as effective as |#
+ */
+ const char *str, *orig_str, *p, *pend;
+ if (is_file_port(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)++;
+ }
+ return(token(sc));
+ }
+ orig_str = (const char *)(port_data(pt) + port_position(pt));
+ pend = (const char *)(port_data(pt) + port_data_size(pt));
+ str = orig_str;
+ while (true)
+ {
+ 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)));
+ }
+ if (p[1] == '#')
+ break;
+ str = (const char *)(p + 1);
+ }
+ port_position(pt) += (p - orig_str + 2);
+ /* now count newlines inside the comment */
+ str = (const char *)orig_str;
+ pend = p;
+ while (true)
+ {
+ p = strchr(str, (int)'\n');
+ if ((p) && (p < pend))
+ {
+ port_line_number(pt)++;
+ str = (const char *)(p + 1);
+ }
+ else break;
+ }
+ return(token(sc));
+}
+
+static token_t read_excl_comment(s7_scheme *sc, s7_pointer pt)
+{
+ /* block comments in #! ... !#
+ * this is needed when an input file is treated as a script:
+ #!/home/bil/cl/snd
+ !#
+ (format #t "a test~%")
+ (exit)
+ * but very often the closing !# is omitted which is too bad
+ */
+ int32_t c;
+ char last_char = ' ';
+ /* make it possible to override #! handling */
+ 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 */
+ }
+ /* not #! as block comment (for Guile I guess) */
+ while ((c = inchar(pt)) != EOF)
+ {
+ if ((c == '#') &&
+ (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)));
+ return(token(sc));
+}
+
+static token_t read_sharp(s7_scheme *sc, s7_pointer pt)
+{
+ int32_t c = inchar(pt); /* inchar can return EOF, so it can't be used directly as an index into the digits array */
+ switch (c)
+ {
+ case EOF:
+ error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "unexpected '#' at end of input", 30)));
+ break;
+
+ case '(': /* #(...) */
+ sc->w = int_one;
+ return(TOKEN_VECTOR);
+
+ case 'i': /* #i(...) */
+ if (read_sharp(sc, pt) == TOKEN_VECTOR)
+ return(TOKEN_INT_VECTOR);
+ backchar('i', pt);
+ break;
+
+ case 'r': /* #r(...) */
+ if (read_sharp(sc, pt) == TOKEN_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);
+ }
+ if (read_sharp(sc, pt) == TOKEN_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);
+ }
+ 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.
+ */
+ sc->strbuf[0] = ':';
+ return(TOKEN_ATOM);
+
+ case '!': /* I don't think #! is special anymore -- maybe remove this code? */
+ return(read_excl_comment(sc, pt));
+
+ case '|':
+ return(read_block_comment(sc, pt));
+ }
+ sc->strbuf[0] = (unsigned char)c;
+ return(TOKEN_SHARP_CONST); /* next stage notices any errors */
+}
+
+static token_t read_comma(s7_scheme *sc, s7_pointer pt)
+{
+ /* here we probably should check for symbol names that start with "@":
+ (define-macro (hi @foo) `(+ ,@foo 1)): (hi 2) -> ;foo: unbound variable
+ but (define-macro (hi .foo) `(+ ,.foo 1)): (hi 2) -> 3
+ and ambiguous: (define-macro (hi @foo . foo) `(list ,@foo))
+ what about , @foo -- is the space significant? We accept ,@ foo. (Currently , @ says unbound variable @foo).
+ */
+ int32_t c = inchar(pt);
+ if (c == '@')
+ return(TOKEN_AT_MARK);
+ if (c == EOF)
+ {
+ sc->strbuf[0] = ','; /* was '@' which doesn't make any sense */
+ return(TOKEN_COMMA); /* was TOKEN_ATOM, which also doesn't seem sensible */
+ }
+ backchar(c, pt);
+ return(TOKEN_COMMA);
+}
+
+static token_t read_dot(s7_scheme *sc, s7_pointer pt)
+{
+ int32_t c = inchar(pt);
+ if (c != EOF)
+ {
+ backchar(c, pt);
+ if ((!char_ok_in_a_name[c]) && (c != 0))
+ return(TOKEN_DOT);
+ }
+ else
+ {
+ sc->strbuf[0] = '.';
+ return(TOKEN_DOT);
+ }
+ sc->strbuf[0] = '.';
+ return(TOKEN_ATOM); /* i.e. something that can start with a dot like a number */
+}
+
+static token_t token(s7_scheme *sc) /* inline here is slower */
+{
+ int32_t c = port_read_white_space(current_input_port(sc))(sc, current_input_port(sc));
+ switch (c)
+ {
+ case '(': return(TOKEN_LEFT_PAREN);
+ case ')': return(TOKEN_RIGHT_PAREN);
+ case '.': return(read_dot(sc, current_input_port(sc)));
+ case '\'': return(TOKEN_QUOTE);
+ case ';': return(port_read_semicolon(current_input_port(sc))(sc, current_input_port(sc)));
+ case '"': return(TOKEN_DOUBLE_QUOTE);
+ case '`': return(TOKEN_BACK_QUOTE);
+ case ',': return(read_comma(sc, current_input_port(sc)));
+ case '#': return(read_sharp(sc, current_input_port(sc)));
+ case '\0':
+ case EOF: return(TOKEN_EOF);
+ default:
+ sc->strbuf[0] = (unsigned char)c; /* every TOKEN_ATOM return goes to port_read_name, so we save a backchar/inchar shuffle by starting the read here */
+ return(TOKEN_ATOM);
+ }
+}
+
+static int32_t read_x_char(s7_scheme *sc, int32_t i, s7_pointer pt)
+{
+ /* possible "\xn...;" char (write creates these things, so we have to read them)
+ * but we could have crazy input like "\x -- with no trailing double quote
+ */
+ for (int32_t c_ctr = 0; ; c_ctr++)
+ {
+ 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 == ';')
+ {
+ 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);
+ }
+ 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);
+ }
+ /* 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);
+ }
+ if (c == ';') /* "\x4;" */
+ {
+ 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);
+ }
+ 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);
+ }
+ sc->strbuf[i++] = (unsigned char)(16 * d1 + d2);
+ }
+ return(i);
+}
+
+static s7_pointer unknown_string_constant(s7_scheme *sc, int32_t c)
+{
+ /* check *read-error-hook* */
+ if (hook_has_functions(sc->read_error_hook))
+ {
+ 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(sc->T);
+}
+
+static s7_pointer read_string_constant(s7_scheme *sc, s7_pointer pt)
+{
+ /* sc->F => error, no check needed here for bad input port and so on */
+ s7_int i = 0;
+
+ if (is_string_port(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);
+ }
+ 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 (*s == '"')
+ {
+ 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)++;
+ }}
+
+ 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;
+ 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);
+ 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);
+ }
+}
+
+static void read_double_quote(s7_scheme *sc)
+{
+ sc->value = read_string_constant(sc, current_input_port(sc));
+ if (sc->value == sc->F) /* can happen if input code ends in the middle of a string */
+ string_read_error_nr(sc, "end of input encountered while in a string");
+ if (sc->value == sc->T)
+ read_error_nr(sc, "unknown backslash usage -- perhaps you meant two backslashes?");
+ if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value);
+}
+
+static /* inline */ bool read_sharp_const(s7_scheme *sc) /* tread but inline makes no difference? (it's currently inlined anyway) */
+{
+ sc->value = port_read_sharp(current_input_port(sc))(sc, current_input_port(sc));
+ if (sc->value == sc->no_value)
+ {
+ /* (set! *#readers* (cons (cons #\; (lambda (s) (read) (values))) *#readers*))
+ * (+ 1 #;(* 2 3) 4)
+ * so we need to get the next token, act on it without any assumptions about read list
+ */
+ sc->tok = token(sc);
+ return(true);
+ }
+ return(false);
+}
+
+static noreturn void read_expression_read_error_nr(s7_scheme *sc)
+{
+ s7_pointer pt = current_input_port(sc);
+ pop_stack(sc);
+ if ((is_input_port(pt)) &&
+ (!port_is_closed(pt)) &&
+ (port_data(pt)) &&
+ (port_position(pt) > 0))
+ {
+ s7_pointer p = make_empty_string(sc, 128, '\0');
+ char *msg = string_value(p);
+ s7_int pos = port_position(pt);
+ s7_int start = pos - 40;
+ if (start < 0) start = 0;
+ memcpy((void *)msg, (const void *)"at \"...", 7);
+ memcpy((void *)(msg + 7), (void *)(port_data(pt) + start), pos - start);
+ memcpy((void *)(msg + 7 + pos - start), (const void *)"...", 3);
+ string_length(p) = 7 + pos - start + 3;
+ error_nr(sc, sc->read_error_symbol, set_elist_1(sc, p));
+ }
+ read_error_nr(sc, "stray comma before ')'?"); /* '("a" "b",) */
+}
+
+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 . ) */
+ }}
+ /* we never get here */
+ return(sc->nil);
+}
+
+static void read_dot_and_expression(s7_scheme *sc)
+{
+ push_stack_no_let_no_code(sc, OP_READ_DOT, sc->args);
+ sc->tok = token(sc);
+ sc->value = read_expression(sc);
+}
+
+static void read_tok_default(s7_scheme *sc)
+{
+ /* by far the main case here is TOKEN_LEFT_PAREN, but it doesn't save anything to move it to this level */
+ push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args);
+ sc->value = read_expression(sc);
+ /* check for op_read_list here and explicit pop_stack are slower */
+}
+
+static int32_t read_atom(s7_scheme *sc, s7_pointer pt)
+{
+ push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args);
+ /* check_stack_size(sc); */
+ sc->value = port_read_name(pt)(sc, pt);
+ sc->args = list_1(sc, sc->value);
+ pair_set_current_input_location(sc, sc->args);
+ return(port_read_white_space(pt)(sc, pt));
+}
+
+static /* inline */ int32_t read_start_list(s7_scheme *sc, s7_pointer pt, int32_t c)
+{
+ sc->strbuf[0] = (unsigned char)c;
+ push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args);
+ check_stack_size(sc); /* s7test */
+ sc->value = port_read_name(pt)(sc, pt);
+ sc->args = list_1(sc, sc->value);
+ pair_set_current_input_location(sc, sc->args);
+ return(port_read_white_space(pt)(sc, pt));
+}
+
+static void op_read_internal(s7_scheme *sc)
+{
+ /* if we're loading a file, and in the file we evaluate (at top-level) something like:
+ * (set-current-input-port (open-input-file "tmp2.r5rs"))
+ * (close-input-port (current-input-port))
+ * ... (with no reset of input port to its original value)
+ * the load process tries to read the loaded string, but the current-input-port is now closed,
+ * and the original is inaccessible! So we get a segfault in token. We don't want to put
+ * a port_is_closed check there because token only rarely is in this danger. I think this
+ * is the only place where we can be about to call token, and someone has screwed up our port.
+ */
+ 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)));
+
+ sc->tok = token(sc);
+ switch (sc->tok)
+ {
+ case TOKEN_EOF: break;
+ 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));
+ break;
+ }
+}
+
+static void op_read_done(s7_scheme *sc)
+{
+ pop_input_port(sc);
+ if (sc->tok == TOKEN_EOF)
+ sc->value = eof_object;
+ sc->current_file = NULL; /* this is for error handling */
+}
+
+static void op_read_s(s7_scheme *sc)
+{
+ s7_pointer port = lookup(sc, cadr(sc->code));
+ if (!is_input_port(port)) /* was also not stdin */
+ {
+ sc->value = g_read(sc, set_plist_1(sc, port));
+ return;
+ }
+ if (port_is_closed(port)) /* I guess the port_is_closed check is needed because we're going down a level below */
+ sole_arg_wrong_type_error_nr(sc, sc->read_symbol, port, an_open_input_port_string);
+
+ if (is_function_port(port))
+ {
+ 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));
+ }}
+ 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));
+ }}
+}
+
+static bool op_read_quasiquote(s7_scheme *sc)
+{
+ /* this was pushed when the backquote was seen, then eventually we popped back to it */
+ sc->value = g_quasiquote_1(sc, sc->value, false);
+ /* doing quasiquote at read time means there are minor inconsistencies in various combinations or quote/' and quasiquote/`.
+ * A quoted ` will expand but quoted quasiquote will not (` can't be redefined, but quasiquote can). see s7test.scm for examples.
+ */
+ return(stack_top_op(sc) != OP_READ_LIST);
+}
+
+static bool pop_read_list(s7_scheme *sc)
+{
+ /* push-stack OP_READ_LIST is always no_code and op is always OP_READ_LIST (and not used), sc->curlet is apparently not needed here */
+ unstack_with(sc, OP_READ_LIST);
+ sc->args = stack_end_args(sc);
+ if (!is_null(sc->args)) return(false); /* fall into read_list where sc->args is placed at end of on-going list, sc->value */
+ sc->args = list_1(sc, sc->value);
+ pair_set_current_input_location(sc, sc->args); /* uses port_location */
+ return(true);
+}
+
+static bool op_load_return_if_eof(s7_scheme *sc)
+{
+ if (SHOW_EVAL_OPS) fprintf(stderr, " op_load_return_if_eof: value: %s\n", display_truncated(sc->value));
+ if (sc->tok != TOKEN_EOF)
+ {
+ push_stack_op_let(sc, OP_LOAD_RETURN_IF_EOF);
+ push_stack_op_let(sc, OP_READ_INTERNAL);
+ sc->code = sc->value;
+ return(true); /* we read an expression, now evaluate it, and return to read the next */
+ }
+ sc->current_file = NULL;
+ return(false);
+}
+
+static bool op_load_close_and_pop_if_eof(s7_scheme *sc)
+{
+ /* (load "file") in scheme: read and evaluate all exprs, then upon EOF, close current and pop input port stack */
+ if (sc->tok != TOKEN_EOF)
+ {
+ 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);
+ else sc->tok = TOKEN_EOF;
+ sc->code = sc->value;
+ return(true); /* we read an expression, now evaluate it, and return to read the next */
+ }
+ if ((S7_DEBUGGING) && (!is_loader_port(current_input_port(sc)))) fprintf(stderr, "%s not loading?\n", display(current_input_port(sc)));
+ /* if *#readers* func hits error, clear_loader_port might not be undone? */
+ s7_close_input_port(sc, current_input_port(sc));
+ pop_input_port(sc);
+ sc->current_file = NULL;
+ if (is_multiple_value(sc->value)) /* (load (file)) where file returns (values "a-file" an-environment)? */
+ sc->value = splice_in_values(sc, multiple_value(sc->value));
+ return(false);
+}
+
+static bool op_read_apply_values(s7_scheme *sc)
+{
+ sc->value = list_2_unchecked(sc, sc->unquote_symbol, list_2(sc, initial_value(sc->apply_values_symbol), sc->value));
+ return(stack_top_op(sc) != OP_READ_LIST);
+}
+
+static goto_t op_read_dot(s7_scheme *sc)
+{
+ token_t c = token(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);
+ }
+ back_up_stack(sc);
+ read_error_nr(sc, "stray dot?"); /* (+ 1 . 2 3) or (list . ) */
+ }
+ /* args = previously read stuff, value = thing just after the dot and before the ')':
+ * (list 1 2 . 3) -> value: 3, args: (2 1 list), '(1 . 2) -> value: 2, args: (1)
+ * but we also get here in a lambda arg list: (lambda (a b . c) #f) -> value: c, args: (b a)
+ */
+ sc->value = any_list_reverse_in_place(sc, sc->value, sc->args);
+ return((stack_top_op(sc) == OP_READ_LIST) ? goto_pop_read_list : goto_start);
+}
+
+static bool op_read_quote(s7_scheme *sc) /* '<datum> -> (#_quote <datum) in s7, not (quote <datum>) because quote is not immutable */
+{
+ /* can't check for sc->value = sc->nil here because we want ''() to be different from '() */
+ if ((sc->safety > IMMUTABLE_VECTOR_SAFETY) &&
+ ((is_pair(sc->value)) || (is_any_vector(sc->value)) || (is_string(sc->value))))
+ set_immutable(sc->value);
+ sc->value = list_2(sc, sc->quote_function, sc->value);
+ return(stack_top_op(sc) != OP_READ_LIST);
+}
+
+static bool op_read_unquote(s7_scheme *sc)
+{
+ /* here if sc->value is a constant, the unquote is pointless (should we complain?)
+ * also currently stray "," can be ignored: (abs , 1) -- scanning the stack for quasiquote or quote seems to be unreliable
+ */
+ if ((is_pair(sc->value)) ||
+ (is_symbol(sc->value)))
+ sc->value = list_2(sc, sc->unquote_symbol, sc->value);
+ return(stack_top_op(sc) != OP_READ_LIST);
+}
+
+/* safety check is at read time, so (immutable? (let-temporarily (((*s7* 'safety) 2)) #(1 2 3))) is #f
+ * but (immutable? (let-temporarily (((*s7* 'safety) 2)) (eval-string "#(1 2 3)"))) is #t
+ */
+static bool op_read_vector(s7_scheme *sc)
+{
+ sc->value = (sc->args == int_one) ? g_vector(sc, sc->value) : g_multivector(sc, integer(sc->args), sc->value); /* sc->args was sc->w earlier from read_sharp */
+ /* here and below all of the sc->value list can be freed, but my tests showed no speed up even in large cases */
+ if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value);
+ return(stack_top_op(sc) != OP_READ_LIST);
+}
+
+static bool op_read_int_vector(s7_scheme *sc)
+{
+ sc->value = (sc->args == int_one) ? g_int_vector(sc, sc->value) : g_int_multivector(sc, integer(sc->args), sc->value);
+ if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value);
+ return(stack_top_op(sc) != OP_READ_LIST);
+}
+
+static bool op_read_float_vector(s7_scheme *sc)
+{
+ /* sc->value is the list of values, #r(...sc->value...) */
+ sc->value = (sc->args == int_one) ? g_float_vector(sc, sc->value) : g_float_multivector(sc, integer(sc->args), sc->value);
+ if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value);
+ return(stack_top_op(sc) != OP_READ_LIST);
+
+ /* to avoid making the list: sc->floats array (growable and maybe pruned),
+ * token_float_vector in read_expression: sc->value = unused, push op_read_float_vector
+ * sc->args = dims (read_sharp sc->w = dims, read_expression push_op moves it to sc->args
+ * <read each entry...>: push op_read_float_vector (no op_read_list), read, eval,
+ * fill sc->floats, when right-paren make new vector [for multidims, get list->frame]
+ */
+}
+
+static bool op_read_byte_vector(s7_scheme *sc)
+{
+ sc->value = (sc->args == int_one) ? g_byte_vector(sc, sc->value) : g_byte_multivector(sc, integer(sc->args), sc->value);
+ if (sc->safety > IMMUTABLE_VECTOR_SAFETY) set_immutable(sc->value);
+ return(stack_top_op(sc) != OP_READ_LIST);
+}
+
+
+/* ---------------- unknown ops ---------------- */
+static bool fixup_unknown_op(s7_scheme *sc, s7_pointer code, s7_pointer func, opcode_t op)
+{
+ set_optimize_op(code, op);
+ if (is_any_closure(func))
+ set_opt1_lambda_add(code, func); /* perhaps set_opt1_lambda_add here and throughout op_unknown* */
+ return(true);
+}
+
+static bool unknown_unknown(s7_scheme *sc, s7_pointer code, opcode_t op)
+{
+ if ((is_symbol(car(code))) &&
+ (!is_slot(s7_slot(sc, car(code)))))
+ unbound_variable_error_nr(sc, car(code));
+ set_optimize_op(code, op);
+ return(true);
+}
+
+static bool is_immutable_and_stable(s7_scheme *sc, s7_pointer func)
+{
+ if (symbol_ctr(func) != 1) /* protect against (define-constant (p) (define-constant (p) ...)) */
+ return(false);
+ if ((is_global(func)) && (is_immutable_slot(global_slot(func))))
+ return(true);
+ for (s7_pointer p = sc->curlet; p; p = let_outlet(p))
+ if ((is_funclet(p)) && (funclet_function(p) != func))
+ return(false);
+ return(is_immutable_slot(s7_slot(sc, func)));
+}
+
+static bool op_unknown(s7_scheme *sc)
+{
+ s7_pointer code = sc->code, f = sc->last_function;
+ if (!f) /* can be NULL if unbound variable */
+ unbound_variable_error_nr(sc, car(sc->code));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s %s\n", __func__, display_truncated(f), s7_type_names[type(f)]);
+
+ switch (type(f))
+ {
+ 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);
+ }}
+ break;
+
+ case T_GOTO: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_GOTO));
+ case T_ITERATOR: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_ITERATE));
+ case T_BACRO: case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f)));
+ case T_BACRO_STAR: case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f)));
+
+ default:
+ if ((is_symbol(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));
+}
+
+static bool fxify_closure_star_g(s7_scheme *sc, s7_pointer f, s7_pointer code)
+{
+ if ((!has_methods(f)) &&
+ (closure_star_arity_to_int(sc, f) != 0))
+ {
+ int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0;
+ bool safe_case = is_safe_closure(f);
+ 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);
+ 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);
+ }
+ fixup_unknown_op(sc, code, f, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA));
+ return(true);
+ }
+ return(false);
+}
+
+static bool op_unknown_closure_s(s7_scheme *sc, s7_pointer f, s7_pointer code)
+{
+ s7_pointer body = closure_body(f);
+ bool one_form = is_null(cdr(body));
+ int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0;
+ set_opt2_sym(code, cadr(code));
+
+ /* code here might be (f x) where f is passed elsewhere as a function parameter,
+ * first time through we look it up, find a safe-closure and optimize as (say) safe_closure_s_a,
+ * next time it is something else, etc. Rather than keep optimizing it locally, we need to
+ * back out: safe_closure_s_* -> safe_closure_s -> closure_s -> op_s_g. Ideally we'd know
+ * this was a parameter or whatever. The tricky case is local letrec(f) calling f which initially
+ * thinks it is not safe, then later is set safe correctly, now outer func is called again,
+ * this time f is safe, and we're ok from then on.
+ */
+ 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;
+ }
+ set_opt1_lambda_add(code, f);
+ return(true);
+ }
+ if (!is_safe_closure(f))
+ set_optimize_op(code, hop + ((one_form) ? OP_CLOSURE_S_O : OP_CLOSURE_S));
+ else
+ if (!is_null(cdr(body)))
+ 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);
+ 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
+ */
+ set_is_unknopt(code);
+ set_opt1_lambda_add(code, f);
+ return(true);
+}
+
+static bool op_unknown_s(s7_scheme *sc)
+{
+ s7_pointer code = sc->code, f = sc->last_function;
+
+ if (!f) unbound_variable_error_nr(sc, car(sc->code));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(f));
+
+ if ((S7_DEBUGGING) && (!is_normal_symbol(cadr(code)))) fprintf(stderr, "%s[%d]: not a symbol: %s\n", __func__, __LINE__, display(code));
+ if ((!is_any_macro(f)) && /* if f is a macro, its argument can be unbound legitimately */
+ (!is_slot(s7_slot(sc, cadr(code)))))
+ return(unknown_unknown(sc, sc->code, (is_normal_symbol(cadr(sc->code))) ? OP_CLEAR_OPTS : OP_S_G));
+
+ if ((is_unknopt(code)) && (!is_closure(f)))
+ return(fixup_unknown_op(sc, code, f, OP_S_G));
+
+ switch (type(f))
+ {
+ case T_C_FUNCTION:
+ if (!(c_function_is_aritable(f, 1))) break;
+ 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);
+ }
+ else
+ {
+ 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));
+ break;
+
+ case T_CLOSURE_STAR:
+ if (fxify_closure_star_g(sc, f, code)) return(true);
+ break;
+
+ case T_GOTO:
+ fx_annotate_arg(sc, cdr(code), sc->curlet);
+ set_opt3_arglen(cdr(code), 1);
+ return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_GOTO_A));
+
+ case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR:
+ fx_annotate_arg(sc, cdr(code), sc->curlet);
+ return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_VECTOR_REF_A));
+
+ case T_STRING:
+ fx_annotate_arg(sc, cdr(code), sc->curlet);
+ return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_STRING_REF_A));
+
+ case T_PAIR:
+ fx_annotate_arg(sc, cdr(code), sc->curlet);
+ return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_PAIR_REF_A));
+
+ 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));
+ }
+ break;
+
+ case T_LET:
+ fx_annotate_arg(sc, cdr(code), sc->curlet);
+ return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_LET_REF_A));
+
+ case T_HASH_TABLE:
+ fx_annotate_arg(sc, cdr(code), sc->curlet);
+ return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_HASH_TABLE_REF_A));
+
+ case T_CONTINUATION:
+ fx_annotate_arg(sc, cdr(code), sc->curlet);
+ return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_CONTINUATION_A));
+
+ case T_BACRO: case T_MACRO:
+ return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f)));
+ case T_BACRO_STAR: case T_MACRO_STAR:
+ return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f)));
+
+ default: break;
+ }
+ if ((is_symbol(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_G));
+}
+
+static bool op_unknown_a(s7_scheme *sc)
+{
+ s7_pointer code = sc->code, f = sc->last_function;
+ if (!f) unbound_variable_error_nr(sc, car(sc->code));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(f));
+
+ switch (type(f))
+ {
+ case T_C_FUNCTION:
+ if (!(c_function_is_aritable(f, 1))) break;
+ case T_C_RST_NO_REQ_FUNCTION:
+ 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);
+ }
+ else
+ {
+ 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);
+ }
+ break;
+
+ case T_CLOSURE_STAR:
+ if (fxify_closure_star_g(sc, f, code)) return(true);
+ break;
+
+ case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR:
+ return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_VECTOR_REF_A));
+
+ case T_STRING: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_STRING_REF_A));
+ case T_PAIR: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_PAIR_REF_A));
+ case T_C_OBJECT: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_C_OBJECT_REF_A));
+ case T_HASH_TABLE: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_HASH_TABLE_REF_A));
+ case T_GOTO: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_GOTO_A));
+ case T_CONTINUATION: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_CONTINUATION_A));
+ case T_BACRO: case T_MACRO:
+ return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f)));
+ case T_BACRO_STAR: case T_MACRO_STAR:
+ return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f)));
+
+ 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 */
+ }
+
+ default: break;
+ }
+ if ((is_symbol(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_A)); /* closure with methods etc */
+}
+
+static bool op_unknown_gg(s7_scheme *sc)
+{
+ bool s1, s2;
+ s7_pointer code = sc->code, f = sc->last_function;
+ if (!f) unbound_variable_error_nr(sc, car(sc->code));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(f));
+
+ s1 = is_normal_symbol(cadr(code));
+ s2 = is_normal_symbol(caddr(code));
+
+ if ((s1) &&
+ (!is_slot(s7_slot(sc, cadr(code)))))
+ return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS));
+ if ((s2) &&
+ (!is_slot(s7_slot(sc, caddr(code)))))
+ return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS));
+
+ switch (type(f))
+ {
+ case T_C_FUNCTION:
+ 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));
+ }}}
+ else
+ {
+ 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);
+
+ 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);
+ }
+ 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);
+ }
+ 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, (is_pair(f)) ? OP_IMPLICIT_PAIR_REF_AA : OP_IMPLICIT_VECTOR_REF_AA));
+
+ case T_HASH_TABLE:
+ fx_annotate_args(sc, cdr(code), sc->curlet);
+ return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_HASH_TABLE_REF_AA));
+
+ case T_BACRO: case T_MACRO:
+ return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f)));
+ case T_BACRO_STAR: case T_MACRO_STAR:
+ return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f)));
+
+ default: break;
+ }
+ if ((is_symbol(car(code))) &&
+ (!is_slot(s7_slot(sc, car(code)))))
+ unbound_variable_error_nr(sc, car(code));
+ fx_annotate_args(sc, cdr(code), sc->curlet);
+ return(fixup_unknown_op(sc, code, f, OP_S_AA));
+}
+
+static bool op_unknown_ns(s7_scheme *sc)
+{
+ s7_pointer code = sc->code, f = sc->last_function;
+ int32_t num_args = opt3_arglen(cdr(code));
+
+ if (!f) unbound_variable_error_nr(sc, car(sc->code));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(f));
+
+ for (s7_pointer arg = cdr(code); is_pair(arg); arg = cdr(arg))
+ if (!is_slot(s7_slot(sc, car(arg))))
+ unbound_variable_error_nr(sc, car(arg));
+
+ switch (type(f))
+ {
+ case T_C_FUNCTION:
+ 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);
+ }
+ else
+ {
+ 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))));
+ }
+ 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)));
+ }
+ break;
+
+ case T_BACRO: case T_MACRO:
+ return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f)));
+ case T_BACRO_STAR: case T_MACRO_STAR:
+ return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f)));
+
+ /* PERHAPS: vector, but need op_implicit_vector_ns? */
+ default: break;
+ }
+ return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS));
+}
+
+static bool op_unknown_aa(s7_scheme *sc)
+{
+ s7_pointer code = sc->code, f = sc->last_function;
+
+ if (!f) unbound_variable_error_nr(sc, car(sc->code));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(f));
+
+ switch (type(f))
+ {
+ case T_C_FUNCTION:
+ 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));
+ }}
+ 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);
+ }
+ 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);
+ }
+ 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_IMPLICIT_VECTOR_REF_AA));
+
+ case T_PAIR: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_PAIR_REF_AA));
+ case T_HASH_TABLE: return(fixup_unknown_op(sc, code, f, OP_IMPLICIT_HASH_TABLE_REF_AA));
+ case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f)));
+ case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f)));
+
+ default: break;
+ }
+ if ((is_symbol(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_AA));
+}
+
+static bool is_normal_happy_symbol(s7_scheme *sc, s7_pointer sym)
+{
+ if (!is_normal_symbol(sym))
+ return(false);
+ if (!is_slot(s7_slot(sc, sym)))
+ unbound_variable_error_nr(sc, sym);
+ return(true);
+}
+
+static bool op_unknown_na(s7_scheme *sc)
+{
+ s7_pointer code = sc->code, f = sc->last_function;
+ int32_t num_args = (is_pair(cdr(code))) ? opt3_arglen(cdr(code)) : 0;
+
+ if (!f) unbound_variable_error_nr(sc, car(sc->code));
+ if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %s\n", __func__, __LINE__, display_truncated(f), display_truncated(sc->code));
+ if (num_args == 0) return(fixup_unknown_op(sc, code, f, OP_S)); /* via op_closure*-fx where original had 0 args, safe case -> op_safe_closure*_0 */
+
+ switch (type(f))
+ {
+ case T_C_FUNCTION:
+ 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);
+ }
+ 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);
+ 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;
+ 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);
+ }
+ 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));
+ }
+ break;
+
+ case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f)));
+ case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f)));
+ /* implicit vector doesn't happen */
+
+ default: break;
+ }
+ /* closure happens if wrong-number-of-args passed -- probably no need for op_s_na */
+ /* PERHAPS: vector */
+ return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS));
+}
+
+static bool op_unknown_np(s7_scheme *sc)
+{
+ s7_pointer code = sc->code, f = sc->last_function;
+ int32_t num_args = (is_pair(cdr(code))) ? opt3_arglen(cdr(code)) : 0;
+
+ 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));
+
+ switch (type(f))
+ {
+ case T_C_FUNCTION:
+ 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);
+ 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);
+ 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);
+ }
+ break;
+
+ case T_MACRO: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_D, f)));
+ case T_MACRO_STAR: return(fixup_unknown_op(sc, code, f, fixup_macro_d(sc, OP_MACRO_STAR_D, f)));
+ }
+ return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS));
+}
+
+static bool unknown_any(s7_scheme *sc, s7_pointer f, s7_pointer code)
+{
+ sc->last_function = f;
+ if (is_null(cdr(code))) return(op_unknown(sc));
+ if ((is_null(cddr(code))) && (is_normal_symbol(cadr(code)))) return(op_unknown_s(sc));
+ set_opt3_arglen(cdr(code), proper_list_length(cdr(code)));
+ return(op_unknown_np(sc));
+}
+
+
+/* ---------------- eval type checkers ---------------- */
+#if WITH_GCC
+#define h_c_function_is_ok(Sc, P) ({s7_pointer _P_; _P_ = P; ((op_has_hop(_P_)) || (c_function_is_ok(Sc, _P_)));})
+#else
+#define h_c_function_is_ok(Sc, P) ((op_has_hop(P)) || (c_function_is_ok(Sc, P)))
+#endif
+
+#define c_function_is_ok_cadr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, cadr(P))))
+#define c_function_is_ok_caddr(Sc, P) ((c_function_is_ok(Sc, P)) && (h_c_function_is_ok(Sc, caddr(P))))
+
+static bool c_function_is_ok_cadr_caddr(s7_scheme *sc, s7_pointer p)
+{
+ return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, caddr(p))));
+}
+
+static bool c_function_is_ok_cadr_cadadr(s7_scheme *sc, s7_pointer p)
+{
+ return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, opt3_pair(p)))); /* cadadr(P) */
+}
+
+static bool c_function_is_ok_cadr_caddadr(s7_scheme *sc, s7_pointer p)
+{
+ return((c_function_is_ok(sc, p)) && (h_c_function_is_ok(sc, cadr(p))) && (h_c_function_is_ok(sc, opt3_pair(p)))); /* caddadr(p) */
+}
+
+/* closure_is_ok_1 checks the type and the body length indications
+ * closure_is_fine_1 just checks the type (safe or unsafe closure)
+ * closure_is_ok calls _ok_1, closure_is_fine calls _fine_1
+ * closure_np_is_ok accepts safe/unsafe etc
+ */
+
+static /* inline */ bool closure_is_ok_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args)
+{
+ s7_pointer f = lookup_unexamined(sc, car(code));
+ if ((f == opt1_lambda_unchecked(code)) ||
+ ((f) && /* this fixup check does save time (e.g. cb) */
+ (low_type_bits(f) == type) &&
+ ((closure_arity(f) == args) || (closure_arity_to_int(sc, f) == args)) && /* 3 type bits to replace this but not hit enough to warrant them */
+ (set_opt1_lambda(code, f))))
+ return(true);
+ sc->last_function = f;
+ return(false);
+}
+
+static /* inline */ bool closure_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args)
+{
+ s7_pointer f = lookup_unexamined(sc, car(code));
+ if ((f == opt1_lambda_unchecked(code)) ||
+ ((f) &&
+ ((low_type_bits(f) & (TYPE_MASK | T_SAFE_CLOSURE)) == type) &&
+ ((closure_arity(f) == args) || (closure_arity_to_int(sc, f) == args)) &&
+ (set_opt1_lambda(code, f))))
+ return(true);
+ sc->last_function = f;
+ return(false);
+}
+
+static bool closure_np_is_ok_1(s7_scheme *sc, s7_pointer code)
+{
+ s7_pointer f = lookup_unexamined(sc, car(code));
+ if ((f == opt1_lambda_unchecked(code)) ||
+ ((f) &&
+ (is_closure(f)) &&
+ (set_opt1_lambda(code, f))))
+ return(true);
+ sc->last_function = f;
+ return(false);
+}
+
+#define closure_is_ok(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_is_ok_1(Sc, Code, Type, Args)))
+#define closure_np_is_ok(Sc, Code) ((symbol_ctr(car(Code)) == 1) || (closure_np_is_ok_1(Sc, Code)))
+#define closure_is_fine(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_is_fine_1(Sc, Code, Type, Args)))
+#define closure_star_is_fine(Sc, Code, Type, Args) ((symbol_ctr(car(Code)) == 1) || (closure_star_is_fine_1(Sc, Code, Type, Args)))
+
+static /* inline */ bool closure_is_eq(s7_scheme *sc)
+{
+ sc->last_function = lookup_unexamined(sc, car(sc->code));
+ return(sc->last_function == opt1_lambda_unchecked(sc->code));
+}
+
+static bool star_arity_is_ok(s7_scheme *sc, s7_pointer val, int32_t args)
+{
+ int32_t arity = closure_star_arity_to_int(sc, val);
+ return((arity < 0) || ((arity * 2) >= args));
+}
+
+static bool closure_star_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args)
+{
+ s7_pointer val = lookup_unexamined(sc, car(code));
+ if ((val == opt1_lambda_unchecked(code)) ||
+ ((val) &&
+ ((low_type_bits(val) & (T_SAFE_CLOSURE | TYPE_MASK)) == type) &&
+ (star_arity_is_ok(sc, val, args)) &&
+ (set_opt1_lambda(code, val))))
+ return(true);
+ sc->last_function = val;
+ return(false);
+}
+
+/* closure_is_fine: */
+#define FINE_UNSAFE_CLOSURE (T_CLOSURE)
+#define FINE_SAFE_CLOSURE (T_CLOSURE | T_SAFE_CLOSURE)
+
+/* closure_star_is_fine: */
+#define FINE_UNSAFE_CLOSURE_STAR (T_CLOSURE_STAR)
+#define FINE_SAFE_CLOSURE_STAR (T_CLOSURE_STAR | T_SAFE_CLOSURE)
+
+/* closure_is_ok: */
+#define OK_UNSAFE_CLOSURE_P (T_CLOSURE | T_ONE_FORM)
+#define OK_SAFE_CLOSURE_P (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM)
+#define OK_UNSAFE_CLOSURE_M (T_CLOSURE | T_MULTIFORM)
+#define OK_SAFE_CLOSURE_M (T_CLOSURE | T_SAFE_CLOSURE | T_MULTIFORM)
+#define OK_SAFE_CLOSURE_A (T_CLOSURE | T_SAFE_CLOSURE | T_ONE_FORM_FX_ARG)
+/* since T_HAS_METHODS is on if there might be methods, this can protect us from that case */
+
+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)));
+}
+
+
+/* ---------------- eval ---------------- */
+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)));
+ sc->cur_op = first_op;
+ goto TOP_NO_POP;
+
+ while (true) /* "continue" in this procedure refers to this loop */
+ {
+ pop_stack(sc);
+ goto TOP_NO_POP;
+
+ BEGIN:
+ if (is_pair(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:
+ sc->cur_op = optimize_op(sc->code); /* sc->code can be anything, optimize_op examines a type field (opt_bits) */
+
+ TOP_NO_POP:
+ if (SHOW_EVAL_OPS) safe_print(fprintf(stderr, " %s (%d), code: %s\n", op_names[sc->cur_op], (int)(sc->cur_op), display_truncated(sc->code)));
+
+ /* it is only slightly faster to use labels as values (computed gotos) here. In my timing tests (June-2018), the best case speedup was in titer.scm
+ * callgrind numbers 4808 to 4669; another good case was tread.scm: 2410 to 2386. Most timings were a draw. computed-gotos-s7.c has the code,
+ * macroized so it will work if such gotos aren't available. I think I'll stick with a switch statement.
+ * Another idea is to put the function in the tree, not an index to it (the optimize_op business above),
+ * then the switch below is not needed, and we free up 16 type bits. C does not guarantee tail calls (I think)
+ * so we'd have each function return the next, and eval would be [while (true) f = f(sc)] but would the function
+ * call overhead be less expensive than the switch? (We get most functions inlined in the current code).
+ * with some fake fx_calls for the P cases, many of these could be [sc->value = fx_function[sc->cur_op](sc, sc->code); continue;]
+ * 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 */
+
+ 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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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;
+
+
+ /* 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_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_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_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;
+
+ 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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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_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;
+
+#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))))) && \
+ (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))))) || \
+ (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_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_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;
+#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;
+#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);
+ }
+
+ /* 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);
+ 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;
+ }}
+ return(sc->F); /* this never happens (make the compiler happy) */
+}
+
+
+/* -------------------------------- s7_heap_scan -------------------------------- */
+#if S7_DEBUGGING
+static void mark_holdee(s7_pointer holder, s7_pointer holdee, const char *root)
+{
+ holdee->holders++;
+ if (holder) holdee->holder = holder;
+ if (root) holdee->root = root;
+}
+
+static void mark_stack_holdees(s7_scheme *sc, s7_pointer p, s7_int top)
+{
+ if (stack_elements(p))
+ {
+ 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);
+ }}
+}
+
+static void save_holder_data(s7_scheme *sc, s7_pointer p)
+{
+ switch (unchecked_type(p))
+ {
+ case T_PAIR: mark_holdee(p, car(p), NULL); mark_holdee(p, cdr(p), NULL); break;
+ case T_CATCH: mark_holdee(p, catch_tag(p), NULL); mark_holdee(p, catch_handler(p), NULL); break;
+ case T_DYNAMIC_WIND: mark_holdee(p, dynamic_wind_in(p), NULL); mark_holdee(p, dynamic_wind_out(p), NULL); mark_holdee(p, dynamic_wind_body(p), NULL); break;
+ case T_INPUT_PORT: mark_holdee(p, port_string_or_function(p), NULL); break;
+ case T_C_POINTER: mark_holdee(p, c_pointer_type(p), NULL); mark_holdee(p, c_pointer_info(p), NULL); break;
+ case T_COUNTER: mark_holdee(p, counter_result(p), NULL); mark_holdee(p, counter_list(p), NULL); mark_holdee(p, counter_let(p), NULL); break;
+ case T_STACK: mark_stack_holdees(sc, p, (p == sc->stack) ? stack_top(sc) : temp_stack_top(p)); break;
+ case T_OUTPUT_PORT: if (is_function_port(p)) mark_holdee(p, port_string_or_function(p), NULL); break;
+
+ case T_ITERATOR:
+ mark_holdee(p, iterator_sequence(p), NULL);
+ if (is_mark_seq(p)) mark_holdee(p, iterator_current(p), NULL);
+ break;
+
+ case T_SLOT:
+ mark_holdee(p, slot_value(p), NULL);
+ mark_holdee(p, slot_symbol(p), NULL);
+ if (slot_has_setter(p)) mark_holdee(p, slot_setter(p), NULL);
+ if (slot_has_pending_value(p)) mark_holdee(p, slot_pending_value(p), NULL);
+ break;
+
+ 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);
+ break;
+
+ case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR:
+ if (is_subvector(p)) mark_holdee(p, subvector_vector(p), NULL);
+ break;
+
+ 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);
+ }
+ 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);
+ break;
+
+ case T_CLOSURE: case T_CLOSURE_STAR:
+ case T_MACRO: case T_MACRO_STAR:
+ case T_BACRO: case T_BACRO_STAR:
+ mark_holdee(p, closure_args(p), NULL);
+ mark_holdee(p, closure_body(p), NULL);
+ mark_holdee(p, closure_let(p), NULL);
+ mark_holdee(p, closure_setter_or_map_list(p), NULL);
+ break;
+
+ 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);
+ }
+ 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);
+ }}
+ break;
+
+ case T_CONTINUATION:
+ mark_holdee(p, continuation_op_stack(p), NULL);
+ mark_stack_holdees(sc, continuation_stack(p), continuation_stack_top(p));
+ break;
+
+ default: break; /* includes T_C_OBJECT */
+ }
+}
+
+void s7_heap_analyze(s7_scheme *sc);
+void s7_heap_analyze(s7_scheme *sc)
+{
+ /* clear possible previous data */
+ for (s7_int k = 0; k < sc->heap_size; k++)
+ {
+ s7_pointer obj = sc->heap[k];
+ obj->root = NULL;
+ obj->holders = 0;
+ obj->holder = NULL;
+ }
+ /* now parcel out all the holdings */
+ for (s7_int k = 0; k < sc->heap_size; k++)
+ save_holder_data(sc, sc->heap[k]);
+
+ {
+ s7_pointer *tmps = sc->free_heap_top;
+ s7_pointer *tmps_top = tmps + sc->gc_temps_size;
+ 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");
+ }}
+
+ mark_holdee(NULL, sc->w, "sc->w");
+ mark_holdee(NULL, sc->x, "sc->x");
+ mark_holdee(NULL, sc->y, "sc->y");
+ mark_holdee(NULL, sc->z, "sc->z");
+ mark_holdee(NULL, sc->temp1, "sc->temp1");
+ mark_holdee(NULL, sc->temp2, "sc->temp2");
+ mark_holdee(NULL, sc->temp3, "sc->temp3");
+ mark_holdee(NULL, sc->temp4, "sc->temp4");
+ mark_holdee(NULL, sc->temp5, "sc->temp5");
+ mark_holdee(NULL, sc->temp6, "sc->temp6");
+ mark_holdee(NULL, sc->temp7, "sc->temp7");
+ mark_holdee(NULL, sc->temp8, "sc->temp8");
+ mark_holdee(NULL, sc->temp9, "sc->temp9");
+ mark_holdee(NULL, sc->temp10, "sc->temp10");
+ mark_holdee(NULL, sc->rec_p1, "sc->rec_p1");
+ mark_holdee(NULL, sc->rec_p2, "sc->rec_p2");
+
+ mark_holdee(NULL, car(sc->t1_1), "car(sc->t1_1)");
+ mark_holdee(NULL, car(sc->t2_1), "car(sc->t2_1)");
+ mark_holdee(NULL, car(sc->t2_2), "car(sc->t2_2)");
+ mark_holdee(NULL, car(sc->t3_1), "car(sc->t3_1)");
+ mark_holdee(NULL, car(sc->t3_2), "car(sc->t3_2)");
+ mark_holdee(NULL, car(sc->t3_3), "car(sc->t3_3)");
+ mark_holdee(NULL, car(sc->t4_1), "car(sc->t4_1)");
+ mark_holdee(NULL, car(sc->u1_1), "car(sc->u1_1)");
+ mark_holdee(NULL, car(sc->plist_1), "car(sc->plist_1)");
+ mark_holdee(NULL, car(sc->plist_2), "car(sc->plist_2)");
+ mark_holdee(NULL, car(sc->plist_3), "car(sc->plist_3)");
+ mark_holdee(NULL, car(sc->plist_4), "car(sc->plist_4)");
+ mark_holdee(NULL, car(sc->qlist_2), "car(sc->qlist_2)");
+ mark_holdee(NULL, car(sc->qlist_3), "car(sc->qlist_3)");
+ mark_holdee(NULL, car(sc->elist_1), "car(sc->elist_1)");
+ mark_holdee(NULL, car(sc->elist_2), "car(sc->elist_2)");
+ mark_holdee(NULL, car(sc->elist_3), "car(sc->elist_3)");
+ mark_holdee(NULL, car(sc->elist_4), "car(sc->elist_4)");
+ mark_holdee(NULL, car(sc->elist_5), "car(sc->elist_5)");
+ mark_holdee(NULL, car(sc->elist_6), "car(sc->elist_6)");
+ mark_holdee(NULL, car(sc->elist_7), "car(sc->elist_7)");
+ mark_holdee(NULL, car(sc->plist_2_2), "cadr(sc->plist_2)");
+ mark_holdee(NULL, cadr(sc->plist_3), "cadr(sc->plist_3)");
+ mark_holdee(NULL, cadr(sc->elist_2), "cadr(sc->elist_2)");
+ mark_holdee(NULL, cadr(sc->elist_3), "cadr(sc->elist_3)");
+ mark_holdee(NULL, cadr(sc->qlist_2), "cadr(sc->qlist_2)");
+ mark_holdee(NULL, caddr(sc->plist_3), "caddr(sc->plist_3)");
+ mark_holdee(NULL, caddr(sc->elist_3), "caddr(sc->elist_3)");
+
+ mark_holdee(NULL, sc->code, "sc->code");
+ mark_holdee(NULL, sc->value, "sc->value");
+ mark_holdee(NULL, sc->args, "sc->args");
+ mark_holdee(NULL, sc->curlet, "sc->curlet");
+ mark_holdee(NULL, sc->stack, "sc->stack");
+ mark_holdee(NULL, sc->default_random_state, "sc->default_random_state");
+ mark_holdee(NULL, sc->let_temp_hook, "sc->let_temp_hook");
+ mark_holdee(NULL, sc->stacktrace_defaults, "sc->stacktrace_defaults");
+ mark_holdee(NULL, sc->protected_objects, "sc->protected_objects");
+ mark_holdee(NULL, sc->protected_setters, "sc->protected_setters");
+ mark_holdee(NULL, sc->protected_setter_symbols, "sc->protected_setter_symbols");
+ mark_holdee(NULL, sc->error_type, "sc->error_type");
+ mark_holdee(NULL, sc->error_data, "sc->error_data");
+ mark_holdee(NULL, sc->error_code, "sc->error_code");
+ mark_holdee(NULL, sc->error_line, "sc->error_line");
+ mark_holdee(NULL, sc->error_file, "sc->error_file");
+ mark_holdee(NULL, sc->error_position, "sc->error_position");
+#if WITH_HISTORY
+ mark_holdee(NULL, sc->error_history, "sc->error_history");
+#endif
+
+ for (gc_obj_t *g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt))
+ mark_holdee(NULL, g->p, "permanent object");
+
+ for (s7_int i = 0; i < sc->protected_objects_size; i++)
+ mark_holdee(NULL, vector_element(sc->protected_objects, i), "gc protected object");
+
+ for (s7_int i = 0; i < sc->protected_setters_loc; i++)
+ mark_holdee(NULL, vector_element(sc->protected_setters, i), "gc protected setter");
+
+ for (s7_int i = 0; i < sc->setters_loc; i++)
+ mark_holdee(NULL, cdr(sc->setters[i]), "setter");
+
+ for (s7_int i = 0; i <= sc->format_depth; i++)
+ if (sc->fdats[i])
+ mark_holdee(NULL, sc->fdats[i]->curly_arg, "fdat curly_arg");
+
+ {
+ s7_pointer *tp = (s7_pointer *)(sc->input_port_stack + sc->input_port_stack_loc);
+ for (s7_pointer *p = sc->input_port_stack; p < tp; p++)
+ mark_holdee(NULL, *p, "input stack");
+ }
+ {
+ s7_pointer *p = sc->op_stack;
+ s7_pointer *tp = sc->op_stack_now;
+ while (p < tp) {s7_pointer x = *p++; mark_holdee(NULL, x, "op stack");}
+ }
+
+ if (sc->rec_stack)
+ for (s7_int i = 0; i < sc->rec_loc; i++)
+ mark_holdee(NULL, sc->rec_els[i], "sc->rec_els");
+
+ {
+ 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");
+ }}
+
+ 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])))
+ for (s7_pointer p = sc->safe_lists[i]; is_pair(p); p = cdr(p))
+ 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");
+ for (s7_pointer p = sc->out_of_range_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "out-of-range");
+ for (s7_pointer p = sc->sole_arg_out_of_range_info; is_pair(p); p = cdr(p)) mark_holdee(NULL, car(p), "simple out-of-range");
+ for (s7_pointer y = sc->rootlet_slots; tis_slot(y); y = next_slot(y))
+ mark_holdee(NULL, slot_value(y), "rootlet");
+#if WITH_HISTORY
+ for (s7_pointer p1 = sc->eval_history1, p2 = sc->eval_history2, p3 = sc->history_pairs; ; p2 = cdr(p2), p3 = cdr(p3))
+ {
+ mark_holdee(NULL, car(p1), "eval history1");
+ mark_holdee(NULL, car(p2), "eval history2");
+ mark_holdee(NULL, car(p3), "eval history3");
+ p1 = cdr(p1);
+ if (p1 == sc->eval_history1) break;
+ }
+#else
+ mark_holdee(NULL, sc->cur_code, "current code");
+#endif
+}
+
+void s7_heap_scan(s7_scheme *sc, int32_t typ);
+void s7_heap_scan(s7_scheme *sc, int32_t typ)
+{
+ bool found_one = false;
+ for (s7_int k = 0; k < sc->heap_size; k++)
+ {
+ 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);
+ }}
+ if (!found_one)
+ fprintf(stderr, "heap-scan: no %s found\n", s7_type_names[typ]);
+}
+
+static s7_pointer g_heap_scan(s7_scheme *sc, s7_pointer args)
+{
+ #define H_heap_scan "(heap-scan type) scans the heap for objects of type and reports info about them"
+ #define Q_heap_scan s7_make_signature(sc, 2, sc->not_symbol, sc->is_integer_symbol)
+ s7_pointer p = car(args);
+ if (!s7_is_integer(p))
+ sole_arg_wrong_type_error_nr(sc, make_symbol(sc, "heap-scan", 9), p, sc->type_names[T_INTEGER]);
+ if ((s7_integer(p) <= 0) || (s7_integer(p) >= NUM_TYPES))
+ sole_arg_out_of_range_error_nr(sc, make_symbol(sc, "heap-scan", 9), p, wrap_string(sc, "0 < type < 48", 13));
+ s7_heap_scan(sc, (int32_t)s7_integer(p)); /* 0..48 currently */
+ return(sc->F);
+}
+
+static s7_pointer g_heap_analyze(s7_scheme *sc, s7_pointer args)
+{
+ #define H_heap_analyze "(heap-analyze) gets heap data for subsequent heap-scan"
+ #define Q_heap_analyze s7_make_signature(sc, 1, sc->not_symbol)
+ s7_heap_analyze(sc);
+ return(sc->F);
+}
+
+static s7_pointer g_heap_holder(s7_scheme *sc, s7_pointer args)
+{
+ #define H_heap_holder "(heap-holder obj) returns the object pointing to obj"
+ #define Q_heap_holder s7_make_signature(sc, 2, sc->T, sc->T)
+ s7_pointer p = car(args);
+ if ((p->holders == 0) || ((!(p->holder)) && (!(p->root)))) return(sc->F);
+ return((p->holder) ? p->holder : s7_make_string(sc, p->root));
+}
+
+static s7_pointer g_heap_holders(s7_scheme *sc, s7_pointer args)
+{
+ #define H_heap_holders "(heap-holders obj) returns the number of objects pointing to obj"
+ #define Q_heap_holders s7_make_signature(sc, 2, sc->is_integer_symbol, sc->T)
+ return(make_integer(sc, car(args)->holders));
+}
+
+/* random debugging stuff */
+static s7_pointer g_show_stack(s7_scheme *sc, s7_pointer args)
+{
+ #define H_show_stack "(show-stack ((limit sc->show_stack_limit)))"
+ #define Q_show_stack s7_make_signature(sc, 2, sc->not_symbol, sc->is_integer_symbol)
+ if ((!is_null(args)) && (s7_is_integer(car(args))))
+ {
+ s7_int old_limit = sc->show_stack_limit;
+ sc->show_stack_limit = s7_integer(car(args));
+ s7_show_stack(sc);
+ sc->show_stack_limit = old_limit;
+ }
+ else s7_show_stack(sc);
+ return(sc->F);
+}
+
+void s7_show_op_stack(s7_scheme *sc);
+void s7_show_op_stack(s7_scheme *sc)
+{
+ fprintf(stderr, "op_stack:\n");
+ for (s7_pointer *p = sc->op_stack, *tp = sc->op_stack_now; (p < tp); p++)
+ fprintf(stderr, " %s\n", display(*p));
+}
+
+static s7_pointer g_show_op_stack(s7_scheme *sc, s7_pointer args)
+{
+ #define H_show_op_stack "no help"
+ #define Q_show_op_stack s7_make_signature(sc, 1, sc->not_symbol)
+ s7_show_op_stack(sc);
+ return(sc->F);
+}
+
+static s7_pointer g_is_op_stack(s7_scheme *sc, s7_pointer args)
+{
+ #define H_is_op_stack "no help"
+ #define Q_is_op_stack s7_make_signature(sc, 1, sc->is_boolean_symbol)
+ return(make_boolean(sc, (sc->op_stack < sc->op_stack_now)));
+}
+#endif
+
+
+/* -------------------------------- *s7* let -------------------------------- */
+
+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));
+}
+
+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);
+ 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));
+}
+
+static s7_int s7_starlet_length(void) {return(SL_NUM_FIELDS - 1);}
+
+static s7_pointer g_s7_starlet_set_fallback(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer sym = cadr(args);
+ if (!is_symbol(sym))
+ sole_arg_wrong_type_error_nr(sc, sc->let_set_symbol, sym, sc->type_names[T_SYMBOL]);
+ return(s7_starlet_set_1(sc, sym, caddr(args)));
+}
+
+static s7_pointer g_s7_starlet_ref_fallback(s7_scheme *sc, s7_pointer args);
+
+static s7_pointer make_s7_starlet(s7_scheme *sc) /* *s7* is semipermanent -- 20-May-21 */
+{
+ s7_pointer slot1 = make_semipermanent_slot(sc, sc->let_set_fallback_symbol, s7_make_function(sc, "s7-let-set", g_s7_starlet_set_fallback, 3, 0, false, "*s7* writer"));
+ s7_pointer slot2 = make_semipermanent_slot(sc, sc->let_ref_fallback_symbol, s7_make_function(sc, "s7-let-ref", g_s7_starlet_ref_fallback, 2, 0, false, "*s7* reader"));
+ s7_pointer x = alloc_pointer(sc);
+ set_full_type(x, T_LET | T_SAFE_PROCEDURE | T_UNHEAP | T_HAS_METHODS | T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK);
+ let_set_id(x, ++sc->let_number);
+ let_set_outlet(x, sc->rootlet);
+ symbol_set_local_slot(sc->let_set_fallback_symbol, sc->let_number, slot1);
+ slot_set_next(slot1, slot_end);
+ symbol_set_local_slot(sc->let_ref_fallback_symbol, sc->let_number, slot2);
+ slot_set_next(slot2, slot1);
+ let_set_slots(x, slot2);
+ set_immutable_slot(slot1); /* make the *s7* let-ref|set! fallbacks immutable */
+ set_immutable_slot(slot2);
+ set_immutable_let(x);
+ sc->s7_starlet_symbol = s7_define_constant(sc, "*s7*", s7_openlet(sc, x)); /* define_constant returns the symbol */
+ for (int32_t i = SL_STACK_TOP; i < SL_NUM_FIELDS; i++)
+ {
+ s7_pointer sym = make_symbol_with_strlen(sc, s7_starlet_names[i]);
+ s7_starlet_symbol_set(sym, (s7_starlet_t)i); /* evaluates sym twice */
+ }
+ return(x);
+}
+
+static void add_symbol_table(s7_scheme *sc, s7_pointer mu_let)
+{
+ /* check the symbol table, counting gensyms etc */
+ s7_int syms = 0, gens = 0, keys = 0, mx_list = 0;
+ s7_pointer *els = vector_elements(sc->symbol_table);
+ for (s7_int i = 0; i < SYMBOL_TABLE_SIZE; i++)
+ {
+ 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++;
+ }
+ 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))));
+}
+
+static s7_pointer kmg(s7_scheme *sc, s7_int bytes)
+{
+ block_t *b = mallocate(sc, 128);
+ int32_t len = 0;
+ if (bytes < 1000)
+ len = snprintf((char *)block_data(b), 128, "%" ld64, bytes);
+ else
+ if (bytes < 1000000)
+ 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);
+ 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)));
+}
+
+static void add_gc_list_sizes(s7_scheme *sc, s7_pointer mu_let)
+{
+ /* check the gc lists (finalizations), at startup there are strings/input-strings from the s7_eval_c_string calls for make-polar et el */
+ s7_int len = sc->strings->size + sc->vectors->size + sc->input_ports->size + sc->output_ports->size + sc->input_string_ports->size +
+ sc->continuations->size + sc->c_objects->size + sc->hash_tables->size + sc->gensyms->size + sc->undefineds->size +
+ sc->multivectors->size + sc->weak_refs->size + sc->weak_hash_iterators->size + sc->opt1_funcs->size;
+
+ int32_t loc = sc->strings->loc + sc->vectors->loc + sc->input_ports->loc + sc->output_ports->loc + sc->input_string_ports->loc +
+ sc->continuations->loc + sc->c_objects->loc + sc->hash_tables->loc + sc->gensyms->loc + sc->undefineds->loc +
+ sc->multivectors->loc + sc->weak_refs->loc + sc->weak_hash_iterators->loc + sc->opt1_funcs->loc;
+
+ 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),
+ 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)))))));
+}
+
+/* handling all *s7* fields via fallbacks lets us use direct field accesses in the rest of s7, and avoids
+ * using ca 100 cells for the let slots/values. We would need the fallbacks anyway for 'files et al.
+ * Since most of the fields need special setters, it's actually less code this way. See old/s7-let-s7.c.
+ */
+
+#if (!_WIN32) /* (!MS_WINDOWS) */
+ #include <sys/resource.h>
+#endif
+
+static s7_pointer memory_usage(s7_scheme *sc)
+{
+ s7_int i, k, len, in_use = 0, all_len = 0;
+ gc_list_t *gp;
+ s7_int ts[NUM_TYPES];
+
+#if (!_WIN32) /* (!MS_WINDOWS) */
+ struct rusage info;
+ struct timeval ut;
+#endif
+
+ s7_pointer mu_let = s7_inlet(sc, sc->nil);
+ s7_int gc_loc = gc_protect_1(sc, mu_let);
+
+#if (!_WIN32) /* (!MS_WINDOWS) */
+ getrusage(RUSAGE_SELF, &info);
+ ut = info.ru_utime;
+ add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-time", 12), make_real(sc, ut.tv_sec + (floor(ut.tv_usec / 1000.0) / 1000.0)));
+#ifdef __APPLE__
+ add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-resident-size", 21), kmg(sc, info.ru_maxrss));
+ /* apple docs say this is in kilobytes, but apparently that is an error */
+#else
+ add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "process-resident-size", 21), kmg(sc, info.ru_maxrss * 1024));
+ /* why does this number sometimes have no relation to RES in top? */
+#endif
+ add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "IO", 2), cons(sc, make_integer(sc, info.ru_inblock), make_integer(sc, info.ru_oublock)));
+#endif
+
+ 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)))));
+ 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)))));
+
+ 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))));
+ 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));
+ i = 0;
+ for (gc_obj_t *g = sc->semipermanent_lets; g; i++, g = (gc_obj_t *)(g->nxt));
+ add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "permanent_lets", 14), make_integer(sc, i));
+
+ /* safe_lists */
+ {
+ 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;}
+ }
+ 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));
+#if S7_DEBUGGING
+ sc->w = sc->unused;
+#endif
+ }
+
+ /* show how many active cells there are of each type (this is where all the memory_usage cpu time goes) */
+ for (i = 0; i < NUM_TYPES; i++) ts[i] = 0;
+ for (k = 0; k < sc->heap_size; k++)
+ ts[unchecked_type(sc->heap[k])]++;
+ sc->w = sc->nil;
+ for (i = 0; i < NUM_TYPES; i++)
+ {
+ 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));
+ }}
+ 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)));
+ 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)));
+ 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);
+ add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "stack", 5), cons(sc, make_integer(sc, stack_top(sc)), make_integer(sc, sc->stack_size)));
+
+ len = sc->autoload_names_top * (sizeof(const char **) + sizeof(s7_int) + sizeof(bool));
+ for (i = 0; i < sc->autoload_names_loc; i++) len += sc->autoload_names_sizes[i];
+ 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))));
+
+ add_gc_list_sizes(sc, mu_let);
+
+ /* strings */
+ gp = sc->strings;
+ for (len = 0, i = 0; i < (int32_t)(gp->loc); i++)
+ len += string_length(gp->list[i]);
+ add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "strings", 7), cons(sc, make_integer(sc, gp->loc), make_integer(sc, len)));
+
+ /* vectors */
+ {
+ 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);}
+ }
+ 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)))));
+ }
+ /* hash-tables */
+ {
+ s7_int hlen = 0;
+ for (i = 0, gp = sc->hash_tables; i < gp->loc; i++)
+ {
+ s7_pointer v = gp->list[i];
+ hlen += ((hash_table_size(v)) * sizeof(hash_entry_t *));
+ hlen += (hash_table_entries(v) * sizeof(hash_entry_t));
+ }
+ 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)));
+ }
+ /* 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)));
+ gp = sc->input_ports;
+ for (i = 0, len = 0; i < gp->loc; i++)
+ {
+ s7_pointer v = gp->list[i];
+ 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)));
+
+ gp = sc->input_string_ports;
+ for (i = 0, len = 0; i < gp->loc; i++)
+ {
+ s7_pointer v = gp->list[i];
+ 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)));
+
+ gp = sc->output_ports;
+ for (i = 0, len = 0; i < gp->loc; i++)
+ {
+ s7_pointer v = gp->list[i];
+ 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)));
+
+ i = 0;
+ for (s7_pointer p = sc->format_ports; p; i++, p = (s7_pointer)port_next(p));
+ add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "format-ports", 12), make_integer(sc, i));
+
+ /* continuations (sketchy!) */
+ gp = sc->continuations;
+ for (i = 0, len = 0; i < gp->loc; i++)
+ if (is_continuation(gp->list[i]))
+ 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))));
+ /* 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) */
+#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)));
+#endif
+ /* free-lists (mallocate) */
+ {
+ block_t *b;
+#if S7_DEBUGGING
+ s7_int num_blocks = 0;
+#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);
+#if S7_DEBUGGING
+ num_blocks += k;
+#endif
+ }
+ for (b = sc->block_lists[TOP_BLOCK_LIST], k = 0; b; b = block_next(b), k++)
+ len += (sizeof(block_t) + block_size(b));
+ sc->w = cons(sc, make_integer(sc, k), sc->w);
+#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)));
+#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)))));
+ 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));
+ }
+
+ s7_gc_unprotect_at(sc, gc_loc);
+ return(mu_let);
+}
+
+static s7_pointer sl_c_types(s7_scheme *sc)
+{
+ s7_pointer res;
+ sc->w = sc->nil;
+ for (int32_t i = 0; i < sc->num_c_object_types; i++) /* c-object type (tag) is i */
+ sc->w = cons(sc, sc->c_object_types[i]->scheme_name, sc->w);
+ res = proper_list_reverse_in_place(sc, sc->w); /* so car(types) has tag 0 */
+ sc->w = sc->unused;
+ return(res);
+}
+
+static s7_pointer sl_file_names(s7_scheme *sc)
+{
+ s7_pointer p;
+ sc->w = sc->nil;
+ for (int32_t i = 0; i <= sc->file_names_top; i++)
+ sc->w = cons(sc, sc->file_names[i], sc->w);
+ p = proper_list_reverse_in_place(sc, sc->w);
+ sc->w = sc->unused;
+ return(p);
+}
+
+static s7_pointer sl_int_fixup(s7_scheme *sc, s7_pointer val)
+{
+#if WITH_GMP
+ return(s7_int_to_big_integer(sc, s7_integer_clamped_if_gmp(sc, val)));
+#else
+ return(val);
+#endif
+}
+
+static s7_pointer sl_history(s7_scheme *sc)
+{
+#if WITH_HISTORY
+ return(cull_history(sc, (sc->cur_code == sc->history_sink) ? sc->old_cur_code : sc->cur_code));
+#else
+ return(sc->cur_code);
+#endif
+}
+
+static s7_pointer sl_active_catches(s7_scheme *sc)
+{
+ s7_pointer lst = sc->nil;
+ for (int64_t i = stack_top(sc) - 1; i >= 3; i -= 4)
+ switch (stack_op(sc->stack, i))
+ {
+ case OP_CATCH_ALL:
+ 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;
+ }
+ return(reverse_in_place_unchecked(sc, sc->nil, lst));
+}
+
+static s7_pointer sl_stack_entries(s7_scheme *sc, s7_pointer stack, int64_t top)
+{
+ s7_pointer lst = sc->nil; /* the stack can contain anything (like #<unused>): this is a dangerous function */
+ for (int64_t i = top - 1; i >= 3; i -= 4)
+ {
+ s7_pointer func = stack_code(stack, i), args = stack_args(stack, i), e = stack_let(stack, i);
+ opcode_t op = stack_op(stack, i);
+ s7_pointer entry = sc->nil;
+ if (s7_is_valid(sc, e)) entry = cons(sc, e, entry);
+ if (s7_is_valid(sc, args)) entry = cons_unchecked(sc, args, entry);
+ if (s7_is_valid(sc, func)) entry = cons_unchecked(sc, func, entry);
+ if ((op >= 0) && (op < NUM_OPS)) entry = cons_unchecked(sc, make_symbol_with_strlen(sc, op_names[op]), entry);
+ lst = cons_unchecked(sc, entry, lst);
+ sc->w = lst;
+ }
+ sc->w = sc->unused;
+ return(reverse_in_place_unchecked(sc, sc->nil, lst));
+}
+
+static s7_pointer sl_protected_objects(s7_scheme *sc)
+{
+ s7_pointer nv = s7_vector_copy(sc, sc->protected_objects);
+ s7_pointer *vals = vector_elements(nv);
+ s7_int len = vector_length(nv);
+ for (s7_int i = 0; i < len; i++)
+ if (vals[i] == sc->unused)
+ vals[i] = sc->F;
+ return(nv);
+}
+
+static s7_pointer s7_starlet(s7_scheme *sc, s7_int choice)
+{
+ switch (choice)
+ {
+ case SL_ACCEPT_ALL_KEYWORD_ARGUMENTS: return(make_boolean(sc, sc->accept_all_keyword_arguments));
+ case SL_AUTOLOADING: return(make_boolean(sc, sc->is_autoloading));
+ case SL_BIGNUM_PRECISION: return(make_integer(sc, sc->bignum_precision));
+ case SL_CATCHES: return(sl_active_catches(sc));
+ case SL_CPU_TIME: return(make_real(sc, (double)clock() / (double)CLOCKS_PER_SEC)); /* cpu, not wall-clock time */
+ case SL_C_TYPES: return(sl_c_types(sc));
+ case SL_DEBUG: return(make_integer(sc, sc->debug));
+ case SL_DEFAULT_HASH_TABLE_LENGTH: return(make_integer(sc, sc->default_hash_table_length));
+ case SL_DEFAULT_RANDOM_STATE: return(sc->default_random_state);
+ case SL_DEFAULT_RATIONALIZE_ERROR: return(make_real(sc, sc->default_rationalize_error));
+ case SL_EQUIVALENT_FLOAT_EPSILON: return(make_real(sc, sc->equivalent_float_epsilon));
+ case SL_EXPANSIONS: return(make_boolean(sc, sc->is_expanding));
+ case SL_FILE_NAMES: case SL_FILENAMES: return(sl_file_names(sc));
+ case SL_FLOAT_FORMAT_PRECISION: return(make_integer(sc, sc->float_format_precision));
+ case SL_FREE_HEAP_SIZE: return(make_integer(sc, sc->free_heap_top - sc->free_heap));
+ case SL_GC_FREED: return(make_integer(sc, sc->gc_freed));
+ case SL_GC_INFO: return(list_3(sc, make_integer(sc, sc->gc_calls), make_integer(sc, sc->gc_total_time), make_integer(sc, ticks_per_second())));
+ case SL_GC_PROTECTED_OBJECTS: return(sl_protected_objects(sc));
+ case SL_GC_RESIZE_HEAP_BY_4_FRACTION: return(make_real(sc, sc->gc_resize_heap_by_4_fraction));
+ case SL_GC_RESIZE_HEAP_FRACTION: return(make_real(sc, sc->gc_resize_heap_fraction));
+ case SL_GC_STATS: return(make_integer(sc, sc->gc_stats));
+ case SL_GC_TEMPS_SIZE: return(make_integer(sc, sc->gc_temps_size));
+ case SL_GC_TOTAL_FREED: return(make_integer(sc, sc->gc_total_freed));
+ case SL_HASH_TABLE_FLOAT_EPSILON: return(make_real(sc, sc->hash_table_float_epsilon));
+ case SL_HEAP_SIZE: return(make_integer(sc, sc->heap_size));
+ case SL_HISTORY: return(sl_history(sc));
+ case SL_HISTORY_ENABLED: return(make_boolean(sc, s7_history_enabled(sc)));
+ case SL_HISTORY_SIZE: return(make_integer(sc, sc->history_size));
+ case SL_INITIAL_STRING_PORT_LENGTH: return(make_integer(sc, sc->initial_string_port_length));
+ case SL_MAJOR_VERSION: return(make_integer(sc, S7_MAJOR_VERSION));
+ case SL_MINOR_VERSION: return(make_integer(sc, S7_MINOR_VERSION));
+ case SL_MAX_FORMAT_LENGTH: return(make_integer(sc, sc->max_format_length));
+ case SL_MAX_HEAP_SIZE: return(make_integer(sc, sc->max_heap_size));
+ case SL_MAX_LIST_LENGTH: return(make_integer(sc, sc->max_list_length));
+ case SL_MAX_PORT_DATA_SIZE: return(make_integer(sc, sc->max_port_data_size));
+ case SL_MAX_STACK_SIZE: return(make_integer(sc, sc->max_stack_size));
+ case SL_MAX_STRING_LENGTH: return(make_integer(sc, sc->max_string_length));
+ case SL_MAX_VECTOR_DIMENSIONS: return(make_integer(sc, sc->max_vector_dimensions));
+ case SL_MAX_VECTOR_LENGTH: return(make_integer(sc, sc->max_vector_length));
+ case SL_MEMORY_USAGE: return(memory_usage(sc));
+ case SL_MOST_NEGATIVE_FIXNUM: return(sl_int_fixup(sc, leastfix));
+ case SL_MOST_POSITIVE_FIXNUM: return(sl_int_fixup(sc, mostfix));
+ case SL_MUFFLE_WARNINGS: return(make_boolean(sc, sc->muffle_warnings));
+ case SL_NUMBER_SEPARATOR: return(chars[(int)(sc->number_separator)]);
+ case SL_OPENLETS: return(make_boolean(sc, sc->has_openlets));
+ case SL_OUTPUT_FILE_PORT_DATA_SIZE: return(make_integer(sc, sc->output_file_port_data_size));
+ case SL_PRINT_LENGTH: return(make_integer(sc, sc->print_length));
+ case SL_PROFILE: return(make_integer(sc, sc->profile));
+ case SL_PROFILE_INFO: return(profile_info_out(sc));
+ case SL_PROFILE_PREFIX: return(sc->profile_prefix);
+ case SL_ROOTLET_SIZE: return(make_integer(sc, let_length(sc, sc->rootlet)));
+ case SL_SAFETY: return(make_integer(sc, sc->safety));
+ case SL_STACK: return(sl_stack_entries(sc, sc->stack, stack_top(sc)));
+ case SL_STACKTRACE_DEFAULTS: return(copy_proper_list(sc, sc->stacktrace_defaults)); /* if not copied, we can set! entries directly to garbage */
+ case SL_STACK_SIZE: return(make_integer(sc, sc->stack_size));
+ case SL_STACK_TOP: return(make_integer(sc, (sc->stack_end - sc->stack_start) / 4));
+ case SL_UNDEFINED_CONSTANT_WARNINGS: return(make_boolean(sc, sc->undefined_constant_warnings));
+ case SL_UNDEFINED_IDENTIFIER_WARNINGS: return(make_boolean(sc, sc->undefined_identifier_warnings));
+ case SL_VERSION: return(s7_make_string(sc, "s7 " S7_VERSION ", " S7_DATE));
+ }
+ return(sc->undefined);
+}
+
+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);
+ if (s7_starlet_symbol(sym) != SL_NO_FIELD)
+ return(s7_starlet(sc, s7_starlet_symbol(sym)));
+ }
+ return(sc->undefined);
+}
+
+s7_pointer s7_let_field_ref(s7_scheme *sc, s7_pointer sym) {return(s7_starlet_ref(sc, sym));}
+
+static s7_pointer g_s7_starlet_ref_fallback(s7_scheme *sc, s7_pointer args)
+{
+ s7_pointer sym = cadr(args);
+ if (!is_symbol(sym))
+ sole_arg_wrong_type_error_nr(sc, sc->let_ref_symbol, sym, sc->type_names[T_SYMBOL]);
+ if (is_keyword(sym))
+ sym = keyword_symbol(sym);
+ return(s7_starlet(sc, s7_starlet_symbol(sym)));
+}
+
+static s7_pointer s7_starlet_iterate(s7_scheme *sc, s7_pointer iterator)
+{
+ s7_pointer symbol, value;
+ iterator_position(iterator)++;
+ if (iterator_position(iterator) >= SL_NUM_FIELDS)
+ return(iterator_quit(iterator));
+ symbol = make_symbol_with_strlen(sc, s7_starlet_names[iterator_position(iterator)]);
+
+ if ((iterator_position(iterator) == SL_STACK) ||
+ (iterator_position(iterator) == SL_GC_PROTECTED_OBJECTS) ||
+ (iterator_position(iterator) == SL_MEMORY_USAGE))
+ value = sc->F; /* (format #f "~W" (inlet *s7*)) or (let->list *s7*) etc */
+ else
+ {
+ s7_pointer osw = sc->w; /* protect against s7_starlet list making */
+ value = s7_starlet(sc, s7_starlet_symbol(symbol));
+ sc->w = osw;
+ }
+ if (iterator_let_cons(iterator))
+ {
+ s7_pointer p = iterator_let_cons(iterator);
+ set_car(p, symbol);
+ set_cdr(p, value);
+ return(p);
+ }
+ return(cons(sc, symbol, value));
+}
+
+static s7_pointer s7_starlet_make_iterator(s7_scheme *sc, s7_pointer iter)
+{
+ iterator_position(iter) = SL_NO_FIELD;
+ iterator_next(iter) = s7_starlet_iterate;
+ iterator_let_cons(iter) = NULL;
+ return(iter);
+}
+
+static s7_pointer sl_real_geq_0(s7_scheme *sc, s7_pointer sym, s7_pointer val)
+{
+ if (!is_real(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_REAL]);
+ if (s7_real(val) < 0.0) s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be negative", 25));
+ return(val);
+}
+
+static s7_pointer sl_integer_gt_0(s7_scheme *sc, s7_pointer sym, s7_pointer val)
+{
+ if (!s7_is_integer(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]);
+ if (s7_integer_clamped_if_gmp(sc, val) <= 0) s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be positive", 21));
+ return(val);
+}
+
+static s7_pointer sl_integer_geq_0(s7_scheme *sc, s7_pointer sym, s7_pointer val)
+{
+ if (!s7_is_integer(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]);
+ if (s7_integer_clamped_if_gmp(sc, val) < 0) s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be negative", 25));
+ return(val);
+}
+
+#if WITH_HISTORY
+static void sl_set_history_size(s7_scheme *sc, s7_int iv)
+{
+ s7_pointer p1, p2;
+ if (iv > MAX_HISTORY_SIZE) iv = MAX_HISTORY_SIZE;
+ if (iv > sc->true_history_size)
+ {
+ /* splice in the new cells, reattach the circles */
+ s7_pointer p3;
+ s7_pointer next1 = cdr(sc->eval_history1);
+ s7_pointer next2 = cdr(sc->eval_history2);
+ s7_pointer next3 = cdr(sc->history_pairs);
+ set_cdr(sc->eval_history1, semipermanent_list(sc, iv - sc->true_history_size));
+ set_cdr(sc->eval_history2, semipermanent_list(sc, iv - sc->true_history_size));
+ set_cdr(sc->history_pairs, semipermanent_list(sc, iv - sc->true_history_size));
+ for (p3 = cdr(sc->history_pairs); is_pair(cdr(p3)); p3 = cdr(p3)) set_car(p3, semipermanent_list(sc, 1));
+ set_car(p3, semipermanent_list(sc, 1));
+ set_cdr(p3, next3);
+ for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2));
+ set_cdr(p1, next1);
+ set_cdr(p2, next2);
+ sc->true_history_size = iv;
+ }
+ sc->history_size = iv;
+ /* clear out both buffers to avoid GC confusion */
+ for (p1 = sc->eval_history1, p2 = sc->eval_history2; ; p2 = cdr(p2))
+ {
+ set_car(p1, sc->nil);
+ set_car(p2, sc->nil);
+ p1 = cdr(p1);
+ if (p1 == sc->eval_history1) break;
+ }
+}
+#endif
+
+#if WITH_GMP
+static s7_pointer set_bignum_precision(s7_scheme *sc, int32_t precision)
+{
+ mp_prec_t bits = (mp_prec_t)precision;
+ s7_pointer bpi;
+ if (precision <= 1) /* (set! (*s7* 'bignum-precision) 1) causes mpfr to segfault! (also 0 and -1) */
+ sole_arg_out_of_range_error_nr(sc, wrap_string(sc, "set! (*s7* 'bignum-precision)", 29), wrap_integer(sc, precision), wrap_string(sc, "has to be greater than 1", 24));
+ mpfr_set_default_prec(bits);
+ mpc_set_default_precision(bits);
+ bpi = big_pi(sc);
+ global_slot(sc->pi_symbol)->object.slt.val = bpi; /* don't check immutable flag here (if debugging) -- i.e. don't use slot_set_value! */
+ return(sc->F);
+}
+#endif
+
+static s7_pointer sl_set_stacktrace_defaults(s7_scheme *sc, s7_pointer sym, s7_pointer val)
+{
+ if (!is_pair(val))
+ s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_PAIR]);
+ if (s7_list_length(sc, val) != 5)
+ s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a list with 5 entries", 21));
+ if (!is_t_integer(car(val)))
+ sl_stacktrace_wrong_type_error_nr(sc, sym, 1, car(val), wrap_string(sc, "an integer (stack frames)", 25), val);
+ if (!is_t_integer(cadr(val)))
+ sl_stacktrace_wrong_type_error_nr(sc, sym, 2, cadr(val), wrap_string(sc, "an integer (cols-for-data)", 26), val);
+ if (!is_t_integer(caddr(val)))
+ sl_stacktrace_wrong_type_error_nr(sc, sym, 3, caddr(val), wrap_string(sc, "an integer (line length)", 24), val);
+ if (!is_t_integer(cadddr(val)))
+ sl_stacktrace_wrong_type_error_nr(sc, sym, 4, cadddr(val), wrap_string(sc, "an integer (comment position)", 29), val);
+ if (!is_boolean(s7_list_ref(sc, val, 4)))
+ sl_stacktrace_wrong_type_error_nr(sc, sym, 5, s7_list_ref(sc, val, 4), wrap_string(sc, "a boolean (treat-data-as-comment)", 33), val);
+ sc->stacktrace_defaults = copy_proper_list(sc, val);
+ return(val);
+}
+
+static s7_pointer sl_set_gc_stats(s7_scheme *sc, s7_pointer sym, s7_pointer val)
+{
+ if (is_boolean(val))
+ {
+ sc->gc_stats = ((val == sc->T) ? GC_STATS : 0);
+ return(val);
+ }
+ if (!s7_is_integer(val))
+ s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
+ sc->gc_stats = s7_integer_clamped_if_gmp(sc, val);
+ if (sc->gc_stats >= 16) /* gc_stats is uint32_t */
+ {
+ sc->gc_stats = 0;
+ s7_starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be between 0 and 15", 29));
+ }
+ return(val);
+}
+
+static s7_pointer sl_set_gc_info(s7_scheme *sc, s7_pointer sym, s7_pointer val) /* ticks_per_second is not settable */
+{
+ if (val == sc->F)
+ {
+ sc->gc_total_time = 0;
+ sc->gc_calls = 0;
+ }
+ 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 */
+ {
+ 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);
+}
+
+static s7_pointer sl_set_profile(s7_scheme *sc, s7_pointer sym, s7_pointer val)
+{
+ if (!s7_is_integer(val))
+ s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]);
+ sc->profile = s7_integer_clamped_if_gmp(sc, val);
+ sc->debug_or_profile = ((sc->debug > 1) || (sc->profile > 0));
+ 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");
+ if (!sc->profile_data)
+ make_profile_info(sc);
+ if (!sc->profile_out)
+ sc->profile_out = s7_make_function(sc, "profile-out", g_profile_out, 2, 0, false, NULL);
+ }
+ return(val);
+}
+
+static s7_pointer sl_set_debug(s7_scheme *sc, s7_pointer sym, s7_pointer val)
+{
+ if (!s7_is_integer(val))
+ s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]);
+ sc->debug = s7_integer_clamped_if_gmp(sc, val);
+ sc->debug_or_profile = ((sc->debug > 1) || (sc->profile > 0));
+ if ((sc->debug > 0) &&
+ (!is_a_feature(make_symbol(sc, "debug.scm", 9), s7_symbol_value(sc, sc->features_symbol))))
+ s7_load(sc, "debug.scm");
+ return(val);
+}
+
+static s7_pointer sl_set_number_separator(s7_scheme *sc, s7_pointer sym, s7_pointer val)
+{
+#if (!WITH_NUMBER_SEPARATOR)
+ s7_warn(sc, 128, "(set! (*s7* 'number-separator) ...) but number-separator is not included in this s7");
+#endif
+ if (!is_character(val))
+ s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_CHARACTER]);
+ if ((is_char_numeric(val)) || (is_char_whitespace(val)) || (!t_number_separator_p[character(val)]) ||
+ (character(val) == 'i') || (character(val) == 'e') || (character(val) == 'E'))
+ /* I guess +nan.0 and +inf.0 are not numeric literals, so we don't need to catch +n_a_n.0 */
+ s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a printing, non-numeric character", 33));
+ sc->number_separator = character(val);
+ return(val);
+}
+
+static s7_pointer sl_set_bignum_precision(s7_scheme *sc, s7_pointer sym, s7_pointer val)
+{
+ s7_int iv;
+ iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val));
+ sc->bignum_precision = iv;
+#if WITH_GMP
+ set_bignum_precision(sc, sc->bignum_precision);
+ mpfr_set_prec(sc->mpfr_1, sc->bignum_precision);
+ mpfr_set_prec(sc->mpfr_2, sc->bignum_precision);
+ mpc_set_prec(sc->mpc_1, sc->bignum_precision);
+ mpc_set_prec(sc->mpc_2, sc->bignum_precision);
+#endif
+ return(val);
+}
+
+static noreturn void sl_unsettable_error_nr(s7_scheme *sc, s7_pointer sym)
+{
+ immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set (*s7* '~S)", 20), sym));
+}
+
+static s7_pointer s7_starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val)
+{
+ s7_int iv;
+
+ if ((S7_DEBUGGING) && (!is_symbol(sym)))
+ {
+ fprintf(stderr, "%s: %s\n", __func__, display(sym));
+ sole_arg_wrong_type_error_nr(sc, sc->let_set_symbol, sym, sc->type_names[T_SYMBOL]);
+ }
+ if (is_keyword(sym))
+ sym = keyword_symbol(sym);
+
+ switch (s7_starlet_symbol(sym))
+ {
+ case SL_ACCEPT_ALL_KEYWORD_ARGUMENTS:
+ if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
+ sc->accept_all_keyword_arguments = s7_boolean(sc, val);
+ return(val);
+
+ case SL_AUTOLOADING:
+ if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
+ sc->is_autoloading = s7_boolean(sc, val);
+ return(val);
+
+ case SL_BIGNUM_PRECISION:
+ return(sl_set_bignum_precision(sc, sym, val));
+
+ case SL_CATCHES:
+ case SL_CPU_TIME:
+ case SL_C_TYPES:
+ sl_unsettable_error_nr(sc, sym);
+
+ case SL_DEBUG:
+ return(sl_set_debug(sc, sym, val));
+
+ case SL_DEFAULT_HASH_TABLE_LENGTH:
+ sc->default_hash_table_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val));
+ return(val);
+
+ case SL_DEFAULT_RANDOM_STATE:
+ if (!is_random_state(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_RANDOM_STATE]);
+#if (!WITH_GMP)
+ random_seed(sc->default_random_state) = random_seed(val);
+ random_carry(sc->default_random_state) = random_carry(val);
+#endif
+ return(val);
+
+ case SL_DEFAULT_RATIONALIZE_ERROR:
+ sc->default_rationalize_error = s7_real(sl_real_geq_0(sc, sym, val));
+ return(val);
+
+ case SL_EQUIVALENT_FLOAT_EPSILON:
+ sc->equivalent_float_epsilon = s7_real(sl_real_geq_0(sc, sym, val));
+ return(val);
+
+ case SL_EXPANSIONS:
+ if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
+ sc->is_expanding = s7_boolean(sc, val);
+ return(val);
+
+ case SL_FILE_NAMES: case SL_FILENAMES: sl_unsettable_error_nr(sc, sym);
+
+ case SL_FLOAT_FORMAT_PRECISION: /* float-format-precision should not be huge => hangs in snprintf -- what's a reasonable limit here? */
+ iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val));
+ sc->float_format_precision = (iv < MAX_FLOAT_FORMAT_PRECISION) ? iv : MAX_FLOAT_FORMAT_PRECISION;
+ return(val);
+
+ case SL_FREE_HEAP_SIZE:
+ case SL_GC_FREED:
+ case SL_GC_TOTAL_FREED:
+ case SL_GC_PROTECTED_OBJECTS:
+ sl_unsettable_error_nr(sc, sym);
+
+ case SL_GC_TEMPS_SIZE:
+ sc->gc_temps_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val));
+ return(val);
+ case SL_GC_RESIZE_HEAP_FRACTION:
+ sc->gc_resize_heap_fraction = s7_real(sl_real_geq_0(sc, sym, val));
+ return(val);
+ case SL_GC_RESIZE_HEAP_BY_4_FRACTION:
+ sc->gc_resize_heap_by_4_fraction = s7_real(sl_real_geq_0(sc, sym, val));
+ return(val);
+ case SL_GC_STATS:
+ return(sl_set_gc_stats(sc, sym, val));
+ case SL_GC_INFO:
+ return(sl_set_gc_info(sc, sym, val));
+
+ case SL_HASH_TABLE_FLOAT_EPSILON:
+ sc->hash_table_float_epsilon = s7_real(sl_real_geq_0(sc, sym, val));
+ return(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);
+ return(val);
+
+ case SL_HISTORY: /* (set! (*s7* 'history) val) */
+ replace_current_code(sc, val);
+ return(val);
+
+ case SL_HISTORY_ENABLED: /* (set! (*s7* 'history-enabled) #f|#t) */
+ if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
+ return(make_boolean(sc, s7_set_history_enabled(sc, s7_boolean(sc, val))));
+
+ case SL_HISTORY_SIZE:
+ iv = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val));
+#if WITH_HISTORY
+ sl_set_history_size(sc, iv);
+#else
+ sc->history_size = iv;
+#endif
+ return(val);
+
+ case SL_INITIAL_STRING_PORT_LENGTH: sc->initial_string_port_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val);
+
+ case SL_MAJOR_VERSION:
+ case SL_MINOR_VERSION:
+ sl_unsettable_error_nr(sc, sym);
+
+ case SL_MAX_FORMAT_LENGTH: sc->max_format_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val);
+ case SL_MAX_HEAP_SIZE: sc->max_heap_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val);
+ case SL_MAX_LIST_LENGTH: sc->max_list_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val);
+ case SL_MAX_PORT_DATA_SIZE: sc->max_port_data_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(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));
+ sc->max_stack_size = (uint32_t)iv;
+ return(val);
+
+ case SL_MAX_STRING_LENGTH: sc->max_string_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val);
+ case SL_MAX_VECTOR_DIMENSIONS: sc->max_vector_dimensions = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val);
+ case SL_MAX_VECTOR_LENGTH: sc->max_vector_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val);
+
+ case SL_MEMORY_USAGE:
+ case SL_MOST_NEGATIVE_FIXNUM:
+ case SL_MOST_POSITIVE_FIXNUM:
+ sl_unsettable_error_nr(sc, sym);
+
+ case SL_MUFFLE_WARNINGS:
+ if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
+ sc->muffle_warnings = s7_boolean(sc, val);
+ return(val);
+
+ case SL_NUMBER_SEPARATOR: /* I think no PL uses the separator in output */
+ return(sl_set_number_separator(sc, sym, val));
+
+ case SL_OPENLETS:
+ if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
+ sc->has_openlets = s7_boolean(sc, val);
+ return(val);
+
+ case SL_OUTPUT_FILE_PORT_DATA_SIZE:
+ sc->output_file_port_data_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val));
+ return(val);
+ case SL_PRINT_LENGTH: /* for pairs and vectors this affects how many elements are printed -- confusing */
+ sc->print_length = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val));
+ return(val);
+
+ case SL_PROFILE:
+ return(sl_set_profile(sc, sym, val));
+ case SL_PROFILE_INFO:
+ if (val != sc->F) s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f (to clear the table)", 23));
+ return(clear_profile_info(sc));
+ case SL_PROFILE_PREFIX:
+ if ((is_symbol(val)) || val == sc->F) {sc->profile_prefix = val; return(val);}
+ s7_starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a symbol or #f", 14));
+
+ case SL_ROOTLET_SIZE:
+ sl_unsettable_error_nr(sc, sym);
+
+ case SL_SAFETY:
+ if (!s7_is_integer(val))
+ 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));
+ sc->safety = s7_integer_clamped_if_gmp(sc, val);
+ return(val);
+
+ case SL_STACKTRACE_DEFAULTS:
+ return(sl_set_stacktrace_defaults(sc, sym,val));
+
+ case SL_STACK:
+ case SL_STACK_SIZE:
+ case SL_STACK_TOP:
+ sl_unsettable_error_nr(sc, sym);
+
+ case SL_UNDEFINED_CONSTANT_WARNINGS:
+ if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
+ sc->undefined_constant_warnings = s7_boolean(sc, val);
+ return(val);
+
+ case SL_UNDEFINED_IDENTIFIER_WARNINGS:
+ if (!is_boolean(val)) s7_starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]);
+ sc->undefined_identifier_warnings = s7_boolean(sc, val);
+ return(val);
+
+ case SL_VERSION:
+ sl_unsettable_error_nr(sc, sym);
+
+ 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));
+ }
+ return(sc->undefined);
+}
+
+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);
+ if (s7_starlet_symbol(sym) != SL_NO_FIELD)
+ return(s7_starlet_set_1(sc, sym, new_value));
+ }
+ return(sc->undefined);
+}
+
+s7_pointer s7_let_field_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value) {return(s7_starlet_set(sc, sym, new_value));}
+
+static void init_s7_starlet_immutable_field(void)
+{
+ s7_starlet_immutable_field = (bool *)Calloc(SL_NUM_FIELDS, sizeof(bool));
+ s7_starlet_immutable_field[SL_CATCHES] = true;
+ s7_starlet_immutable_field[SL_CPU_TIME] = true;
+ s7_starlet_immutable_field[SL_C_TYPES] = true;
+ s7_starlet_immutable_field[SL_FILE_NAMES] = true;
+ s7_starlet_immutable_field[SL_FILENAMES] = true;
+ s7_starlet_immutable_field[SL_FREE_HEAP_SIZE] = true;
+ s7_starlet_immutable_field[SL_GC_FREED] = true;
+ s7_starlet_immutable_field[SL_GC_TOTAL_FREED] = true;
+ s7_starlet_immutable_field[SL_GC_PROTECTED_OBJECTS] = true;
+ s7_starlet_immutable_field[SL_MEMORY_USAGE] = true;
+ s7_starlet_immutable_field[SL_MOST_NEGATIVE_FIXNUM] = true;
+ s7_starlet_immutable_field[SL_MOST_POSITIVE_FIXNUM] = true;
+ s7_starlet_immutable_field[SL_ROOTLET_SIZE] = true;
+ s7_starlet_immutable_field[SL_STACK] = true;
+ s7_starlet_immutable_field[SL_STACK_SIZE] = true;
+ s7_starlet_immutable_field[SL_STACK_TOP] = true;
+ s7_starlet_immutable_field[SL_VERSION] = true;
+ s7_starlet_immutable_field[SL_MAJOR_VERSION] = true;
+ s7_starlet_immutable_field[SL_MINOR_VERSION] = true;
+}
+
+#define NUM_INTEGER_WRAPPERS 4
+#define NUM_REAL_WRAPPERS 4
+
+/* ---------------- gdbinit annotated stacktrace ---------------- */
+#if (!MS_WINDOWS)
+/* s7bt, s7btfull: gdb stacktrace decoding */
+
+static const char *decoded_name(s7_scheme *sc, const s7_pointer p)
+{
+ if (p == sc->value) return("sc->value");
+ if (p == sc->args) return("sc->args");
+ if (p == sc->code) return("sc->code");
+ if (p == sc->cur_code) return("sc->cur_code");
+ if (p == sc->curlet) return("sc->curlet");
+ if (p == sc->nil) return("()");
+ if (p == sc->T) return("#t");
+ if (p == sc->F) return("#f");
+ if (p == eof_object) return("eof_object");
+ if (p == sc->undefined) return("undefined");
+ if (p == sc->unspecified) return("unspecified");
+ if (p == sc->no_value) return("no_value");
+ if (p == sc->unused) return("#<unused>");
+ if (p == sc->symbol_table) return("symbol_table");
+ if (p == sc->rootlet) return("rootlet");
+ if (p == sc->s7_starlet) return("*s7*"); /* this is the function */
+ if (p == sc->owlet) return("owlet");
+ if (p == sc->standard_input) return("*stdin*");
+ if (p == sc->standard_output) return("*stdout*");
+ if (p == sc->standard_error) return("*stderr*");
+ if (p == sc->else_symbol) return("else_symbol");
+ if (p == current_input_port(sc)) return("current-input-port");
+ if (p == current_output_port(sc)) return("current-output-port");
+ if (p == current_error_port(sc)) return("current-error_port");
+ if ((is_let(p)) && (is_unlet(p))) return("unlet");
+ {
+ s7_pointer wrapper;
+ int32_t i;
+ for (i = 0, wrapper = sc->string_wrappers; i < NUM_STRING_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("string-wrapper");
+ for (i = 0, wrapper = sc->integer_wrappers; i < NUM_INTEGER_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("integer-wrapper");
+ for (i = 0, wrapper = sc->real_wrappers; i < NUM_REAL_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("real-wrapper");
+ for (i = 0, wrapper = sc->c_pointer_wrappers; i < NUM_C_POINTER_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("c-pointer-wrapper");
+ }
+ return((p == sc->stack) ? "stack" : NULL);
+}
+
+static bool is_decodable(s7_scheme *sc, const s7_pointer p)
+{
+ int32_t i;
+ s7_pointer *tp = sc->heap;
+ s7_pointer *heap_top = (s7_pointer *)(sc->heap + sc->heap_size);
+
+ /* check symbol-table */
+ 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);
+ }
+
+ for (i = 0; i < NUM_CHARS; i++) if (p == chars[i]) return(true);
+ for (i = 0; i < NUM_SMALL_INTS; i++) if (p == small_ints[i]) return(true);
+
+ /* check the heap */
+ while (tp < heap_top)
+ if (p == (*tp++))
+ return(true);
+ return(false);
+}
+
+const char *s7_decode_bt(s7_scheme *sc);
+const char *s7_decode_bt(s7_scheme *sc)
+{
+ FILE *fp = fopen("gdb.txt", "r");
+ if (fp)
+ {
+ int64_t size;
+ size_t bytes;
+ bool in_quotes = false, old_stop = sc->stop_at_error;
+ uint8_t *bt;
+ block_t *bt_block;
+
+ sc->stop_at_error = false;
+ fseek(fp, 0, SEEK_END);
+ size = ftell(fp);
+ rewind(fp);
+
+ bt_block = mallocate(sc, (size + 1) * sizeof(uint8_t));
+ 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 ");
+ }
+ 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);
+ }}}}}}}}
+ liberate(sc, bt_block);
+ sc->stop_at_error = old_stop;
+ }
+ return("");
+}
+#endif
+
+
+/* -------------------------------- initialization -------------------------------- */
+static void init_fx_function(void)
+{
+ fx_function = (s7_function *)Calloc(NUM_OPS, sizeof(s7_function));
+
+ fx_function[HOP_SAFE_C_NC] = fx_c_nc;
+ fx_function[HOP_SAFE_C_S] = fx_c_s;
+ fx_function[HOP_SAFE_C_SC] = fx_c_sc;
+ fx_function[HOP_SAFE_C_CS] = fx_c_cs;
+ fx_function[HOP_SAFE_C_CQ] = fx_c_cq;
+ fx_function[HOP_SAFE_C_FF] = fx_c_ff;
+ fx_function[HOP_SAFE_C_SS] = fx_c_ss;
+ fx_function[HOP_SAFE_C_opNCq] = fx_c_opncq;
+ fx_function[HOP_SAFE_C_opSq] = fx_c_opsq;
+ fx_function[HOP_SAFE_C_opSSq] = fx_c_opssq;
+ fx_function[HOP_SAFE_C_opSCq] = fx_c_opscq;
+ fx_function[HOP_SAFE_C_opCSq] = fx_c_opcsq;
+ fx_function[HOP_SAFE_C_opSq_S] = fx_c_opsq_s;
+ fx_function[HOP_SAFE_C_opSq_C] = fx_c_opsq_c;
+ fx_function[HOP_SAFE_C_opSq_CS] = fx_c_opsq_cs;
+ fx_function[HOP_SAFE_C_S_opSq] = fx_c_s_opsq;
+ fx_function[HOP_SAFE_C_C_opSq] = fx_c_c_opsq;
+ fx_function[HOP_SAFE_C_opCSq_C] = fx_c_opcsq_c;
+ fx_function[HOP_SAFE_C_opCSq_S] = fx_c_opcsq_s;
+ fx_function[HOP_SAFE_C_S_opCSq] = fx_c_s_opcsq;
+ fx_function[HOP_SAFE_C_opSSq_C] = fx_c_opssq_c;
+ fx_function[HOP_SAFE_C_opSCq_C] = fx_c_opscq_c;
+ fx_function[HOP_SAFE_C_opSSq_S] = fx_c_opssq_s;
+ fx_function[HOP_SAFE_C_S_opSSq] = fx_c_s_opssq;
+ fx_function[HOP_SAFE_C_C_opSSq] = fx_c_c_opssq;
+ fx_function[HOP_SAFE_C_S_opSCq] = fx_c_s_opscq;
+ fx_function[HOP_SAFE_C_C_opSCq] = fx_c_c_opscq;
+ fx_function[HOP_SAFE_C_opSq_opSq] = fx_c_opsq_opsq;
+ fx_function[HOP_SAFE_C_opSq_opSSq] = fx_c_opsq_opssq;
+ fx_function[HOP_SAFE_C_opSSq_opSq] = fx_c_opssq_opsq;
+ fx_function[HOP_SAFE_C_opSSq_opSSq] = fx_c_opssq_opssq;
+ fx_function[HOP_SAFE_C_op_opSqq] = fx_c_op_opsqq;
+ fx_function[HOP_SAFE_C_op_S_opSqq] = fx_c_op_s_opsqq;
+ fx_function[HOP_SAFE_C_op_opSq_Sq] = fx_c_op_opsq_sq;
+ fx_function[HOP_SAFE_C_op_opSSqq_S] = fx_c_op_opssqq_s;
+
+ fx_function[HOP_SAFE_C_SSC] = fx_c_ssc;
+ fx_function[HOP_SAFE_C_SSS] = fx_c_sss;
+ fx_function[HOP_SAFE_C_SCS] = fx_c_scs;
+ fx_function[HOP_SAFE_C_SCC] = fx_c_scc;
+ fx_function[HOP_SAFE_C_CSS] = fx_c_css;
+ fx_function[HOP_SAFE_C_CSC] = fx_c_csc;
+ fx_function[HOP_SAFE_C_CCS] = fx_c_ccs;
+ fx_function[HOP_SAFE_C_NS] = fx_c_ns;
+
+ fx_function[HOP_SAFE_C_A] = fx_c_a;
+ fx_function[HOP_SAFE_C_AA] = fx_c_aa;
+ fx_function[HOP_SAFE_C_SA] = fx_c_sa;
+ fx_function[HOP_SAFE_C_AS] = fx_c_as;
+ fx_function[HOP_SAFE_C_CA] = fx_c_ca;
+ fx_function[HOP_SAFE_C_AC] = fx_c_ac;
+ fx_function[HOP_SAFE_C_AAA] = fx_c_aaa;
+ fx_function[HOP_SAFE_C_CAC] = fx_c_cac;
+ fx_function[HOP_SAFE_C_CSA] = fx_c_csa;
+ fx_function[HOP_SAFE_C_SCA] = fx_c_sca;
+ fx_function[HOP_SAFE_C_SAS] = fx_c_sas;
+ fx_function[HOP_SAFE_C_SAA] = fx_c_saa;
+ fx_function[HOP_SAFE_C_SSA] = fx_c_ssa;
+ fx_function[HOP_SAFE_C_ASS] = fx_c_ass;
+ fx_function[HOP_SAFE_C_AGG] = fx_c_agg;
+ fx_function[HOP_SAFE_C_ALL_CA] = fx_c_all_ca;
+ fx_function[HOP_SAFE_C_NA] = fx_c_na;
+ fx_function[HOP_SAFE_C_4A] = fx_c_4a;
+ fx_function[HOP_SAFE_C_opAq] = fx_c_opaq;
+ fx_function[HOP_SAFE_C_opAAq] = fx_c_opaaq;
+ fx_function[HOP_SAFE_C_opAAAq] = fx_c_opaaaq;
+ fx_function[HOP_SAFE_C_opAq_S] = fx_c_opaq_s;
+ fx_function[HOP_SAFE_C_S_opAq] = fx_c_s_opaq;
+ fx_function[HOP_SAFE_C_S_opAAq] = fx_c_s_opaaq;
+
+ fx_function[HOP_HASH_TABLE_INCREMENT] = fx_hash_table_increment;
+
+ fx_function[HOP_SAFE_THUNK_A] = fx_safe_thunk_a;
+ fx_function[HOP_SAFE_CLOSURE_S_A] = fx_safe_closure_s_a;
+ fx_function[HOP_SAFE_CLOSURE_A_A] = fx_safe_closure_a_a;
+ fx_function[HOP_SAFE_CLOSURE_SS_A] = fx_safe_closure_ss_a;
+ fx_function[HOP_SAFE_CLOSURE_AA_A] = fx_safe_closure_aa_a;
+ fx_function[HOP_SAFE_CLOSURE_3S_A] = fx_safe_closure_3s_a;
+ fx_function[HOP_SAFE_CLOSURE_S_TO_S] = fx_safe_closure_s_to_s;
+ fx_function[HOP_SAFE_CLOSURE_S_TO_SC] = fx_safe_closure_s_to_sc;
+ fx_function[HOP_SAFE_CLOSURE_A_TO_SC] = fx_safe_closure_a_to_sc;
+
+ fx_function[OP_COND_NA_NA] = fx_cond_na_na;
+#if (!WITH_GMP)
+ fx_function[OP_CASE_A_I_S_A] = fx_case_a_i_s_a;
+#endif
+ fx_function[OP_CASE_A_E_S_A] = fx_case_a_e_s_a;
+ fx_function[OP_CASE_A_G_S_A] = fx_case_a_g_s_a;
+ fx_function[OP_CASE_A_S_G_A] = fx_case_a_s_g_a;
+ fx_function[OP_IF_A_C_C] = fx_if_a_c_c;
+ fx_function[OP_IF_A_A] = fx_if_a_a;
+ fx_function[OP_IF_S_A_A] = fx_if_s_a_a;
+ fx_function[OP_IF_A_A_A] = fx_if_a_a_a;
+ fx_function[OP_IF_AND2_S_A] = fx_if_and2_s_a;
+ fx_function[OP_IF_NOT_A_A] = fx_if_not_a_a;
+ fx_function[OP_IF_NOT_A_A_A] = fx_if_not_a_a_a;
+ fx_function[OP_IF_IS_TYPE_S_A_A] = fx_if_is_type_s_a_a;
+ fx_function[OP_OR_2A] = fx_or_2a;
+ fx_function[OP_OR_S_2] = fx_or_s_2;
+ fx_function[OP_OR_S_TYPE_2] = fx_or_s_type_2;
+ fx_function[OP_OR_3A] = fx_or_3a;
+ fx_function[OP_OR_N] = fx_or_n;
+ fx_function[OP_AND_2A] = fx_and_2a;
+ fx_function[OP_AND_S_2] = fx_and_s_2;
+ fx_function[OP_AND_3A] = fx_and_3a;
+ fx_function[OP_AND_N] = fx_and_n;
+ fx_function[OP_BEGIN_NA] = fx_begin_na;
+ fx_function[OP_BEGIN_AA] = fx_begin_aa;
+ fx_function[OP_LET_TEMP_A_A] = fx_let_temp_a_a;
+ fx_function[OP_WITH_LET_S] = fx_with_let_s;
+
+ fx_function[OP_IMPLICIT_S7_STARLET_REF_S] = fx_implicit_s7_starlet_ref_s;
+ fx_function[OP_IMPLICIT_LET_REF_C] = fx_implicit_let_ref_c;
+ fx_function[OP_IMPLICIT_HASH_TABLE_REF_A] = fx_implicit_hash_table_ref_a;
+ fx_function[OP_IMPLICIT_PAIR_REF_A] = fx_implicit_pair_ref_a;
+ fx_function[OP_IMPLICIT_C_OBJECT_REF_A] = fx_implicit_c_object_ref_a;
+ fx_function[OP_IMPLICIT_VECTOR_REF_A] = fx_implicit_vector_ref_a;
+
+ /* these are ok even if a "z" branch is taken -- in that case the body does not have the is_optimized bit, so is_fxable returns false */
+ fx_function[OP_TC_AND_A_OR_A_LA] = fx_tc_and_a_or_a_la;
+ fx_function[OP_TC_OR_A_AND_A_LA] = fx_tc_or_a_and_a_la;
+ fx_function[OP_TC_OR_A_A_AND_A_A_LA] = fx_tc_or_a_a_and_a_a_la;
+ fx_function[OP_TC_AND_A_OR_A_LAA] = fx_tc_and_a_or_a_laa;
+ fx_function[OP_TC_OR_A_AND_A_LAA] = fx_tc_or_a_and_a_laa;
+ fx_function[OP_TC_AND_A_OR_A_L3A] = fx_tc_and_a_or_a_l3a;
+ fx_function[OP_TC_OR_A_AND_A_L3A] = fx_tc_or_a_and_a_l3a;
+ fx_function[OP_TC_AND_A_OR_A_A_LA] = fx_tc_and_a_or_a_a_la;
+ fx_function[OP_TC_OR_A_AND_A_A_LA] = fx_tc_or_a_and_a_a_la;
+ fx_function[OP_TC_IF_A_Z_LA] = fx_tc_if_a_z_la;
+ fx_function[OP_TC_IF_A_LA_Z] = fx_tc_if_a_la_z;
+ fx_function[OP_TC_COND_A_Z_LA] = fx_tc_cond_a_z_la;
+ fx_function[OP_TC_COND_A_LA_Z] = fx_tc_cond_a_la_z;
+ fx_function[OP_TC_IF_A_Z_LAA] = fx_tc_if_a_z_laa;
+ fx_function[OP_TC_IF_A_LAA_Z] = fx_tc_if_a_laa_z;
+ fx_function[OP_TC_COND_A_Z_LAA] = fx_tc_cond_a_z_laa;
+ fx_function[OP_TC_COND_A_LAA_Z] = fx_tc_cond_a_laa_z;
+ fx_function[OP_TC_IF_A_Z_L3A] = fx_tc_if_a_z_l3a;
+ fx_function[OP_TC_IF_A_L3A_Z] = fx_tc_if_a_l3a_z;
+ fx_function[OP_TC_IF_A_Z_IF_A_Z_LA] = fx_tc_if_a_z_if_a_z_la;
+ fx_function[OP_TC_IF_A_Z_IF_A_LA_Z] = fx_tc_if_a_z_if_a_la_z;
+ fx_function[OP_TC_COND_A_Z_A_Z_LA] = fx_tc_cond_a_z_a_z_la;
+ fx_function[OP_TC_COND_A_Z_A_LA_Z] = fx_tc_cond_a_z_a_la_z;
+ fx_function[OP_TC_AND_A_IF_A_Z_LA] = fx_tc_and_a_if_a_z_la;
+ fx_function[OP_TC_AND_A_IF_A_LA_Z] = fx_tc_and_a_if_a_la_z;
+ fx_function[OP_TC_IF_A_Z_IF_A_LAA_Z] = fx_tc_if_a_z_if_a_laa_z;
+ fx_function[OP_TC_IF_A_Z_IF_A_Z_LAA] = fx_tc_if_a_z_if_a_z_laa;
+ fx_function[OP_TC_COND_A_Z_A_Z_LAA] = fx_tc_cond_a_z_a_z_laa;
+ fx_function[OP_TC_COND_A_Z_A_LAA_Z] = fx_tc_cond_a_z_a_laa_z;
+ fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A] = fx_tc_if_a_z_if_a_l3a_l3a;
+ fx_function[OP_TC_CASE_LA] = fx_tc_case_la;
+ fx_function[OP_TC_OR_A_AND_A_A_L3A] = fx_tc_or_a_and_a_a_l3a;
+ fx_function[OP_TC_LET_IF_A_Z_LA] = fx_tc_let_if_a_z_la;
+ fx_function[OP_TC_LET_IF_A_Z_LAA] = fx_tc_let_if_a_z_laa;
+ fx_function[OP_TC_LET_WHEN_LAA] = fx_tc_let_when_laa;
+ fx_function[OP_TC_LET_UNLESS_LAA] = fx_tc_let_unless_laa;
+ fx_function[OP_TC_LET_COND] = fx_tc_let_cond;
+ fx_function[OP_TC_COND_A_Z_A_LAA_LAA] = fx_tc_cond_a_z_a_laa_laa;
+ fx_function[OP_TC_WHEN_LA] = fx_tc_when_la;
+ fx_function[OP_TC_WHEN_LAA] = fx_tc_when_laa;
+ fx_function[OP_TC_WHEN_L3A] = fx_tc_when_l3a;
+
+ fx_function[OP_RECUR_IF_A_A_opA_LAq] = fx_recur_if_a_a_opa_laq;
+ fx_function[OP_RECUR_IF_A_opA_LAq_A] = fx_recur_if_a_opa_laq_a;
+ fx_function[OP_RECUR_IF_A_A_AND_A_LAA_LAA] = fx_recur_if_a_a_and_a_laa_laa;
+ fx_function[OP_RECUR_COND_A_A_A_A_opLA_LAq] = fx_recur_cond_a_a_a_a_opla_laq; /* very few calls (only s7test) */
+ fx_function[OP_RECUR_AND_A_OR_A_LAA_LAA] = fx_recur_and_a_or_a_laa_laa; /* very few calls (lint) */
+}
+
+static void init_opt_functions(s7_scheme *sc)
+{
+#if (!WITH_PURE_S7)
+ s7_set_b_7pp_function(sc, global_value(sc->char_ci_lt_symbol), char_ci_lt_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->char_ci_leq_symbol), char_ci_leq_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->char_ci_gt_symbol), char_ci_gt_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->char_ci_geq_symbol), char_ci_geq_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->char_ci_eq_symbol), char_ci_eq_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->string_ci_lt_symbol), string_ci_lt_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->string_ci_leq_symbol), string_ci_leq_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->string_ci_gt_symbol), string_ci_gt_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->string_ci_geq_symbol), string_ci_geq_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->string_ci_eq_symbol), string_ci_eq_b_7pp);
+
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_lt_symbol), char_ci_lt_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_leq_symbol), char_ci_leq_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_gt_symbol), char_ci_gt_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_geq_symbol), char_ci_geq_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->char_ci_eq_symbol), char_ci_eq_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_lt_symbol), string_ci_lt_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_leq_symbol), string_ci_leq_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_gt_symbol), string_ci_gt_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_geq_symbol), string_ci_geq_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->string_ci_eq_symbol), string_ci_eq_b_unchecked);
+
+ s7_set_p_pp_function(sc, global_value(sc->vector_append_symbol), vector_append_p_pp);
+ s7_set_p_ppp_function(sc, global_value(sc->vector_append_symbol), vector_append_p_ppp);
+ s7_set_i_i_function(sc, global_value(sc->integer_length_symbol), integer_length_i_i);
+ s7_set_i_7p_function(sc, global_value(sc->string_length_symbol), string_length_i_7p);
+ s7_set_i_7p_function(sc, global_value(sc->vector_length_symbol), vector_length_i_7p);
+ s7_set_p_p_function(sc, global_value(sc->vector_to_list_symbol), vector_to_list_p_p);
+ s7_set_p_p_function(sc, global_value(sc->string_to_list_symbol), string_to_list_p_p);
+ s7_set_p_p_function(sc, global_value(sc->vector_length_symbol), vector_length_p_p);
+ s7_set_b_7p_function(sc, global_value(sc->is_exact_symbol), is_exact_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->is_inexact_symbol), is_inexact_b_7p);
+ s7_set_p_p_function(sc, global_value(sc->exact_to_inexact_symbol), exact_to_inexact_p_p);
+ s7_set_p_p_function(sc, global_value(sc->inexact_to_exact_symbol), inexact_to_exact_p_p);
+#endif
+
+ s7_set_p_pp_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_p_pp);
+ s7_set_d_7pi_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_d_7pi);
+ s7_set_d_7pii_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_d_7pii);
+ s7_set_d_7piii_function(sc, global_value(sc->float_vector_ref_symbol), float_vector_ref_d_7piii);
+ s7_set_d_7pid_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_d_7pid);
+ s7_set_d_7piid_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_d_7piid);
+ s7_set_d_7piiid_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_d_7piiid);
+
+ s7_set_p_pp_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_p_pp);
+ s7_set_i_7pi_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_i_7pi);
+ s7_set_i_7pii_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_i_7pii);
+ s7_set_i_7piii_function(sc, global_value(sc->int_vector_ref_symbol), int_vector_ref_i_7piii);
+ s7_set_i_7pii_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_i_7pii);
+ s7_set_i_7piii_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_i_7piii);
+
+ s7_set_i_7pi_function(sc, global_value(sc->byte_vector_ref_symbol), byte_vector_ref_i_7pi);
+ s7_set_i_7pii_function(sc, global_value(sc->byte_vector_ref_symbol), byte_vector_ref_i_7pii);
+ s7_set_i_7pii_function(sc, global_value(sc->byte_vector_set_symbol), byte_vector_set_i_7pii);
+ s7_set_i_7piii_function(sc, global_value(sc->byte_vector_set_symbol), byte_vector_set_i_7piii);
+
+ s7_set_p_pp_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pp);
+ s7_set_p_pi_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pi);
+ s7_set_p_pii_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pii);
+ s7_set_p_pip_function(sc, global_value(sc->vector_set_symbol), vector_set_p_pip);
+ s7_set_p_piip_function(sc, global_value(sc->vector_set_symbol), vector_set_p_piip);
+ s7_set_p_pi_unchecked_function(sc, global_value(sc->vector_ref_symbol), vector_ref_p_pi_unchecked);
+ s7_set_p_pip_unchecked_function(sc, global_value(sc->vector_set_symbol), vector_set_p_pip_unchecked);
+ s7_set_p_ppp_function(sc, global_value(sc->vector_set_symbol), vector_set_p_ppp);
+ s7_set_p_ppp_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_p_ppp);
+
+ s7_set_p_pp_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pp);
+ s7_set_p_pi_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pi);
+ s7_set_p_pip_function(sc, global_value(sc->list_set_symbol), list_set_p_pip);
+ s7_set_p_pi_unchecked_function(sc, global_value(sc->list_ref_symbol), list_ref_p_pi_unchecked);
+ s7_set_p_pip_unchecked_function(sc, global_value(sc->list_set_symbol), list_set_p_pip_unchecked);
+ s7_set_p_p_function(sc, global_value(sc->cyclic_sequences_symbol), cyclic_sequences_p_p);
+ s7_set_p_pp_function(sc, global_value(sc->let_ref_symbol), let_ref);
+ s7_set_p_ppp_function(sc, global_value(sc->let_set_symbol), let_set_2); /* originally named "let_set" but that was unsearchable */
+ s7_set_p_pi_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pi);
+ s7_set_p_pp_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pp);
+ s7_set_p_pip_function(sc, global_value(sc->string_set_symbol), string_set_p_pip);
+ s7_set_p_pi_unchecked_function(sc, global_value(sc->string_ref_symbol), string_ref_p_pi_unchecked);
+ s7_set_p_pip_unchecked_function(sc, global_value(sc->string_set_symbol), string_set_p_pip_unchecked);
+ s7_set_p_pp_function(sc, global_value(sc->hash_table_ref_symbol), hash_table_ref_p_pp);
+ s7_set_p_ppp_function(sc, global_value(sc->hash_table_set_symbol), hash_table_set_p_ppp);
+
+ s7_set_p_ii_function(sc, global_value(sc->complex_symbol), complex_p_ii);
+ s7_set_p_dd_function(sc, global_value(sc->complex_symbol), complex_p_dd);
+ s7_set_p_i_function(sc, global_value(sc->number_to_string_symbol), number_to_string_p_i);
+ s7_set_p_p_function(sc, global_value(sc->number_to_string_symbol), number_to_string_p_p);
+ s7_set_p_pp_function(sc, global_value(sc->number_to_string_symbol), number_to_string_p_pp);
+ s7_set_p_p_function(sc, global_value(sc->string_to_number_symbol), string_to_number_p_p);
+ s7_set_p_pp_function(sc, global_value(sc->string_to_number_symbol), string_to_number_p_pp);
+
+ s7_set_p_p_function(sc, global_value(sc->car_symbol), car_p_p);
+ s7_set_p_pp_function(sc, global_value(sc->set_car_symbol), set_car_p_pp);
+ s7_set_p_p_function(sc, global_value(sc->cdr_symbol), cdr_p_p);
+ s7_set_p_pp_function(sc, global_value(sc->set_cdr_symbol), set_cdr_p_pp);
+ s7_set_p_p_function(sc, global_value(sc->caar_symbol), caar_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cadr_symbol), cadr_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cdar_symbol), cdar_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cddr_symbol), cddr_p_p);
+ s7_set_p_p_function(sc, global_value(sc->caddr_symbol), caddr_p_p);
+ s7_set_p_p_function(sc, global_value(sc->caadr_symbol), caadr_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cadar_symbol), cadar_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cdddr_symbol), cdddr_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cdadr_symbol), cdadr_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cddar_symbol), cddar_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cdaar_symbol), cdaar_p_p);
+ s7_set_p_p_function(sc, global_value(sc->caaar_symbol), caaar_p_p);
+ s7_set_p_p_function(sc, global_value(sc->caddar_symbol), caddar_p_p);
+ s7_set_p_p_function(sc, global_value(sc->caaddr_symbol), caaddr_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cadddr_symbol), cadddr_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cadadr_symbol), cadadr_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cddadr_symbol), cddadr_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cdddar_symbol), cdddar_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cddddr_symbol), cddddr_p_p);
+
+ s7_set_p_p_function(sc, global_value(sc->string_symbol), string_p_p);
+ s7_set_p_p_function(sc, global_value(sc->string_to_symbol_symbol), string_to_symbol_p_p);
+ s7_set_p_p_function(sc, global_value(sc->symbol_to_string_symbol), symbol_to_string_p_p);
+ s7_set_p_p_function(sc, global_value(sc->symbol_symbol), string_to_symbol_p_p);
+ s7_set_p_pp_function(sc, global_value(sc->symbol_symbol), symbol_p_pp);
+ s7_set_p_function(sc, global_value(sc->newline_symbol), newline_p);
+ s7_set_p_p_function(sc, global_value(sc->newline_symbol), newline_p_p);
+ s7_set_p_p_function(sc, global_value(sc->display_symbol), display_p_p);
+ s7_set_p_pp_function(sc, global_value(sc->display_symbol), display_p_pp);
+ s7_set_p_p_function(sc, global_value(sc->write_symbol), write_p_p);
+ s7_set_p_pp_function(sc, global_value(sc->write_symbol), write_p_pp);
+ s7_set_p_p_function(sc, global_value(sc->write_char_symbol), write_char_p_p);
+ s7_set_p_pp_function(sc, global_value(sc->write_char_symbol), write_char_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->write_string_symbol), write_string_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->read_line_symbol), read_line_p_pp);
+ s7_set_p_p_function(sc, global_value(sc->read_line_symbol), read_line_p_p);
+
+ s7_set_p_pp_function(sc, global_value(sc->inlet_symbol), inlet_p_pp);
+ s7_set_i_7p_function(sc, global_value(sc->port_line_number_symbol), s7_port_line_number);
+ s7_set_p_pp_function(sc, global_value(sc->cons_symbol), cons_p_pp);
+ s7_set_p_function(sc, global_value(sc->open_output_string_symbol), s7_open_output_string);
+ s7_set_p_ppi_function(sc, global_value(sc->char_position_symbol), char_position_p_ppi);
+ s7_set_p_pp_function(sc, global_value(sc->append_symbol), s7_append);
+ s7_set_p_pp_function(sc, global_value(sc->string_append_symbol), string_append_p_pp);
+ s7_set_p_ppp_function(sc, global_value(sc->append_symbol), append_p_ppp);
+ s7_set_p_function(sc, global_value(sc->values_symbol), values_p);
+ s7_set_p_p_function(sc, global_value(sc->values_symbol), values_p_p);
+ s7_set_p_pp_function(sc, global_value(sc->member_symbol), member_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->assoc_symbol), assoc_p_pp);
+
+ s7_set_i_i_function(sc, global_value(sc->abs_symbol), abs_i_i);
+ s7_set_d_d_function(sc, global_value(sc->abs_symbol), abs_d_d);
+ s7_set_p_p_function(sc, global_value(sc->abs_symbol), abs_p_p);
+ s7_set_i_i_function(sc, global_value(sc->magnitude_symbol), magnitude_i_i);
+ s7_set_d_d_function(sc, global_value(sc->magnitude_symbol), magnitude_d_d);
+ s7_set_p_p_function(sc, global_value(sc->magnitude_symbol), magnitude_p_p);
+
+ s7_set_p_d_function(sc, global_value(sc->sin_symbol), sin_p_d);
+ s7_set_p_p_function(sc, global_value(sc->sin_symbol), sin_p_p);
+ s7_set_p_d_function(sc, global_value(sc->cos_symbol), cos_p_d);
+ s7_set_p_p_function(sc, global_value(sc->cos_symbol), cos_p_p);
+ s7_set_p_p_function(sc, global_value(sc->tan_symbol), tan_p_p);
+ s7_set_p_p_function(sc, global_value(sc->asin_symbol), asin_p_p);
+ s7_set_p_p_function(sc, global_value(sc->acos_symbol), acos_p_p);
+ s7_set_p_p_function(sc, global_value(sc->sinh_symbol), sinh_p_p);
+ s7_set_p_p_function(sc, global_value(sc->cosh_symbol), cosh_p_p);
+ s7_set_p_p_function(sc, global_value(sc->asinh_symbol), asinh_p_p);
+ s7_set_p_p_function(sc, global_value(sc->acosh_symbol), acosh_p_p);
+ s7_set_p_p_function(sc, global_value(sc->atanh_symbol), atanh_p_p);
+ s7_set_p_p_function(sc, global_value(sc->tanh_symbol), tanh_p_p);
+ s7_set_d_d_function(sc, global_value(sc->sin_symbol), sin_d_d);
+ s7_set_d_d_function(sc, global_value(sc->cos_symbol), cos_d_d);
+ s7_set_d_d_function(sc, global_value(sc->sinh_symbol), sinh_d_d);
+ s7_set_p_d_function(sc, global_value(sc->sinh_symbol), sinh_p_d);
+ s7_set_d_d_function(sc, global_value(sc->cosh_symbol), cosh_d_d);
+ s7_set_p_d_function(sc, global_value(sc->cosh_symbol), cosh_p_d);
+ s7_set_d_d_function(sc, global_value(sc->exp_symbol), exp_d_d);
+ s7_set_p_d_function(sc, global_value(sc->exp_symbol), exp_p_d);
+
+ s7_set_p_d_function(sc, global_value(sc->rationalize_symbol), rationalize_p_d);
+ s7_set_p_i_function(sc, global_value(sc->rationalize_symbol), rationalize_p_i);
+ s7_set_i_i_function(sc, global_value(sc->rationalize_symbol), rationalize_i_i);
+ s7_set_p_p_function(sc, global_value(sc->truncate_symbol), truncate_p_p);
+ s7_set_p_p_function(sc, global_value(sc->round_symbol), round_p_p);
+ s7_set_p_p_function(sc, global_value(sc->ceiling_symbol), ceiling_p_p);
+ s7_set_p_p_function(sc, global_value(sc->floor_symbol), floor_p_p);
+ s7_set_p_pp_function(sc, global_value(sc->max_symbol), max_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->min_symbol), min_p_pp);
+ s7_set_p_p_function(sc, global_value(sc->sqrt_symbol), sqrt_p_p);
+#if (!WITH_GMP)
+ s7_set_p_pp_function(sc, global_value(sc->expt_symbol), expt_p_pp);
+ /* same problem affects big_log|logior|logand|logxor|lcm|gcd|rationalize|remainder|modulo -- *_p_* will fail in gmp s7 */
+ s7_set_p_d_function(sc, global_value(sc->ceiling_symbol), ceiling_p_d);
+ s7_set_p_d_function(sc, global_value(sc->floor_symbol), floor_p_d);
+ s7_set_p_d_function(sc, global_value(sc->truncate_symbol), truncate_p_d);
+ s7_set_p_d_function(sc, global_value(sc->round_symbol), round_p_d);
+#endif
+ s7_set_d_7dd_function(sc, global_value(sc->remainder_symbol), remainder_d_7dd);
+ s7_set_i_7ii_function(sc, global_value(sc->remainder_symbol), remainder_i_7ii);
+ s7_set_i_7ii_function(sc, global_value(sc->quotient_symbol), quotient_i_7ii);
+ s7_set_d_7dd_function(sc, global_value(sc->modulo_symbol), modulo_d_7dd);
+ s7_set_i_ii_function(sc, global_value(sc->modulo_symbol), modulo_i_ii);
+ s7_set_p_dd_function(sc, global_value(sc->multiply_symbol), mul_p_dd);
+ s7_set_p_dd_function(sc, global_value(sc->add_symbol), add_p_dd);
+ s7_set_p_ii_function(sc, global_value(sc->add_symbol), add_p_ii);
+ s7_set_p_dd_function(sc, global_value(sc->subtract_symbol), subtract_p_dd);
+ s7_set_p_ii_function(sc, global_value(sc->subtract_symbol), subtract_p_ii);
+
+ s7_set_p_pp_function(sc, global_value(sc->modulo_symbol), modulo_p_pp);
+ s7_set_p_pi_function(sc, global_value(sc->modulo_symbol), modulo_p_pi);
+ s7_set_p_pp_function(sc, global_value(sc->remainder_symbol), remainder_p_pp);
+ s7_set_p_pi_function(sc, global_value(sc->remainder_symbol), remainder_p_pi);
+ s7_set_p_pp_function(sc, global_value(sc->quotient_symbol), quotient_p_pp);
+ s7_set_p_pi_function(sc, global_value(sc->quotient_symbol), quotient_p_pi);
+ s7_set_p_pp_function(sc, global_value(sc->subtract_symbol), subtract_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->add_symbol), add_p_pp);
+ s7_set_p_ppp_function(sc, global_value(sc->add_symbol), add_p_ppp);
+ s7_set_p_pp_function(sc, global_value(sc->multiply_symbol), multiply_p_pp);
+ s7_set_p_ppp_function(sc, global_value(sc->multiply_symbol), multiply_p_ppp);
+ s7_set_p_pp_function(sc, global_value(sc->divide_symbol), divide_p_pp);
+ s7_set_p_p_function(sc, global_value(sc->divide_symbol), invert_p_p);
+ s7_set_p_p_function(sc, global_value(sc->subtract_symbol), negate_p_p);
+ s7_set_p_p_function(sc, global_value(sc->is_even_symbol), is_even_p_p);
+ s7_set_p_p_function(sc, global_value(sc->is_odd_symbol), is_odd_p_p);
+
+ s7_set_p_p_function(sc, global_value(sc->random_symbol), random_p_p);
+ s7_set_d_7d_function(sc, global_value(sc->random_symbol), random_d_7d);
+ s7_set_i_7i_function(sc, global_value(sc->random_symbol), random_i_7i);
+
+ s7_set_p_d_function(sc, global_value(sc->float_vector_symbol), float_vector_p_d);
+ s7_set_p_i_function(sc, global_value(sc->int_vector_symbol), int_vector_p_i);
+ s7_set_p_i_function(sc, global_value(sc->float_vector_symbol), float_vector_p_i);
+ s7_set_i_i_function(sc, global_value(sc->round_symbol), round_i_i);
+ s7_set_i_i_function(sc, global_value(sc->floor_symbol), floor_i_i);
+ s7_set_i_i_function(sc, global_value(sc->ceiling_symbol), ceiling_i_i);
+ s7_set_i_i_function(sc, global_value(sc->truncate_symbol), truncate_i_i);
+
+ s7_set_d_d_function(sc, global_value(sc->tan_symbol), tan_d_d);
+ s7_set_d_dd_function(sc, global_value(sc->atan_symbol), atan_d_dd);
+ s7_set_d_d_function(sc, global_value(sc->tanh_symbol), tanh_d_d);
+ s7_set_p_p_function(sc, global_value(sc->exp_symbol), exp_p_p);
+#if (!WITH_GMP)
+ s7_set_i_7ii_function(sc, global_value(sc->ash_symbol), ash_i_7ii);
+ s7_set_i_7d_function(sc, global_value(sc->round_symbol), round_i_7d);
+ s7_set_i_7d_function(sc, global_value(sc->floor_symbol), floor_i_7d);
+ s7_set_i_7d_function(sc, global_value(sc->ceiling_symbol), ceiling_i_7d);
+ s7_set_i_7p_function(sc, global_value(sc->floor_symbol), floor_i_7p);
+ s7_set_i_7p_function(sc, global_value(sc->ceiling_symbol), ceiling_i_7p);
+ s7_set_i_7d_function(sc, global_value(sc->truncate_symbol), truncate_i_7d);
+#endif
+
+ s7_set_d_d_function(sc, global_value(sc->add_symbol), add_d_d);
+ s7_set_d_d_function(sc, global_value(sc->subtract_symbol), subtract_d_d);
+ s7_set_d_d_function(sc, global_value(sc->multiply_symbol), multiply_d_d);
+ s7_set_d_7d_function(sc, global_value(sc->divide_symbol), divide_d_7d);
+ s7_set_d_dd_function(sc, global_value(sc->add_symbol), add_d_dd);
+ s7_set_d_id_function(sc, global_value(sc->add_symbol), add_d_id);
+ s7_set_d_dd_function(sc, global_value(sc->subtract_symbol), subtract_d_dd);
+ s7_set_d_id_function(sc, global_value(sc->subtract_symbol), subtract_d_id);
+ s7_set_d_dd_function(sc, global_value(sc->multiply_symbol), multiply_d_dd);
+ s7_set_d_id_function(sc, global_value(sc->multiply_symbol), multiply_d_id);
+ s7_set_d_7dd_function(sc, global_value(sc->divide_symbol), divide_d_7dd);
+ s7_set_d_ddd_function(sc, global_value(sc->add_symbol), add_d_ddd);
+ s7_set_d_ddd_function(sc, global_value(sc->subtract_symbol), subtract_d_ddd);
+ s7_set_d_ddd_function(sc, global_value(sc->multiply_symbol), multiply_d_ddd);
+ s7_set_d_dddd_function(sc, global_value(sc->add_symbol), add_d_dddd);
+ s7_set_d_dddd_function(sc, global_value(sc->subtract_symbol), subtract_d_dddd);
+ s7_set_d_dddd_function(sc, global_value(sc->multiply_symbol), multiply_d_dddd);
+ s7_set_p_i_function(sc, global_value(sc->divide_symbol), divide_p_i);
+ s7_set_p_ii_function(sc, global_value(sc->divide_symbol), divide_p_ii);
+ s7_set_d_dd_function(sc, global_value(sc->max_symbol), max_d_dd);
+ s7_set_d_dd_function(sc, global_value(sc->min_symbol), min_d_dd);
+ s7_set_d_ddd_function(sc, global_value(sc->max_symbol), max_d_ddd);
+ s7_set_d_ddd_function(sc, global_value(sc->min_symbol), min_d_ddd);
+ s7_set_d_dddd_function(sc, global_value(sc->max_symbol), max_d_dddd);
+ s7_set_d_dddd_function(sc, global_value(sc->min_symbol), min_d_dddd);
+ s7_set_i_ii_function(sc, global_value(sc->max_symbol), max_i_ii);
+ s7_set_i_ii_function(sc, global_value(sc->min_symbol), min_i_ii);
+ s7_set_i_iii_function(sc, global_value(sc->max_symbol), max_i_iii);
+ s7_set_i_iii_function(sc, global_value(sc->min_symbol), min_i_iii);
+ s7_set_i_i_function(sc, global_value(sc->subtract_symbol), subtract_i_i);
+ s7_set_i_ii_function(sc, global_value(sc->add_symbol), add_i_ii);
+ s7_set_i_iii_function(sc, global_value(sc->add_symbol), add_i_iii);
+ s7_set_i_ii_function(sc, global_value(sc->subtract_symbol), subtract_i_ii);
+ s7_set_i_iii_function(sc, global_value(sc->subtract_symbol), subtract_i_iii);
+ s7_set_i_ii_function(sc, global_value(sc->multiply_symbol), multiply_i_ii);
+ s7_set_i_iii_function(sc, global_value(sc->multiply_symbol), multiply_i_iii);
+
+ s7_set_i_i_function(sc, global_value(sc->lognot_symbol), lognot_i_i);
+ s7_set_i_ii_function(sc, global_value(sc->logior_symbol), logior_i_ii);
+ s7_set_i_ii_function(sc, global_value(sc->logxor_symbol), logxor_i_ii);
+ s7_set_i_ii_function(sc, global_value(sc->logand_symbol), logand_i_ii);
+ s7_set_i_iii_function(sc, global_value(sc->logior_symbol), logior_i_iii);
+ s7_set_i_iii_function(sc, global_value(sc->logxor_symbol), logxor_i_iii);
+ s7_set_i_iii_function(sc, global_value(sc->logand_symbol), logand_i_iii);
+ s7_set_b_7ii_function(sc, global_value(sc->logbit_symbol), logbit_b_7ii);
+ s7_set_b_7pp_function(sc, global_value(sc->logbit_symbol), logbit_b_7pp);
+
+ s7_set_i_7p_function(sc, global_value(sc->numerator_symbol), numerator_i_7p);
+ s7_set_i_7p_function(sc, global_value(sc->denominator_symbol), denominator_i_7p);
+ s7_set_i_7p_function(sc, global_value(sc->char_to_integer_symbol), char_to_integer_i_7p);
+ s7_set_i_7p_function(sc, global_value(sc->hash_table_entries_symbol), hash_table_entries_i_7p);
+ s7_set_i_7p_function(sc, global_value(sc->tree_leaves_symbol), tree_leaves_i_7p);
+ s7_set_p_p_function(sc, global_value(sc->char_to_integer_symbol), char_to_integer_p_p);
+
+ s7_set_b_p_function(sc, global_value(sc->is_boolean_symbol), s7_is_boolean);
+ s7_set_b_p_function(sc, global_value(sc->is_byte_symbol), is_byte);
+ s7_set_b_p_function(sc, global_value(sc->is_byte_vector_symbol), is_byte_vector_b_p);
+ s7_set_b_p_function(sc, global_value(sc->is_c_object_symbol), s7_is_c_object);
+ s7_set_b_p_function(sc, global_value(sc->is_char_symbol), s7_is_character);
+ s7_set_b_p_function(sc, global_value(sc->is_complex_symbol), s7_is_complex);
+ s7_set_b_p_function(sc, global_value(sc->is_continuation_symbol), is_continuation_b_p);
+ s7_set_b_p_function(sc, global_value(sc->is_c_pointer_symbol), s7_is_c_pointer);
+ s7_set_b_p_function(sc, global_value(sc->is_dilambda_symbol), s7_is_dilambda);
+ s7_set_b_p_function(sc, global_value(sc->is_eof_object_symbol), is_eof_object_b_p);
+ s7_set_b_7p_function(sc, global_value(sc->is_even_symbol), is_even_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->is_odd_symbol), is_odd_b_7p);
+ s7_set_b_p_function(sc, global_value(sc->is_float_symbol), is_float_b);
+ s7_set_b_p_function(sc, global_value(sc->is_float_vector_symbol), s7_is_float_vector);
+ s7_set_b_p_function(sc, global_value(sc->is_gensym_symbol), is_gensym_b_p);
+ s7_set_b_p_function(sc, global_value(sc->is_hash_table_symbol), s7_is_hash_table);
+ s7_set_b_7p_function(sc, global_value(sc->is_infinite_symbol), is_infinite_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->is_nan_symbol), is_nan_b_7p);
+ s7_set_b_p_function(sc, global_value(sc->is_input_port_symbol), is_input_port_b);
+ s7_set_b_p_function(sc, global_value(sc->is_integer_symbol), s7_is_integer);
+ s7_set_b_p_function(sc, global_value(sc->is_int_vector_symbol), s7_is_int_vector);
+ s7_set_b_p_function(sc, global_value(sc->is_keyword_symbol), s7_is_keyword);
+ s7_set_b_p_function(sc, global_value(sc->is_let_symbol), s7_is_let);
+ s7_set_b_p_function(sc, global_value(sc->is_list_symbol), is_list_b);
+ s7_set_b_p_function(sc, global_value(sc->is_macro_symbol), is_macro_b);
+ s7_set_b_p_function(sc, global_value(sc->is_number_symbol), s7_is_number);
+ s7_set_b_p_function(sc, global_value(sc->is_output_port_symbol), is_output_port_b);
+ s7_set_b_p_function(sc, global_value(sc->is_pair_symbol), s7_is_pair);
+ s7_set_b_p_function(sc, global_value(sc->is_null_symbol), is_null_b_p);
+ s7_set_b_7p_function(sc, global_value(sc->is_port_closed_symbol), is_port_closed_b_7p);
+ s7_set_b_p_function(sc, global_value(sc->is_procedure_symbol), s7_is_procedure);
+ s7_set_b_7p_function(sc, global_value(sc->is_proper_list_symbol), s7_is_proper_list);
+ s7_set_b_p_function(sc, global_value(sc->is_random_state_symbol), s7_is_random_state);
+ s7_set_b_p_function(sc, global_value(sc->is_rational_symbol), s7_is_rational);
+ s7_set_b_p_function(sc, global_value(sc->is_real_symbol), s7_is_real);
+ s7_set_b_p_function(sc, global_value(sc->is_sequence_symbol), is_sequence_b);
+ s7_set_b_p_function(sc, global_value(sc->is_string_symbol), s7_is_string);
+ s7_set_b_p_function(sc, global_value(sc->is_symbol_symbol), s7_is_symbol);
+ s7_set_b_p_function(sc, global_value(sc->is_syntax_symbol), s7_is_syntax);
+ s7_set_b_p_function(sc, global_value(sc->is_vector_symbol), s7_is_vector);
+ s7_set_b_7p_function(sc, global_value(sc->is_iterator_symbol), is_iterator_b_7p);
+
+ s7_set_b_7p_function(sc, global_value(sc->is_char_alphabetic_symbol), is_char_alphabetic_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->is_char_lower_case_symbol), is_char_lower_case_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->is_char_numeric_symbol), is_char_numeric_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->is_char_upper_case_symbol), is_char_upper_case_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->is_char_whitespace_symbol), is_char_whitespace_b_7p);
+
+ s7_set_b_p_function(sc, global_value(sc->is_openlet_symbol), s7_is_openlet);
+ s7_set_b_7p_function(sc, global_value(sc->iterator_is_at_end_symbol), iterator_is_at_end_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->is_zero_symbol), is_zero_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->is_negative_symbol), is_negative_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->is_positive_symbol), is_positive_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->not_symbol), not_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->is_provided_symbol), is_provided_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->is_defined_symbol), is_defined_b_7p);
+ s7_set_b_7pp_function(sc, global_value(sc->is_defined_symbol), is_defined_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->tree_memq_symbol), s7_tree_memq);
+ s7_set_b_7p_function(sc, global_value(sc->tree_is_cyclic_symbol), tree_is_cyclic);
+ s7_set_b_7pp_function(sc, global_value(sc->tree_set_memq_symbol), tree_set_memq_b_7pp);
+ s7_set_p_pp_function(sc, global_value(sc->tree_set_memq_symbol), tree_set_memq_p_pp);
+ s7_set_b_p_function(sc, global_value(sc->is_immutable_symbol), s7_is_immutable);
+
+ s7_set_p_p_function(sc, global_value(sc->is_proper_list_symbol), is_proper_list_p_p);
+ s7_set_p_p_function(sc, global_value(sc->is_pair_symbol), is_pair_p_p);
+ s7_set_p_p_function(sc, global_value(sc->is_char_symbol), is_char_p_p);
+ s7_set_p_p_function(sc, global_value(sc->is_constant_symbol), is_constant_p_p);
+ s7_set_b_7p_function(sc, global_value(sc->is_constant_symbol), is_constant_b_7p);
+ s7_set_p_p_function(sc, global_value(sc->type_of_symbol), s7_type_of);
+ s7_set_p_i_function(sc, global_value(sc->integer_to_char_symbol), integer_to_char_p_i);
+ s7_set_p_p_function(sc, global_value(sc->integer_to_char_symbol), integer_to_char_p_p);
+ s7_set_p_p_function(sc, global_value(sc->iterate_symbol), iterate_p_p);
+ s7_set_p_p_function(sc, global_value(sc->list_symbol), list_p_p);
+ s7_set_p_pp_function(sc, global_value(sc->list_symbol), list_p_pp);
+ s7_set_p_ppp_function(sc, global_value(sc->list_symbol), list_p_ppp);
+ s7_set_p_pp_function(sc, global_value(sc->list_tail_symbol), list_tail_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->make_list_symbol), make_list_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->assq_symbol), assq_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->assv_symbol), assv_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->memq_symbol), memq_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->memv_symbol), memv_p_pp);
+ s7_set_p_p_function(sc, global_value(sc->tree_leaves_symbol), tree_leaves_p_p);
+ s7_set_p_p_function(sc, global_value(sc->length_symbol), s7_length);
+ s7_set_p_p_function(sc, global_value(sc->pair_line_number_symbol), pair_line_number_p_p);
+ s7_set_p_p_function(sc, global_value(sc->port_line_number_symbol), port_line_number_p_p);
+ s7_set_p_p_function(sc, global_value(sc->port_filename_symbol), port_filename_p_p);
+ s7_set_p_p_function(sc, global_value(sc->c_pointer_info_symbol), c_pointer_info_p_p);
+ s7_set_p_p_function(sc, global_value(sc->c_pointer_type_symbol), c_pointer_type_p_p);
+ s7_set_p_p_function(sc, global_value(sc->c_pointer_weak1_symbol), c_pointer_weak1_p_p);
+ s7_set_p_p_function(sc, global_value(sc->c_pointer_weak2_symbol), c_pointer_weak2_p_p);
+ s7_set_p_p_function(sc, global_value(sc->is_char_alphabetic_symbol), is_char_alphabetic_p_p);
+ s7_set_p_p_function(sc, global_value(sc->is_char_whitespace_symbol), is_char_whitespace_p_p);
+ s7_set_p_p_function(sc, global_value(sc->is_char_numeric_symbol), is_char_numeric_p_p);
+ s7_set_p_p_function(sc, global_value(sc->char_upcase_symbol), char_upcase_p_p);
+ s7_set_p_p_function(sc, global_value(sc->read_char_symbol), read_char_p_p);
+ s7_set_p_i_function(sc, global_value(sc->make_string_symbol), make_string_p_i);
+ s7_set_p_ii_function(sc, global_value(sc->make_int_vector_symbol), make_int_vector_p_ii);
+ s7_set_p_ii_function(sc, global_value(sc->make_byte_vector_symbol), make_byte_vector_p_ii);
+ s7_set_p_pp_function(sc, global_value(sc->vector_symbol), vector_p_pp);
+ s7_set_p_p_function(sc, global_value(sc->signature_symbol), s7_signature);
+ s7_set_p_p_function(sc, global_value(sc->copy_symbol), copy_p_p);
+ s7_set_p_p_function(sc, global_value(sc->reverse_symbol), reverse_p_p);
+ s7_set_p_p_function(sc, global_value(sc->object_to_let_symbol), object_to_let_p_p);
+ s7_set_p_p_function(sc, global_value(sc->outlet_symbol), outlet_p_p);
+ s7_set_p_p_function(sc, global_value(sc->make_iterator_symbol), s7_make_iterator);
+
+#if WITH_SYSTEM_EXTRAS
+ s7_set_b_7p_function(sc, global_value(sc->is_directory_symbol), is_directory_b_7p);
+ s7_set_b_7p_function(sc, global_value(sc->file_exists_symbol), file_exists_b_7p);
+#endif
+
+ s7_set_b_i_function(sc, global_value(sc->is_even_symbol), is_even_i);
+ s7_set_b_i_function(sc, global_value(sc->is_odd_symbol), is_odd_i);
+ s7_set_b_i_function(sc, global_value(sc->is_zero_symbol), is_zero_i);
+ s7_set_b_d_function(sc, global_value(sc->is_zero_symbol), is_zero_d);
+ s7_set_p_p_function(sc, global_value(sc->is_zero_symbol), is_zero_p_p);
+ s7_set_p_p_function(sc, global_value(sc->is_positive_symbol), is_positive_p_p);
+ s7_set_p_p_function(sc, global_value(sc->is_negative_symbol), is_negative_p_p);
+ s7_set_p_p_function(sc, global_value(sc->real_part_symbol), real_part_p_p);
+ s7_set_p_p_function(sc, global_value(sc->imag_part_symbol), imag_part_p_p);
+ s7_set_d_p_function(sc, global_value(sc->real_part_symbol), real_part_d_p);
+ s7_set_d_p_function(sc, global_value(sc->imag_part_symbol), imag_part_d_p);
+ s7_set_b_i_function(sc, global_value(sc->is_positive_symbol), is_positive_i);
+ s7_set_b_d_function(sc, global_value(sc->is_positive_symbol), is_positive_d);
+ s7_set_b_i_function(sc, global_value(sc->is_negative_symbol), is_negative_i);
+ s7_set_b_d_function(sc, global_value(sc->is_negative_symbol), is_negative_d);
+
+ s7_set_p_pi_function(sc, global_value(sc->lt_symbol), lt_p_pi);
+ s7_set_b_pi_function(sc, global_value(sc->lt_symbol), lt_b_pi);
+ s7_set_p_pi_function(sc, global_value(sc->leq_symbol), leq_p_pi);
+ s7_set_b_pi_function(sc, global_value(sc->leq_symbol), leq_b_pi);
+ s7_set_p_pi_function(sc, global_value(sc->gt_symbol), gt_p_pi);
+ s7_set_b_pi_function(sc, global_value(sc->gt_symbol), gt_b_pi);
+ s7_set_p_pi_function(sc, global_value(sc->geq_symbol), geq_p_pi);
+ s7_set_b_pi_function(sc, global_value(sc->geq_symbol), geq_b_pi);
+ /* no ip pd dp! */
+ s7_set_b_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_b_pi);
+ s7_set_p_pi_function(sc, global_value(sc->num_eq_symbol), num_eq_p_pi);
+ s7_set_p_pi_function(sc, global_value(sc->add_symbol), add_p_pi);
+ s7_set_p_pi_function(sc, global_value(sc->subtract_symbol), g_sub_xi);
+ s7_set_p_pi_function(sc, global_value(sc->multiply_symbol), multiply_p_pi);
+
+ s7_set_p_ii_function(sc, global_value(sc->num_eq_symbol), num_eq_p_ii);
+ s7_set_p_dd_function(sc, global_value(sc->num_eq_symbol), num_eq_p_dd);
+ s7_set_p_pp_function(sc, global_value(sc->num_eq_symbol), num_eq_p_pp);
+ s7_set_b_7pp_function(sc, global_value(sc->num_eq_symbol), num_eq_b_7pp);
+ s7_set_b_ii_function(sc, global_value(sc->num_eq_symbol), num_eq_b_ii);
+ s7_set_b_dd_function(sc, global_value(sc->num_eq_symbol), num_eq_b_dd);
+
+ s7_set_p_ii_function(sc, global_value(sc->lt_symbol), lt_p_ii);
+ s7_set_p_dd_function(sc, global_value(sc->lt_symbol), lt_p_dd);
+ s7_set_p_pp_function(sc, global_value(sc->lt_symbol), lt_p_pp);
+ s7_set_b_7pp_function(sc, global_value(sc->lt_symbol), lt_b_7pp);
+ s7_set_b_ii_function(sc, global_value(sc->lt_symbol), lt_b_ii);
+ s7_set_b_dd_function(sc, global_value(sc->lt_symbol), lt_b_dd);
+
+ s7_set_b_ii_function(sc, global_value(sc->leq_symbol), leq_b_ii);
+ s7_set_p_dd_function(sc, global_value(sc->leq_symbol), leq_p_dd);
+ s7_set_p_ii_function(sc, global_value(sc->leq_symbol), leq_p_ii);
+ s7_set_b_dd_function(sc, global_value(sc->leq_symbol), leq_b_dd);
+ s7_set_p_pp_function(sc, global_value(sc->leq_symbol), leq_p_pp);
+ s7_set_b_7pp_function(sc, global_value(sc->leq_symbol), leq_b_7pp);
+
+ s7_set_b_ii_function(sc, global_value(sc->gt_symbol), gt_b_ii);
+ s7_set_b_dd_function(sc, global_value(sc->gt_symbol), gt_b_dd);
+ s7_set_p_dd_function(sc, global_value(sc->gt_symbol), gt_p_dd);
+ s7_set_p_ii_function(sc, global_value(sc->gt_symbol), gt_p_ii);
+ s7_set_p_pp_function(sc, global_value(sc->gt_symbol), gt_p_pp);
+ s7_set_b_7pp_function(sc, global_value(sc->gt_symbol), gt_b_7pp);
+
+ s7_set_b_ii_function(sc, global_value(sc->geq_symbol), geq_b_ii);
+ s7_set_b_dd_function(sc, global_value(sc->geq_symbol), geq_b_dd);
+ s7_set_p_ii_function(sc, global_value(sc->geq_symbol), geq_p_ii);
+ s7_set_p_dd_function(sc, global_value(sc->geq_symbol), geq_p_dd);
+ s7_set_p_pp_function(sc, global_value(sc->geq_symbol), geq_p_pp);
+ s7_set_b_7pp_function(sc, global_value(sc->geq_symbol), geq_b_7pp);
+
+ s7_set_b_pp_function(sc, global_value(sc->is_eq_symbol), s7_is_eq);
+ s7_set_p_pp_function(sc, global_value(sc->is_eq_symbol), is_eq_p_pp);
+ s7_set_b_7pp_function(sc, global_value(sc->is_eqv_symbol), s7_is_eqv);
+ s7_set_p_pp_function(sc, global_value(sc->is_eqv_symbol), is_eqv_p_pp);
+ s7_set_b_7pp_function(sc, global_value(sc->is_equal_symbol), s7_is_equal);
+ s7_set_b_7pp_function(sc, global_value(sc->is_equivalent_symbol), s7_is_equivalent);
+ s7_set_p_pp_function(sc, global_value(sc->is_equal_symbol), is_equal_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->is_equivalent_symbol), is_equivalent_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->char_eq_symbol), char_eq_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->make_float_vector_symbol), make_float_vector_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->setter_symbol), setter_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->complex_symbol), complex_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->string_eq_symbol), string_eq_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->string_lt_symbol), string_lt_p_pp);
+ s7_set_p_pp_function(sc, global_value(sc->string_gt_symbol), string_gt_p_pp);
+
+ s7_set_b_7pp_function(sc, global_value(sc->char_lt_symbol), char_lt_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->char_leq_symbol), char_leq_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->char_gt_symbol), char_gt_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->char_geq_symbol), char_geq_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->char_eq_symbol), char_eq_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->string_lt_symbol), string_lt_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->string_leq_symbol), string_leq_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->string_gt_symbol), string_gt_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->string_geq_symbol), string_geq_b_7pp);
+ s7_set_b_7pp_function(sc, global_value(sc->string_eq_symbol), string_eq_b_7pp);
+
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->char_lt_symbol), char_lt_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->char_leq_symbol), char_leq_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->char_gt_symbol), char_gt_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->char_geq_symbol), char_geq_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->char_eq_symbol), char_eq_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->string_lt_symbol), string_lt_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->string_leq_symbol), string_leq_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->string_gt_symbol), string_gt_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->string_geq_symbol), string_geq_b_unchecked);
+ s7_set_b_pp_unchecked_function(sc, global_value(sc->string_eq_symbol), string_eq_b_unchecked);
+
+ s7_set_b_7pp_function(sc, global_value(sc->is_aritable_symbol), is_aritable_b_7pp);
+}
+
+static void init_features(s7_scheme *sc)
+{
+ s7_provide(sc, "s7");
+ s7_provide(sc, "s7-" S7_VERSION);
+ s7_provide(sc, "ratios"); /* changed from ratio 22-Aug-23; r7rs uses the plural */
+
+#if HAVE_COMPLEX_NUMBERS
+ s7_provide(sc, "complex-numbers");
+#endif
+#if WITH_GMP
+ s7_provide(sc, "gmp");
+#else
+ s7_provide(sc, "ieee-float"); /* why would anyone care? -- this is for r7rs -- why singular this time? */
+#endif
+#if WITH_PURE_S7
+ s7_provide(sc, "pure-s7");
+#endif
+#if WITH_EXTRA_EXPONENT_MARKERS
+ s7_provide(sc, "dfls-exponents");
+#endif
+#if HAVE_OVERFLOW_CHECKS
+ s7_provide(sc, "overflow-checks");
+#endif
+#if WITH_SYSTEM_EXTRAS
+ s7_provide(sc, "system-extras");
+#endif
+#if WITH_IMMUTABLE_UNQUOTE
+ s7_provide(sc, "immutable-unquote");
+#endif
+#if S7_DEBUGGING
+ s7_provide(sc, "debugging");
+#endif
+#if WITH_NUMBER_SEPARATOR
+ s7_provide(sc, "number-separator");
+#endif
+#if WITH_HISTORY
+ s7_provide(sc, "history");
+#endif
+#if WITH_C_LOADER
+ s7_provide(sc, "dlopen");
+#endif
+#if (!DISABLE_AUTOLOAD)
+ s7_provide(sc, "autoload");
+#endif
+#if S7_ALIGNED
+ s7_provide(sc, "aligned");
+#endif
+#if POINTER_32
+ s7_provide(sc, "32-bit");
+#endif
+
+#ifdef __APPLE__
+ s7_provide(sc, "osx");
+#endif
+#ifdef __linux__
+ s7_provide(sc, "linux");
+#endif
+#ifdef __OpenBSD__
+ s7_provide(sc, "openbsd");
+#endif
+#ifdef __NetBSD__
+ s7_provide(sc, "netbsd");
+#endif
+#ifdef __FreeBSD__
+ s7_provide(sc, "freebsd");
+#endif
+#if MS_WINDOWS
+ s7_provide(sc, "windows");
+#endif
+#ifdef __bfin__
+ s7_provide(sc, "blackfin");
+#endif
+#ifdef __ANDROID__
+ s7_provide(sc, "android");
+#endif
+#ifdef __MSYS__
+ s7_provide(sc, "msys2"); /* from chai xiaoxiang */
+#endif
+#ifdef __MINGW32__ /* this is also defined in mingw64 */
+ s7_provide(sc, "mingw");
+#endif
+#ifdef __CYGWIN__
+ s7_provide(sc, "cygwin"); /* this is also defined in msys2 */
+#endif
+#ifdef __hpux
+ s7_provide(sc, "hpux");
+#endif
+#if defined(__sun) && defined(__SVR4)
+ s7_provide(sc, "solaris");
+#endif
+
+#ifdef __clang__
+ s7_provide(sc, "clang");
+#endif
+#ifdef __GNUC__
+ s7_provide(sc, "gcc");
+#endif
+#ifdef __TINYC__
+ s7_provide(sc, "tcc"); /* appears to be 3-4 times slower than gcc (compilation is at least 10 times faster however) */
+#endif
+#ifdef __EMSCRIPTEN__
+ s7_provide(sc, "emscripten");
+#endif
+#ifdef _MSC_VER
+ s7_provide(sc, "msvc");
+#endif
+}
+
+static void init_wrappers(s7_scheme *sc)
+{
+ s7_pointer cp, qp;
+
+ sc->integer_wrappers = semipermanent_list(sc, NUM_INTEGER_WRAPPERS);
+ for (cp = sc->integer_wrappers, qp = sc->integer_wrappers; is_pair(cp); qp = cp, cp = cdr(cp))
+ {
+ s7_pointer p = alloc_pointer(sc);
+ full_type(p) = T_INTEGER | T_IMMUTABLE | T_MUTABLE | T_UNHEAP; /* mutable to turn off set_has_number_name (see set_number_name) */
+ set_integer(p, 0);
+ set_car(cp, p);
+ }
+ unchecked_set_cdr(qp, sc->integer_wrappers);
+
+ sc->real_wrappers = semipermanent_list(sc, NUM_REAL_WRAPPERS);
+ for (cp = sc->real_wrappers, qp = sc->real_wrappers; is_pair(cp); qp = cp, cp = cdr(cp))
+ {
+ s7_pointer p = alloc_pointer(sc);
+ full_type(p) = T_REAL | T_IMMUTABLE | T_MUTABLE | T_UNHEAP;
+ set_real(p, 0.0);
+ set_car(cp, p);
+ }
+ unchecked_set_cdr(qp, sc->real_wrappers);
+
+ sc->string_wrappers = semipermanent_list(sc, NUM_STRING_WRAPPERS);
+ for (cp = sc->string_wrappers, qp = sc->string_wrappers; is_pair(cp); qp = cp, cp = cdr(cp))
+ {
+ s7_pointer p = alloc_pointer(sc);
+ full_type(p) = T_STRING | T_IMMUTABLE | T_SAFE_PROCEDURE | T_UNHEAP;
+ string_block(p) = NULL;
+ string_value(p) = NULL;
+ string_length(p) = 0;
+ string_hash(p) = 0;
+ set_car(cp, p);
+ }
+ unchecked_set_cdr(qp, sc->string_wrappers);
+
+ sc->c_pointer_wrappers = semipermanent_list(sc, NUM_C_POINTER_WRAPPERS);
+ for (cp = sc->c_pointer_wrappers, qp = sc->c_pointer_wrappers; is_pair(cp); qp = cp, cp = cdr(cp))
+ {
+ s7_pointer p = alloc_pointer(sc);
+ full_type(p) = T_C_POINTER | T_IMMUTABLE | T_UNHEAP;
+ c_pointer(p) = NULL;
+ c_pointer_type(p) = sc->F;
+ c_pointer_info(p) = sc->F;
+ c_pointer_weak1(p) = sc->F;
+ c_pointer_weak2(p) = sc->F;
+ set_car(cp, p);
+ }
+ unchecked_set_cdr(qp, sc->c_pointer_wrappers);
+}
+
+static s7_pointer syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc)
+{
+ s7_int len = safe_strlen(name);
+ uint64_t hash = raw_string_hash((const uint8_t *)name, len);
+ uint32_t loc = hash % SYMBOL_TABLE_SIZE;
+ s7_pointer x = new_symbol(sc, name, len, hash, loc);
+ s7_pointer syn = alloc_pointer(sc);
+
+ set_full_type(syn, T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS | T_GLOBAL | T_UNHEAP);
+ syntax_opcode(syn) = op;
+ syntax_set_symbol(syn, x);
+ syntax_min_args(syn) = integer(min_args);
+ syntax_max_args(syn) = ((max_args == max_arity) ? -1 : integer(max_args));
+ syntax_documentation(syn) = doc;
+ set_global_slot(x, make_semipermanent_slot(sc, x, syn));
+ set_initial_slot(x, make_semipermanent_slot(sc, x, syn)); /* set_local_slot(x, global_slot(x)); */
+ slot_set_next(initial_slot(x), sc->unlet_slots);
+ sc->unlet_slots = initial_slot(x);
+ set_type_bit(x, T_SYMBOL | T_SYNTACTIC | T_GLOBAL | T_UNHEAP);
+ symbol_set_local_slot_unchecked(x, 0LL, sc->nil);
+ symbol_clear_ctr(x);
+ return(x);
+}
+
+static s7_pointer definer_syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc)
+{
+ s7_pointer x = syntax(sc, name, op, min_args, max_args, doc);
+ set_syntax_is_definer(x);
+ return(x);
+}
+
+static s7_pointer binder_syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc)
+{
+ s7_pointer x = syntax(sc, name, op, min_args, max_args, doc);
+ set_syntax_is_binder(x);
+ return(x);
+}
+
+static s7_pointer copy_args_syntax(s7_scheme *sc, const char *name, opcode_t op, s7_pointer min_args, s7_pointer max_args, const char *doc)
+{
+ s7_pointer x = syntax(sc, name, op, min_args, max_args, doc);
+ s7_pointer p = global_value(x);
+ full_type(p) |= T_COPY_ARGS;
+ return(x);
+}
+
+static s7_pointer make_unique(s7_scheme *sc, const char* name, uint64_t typ)
+{
+ s7_pointer p = alloc_pointer(sc);
+ set_full_type(p, typ | T_IMMUTABLE | T_UNHEAP);
+ if (typ != T_UNUSED) set_optimize_op(p, OP_CONSTANT);
+ if (typ == T_UNDEFINED) /* sc->undefined here to avoid the undefined_constant_warning */
+ {
+ undefined_set_name_length(p, safe_strlen(name));
+ undefined_name(p) = copy_string_with_length(name, undefined_name_length(p));
+ }
+ else
+ {
+ unique_name_length(p) = safe_strlen(name);
+ unique_name(p) = copy_string_with_length(name, unique_name_length(p));
+ add_saved_pointer(sc, (void *)unique_name(p));
+ }
+ return(p);
+}
+
+static s7_pointer symbol_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val)
+{
+ s7_pointer slot = s7_slot(sc, sym);
+ if (!is_slot(slot))
+ error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "set!: '~S is unbound", 20), sym));
+ if (is_immutable_slot(slot))
+ immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->symbol_symbol, sym));
+ slot_set_value(slot, val);
+ return(val);
+}
+
+static s7_pointer g_symbol_set(s7_scheme *sc, s7_pointer args) /* (set! (symbol <lst>) <val>) */
+{
+ s7_int i = 0, len;
+ s7_pointer lst, val;
+ if (is_null(cddr(args)))
+ return(symbol_set_1(sc, g_symbol(sc, set_plist_1(sc, car(args))), cadr(args)));
+ len = proper_list_length(args) - 1;
+ lst = safe_list_if_possible(sc, len);
+ if (in_heap(lst)) gc_protect_via_stack(sc, lst);
+ for (s7_pointer ap = args, lp = lst; i < len; ap = cdr(ap), lp = cdr(lp), i++) set_car(lp, car(ap));
+ val = symbol_set_1(sc, g_symbol(sc, lst), s7_list_ref(sc, args, len));
+ if (in_heap(lst)) unstack_gc_protect(sc); else clear_list_in_use(lst);
+ return(val);
+}
+
+static void init_setters(s7_scheme *sc)
+{
+ sc->vector_set_function = global_value(sc->vector_set_symbol);
+ set_is_setter(sc->vector_set_symbol);
+ /* not float-vector-set! here */
+
+ sc->list_set_function = global_value(sc->list_set_symbol);
+ set_is_setter(sc->list_set_symbol);
+
+ sc->hash_table_set_function = global_value(sc->hash_table_set_symbol);
+ set_is_setter(sc->hash_table_set_symbol);
+
+ sc->let_set_function = global_value(sc->let_set_symbol);
+ set_is_setter(sc->let_set_symbol);
+
+ sc->string_set_function = global_value(sc->string_set_symbol);
+ set_is_setter(sc->string_set_symbol);
+
+ set_is_setter(sc->byte_vector_set_symbol);
+ set_is_setter(sc->set_car_symbol);
+ set_is_setter(sc->set_cdr_symbol);
+ set_is_safe_setter(sc->byte_vector_set_symbol);
+ set_is_safe_setter(sc->int_vector_set_symbol);
+ set_is_safe_setter(sc->float_vector_set_symbol);
+ set_is_safe_setter(sc->string_set_symbol);
+
+#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"));
+ 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"));
+#else
+ set_is_setter(sc->set_current_input_port_symbol);
+ set_is_setter(sc->set_current_output_port_symbol);
+ s7_function_set_setter(sc, sc->current_input_port_symbol, sc->set_current_input_port_symbol);
+ s7_function_set_setter(sc, sc->current_output_port_symbol, sc->set_current_output_port_symbol);
+#endif
+
+ set_is_setter(sc->set_current_error_port_symbol);
+ s7_function_set_setter(sc, sc->current_error_port_symbol, sc->set_current_error_port_symbol);
+ /* despite the similar names, current-error-port is different from the other two, and a setter is needed
+ * in scheme because error and warn send output to it by default. It is not a "dynamic variable".
+ */
+
+ s7_function_set_setter(sc, sc->car_symbol, sc->set_car_symbol);
+ s7_function_set_setter(sc, sc->cdr_symbol, sc->set_cdr_symbol);
+ s7_function_set_setter(sc, sc->hash_table_ref_symbol, sc->hash_table_set_symbol);
+ s7_function_set_setter(sc, sc->vector_ref_symbol, sc->vector_set_symbol);
+ s7_function_set_setter(sc, sc->float_vector_ref_symbol, sc->float_vector_set_symbol);
+ s7_function_set_setter(sc, sc->int_vector_ref_symbol, sc->int_vector_set_symbol);
+ s7_function_set_setter(sc, sc->byte_vector_ref_symbol, sc->byte_vector_set_symbol);
+ s7_function_set_setter(sc, sc->list_ref_symbol, sc->list_set_symbol);
+ 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"));
+ 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"));
+ 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"));
+ 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"));
+ 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"));
+ 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"));
+ 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"));
+ c_function_set_setter(global_value(sc->symbol_symbol),
+ s7_make_safe_function(sc, "#<symbol-set>", g_symbol_set, 2, 0, true, "symbol setter"));
+}
+
+static void init_syntax(s7_scheme *sc)
+{
+ #define H_quote "(quote obj) returns obj unevaluated. 'obj is an abbreviation for (quote obj)."
+ #define H_if "(if expr true-stuff optional-false-stuff) evaluates expr, then if it is true, evaluates true-stuff; otherwise, \
+if optional-false-stuff exists, it is evaluated."
+ #define H_when "(when expr ...) evaluates expr, and if it is true, evaluates each form in its body, returning the value of the last"
+ #define H_unless "(unless expr ...) evaluates expr, and if it is false, evaluates each form in its body, returning the value of the last"
+ #define H_begin "(begin ...) evaluates each form in its body, returning the value of the last one"
+ #define H_set "(set! variable value) sets the value of variable to value."
+ #define H_let "(let ((var val)...) ...) binds each variable to its initial value, then evaluates its body,\
+returning the value of the last form. The let variables are local to it, and are not available for use until all have been initialized."
+ #define H_let_star "(let* ((var val)...) ...) binds each variable to its initial value, then evaluates its body, \
+returning the value of the last form. The let* variables are local to it, and are available immediately."
+ #define H_letrec "(letrec ((var (lambda ...)))...) is like let, but var can refer to itself in its value \
+(i.e. you can define local recursive functions)"
+ #define H_letrec_star "(letrec* ((var val))...) is like letrec, but successive bindings are handled as in let*"
+ #define H_cond "(cond (expr clause...)...) is like if..then. Each expr is evaluated in order, and if one is not #f, \
+the associated clauses are evaluated, whereupon cond returns."
+ #define H_and "(and expr expr ...) evaluates each of its arguments in order, quitting (and returning #f) \
+as soon as one of them returns #f. If all are non-#f, it returns the last value."
+ #define H_or "(or expr expr ...) evaluates each of its arguments in order, quitting as soon as one of them is not #f. \
+If all are #f, or returns #f."
+ #define H_case "(case val ((key...) clause...)...) looks for val in the various lists of keys, and if a \
+match is found (via eqv?), the associated clauses are evaluated, and case returns."
+ #define H_do "(do (vars...) (loop control and return value) ...) is a do-loop."
+ #define H_lambda "(lambda args ...) returns a function."
+ #define H_lambda_star "(lambda* args ...) returns a function; the args list can have default values, \
+the parameters themselves can be accessed via keywords."
+ #define H_define "(define var val) assigns val to the variable (symbol) var. (define (func args) ...) is \
+shorthand for (define func (lambda args ...))"
+ #define H_define_star "(define* (func args) ...) defines a function with optional/keyword arguments."
+ #define H_define_constant "(define-constant var val) defines var to be a constant (it can't be set or bound), with the value val."
+ #define H_define_macro "(define-macro (mac args) ...) defines mac to be a macro."
+ #define H_define_macro_star "(define-macro* (mac args) ...) defines mac to be a macro with optional/keyword arguments."
+ #define H_macro "(macro args ...) defines an unnamed macro."
+ #define H_macro_star "(macro* args ...) defines an unnamed macro with optional/keyword arguments."
+ #define H_define_expansion "(define-expansion (mac args) ...) defines mac to be a read-time macro."
+ #define H_define_expansion_star "(define-expansion* (mac args) ...) defines mac to be a read-time macro*."
+ #define H_define_bacro "(define-bacro (mac args) ...) defines mac to be a bacro."
+ #define H_define_bacro_star "(define-bacro* (mac args) ...) defines mac to be a bacro with optional/keyword arguments."
+ #define H_bacro "(bacro args ...) defines an unnamed bacro."
+ #define H_bacro_star "(bacro* args ...) defines an unnamed bacro with optional/keyword arguments."
+ #define H_with_baffle "(with-baffle ...) evaluates its body in a context that blocks re-entry via call/cc."
+ #define H_macroexpand "(macroexpand macro-call) returns the result of the expansion phase of evaluating the macro call."
+ #define H_with_let "(with-let let ...) evaluates its body in the environment let."
+ #define H_let_temporarily "(let-temporarily ((var value)...) . body) sets each var to its new value, evals body, \
+then returns each var to its original value."
+
+ sc->quote_symbol = syntax(sc, "quote", OP_QUOTE, int_one, int_one, H_quote);
+ sc->quote_function = initial_value(sc->quote_symbol);
+ sc->if_symbol = syntax(sc, "if", OP_IF, int_two, int_three, H_if);
+ sc->when_symbol = syntax(sc, "when", OP_WHEN, int_two, max_arity, H_when);
+ sc->unless_symbol = syntax(sc, "unless", OP_UNLESS, int_two, max_arity, H_unless);
+ sc->begin_symbol = syntax(sc, "begin", OP_BEGIN, int_zero, max_arity, H_begin); /* (begin) is () */
+ sc->set_symbol = syntax(sc, "set!", OP_SET, int_two, int_two, H_set);
+ set_is_setter(sc->set_symbol); /* ? 26-Jan-24 */
+ sc->cond_symbol = copy_args_syntax(sc, "cond", OP_COND, int_one, max_arity, H_cond);
+ sc->and_symbol = copy_args_syntax(sc, "and", OP_AND, int_zero, max_arity, H_and);
+ sc->or_symbol = copy_args_syntax(sc, "or", OP_OR, int_zero, max_arity, H_or);
+ sc->case_symbol = syntax(sc, "case", OP_CASE, int_two, max_arity, H_case);
+ sc->macroexpand_symbol = syntax(sc, "macroexpand", OP_MACROEXPAND, int_one, int_one, H_macroexpand);
+ sc->let_temporarily_symbol = syntax(sc, "let-temporarily", OP_LET_TEMPORARILY, int_two, max_arity, H_let_temporarily);
+ sc->define_symbol = definer_syntax(sc, "define", OP_DEFINE, int_two, max_arity, H_define);
+ sc->define_star_symbol = definer_syntax(sc, "define*", OP_DEFINE_STAR, int_two, max_arity, H_define_star);
+ sc->define_constant_symbol = definer_syntax(sc, "define-constant", OP_DEFINE_CONSTANT, int_two, max_arity, H_define_constant);
+ sc->define_macro_symbol = definer_syntax(sc, "define-macro", OP_DEFINE_MACRO, int_two, max_arity, H_define_macro);
+ sc->define_macro_star_symbol = definer_syntax(sc, "define-macro*", OP_DEFINE_MACRO_STAR, int_two, max_arity, H_define_macro_star);
+ sc->define_expansion_symbol = definer_syntax(sc, "define-expansion",OP_DEFINE_EXPANSION, int_two, max_arity, H_define_expansion);
+ sc->define_expansion_star_symbol = definer_syntax(sc, "define-expansion*",OP_DEFINE_EXPANSION_STAR, int_two, max_arity, H_define_expansion_star);
+ sc->define_bacro_symbol = definer_syntax(sc, "define-bacro", OP_DEFINE_BACRO, int_two, max_arity, H_define_bacro);
+ sc->define_bacro_star_symbol = definer_syntax(sc, "define-bacro*", OP_DEFINE_BACRO_STAR, int_two, max_arity, H_define_bacro_star);
+ sc->let_symbol = binder_syntax(sc, "let", OP_LET, int_two, max_arity, H_let);
+ sc->let_star_symbol = binder_syntax(sc, "let*", OP_LET_STAR, int_two, max_arity, H_let_star);
+ sc->letrec_symbol = binder_syntax(sc, "letrec", OP_LETREC, int_two, max_arity, H_letrec);
+ sc->letrec_star_symbol = binder_syntax(sc, "letrec*", OP_LETREC_STAR, int_two, max_arity, H_letrec_star);
+ sc->do_symbol = binder_syntax(sc, "do", OP_DO, int_two, max_arity, H_do); /* 2 because body can be null */
+ sc->lambda_symbol = binder_syntax(sc, "lambda", OP_LAMBDA, int_two, max_arity, H_lambda);
+ sc->lambda_star_symbol = binder_syntax(sc, "lambda*", OP_LAMBDA_STAR, int_two, max_arity, H_lambda_star);
+ sc->macro_symbol = binder_syntax(sc, "macro", OP_MACRO, int_two, max_arity, H_macro);
+ sc->macro_star_symbol = binder_syntax(sc, "macro*", OP_MACRO_STAR, int_two, max_arity, H_macro_star);
+ sc->bacro_symbol = binder_syntax(sc, "bacro", OP_BACRO, int_two, max_arity, H_bacro);
+ sc->bacro_star_symbol = binder_syntax(sc, "bacro*", OP_BACRO_STAR, int_two, max_arity, H_bacro_star);
+ sc->with_let_symbol = binder_syntax(sc, "with-let", OP_WITH_LET, int_one, max_arity, H_with_let);
+ sc->with_baffle_symbol = binder_syntax(sc, "with-baffle", OP_WITH_BAFFLE, int_zero, max_arity, H_with_baffle); /* (with-baffle) is () */
+ set_local_slot(sc->with_let_symbol, global_slot(sc->with_let_symbol)); /* for set_locals */
+ set_immutable(sc->with_let_symbol);
+ set_immutable_slot(global_slot(sc->with_let_symbol));
+ sc->setter_symbol = make_symbol(sc, "setter", 6);
+
+ sc->feed_to_symbol = make_symbol(sc, "=>", 2);
+ sc->body_symbol = make_symbol(sc, "body", 4);
+ sc->read_error_symbol = make_symbol(sc, "read-error", 10);
+ sc->string_read_error_symbol = make_symbol(sc, "string-read-error", 17);
+ sc->syntax_error_symbol = make_symbol(sc, "syntax-error", 12);
+ sc->unbound_variable_symbol = make_symbol(sc, "unbound-variable", 16);
+ sc->wrong_type_arg_symbol = make_symbol(sc, "wrong-type-arg", 14);
+ sc->wrong_number_of_args_symbol = make_symbol(sc, "wrong-number-of-args", 20);
+ sc->format_error_symbol = make_symbol(sc, "format-error", 12);
+ sc->autoload_error_symbol = make_symbol(sc, "autoload-error", 14);
+ sc->out_of_range_symbol = make_symbol(sc, "out-of-range", 12);
+ sc->out_of_memory_symbol = make_symbol(sc, "out-of-memory", 13);
+ sc->io_error_symbol = make_symbol(sc, "io-error", 8);
+ sc->missing_method_symbol = make_symbol(sc, "missing-method", 14);
+ sc->number_to_real_symbol = make_symbol(sc, "number_to_real", 14);
+ sc->invalid_escape_function_symbol = make_symbol(sc, "invalid-escape-function", 23);
+ sc->immutable_error_symbol = make_symbol(sc, "immutable-error", 15);
+ sc->division_by_zero_symbol = make_symbol(sc, "division-by-zero", 16);
+ sc->bad_result_symbol = make_symbol(sc, "bad-result", 10);
+ sc->no_setter_symbol = make_symbol(sc, "no-setter", 9);
+ sc->baffled_symbol = make_symbol(sc, "baffled!", 8);
+ sc->value_symbol = make_symbol(sc, "value", 5);
+ sc->type_symbol = make_symbol(sc, "type", 4);
+ sc->position_symbol = make_symbol(sc, "position", 8);
+ sc->file_symbol = make_symbol(sc, "file", 4);
+ sc->line_symbol = make_symbol(sc, "line", 4);
+ sc->function_symbol = make_symbol(sc, "function", 8);
+
+ sc->else_symbol = make_symbol(sc, "else", 4);
+ s7_make_slot(sc, sc->rootlet, sc->else_symbol, sc->else_symbol);
+ slot_set_value(initial_slot(sc->else_symbol), s7_make_keyword(sc, "else")); /* 3-Oct-23 was #t */
+ /* if we set #_else to 'else, it can pick up a local else value: (let ((else #f)) (cond (#_else 2)...)) -- #_* is read-time */
+
+ sc->allow_other_keys_keyword = s7_make_keyword(sc, "allow-other-keys");
+ sc->rest_keyword = s7_make_keyword(sc, "rest");
+ sc->if_keyword = s7_make_keyword(sc, "if"); /* internal optimizer local-let marker */
+ sc->readable_keyword = s7_make_keyword(sc, "readable");
+ sc->display_keyword = s7_make_keyword(sc, "display");
+ sc->write_keyword = s7_make_keyword(sc, "write");
+}
+
+static void init_rootlet(s7_scheme *sc)
+{
+ /* most of init_rootlet (the built-in functions for example), could be shared by all s7 instances.
+ * currently, each s7_init call allocates room for them, then s7_free frees it -- kinda wasteful.
+ */
+ s7_pointer sym;
+ init_syntax(sc);
+
+ sc->owlet = init_owlet(sc);
+
+ sc->wrong_type_arg_info = semipermanent_list(sc, 6);
+ set_car(sc->wrong_type_arg_info, s7_make_semipermanent_string(sc, "~A ~:D argument, ~S, is ~A but should be ~A"));
+
+ sc->sole_arg_wrong_type_info = semipermanent_list(sc, 5);
+ set_car(sc->sole_arg_wrong_type_info, s7_make_semipermanent_string(sc, "~A argument, ~S, is ~A but should be ~A"));
+
+ sc->out_of_range_info = semipermanent_list(sc, 5);
+ set_car(sc->out_of_range_info, s7_make_semipermanent_string(sc, "~A ~:D argument, ~S, is out of range (~A)"));
+
+ sc->sole_arg_out_of_range_info = semipermanent_list(sc, 4);
+ set_car(sc->sole_arg_out_of_range_info, s7_make_semipermanent_string(sc, "~A argument, ~S, is out of range (~A)"));
+
+ sc->gc_off = false;
+
+ #define defun(Scheme_Name, C_Name, Req, Opt, Rst) \
+ s7_define_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)
+
+ #define unsafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) \
+ s7_define_unsafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)
+
+ #define semisafe_defun(Scheme_Name, C_Name, Req, Opt, Rst) \
+ s7_define_semisafe_typed_function(sc, Scheme_Name, g_ ## C_Name, Req, Opt, Rst, H_ ## C_Name, Q_ ## C_Name)
+
+ #define bool_defun(Scheme_Name, C_Name, Opt, SymId, Marker, Simple) \
+ define_bool_function(sc, Scheme_Name, g_ ## C_Name, Opt, H_ ## C_Name, Q_ ## C_Name, SymId, Marker, Simple, b_ ## C_Name ## _setter)
+
+ /* we need the sc->is_* symbols first for the procedure signature lists */
+ 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_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_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_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_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_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_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_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_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);
+
+ /* these are for signatures */
+ 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 */
+ 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);
+ sc->pl_sf = s7_make_signature(sc, 3, sc->T, sc->is_string_symbol, s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol));
+ sc->pcl_bt = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->T);
+ sc->pcl_bc = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_char_symbol);
+ sc->pcl_bs = s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_string_symbol);
+ sc->pcl_i = s7_make_circular_signature(sc, 0, 1, sc->is_integer_symbol);
+ sc->pcl_r = s7_make_circular_signature(sc, 0, 1, sc->is_real_symbol);
+ sc->pcl_f = s7_make_circular_signature(sc, 0, 1, sc->is_rational_symbol);
+ sc->pcl_n = s7_make_circular_signature(sc, 0, 1, sc->is_number_symbol);
+ sc->pcl_s = s7_make_circular_signature(sc, 0, 1, sc->is_string_symbol);
+ sc->pcl_v = s7_make_circular_signature(sc, 0, 1, sc->is_vector_symbol);
+ sc->pcl_c = s7_make_circular_signature(sc, 0, 1, sc->is_char_symbol);
+ sc->pcl_e = s7_make_circular_signature(sc, 0, 1,
+ s7_make_signature(sc, 4, sc->is_let_symbol, sc->is_procedure_symbol, sc->is_macro_symbol, sc->is_c_object_symbol));
+
+ sc->values_symbol = make_symbol(sc, "values", 6);
+
+ 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->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 */
+ 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 */
+ set_func_is_definer(sc->curlet_symbol);
+ 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 */
+ set_func_is_definer(sc->varlet_symbol);
+ 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);
+ 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);
+ 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->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->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->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->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 */
+#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->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->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);
+ /* 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).
+ * a safe procedure leaves its argument list alone, does not push anything on the stack,
+ * and leaves sc->code|args unscathed (fx_call assumes that is the case). The stack part can
+ * be hidden: if a c_function calls s7_apply_function (lambda passed as arg as in some clm gens)
+ * then is called with args that use fx*, and the lambda func does the same, the two calls
+ * can step on each other.
+ */
+
+ sc->call_with_input_string_symbol = semisafe_defun("call-with-input-string", call_with_input_string, 2, 0, false); /* body unsafe if func=read */
+ sc->call_with_input_file_symbol = semisafe_defun("call-with-input-file", call_with_input_file, 2, 0, false);
+ sc->with_input_from_string_symbol = semisafe_defun("with-input-from-string", with_input_from_string, 2, 0, false);
+ sc->with_input_from_file_symbol = semisafe_defun("with-input-from-file", with_input_from_file, 2, 0, false);
+
+ sc->call_with_output_string_symbol = semisafe_defun("call-with-output-string", call_with_output_string, 1, 0, false);
+ sc->call_with_output_file_symbol = semisafe_defun("call-with-output-file", call_with_output_file, 2, 0, false);
+ sc->with_output_to_string_symbol = semisafe_defun("with-output-to-string", with_output_to_string, 1, 0, false);
+ 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);
+#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->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);
+#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);
+
+#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);
+ /* 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);
+
+#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);
+#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);
+ set_is_setter(sc->vector_symbol); /* like cons, I guess */
+ sc->vector_typer_symbol = defun("vector-typer", vector_typer, 1, 0, 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->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->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->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_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->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);
+ set_func_is_definer(sc->eval_symbol);
+ 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 */
+ 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->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 */
+ /* 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->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 */
+#if WITH_IMMUTABLE_UNQUOTE
+ sc->unquote_symbol = make_symbol(sc, "<unquote>", 9);
+ set_immutable(sc->unquote_symbol);
+#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*> */
+#if (!DISABLE_DEPRECATED)
+ defun("[list*]", qq_append, 2, 0, false);
+#endif
+ sc->apply_values_symbol = unsafe_defun("apply-values", apply_values, 0, 1, false);
+ 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->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->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);
+
+#if WITH_GCC
+ s7_define_function(sc, "abort", g_abort, 0, 0, false, "drop into gdb I hope");
+#endif
+#if S7_DEBUGGING
+ defun("heap-scan", heap_scan, 1, 0, false);
+ defun("heap-analyze", heap_analyze, 0, 0, false);
+ defun("heap-holder", heap_holder, 1, 0, false);
+ defun("heap-holders", heap_holders, 1, 0, false);
+
+ defun("show-stack", show_stack, 0, 1, false);
+ defun("show-op-stack", show_op_stack, 0, 0, false);
+ defun("op-stack?", is_op_stack, 0, 0, false);
+#endif
+ s7_define_function(sc, "s7-optimize", g_optimize, 1, 0, false, "short-term debugging aid");
+ sc->c_object_set_function = s7_make_safe_function(sc, "#<c-object-setter>", g_c_object_set, 1, 0, true, "c-object setter");
+ /* c_function_signature(sc->c_object_set_function) = s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_c_object_symbol, sc->T); */
+
+ set_scope_safe(global_value(sc->call_with_input_string_symbol));
+ set_scope_safe(global_value(sc->call_with_input_file_symbol));
+ set_scope_safe(global_value(sc->call_with_output_string_symbol));
+ set_scope_safe(global_value(sc->call_with_output_file_symbol));
+ set_scope_safe(global_value(sc->with_input_from_string_symbol));
+ set_scope_safe(global_value(sc->with_input_from_file_symbol));
+ set_scope_safe(global_value(sc->with_output_to_string_symbol));
+ set_scope_safe(global_value(sc->with_output_to_file_symbol));
+ set_maybe_safe(global_value(sc->assoc_symbol));
+ set_scope_safe(global_value(sc->assoc_symbol));
+ set_maybe_safe(global_value(sc->member_symbol));
+ set_scope_safe(global_value(sc->member_symbol));
+ set_scope_safe(global_value(sc->sort_symbol));
+ set_scope_safe(global_value(sc->call_with_exit_symbol));
+ set_scope_safe(global_value(sc->for_each_symbol));
+ set_maybe_safe(global_value(sc->for_each_symbol));
+ set_scope_safe(global_value(sc->map_symbol));
+ set_maybe_safe(global_value(sc->map_symbol));
+ set_scope_safe(global_value(sc->dynamic_wind_symbol));
+ set_scope_safe(global_value(sc->catch_symbol));
+ set_scope_safe(global_value(sc->throw_symbol));
+ set_scope_safe(global_value(sc->error_symbol));
+ set_scope_safe(global_value(sc->apply_values_symbol));
+
+ sc->tree_leaves_symbol = defun("tree-leaves", tree_leaves, 1, 0, false);
+ sc->tree_memq_symbol = defun("tree-memq", tree_memq, 2, 0, false);
+ sc->tree_set_memq_symbol = defun("tree-set-memq", tree_set_memq, 2, 0, false);
+ sc->tree_count_symbol = defun("tree-count", tree_count, 2, 1, false);
+ sc->tree_is_cyclic_symbol = defun("tree-cyclic?", tree_is_cyclic, 1, 0, false);
+
+ sc->quasiquote_symbol = s7_define_macro(sc, "quasiquote", g_quasiquote, 1, 0, false, H_quasiquote); /* is this considered syntax? r7rs says yes; also unquote */
+ sc->quasiquote_function = initial_value(sc->quasiquote_symbol);
+ sc->profile_in_symbol = unsafe_defun("profile-in", profile_in, 2, 0, false); /* calls dynamic-unwind */
+ sc->profile_out = NULL;
+
+ /* -------- *features* -------- */
+ sc->features_symbol = s7_define_variable_with_documentation(sc, "*features*", sc->nil, "list of currently available features ('complex-numbers, etc)");
+ s7_set_setter(sc, sc->features_symbol, sc->features_setter = s7_make_safe_function(sc, "#<set-*features*>", g_features_set, 2, 0, false, "*features* setter"));
+
+ /* -------- *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");
+ 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
+ sc->cload_directory_symbol = s7_define_variable(sc, "*cload-directory*", s7_make_string(sc, (char *)CLOAD_DIR));
+ s7_add_to_load_path(sc, (const char *)CLOAD_DIR);
+#else
+ 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"));
+
+ /* -------- *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);
+ c_function_set_setter(global_value(sc->autoloader_symbol), global_value(sc->autoload_symbol)); /* (set! (*autoload* x) y) */
+
+ sc->libraries_symbol = s7_define_variable_with_documentation(sc, "*libraries*", sc->nil, "list of currently loaded libraries (libc.scm, etc)");
+ s7_set_setter(sc, sc->libraries_symbol, s7_make_safe_function(sc, "#<set-*libraries*>", g_libraries_set, 2, 0, false, "*libraries* setter"));
+
+ s7_autoload(sc, make_symbol(sc, "cload.scm", 9), s7_make_semipermanent_string(sc, "cload.scm"));
+ s7_autoload(sc, make_symbol(sc, "lint.scm", 8), s7_make_semipermanent_string(sc, "lint.scm"));
+ s7_autoload(sc, make_symbol(sc, "stuff.scm", 9), s7_make_semipermanent_string(sc, "stuff.scm"));
+ s7_autoload(sc, make_symbol(sc, "mockery.scm", 11), s7_make_semipermanent_string(sc, "mockery.scm"));
+ s7_autoload(sc, make_symbol(sc, "write.scm", 9), s7_make_semipermanent_string(sc, "write.scm"));
+ s7_autoload(sc, make_symbol(sc, "reactive.scm", 12), s7_make_semipermanent_string(sc, "reactive.scm"));
+ s7_autoload(sc, make_symbol(sc, "repl.scm", 8), s7_make_semipermanent_string(sc, "repl.scm"));
+ s7_autoload(sc, make_symbol(sc, "r7rs.scm", 8), s7_make_semipermanent_string(sc, "r7rs.scm"));
+ s7_autoload(sc, make_symbol(sc, "profile.scm", 11), s7_make_semipermanent_string(sc, "profile.scm"));
+ s7_autoload(sc, make_symbol(sc, "debug.scm", 9), s7_make_semipermanent_string(sc, "debug.scm"));
+ s7_autoload(sc, make_symbol(sc, "case.scm", 8), s7_make_semipermanent_string(sc, "case.scm"));
+
+ s7_autoload(sc, make_symbol(sc, "libc.scm", 8), s7_make_semipermanent_string(sc, "libc.scm"));
+ s7_autoload(sc, make_symbol(sc, "libm.scm", 8), s7_make_semipermanent_string(sc, "libm.scm")); /* repl.scm adds *libm* */
+ s7_autoload(sc, make_symbol(sc, "libdl.scm", 9), s7_make_semipermanent_string(sc, "libdl.scm"));
+ s7_autoload(sc, make_symbol(sc, "libgsl.scm", 10), s7_make_semipermanent_string(sc, "libgsl.scm")); /* repl.scm adds *libgsl* */
+ s7_autoload(sc, make_symbol(sc, "libgdbm.scm", 11), s7_make_semipermanent_string(sc, "libgdbm.scm"));
+ s7_autoload(sc, make_symbol(sc, "libutf8proc.scm", 15), s7_make_semipermanent_string(sc, "libutf8proc.scm"));
+
+ sc->require_symbol = s7_define_macro(sc, "require", g_require, 1, 0, true, H_require);
+ sc->stacktrace_defaults = s7_list(sc, 5, int_three, small_int(45), small_int(80), small_int(45), sc->T); /* assume NUM_SMALL_INTS >= NUM_CHARS == 256 */
+
+ /* -------- *#readers* -------- */
+ sym = s7_define_variable_with_documentation(sc, "*#readers*", sc->nil, "list of current reader macros");
+ sc->sharp_readers = global_slot(sym);
+ s7_set_setter(sc, sym, s7_make_safe_function(sc, "#<set-*#readers*>", g_sharp_readers_set, 2, 0, false, "*#readers* setter"));
+
+ sc->local_documentation_symbol = make_symbol(sc, "+documentation+", 15);
+ sc->local_signature_symbol = make_symbol(sc, "+signature+", 11);
+ sc->local_setter_symbol = make_symbol(sc, "+setter+", 8);
+ sc->local_iterator_symbol = make_symbol(sc, "+iterator+", 10);
+
+ init_features(sc);
+ init_setters(sc);
+}
+
+#if (!MS_WINDOWS)
+static pthread_mutex_t init_lock = PTHREAD_MUTEX_INITIALIZER;
+#endif
+
+s7_scheme *s7_init(void)
+{
+ int32_t i;
+ s7_scheme *sc;
+ static bool already_inited = false;
+
+#if (!MS_WINDOWS)
+ setlocale(LC_NUMERIC, "C"); /* use decimal point in floats */
+ pthread_mutex_lock(&init_lock);
+#endif
+
+ if (!already_inited)
+ {
+ init_types();
+ init_ctables();
+ init_mark_functions();
+ init_display_functions();
+ init_length_functions();
+ init_equals();
+ init_hash_maps();
+ init_pows();
+ init_int_limits();
+ init_small_ints();
+ init_uppers();
+ init_chars();
+ init_strings();
+ init_fx_function();
+ init_catchers();
+ init_s7_starlet_immutable_field();
+ already_inited = true;
+ }
+#if S7_DEBUGGING
+ init_never_unheaped();
+#endif
+#if (!MS_WINDOWS)
+ pthread_mutex_unlock(&init_lock);
+#endif
+ sc = (s7_scheme *)Calloc(1, sizeof(s7_scheme)); /* not malloc! */
+ cur_sc = sc; /* for gdb/debugging */
+ sc->gc_off = true; /* sc->args and so on are not set yet, so a gc during init -> segfault */
+ sc->gc_in_progress = false;
+ sc->gc_stats = 0;
+
+ sc->saved_pointers = (void **)Malloc(INITIAL_SAVED_POINTERS_SIZE * sizeof(void *));
+ sc->saved_pointers_loc = 0;
+ sc->saved_pointers_size = INITIAL_SAVED_POINTERS_SIZE;
+
+ init_gc_caches(sc);
+ sc->semipermanent_cells = 0;
+ sc->alloc_pointer_k = ALLOC_POINTER_SIZE;
+ sc->alloc_pointer_cells = NULL;
+ sc->alloc_big_pointer_k = ALLOC_BIG_POINTER_SIZE;
+ sc->alloc_big_pointer_cells = NULL;
+ sc->alloc_function_k = ALLOC_FUNCTION_SIZE;
+ sc->alloc_function_cells = NULL;
+ sc->alloc_symbol_k = ALLOC_SYMBOL_SIZE;
+ sc->alloc_symbol_cells = NULL;
+ sc->num_to_str_size = -1;
+ sc->num_to_str = NULL;
+ init_block_lists(sc);
+ sc->alloc_string_k = ALLOC_STRING_SIZE;
+ sc->alloc_string_cells = NULL;
+ sc->alloc_opt_func_cells = NULL;
+ sc->alloc_opt_func_k = ALLOC_FUNCTION_SIZE;
+ sc->longjmp_ok = false;
+ sc->setjmp_loc = NO_SET_JUMP;
+ sc->max_vector_length = (1LL << 32);
+ sc->max_string_length = 1073741824; /* 1 << 30 */
+ sc->max_format_length = 10000;
+ sc->max_list_length = 1073741824;
+ sc->max_vector_dimensions = 512;
+ sc->strbuf_size = INITIAL_STRBUF_SIZE;
+ sc->strbuf = (char *)Calloc(sc->strbuf_size, 1);
+ sc->print_width = sc->max_string_length;
+ sc->short_print = false;
+ sc->in_with_let = false;
+ sc->object_out_locked = false;
+ sc->has_openlets = true;
+ sc->is_expanding = true;
+ sc->accept_all_keyword_arguments = false;
+ sc->muffle_warnings = false;
+ sc->initial_string_port_length = 128;
+ sc->format_depth = -1;
+ sc->singletons = (s7_pointer *)Calloc(256, sizeof(s7_pointer));
+ add_saved_pointer(sc, sc->singletons);
+ sc->read_line_buf = NULL;
+ sc->read_line_buf_size = 0;
+ sc->stop_at_error = true;
+
+ sc->nil = make_unique(sc, "()", T_NIL);
+ sc->unused = make_unique(sc, "#<unused>", T_UNUSED);
+ sc->T = make_unique(sc, "#t", T_BOOLEAN);
+ sc->F = make_unique(sc, "#f", T_BOOLEAN);
+ sc->undefined = make_unique(sc, "#<undefined>", T_UNDEFINED);
+ sc->unspecified = make_unique(sc, "#<unspecified>", T_UNSPECIFIED);
+ sc->no_value = make_unique(sc, (SHOW_EVAL_OPS) ? "#<no-value>" : "#<unspecified>", T_UNSPECIFIED);
+
+ unique_car(sc->nil) = sc->unspecified; /* see op_if1 */
+ unique_cdr(sc->nil) = sc->unspecified;
+ unique_cdr(sc->unspecified) = sc->unspecified;
+
+ sc->t1_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE);
+ sc->t2_2 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE);
+ sc->t2_1 = semipermanent_cons(sc, sc->unused, sc->t2_2, T_PAIR | T_IMMUTABLE);
+ sc->t3_3 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE);
+ sc->t3_2 = semipermanent_cons(sc, sc->unused, sc->t3_3, T_PAIR | T_IMMUTABLE);
+ sc->t3_1 = semipermanent_cons(sc, sc->unused, sc->t3_2, T_PAIR | T_IMMUTABLE);
+ sc->t4_1 = semipermanent_cons(sc, sc->unused, sc->t3_1, T_PAIR | T_IMMUTABLE);
+ sc->u1_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE); /* ulist */
+
+ sc->safe_lists[0] = sc->nil;
+ for (i = 1; i < NUM_SAFE_PRELISTS; i++)
+ sc->safe_lists[i] = semipermanent_list(sc, i);
+ for (i = NUM_SAFE_PRELISTS; i < NUM_SAFE_LISTS; i++)
+ sc->safe_lists[i] = sc->nil;
+ sc->current_safe_list = 0;
+#if S7_DEBUGGING
+ local_memset((void *)(sc->safe_list_uses), 0, NUM_SAFE_LISTS);
+#endif
+
+ sc->input_port_stack_size = INPUT_PORT_STACK_INITIAL_SIZE;
+ sc->input_port_stack = (s7_pointer *)Malloc(sc->input_port_stack_size * sizeof(s7_pointer));
+ sc->input_port_stack_loc = 0;
+
+ sc->code = sc->nil;
+#if WITH_HISTORY
+ sc->eval_history1 = semipermanent_list(sc, DEFAULT_HISTORY_SIZE);
+ sc->eval_history2 = semipermanent_list(sc, DEFAULT_HISTORY_SIZE);
+ sc->history_pairs = semipermanent_list(sc, DEFAULT_HISTORY_SIZE);
+ sc->history_sink = semipermanent_list(sc, 1);
+ unchecked_set_cdr(sc->history_sink, sc->history_sink);
+ {
+ s7_pointer p1, p2, p3;
+ for (p3 = sc->history_pairs; is_pair(cdr(p3)); p3 = cdr(p3)) set_car(p3, semipermanent_list(sc, 1));
+ set_car(p3, semipermanent_list(sc, 1));
+ unchecked_set_cdr(p3, sc->history_pairs);
+ for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2));
+ unchecked_set_cdr(p1, sc->eval_history1);
+ unchecked_set_cdr(p2, sc->eval_history2);
+ sc->cur_code = sc->eval_history1;
+ sc->using_history1 = true;
+ sc->old_cur_code = sc->cur_code;
+ }
+#else
+ sc->cur_code = sc->F;
+#endif
+ sc->args = sc->nil;
+ sc->value = sc->nil;
+ sc->w = sc->unused;
+ sc->x = sc->unused;
+ sc->y = sc->unused;
+ sc->z = sc->unused;
+ sc->temp1 = sc->unused;
+ sc->temp2 = sc->unused;
+ sc->temp3 = sc->unused;
+ sc->temp4 = sc->unused;
+ sc->temp5 = sc->unused;
+ sc->temp6 = sc->unused;
+ sc->temp7 = sc->unused;
+ sc->temp8 = sc->unused;
+ sc->temp9 = sc->unused;
+ sc->temp10 = sc->unused;
+ sc->rec_p1 = sc->unused;
+ sc->rec_p2 = sc->unused;
+
+ sc->begin_hook = NULL;
+ sc->autoload_table = sc->nil;
+ sc->autoload_names = NULL;
+ sc->autoload_names_sizes = NULL;
+ sc->autoloaded_already = NULL;
+ sc->autoload_names_loc = 0;
+#if DISABLE_AUTOLOAD /* might not be defined, so we can't play games */
+ sc->is_autoloading = false;
+#else
+ sc->is_autoloading = true;
+#endif
+ sc->rec_stack = NULL;
+ sc->show_stack_limit = 20;
+
+ sc->heap_size = INITIAL_HEAP_SIZE;
+ if ((sc->heap_size % 32) != 0)
+ sc->heap_size = 32 * (int64_t)ceil((double)(sc->heap_size) / 32.0);
+ sc->heap = (s7_pointer *)Malloc(sc->heap_size * sizeof(s7_pointer));
+ sc->free_heap = (s7_cell **)Malloc(sc->heap_size * sizeof(s7_cell *));
+ sc->free_heap_top = (s7_cell **)(sc->free_heap + INITIAL_HEAP_SIZE);
+ sc->free_heap_trigger = (s7_cell **)(sc->free_heap + GC_TRIGGER_SIZE);
+ sc->previous_free_heap_top = sc->free_heap_top;
+ {
+ s7_cell *cells = (s7_cell *)Malloc(INITIAL_HEAP_SIZE * sizeof(s7_cell)); /* was calloc 14-Apr-22 */
+ 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];
+#if S7_DEBUGGING
+ 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];
+#if S7_DEBUGGING
+ sc->heap[i]->debugger_bits = 0; sc->heap[i]->gc_line = 0; sc->heap[i]->gc_func = NULL;
+#endif
+ 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 */
+ sc->heap_blocks = (heap_block_t *)Malloc(sizeof(heap_block_t));
+ sc->heap_blocks->start = (intptr_t)cells;
+ sc->heap_blocks->end = (intptr_t)cells + (sc->heap_size * sizeof(s7_cell));
+ sc->heap_blocks->offset = 0;
+ sc->heap_blocks->next = NULL;
+ }
+ sc->gc_temps_size = GC_TEMPS_SIZE;
+ sc->gc_resize_heap_fraction = GC_RESIZE_HEAP_FRACTION;
+ sc->gc_resize_heap_by_4_fraction = GC_RESIZE_HEAP_BY_4_FRACTION;
+ sc->max_heap_size = (1LL << 45);
+ sc->gc_calls = 0;
+ sc->gc_total_time = 0;
+ /* unvectorize free-heap? t_free obj nxt -> next in list, free_heap_top|length; get free: obj=free_heap_top; top=nxt; len--
+ * push: cur->nxt=top, top=cur len++; trigger when len<trigger; can still do batch alloc/free setting len at end;
+ * how to gc sweep tmps -- seems to require a back pointer (2-way list) but there's no room; no need to realloc when heap grows, but do
+ * need to place new cells on the free list; no malloc needed, but we need to make the initial list; saves 1/8 of heap-related space.
+ * maybe a circular list (vector?) for tmps
+ */
+
+ sc->max_port_data_size = (1LL << 45);
+#ifndef OUTPUT_FILE_PORT_DATA_SIZE
+ #define OUTPUT_FILE_PORT_DATA_SIZE 2048
+#endif
+ sc->output_file_port_data_size = OUTPUT_FILE_PORT_DATA_SIZE;
+
+ /* this has to precede s7_make_* allocations */
+ sc->protected_setters_size = INITIAL_PROTECTED_OBJECTS_SIZE;
+ sc->protected_setters_loc = 0;
+ sc->protected_setters = make_vector_1(sc, INITIAL_PROTECTED_OBJECTS_SIZE, FILLED, T_VECTOR);
+ sc->protected_setter_symbols = make_vector_1(sc, INITIAL_PROTECTED_OBJECTS_SIZE, FILLED, T_VECTOR);
+
+ sc->protected_objects_size = INITIAL_PROTECTED_OBJECTS_SIZE;
+ sc->protected_objects_free_list = (s7_int *)Malloc(INITIAL_PROTECTED_OBJECTS_SIZE * sizeof(s7_int));
+ sc->protected_objects_free_list_loc = INITIAL_PROTECTED_OBJECTS_SIZE - 1;
+ sc->protected_objects = make_vector_1(sc, INITIAL_PROTECTED_OBJECTS_SIZE, FILLED, T_VECTOR);
+ for (i = 0; i < INITIAL_PROTECTED_OBJECTS_SIZE; i++) /* using #<unused> as the not-set indicator here lets that value leak out! */
+ {
+ vector_element(sc->protected_objects, i) = sc->unused;
+ vector_element(sc->protected_setters, i) = sc->unused;
+ vector_element(sc->protected_setter_symbols, i) = sc->unused;
+ sc->protected_objects_free_list[i] = i;
+ }
+
+ sc->stack = make_vector_1(sc, INITIAL_STACK_SIZE, FILLED, T_VECTOR);
+ /* if not_filled, segfault in gc_mark in mark_stack_1 after size check? probably unfilled OP_BARRIER etc? */
+ sc->stack_start = vector_elements(sc->stack); /* stack type set below */
+ sc->stack_end = sc->stack_start;
+ sc->stack_size = INITIAL_STACK_SIZE;
+ sc->stack_resize_trigger = (s7_pointer *)(sc->stack_start + (INITIAL_STACK_SIZE - STACK_RESIZE_TRIGGER));
+ set_full_type(sc->stack, T_STACK);
+ sc->max_stack_size = (1 << 30);
+ stack_clear_flags(sc->stack);
+ initialize_op_stack(sc);
+
+ /* keep the symbol table out of the heap */
+ sc->symbol_table = (s7_pointer)Malloc(sizeof(s7_cell)); /* was calloc 14-Apr-22 */
+ full_type(sc->symbol_table) = T_VECTOR | T_UNHEAP | T_SYMBOL_TABLE;
+ vector_length(sc->symbol_table) = SYMBOL_TABLE_SIZE;
+ vector_elements(sc->symbol_table) = (s7_pointer *)Malloc(SYMBOL_TABLE_SIZE * sizeof(s7_pointer));
+ vector_getter(sc->symbol_table) = t_vector_getter;
+ vector_setter(sc->symbol_table) = t_vector_setter;
+ t_vector_fill(sc->symbol_table, sc->nil);
+
+ { /* sc->opts */
+ opt_info *os = (opt_info *)Malloc(OPTS_SIZE * sizeof(opt_info)); /* was calloc, 17-Oct-21 */
+ add_saved_pointer(sc, os);
+ for (i = 0; i < OPTS_SIZE; i++)
+ {
+ opt_info *o = &os[i];
+ sc->opts[i] = o;
+ o->sc = sc;
+ }}
+
+ for (i = 0; i < NUM_TYPES; i++)
+ sc->type_names[i] = s7_make_semipermanent_string(sc, (const char *)type_name_from_type(i, INDEFINITE_ARTICLE));
+
+#if WITH_MULTITHREAD_CHECKS
+ sc->lock_count = 0;
+ {
+ pthread_mutexattr_t attr;
+ pthread_mutexattr_init(&attr);
+ pthread_mutexattr_settype(&attr, PTHREAD_MUTEX_RECURSIVE);
+ pthread_mutex_init(&sc->lock, &attr);
+ }
+#endif
+
+ sc->c_object_types = NULL;
+ sc->c_object_types_size = 0;
+ sc->num_c_object_types = 0;
+ sc->typnam = NULL;
+ sc->typnam_len = 0;
+ sc->default_rationalize_error = 1.0e-12;
+ sc->hash_table_float_epsilon = 1.0e-12;
+ sc->equivalent_float_epsilon = 1.0e-15;
+ sc->float_format_precision = WRITE_REAL_PRECISION;
+ sc->number_separator = '\0';
+ sc->default_hash_table_length = 8;
+ sc->gensym_counter = 0;
+ sc->capture_let_counter = 0;
+ sc->continuation_counter = 0;
+ sc->f_class = 0;
+ sc->add_class = 0;
+ sc->num_eq_class = 0;
+ sc->let_number = 0;
+ sc->format_column = 0;
+ sc->format_ports = NULL;
+ sc->file_names = NULL;
+ sc->file_names_size = 0;
+ sc->file_names_top = -1;
+ sc->s7_call_line = 0;
+ sc->s7_call_file = NULL;
+ sc->s7_call_name = NULL;
+ sc->safety = NO_SAFETY;
+ sc->debug = 0;
+ sc->profile = 0;
+ sc->profile_position = 0;
+ sc->debug_or_profile = false;
+ sc->profiling_gensyms = false;
+ sc->profile_data = NULL;
+ sc->profile_prefix = sc->F;
+ sc->print_length = DEFAULT_PRINT_LENGTH;
+ sc->history_size = DEFAULT_HISTORY_SIZE;
+ sc->true_history_size = DEFAULT_HISTORY_SIZE;
+ sc->baffle_ctr = 0;
+ sc->map_call_ctr = 0;
+ sc->syms_tag = 0;
+ sc->syms_tag2 = 0;
+ sc->class_name_symbol = make_symbol(sc, "class-name", 10);
+ sc->name_symbol = make_symbol(sc, "name", 4);
+ sc->trace_in_symbol = make_symbol(sc, "trace-in", 8);
+ sc->size_symbol = make_symbol(sc, "size", 4);
+ sc->is_mutable_symbol = make_symbol(sc, "mutable?", 8);
+ sc->file__symbol = make_symbol(sc, "FILE*", 5);
+ sc->circle_info = make_shared_info(sc);
+ sc->fdats = (format_data_t **)Calloc(8, sizeof(format_data_t *));
+ sc->num_fdats = 8;
+ sc->mlist_1 = semipermanent_list(sc, 1);
+ sc->mlist_2 = semipermanent_list(sc, 2);
+ sc->plist_1 = semipermanent_list(sc, 1);
+ sc->plist_2 = semipermanent_list(sc, 2);
+ sc->plist_2_2 = cdr(sc->plist_2);
+ sc->plist_3 = semipermanent_list(sc, 3);
+ sc->plist_4 = semipermanent_cons(sc, sc->unused, sc->plist_3, T_PAIR | T_IMMUTABLE);
+ sc->qlist_2 = semipermanent_list(sc, 2);
+ sc->qlist_3 = semipermanent_cons(sc, sc->unused, sc->qlist_2, T_PAIR | T_IMMUTABLE);
+ sc->clist_1 = semipermanent_list(sc, 1);
+ sc->clist_2 = semipermanent_list(sc, 2);
+ sc->dlist_1 = semipermanent_list(sc, 1);
+ sc->elist_1 = semipermanent_cons(sc, sc->unused, sc->nil, T_PAIR | T_IMMUTABLE | T_IS_ELIST);
+ sc->elist_2 = semipermanent_list(sc, 2); set_is_elist(sc->elist_2);
+ sc->elist_3 = semipermanent_list(sc, 3); set_is_elist(sc->elist_3);
+ sc->elist_4 = semipermanent_cons(sc, sc->unused, sc->elist_3, T_PAIR | T_IMMUTABLE | T_IS_ELIST);
+ sc->elist_5 = semipermanent_cons(sc, sc->unused, sc->elist_4, T_PAIR | T_IMMUTABLE | T_IS_ELIST);
+ sc->elist_6 = semipermanent_cons(sc, sc->unused, sc->elist_5, T_PAIR | T_IMMUTABLE | T_IS_ELIST);
+ sc->elist_7 = semipermanent_cons(sc, sc->unused, sc->elist_6, T_PAIR | T_IMMUTABLE | T_IS_ELIST);
+ sc->undefined_identifier_warnings = false;
+ sc->undefined_constant_warnings = false;
+ sc->wrap_only = make_wrap_only(sc);
+ sc->unentry = (hash_entry_t *)Malloc(sizeof(hash_entry_t));
+ hash_entry_set_value(sc->unentry, sc->F);
+ sc->begin_op = OP_BEGIN_NO_HOOK;
+ /* we used to laboriously set various other fields to null, but the calloc takes care of that */
+ sc->tree_pointers = NULL;
+ sc->tree_pointers_size = 0;
+ sc->tree_pointers_top = 0;
+ sc->objstr_max_len = S7_INT64_MAX;
+ sc->let_temp_hook = sc->nil;
+
+ sc->rootlet = alloc_pointer(sc);
+ set_full_type(sc->rootlet, T_LET | T_SAFE_PROCEDURE | T_UNHEAP);
+ let_set_id(sc->rootlet, -1);
+ let_set_outlet(sc->rootlet, NULL);
+ let_set_slots(sc->rootlet, slot_end);
+ add_semipermanent_let_or_slot(sc, sc->rootlet);
+
+ sc->rootlet_slots = slot_end;
+ set_curlet(sc, sc->rootlet);
+ sc->shadow_rootlet = sc->rootlet;
+ sc->unlet_slots = slot_end;
+
+ init_wrappers(sc);
+ init_standard_ports(sc);
+ init_rootlet(sc);
+ init_open_input_function_choices(sc);
+
+ {
+ s7_pointer p;
+ new_cell(sc, p, T_RANDOM_STATE); /* s7_set_default_random_state might set sc->default_random_state, so this shouldn't be permanent */
+ sc->default_random_state = p;
+#if WITH_GMP
+ mpz_set_ui(sc->mpz_1, (uint64_t)my_clock());
+ gmp_randinit_default(random_gmp_state(p));
+ gmp_randseed(random_gmp_state(p), sc->mpz_1);
+#else
+ random_seed(p) = (uint64_t)my_clock(); /* used to be time(NULL), but that means separate threads can get the same random number sequence */
+ random_carry(p) = 1675393560;
+#endif
+ }
+
+ sc->bignum_precision = DEFAULT_BIGNUM_PRECISION;
+#if WITH_GMP
+ sc->bigints = NULL;
+ sc->bigrats = NULL;
+ sc->bigflts = NULL;
+ sc->bigcmps = NULL;
+
+ mpfr_set_default_prec((mp_prec_t)DEFAULT_BIGNUM_PRECISION);
+ mpc_set_default_precision((mp_prec_t)DEFAULT_BIGNUM_PRECISION);
+ mpz_inits(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL);
+ mpq_inits(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL);
+ mpfr_inits2(DEFAULT_BIGNUM_PRECISION, sc->mpfr_1, sc->mpfr_2, sc->mpfr_3, NULL);
+ mpc_init(sc->mpc_1);
+ mpc_init(sc->mpc_2);
+
+ sc->pi_symbol = s7_define_constant(sc, "pi", big_pi(sc)); /* not actually a constant because it changes with bignum-precision */
+ s7_provide(sc, "gmp");
+#else
+ sc->pi_symbol = s7_define_constant(sc, "pi", real_pi);
+#endif
+
+ for (i = 0; i < 10; i++) sc->singletons[(uint8_t)'0' + i] = small_int(i);
+ sc->singletons[(uint8_t)'+'] = sc->add_symbol;
+ sc->singletons[(uint8_t)'-'] = sc->subtract_symbol;
+ sc->singletons[(uint8_t)'*'] = sc->multiply_symbol;
+ sc->singletons[(uint8_t)'/'] = sc->divide_symbol;
+ sc->singletons[(uint8_t)'<'] = sc->lt_symbol;
+ sc->singletons[(uint8_t)'>'] = sc->gt_symbol;
+ sc->singletons[(uint8_t)'='] = sc->num_eq_symbol;
+
+ init_choosers(sc);
+ init_typers(sc);
+ init_opt_functions(sc);
+ s7_set_history_enabled(sc, false);
+#if S7_DEBUGGING
+ init_tc_rec(sc);
+#endif
+
+ init_signatures(sc); /* depends on procedure symbols */
+ sc->s7_starlet = make_s7_starlet(sc);
+ s7_set_history_enabled(sc, true);
+
+ s7_eval_c_string(sc, "(define make-hook \n\
+ (let ((+documentation+ \"(make-hook . pars) returns a new hook (a function) that passes the parameters to each function in its function list.\")) \n\
+ (lambda hook-args \n\
+ (let ((body ())) \n\
+ (apply lambda* hook-args \n\
+ `((let ((result #<unspecified>)) \n\
+ (let ((hook (openlet (sublet (curlet) 'let-ref-fallback (lambda (e sym) #<undefined>))))) \n\
+ (for-each (lambda (hook-function) (hook-function hook)) body) \n\
+ result))))))))");
+ /* (procedure-source (make-hook 'x 'y)): (lambda* (x y) (let ((result #<unspecified>)) ... result)), see stuff.scm for commentary */
+
+ s7_eval_c_string(sc, "(define hook-functions \n\
+ (let ((+signature+ '(#t procedure?)) \n\
+ (+documentation+ \"(hook-functions hook) gets or sets the list of functions associated with the hook\")) \n\
+ (dilambda \n\
+ (lambda (hook) \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\
+ ((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\
+ (if (do ((p lst (cdr p))) \n\
+ ((not (and (pair? p) \n\
+ (procedure? (car p)) \n\
+ (aritable? (car p) 1))) \n\
+ (null? p))) \n\
+ (set! ((funclet hook) 'body) lst) \n\
+ (error 'wrong-type-arg \"hook-functions must be a list of functions, each accepting one argument: ~S\" lst))))))");
+
+ /* -------- *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).");
+
+ /* -------- *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");
+
+ /* -------- *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)");
+
+ /* -------- *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))");
+
+ /* -------- *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).");
+
+ /* -------- *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).");
+
+ /* -------- *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).");
+
+ sc->let_temp_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)");
+
+ s7_eval_c_string(sc, "(define-expansion (reader-cond . clauses) \n\
+ (if (null? clauses) \n\
+ (error 'syntax-error \"reader-cond: no clauses?\")) \n\
+ (call-with-exit \n\
+ (lambda (return) \n\
+ (for-each \n\
+ (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\
+ (when val \n\
+ (return \n\
+ (cond ((null? (cdr clause)) val) \n\
+ ((eq? (cadr clause) '=>) ((eval (caddr clause)) val)) \n\
+ ((null? (cddr clause)) (cadr clause)) \n\
+ (else (apply values (cdr clause)))))))) \n\
+ clauses) \n\
+ (values))))"); /* this is not redundant */ /* map above ignores trailing cdr if improper */
+ /* was (return `(values ,@(cdr clause))) snd-14, begin snd-13, snd-23 (else (apply values (map quote (cdr clause)))) */
+ /* we need "values" (not "begin") to make sure all entries are plugged in at the source location? but that's not how "cond" works */
+ /* maybe a better name: reader-cond-values? or reader-values or splicing-cond? */
+
+#if (!WITH_PURE_S7)
+ s7_define_variable(sc, "make-rectangular", global_value(sc->complex_symbol));
+ s7_eval_c_string(sc, "(define make-polar \n\
+ (let ((+signature+ '(number? real? real?))) \n\
+ (lambda (mag ang) \n\
+ (if (and (real? mag) (real? ang)) \n\
+ (complex (* mag (cos ang)) (* mag (sin ang))) \n\
+ (error 'wrong-type-arg \"make-polar arguments should be real\")))))");
+
+ s7_eval_c_string(sc, "(define (call-with-values producer consumer) (apply consumer (list (producer))))");
+ /* (consumer (producer)) will work in any "normal" context. If consumer is syntax and then subsequently not syntax, there is confusion */
+
+ s7_eval_c_string(sc, "(define-macro (multiple-value-bind vars expression . body) \n\
+ (list (cons 'lambda (cons vars body)) expression))");
+
+ s7_eval_c_string(sc, "(define-macro (cond-expand . clauses) \n\
+ (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\
+ (cons 'cond (map (lambda (clause) \n\
+ (if (pair? clause) \n\
+ (cons (traverse (car clause)) \n\
+ (case (cdr clause) ((()) '(#f)) (else))) \n\
+ (error 'syntax-error \"cond-expand: clause is not a pair, ~S\" clause))) \n\
+ 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
+ * (begin 23 (cond-expand (surreals 1) (foonly 2))) should evaluate to 23.
+ */
+ /* make-polar, call-with-values, make-hook, hook-functions, multiple-value-bind, cond-expand, and reader-cond can't
+ * set the initial_value to the global_value so that #_... can be used because the global_value is not semipremanent.
+ */
+#endif
+
+#if S7_DEBUGGING
+ s7_define_function(sc, "report-missed-calls", g_report_missed_calls, 0, 0, false, NULL); /* tc/recur tests in s7test.scm */
+ if (strcmp(op_names[HOP_SAFE_C_PP], "h_safe_c_pp") != 0) fprintf(stderr, "c op_name: %s\n", op_names[HOP_SAFE_C_PP]);
+ if (strcmp(op_names[OP_SET_WITH_LET_2], "set_with_let_2") != 0) fprintf(stderr, "set op_name: %s\n", op_names[OP_SET_WITH_LET_2]);
+ if (NUM_OPS != 927) fprintf(stderr, "size: cell: %d, block: %d, max op: %d, opt: %d\n", (int)sizeof(s7_cell), (int)sizeof(block_t), NUM_OPS, (int)sizeof(opt_info));
+ /* cell size: 48, 120 if debugging, block size: 40, opt: 128 or 280 */
+#endif
+ return(sc);
+}
+
+
+/* -------------------------------- s7_free -------------------------------- */
+static void gc_list_free(gc_list_t *g)
+{
+ free(g->list);
+ free(g);
+}
+
+static void big_block_free(s7_scheme *sc, block_t *block)
+{
+ if ((block_index(block) == TOP_BLOCK_LIST) && (block_data(block)))
+ {
+ free(block_data(block));
+ block_data(block) = NULL;
+ }
+}
+
+void s7_free(s7_scheme *sc)
+{
+ /* free the memory associated with sc (not globals since we might have multiple s7 interpreters running)
+ * most pointers are in the saved_pointers table, but any that might be realloc'd need to be handled explicitly
+ * valgrind --leak-check=full --show-reachable=no --suppressions=/home/bil/cl/free.supp repl s7test.scm
+ * valgrind --leak-check=full --show-reachable=yes --gen-suppressions=all --error-limit=no --log-file=raw.log repl s7test.scm
+ */
+ s7_int i;
+ gc_list_t *gp;
+
+ /* g_gc(sc, sc->nil); */ /* probably not needed (my simple tests work fine if the gc call is omitted) */ /* removed 14-Apr-22 */
+ /* s7_quit(sc); */ /* not always needed -- will clean up the C stack if we haven't returned to the top level */
+
+ gp = sc->c_objects; /* do this first since they might involve gc_unprotect etc */
+ for (i = 0; i < gp->loc; i++)
+ {
+ s7_pointer s1 = gp->list[i];
+ if (c_object_gc_free(sc, s1))
+ (*(c_object_gc_free(sc, s1)))(sc, s1);
+ else (*(c_object_free(sc, s1)))(c_object_value(s1));
+ }
+ gc_list_free(gp);
+
+ gp = sc->vectors;
+ for (i = 0; i < gp->loc; i++)
+ if (block_index(unchecked_vector_block(gp->list[i])) == TOP_BLOCK_LIST)
+ free(block_data(unchecked_vector_block(gp->list[i])));
+ gc_list_free(gp);
+ gc_list_free(sc->multivectors); /* I assume vector_dimension_info won't need 131072 bytes */
+
+ gp = sc->strings;
+ for (i = 0; i < gp->loc; i++)
+ if (block_index(unchecked_string_block(gp->list[i])) == TOP_BLOCK_LIST)
+ free(block_data(unchecked_string_block(gp->list[i])));
+ gc_list_free(gp);
+
+ gp = sc->output_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))
+ 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]));
+ }
+ 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))
+ 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 */
+
+ gp = sc->hash_tables;
+ for (i = 0; i < gp->loc; i++)
+ if (block_index(unchecked_hash_table_block(gp->list[i])) == TOP_BLOCK_LIST)
+ free(block_data(unchecked_hash_table_block(gp->list[i])));
+ gc_list_free(gp);
+
+#if WITH_GMP
+ /* free lists */
+ {bigint *p, *np; for (p = sc->bigints; p; p = np) {mpz_clear(p->n); np = p->nxt; free(p);}}
+ {bigrat *p, *np; for (p = sc->bigrats; p; p = np) {mpq_clear(p->q); np = p->nxt; free(p);}}
+ {bigflt *p, *np; for (p = sc->bigflts; p; p = np) {mpfr_clear(p->x); np = p->nxt; free(p);}}
+ {bigcmp *p, *np; for (p = sc->bigcmps; p; p = np) {mpc_clear(p->z); np = p->nxt; free(p);}}
+
+ gp = sc->big_integers;
+ for (i = 0; i < gp->loc; i++) {bigint *p; p = big_integer_bgi(gp->list[i]); mpz_clear(p->n); free(p);}
+ gc_list_free(gp);
+
+ gp = sc->big_ratios;
+ for (i = 0; i < gp->loc; i++) {bigrat *p; p = big_ratio_bgr(gp->list[i]); mpq_clear(p->q); free(p);}
+ gc_list_free(gp);
+
+ gp = sc->big_reals;
+ for (i = 0; i < gp->loc; i++) {bigflt *p; p = big_real_bgf(gp->list[i]); mpfr_clear(p->x); free(p);}
+ gc_list_free(gp);
+
+ gp = sc->big_complexes;
+ for (i = 0; i < gp->loc; i++) {bigcmp *p; p = big_complex_bgc(gp->list[i]); mpc_clear(p->z); free(p);}
+ gc_list_free(gp);
+
+ gp = sc->big_random_states;
+ for (i = 0; i < gp->loc; i++) gmp_randclear(random_gmp_state(gp->list[i]));
+ gc_list_free(gp);
+
+ gmp_randclear(random_gmp_state(sc->default_random_state));
+
+ /* temps */
+ if (sc->ratloc) free_rat_locals(sc);
+ mpz_clears(sc->mpz_1, sc->mpz_2, sc->mpz_3, sc->mpz_4, NULL);
+ mpq_clears(sc->mpq_1, sc->mpq_2, sc->mpq_3, NULL);
+ mpfr_clears(sc->mpfr_1, sc->mpfr_2, sc->mpfr_3, NULL);
+ mpc_clear(sc->mpc_1);
+ mpc_clear(sc->mpc_2);
+ /* I claim the leftovers (864 bytes, all from mpfr_cosh) are gmp's fault */
+#endif
+
+ free(undefined_name(sc->undefined));
+ gp = sc->undefineds;
+ for (i = 0; i < gp->loc; i++)
+ free(undefined_name(gp->list[i]));
+ gc_list_free(gp);
+
+ gc_list_free(sc->gensyms);
+ gc_list_free(sc->continuations); /* stack is simple vector (handled above) */
+ gc_list_free(sc->weak_refs);
+ gc_list_free(sc->weak_hash_iterators);
+ gc_list_free(sc->opt1_funcs);
+
+ free(port_port(sc->standard_output));
+ free(port_port(sc->standard_error));
+ free(port_port(sc->standard_input));
+
+ if (sc->autoload_names) free(sc->autoload_names);
+ if (sc->autoload_names_sizes) free(sc->autoload_names_sizes);
+ if (sc->autoloaded_already)
+ {
+ for (i = 0; i < sc->autoload_names_loc; 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))
+ if (block_data(top))
+ free(block_data(top));
+
+ big_block_free(sc, stack_block(sc->stack));
+ big_block_free(sc, vector_block(sc->protected_objects));
+ for (i = 0; i < sc->saved_pointers_loc; i++)
+ free(sc->saved_pointers[i]);
+ free(sc->saved_pointers);
+
+ {
+ gc_obj_t *g, *gnxt;
+ heap_block_t *hpnxt;
+ for (g = sc->semipermanent_lets; g; g = gnxt) {gnxt = g->nxt; free(g);}
+ for (g = sc->semipermanent_objects; g; g = gnxt) {gnxt = g->nxt; free(g);}
+ for (heap_block_t *hp = sc->heap_blocks; hp; hp = hpnxt) {hpnxt = hp->next; free(hp);}
+ }
+
+ free(sc->heap);
+ free(sc->free_heap);
+ free(vector_elements(sc->symbol_table)); /* alloc'd directly, not via block */
+ free(sc->symbol_table);
+ free(sc->setters);
+ free(sc->op_stack);
+ if (sc->tree_pointers) free(sc->tree_pointers);
+ free(sc->num_to_str);
+ free(sc->protected_objects_free_list);
+ if (sc->read_line_buf) free(sc->read_line_buf);
+ free(sc->strbuf);
+ free_shared_info(sc->circle_info);
+ if (sc->file_names) free(sc->file_names);
+ free(sc->unentry);
+ free(sc->input_port_stack);
+ if (sc->typnam) free(sc->typnam);
+
+ 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]);
+ }
+ free(sc->fdats);
+
+ if (sc->profile_data)
+ {
+ free(sc->profile_data->funcs);
+ free(sc->profile_data->let_names);
+ free(sc->profile_data->files);
+ free(sc->profile_data->lines);
+ free(sc->profile_data->excl);
+ free(sc->profile_data->timing_data);
+ free(sc->profile_data);
+ }
+ 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);
+ }
+ free(sc->c_object_types);
+ }
+ free(sc);
+}
+
+
+/* -------------------------------- repl -------------------------------- */
+#ifndef USE_SND
+ #define USE_SND 0
+#endif
+#ifndef WITH_MAIN
+ #define WITH_MAIN 0
+#endif
+
+#if WITH_MAIN && WITH_NOTCURSES
+ #include "nrepl.c"
+ /* gcc -o nrepl s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl -DWITH_MAIN -DWITH_NOTCURSES -lnotcurses-core */
+#else
+
+static void dumb_repl(s7_scheme *sc)
+{
+ while (true)
+ {
+ char buffer[512];
+ fprintf(stdout, "\n> ");
+ if (!fgets(buffer, 512, stdin)) break; /* error or ctrl-D */
+ if (((buffer[0] != '\n') || (strlen(buffer) > 1)))
+ {
+ char response[1024];
+ snprintf(response, 1024, "(write %s)", buffer);
+ s7_eval_c_string(sc, response);
+ }}
+ fprintf(stdout, "\n");
+ if (ferror(stdin))
+ fprintf(stderr, "read error on stdin\n");
+}
+
+void s7_repl(s7_scheme *sc)
+{
+#if (!WITH_C_LOADER)
+ dumb_repl(sc);
+#else
+#if WITH_NOTCURSES
+ s7_load(sc, "nrepl.scm");
+#else
+ /* try to get lib_s7.so from the repl's directory, and set *libc*.
+ * otherwise repl.scm will try to load libc.scm which will try to build libc_s7.so locally, but that requires s7.h
+ */
+ bool repl_loaded = false;
+ s7_pointer e = s7_inlet(sc, set_clist_2(sc, make_symbol(sc, "init_func", 9), make_symbol(sc, "libc_s7_init", 12)));
+ s7_int gc_loc = gc_protect_1(sc, e);
+ s7_pointer old_e = s7_set_curlet(sc, e); /* e is now (curlet) so loaded names from libc will be placed there, not in (rootlet) */
+ s7_pointer val = s7_load_with_environment(sc, "libc_s7.so", e);
+ if (val)
+ {
+ s7_pointer libs = global_slot(sc->libraries_symbol);
+ uint64_t hash = raw_string_hash((const uint8_t *)"*libc*", 6); /* hack around an idiotic gcc 10.2.1 warning */
+ s7_define(sc, sc->rootlet, new_symbol(sc, "*libc*", 6, hash, hash % SYMBOL_TABLE_SIZE), e);
+ slot_set_value(libs, cons(sc, cons(sc, s7_make_semipermanent_string(sc, "libc.scm"), e), slot_value(libs)));
+ }
+
+ s7_set_curlet(sc, old_e); /* restore incoming (curlet) */
+ s7_gc_unprotect_at(sc, gc_loc);
+
+ if (!val) /* s7_load was unable to find/load libc_s7.so */
+ dumb_repl(sc);
+ else
+ {
+#if S7_DEBUGGING
+ s7_autoload(sc, make_symbol(sc, "compare-calls", 13), s7_make_string(sc, "compare-calls.scm"));
+ s7_autoload(sc, make_symbol(sc, "get-overheads", 13), s7_make_string(sc, "compare-calls.scm"));
+#endif
+ s7_provide(sc, "libc.scm");
+ if (!repl_loaded) s7_load(sc, "repl.scm");
+ s7_eval_c_string(sc, "((*repl* 'run))");
+ }
+#endif
+#endif
+}
+
+#if WITH_MAIN && (!USE_SND)
+
+#if (!MS_WINDOWS) && WITH_C_LOADER
+static char *realdir(const char *filename) /* this code courtesy Lassi Kortela 4-Nov-19 */
+{
+ char *path;
+ char *p;
+ /* s7_repl wants to load libc_s7.o (for tcsetattr et al), but if it is started in a directory other than the libc_s7.so
+ * directory, it fails (it tries to build the library but that requires s7.h and libc.scm). So here we are trying to
+ * guess the libc_s7 directory from the command line program name. This can't work in general, but it works often
+ * enough to be worth the effort. If S7_LOAD_PATH is set, it is used instead.
+ */
+ if (!strchr(filename, '/'))
+ return(NULL);
+
+ if (!(path = realpath(filename, NULL))) /* in Windows maybe GetModuleFileName(NULL, buffer, buffer_size) */
+ {
+ fprintf(stderr, "%s: %s\n", strerror(errno), filename);
+ exit(2);
+ }
+ if (!(p = strrchr(path, '/')))
+ {
+ free(path);
+ fprintf(stderr, "please provide the full pathname for %s\n", filename);
+ exit(2);
+ }
+ if (p > path) *p = '\0'; else p[1] = 0;
+ return(path);
+}
+#endif
+
+int main(int argc, char **argv)
+{
+ s7_scheme *sc = s7_init();
+ fprintf(stderr, "s7: %s\n", S7_DATE);
+
+ if (argc == 2)
+ {
+ fprintf(stderr, "load %s\n", argv[1]);
+ if (!s7_load(sc, argv[1]))
+ {
+ fprintf(stderr, "can't load %s\n", argv[1]);
+ return(2);
+ }}
+ else
+ {
+#if (MS_WINDOWS) || (!WITH_C_LOADER) || ((defined(__linux__)) && (!defined(__GLIBC__))) /* musl? */
+ dumb_repl(sc);
+#else
+#ifdef S7_LOAD_PATH
+ s7_add_to_load_path(sc, S7_LOAD_PATH);
+#else
+ char *dir = realdir(argv[0]);
+ if (dir)
+ {
+ s7_add_to_load_path(sc, dir);
+ free(dir);
+ }
+#endif
+ s7_repl(sc);
+#endif
+ }
+ return(0);
+}
+
+/* in Linux: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-dynamic ; also need libc.scm cload.scm repl.scm to get a decent repl
+ * in *BSD: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm -Wl,-export-dynamic
+ * in OSX: gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm
+ * (clang also needs LDFLAGS="-Wl,-export-dynamic" in Linux and "-fPIC")
+ * in msys2: gcc s7.c -o s7 -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-all-symbols,--out-implib,s7.lib
+ * for tcc: tcc -o s7 s7.c -I. -lm -DWITH_MAIN -ldl -rdynamic -DWITH_C_LOADER
+ *
+ * for nrepl: gcc s7.c -o repl -DWITH_MAIN -DWITH_NOTCURSES -I. -O2 -g -lnotcurses-core -ldl -lm -Wl,-export-dynamic
+ *
+ * (s7.c compile time 27-Oct-22 49 secs)
+ * musl works, but there is some problem in libgsl.scm with gsl/gsl_blas.h I think
+ *
+ * valgrind --leak-check=full --show-reachable=no --suppressions=/home/bil/cl/free.supp repl s7test.scm
+ */
+#endif
+#endif
+
+/* --------------------------------------------------------------
+ * 19.9 20.9 21.0 22.0 23.0 24.0 24.3
+ * --------------------------------------------------------------
+ * tpeak 148 115 114 108 105 102 102
+ * tref 1081 691 687 463 459 464 410
+ * index 1026 1016 973 967 972 973
+ * tmock 1177 1165 1057 1019 1032 1029
+ * tvect 3408 2519 2464 1772 1669 1497 1454
+ * tauto 2562 2048 1729 1707
+ * texit 1884 1930 1950 1778 1741 1770 1769
+ * s7test 1873 1831 1818 1829 1830 1857
+ * lt 2222 2187 2172 2150 2185 1950 1952
+ * thook 7651 2590 2030 2046 2011
+ * dup 3805 3788 2492 2239 2097 2031
+ * tcopy 8035 5546 2539 2375 2386 2387
+ * tread 2440 2421 2419 2408 2405 2256
+ * titer 3657 2865 2842 2641 2509 2449 2446
+ * trclo 8031 2735 2574 2454 2445 2449 2470
+ * tmat 3065 3042 2524 2578 2590 2519
+ * tload 3046 2404 2566 2537
+ * fbench 2933 2688 2583 2460 2430 2478 2562
+ * tsort 3683 3105 3104 2856 2804 2858 2858
+ * tobj 4016 3970 3828 3577 3508 3513
+ * teq 4068 4045 3536 3486 3544 3527
+ * tio 3816 3752 3683 3620 3583 3601
+ * tmac 3950 3873 3033 3677 3677 3683
+ * tclo 6362 4787 4735 4390 4384 4474 4337
+ * tcase 4960 4793 4439 4430 4439 4429
+ * tlet 9166 7775 5640 4450 4427 4457 4481
+ * tfft 7820 7729 4755 4476 4536 4542
+ * tstar 6139 5923 5519 4449 4550 4584
+ * tmap 8869 8774 4489 4541 4586 4593
+ * tshoot 5525 5447 5183 5055 5034 5052
+ * tform 5357 5348 5307 5316 5084 5087
+ * tstr 10.0 6880 6342 5488 5162 5180 5205
+ * tnum 6348 6013 5433 5396 5409 5432
+ * tgsl 8485 7802 6373 6282 6208 6181
+ * tari 15.0 13.0 12.7 6827 6543 6278 6274
+ * tlist 9219 7896 7546 6558 6240 6300 6305
+ * tset 6260 6364 6420
+ * trec 19.5 6936 6922 6521 6588 6583 6584
+ * tleft 11.1 10.4 10.2 7657 7479 7627 7612
+ * tmisc 8142 7631 7673
+ * tlamb 8003 7941 7948
+ * tgc 11.9 11.1 8177 7857 7986 8014
+ * thash 11.8 11.7 9734 9479 9526 9254
+ * cb 12.9 11.2 11.0 9658 9564 9609 9641
+ * tmap-hash 1671.0 1467.0 10.3
+ * tmv 16.0 15.4 14.7 14.5 14.4 11.9
+ * tgen 11.2 11.4 12.0 12.1 12.2 12.3
+ * tall 15.9 15.6 15.6 15.6 15.6 15.1 15.1
+ * timp 25.4 24.4 20.0 19.6 19.7 15.6
+ * calls 36.7 37.5 37.0 37.5 37.1 37.1
+ * sg 55.9 55.8 55.4 55.2
+ * tbig 177.4 175.8 156.5 148.1 146.2 146.2
+ * --------------------------------------------------------------
+ *
+ * snd-region|select: (since we can't check for consistency when set), should there be more elaborate writable checks for default-output-header|sample-type?
+ * fx_chooser can't depend on the is_global bit because it sees args before local bindings reset that bit, get rid of these if possible
+ * lots of is_global(sc->quote_symbol)
+ * (define print-length (list 1 2)) (define (f) (with-let *s7* (+ print-length 1))) (display (f)) (newline) -- need a placeholder-let (or actual let) for *s7*?
+ * so (with-let *s7* ...) would make a let with whatever *s7* entries are needed? -> (let ((print-length (*s7* 'print-length))) ...)
+ * currently sc->s7_starlet is a let (make_s7_starlet) using g_s7_let_ref_fallback, so it assumes print-length above is undefined
+ * need some print-length/print-elements distinction for vector/pair etc
+ * 73050 vars_opt_ok problem
+ */
diff --git a/sources/s7.h b/sources/s7.h
new file mode 100644
index 0000000..97008da
--- /dev/null
+++ b/sources/s7.h
@@ -0,0 +1,1245 @@
+#ifndef S7_H
+#define S7_H
+
+#define S7_VERSION "10.8"
+#define S7_DATE "24-Apr-2024"
+#define S7_MAJOR_VERSION 10
+#define S7_MINOR_VERSION 8
+
+#include <stdint.h> /* for int64_t */
+
+typedef int64_t s7_int;
+typedef double s7_double;
+
+#ifndef __cplusplus
+#ifndef _MSC_VER
+ #include <stdbool.h>
+#else
+#ifndef true
+ #define bool unsigned char
+ #define true 1
+ #define false 0
+#endif
+#endif
+#endif
+
+#if WITH_GMP
+ /* in g++ these includes need to be outside the extern "C" business */
+ #include <gmp.h>
+ #include <mpfr.h>
+ #include <mpc.h>
+#endif
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+typedef struct s7_scheme s7_scheme;
+typedef struct s7_cell *s7_pointer;
+
+s7_scheme *s7_init(void);
+ /* s7_scheme is our interpreter
+ * s7_pointer is a Scheme object of any (Scheme) type
+ * s7_init creates the interpreter.
+ */
+void s7_free(s7_scheme *sc);
+
+typedef s7_pointer (*s7_function)(s7_scheme *sc, s7_pointer args); /* that is, obj = func(s7, args) -- args is a list of arguments */
+typedef s7_pointer (*s7_pfunc)(s7_scheme *sc);
+
+s7_pointer s7_f(s7_scheme *sc); /* #f */
+s7_pointer s7_t(s7_scheme *sc); /* #t */
+s7_pointer s7_nil(s7_scheme *sc); /* () */
+s7_pointer s7_undefined(s7_scheme *sc); /* #<undefined> */
+s7_pointer s7_unspecified(s7_scheme *sc); /* #<unspecified> */
+bool s7_is_unspecified(s7_scheme *sc, s7_pointer val); /* returns true if val is #<unspecified> */
+s7_pointer s7_eof_object(s7_scheme *sc); /* #<eof> */
+bool s7_is_null(s7_scheme *sc, s7_pointer p); /* null? */
+
+ /* these are the Scheme constants; they do not change in value during a run,
+ * so they can be safely assigned to C global variables if desired.
+ */
+
+bool s7_is_valid(s7_scheme *sc, s7_pointer arg); /* does 'arg' look like an s7 object? */
+bool s7_is_c_pointer(s7_pointer arg); /* (c-pointer? arg) */
+bool s7_is_c_pointer_of_type(s7_pointer arg, s7_pointer type);
+void *s7_c_pointer(s7_pointer p);
+void *s7_c_pointer_with_type(s7_scheme *sc, s7_pointer p, s7_pointer expected_type, const char *caller, s7_int argnum);
+s7_pointer s7_c_pointer_type(s7_pointer p);
+s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr); /* these are for passing uninterpreted C pointers through Scheme */
+s7_pointer s7_make_c_pointer_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info);
+s7_pointer s7_make_c_pointer_wrapper_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info);
+
+s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str); /* (eval-string str) */
+s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer e);
+s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer arg, bool use_write);
+ /* (object->string obj) */
+char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj); /* same as object->string but returns a C char* directly */
+ /* the returned value should be freed by the caller */
+
+s7_pointer s7_load(s7_scheme *sc, const char *file); /* (load file) */
+s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e);
+s7_pointer s7_load_c_string(s7_scheme *sc, const char *content, s7_int bytes);
+s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer e);
+s7_pointer s7_load_path(s7_scheme *sc); /* *load-path* */
+s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir); /* (set! *load-path* (cons dir *load-path*)) */
+s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_function); /* (autoload symbol file-or-function) */
+void s7_autoload_set_names(s7_scheme *sc, const char **names, s7_int size);
+
+ /* the load path is a list of directories to search if load can't find the file passed as its argument.
+ *
+ * s7_load and s7_load_with_environment can load shared object files as well as scheme code.
+ * The scheme (load "somelib.so" (inlet 'init_func 'somelib_init)) is equivalent to
+ * s7_load_with_environment(s7, "somelib.so", s7_inlet(s7, s7_list(s7, 2, s7_make_symbol(s7, "init_func"), s7_make_symbol(s7, "somelib_init"))))
+ * s7_load_with_environment returns NULL if it can't load the file.
+ */
+void s7_quit(s7_scheme *sc);
+ /* this tries to break out of the current evaluation, leaving everything else intact */
+
+void (*s7_begin_hook(s7_scheme *sc))(s7_scheme *sc, bool *val);
+void s7_set_begin_hook(s7_scheme *sc, void (*hook)(s7_scheme *sc, bool *val));
+ /* call "hook" at the start of any block; use NULL to cancel.
+ * s7_begin_hook returns the current begin_hook function or NULL.
+ */
+
+s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e); /* (eval code e) -- e is the optional environment */
+s7_pointer s7_eval_with_location(s7_scheme *sc, s7_pointer code, s7_pointer e, const char *caller, const char *file, s7_int line);
+void s7_provide(s7_scheme *sc, const char *feature); /* add feature (as a symbol) to the *features* list */
+bool s7_is_provided(s7_scheme *sc, const char *feature); /* (provided? feature) */
+void s7_repl(s7_scheme *sc);
+
+s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info);
+s7_pointer s7_wrong_type_arg_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr);
+s7_pointer s7_wrong_type_error(s7_scheme *sc, s7_pointer caller, s7_int arg_n, s7_pointer arg, s7_pointer descr);
+ /* set arg_n to 0 to indicate that caller takes only one argument (so the argument number need not be reported */
+s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr);
+s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args);
+
+ /* these are equivalent to (error ...) in Scheme
+ * the first argument to s7_error is a symbol that can be caught (via (catch tag ...))
+ * the rest of the arguments are passed to the error handler (if in catch)
+ * or printed out (in the default case). If the first element of the list
+ * of args ("info") is a string, the default error handler treats it as
+ * a format control string, and passes it to format with the rest of the
+ * info list as the format function arguments.
+ *
+ * s7_wrong_type_arg_error is equivalent to s7_error with a type of 'wrong-type-arg
+ * and similarly s7_out_of_range_error with type 'out-of-range.
+ *
+ * catch in Scheme is taken from Guile:
+ *
+ * (catch tag thunk handler)
+ *
+ * evaluates 'thunk'. If an error occurs, and the type matches 'tag' (or if 'tag' is #t),
+ * the handler is called, passing it the arguments (including the type) passed to the
+ * error function. If no handler is found, the default error handler is called,
+ * normally printing the error arguments to current-error-port.
+ */
+
+s7_pointer s7_stacktrace(s7_scheme *sc);
+s7_pointer s7_history(s7_scheme *sc); /* the current (circular backwards) history buffer */
+s7_pointer s7_add_to_history(s7_scheme *sc, s7_pointer entry); /* add entry to the history buffer */
+bool s7_history_enabled(s7_scheme *sc);
+bool s7_set_history_enabled(s7_scheme *sc, bool enabled);
+
+s7_pointer s7_gc_on(s7_scheme *sc, bool on); /* (gc on) */
+
+s7_int s7_gc_protect(s7_scheme *sc, s7_pointer x);
+void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc);
+s7_pointer s7_gc_protected_at(s7_scheme *sc, s7_int loc);
+s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x);
+s7_pointer s7_gc_protect_2_via_stack(s7_scheme *sc, s7_pointer x, s7_pointer y);
+s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x);
+s7_pointer s7_gc_protect_via_location(s7_scheme *sc, s7_pointer x, s7_int loc);
+s7_pointer s7_gc_unprotect_via_location(s7_scheme *sc, s7_int loc);
+
+ /* any s7_pointer object held in C (as a local variable for example) needs to be
+ * protected from garbage collection if there is any chance the GC may run without
+ * an existing Scheme-level reference to that object. s7_gc_protect places the
+ * object in a vector that the GC always checks, returning the object's location
+ * in that table. s7_gc_unprotect_at unprotects the object (removes it from the
+ * vector) using the location passed to it. s7_gc_protected_at returns the object
+ * at the given location.
+ *
+ * You can turn the GC on and off via s7_gc_on.
+ *
+ * There is a built-in lag between the creation of a new object and its first possible GC
+ * (the lag time is set indirectly by GC_TEMPS_SIZE in s7.c), so you don't need to worry about
+ * very short term temps such as the arguments to s7_cons in:
+ *
+ * s7_cons(s7, s7_make_real(s7, 3.14),
+ * s7_cons(s7, s7_make_integer(s7, 123), s7_nil(s7)));
+ */
+
+bool s7_is_eq(s7_pointer a, s7_pointer b); /* (eq? a b) */
+bool s7_is_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b); /* (eqv? a b) */
+bool s7_is_equal(s7_scheme *sc, s7_pointer a, s7_pointer b); /* (equal? a b) */
+bool s7_is_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y); /* (equivalent? x y) */
+
+bool s7_is_boolean(s7_pointer x); /* (boolean? x) */
+bool s7_boolean(s7_scheme *sc, s7_pointer x); /* Scheme boolean -> C bool */
+s7_pointer s7_make_boolean(s7_scheme *sc, bool x); /* C bool -> Scheme boolean */
+
+ /* for each Scheme type (boolean, integer, string, etc), there are three
+ * functions: s7_<type>(...), s7_make_<type>(...), and s7_is_<type>(...):
+ *
+ * s7_boolean(s7, obj) returns the C bool corresponding to the value of 'obj' (#f -> false)
+ * s7_make_boolean(s7, false|true) returns the s7 boolean corresponding to the C bool argument (false -> #f)
+ * s7_is_boolean(s7, obj) returns true if 'obj' has a boolean value (#f or #t).
+ */
+
+
+bool s7_is_pair(s7_pointer p); /* (pair? p) */
+s7_pointer s7_cons(s7_scheme *sc, s7_pointer a, s7_pointer b); /* (cons a b) */
+
+s7_pointer s7_car(s7_pointer p); /* (car p) */
+s7_pointer s7_cdr(s7_pointer p); /* (cdr p) */
+
+s7_pointer s7_set_car(s7_pointer p, s7_pointer q); /* (set-car! p q) */
+s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q); /* (set-cdr! p q) */
+
+s7_pointer s7_cadr(s7_pointer p); /* (cadr p) */
+s7_pointer s7_cddr(s7_pointer p); /* (cddr p) */
+s7_pointer s7_cdar(s7_pointer p); /* (cdar p) */
+s7_pointer s7_caar(s7_pointer p); /* (caar p) */
+
+s7_pointer s7_caadr(s7_pointer p); /* etc */
+s7_pointer s7_caddr(s7_pointer p);
+s7_pointer s7_cadar(s7_pointer p);
+s7_pointer s7_caaar(s7_pointer p);
+s7_pointer s7_cdadr(s7_pointer p);
+s7_pointer s7_cdddr(s7_pointer p);
+s7_pointer s7_cddar(s7_pointer p);
+s7_pointer s7_cdaar(s7_pointer p);
+
+s7_pointer s7_caaadr(s7_pointer p);
+s7_pointer s7_caaddr(s7_pointer p);
+s7_pointer s7_caadar(s7_pointer p);
+s7_pointer s7_caaaar(s7_pointer p);
+s7_pointer s7_cadadr(s7_pointer p);
+s7_pointer s7_cadddr(s7_pointer p);
+s7_pointer s7_caddar(s7_pointer p);
+s7_pointer s7_cadaar(s7_pointer p);
+s7_pointer s7_cdaadr(s7_pointer p);
+s7_pointer s7_cdaddr(s7_pointer p);
+s7_pointer s7_cdadar(s7_pointer p);
+s7_pointer s7_cdaaar(s7_pointer p);
+s7_pointer s7_cddadr(s7_pointer p);
+s7_pointer s7_cddddr(s7_pointer p);
+s7_pointer s7_cdddar(s7_pointer p);
+s7_pointer s7_cddaar(s7_pointer p);
+
+bool s7_is_list(s7_scheme *sc, s7_pointer p); /* (list? p) -> (or (pair? p) (null? p)) */
+bool s7_is_proper_list(s7_scheme *sc, s7_pointer p); /* (proper-list? p) */
+s7_int s7_list_length(s7_scheme *sc, s7_pointer a); /* (length a) */
+s7_pointer s7_make_list(s7_scheme *sc, s7_int len, s7_pointer init); /* (make-list len init) */
+s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...); /* (list ...) */
+s7_pointer s7_list_nl(s7_scheme *sc, s7_int num_values, ...); /* (list ...) arglist should be NULL terminated (more error checks than s7_list) */
+s7_pointer s7_array_to_list(s7_scheme *sc, s7_int num_values, s7_pointer *array); /* array contents -> list */
+void s7_list_to_array(s7_scheme *sc, s7_pointer list, s7_pointer *array, int32_t len); /* list -> array (intended for old code) */
+s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a); /* (reverse a) */
+s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b); /* (append a b) */
+s7_pointer s7_list_ref(s7_scheme *sc, s7_pointer lst, s7_int num); /* (list-ref lst num) */
+s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, s7_int num, s7_pointer val); /* (list-set! lst num val) */
+s7_pointer s7_assoc(s7_scheme *sc, s7_pointer obj, s7_pointer lst); /* (assoc obj lst) */
+s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer x); /* (assq obj lst) */
+s7_pointer s7_member(s7_scheme *sc, s7_pointer obj, s7_pointer lst); /* (member obj lst) */
+s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x); /* (memq obj lst) */
+bool s7_tree_memq(s7_scheme *sc, s7_pointer sym, s7_pointer tree); /* (tree-memq sym tree) */
+
+
+bool s7_is_string(s7_pointer p); /* (string? p) */
+const char *s7_string(s7_pointer p); /* Scheme string -> C string (do not free the string) */
+s7_pointer s7_make_string(s7_scheme *sc, const char *str); /* C string -> Scheme string (str is copied) */
+s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, s7_int len); /* same as s7_make_string, but provides strlen */
+s7_pointer s7_make_string_wrapper(s7_scheme *sc, const char *str);
+s7_pointer s7_make_string_wrapper_with_length(s7_scheme *sc, const char *str, s7_int len);
+s7_pointer s7_make_permanent_string(s7_scheme *sc, const char *str); /* make a string that will never be GC'd */
+s7_pointer s7_make_semipermanent_string(s7_scheme *sc, const char *str); /* for (s7) string permanent within one s7 instance (freed upon s7_free) */
+s7_int s7_string_length(s7_pointer str); /* (string-length str) */
+
+
+bool s7_is_character(s7_pointer p); /* (character? p) */
+uint8_t s7_character(s7_pointer p); /* Scheme character -> unsigned C char */
+s7_pointer s7_make_character(s7_scheme *sc, uint8_t c); /* unsigned C char -> Scheme character */
+
+
+bool s7_is_number(s7_pointer p); /* (number? p) */
+bool s7_is_integer(s7_pointer p); /* (integer? p) */
+s7_int s7_integer(s7_pointer p); /* Scheme integer -> C integer (s7_int) */
+s7_pointer s7_make_integer(s7_scheme *sc, s7_int num); /* C s7_int -> Scheme integer */
+
+bool s7_is_real(s7_pointer p); /* (real? p) */
+s7_double s7_real(s7_pointer p); /* Scheme real -> C double */
+s7_pointer s7_make_real(s7_scheme *sc, s7_double num); /* C double -> Scheme real */
+s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n);
+s7_double s7_number_to_real(s7_scheme *sc, s7_pointer x); /* x can be any kind of number */
+s7_double s7_number_to_real_with_caller(s7_scheme *sc, s7_pointer x, const char *caller);
+s7_double s7_number_to_real_with_location(s7_scheme *sc, s7_pointer x, s7_pointer caller);
+s7_int s7_number_to_integer(s7_scheme *sc, s7_pointer x);
+s7_int s7_number_to_integer_with_caller(s7_scheme *sc, s7_pointer x, const char *caller);
+
+bool s7_is_rational(s7_pointer arg); /* (rational? arg) -- integer or ratio */
+bool s7_is_ratio(s7_pointer arg); /* true if arg is a ratio, not an integer */
+s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b); /* returns the Scheme object a/b */
+s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error); /* (rationalize x error) */
+s7_int s7_numerator(s7_pointer x); /* (numerator x) */
+s7_int s7_denominator(s7_pointer x); /* (denominator x) */
+s7_double s7_random(s7_scheme *sc, s7_pointer state); /* (random x) */
+s7_pointer s7_random_state(s7_scheme *sc, s7_pointer seed); /* (random-state seed) */
+s7_pointer s7_random_state_to_list(s7_scheme *sc, s7_pointer args); /* (random-state->list r) */
+void s7_set_default_random_state(s7_scheme *sc, s7_int seed, s7_int carry);
+bool s7_is_random_state(s7_pointer p); /* (random-state? p) */
+
+bool s7_is_complex(s7_pointer arg); /* (complex? arg) */
+s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b); /* returns the Scheme object a+bi */
+s7_double s7_real_part(s7_pointer z); /* (real-part z) */
+s7_double s7_imag_part(s7_pointer z); /* (imag-part z) */
+char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, s7_int radix); /* (number->string obj radix) */
+
+bool s7_is_vector(s7_pointer p); /* (vector? p) */
+s7_int s7_vector_length(s7_pointer vec); /* (vector-length vec) */
+s7_int s7_vector_rank(s7_pointer vect); /* number of dimensions in vect */
+s7_int s7_vector_dimension(s7_pointer vec, s7_int dim);
+s7_pointer *s7_vector_elements(s7_pointer vec); /* a pointer to the array of s7_pointers */
+s7_int *s7_int_vector_elements(s7_pointer vec);
+uint8_t *s7_byte_vector_elements(s7_pointer vec);
+s7_double *s7_float_vector_elements(s7_pointer vec);
+bool s7_is_float_vector(s7_pointer p); /* (float-vector? p) */
+bool s7_is_int_vector(s7_pointer p); /* (int-vector? p) */
+bool s7_is_byte_vector(s7_pointer p); /* (byte-vector? p) */
+
+s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_int index); /* (vector-ref vec index) */
+s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer a); /* (vector-set! vec index a) */
+s7_pointer s7_vector_ref_n(s7_scheme *sc, s7_pointer vector, s7_int indices, ...); /* multidimensional vector-ref */
+s7_pointer s7_vector_set_n(s7_scheme *sc, s7_pointer vector, s7_pointer value, s7_int indices, ...); /* multidimensional vector-set! */
+s7_int s7_vector_dimensions(s7_pointer vec, s7_int *dims, s7_int dims_size); /* vector dimensions */
+s7_int s7_vector_offsets(s7_pointer vec, s7_int *offs, s7_int offs_size);
+
+s7_int s7_int_vector_ref(s7_pointer vec, s7_int index);
+s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value);
+uint8_t s7_byte_vector_ref(s7_pointer vec, s7_int index);
+uint8_t s7_byte_vector_set(s7_pointer vec, s7_int index, uint8_t value);
+s7_double s7_float_vector_ref(s7_pointer vec, s7_int index);
+s7_double s7_float_vector_set(s7_pointer vec, s7_int index, s7_double value);
+
+s7_pointer s7_make_vector(s7_scheme *sc, s7_int len); /* (make-vector len) */
+s7_pointer s7_make_int_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info);
+s7_pointer s7_make_byte_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info);
+s7_pointer s7_make_float_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info);
+s7_pointer s7_make_normal_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info); /* make-vector but possibly multidimensional */
+s7_pointer s7_make_float_vector_wrapper(s7_scheme *sc, s7_int len, s7_double *data, s7_int dims, s7_int *dim_info, bool free_data);
+s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill); /* (make-vector len fill) */
+
+void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj); /* (vector-fill! vec obj) */
+s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vect);
+s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect); /* (vector->list vec) */
+ /*
+ * (vect i) is the same as (vector-ref vect i)
+ * (set! (vect i) x) is the same as (vector-set! vect i x)
+ * (vect i j k) accesses the 3-dimensional vect
+ * (set! (vect i j k) x) sets that element (vector-ref and vector-set! can also be used)
+ * (make-vector (list 2 3 4)) returns a 3-dimensional vector with the given dimension sizes
+ * (make-vector '(2 3) 1.0) returns a 2-dim vector with all elements set to 1.0
+ */
+
+bool s7_is_hash_table(s7_pointer p); /* (hash-table? p) */
+s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size); /* (make-hash-table size) */
+s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key);
+ /* (hash-table-ref table key) */
+s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value);
+ /* (hash-table-set! table key value) */
+s7_int s7_hash_code(s7_scheme *sc, s7_pointer obj, s7_pointer eqfunc); /* (hash-code obj [eqfunc]) */
+
+s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook); /* (hook-functions hook) */
+s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions); /* (set! (hook-functions hook) ...) */
+
+
+bool s7_is_input_port(s7_scheme *sc, s7_pointer p); /* (input-port? p) */
+bool s7_is_output_port(s7_scheme *sc, s7_pointer p); /* (output-port? p) */
+const char *s7_port_filename(s7_scheme *sc, s7_pointer x); /* (port-filename p) */
+s7_int s7_port_line_number(s7_scheme *sc, s7_pointer p); /* (port-line-number p) */
+
+s7_pointer s7_current_input_port(s7_scheme *sc); /* (current-input-port) */
+s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer p); /* (set-current-input-port) */
+s7_pointer s7_current_output_port(s7_scheme *sc); /* (current-output-port) */
+s7_pointer s7_set_current_output_port(s7_scheme *sc, s7_pointer p); /* (set-current-output-port) */
+s7_pointer s7_current_error_port(s7_scheme *sc); /* (current-error-port) */
+s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port); /* (set-current-error-port port) */
+void s7_close_input_port(s7_scheme *sc, s7_pointer p); /* (close-input-port p) */
+void s7_close_output_port(s7_scheme *sc, s7_pointer p); /* (close-output-port p) */
+s7_pointer s7_open_input_file(s7_scheme *sc, const char *name, const char *mode);
+ /* (open-input-file name mode) */
+s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode);
+ /* (open-output-file name mode) */
+ /* mode here is an optional C style flag, "a" for "alter", etc ("r" is the input default, "w" is the output default) */
+s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string);
+ /* (open-input-string str) */
+s7_pointer s7_open_output_string(s7_scheme *sc); /* (open-output-string) */
+const char *s7_get_output_string(s7_scheme *sc, s7_pointer out_port); /* (get-output-string port) -- current contents of output string */
+ /* don't free the string */
+s7_pointer s7_output_string(s7_scheme *sc, s7_pointer p); /* same but returns an s7 string */
+bool s7_flush_output_port(s7_scheme *sc, s7_pointer p); /* (flush-output-port port) */
+
+typedef enum {S7_READ, S7_READ_CHAR, S7_READ_LINE, S7_PEEK_CHAR, S7_IS_CHAR_READY, S7_NUM_READ_CHOICES} s7_read_t;
+s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port));
+s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port));
+
+s7_pointer s7_read_char(s7_scheme *sc, s7_pointer port); /* (read-char port) */
+s7_pointer s7_peek_char(s7_scheme *sc, s7_pointer port); /* (peek-char port) */
+s7_pointer s7_read(s7_scheme *sc, s7_pointer port); /* (read port) */
+void s7_newline(s7_scheme *sc, s7_pointer port); /* (newline port) */
+s7_pointer s7_write_char(s7_scheme *sc, s7_pointer c, s7_pointer port); /* (write-char c port) */
+s7_pointer s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port); /* (write obj port) */
+s7_pointer s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port); /* (display obj port) */
+const char *s7_format(s7_scheme *sc, s7_pointer args); /* (format ... */
+
+
+bool s7_is_syntax(s7_pointer p); /* (syntax? p) */
+bool s7_is_symbol(s7_pointer p); /* (symbol? p) */
+const char *s7_symbol_name(s7_pointer p); /* (symbol->string p) -- don't free the string */
+s7_pointer s7_make_symbol(s7_scheme *sc, const char *name); /* (string->symbol name) */
+s7_pointer s7_gensym(s7_scheme *sc, const char *prefix); /* (gensym prefix) */
+
+bool s7_is_keyword(s7_pointer obj); /* (keyword? obj) */
+s7_pointer s7_make_keyword(s7_scheme *sc, const char *key); /* (string->keyword key) */
+s7_pointer s7_keyword_to_symbol(s7_scheme *sc, s7_pointer key); /* (keyword->symbol key) */
+
+s7_pointer s7_rootlet(s7_scheme *sc); /* (rootlet) */
+s7_pointer s7_shadow_rootlet(s7_scheme *sc);
+s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let);
+s7_pointer s7_curlet(s7_scheme *sc); /* (curlet) */
+s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e); /* returns previous curlet */
+s7_pointer s7_outlet(s7_scheme *sc, s7_pointer e); /* (outlet e) */
+s7_pointer s7_sublet(s7_scheme *sc, s7_pointer env, s7_pointer bindings); /* (sublet e ...) */
+s7_pointer s7_inlet(s7_scheme *sc, s7_pointer bindings); /* (inlet ...) */
+s7_pointer s7_varlet(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value); /* (varlet env symbol value) */
+s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer env); /* (let->list env) */
+bool s7_is_let(s7_pointer e); /* )let? e) */
+s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer env, s7_pointer sym); /* (let-ref e sym) */
+s7_pointer s7_let_set(s7_scheme *sc, s7_pointer env, s7_pointer sym, s7_pointer val); /* (let-set! e sym val) */
+s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e); /* (openlet e) */
+bool s7_is_openlet(s7_pointer e); /* (openlet? e) */
+s7_pointer s7_method(s7_scheme *sc, s7_pointer obj, s7_pointer method);
+
+/* *s7* */
+/* these renamed because "s7_let_field" seems the same as "s7_let", but here we're referring to *s7*, not any let */
+s7_pointer s7_let_field_ref(s7_scheme *sc, s7_pointer sym); /* (*s7* sym) */
+s7_pointer s7_let_field_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value); /* (set! (*s7* sym) new_value) */
+/* new names */
+s7_pointer s7_starlet_ref(s7_scheme *sc, s7_pointer sym); /* (*s7* sym) */
+s7_pointer s7_starlet_set(s7_scheme *sc, s7_pointer sym, s7_pointer new_value); /* (set! (*s7* sym) new_value) */
+
+s7_pointer s7_name_to_value(s7_scheme *sc, const char *name); /* name's value in the current environment (after turning name into a symbol) */
+s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name);
+s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym);
+s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val);
+s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer local_env);
+bool s7_for_each_symbol_name(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data);
+bool s7_for_each_symbol(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data);
+
+ /* these access the current environment and symbol table, providing
+ * a symbol's current binding (s7_name_to_value takes the symbol name as a char*,
+ * s7_symbol_value takes the symbol itself, s7_symbol_set_value changes the
+ * current binding, and s7_symbol_local_value uses the environment passed
+ * as its third argument).
+ *
+ * To iterate over the complete symbol table, use s7_for_each_symbol_name,
+ * and s7_for_each_symbol. Both call 'symbol_func' on each symbol, passing it
+ * the symbol or symbol name, and the uninterpreted 'data' pointer.
+ * the current binding. The for-each loop stops if the symbol_func returns true,
+ * or at the end of the table.
+ */
+
+s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_pointer finish);
+
+bool s7_is_immutable(s7_pointer p);
+s7_pointer s7_immutable(s7_pointer p);
+
+void s7_define(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value);
+bool s7_is_defined(s7_scheme *sc, const char *name);
+s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value);
+s7_pointer s7_define_variable_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help);
+s7_pointer s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value);
+s7_pointer s7_define_constant_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help);
+s7_pointer s7_define_constant_with_environment(s7_scheme *sc, s7_pointer envir, const char *name, s7_pointer value);
+ /* These functions add a symbol and its binding to either the top-level environment
+ * or the 'env' passed as the second argument to s7_define. Except for s7_define, they return
+ * the name as a symbol.
+ *
+ * s7_define_variable(sc, "*features*", s7_nil(sc));
+ *
+ * in s7.c is equivalent to the top level form
+ *
+ * (define *features* ())
+ *
+ * s7_define_variable is simply s7_define with string->symbol and the global environment.
+ * s7_define_constant is s7_define but makes its "definee" immutable.
+ * s7_define is equivalent to define in Scheme, except that it does not return the value.
+ */
+
+bool s7_is_function(s7_pointer p);
+bool s7_is_procedure(s7_pointer x); /* (procedure? x) */
+bool s7_is_macro(s7_scheme *sc, s7_pointer x); /* (macro? x) */
+s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p);
+s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p);
+s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer p);
+s7_pointer s7_funclet(s7_scheme *sc, s7_pointer p); /* (funclet x) */
+bool s7_is_aritable(s7_scheme *sc, s7_pointer x, s7_int args); /* (aritable? x args) */
+s7_pointer s7_arity(s7_scheme *sc, s7_pointer x); /* (arity x) */
+const char *s7_help(s7_scheme *sc, s7_pointer obj); /* (help obj) */
+s7_pointer s7_make_continuation(s7_scheme *sc); /* call/cc... (see example below) */
+
+const char *s7_documentation(s7_scheme *sc, s7_pointer p); /* (documentation x) if any (don't free the string) */
+const char *s7_set_documentation(s7_scheme *sc, s7_pointer p, const char *new_doc);
+s7_pointer s7_setter(s7_scheme *sc, s7_pointer obj); /* (setter obj) */
+s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer p, s7_pointer setter); /* (set! (setter p) setter) */
+s7_pointer s7_signature(s7_scheme *sc, s7_pointer func); /* (signature obj) */
+s7_pointer s7_make_signature(s7_scheme *sc, s7_int len, ...); /* procedure-signature data */
+s7_pointer s7_make_circular_signature(s7_scheme *sc, s7_int cycle_point, s7_int len, ...);
+
+/* possibly unsafe functions: */
+s7_pointer s7_make_function(s7_scheme *sc, const char *name, s7_function fnc, s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc);
+
+/* safe functions: */
+s7_pointer s7_make_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_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);
+
+/* arglist or body possibly unsafe: */
+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);
+
+/* arglist and body safe: */
+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_pointer s7_define_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);
+
+/* arglist unsafe or body unsafe: */
+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);
+
+/* arglist safe, body possibly unsafe: */
+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_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc);
+s7_pointer s7_make_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc);
+void s7_define_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc);
+void s7_define_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc);
+void s7_define_typed_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc, s7_pointer signature);
+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_make_function creates a Scheme function object from the s7_function 'fnc'.
+ * Its name (for s7_describe_object) is 'name', it requires 'required_args' arguments,
+ * can accept 'optional_args' other arguments, and if 'rest_arg' is true, it accepts
+ * a "rest" argument (a list of all the trailing arguments). The function's documentation
+ * is 'doc'. The s7_make_functions return the new function, but the s7_define_function (and macro)
+ * procedures return the name as a symbol (a desire for backwards compatibility brought about this split).
+ *
+ * s7_define_function is the same as s7_make_function, but it also adds 'name' (as a symbol) to the
+ * global (top-level) environment, with the function as its value (and returns the symbol, not the function).
+ * For example, the Scheme function 'car' is essentially:
+ *
+ * s7_pointer g_car(s7_scheme *sc, s7_pointer args) {return(s7_car(s7_car(args)));}
+ *
+ * then bound to the name "car":
+ *
+ * s7_define_function(sc, "car", g_car, 1, 0, false, "(car obj)");
+ * ^ one required arg, no optional arg, no "rest" arg
+ *
+ * s7_is_function returns true if its argument is a function defined in this manner.
+ * s7_apply_function applies the function (the result of s7_make_function) to the arguments.
+ *
+ * s7_define_macro defines a Scheme macro; its arguments are not evaluated (unlike a function),
+ * but the macro's returned value (assumed to be some sort of Scheme expression) is evaluated.
+ * s7_define_macro returns the name as a symbol.
+ *
+ * Use the "unsafe" definer if the function might call the evaluator itself in some way (s7_apply_function for example),
+ * or messes with s7's stack.
+ */
+
+ /* In s7, (define* (name . args) body) or (define name (lambda* args body))
+ * define a function that takes optional (keyword) named arguments.
+ * The "args" is a list that can contain either names (normal arguments),
+ * or lists of the form (name default-value), in any order. When called,
+ * the names are bound to their default values (or #f), then the function's
+ * current arglist is scanned. Any name that occurs as a keyword (":name")
+ * precedes that argument's new value. Otherwise, as values occur, they
+ * are plugged into the environment based on their position in the arglist
+ * (as normal for a function). So,
+ *
+ * (define* (hi a (b 32) (c "hi")) (list a b c))
+ * (hi 1) -> '(1 32 "hi")
+ * (hi :b 2 :a 3) -> '(3 2 "hi")
+ * (hi 3 2 1) -> '(3 2 1)
+ *
+ * :rest causes its argument to be bound to the rest of the arguments at that point.
+ *
+ * The C connection to this takes the function name, the C function to call, the argument
+ * list as written in Scheme, and the documentation string. s7 makes sure the arguments
+ * are ordered correctly and have the specified defaults before calling the C function.
+ * s7_define_function_star(sc, "a-func", a_func, "arg1 (arg2 32)", "an example of C define*");
+ * Now (a-func :arg1 2) calls the C function a_func(2, 32). See the example program in s7.html.
+ *
+ * In s7 Scheme, define* can be used just for its optional arguments feature, but that is
+ * included in s7_define_function. s7_define_function_star implements keyword arguments
+ * for C-level functions (as well as optional/rest arguments).
+ */
+
+s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args);
+s7_pointer s7_apply_function_star(s7_scheme *sc, s7_pointer fnc, s7_pointer args);
+
+s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args);
+s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args, const char *caller, const char *file, s7_int line);
+s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7_pointer error_handler);
+
+ /* s7_call takes a Scheme function and applies it to 'args' (a list of arguments) returning the result.
+ * s7_pointer kar;
+ * kar = s7_make_function(sc, "car", g_car, 1, 0, false, "(car obj)");
+ * s7_integer(s7_call(sc, kar, s7_cons(sc, s7_cons(sc, s7_make_integer(sc, 123), s7_nil(sc)), s7_nil(sc))));
+ * returns 123.
+ *
+ * s7_call_with_location passes some information to the error handler.
+ * s7_call makes sure some sort of catch exists if an error occurs during the call, but
+ * s7_apply_function does not -- it assumes the catch has been set up already.
+ * s7_call_with_catch wraps an explicit catch around a function call ("body" above);
+ * s7_call_with_catch(sc, tag, body, err) is equivalent to (catch tag body err).
+ */
+
+bool s7_is_dilambda(s7_pointer obj);
+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);
+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);
+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);
+
+s7_pointer s7_values(s7_scheme *sc, s7_pointer args); /* (values ...) */
+bool s7_is_multiple_value(s7_pointer obj); /* is obj the results of (values ...) */
+
+s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e); /* (make-iterator e) */
+bool s7_is_iterator(s7_pointer obj); /* (iterator? obj) */
+bool s7_iterator_is_at_end(s7_scheme *sc, s7_pointer obj); /* (iterator-at-end? obj) */
+s7_pointer s7_iterate(s7_scheme *sc, s7_pointer iter); /* (iterate iter) */
+
+s7_pointer s7_copy(s7_scheme *sc, s7_pointer args); /* (copy ...) */
+s7_pointer s7_fill(s7_scheme *sc, s7_pointer args); /* (fill! ...) */
+s7_pointer s7_type_of(s7_scheme *sc, s7_pointer arg); /* (type-of arg) */
+
+
+
+/* -------------------------------------------------------------------------------- */
+/* c types/objects */
+
+void s7_mark(s7_pointer p);
+
+bool s7_is_c_object(s7_pointer p);
+s7_int s7_c_object_type(s7_pointer obj);
+void *s7_c_object_value(s7_pointer obj);
+void *s7_c_object_value_checked(s7_pointer obj, s7_int type);
+s7_pointer s7_make_c_object(s7_scheme *sc, s7_int type, void *value);
+s7_pointer s7_make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let);
+s7_pointer s7_make_c_object_without_gc(s7_scheme *sc, s7_int type, void *value);
+s7_pointer s7_c_object_let(s7_pointer obj);
+s7_pointer s7_c_object_set_let(s7_scheme *sc, s7_pointer obj, s7_pointer e);
+/* the "let" in s7_make_c_object_with_let and s7_c_object_set_let needs to be GC protected by marking it in the c_object's mark function */
+
+s7_int s7_make_c_type(s7_scheme *sc, const char *name); /* create a new c_object type */
+
+/* old style free/mark/equal */
+void s7_c_type_set_free (s7_scheme *sc, s7_int tag, void (*gc_free)(void *value));
+void s7_c_type_set_mark (s7_scheme *sc, s7_int tag, void (*mark)(void *value));
+void s7_c_type_set_equal (s7_scheme *sc, s7_int tag, bool (*equal)(void *value1, void *value2));
+
+/* new style free/mark/equal and equivalent */
+void s7_c_type_set_gc_free (s7_scheme *sc, s7_int tag, s7_pointer (*gc_free) (s7_scheme *sc, s7_pointer obj)); /* free c_object function, new style*/
+void s7_c_type_set_gc_mark (s7_scheme *sc, s7_int tag, s7_pointer (*mark) (s7_scheme *sc, s7_pointer obj)); /* mark function, new style */
+void s7_c_type_set_is_equal (s7_scheme *sc, s7_int tag, s7_pointer (*is_equal) (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_is_equivalent(s7_scheme *sc, s7_int tag, s7_pointer (*is_equivalent)(s7_scheme *sc, s7_pointer args));
+
+void s7_c_type_set_ref (s7_scheme *sc, s7_int tag, s7_pointer (*ref) (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_set (s7_scheme *sc, s7_int tag, s7_pointer (*set) (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_length (s7_scheme *sc, s7_int tag, s7_pointer (*length) (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_copy (s7_scheme *sc, s7_int tag, s7_pointer (*copy) (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_fill (s7_scheme *sc, s7_int tag, s7_pointer (*fill) (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_reverse (s7_scheme *sc, s7_int tag, s7_pointer (*reverse) (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_to_list (s7_scheme *sc, s7_int tag, s7_pointer (*to_list) (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_to_string (s7_scheme *sc, s7_int tag, s7_pointer (*to_string) (s7_scheme *sc, s7_pointer args));
+void s7_c_type_set_getter (s7_scheme *sc, s7_int tag, s7_pointer getter);
+void s7_c_type_set_setter (s7_scheme *sc, s7_int tag, s7_pointer setter);
+/* For the copy function, either the first or second argument can be a c-object of the given type. */
+
+ /* These functions create a new Scheme object type. There is a simple example in s7.html.
+ *
+ * s7_make_c_type creates a new C-based type for Scheme. It returns an s7_int "tag" used to indentify this type elsewhere.
+ * The functions associated with this type are set via s7_c_type_set*:
+ *
+ * free: the function called when an object of this type is about to be garbage collected
+ * mark: called during the GC mark pass -- you should call s7_mark
+ * on any embedded s7_pointer associated with the object (including its "let") to protect if from the GC.
+ * gc_mark and gc_free are new forms of mark and free, taking the c_object s7_pointer rather than its void* value
+ * equal: compare two objects of this type; (equal? obj1 obj2) -- this is the old form
+ * is_equal: compare objects as in equal? -- this is the new form of equal?
+ * is_equivalent: compare objects as in equivalent?
+ * ref: a function that is called whenever an object of this type
+ * occurs in the function position (at the car of a list; the rest of the list
+ * is passed to the ref function as the arguments: (obj ...))
+ * set: a function that is called whenever an object of this type occurs as
+ * the target of a generalized set! (set! (obj ...) val)
+ * length: the function called when the object is asked what its length is.
+ * copy: the function called when a copy of the object is needed.
+ * fill: the function called to fill the object with some value.
+ * reverse: similarly...
+ * to_string: object->string for an object of this type
+ * getter/setter: these help the optimizer handle applicable c-objects (see s7test.scm for an example)
+ *
+ * s7_is_c_object returns true if 'p' is a c_object
+ * s7_c_object_type returns the c_object's type (the s7_int passed to s7_make_c_object)
+ * s7_c_object_value returns the value bound to that c_object (the void *value of s7_make_c_object)
+ * s7_make_c_object creates a new Scheme entity of the given type with the given (uninterpreted) value
+ * s7_mark marks any Scheme c_object as in-use (use this in the mark function to mark
+ * any embedded s7_pointer variables).
+ */
+
+/* -------------------------------------------------------------------------------- */
+/* the new clm optimizer! this time for sure!
+ * d=double, i=integer, v=c_object, p=s7_pointer
+ * first return type, then arg types, d_vd -> returns double takes c_object and double (i.e. a standard clm generator)
+ *
+ * It is possible to tell s7 to call a foreign function directly, without any scheme-related
+ * overhead. The call needs to take the form of one of the s7_*_t functions in s7.h. For example,
+ * one way to call + is to pass it two s7_double arguments and get an s7_double back. This is the
+ * s7_d_dd_t function (the first letter gives the return type, the rest give successive argument types).
+ * We tell s7 about it via s7_set_d_dd_function. Whenever s7's optimizer encounters + with two arguments
+ * that it (the optimizer) knows are s7_doubles, in a context where an s7_double result is expected,
+ * s7 calls the s7_d_dd_t function directly without consing a list of arguments, and without
+ * wrapping up the result as a scheme cell.
+ */
+
+s7_pfunc s7_optimize(s7_scheme *sc, s7_pointer expr);
+
+typedef s7_double (*s7_float_function)(s7_scheme *sc);
+s7_float_function s7_float_optimize(s7_scheme *sc, s7_pointer expr);
+
+typedef s7_double (*s7_d_t)(void);
+void s7_set_d_function(s7_scheme *sc, s7_pointer f, s7_d_t df);
+s7_d_t s7_d_function(s7_pointer f);
+
+typedef s7_double (*s7_d_d_t)(s7_double x);
+void s7_set_d_d_function(s7_scheme *sc, s7_pointer f, s7_d_d_t df);
+s7_d_d_t s7_d_d_function(s7_pointer f);
+
+typedef s7_double (*s7_d_dd_t)(s7_double x1, s7_double x2);
+void s7_set_d_dd_function(s7_scheme *sc, s7_pointer f, s7_d_dd_t df);
+s7_d_dd_t s7_d_dd_function(s7_pointer f);
+
+typedef s7_double (*s7_d_ddd_t)(s7_double x1, s7_double x2, s7_double x3);
+void s7_set_d_ddd_function(s7_scheme *sc, s7_pointer f, s7_d_ddd_t df);
+s7_d_ddd_t s7_d_ddd_function(s7_pointer f);
+
+typedef s7_double (*s7_d_dddd_t)(s7_double x1, s7_double x2, s7_double x3, s7_double x4);
+void s7_set_d_dddd_function(s7_scheme *sc, s7_pointer f, s7_d_dddd_t df);
+s7_d_dddd_t s7_d_dddd_function(s7_pointer f);
+
+typedef s7_double (*s7_d_v_t)(void *v);
+void s7_set_d_v_function(s7_scheme *sc, s7_pointer f, s7_d_v_t df);
+s7_d_v_t s7_d_v_function(s7_pointer f);
+
+typedef s7_double (*s7_d_vd_t)(void *v, s7_double d);
+void s7_set_d_vd_function(s7_scheme *sc, s7_pointer f, s7_d_vd_t df);
+s7_d_vd_t s7_d_vd_function(s7_pointer f);
+
+typedef s7_double (*s7_d_vdd_t)(void *v, s7_double x1, s7_double x2);
+void s7_set_d_vdd_function(s7_scheme *sc, s7_pointer f, s7_d_vdd_t df);
+s7_d_vdd_t s7_d_vdd_function(s7_pointer f);
+
+typedef s7_double (*s7_d_vid_t)(void *v, s7_int i, s7_double d);
+void s7_set_d_vid_function(s7_scheme *sc, s7_pointer f, s7_d_vid_t df);
+s7_d_vid_t s7_d_vid_function(s7_pointer f);
+
+typedef s7_double (*s7_d_p_t)(s7_pointer p);
+void s7_set_d_p_function(s7_scheme *sc, s7_pointer f, s7_d_p_t df);
+s7_d_p_t s7_d_p_function(s7_pointer f);
+
+typedef s7_double (*s7_d_pd_t)(s7_pointer v, s7_double x);
+void s7_set_d_pd_function(s7_scheme *sc, s7_pointer f, s7_d_pd_t df);
+s7_d_pd_t s7_d_pd_function(s7_pointer f);
+
+typedef s7_double (*s7_d_7pi_t)(s7_scheme *sc, s7_pointer v, s7_int i);
+void s7_set_d_7pi_function(s7_scheme *sc, s7_pointer f, s7_d_7pi_t df);
+s7_d_7pi_t s7_d_7pi_function(s7_pointer f);
+
+typedef s7_double (*s7_d_7pid_t)(s7_scheme *sc, s7_pointer v, s7_int i, s7_double d);
+void s7_set_d_7pid_function(s7_scheme *sc, s7_pointer f, s7_d_7pid_t df);
+s7_d_7pid_t s7_d_7pid_function(s7_pointer f);
+
+typedef s7_double (*s7_d_id_t)(s7_int i, s7_double d);
+void s7_set_d_id_function(s7_scheme *sc, s7_pointer f, s7_d_id_t df);
+s7_d_id_t s7_d_id_function(s7_pointer f);
+
+typedef s7_double (*s7_d_ip_t)(s7_int i, s7_pointer p);
+void s7_set_d_ip_function(s7_scheme *sc, s7_pointer f, s7_d_ip_t df);
+s7_d_ip_t s7_d_ip_function(s7_pointer f);
+
+typedef s7_int (*s7_i_i_t)(s7_int x);
+void s7_set_i_i_function(s7_scheme *sc, s7_pointer f, s7_i_i_t df);
+s7_i_i_t s7_i_i_function(s7_pointer f);
+
+typedef s7_int (*s7_i_7d_t)(s7_scheme *sc, s7_double x);
+void s7_set_i_7d_function(s7_scheme *sc, s7_pointer f, s7_i_7d_t df);
+s7_i_7d_t s7_i_7d_function(s7_pointer f);
+
+typedef s7_int (*s7_i_ii_t)(s7_int i1, s7_int i2);
+void s7_set_i_ii_function(s7_scheme *sc, s7_pointer f, s7_i_ii_t df);
+s7_i_ii_t s7_i_ii_function(s7_pointer f);
+
+typedef s7_int (*s7_i_7p_t)(s7_scheme *sc, s7_pointer p);
+void s7_set_i_7p_function(s7_scheme *sc, s7_pointer f, s7_i_7p_t df);
+s7_i_7p_t s7_i_7p_function(s7_pointer f);
+
+typedef bool (*s7_b_p_t)(s7_pointer p);
+void s7_set_b_p_function(s7_scheme *sc, s7_pointer f, s7_b_p_t df);
+s7_b_p_t s7_b_p_function(s7_pointer f);
+
+typedef s7_pointer (*s7_p_d_t)(s7_scheme *sc, s7_double x);
+void s7_set_p_d_function(s7_scheme *sc, s7_pointer f, s7_p_d_t df);
+s7_p_d_t s7_p_d_function(s7_pointer f);
+
+typedef s7_pointer (*s7_p_p_t)(s7_scheme *sc, s7_pointer p);
+void s7_set_p_p_function(s7_scheme *sc, s7_pointer f, s7_p_p_t df);
+s7_p_p_t s7_p_p_function(s7_pointer f);
+
+typedef s7_pointer (*s7_p_pp_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2);
+void s7_set_p_pp_function(s7_scheme *sc, s7_pointer f, s7_p_pp_t df);
+s7_p_pp_t s7_p_pp_function(s7_pointer f);
+
+typedef s7_pointer (*s7_p_ppp_t)(s7_scheme *sc, s7_pointer p1, s7_pointer p2, s7_pointer p3);
+void s7_set_p_ppp_function(s7_scheme *sc, s7_pointer f, s7_p_ppp_t df);
+s7_p_ppp_t s7_p_ppp_function(s7_pointer f);
+
+/* Here is an example of using these functions; more extensive examples are in clm2xen.c in sndlib, and in s7.c.
+ * (This example comes from a HackerNews discussion):
+ * plus.c:
+ * --------
+ * #include "s7.h"
+ *
+ * s7_pointer g_plusone(s7_scheme *sc, s7_pointer args) {return(s7_make_integer(sc, s7_integer(s7_car(args)) + 1));}
+ * s7_int plusone(s7_int x) {return(x + 1);}
+ *
+ * void plusone_init(s7_scheme *sc)
+ * {
+ * s7_define_safe_function(sc, "plusone", g_plusone, 1, 0, false, "");
+ * s7_set_i_i_function(sc, s7_name_to_value(sc, "plusone"), plusone);
+ * }
+ * --------
+ * gcc -c plus.c -fPIC -O2 -lm
+ * gcc plus.o -shared -o plus.so -ldl -lm -Wl,-export-dynamic
+ * repl
+ * <1> (load "plus.so" (inlet 'init_func 'plusone_init))
+ * --------
+ */
+
+/* -------------------------------------------------------------------------------- */
+
+/* maybe remove these? */
+s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol);
+s7_pointer s7_slot_value(s7_pointer slot);
+s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value);
+s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value);
+void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value);
+
+/* -------------------------------------------------------------------------------- */
+
+#if (!DISABLE_DEPRECATED)
+typedef s7_int s7_Int;
+typedef s7_double s7_Double;
+
+#define s7_is_object s7_is_c_object
+#define s7_object_type s7_c_object_type
+#define s7_object_value s7_c_object_value
+#define s7_make_object s7_make_c_object
+#define s7_mark_object s7_mark
+#define s7_UNSPECIFIED(Sc) s7_unspecified(Sc)
+#endif
+
+
+bool s7_is_bignum(s7_pointer obj);
+#if WITH_GMP
+ mpfr_t *s7_big_real(s7_pointer x);
+ mpz_t *s7_big_integer(s7_pointer x);
+ mpq_t *s7_big_ratio(s7_pointer x);
+ mpc_t *s7_big_complex(s7_pointer x);
+
+ bool s7_is_big_real(s7_pointer x);
+ bool s7_is_big_integer(s7_pointer x);
+ bool s7_is_big_ratio(s7_pointer x);
+ bool s7_is_big_complex(s7_pointer x);
+
+ s7_pointer s7_make_big_real(s7_scheme *sc, mpfr_t *val);
+ s7_pointer s7_make_big_integer(s7_scheme *sc, mpz_t *val);
+ s7_pointer s7_make_big_ratio(s7_scheme *sc, mpq_t *val);
+ s7_pointer s7_make_big_complex(s7_scheme *sc, mpc_t *val);
+#endif
+
+
+/* --------------------------------------------------------------------------------
+ *
+ * s7 changes
+
+ * 8-Jan-23: s7_gc_protect_2_via_stack.
+ * --------
+ * 15-Nov: s7_make_c_pointer_wrapper_with_type.
+ * 17-Mar-23: moved s7_is_bignum declaration outside WITH_GMP.
+ * --------
+ * 9-Nov: nan, nan-payload, +nan.<int>.
+ * 19-Oct: s7_let_field* synonyms: s7_starlet*.
+ * 16-Sep: s7_number_to_real_with_location. s7_wrong_type_error. s7_make_string_wrapper_with_length. s7_make_semipermanent_string.
+ * 21-Apr: s7_is_multiple_value.
+ * 11-Apr: removed s7_apply_*.
+ * 22-Mar: s7_eval_with_location.
+ * 16-Mar: s7_list_to_array for the s7_apply_* changes.
+ * 8-Mar-22: moved s7_apply_* to xen.h if DISABLE_DEPRECATED.
+ * --------
+ * 24-Nov: moved s7_p_p_t and friends into s7.h.
+ * 23-Sep: s7_make_byte_vector, s7_is_byte_vector, s7_byte_vector_ref|set|elements.
+ * 25-Aug: s7_output_string (like s7_get_output_string, but returns an s7 string).
+ * 19-Jul: s7_is_random_state, s7_make_normal_vector. s7_array_to_list.
+ * 12-Apr: s7_optimize now returns an s7_pfunc, not an s7_function.
+ * 7-Apr: removed the "args" parameter from s7_float_function. added s7_make_c_object_without_gc.
+ * 31-Mar: vector-rank, vector-dimension.
+ * 17-Mar: removed deprecated nan.0 and inf.0 due to compiler stupidity.
+ * 25-Jan: s7_define_semisafe_typed_function.
+ * 6-Jan-21: s7_hash_code.
+ * --------
+ * 14-Oct: s7_load_c_string and s7_load_c_string_with_environment.
+ * 10-Sep: s7_free.
+ * 5-Aug: s7_make_list.
+ * 31-July: s7_define_constant_with_environment and s7_dilambda_with_environment.
+ * 29-July: open-input|output-function. add S7_NUM_READ_CHOICES to s7_read_t enum and remove (unused) S7_READ_BYTE.
+ * 20-July: s7_c_pointer_with_type. notcurses_s7.c and nrepl.scm. *autoload-hook*.
+ * 8-July: s7_int|float_vector_ref|set. subvector parameter order changed.
+ * 17-June: removed deprecated *s7* accessors.
+ * 20-May: libarb_s7.c.
+ * 12-May: s7_is_big*.
+ * 6-May: added s7_scheme* initial arguments to s7_set_* opt_func calls (s7_set_d_d_function for example).
+ * 23-Apr: added s7_scheme* initial argument to s7_is_eqv.
+ * 9-Mar: move openlets to (*s7* 'openlets), s7-version to (*s7* 'version), deprecate nan.0 and inf.0.
+ * 17-Feb: s7_let_field_ref|set for *s7* access. *function* to replace __func__.
+ * deprecate __func__, s7_print_length, s7_float_format_precision, s7_set_gc_stats.
+ * 31-Jan: macro(*) and bacro(*) -- unnamed macros analogous to lambda(*).
+ * 20-Jan: debug.scm and (*s7* 'debug), trace-in, dynamic-unwind.
+ * remove coverlets (openlets is now a dilambda).
+ * 10-Jan: s7_c_type_set_gc_free and s7_c_type_set_gc_mark.
+ * 2-Jan-20: s7_c_type_set_is_equal and s7_c_type_set_is_equivalent.
+ * --------
+ * 2-Nov: s7_repl.
+ * 30-Oct: change S7_DATE format, and start updating it to reflect s7.c.
+ * 30-Jul: define-expansion*.
+ * 12-Jul: s7_call_with_catch, s7_load now returns NULL if file not found (rather than raise an error).
+ * 8-July: most-positive-fixnum and most-negative-fixnum moved to *s7*.
+ * 23-May: added s7_scheme argument to s7_c_object_set_let.
+ * 19-May: s7_gc_stats renamed s7_set_gc_stats.
+ * 7-May: s7_gc_unprotect_via_stack and s7_gc_(un)protect_via_location.
+ * 22-Mar: s7_float_format_precision. port-position. port-file.
+ * 4-Jan-19: morally-equal? -> equivalent?
+ * --------
+ * 29-Dec: s7_c_type_set_getter|setter (implicit c-object access).
+ * 23-Dec: remove hash-table, rename hash-table* to hash-table. add weak-hash-table.
+ * 3-Dec: deprecate s7_gc_unprotect (use s7_gc_unprotect_at).
+ * 21-Nov: added s7_history_enabled and s7_set_history_enabled.
+ * 3-Nov: removed the "value" argument from s7_for_each_symbol.
+ * 22-Sep: s7_list_nl.
+ * 12-Sep: byte-vectors can be multidimensional; homogenous vectors of any built-in type. typed hash-tables.
+ * 29-Jul: symbol-setter deprecated (use setter). s7_symbol_documentation (and setter) folded into s7_documentation.
+ * 12-Jul: changed s7_vector_dimensions|offsets.
+ * Added s7_scheme* arg to make_permanent_string and several of the optimizer functions.
+ * 3-Jul: changed make-shared-vector to subvector.
+ * 20-May: s7_keyword_to_symbol.
+ * 6-May: s7_mark_c_object -> s7_mark.
+ * 26-Apr: s7_c_type_set_to_list|string, s7_c_type_set_apply -> s7_c_type_set_ref, removed s7_c_type_set_set|apply_direct
+ * c_type length|set|ref are now s7_functions (args, not obj, etc).
+ * 23-Mar: s7_peek_char and s7_read_char now return s7_pointer, s7_write_char takes s7_pointer, not int32_t c
+ * s7_gc_protect and friends now return/take s7_int location, not uint32_t.
+ * removed s7_new_type_x.
+ * 19-Mar: int32_t -> s7_int in various functions.
+ * 17-Mar: deprecate s7_ulong and s7_ulong_long functions.
+ * 26-Jan-18: s7_set_setter.
+ * --------
+ * 11-Dec: s7_gc_protect_via_stack
+ * 3-Oct: renamed procedure-signature -> signature, procedure-documentation -> documentation, and procedure-setter -> setter.
+ * 18-Sep: s7_immutable, s7_is_immutable. define-constant follows lexical scope now.
+ * s7_symbol_access -> s7_symbol_setter, symbol-access -> symbol-setter.
+ * 3-Aug: object->c_object name changes.
+ * 28-Jul: s7_make_c_pointer_with_type and s7_c_pointer_type.
+ * 24-Jul: int64_t rather than long long int, and various related changes.
+ * 18-Jul: s7_make_object_with_let.
+ * 8-July: s7_define_typed_function_star, s7_make_function_star. s7_apply_function_star.
+ * 27-June: s7_make_string_wrapper.
+ * 22-May: lambda* keyword arg handling changed slightly.
+ * 9-May: s7_history, s7_add_to_history.
+ * 20-Apr: s7_tree_memq (for Snd), s7_type_of, many changes for new clm optimizer.
+ * 10-Apr: added s7_scheme first argument to s7_iterator_is_at_end.
+ * 28-Mar: removed the "rf", "pf" and "if" clm optimization functions.
+ * s7_optimize, s7_float_optimize, s7_procedure_signature.
+ * 22-Feb: removed the "gf" clm optimization functions.
+ * 11-Feb: #e, #i, #d removed. #i(...) is an int-vector constant, #r(...) a float-vector.
+ * 2-Jan-17: {apply_values} -> apply-values, {list} -> list-values, and {append} -> append.
+ * --------
+ * 23-Sep: make-keyword -> string->keyword.
+ * 9-Aug: s7_varlet.
+ * 29-Jul: s7_define_unsafe_typed_function.
+ * 30-May: symbol takes any number of args. make-vector no longer takes an optional fourth argument.
+ * 24-May: let-ref/set! check rootlet now if let is not an open let; setter for with-let.
+ * 20-Feb: removed last vestiges of quasiquoted vector support.
+ * 3-Feb: *cload-directory*.
+ * 14-Jan: profile.scm. Moved multiple-value-set! to stuff.scm. Setter for port-line-number.
+ * 7-Jan: s7_load_with_environment.
+ * s7_eval_c_string takes only one statement now (use begin to handle multiple statements)
+ * 4-Jan-16: remove s7_eval_form, change s7_eval to take its place.
+ * --------
+ * 11-Dec: owlet error-history field if WITH_HISTORY=1
+ * 6-Nov: removed :key and :optional.
+ * 16-Oct: s7_make_random_state -> s7_random_state.
+ * 16-Aug: remove s7_define_integer_function, s7_function_set_removes_temp,
+ * add s7_define_typed_function, s7_make_signature.
+ * 5-Aug: added s7_scheme* arg to s7_openlet and s7_outlet.
+ * 3-Jul: s7_Double -> s7_double, s7_Int -> s7_int. Removed function_chooser_data.
+ * 27-Jun: s7_rf_t, s7_rp_t etc.
+ * 19-Jun: removed the ex_parser stuff, set_step_safe, s7_ex_fallback.
+ * 5-May: s7_make_iterator and friends.
+ * 16-Apr: added s7_fill, changed arg interpretation of s7_copy, s7_dynamic_wind.
+ * 30-Mar: s7_eval_c_string_with_environment (repl experiment).
+ * 19-Mar: repl.scm.
+ * 28-Feb: s7_vector_print_length -> s7_print_length, set case also.
+ * 25-Feb: s7_closure_* funcs to replace clumsy (deprecated) s7_procedure_source.
+ * 29-Jan: changed args to s7_new_type_x (added s7_scheme arg, fill! takes s7_function).
+ * 14-Jan-15: make-iterator, iterator?
+ * --------
+ * 26-Dec: s7_arity replaces s7_procedure_arity. s7_define_integer_function. deprecate s7_procedure_name.
+ * 5-Nov: s7_shadow_rootlet and s7_set_shadow_rootlet.
+ * 30-Aug: s7_make_safe_function (for cload.scm).
+ * 25-July: define and friends now return the value, not the symbol.
+ * procedure_with_setter -> dilambda.
+ * environment -> let. All the replaced names are deprecated.
+ * 30-June: s7_method.
+ * 16-June: remove unoptimize and s7_unoptimize.
+ * 14-May: s7_define_safe_function_star. Removed s7_catch_all.
+ * 22-Apr: remove s7_apply_n_10, s7_is_valid_pointer, s7_keyword_eq_p.
+ * 5-Mar-14: s7_heap_size, s7_gc_freed (subsequently removed).
+ * --------
+ * 8-Nov: s7_symbol_documentation, s7_define_constant_with_documentation.
+ * 17-Oct: bignum-precision (procedure-with-setter) is now an integer variable named *bignum-precision*.
+ * 28-Aug: s7_int|float_vector_elements (homogeneous vectors), libc.scm.
+ * 16-Aug: ~W directive in format, make-shared-vector.
+ * 23-Jul: s7_autoload_set_names, libm.scm, libdl.scm, libgdbm.scm, r7rs.scm, s7libtest.scm.
+ * 21-Jul: s7_is_valid (replaces deprecated s7_is_valid_pointer).
+ * 24-Jun: some bool-related changes for Windows Visual C++, including change to s7_begin_hook.
+ * 3-June: s7_autoload.
+ * 28-May: export s7_is_provided. Added s7_scheme* arg to s7_procedure_environment.
+ * 21-May: equality predicate optional arg in make-hash-table.
+ * 14-May: glistener.c, glistener.h, s7_symbol_table_find_name (for glistener).
+ * 2-May: r7rs changes: flush-output-port, vector-append, read|write-string, boolean=?, symbol=?.
+ * start/end args for string-fill!, vector-fill!, string->list, vector->list, and copy.
+ * exit, emergency-exit.
+ * 7-Apr: removed s7_scheme* arg from s7_slot_value, added s7_is_local_variable.
+ * 25-Mar: char-position, string-position, environment-ref, environment-set! added to the scheme side.
+ * 9-Jan-13: s7_cos, s7_sin, other optimization changes.
+ * --------
+ * 24-Dec: s7_set_object_array_info and other such changes.
+ * 20-Nov: removed s7_set_error_exiter and s7_error_and_exit which I think have never been used.
+ * 22-Oct: changed args to s7_function_class and s7_function_set_class.
+ * 22-Aug: symbol->dynamic-value.
+ * 10-Aug: exported s7_outer_environment.
+ * 6-Aug: removed WITH_OPTIMIZATION.
+ * 25-July: environment (in scheme). s7_vector_ref_n and s7_vector_set_n. s7_copy.
+ * added s7_scheme arg to s7_number_to_real|integer.
+ * 16-July: s7_function_returns_temp (an experiment).
+ * 2-July: s7_object_set_* functions.
+ * 11-June: throw.
+ * 4-June. s7_object_environment.
+ * 31-May: added s7_scheme argument to all the optimizer chooser functions.
+ * 24-May: open-environment?
+ * 17-May: arity, aritable?
+ * removed trace and untrace.
+ * 14-May: s7_list. s7_procedure_set_setter. Removed s7_procedure_getter.
+ * procedure-setter is settable: removed most of procedure-with-setter.
+ * make-type replaced by open-environment.
+ * 11-May: s7 2.0: hook implementation changed completely.
+ * s7_environment_ref|set.
+ * 4-May: *error-info* replaced by error-environment, and stacktrace has changed.
+ * 22-Apr: #_<name> = startup (built-in) value of name
+ * 17-Apr: with-baffle.
+ * 14-Apr: WITH_SYSTEM_EXTRAS (default 0) has additional OS and IO functions:
+ * directory? file-exists? delete-file getenv directory->list system
+ * 26-Mar: "@" as exponent, WITH_AT_SIGN_AS_EXPONENT switch (default is 1).
+ * 18-Mar: removed *trace-hook*.
+ * 6-Feb: random-state?, hash-table-iterator?, and morally-equal?
+ * 18-Jan: s7_environment_to_list and environment->list return just the local environment's bindings.
+ * outer-environment returns the environment enclosing its argument (an environment).
+ * environments are now applicable objects.
+ * added the object system example to s7.html.
+ * 12-Jan: added reverse argument to s7_new_type_x. This is needed because an object might implement
+ * the apply and set methods, but they might refer to different things.
+ * 6-Jan-12: added (scheme side) logbit?.
+ * --------
+ * 21-Dec: s7_eval, s7_make_slot, s7_slot_set_value.
+ * changed s7_symbol_slot to s7_slot, and s7_symbol_slot_value to s7_slot_value.
+ * 26-Oct: s7_procedure_name.
+ * 6-Oct: changed s7_make_closure args: split the code argument in two (args and body).
+ * s7_make_closure(... code ...) is now s7_make_closure(... car(code), cdr(code) ...)
+ * s7_is_environment.
+ * 19-Aug: s7_function_chooser_data.
+ * 11-Aug: s7_symbol_accessor functions. s7_cxxxxr.
+ * 9-Aug: s7_function_chooser, s7_function_choice, s7_function_choice_set_direct.
+ * 20-Jul: s7_function_class, s7_function_set_class, and s7_function_set_chooser.
+ * 14-Jul: removed thread and profiling support.
+ * 5-June: s7_define_safe_function and s7_unoptimize exported; added unoptimize function in scheme.
+ * 30-May: environment->list and s7_environment_to_list since environments are no longer alists internally.
+ * 26-May: added s7_scheme argument to s7_procedure_setter and getter (old names had "with_setter_").
+ * 28-Apr: s7_help.
+ * 5-Apr: pair-line-number.
+ * 14-Mar: s7_make_random_state, optional state argument to s7_random, random-state->list, s7_random_state_to_list.
+ * 10-Feb: s7_vector_print_length, s7_set_vector_print_length.
+ * 7-Feb: s7_begin_hook, s7_set_begin_hook.
+ * 25-Jan: s7_is_thread, s7_thread, s7_make_thread, s7_thread_s7, s7_thread_data.
+ * s7_is_lock, s7_make_lock, s7_lock.
+ * changed s7_thread_variable_value to s7_thread_variable.
+ * 23-Jan: removed (scheme-level) quit.
+ * 17-Jan-11: make-hash-table-iterator.
+ * map and for-each accept any applicable object as the first argument.
+ * format's ~{...~} directive can handle any applicable object.
+ * --------
+ * 17-Dec: removed unquote-splicing; replaced by (unquote (apply values ...)).
+ * 12-Dec: environment?
+ * 7-Dec: member and assoc have an optional third arg, the comparison function.
+ * 1-Dec: *gc-stats* in Scheme, s7_gc_stats in C.
+ * gmp and gtk-repl examples in s7.html.
+ * 21-Nov: Load C module example in s7.html.
+ * 12-Nov: *trace-hook*, *load-hook*, *error-hook*, and *unbound-variable-hook* are now s7 hooks.
+ * 9-Nov: hooks: C side: s7_is_hook, s7_make_hook, s7_hook_apply, s7_hook_functions, s7_hook_arity, s7_hook_documentation.
+ * s7 side: hook?, make-hook, hook, hook-apply, hook-functions, hook-arity, hook-documentation.
+ * 8-Nov: Closure defined in C example in s7.html.
+ * 23-Oct: s7_call_with_location for better error reporting.
+ * 19-Oct: *stdin*, *stdout*, *stderr* for default IO ports (rather than nil which is ambiguous).
+ * 14-Oct: removed special variable support.
+ * 30-Sep: setters for current-input-port, current-output-port, and current-error-port.
+ * 30-Aug: :allow-other-keys in define*.
+ * 10-Aug: added boolean argument use_write to s7_object_to_string (true=write, false=display).
+ * 30-July: special macro for access to dynamic binding.
+ * s7_symbol_special_value for C-side access to dynamic bindings.
+ * s7_is_macro.
+ * port-closed? returns #t if its argument (a port) is closed.
+ * 22-July: s7_make_character takes uint32_t, rather than int.
+ * added symbol function for funny symbol names.
+ * 12-July: initial-environment.
+ * 7-July: removed force and delay: use slib.
+ * 3-July: new backquote implementation.
+ * 28-June: syntactic keywords (e.g. lambda) are applicable.
+ * 7-June: changed key arg in s7_hash_table_ref|set to be s7_pointer, not const char*.
+ * hash-tables can now handle any s7 object as the key.
+ * map and for-each now pass a hash-table entry to the function, rather than an internal alist.
+ * reverse of a hash-table reverses the keys and values (i.e. old value becomes new key, etc).
+ * 2-June: removed procedure-with-setter-setter-arity and folded that info into procedure-arity (use cdddr).
+ * 22-May: multidimensional vectors are no longer optional.
+ * 9-May: s7_read_char and s7_peek_char have to return an int, not a char (<eof>=-1, but 255 is a legit char).
+ * s7_write_char and s7_open_output_function have similar changes.
+ * 3-May: *#readers* to customize #... reading. Also nan? and infinite?.
+ * multidimensional vector constants using #nD(...): (#2D((1 2 3) (4 5 6)) 0 0) -> 1.
+ * 13-Apr: removed hash-table|vector|string-for-each -- these are handled by for-each.
+ * also removed vector-map -- map is generic, but always returns a list.
+ * 12-Apr: removed immutable constant checks -- see s7.html.
+ * 7-Apr: *unbound-variable-hook*.
+ * augment-environment and s7_augment_environment.
+ * 29-Mar: symbol-access, s7_symbol_access, s7_symbol_set_access.
+ * C example of notification in s7.html.
+ * 25-Mar: make-type. s7_is_equal now includes an s7_scheme pointer as its first argument.
+ * 24-Mar: s7_is_defined.
+ * 19-Mar: removed encapsulation mechanism and s7_define_set_function.
+ * 18-Mar: added macro?.
+ * 27-Feb: removed r4rs-style macro syntax.
+ * 17-Feb: s7_number_to_integer.
+ * 20-Jan-10: removed the stack function.
+ * --------
+ * 16-Dec: hash-table-for-each.
+ * 1-Dec: mpc versions before 0.8.0 are no longer supported.
+ * 24-Nov: define-macro* and defmacro*.
+ * force and delay included only if WITH_FORCE set, promise? removed.
+ * 17-Nov: s7_is_boolean no longer takes the s7_scheme argument.
+ * 7-Nov: s7_vector_dimensions, s7_vector_offsets, example of use.
+ * 3-Nov: s7_vector_rank.
+ * 30-Oct: *trace-hook*.
+ * 12-Oct: s7_port_filename.
+ * 5-Oct: s7_c_pointer and friends.
+ * 14-Sep: s7_values, s7_make_continuation, and a better interrupt example.
+ * vector-for-each, vector-map, string-for-each.
+ * 7-Sep: s7_open_input_function. with-environment. receive.
+ * 3-Sep: s7.html, s7-slib-init.scm.
+ * s7_stacktrace in s7.h.
+ * 27-Aug: vector and hash-table sizes are now s7_ints, rather than ints.
+ * 20-Aug: s7_remove_from_heap.
+ * 17-Aug: *error-info*.
+ * 7-Aug: s7_define_function_with_setter.
+ * s7_quit and example of signal handling.
+ * 6-Aug: encapsulation. s7_define_set_function. s7_new_type_x.
+ * generic function: copy, and length is generic.
+ * 1-Aug: lower-case versions of s7_T and friends.
+ * s7_define_macro. macroexpand.
+ * strings are set-applicable (like vectors).
+ * 31-Jul: *error-hook*.
+ * 30-Jul: changed backtrace handling: removed backtrace stuff, added stacktrace.
+ * removed gc-verbose and load-verbose replaced by *load-hook*.
+ * 23-Jul: __func__.
+ * 20-Jul: trace and untrace.
+ * 14-Jul: replaced s7_make_closure_star with s7_define_function_star.
+ * 29-Jun: s7_format declaration.
+ * 12-May: s7_is_constant.
+ * 20-Apr: changed rationalize to be both r5rs-acceptable and fast.
+ * 6-Apr: added s7_make_permanent_string.
+ * 14-Mar: removed s7_local_gc_protect and s7_local_gc_unprotect.
+ * 4-Mar: multidimensional and applicable vectors.
+ * 1-Mar: s7_random added to s7.h.
+ * 29-Jan: s7_is_bignum and friends.
+ * 26-Jan: added s7_scheme arg to s7_vector_fill.
+ * 16-Jan: s7_is_ulong_long and friends for C pointers in 64-bit situations.
+ * 9-Jan-09 multiprecision arithmetic (gmp, mpfr, mpc) on the WITH_GMP switch
+ * --------
+ * 29-Dec: "+" specialization example, s7_apply_function.
+ * 3-Dec: s7_open_output_function.
+ * 30-Nov: s7_wrong_number_of_args_error.
+ * 24-Nov: changed s7_make_counted_string to s7_make_string_with_length.
+ * also added built-in format and define*
+ * 10-Nov: s7_define_constant,
+ * built-in (scheme-side) pi, most-positive-fixnum, most-negative-fixnum
+ * 7-Nov: removed s7_is_immutable and friends, s7_reverse_in_place.
+ * removed the s7_pointer arg to s7_gc_on.
+ * added s7_UNSPECIFIED
+ * 25-Oct: added name arg to s7_make_procedure_with_setter,
+ * and s7_scheme arg to new_type print func.
+ * 1-Oct-08 version 1.0
+ */
+
+
+#ifdef __cplusplus
+}
+#endif
+
+#endif
diff --git a/sources/text.h b/sources/text.h
index a44bbce..74716c1 100644
--- a/sources/text.h
+++ b/sources/text.h
@@ -1,11 +1,33 @@
#include "raylib.h"
-#include <libguile.h>
+#include "s7.h"
#include <stdio.h>
+#include <stdlib.h>
-static void rl_draw_text() {
- DrawText("a", 200, 80, 20, RED); //< this line segfaults
+int texture_2d_tag;
+
+static s7_pointer free_texture_2d(s7_scheme *s7, s7_pointer obj) {
+ Texture2D *texture = (Texture2D *) s7_c_object_value(obj);
+ UnloadTexture(*texture);
+ free(texture);
+ return(NULL);
+}
+
+static s7_pointer rl_draw_text(s7_scheme *s7, s7_pointer args) {
+ DrawText(s7_string(s7_car(args)), 200, 80, 20, RED);
+ return(NULL);
+}
+
+static s7_pointer rl_load_texture(s7_scheme *s7, s7_pointer args) {
+ Texture2D texture = LoadTexture("./assets/test.png");
+ Texture2D *texture_ptr = (Texture2D *) malloc(sizeof(Texture2D));
+ *texture_ptr = texture;
+ return (s7_make_c_object(s7, texture_2d_tag, (void *) texture_ptr));
}
-static void rl_text_define_methods() {
- SCM handler = scm_c_define_gsubr ("rl-draw-text", 0, 0, 0, rl_draw_text);
+static void rl_text_define_methods(s7_scheme *s7) {
+ s7_define_safe_function(s7, "rl-draw-text", rl_draw_text, 1, 0, false, "test");
+ s7_define_safe_function(s7, "rl-load-texture", rl_load_texture, 0, 0, false, "test");
+
+ texture_2d_tag = s7_make_c_type(s7, "texture-2d");
+ s7_c_type_set_gc_free(s7, texture_2d_tag, free_texture_2d);
}
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-03 04:50:06 +0000