From 57c6e52f86798176c7415c5f109a8a624efeedb8 Mon Sep 17 00:00:00 2001 From: cat Date: Mon, 30 Jun 2025 14:22:24 +1000 Subject: [PATCH] ok i promise i will actually start the rewrite --- Makefile | 8 +- dat.h | 15 - fns.h | 7 - img.c | 59 - readme | 50 +- s7.c | 101531 ++++++++++++++++++++++++++++++++++++++++++++ s7.h | 1307 + samply/act.c | 4 - samply/error.png | Bin 100211 -> 0 bytes samply/idle.png | Bin 91787 -> 0 bytes samply/img.c | 7 - samply/readme | 3 - samply/samply.h | 6 - samply/walk1.png | Bin 72585 -> 0 bytes samply/walk2.png | Bin 72323 -> 0 bytes slutpet.6 | 23 - slutpet.c | 0 sp.c | 4 + 18 files changed, 102889 insertions(+), 135 deletions(-) delete mode 100644 dat.h delete mode 100644 fns.h delete mode 100644 img.c create mode 100644 s7.c create mode 100644 s7.h delete mode 100644 samply/act.c delete mode 100644 samply/error.png delete mode 100644 samply/idle.png delete mode 100644 samply/img.c delete mode 100644 samply/readme delete mode 100644 samply/samply.h delete mode 100644 samply/walk1.png delete mode 100644 samply/walk2.png delete mode 100644 slutpet.6 delete mode 100644 slutpet.c create mode 100644 sp.c diff --git a/Makefile b/Makefile index ad7965e..5048280 100644 --- a/Makefile +++ b/Makefile @@ -4,12 +4,14 @@ PREFIX ?= /usr/local CFLAGS := $(CFLAGS) `pkg-config --cflags --libs sdl3` LDFLAGS := $(LDFLAGS) -lm -SRCS = slutpet.c img.c samply.c sdl.c +SRCS = sp.c all: slutpet -slutpet: ${SRCS} +slutpet: ${SRCS} s7.o + +s7.o: s7.c .PHONY: clean clean: - -rm -f slutpet + -rm -f slutpet s7.o diff --git a/dat.h b/dat.h deleted file mode 100644 index 9cac8d8..0000000 --- a/dat.h +++ /dev/null @@ -1,15 +0,0 @@ -typedef struct Action Action; -typedef struct Image Image; - -struct Action { - // step - // click -}; - -struct Image { - char *name; - int w, h, bpp; - unsigned char *data; - SDL_Surface *sur; - SDL_Texture *tex; -}; diff --git a/fns.h b/fns.h deleted file mode 100644 index cc7db9c..0000000 --- a/fns.h +++ /dev/null @@ -1,7 +0,0 @@ -#define babble(...) SDL_LogDebug(SDL_LOG_CATEGORY_APPLICATION, __VA_ARGS__) -#define info(...) SDL_Log(__VA_ARGS__) -#define shit(...) SDL_LogError(SDL_LOG_CATEGORY_APPLICATION, __VA_ARGS__) -#define fuck(...) SDL_LogCritical(SDL_LOG_CATEGORY_APPLICATION, __VA_ARGS__) - -void free_image(Image *i); -int load_image(Image *i, SDL_Renderer *ren); diff --git a/img.c b/img.c deleted file mode 100644 index 99a2986..0000000 --- a/img.c +++ /dev/null @@ -1,59 +0,0 @@ -#define STB_IMAGE_IMPLEMENTATION -#define STBI_MALLOC(sz) SDL_malloc(sz) -#define STBI_REALLOC(p,newsz) SDL_realloc(p,newsz) -#define STBI_FREE(p) SDL_free(p) -#include -#include "stb_image.h" - -#include "dat.h" -#include "fns.h" - -void -free_image(Image *i) -{ - if (i->tex) { - babble("destroying texture for image %s...", i->name); - SDL_DestroyTexture(i->tex); - } - if (i->sur) { - babble("destroying surface for image %s...", i->name); - SDL_DestroySurface(i->sur); - } - if (i->data) { - babble("destroying data for image %s...", i->name); - stbi_image_free(i->data); - } -} - -int -load_image(Image *i, SDL_Renderer *ren) -{ - babble("opening image %s...", i->name); - i->data = stbi_load(i->name, &i->w, &i->h, &i->bpp, 4); - if (!i->data) { - shit("stbi_load: %s", stbi_failure_reason()); - goto err; - } - - babble("creating surface for image %s...", i->name); - i->sur = SDL_CreateSurfaceFrom(i->w, i->h, SDL_PIXELFORMAT_RGBA32, - i->data, i->w * 4); - if (!i->sur) { - shit("SDL_CreateSurfaceFrom: %s", SDL_GetError()); - goto err; - } - - babble("creating texture for image %s...", i->name); - i->tex = SDL_CreateTextureFromSurface(ren, i->sur); - if (!i->tex) { - shit("SDL_CreateTextureFromSurface: %s", SDL_GetError()); - goto err; - } - - babble("created image %s!", i->name); - return 0; - -err: - free_image(i); - return -1; -} diff --git a/readme b/readme index 085c905..68830fc 100644 --- a/readme +++ b/readme @@ -1,12 +1,46 @@ -horny desktop pet thing. +design (+ usage) -currently being rewritten to make structural sense. +(this is for now just a design document and not describing the actual program.) -you need sdl3 to build it. -i have not tried cross-compiling to windows yet. +slutpet makes use of s7 scheme as a scripting language. +(this, by the way, is why the program takes a weirdly long time to compile -- +s7.{c,h} contain the entire s7 scheme interpreter, over 100,000 lines.) +if you don't know scheme, + a) don't worry, it's pretty simple, and + b) sorry in advance. -i think it's probably best to use some sort of extension language. -i want people to be able to create their own pets without having to -figure out how to recompile. +c source files: -run it with `SDL_LOGGING=app=debug ./slutpet` for verbose logging +sp.c: main entry, exit, event/render loops + +a pet is implemented by setting the variable 'pet' to +an alist (is this the correct term?) which contains some values. +setting the pet variable should handle this automatically, +but various hooks can then be set, which will be executed +whenever a certain event has happened. + +list of variables: +pet: the pet that the program will use. this is a list of cons that define the pet. + TODO: maybe this should be a macro that sets other variables. + +pet-name: string containing the pet's name. + +list of hooks: +pre-init-hook: before anything has happened at all; right after s7 has been initialised. + this is also before any init files have been read +post-init-hook: when the window has been set up and things are ready to happen. + the current pet should be set and initialised by this point. +tick-hook: every program tick. the pet's drawing information should be set + here so it can be rendered. +TODO: figure out what to do about event hooks +pre-quit-hook: the program is about to exit, no de-init things have been done yet. +post-quit-hook: everything (except, obviously, the s7 interpreter) has been de-initialised. + +list of functions: +(load-image path): set up a new image, with the data taken from the given path. + this will return the a list of cons pairs with the image data, + in a form that can be used in the pet variable. +(free-image image): free heap-allocated data in image. + +list of c-types: +pixmap: the data created from stb-image. diff --git a/s7.c b/s7.c new file mode 100644 index 0000000..1448f4a --- /dev/null +++ b/s7.c @@ -0,0 +1,101531 @@ +/* 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, s7.html, s7-ffi.html, and s7-scm.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. + * In variables, i, j, and k are ints, p is a pair (usually), e is a let (environment), x and y are floats (usually), o is opt_info*. + * + * ---------------- 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 g++ 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 are slower + * 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. clang defines __GNUC__ */ + #define WITH_GCC 1 +#else + #define WITH_GCC 0 +#endif +#if (defined(__clang__) && __cplusplus) /* pointless -- this is a moving target */ + #define WITH_CLANG_PP 1 +#else + #define WITH_CLANG_PP 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 hardware cache size probably matters more). + * The heap size must be a multiple of 32. Each object takes 48 bytes. s7 is fine with the initial heap size set to 800. + */ + +#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. + * 4129: tlet +530 [symbol_p_pp], thash +565 [make_symbol], max-bin: (3 5), tlet: (258 3) + * 16381: tlet +80 [symbol_p_pp], thash +80 [make_symbol], max-bin: (2 25), tlet: (85 1) + * 24001: tlet +33 [symbol_p_pp], thash +50 [make_symbol], max-bin: (2 19), tlet: (56 7) + * 32749: (677 symbols if exit.scm) max-bin: (2 13), tlet: (40 4) + * 72101: tlet -40 [symbol_p_pp], thash -40 [make_symbol], max-bin: (2 11), tlet: (30 5) + */ + +#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 256 /* was INITIAL_STACK_SIZE/2 which seems excessive */ + +#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. + */ + +#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 */ + + +/* ---------------- 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 40 /* (*s7* 'print-length) initial value, was 32 but that's too small 26-May-24 */ +#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 + /* Da Shen adds that you'll need the compiler flag /fp:precise if you're using github actions */ + #endif + #ifndef HAVE_COMPLEX_TRIG + #define HAVE_COMPLEX_TRIG 0 + #endif +#else + #ifndef HAVE_COMPLEX_NUMBERS + #if __TINYC__ || (__clang__ && __cplusplus) /* clang++ is hopeless */ + #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 + #include + #include + #include + #include +#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 + #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 no_return _Noreturn /* deprecated in C23 */ +#else + #define no_return __attribute__((noreturn)) + /* this is ok in gcc/g++/clang and tcc; clang++ complains about "noreturn", hence "no_return" */ + /* 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, local_memset, local_strncmp */ +#endif + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +#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? + */ +#endif + +#if !MS_WINDOWS + #include +#endif + +#if __cplusplus + #include +#else + #include +#endif + +#include "s7.h" + +/* there is also apparently __STDC_NO_COMPLEX__ */ +#if WITH_CLANG_PP + #define CMPLX(x, y) __builtin_complex ((double) (x), (double) (y)) +#endif +#if HAVE_COMPLEX_NUMBERS + #if __cplusplus + #include + using namespace std; /* the code has to work in C as well as C++, so we can't scatter std:: all over the place */ + /* moved the typedef to s7.h. */ + #else + #include + /* typedef double complex s7_complex; */ + #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 WITH_CLANG_PP + #define s7_complex_i ((double)1.0i) +#else +#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 +#endif + +#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 /* deprecated in C23? */ + #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 + +#ifndef POINTER_32 /* for testing */ +#if (((defined(SIZEOF_VOID_P)) && (SIZEOF_VOID_P == 4)) || ((defined(__SIZEOF_POINTER__)) && (__SIZEOF_POINTER__ == 4)) || (!defined(__LP64__))) + #define POINTER_32 true +#else + #define POINTER_32 false +#endif +#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 +typedef uint64_t s7_uint; + +#define ld64 PRId64 +/* #define lu64 PRIu64 */ +#define p64 PRIdPTR + +#define MAX_FLOAT_FORMAT_PRECISION 128 /* does this make any sense? 53 bits in mantissa: 16 digits, are the extra digits just garbage? */ + +/* 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_COMPLEX_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", "complex_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:pair, 2:nil, 3:unused, 4:undefined, 5:unspecified, 6:eof, 7:boolean, 8:character, 9:syntax, 10:symbol, + 11:integer, 12:ratio, 13:real, 14:complex, 15:big_integer, 16:big_ratio, 17:big_real, 18:big_complex, + 19:string, 20:c_object, 21:vector, 22:int_vector, 23:float_vector, 24:byte_vector, 25:complex_vector, + 26:catch, 27:dynamic_wind, 28:hash_table, 29:let, 30:iterator, + 31:stack, 32:counter, 33:slot, 34:c_pointer, 35:output_port, 36:input_port, 37:random_state, 38:continuation, 39:goto, + 40:closure, 41:closure_star, 42:macro, 43:macro_star, 44:bacro, 45:bacro_star, + 46:c_macro, 47:c_function_star, 48:c_function, 49:c_rst_no_req_function, + 50:num_types +*/ + +typedef struct block_t { + union { + void *data; + s7_pointer d_ptr; + s7_int *i_ptr; + s7_int tag; + } dx; + int32_t index; + union { + bool needs_free; + uint32_t iter_or_size; + } ln; + union { + s7_int size; + s7_uint usize; + } sz; + union { + struct block_t *next; + char *documentation; + s7_pointer ksym; + s7_uint nx_uint; + 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->sz.size +#define block_set_size(p, Size) p->sz.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) p->sz.usize /* block_size(p) */ +#define hash_entry_set_raw_hash(p, Hash) p->sz.usize = Hash /* block_set_size(p, Hash) */ + +typedef block_t vdims_t; +#define vdims_rank(p) p->sz.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_complex_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, if typedef'd becomes uint32_t (but we want -1) */ + +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 port); /* internal get-next-name reader */ + s7_pointer (*read_sharp)(s7_scheme *sc, s7_pointer port); /* internal get-next-sharp-constant reader */ + s7_pointer (*read_line)(s7_scheme *sc, s7_pointer port, bool eol_case);/* function to read a string up to \n */ + void (*displayer)(s7_scheme *sc, const char *s, s7_pointer port); /* (display s pt) -- port_write_string without strlen?? */ + void (*close_port)(s7_scheme *sc, s7_pointer port); /* 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_ip, o_d_pd, o_d_7p, 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 class_id; /* can't use "class" -- confuses g++ */ + const char *doc; + opt_funcs_t *opt_data; /* vunion-functions (see below) */ + s7_pointer generic_ff, setter, signature, pars, let; + 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; /* 104 = sizeof(c_proc_t) */ + + +typedef struct { + s7_int type, outer_type; + s7_pointer scheme_name, getter, setter; + void (*mark)(void *val); + void (*free)(void *value); + bool (*eql)(void *val1, void *val2); +#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_uint (*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_7p_t)(s7_scheme *sc, s7_pointer p1); +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 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_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_double (*d_7p_f)(s7_scheme *sc, 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; + +typedef struct unlet_entry_t { + s7_pointer symbol; + struct unlet_entry_t *next; +} unlet_entry_t; + + +/* -------------------------------- cell structure -------------------------------- */ + +typedef struct s7_cell { + union { + s7_uint u64_type; /* type info */ + s7_int 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 { + s7_int integer_value; /* integers */ + s7_double real_value; /* floats */ + + struct { /* ratios */ + s7_int numerator; + s7_int denominator; + } fraction_value; + + union { +#if !WITH_CLANG_PP + s7_complex z; +#endif + struct { /* complex numbers */ + s7_double rl; + s7_double im; + } complex_value; + } cz; + +#if WITH_GMP + bigint *bgi; /* bignums (integer) */ + bigrat *bgr; /* (ratio) */ + bigflt *bgf; /* (float) */ + bigcmp *bgc; /* (complex) */ +#endif + } number; + + 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; + s7_complex *complexes; + 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; + s7_int top, flags; + } stk; + + struct { /* hash-tables */ + s7_uint 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 seq, cur; + union { + s7_int loc; + s7_pointer slot; /* let iterator current slow */ + } lc; + union { + s7_int len; + s7_pointer slow; /* pair iterator cycle check */ + hash_entry_t *entry; /* hash-table iterator current entry */ + } 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; + s7_uint hash; + const char *fstr; + s7_uint 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; + s7_uint hash; /* string hash-index */ + block_t *block; + block_t *gensym_block; + } string; + + struct { /* symbols */ + s7_pointer name, global_slot, local_slot; + s7_int id; /* which let last bound the symbol -- for faster symbol lookup */ + uint32_t ctr; /* how many times has symbol been bound */ + uint32_t small_symbol_tag; /* symbol as member of a (small) set (tree-set-memq etc), assumed to be uint32_t in clear_small_symbol_set */ + } sym; + + struct { /* syntax */ + s7_pointer symbol; + opcode_t op; + int32_t min_args, max_args; + const char *documentation; + /* 1 unused */ + } 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; + s7_int 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 # */ + s7_pointer car, cdr; /* unique_car|cdr, for sc->nil these are sc->unspecified for faster assoc etc */ + s7_int unused_let_id; + const char *name; + s7_int len; + } unq; + + struct { /* #<...> */ + char *name; /* not const because the GC frees it */ + s7_int len; + /* 3 unused */ + } undef; + + struct { /* # */ + const char *name; + s7_int len; + /* 3 unused */ + } eof; + + struct { /* counter (internal) */ + s7_pointer result, list, env, slots; /* env = counter_let (curlet after map/for-each let created) */ + s7_uint cap; /* sc->capture_let_counter for let reuse */ + } ctr; + + struct { /* random-state */ +#if WITH_GMP + gmp_randstate_t state; +#else + s7_uint 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; + /* 1 unused */ + } c_obj; + + struct { /* continuations */ + block_t *block; + s7_pointer stack, op_stack; + s7_pointer *stack_start, *stack_end; + } cwcc; + + struct { /* call-with-exit */ + s7_uint goto_loc, op_stack_loc; + bool active; + s7_pointer name; + /* 1 unused */ + } rexit; + + struct { /* catch */ + s7_uint 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; + /* 1 unused */ + } winder; + } object; + +#if S7_DEBUGGING + int32_t alloc_line, uses, explicit_free_line, gc_line, holders, carrier_line; + s7_int 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; + s7_int big_hloc; +} s7_big_cell; +typedef struct s7_big_cell *s7_big_pointer; + +typedef struct heap_block_t { + intptr_t start, end; + s7_int 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; + s7_int 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, gc_true_calls, gc_true_total_time; + 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; /* # */ + s7_pointer 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; + unlet_entry_t *unlet_entries; /* 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; + s7_uint capture_let_counter; + bool short_print, is_autoloading, in_with_let, object_out_locked, has_openlets, is_expanding, accept_all_keyword_arguments; + bool got_tc, got_rec, not_tc, muffle_warnings, symbol_quote, reset_error_hook; + s7_int rec_tc_args; + s7_int 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_length; + s7_int max_vector_length, max_string_length, max_list_length, max_vector_dimensions, max_string_port_length, rec_loc, rec_len, max_show_stack_frames; + s7_pointer stacktrace_defaults, symbol_printer, do_body_p, iterator_at_end_value; + + s7_pointer rec_stack, rec_testp, rec_f1p, rec_f2p, rec_f3p, rec_f4p, rec_f5p, rec_f6p, rec_f7p, rec_f8p; + 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_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; + bool rec_bool; + + 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 v, w, x, y, z; + s7_pointer temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8, temp9, read_dims; + 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, complex_wrappers, c_pointer_wrappers, let_wrappers, slot_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]; + + s7_int big_symbol_tag; + uint32_t small_symbol_tag; +#if S7_DEBUGGING + int32_t big_symbol_set_line, small_symbol_set_line, big_symbol_set_state, small_symbol_set_state, y_line, v_line, x_line, t_line; + const char *big_symbol_set_func, *small_symbol_set_func; +#endif + 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, complex_vector_ref_symbol, complex_vector_set_symbol, complex_vector_symbol, + cond_expand_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, procedure_arglist_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, hook_functions_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_let_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_complex_vector_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_integer_or_number_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, + local_documentation_symbol, local_signature_symbol, local_setter_symbol, local_iterator_symbol, + macro_symbol, macro_star_symbol, magnitude_symbol, + make_byte_vector_symbol, make_complex_vector_symbol, make_float_vector_symbol, make_hash_table_symbol, + make_weak_hash_table_symbol, make_int_vector_symbol, make_iterator_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, reader_cond_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_keyword_symbol, string_to_number_symbol, string_to_symbol_symbol, string_upcase_symbol, + sublet_symbol, substring_symbol, substring_uncopied_symbol, subtract_symbol, subvector_symbol, subvector_position_symbol, subvector_vector_symbol, + symbol_symbol, symbol_to_dynamic_value_symbol, symbol_initial_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; + s7_pointer hash_code_symbol, dummy_equal_hash_table, features_setter; +#if !WITH_PURE_S7 + s7_pointer char_ci_eq_symbol, char_ci_geq_symbol, char_ci_gt_symbol, char_ci_leq_symbol, char_ci_lt_symbol, integer_length_symbol, + is_char_ready_symbol, let_to_list_symbol, list_to_string_symbol, list_to_vector_symbol, make_polar_symbol, string_ci_eq_symbol, + string_ci_geq_symbol, string_ci_gt_symbol, string_ci_leq_symbol, string_ci_lt_symbol, string_length_symbol, + string_to_list_symbol, vector_length_symbol, vector_to_list_symbol; +#endif + + /* syntax symbols et al */ + s7_pointer allow_other_keys_keyword, and_symbol, anon_symbol, autoload_error_symbol, bad_result_symbol, baffled_symbol, begin_symbol, body_symbol, case_symbol, + class_name_symbol, cond_symbol, define_bacro_star_symbol, define_bacro_symbol, define_constant_symbol, define_expansion_star_symbol, + define_expansion_symbol, define_macro_star_symbol, define_macro_symbol, define_star_symbol, define_symbol, display_keyword, + division_by_zero_symbol, do_symbol, else_symbol, feed_to_symbol, format_error_symbol, if_keyword, if_symbol, immutable_error_symbol, + invalid_exit_function_symbol, io_error_symbol, lambda_star_symbol, lambda_symbol, let_star_symbol, let_symbol, + letrec_star_symbol, letrec_symbol, macroexpand_symbol, missing_method_symbol, no_setter_symbol, number_to_real_symbol, or_symbol, + out_of_memory_symbol, out_of_range_symbol, profile_in_symbol, quasiquote_function, quasiquote_symbol, quote_function, quote_symbol, + read_error_symbol, readable_keyword, rest_keyword, set_symbol, string_read_error_symbol, symbol_table_symbol, + syntax_error_symbol, trace_in_symbol, type_symbol, unbound_variable_symbol, unless_symbol, + unquote_symbol, value_symbol, when_symbol, with_baffle_symbol, with_let_symbol, write_keyword, + wrong_number_of_args_symbol, wrong_type_arg_symbol; + + /* signatures of sequences used as applicable objects: ("hi" 1) */ + s7_pointer byte_vector_signature, c_object_signature, float_vector_signature, hash_table_signature, int_vector_signature, + let_signature, pair_signature, string_signature, vector_signature, complex_vector_signature; + /* common signatures */ + s7_pointer pcl_bc, pcl_bs, pcl_bt, pcl_c, 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_1x, add_2, add_3, add_4, add_i_random, add_x1, append_2, ash_ic, ash_ii, bv_ref_2, bv_ref_3, bv_set_3, + cdr_let_ref, cdr_let_set, char_equal_2, char_greater_2, char_less_2, char_position_csi, complex_wrapped, curlet_ref, cv_ref_2, cv_set_3, + display_2, display_f, dynamic_wind_body, dynamic_wind_init, dynamic_wind_unchecked, + format_as_objstr, format_f, format_just_control_string, format_no_column, fv_ref_2, fv_ref_3, fv_set_3, fv_set_unchecked, geq_2, + get_output_string_uncopied, hash_table_2, hash_table_ref_2, int_log2, is_defined_in_rootlet, is_defined_in_unlet, iv_ref_2, iv_ref_3, iv_set_3, + list_0, list_1, list_2, list_3, list_4, list_ref_at_0, list_ref_at_1, list_ref_at_2, list_set_i, + logand_2, logand_ii, logior_ii, logior_2, logxor_2, memq_2, memq_3, memq_4, memq_any, multiply_3, + outlet_unlet, profile_out, read_char_1, restore_setter, rootlet_ref, simple_char_eq, simple_char_eq1, simple_char_eq2, + simple_inlet, simple_list_values, starlet_ref, starlet_set, + string_append_2, string_c1, string_equal_2, string_equal_2c, string_greater_2, string_less_2, sublet_curlet, substring_uncopied, subtract_1, + subtract_2, subtract_2f, subtract_3, subtract_f2, subtract_x1, sv_unlet_ref, symbol_to_string_uncopied, tree_set_memq_syms, + unlet_disabled, unlet_ref, unlet_set, values_uncopied, vector_2, vector_3, vector_ref_2, vector_ref_3, vector_set_3, vector_set_4, write_2; + + s7_pointer divide_2, divide_by_2, geq_xf, geq_xi, greater_2, greater_xf, greater_xi, invert_1, invert_x, leq_2, leq_ixx, + leq_xi, less_2, less_x0, less_xf, less_xi, max_2, max_3, min_2, min_3, + multiply_2, num_eq_2, num_eq_ix, num_eq_xi, random_1, random_f, random_i; + s7_pointer seed_symbol, carry_symbol; + + /* object->let symbols */ + s7_pointer active_symbol, alias_symbol, at_end_symbol, c_object_ref_symbol, c_type_symbol, class_symbol, closed_symbol, + current_value_symbol, data_symbol, dimensions_symbol, entries_symbol, file_info_symbol, file_symbol, function_symbol, info_symbol, + is_mutable_symbol, line_symbol, open_symbol, original_vector_symbol, pointer_symbol, port_type_symbol, position_symbol, + sequence_symbol, size_symbol, source_symbol, weak_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]; + int32_t *tc_rec_calls; + bool printing_gc_info; + s7_int blocks_allocated, format_ports_allocated, c_functions_allocated; + s7_int blocks_borrowed[NUM_BLOCK_LISTS], blocks_freed[NUM_BLOCK_LISTS], blocks_mallocated[NUM_BLOCK_LISTS]; + s7_int string_wrapper_allocs, integer_wrapper_allocs, real_wrapper_allocs, complex_wrapper_allocs, c_pointer_wrapper_allocs, let_wrapper_allocs, slot_wrapper_allocs; +#endif + + s7_pointer autoload_table, starlet, starlet_symbol, temp_error_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]; + s7_int overall_start_time; +}; + +static no_return 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 + +#if S7_DEBUGGING || DISABLE_FILE_OUTPUT || POINTER_32 + static s7_scheme *cur_sc = NULL; +#endif +#if S7_DEBUGGING || ((DISABLE_FILE_OUTPUT || POINTER_32) && (!WITH_GCC)) + static s7_scheme *original_cur_sc = NULL; +#endif + +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));} + +#if !WITH_GCC +/* I assume that MS C can't handle the ({...}) business (WITH_GCC include clang and tinyc) */ +#define fwrite local_fwrite +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))); + return(0); +} +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)); +} +#else +#define fwrite(Ptr, Size, N, Stream) ({error_nr(sc, sc->io_error_symbol, set_elist_1(sc, wrap_string(sc, "writing a file is not allowed in this version of s7", 51))); 0;}) +#define fopen(Path, Mode) \ + ({if ((Mode[0] == 'w') || (Mode[0] == 'a')) \ + error_nr(sc, 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))); \ + old_fopen(Path, Mode);}) +#endif +#endif /* DISABLE_FILE_OUTPUT */ + +#if POINTER_32 +/* passing in sc here gloms up the 64-bit code intolerably -- 32-bit users will just have to live with cur_sc! */ +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(Size) malloc(Size) +#define Calloc(N, Size) calloc(N, Size) +#define Realloc(Ptr, Size) realloc(Ptr, Size) +#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) + { + s7_int *s1 = (s7_int *)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; + s7_int *vals = (s7_int *)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; + for (int32_t i = 0; i < NUM_BLOCK_LISTS; i++) + sc->blocks_borrowed[i] = 0; +#endif +} + +static inline void liberate(s7_scheme *sc, block_t *p) +{ +#if S7_DEBUGGING + sc->blocks_freed[block_index(p)]++; +#endif + 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 /* biggest blocks (allocated according to each particular size) are freed and placed on the 0-th list */ + { + 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) +{ +#if S7_DEBUGGING + sc->blocks_freed[BLOCK_LIST]++; +#endif + 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 */ + 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) + { + char *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; + } + { + char *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) + { +#if S7_DEBUGGING + sc->blocks_mallocated[index]++; +#endif + 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. + */ +#if S7_DEBUGGING + sc->blocks_mallocated[index + 1]++; + sc->blocks_borrowed[index + 1]++; +#endif + sc->block_lists[index + 1] = (block_t *)block_next(p); + block_set_size(p, bytes); + return(p); + }} + p = mallocate_block(sc); + block_data(p) = (index < TOP_BLOCK_LIST) ? (void *)permalloc(sc, (size_t)(1 << index)) : Malloc(bytes); + block_set_index(p, index); +#if S7_DEBUGGING + sc->blocks_mallocated[index]++; +#endif + }} + else + { +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + 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 ((S7_DEBUGGING) && (bytes < (size_t)block_size(op))) fprintf(stderr, "reallocate to smaller block?\n"); + 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_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_any_closure_p[i] = false; + t_any_macro_p[i] = false; + t_applicable_p[i] = false; + t_has_closure_let[i] = false; + t_immutable_p[i] = true; + t_macro_setter_p[i] = false; + t_mappable_p[i] = false; + t_number_p[i] = false; + t_procedure_p[i] = false; + t_rational_p[i] = false; + t_real_p[i] = false; + t_sequence_p[i] = false; + t_simple_p[i] = false; + t_small_real_p[i] = false; + t_structure_p[i] = false; + t_vector_p[i] = false; +#if S7_DEBUGGING + t_ext_p[i] = false; + t_exs_p[i] = false; +#endif + } + { + const int32_t nums[8] = {T_INTEGER, T_RATIO, T_REAL, T_COMPLEX, T_BIG_INTEGER, T_BIG_RATIO, T_BIG_REAL, T_BIG_COMPLEX}; + for (int32_t i = 0; i < 8; i++) t_number_p[nums[i]] = 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; + + { + const int32_t recs[8] = {T_PAIR, T_VECTOR, T_HASH_TABLE, T_SLOT, T_LET, T_ITERATOR, T_C_OBJECT, T_C_POINTER}; + for (int32_t i = 0; i < 8; i++) t_structure_p[recs[i]] = true; + } + { + const int32_t seqs[11] = { + T_NIL, T_PAIR, T_STRING, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR, T_HASH_TABLE, T_LET, T_C_OBJECT}; + /* this assumes the object has a length method? */ + for (int32_t i = 0; i < 11; i++) t_sequence_p[seqs[i]] = true; + } + { + const int32_t maps[18] = { + T_PAIR, T_STRING, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR, T_HASH_TABLE, + T_LET, T_C_OBJECT, T_ITERATOR, T_C_MACRO, T_MACRO, T_MACRO_STAR, T_BACRO, T_BACRO_STAR, T_CLOSURE, T_CLOSURE_STAR}; + for (int32_t i = 0; i < 18; i++) t_mappable_p[maps[i]] = true; + } + { + const int32_t appls[24] = { + T_PAIR, T_STRING, T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR, + T_HASH_TABLE, T_ITERATOR, T_LET, T_C_OBJECT, T_C_MACRO, T_MACRO, T_MACRO_STAR, T_BACRO, T_BACRO_STAR, + T_SYNTAX, T_C_FUNCTION, T_C_FUNCTION_STAR, T_C_RST_NO_REQ_FUNCTION, + T_CLOSURE, T_CLOSURE_STAR, T_GOTO, T_CONTINUATION}; + for (int32_t i = 0; i < 24; i++) t_applicable_p[appls[i]] = true; + } + { + const int32_t immuts[15] = { + T_PAIR, T_UNDEFINED, T_SYMBOL, T_STRING, T_C_OBJECT, T_C_POINTER, T_VECTOR, T_FLOAT_VECTOR, T_INT_VECTOR, + T_BYTE_VECTOR, T_COMPLEX_VECTOR, T_HASH_TABLE, T_LET, T_SLOT, T_RANDOM_STATE}; + for (int32_t i = 0; i < 15; i++) t_immutable_p[immuts[i]] = false; + /* T_ITERATOR, T_INPUT_PORT, T_OUTPUT_PORT ?? */ + } + { + const int32_t vecs[5] = {T_VECTOR, T_INT_VECTOR, T_FLOAT_VECTOR, T_BYTE_VECTOR, T_COMPLEX_VECTOR}; + for (int32_t i = 0; i < 5; i++) t_vector_p[vecs[i]] = true; + } + { + const int32_t procs[7] = {T_C_FUNCTION, T_C_FUNCTION_STAR, T_C_RST_NO_REQ_FUNCTION, T_CLOSURE, T_CLOSURE_STAR, T_GOTO, T_CONTINUATION}; + for (int32_t i = 0; i < 7; i++) t_procedure_p[procs[i]] = 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; + + /* not T_UNDEFINED here: only # itself will work with eq? */ + /* T_LET needs let_equal in member et al, 29-Nov-22. Also not sure about ports. */ + { + const int32_t simps[12] = {T_NIL, T_EOF, T_BOOLEAN, T_CHARACTER, T_SYMBOL, T_SYNTAX, + T_C_MACRO, T_C_FUNCTION, T_C_FUNCTION_STAR, T_C_RST_NO_REQ_FUNCTION, T_INPUT_PORT, T_OUTPUT_PORT}; + for (int32_t i = 0; i < 12; i++) t_simple_p[simps[i]] = true; + } +#if S7_DEBUGGING + t_ext_p[T_UNUSED] = true; + t_ext_p[T_SLOT] = true; + t_ext_p[T_STACK] = 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 + /* these cases are errors (null pointer, T_FREE checked by check_nref called by check_ref_exs) */ + 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; +#if !WITH_GMP + t_exs_p[T_BIG_INTEGER] = true; + t_exs_p[T_BIG_RATIO] = true; + t_exs_p[T_BIG_REAL] = true; + t_exs_p[T_BIG_COMPLEX] = true; +#endif +#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, Code);} while (0) +#define replace_current_code(Sc, Code) set_car(Sc->cur_code, 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 = Code +#define replace_current_code(Sc, Code) Sc->cur_code = 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_scheme *sc, s7_pointer p, const char *func, int32_t line); + static s7_pointer check_let_ref(s7_pointer p, s7_uint role, const char *func, int32_t line); + 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); /* for REPORT_ROOTLET_REDEF below */ + #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_CFn(P) check_ref_cfn(P, __func__, __LINE__) /* c-functions (not c-macro) */ + #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_Cvc(P) check_ref_one(P, T_COMPLEX_VECTOR, __func__, __LINE__, "sweep", 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 (user-visible) type, but # 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) + #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_Muti(P) check_ref_muti(P, __func__, __LINE__) /* a mutable integer */ + #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(sc, 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_Prf(P) check_ref_prf(P, __func__, __LINE__) /* pair or #f */ + #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 end_slot, only for traversing let slot lists */ + #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_CFn(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_Cvc(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_Muti(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_Prf(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) (unchecked_type(p) == T_FREE) +#define is_free_and_clear(p) (full_type(p) == T_FREE) /* protect against new_cell in-between states? full_type is unchecked */ +#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_SAFE_LIST_IN_USE T_SIMPLE_ARG_DEFAULTS /* only on sc->safe_lists */ +#define safe_list_is_in_use(p) has_low_type_bit(T_Pair(p), T_SAFE_LIST_IN_USE) +#define set_safe_list_in_use(p) set_low_type_bit(T_Pair(p), T_SAFE_LIST_IN_USE) +#define clear_safe_list_in_use(p) do {clear_low_type_bit(T_Pair(p), T_SAFE_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_UNSAFE_DO (1 << (16 + 0)) +#define T_MID_UNSAFE_DO (1 << 0) +#define is_unsafe_do(p) has_mid_type_bit(T_Pair(p), T_MID_UNSAFE_DO) +#define set_unsafe_do(p) set_mid_type_bit(T_Pair(p), T_MID_UNSAFE_DO) +/* marks do-loops that resist optimization */ + +#define T_MID_DOX_SLOT1 T_MID_UNSAFE_DO +#define has_dox_slot1(p) has_mid_type_bit(T_Let(p), T_MID_DOX_SLOT1) +#define set_has_dox_slot1(p) set_mid_type_bit(T_Let(p), T_MID_DOX_SLOT1) +/* marks a let that includes the dox_slot1 */ + +#define T_MID_EVEN_ARGS T_MID_UNSAFE_DO +#define has_even_args(p) has_mid_type_bit(T_CFn(p), T_MID_EVEN_ARGS) +#define set_has_even_args(p) set_mid_type_bit(T_CFn(p), T_MID_EVEN_ARGS) + +#define T_MID_MAYBE_SHADOWED T_MID_UNSAFE_DO +#define is_maybe_shadowed(p) has_mid_type_bit(T_Sym(p), T_MID_MAYBE_SHADOWED) +#define set_is_maybe_shadowed(p) set_mid_type_bit(T_Sym(p), T_MID_MAYBE_SHADOWED) + +#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(T_Seq(p), T_MID_COLLECTED | T_MID_SHARED) +#define clear_collected_and_shared(p) clear_mid_type_bit(T_Seq(p), T_MID_COLLECTED | T_MID_SHARED) /* this can clear free cells = calloc */ + +#define T_LOW_COUNT (1 << (16 + 4)) +#define T_MID_LOW_COUNT (1 << 4) +#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_LOW_COUNT +#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_INITIAL_VALUE T_MID_LOW_COUNT +#define is_initial_value(p) has_mid_type_bit(p, T_INITIAL_VALUE) +#define set_is_initial_value(p) set_mid_type_bit(p, T_INITIAL_VALUE) +#define initial_value_is_defined(p) (initial_value(T_Sym(p)) != sc->undefined) + +#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" */ +/* see also T_NO_FLOAT_OPT below */ + +#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 set_immutable_string(p) set_mid_type_bit(T_Str(p), T_MID_IMMUTABLE) +#define set_immutable_pair(p) set_mid_type_bit(T_Pair(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_FULL_ALLOW_OTHER_KEYS (1 << (16 + 9)) +#define T_ALLOW_OTHER_KEYS (1 << 9) +#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)...) (where there are no args) because there's only one nil, and besides, it does say "other". + */ + +#define T_LET_REMOVED T_ALLOW_OTHER_KEYS +#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_ALLOW_OTHER_KEYS +#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(p) has_mid_type_bit(p, T_MID_MUTABLE) +#define is_mutable_number(p) has_mid_type_bit(T_Num(p), T_MID_MUTABLE) +#define is_mutable_integer(p) has_mid_type_bit(T_Int(p), T_MID_MUTABLE) +#if S7_DEBUGGING +#define clear_mutable_number(p) do {check_mutable_bit(p); clear_mid_type_bit(T_Num(p), T_MID_MUTABLE);} while (0) +#define clear_mutable_integer(p) do {check_mutable_bit(p); clear_mid_type_bit(T_Int(p), T_MID_MUTABLE);} while (0) +#else +#define clear_mutable_number(p) clear_mid_type_bit(T_Num(p), T_MID_MUTABLE) +#define clear_mutable_integer(p) clear_mid_type_bit(T_Int(p), T_MID_MUTABLE) +#endif +/* 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 has_carrier(p) has_mid_type_bit(T_Itr(p), T_MARK_SEQ) +#if S7_DEBUGGING + #define set_has_carrier(p) do {set_mid_type_bit(T_Itr(p), T_MARK_SEQ); p->carrier_line = __LINE__;} while (0) +#else + #define set_has_carrier(p) set_mid_type_bit(T_Itr(p), T_MARK_SEQ) +#endif +/* 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_ALLOW_OTHER_KEYS +#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_ALLOW_OTHER_KEYS +#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_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 */ +#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(T_Slt(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 has_methods_unchecked(p) has_mid_type_bit(p, T_MID_HAS_METHODS) +#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 # */ +#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 a let or closure that is "open" for generic functions etc, don't reuse this bit */ + +#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_CFn(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_CFn(p), T_BOOL_SETTER) +#define c_function_set_has_bool_setter(p) set_high_type_bit(T_CFn(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_CFn(p), T_DEFINER) +#define set_func_is_definer(p) do {set_high_type_bit(T_CFn(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) + +#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_CFn(p), T_SEMISAFE) +#define set_is_semisafe(p) set_high_type_bit(T_CFn(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) /* not T_Seq, p can be free(!) */ + +#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_CFn(p), T_SIMPLE_ELEMENTS) +#define c_function_set_has_simple_elements(p) set_high_type_bit(T_CFn(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) + +#define T_FULL_TRUE_IS_DONE (1LL << (48 + 10)) +#define T_TRUE_IS_DONE (1 << 10) +#define true_is_done(p) has_high_type_bit(T_Pair(p), T_TRUE_IS_DONE) +#define set_true_is_done(p) set_high_type_bit(T_Pair(p), T_TRUE_IS_DONE) +#define set_a_is_cadr(p) set_true_is_done(p) +#define a_is_cadr(p) true_is_done(p) + +/* #define T_FULL_IS_SAVER T_FULL_TRUE_IS_DONE */ +#define T_IS_SAVER T_TRUE_IS_DONE +#define is_saver(p) has_high_type_bit(p, T_IS_SAVER) +#define set_is_saver(p) do {set_high_type_bit(T_Sym(p), T_IS_SAVER); set_high_type_bit(T_Fnc(global_value(p)), T_IS_SAVER);} while (0) + +#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_FULL_IS_TRANSLUCENT T_FULL_UNKNOPT */ +#define T_IS_TRANSLUCENT T_UNKNOPT +#define is_translucent(p) (((is_symbol(p)) || (is_c_function(p))) && (has_high_type_bit(p, T_IS_TRANSLUCENT))) +#define set_is_translucent(p) do {set_high_type_bit(T_Sym(p), T_IS_TRANSLUCENT); set_high_type_bit(T_Fnc(global_value(p)), T_IS_TRANSLUCENT);} while (0) + +#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_SETTER T_SAFETY_CHECKED +#define set_is_setter(p) do {set_high_type_bit(T_Sym(p), T_SETTER); set_high_type_bit(global_value(p), T_SETTER);} while (0) +#define is_setter(p) ((has_high_type_bit(p, T_SETTER)) && (!is_pair(p))) +/* optimizer flag for a procedure that sets some variable (set-car! for example) */ + +#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 clear_has_fn(p) clear_high_type_bit(T_Pair(p), T_HAS_FN) + +/* #define T_FULL_IS_ESCAPER T_FULL_HAS_FN */ +#define T_IS_ESCAPER T_HAS_FN +#define is_escaper(p) ((has_high_type_bit(p, T_IS_ESCAPER)) && (!is_pair(p))) +#define set_is_escaper_syntax(p) do {set_high_type_bit(T_Sym(p), T_IS_ESCAPER); set_high_type_bit(T_Syn(global_value(p)), T_IS_ESCAPER);} while (0) +#define set_is_escaper_function(p) do {set_high_type_bit(T_Sym(p), T_IS_ESCAPER); set_high_type_bit(T_Fnc(global_value(p)), T_IS_ESCAPER);} while (0) + +#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_starlet let_set_slot */ +#define unheap(sc, p) set_high_type_bit(T_Ext(p), T_SHORT_UNHEAP) + +#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 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) +#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_pair(cdr(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(Port) (((port_line_number(Port) & PAIR_LINE_MASK) << PAIR_LINE_OFFSET) | \ + ((port_file_number(Port) & PAIR_FILE_MASK) << PAIR_FILE_OFFSET) | \ + ((port_position(Port) & 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_CFn(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 # */ +#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 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 {clear_has_fn(f); 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_fn(f);} while (0) +#define set_fn_direct(f, X) do {set_opt2(f, (s7_pointer)(X), OPT2_FN); set_has_fn(f);} while (0) +#define set_class_and_fn_proc(X, f) do {set_opt1_cfunc(X, f); set_fn_direct(X, c_function_call(f));} while (0) + +#if WITH_GCC +#if S7_DEBUGGING + #define fx_call(Sc, F) ({s7_pointer _P_, _C_, _V_; _P_ = F; _C_ = sc->code; _V_ = fx_proc(_P_)(Sc, car(_P_)); if (sc->code != _C_) fprintf(stderr, "%s%s[%d]: %s clobbered sc-code%s\n", bold_text, __func__, __LINE__, display(_C_), unbold_text); _V_;}) + #define fn_call(Sc, F) ({s7_pointer _P_, _C_, _V_; _P_ = F; _C_ = sc->code; _V_ = fn_proc(_P_)(Sc, cdr(_P_)); if (sc->code != _C_) fprintf(stderr, "%s%s[%d]: %s clobbered sc-code%s\n", bold_text, __func__, __LINE__, display(_C_), unbold_text); _V_;}) +#else + #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_));}) +#endif +#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) = Val /* can be a slot or # or # etc */ +#define cdr(p) (T_Pair(p))->object.cons.cdr +#define unchecked_set_cdr(p, Val) cdr(p) = T_Exs(Val) /* # in g_gc */ +#define unchecked_cdr(p) (T_Exs(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 caar(p) car(car(p)) +#define cadr(p) car(cdr(p)) +#define set_cadr(p, Val) car(cdr(p)) = T_Exs(Val) /* # 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 */ +#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) + +#if S7_DEBUGGING +#define s7_t_slot(Sc, P) s7_t_slot_1(Sc, P, __func__, __LINE__) +static s7_pointer s7_t_slot_1(s7_scheme *sc, s7_pointer symbol, const char *func, int line) +{ + s7_pointer p = s7_slot(sc, symbol); + if (type(p) == T_SLOT) return(p); + fprintf(stderr, "%s[%d]: slot: %d\n", func, line, (p == sc->undefined)); + return(p); +} +#else +#define s7_t_slot(Sc, P) s7_slot(Sc, P) +#endif + +#define is_symbol(p) (type(p) == T_SYMBOL) +#define is_normal_symbol(p) ((is_symbol(p)) && (!is_keyword(p))) /* ((full_type(p) & (0xff | T_KEYWORD)) == T_SYMBOL) is exactly the same speed */ +#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_uint)((intptr_t)(p)) +#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 starlet_symbol_id(p) ((uint8_t)((block_size(symbol_info(p)) >> 8) & 0xff)) /* *s7* id */ +#define starlet_symbol_set_id(p, F) block_size(symbol_info(p)) = ((block_size(symbol_info(p)) & ~0xff00) | (((F) & 0xff) << 8)) + +#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, T_Sym(Symbol), __func__, __LINE__) +#else + #define set_local(p) full_type(T_Sym(p)) &= ~(T_DONT_EVAL_ARGS | T_SYNTACTIC) + /* if symbol_increment_ctr, local shadowing value is not found? same if {} */ +#endif +#define is_global(p) (symbol_id(p) == 0) +#define is_defined_global(p) ((is_slot(global_slot(p))) && (symbol_id(p) == 0)) + +#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_Sld((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) symbol_info(p)->ex.ex_ptr +#define set_initial_value(p, Val) initial_value(p) = T_Ext(Val) +#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 set_global_value(p, Val) slot_set_value(global_slot(T_Sym(p)), Val) /* slot_set_value checks T_Ext */ + +#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 big_symbol_tag(p) symbol_info(p)->dx.tag +#define set_big_symbol_tag(p, Val) symbol_info(p)->dx.tag = Val + +#define small_symbol_tag(p) (T_Sym(p))->object.sym.small_symbol_tag +#define set_small_symbol_tag(p, Val) (T_Sym(p))->object.sym.small_symbol_tag = Val +#define symbol_shadows(p) symbol_info(p)->ln.iter_or_size +#define symbol_set_shadows(p, Val) symbol_info(p)->ln.iter_or_size = 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 /* used only to set initial ctr value */ +#define symbol_increment_ctr(p) (T_Sym(p))->object.sym.ctr++ /* despite this expense, ctr does save a lot overall */ +#define symbol_has_help(p) (is_documented(symbol_name_cell(p))) +#define symbol_set_has_help(p) set_documented(symbol_name_cell(p)) + +#define symbol_set_local_slot_unchecked(Symbol, Id, Slot) \ + do {(Symbol)->object.sym.local_slot = T_Sld(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_Sld(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))); \ + (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, T_Slt(Slot), T_Nmv(Value)); else slot_set_value(T_Slt(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 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_id(p, Id) do {(T_Let(p))->object.envr.id = Id; if ((p == sc->rootlet) && (Id != -1)) {fprintf(stderr, "%s[%d]: rootlet id: %" ld64 "\n", __func__, __LINE__, (s7_int)Id); if (sc->stop_at_error) abort();}} while (0) + #define let_set_slots(p, Slot) check_let_set_slots(sc, 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_id(p, Id) (T_Let(p))->object.envr.id = Id + #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 let_set_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_complex_vector(p) (type(p) == T_COMPLEX_VECTOR) +#define complex_vector(p, i) ((T_Cvc(p))->object.vector.elements.complexes[i]) +#define complex_vector_complexes(p) (T_Cvc(p))->object.vector.elements.complexes + +#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 +/* hash_table_mask comes from an earlier hash_map, but hash_table_size is still a power of 2, so hash_map's % wastes an entry, but + * the mask (pow2-1) is still useful -- in pointer_map for example if we divide by pow2, we can end up just tossing the 3 lower bits, + * (hash-table :a 1 :b 2 :c 3) -> hash-stats:empty|1|2|n|most (7 0 0 1 3) + */ +#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_uint +#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.iter_or_size +#define missing_key_value(Sc) hash_entry_value(Sc->unentry) + +#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.seq +#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_current(p) (T_Itr(p))->object.iter.cur +#define iterator_carrier(p) (T_Itr(p))->object.iter.cur +#define iterator_is_at_end(p) (!iter_ok(p)) /* ((full_type(T_Itr(p)) & T_ITER_OK) == 0) */ +#define iterator_at_end_value(Sc) Sc->iterator_at_end_value + +#define pair_iterator_slow(p) T_Lst((T_Itr_Pair(p))->object.iter.lw.slow) /* applies only to pairs */ +#define pair_iterator_set_slow(p, Val) (T_Itr_Pair(p))->object.iter.lw.slow = T_Lst(Val) +#define hash_iterator_entry(p) (T_Itr_Hash(p))->object.iter.lw.entry /* applies only to hash-tables */ +#define let_iterator_slot(p) T_Sln((T_Itr_Let(p))->object.iter.lc.slot) /* applies only to lets */ +#define let_iterator_set_slot(p, Val) (T_Itr_Let(p))->object.iter.lc.slot = T_Sln(Val) + +#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 /* not T_CFn -- this also applies to T_C_MACROs */ +#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 /* const char* */ +#define c_function_name_length(f) c_function_data(f)->name_length /* int32_t */ +#define c_function_documentation(f) c_function_data(f)->doc /* const char* */ +#define c_function_signature(f) T_Prf(c_function_data(f)->signature) /* pair or #f */ +#define c_function_set_signature(f, Val) c_function_data(f)->signature = T_Prf(Val) +#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)->class_id /* uint32_t */ +#define c_function_chooser(f) c_function_data(f)->chooser +#define c_function_base(f) T_CFn(c_function_data(f)->generic_ff) +#define c_function_set_base(f, Val) c_function_data(f)->generic_ff = T_CFn(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) T_Sym(c_function_data(f)->sam.c_sym) /* f is c_function or c_macro, but not c_function* -- doesn't fit current checks */ +#define c_function_set_symbol(f, Sym) c_function_data(f)->sam.c_sym = T_Sym(Sym) +#define c_function_let(f) T_Let(c_function_data(f)->let) +#define c_function_set_let(f, Val) c_function_data(f)->let = T_Let(Val) + +#define c_function_bool_setter(f) T_CFn(c_function_data(f)->dam.bool_setter) +#define c_function_set_bool_setter(f, Val) c_function_data(f)->dam.bool_setter = T_CFn(Val) + +#define c_function_arg_defaults(f) c_function_data(T_Fst(f))->dam.arg_defaults /* array of s7_pointer */ +#define c_function_call_args(f) c_function_data(T_Fst(f))->cam.call_args /* pair or NULL */ +#define c_function_arg_names(f) c_function_data(T_Fst(f))->sam.arg_names /* array of s7_pointer */ +#define c_function_opt_data(f) c_function_data(f)->opt_data /* opt_funcs_t (vunion) */ + +#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.iter_or_size +#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_pars(p) T_Arg((T_Clo(p))->object.func.args) +#define closure_set_pars(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) +#define closure_set_setter_or_map_list(p, Val) T_Clo(p)->object.func.setter = Val +/* closure_map_list refers to a cyclic list detector in map */ + +#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_sc(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 begin_temp(P, Val) do {s7_pointer __val__ = Val; begin_temp_1(sc, P, __val__, __func__, __LINE__); P = __val__;} while (0) +static void begin_temp_1(s7_scheme *sc, s7_pointer p, s7_pointer val, const char *func, int line) +{ + if(p != sc->unused) + { + char *s1; + fprintf(stderr, "%s[%d]: begin_temp %s %d %s\n", func, line, + (p == sc->y) ? "sc->y" : ((p == sc->v) ? "sc->v" : ((p == sc->x) ? "sc->x" : ((p == sc->temp6) ? "sc->temp6" : "???"))), + (p == sc->y) ? sc->y_line : ((p == sc->v) ? sc->v_line : ((p == sc->x) ? sc->x_line : sc->t_line)), + s1 = s7_object_to_c_string(sc, p)); + free(s1); + /* if (sc->stop_at_error) abort(); */ /* this happens when an error interrupts a loop (for-each etc) so end_temp is missed */ + } + if (p == sc->y) sc->y_line = line; else if (p == sc->v) sc->v_line = line; else if (p == sc->x) sc->x_line = line; else sc->t_line = line; +} +#else +#define begin_temp(p, Val) p = Val +#endif +#define end_temp(p) p = sc->unused +#define return_with_end_temp(Temp) do {s7_pointer Result = Temp; end_temp(Temp); return(Result);} while (0) + +#if __cplusplus && HAVE_COMPLEX_NUMBERS + static s7_double Real(complex x) {return(real(x));} /* protect the C++ name */ + static s7_double Imag(complex 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.cz.complex_value.rl +#define set_real_part(p, x) real_part(p) = x +#define imag_part(p) (T_Cmp(p))->object.number.cz.complex_value.im +#define set_imag_part(p, x) imag_part(p) = x +#if WITH_CLANG_PP +#define a_bi(p) CMPLX((T_Cmp(p))->object.number.cz.complex_value.rl, p->object.number.cz.complex_value.im) +#else +#define a_bi(p) (T_Cmp(p))->object.number.cz.z +#define set_a_bi(p, x) a_bi(p) = x +#endif +#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 *result; + if (!has_methods_unchecked(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 */ + result = string_value(s7_object_to_string(cur_sc, obj, false)); + set_type_bit(obj, T_HAS_METHODS); /* same for set_has_methods */ + return(result); +} +#else +#define display(Obj) string_value(s7_object_to_string(sc, Obj, false)) +#endif +#define display_truncated(Obj) string_value(object_to_string_truncated(sc, Obj)) + +#if S7_DEBUGGING +static void check_mutable_bit(s7_pointer p) +{ + if (!is_mutable(p)) + fprintf(stderr, "%s[%d]: mutable cleared already?\n", p->gc_func, p->gc_line); +} + +static void set_type_1(s7_pointer p, s7_uint typ, const char *func, int32_t line) +{ + p->alloc_line = line; + p->alloc_func = func; + p->alloc_type = typ; + p->explicit_free_line = 0; + p->uses++; + if (((typ) & TYPE_MASK) == T_FREE) + fprintf(stderr, "%d: set free, %p type to #x%" PRIx64 "\n", __LINE__, p, (s7_int)(typ)); + else + if (((typ) & TYPE_MASK) >= NUM_TYPES) + fprintf(stderr, "%d: set invalid type, %p type to #x%" PRIx64 "\n", __LINE__, p, (s7_int)(typ)); + else + { + if (((full_type(p) & T_IMMUTABLE) != 0) && ((full_type(p) != (s7_uint)(typ)))) + { + fprintf(stderr, "%s[%d]: set immutable %p type %d to %" ld64 "\n", __func__, __LINE__, p, unchecked_type(p), (s7_int)(typ)); + abort(); + } + if (((full_type(p) & T_UNHEAP) != 0) && (((typ) & T_UNHEAP) == 0)) + fprintf(stderr, "%s[%d]: clearing unheap in set type!\n", __func__, __LINE__); + } + full_type(p) = typ; +} +#endif + +static int32_t s7_int_digits_by_radix[17]; + +#define S7_INT_BITS 63 + +#define S7_INT64_MAX 9223372036854775807LL +/* #define S7_INT64_MIN -9223372036854775808LL */ /* why is this disallowed in C? "warning: integer constant is so large that it is unsigned" */ +#define S7_INT64_MIN (int64_t)(-S7_INT64_MAX - 1LL) /* in gcc 9 we had to assign this to an s7_int, then use that! */ + +#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_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)Malloc(sizeof(s7_cell)); /* was using Calloc to clear name. 22-May-25 */ + 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 +/* if NUM_SMALL_INTS 256, tvect: +240 trclo +200 tfft +170 trec +300 etc -- mostly gc + various adds */ + +static bool t_number_separator_p[NUM_CHARS]; +static s7_cell *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) +{ + s7_cell *cells; + small_ints = (s7_cell *)Malloc(NUM_SMALL_INTS * sizeof(s7_cell)); /* was calloc 14-Apr-22, used a pointless intermediate s7_pointer array until 22-May-25 */ + for (int32_t i = 0; i < NUM_SMALL_INTS; i++) + { + s7_pointer p; + p = &small_ints[i]; + full_type(p) = T_IMMUTABLE | T_INTEGER | T_UNHEAP; + set_integer(p, i); + } + /* setup a few other numbers while we're here */ + #define EXTRA_NUMBERS 11 + cells = (s7_cell *)Malloc(EXTRA_NUMBERS * sizeof(s7_cell)); + + #define init_integer(Ptr, Num) \ + do {full_type(Ptr) = T_INTEGER | T_IMMUTABLE | T_UNHEAP; set_integer(Ptr, Num);} while (0) + #define init_real(Ptr, Num) \ + do {full_type(Ptr) = T_REAL | T_IMMUTABLE | T_UNHEAP; set_real(Ptr, Num);} while (0) + #define init_complex(Ptr, Real, Imag) \ + do {full_type(Ptr) = T_COMPLEX | T_IMMUTABLE | T_UNHEAP; set_real_part(Ptr, Real); set_imag_part(Ptr, Imag);} while (0) + + real_zero = &cells[0]; init_real(real_zero, 0.0); + real_one = &cells[1]; init_real(real_one, 1.0); + real_NaN = &cells[2]; init_real(real_NaN, NAN); + complex_NaN = &cells[10]; init_complex(complex_NaN, NAN, NAN); + real_infinity = &cells[3]; init_real(real_infinity, INFINITY); + real_minus_infinity = &cells[4]; init_real(real_minus_infinity, -INFINITY); + real_pi = &cells[5]; init_real(real_pi, 3.1415926535897932384626433832795029L); + + arity_not_set = &cells[6]; init_integer(arity_not_set, CLOSURE_ARITY_NOT_SET); + max_arity = &cells[7]; init_integer(max_arity, MAX_ARITY); + minus_one = &cells[8]; init_integer(minus_one, -1); + minus_two = &cells[9]; init_integer(minus_two, -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_INT64_MIN); + 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 FINIT NULL /* or sc->unused */ +#define new_cell(Sc, Obj, Type) \ + do { \ + if (Sc->gc_in_progress) fprintf(stderr, "%s[%d]: new_cell during GC\n", __func__, __LINE__); \ + 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; \ + Obj->object.cons.car = FINIT; Obj->object.cons.cdr = FINIT; Obj->object.cons.opt1 = FINIT; Obj->object.cons.o2.opt2 = FINIT; Obj->object.cons.o3.opt3 = FINIT; \ + set_full_type(Obj, Type); \ + } while (0) + +#define new_cell_no_check(Sc, Obj, Type) \ + do { \ + if (Sc->gc_in_progress) fprintf(stderr, "%s[%d]: new_cell_no_check during GC\n", __func__, __LINE__); \ + 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; \ + Obj->object.cons.car = FINIT; Obj->object.cons.cdr = FINIT; Obj->object.cons.opt1 = FINIT; Obj->object.cons.o2.opt2 = FINIT; Obj->object.cons.o3.opt3 = FINIT; \ + 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 make_complex_unchecked(Sc, R, I) \ + ({ s7_double _im_; _im_ = (I); ((_im_ == 0.0) ? make_real_unchecked(Sc, R) : \ + ({ s7_pointer _C_; new_cell_no_check(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_) : (s7_double)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_unchecked(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 + + +/* -------------------------------------------------------------------------------- + * local versions of some standard C library functions + * timing tests involving these are very hard to interpret, local_memset is faster using s7_int than int32_t + * but don't replace local_memset and memclr64 with memset! tbig -> 290! + */ + +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) + { + s7_int *s1 = (s7_int *)s; + size_t n8 = n >> 3; + s7_int ival = val | (val << 8) | (val << 16) | (((s7_uint)val) << 24); /* s7_uint casts make gcc/clang/fsanitize happy */ + ival = (((s7_uint)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 + if ((len <= 0) || (!str)) + {fprintf(stderr, "%s[%d]: len: %" ld64 ", str: %s\n", __func__, __LINE__, len, str); if (cur_sc->stop_at_error) abort();} +#endif + 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; + s7_int *is1 = (s7_int *)s1, *is2 = (s7_int *)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); /* 45B in tbig!! v-big38 */ + 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); /* str[31] */ + char *op = p; + if ((S7_DEBUGGING) && (num < 0)) {fprintf(stderr, "%s[%d]: num=%" ld64, __func__, __LINE__, num); if (sc->stop_at_error) abort();} + *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); + if ((S7_DEBUGGING) && (num < 0)) {fprintf(stderr, "%s[%d]: num=%" ld64, __func__, __LINE__, num); if (sc->stop_at_error) abort();} + *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, T_Sym(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, T_Sym(Sym)) + #define lookup_checked(Sc, Sym) ({s7_pointer _x_; _x_ = lookup_1(Sc, T_Sym(Sym)); ((_x_) ? _x_ : unbound_variable(Sc, T_Sym(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, + + 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_C_SC, HOP_C_SC, 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_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_STARLET_REF_S, OP_IMPLICIT_STARLET_SET_S, + 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_OPENLETS, OP_LET_TEMP_S7_OPENLETS_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_COMPLEX_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_SS, 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_L2A, OP_TC_OR_A_AND_A_L2A, 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_L2A, OP_TC_WHEN_L3A, OP_TC_LET_WHEN_L2A, + OP_TC_COND_A_Z_A_L2A_L2A, OP_TC_LET_COND, OP_TC_COND_N, + OP_TC_IF_A_Z_LA, OP_TC_IF_A_Z_L2A, OP_TC_IF_A_Z_L3A, + OP_TC_IF_A_Z_IF_A_Z_LA, OP_TC_IF_A_Z_IF_A_LA_Z, OP_TC_IF_A_Z_IF_A_Z_L2A, OP_TC_IF_A_Z_IF_A_L2A_Z, + OP_TC_IF_A_Z_IF_A_Z_L3A, OP_TC_IF_A_Z_IF_A_L3A_Z, OP_TC_IF_A_Z_IF_A_L3A_L3A, + OP_TC_LET_IF_A_Z_LA, OP_TC_LET_IF_A_Z_L2A, OP_TC_IF_A_Z_LET_IF_A_Z_L2A, + OP_TC_AND_A_IF_A_Z_LA, OP_TC_AND_A_IF_A_LA_Z, + OP_TC_CASE_LA, OP_TC_CASE_L2A, OP_TC_CASE_L3A, /* treat this as last tc op (see below) */ + + OP_RECUR_IF_A_A_opLA_LAq, OP_RECUR_IF_A_A_opL2A_L2Aq, OP_RECUR_IF_A_A_opL3A_L3Aq, + OP_RECUR_IF_A_A_opA_LAq, OP_RECUR_IF_A_A_opA_L2Aq, OP_RECUR_IF_A_A_opA_L3Aq, + OP_RECUR_IF_A_A_opLA_LA_LAq, OP_RECUR_IF_A_A_AND_A_L2A_L2A, OP_RECUR_IF_A_A_opA_LA_LAq, + OP_RECUR_IF_A_A_IF_A_A_opLA_LAq, OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq, OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq, + OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq, OP_RECUR_COND_A_A_A_A_opA_L2Aq, + OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq, OP_RECUR_AND_A_OR_A_L2A_L2A, + + NUM_OPS}; + +#define is_tc_op(Op) ((Op >= OP_TC_AND_A_OR_A_LA) && (Op <= OP_TC_CASE_L3A)) + +typedef enum {combine_p, combine_pp, combine_cp, combine_sp, combine_pc, combine_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", "c_sc", "h_c_sc", "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_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_s", + "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_openlets", "let_temp_s7_openlets_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_complex_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_ss", "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_l2a", "tc_or_a_and_a_l2a", "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_l2a", "tc_when_l3a", "tc_let_when_l2a", + "tc_cond_a_z_a_l2a_l2a", "tc_let_cond", "tc_cond_n", + "tc_if_a_z_la", "tc_if_a_z_l2a", "tc_if_a_z_l3a", + "tc_if_a_z_if_a_z_la", "tc_if_a_z_if_a_la_z", "tc_if_a_z_if_a_z_l2a", "tc_if_a_z_if_a_l2a_z", + "tc_if_a_z_if_a_z_l3a", "tc_if_a_z_if_a_l3a_z", "tc_if_a_z_if_a_l3a_l3a", + "tc_let_if_a_z_la", "tc_let_if_a_z_l2a", "if_a_z_let_if_a_z_l2a", + "tc_and_a_if_a_z_la", "tc_and_a_if_a_la_z", + "tc_case_la", "tc_case_l2a", "tc_case_l3a", + + "recur_if_a_a_opla_laq", "recur_if_a_a_opl2a_l2aq", "recur_if_a_a_opl3a_l3aq", + "recur_if_a_a_opa_laq", "recur_if_a_a_opa_l2aq", "recur_if_a_a_opa_l3aq", + "recur_if_a_a_opla_la_laq", "recur_if_a_a_and_a_l2a_l2a", "recur_if_a_a_opa_la_laq", + "recur_if_a_a_if_a_a_opla_laq", "recur_if_a_a_if_a_a_opl2a_l2aq", "recur_if_a_a_if_a_a_opl3a_l3aq", + "recur_if_a_a_if_a_l2a_opa_l2aq", "recur_cond_a_a_a_a_opa_l2aq", + "recur_cond_a_a_a_l2a_lopa_l2aq", "recur_and_a_or_a_l2a_l2a" +}; + +#define is_safe_c_op(op) ((op >= OP_SAFE_C_NC) && (op < OP_THUNK)) +#define is_safe_closure_op(op) ((op >= OP_SAFE_CLOSURE_S) && (op < OP_ANY_CLOSURE_3P)) +#define is_safe_closure_star_op(op) ((op >= OP_SAFE_CLOSURE_STAR_A) && (op < OP_C_SS)) +#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_accept_all_keyword_arguments, sl_autoloading, sl_bignum_precision, sl_catches, sl_cpu_time, sl_c_types, + sl_debug, sl_default_hash_table_length, sl_default_random_state, sl_default_rationalize_error, sl_equivalent_float_epsilon, + sl_expansions, sl_filenames, sl_file_names, sl_float_format_precision, sl_free_heap_size, sl_gc_freed, sl_gc_info, + sl_gc_protected_objects, sl_gc_resize_heap_by_4_fraction, sl_gc_resize_heap_fraction, sl_gc_stats, sl_gc_temps_size, + sl_gc_total_freed, sl_hash_table_float_epsilon, sl_hash_table_missing_key_value, sl_heap_size, sl_history, sl_history_enabled, + sl_history_size, sl_initial_string_port_length, sl_iterator_at_end_value, sl_major_version, sl_max_heap_size, sl_max_list_length, + sl_max_stack_size, sl_max_string_length, sl_max_string_port_length, sl_max_vector_dimensions, sl_max_vector_length, + sl_memory_usage, sl_minor_version, sl_most_negative_fixnum, sl_most_positive_fixnum, sl_muffle_warnings, + sl_number_separator, sl_openlets, sl_output_file_port_length, sl_print_length, sl_profile, sl_profile_info, + sl_profile_prefix, sl_rootlet_size, sl_safety, sl_stack, sl_stacktrace_defaults, sl_stack_size, sl_stack_top, + sl_symbol_quote, sl_symbol_printer, sl_undefined_constant_warnings, sl_undefined_identifier_warnings, sl_version, + sl_num_fields} starlet_t; + +static const char *starlet_names[sl_num_fields] = + {"no-field", "accept-all-keyword-arguments", "autoloading?", "bignum-precision", "catches", "cpu-time", "c-types", + "debug", "default-hash-table-length", "default-random-state", "default-rationalize-error", "equivalent-float-epsilon", + "expansions?", "filenames", "file-names", "float-format-precision", "free-heap-size", "gc-freed", "gc-info", + "gc-protected-objects", "gc-resize-heap-by-4-fraction", "gc-resize-heap-fraction", "gc-stats", "gc-temps-size", + "gc-total-freed", "hash-table-float-epsilon", "hash-table-missing-key-value", "heap-size", "history", "history-enabled", + "history-size", "initial-string-port-length", "iterator-at-end-value", "major-version", "max-heap-size", "max-list-length", + "max-stack-size", "max-string-length", "max-string-port-length", "max-vector-dimensions", "max-vector-length", + "memory-usage", "minor-version", "most-negative-fixnum", "most-positive-fixnum", "muffle-warnings?", + "number-separator", "openlets", "output-file-port-length", "print-length", "profile", "profile-info", + "profile-prefix", "rootlet-size", "safety", "stack", "stacktrace-defaults", "stack-size", "stack-top", + "symbol-quote?", "symbol-printer", "undefined-constant-warnings", "undefined-identifier-warnings", "version"}; + +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 s7_int 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 +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 + { + s7_int 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 0x000fc00000000c0 /* high 6 bits of optimizer code + high 2 bits of type */ + +static char *describe_type_bits(s7_scheme *sc, s7_pointer obj) +{ + const s7_uint full_typ = full_type(obj); + const 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_any_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_UNSAFE_DO) != 0) ? ((is_pair(obj)) ? " unsafe-do" : + ((is_let(obj)) ? " dox-slot1" : + ((is_any_c_function(obj)) ? " even-args" : + ((is_symbol(obj)) ? " maybe-shadowed" : + " ?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_LOW_COUNT) != 0) ? ((is_pair(obj)) ? " low-count" : " init-value") : "", + /* 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_ALLOW_OTHER_KEYS) != 0) ? ((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_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 */ + ((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 */ + ((full_typ & T_FULL_TRUE_IS_DONE) != 0) ? ((is_pair(obj)) ? " #t-is-done" : + ((is_symbol(obj)) ? " saver-symbol" : + ((is_c_function(obj)) ? " saver-c-function" : + " ?34?"))) : "", + /* bit 35+24 */ + ((full_typ & T_FULL_UNKNOPT) != 0) ? ((is_pair(obj)) ? " unknopt" : + ((is_symbol(obj)) ? " translucent-symbol" : + ((is_c_function(obj)) ? " translucent-c-function" : + " ?35?"))) : "", + /* bit 36+24 */ + ((full_typ & T_FULL_SAFETY_CHECKED) != 0) ? ((is_pair(obj)) ? " safety-checked" : + ((is_symbol(obj)) ? " setter" : + ((is_c_function(obj)) ? " setter-c-function" : + ((is_syntax(obj)) ? " setter-syntax" : + " ?36?")))) : "", + /* bit 37+24 */ + ((full_typ & T_FULL_HAS_FN) != 0) ? ((is_pair(obj)) ? " has-fn" : + ((is_symbol(obj)) ? " escaper-symbol" : + ((is_syntax(obj)) ? " escaper-syntax" : + ((is_c_function(obj)) ? " escaper-c-function" : + " ?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, "%s? (type: %d), opt_op: %d %s, full_type: #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) +{ + const int32_t heaped[20] = { + T_BACRO, T_BACRO_STAR, T_CATCH, T_CLOSURE, T_CLOSURE_STAR, T_CONTINUATION, T_COUNTER, T_C_OBJECT, T_C_POINTER, T_DYNAMIC_WIND, + T_FREE, T_GOTO, T_HASH_TABLE, T_ITERATOR, T_MACRO, T_MACRO_STAR, T_RANDOM_STATE, T_SLOT, T_STACK, T_VECTOR}; + /* T_UNUSED, like T_NIL, is never in the heap */ + for (int32_t i = 0; i < NUM_TYPES; i++) never_unheaped[i] = false; + for (int32_t i = 0; i < 20; i++) never_unheaped[heaped[i]] = true; +} + +static bool has_odd_bits(s7_pointer obj) +{ + const s7_uint 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_any_macro(obj))) return(true); + if (((full_typ & T_MULTIPLE_VALUE) != 0) && (!is_symbol(obj)) && (!is_pair(obj))) return(true); + if (((full_typ & T_UNSAFE_DO) != 0) && (!is_pair(obj)) && (!is_let(obj)) && (!is_any_c_function(obj)) && (!is_symbol(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_LOW_COUNT) != 0) && (!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)) && (!is_symbol(obj)) && (!is_c_function(obj))) return(true); + if (((full_typ & T_FULL_SAFETY_CHECKED) != 0) && (!is_pair(obj)) && (!is_normal_symbol(obj)) && (!is_c_function(obj)) && (!is_syntax(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_FULL_ALLOW_OTHER_KEYS) != 0) && (!is_slot(obj)) && (!is_pair(obj)) && (!is_let(obj)) && (!is_c_function_star(obj)) && (!is_let(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_pair(obj)) && (!is_hash_table(obj)) && (!is_any_macro(obj)) && (!is_symbol(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)) && (!is_symbol(obj)) && (!is_syntax(obj)) && (!is_c_function(obj))) return(true); + if (((full_typ & T_FULL_TRUE_IS_DONE) != 0) && (!is_pair(obj)) && (!is_symbol(obj)) && (!is_c_function(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]); print_gc_info(cur_sc, obj, __func__, __LINE__); 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 e = sc->curlet; e; e = let_outlet(e)) + { + if (e == sc->owlet) + fprintf(stderr, "(owlet): "); + else + if (e == sc->rootlet) + fprintf(stderr, "(rootlet): "); + else + if (is_funclet(e)) + fprintf(stderr, "(%s funclet): ", display(funclet_function(e))); + else + if (e == sc->shadow_rootlet) + fprintf(stderr, "(shadow rootlet): "); + fprintf(stderr, "%s\n", display(e)); + } +} + +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_defined_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_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(s7_scheme *sc, const char *complaint, s7_pointer p, const char *func, int32_t line, uint8_t typ) +{ + char *pstr = object_raw_type_to_string(p); + fprintf(stderr, complaint, bold_text, func, line, checked_type_name(sc, typ), pstr, unbold_text); + free(pstr); + if (sc->stop_at_error) abort(); +} + +static char *show_debugger_bits(s7_pointer p) +{ + char *bits_str = (char *)Malloc(512); + const s7_int 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 + { + const 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_scheme *sc, 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 == sc->rootlet) && (slot != slot_end)) + { + fprintf(stderr, "%s[%d]: setting rootlet slots!\n", func, line); + if (sc->stop_at_error) abort(); + } + T_Let(p)->object.envr.slots = T_Sln(slot); +} + +static s7_pointer check_let_ref(s7_pointer p, s7_uint 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, s7_uint 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_prf(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = unchecked_type(p); + if ((typ != T_PAIR) && (p != cur_sc->F)) + complain(cur_sc, "%s%s[%d]: not a pair or #f, but %s (%s)%s\n", p, func, line, typ); + 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(cur_sc, "%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(cur_sc, "%s%s[%d]: not an input port or #f, 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(cur_sc, "%s%s[%d]: not an output port or #f, 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(cur_sc, "%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) +{ + if (!p) + fprintf(stderr, "%s[%d]: null pointer passed to check_ref_clo\n", func, line); + else + { + uint8_t typ = unchecked_type(p); + if (!t_has_closure_let[typ]) complain(cur_sc, "%s%s[%d]: not a closure, but %s (%s)%s\n", p, func, line, typ); + } + return(p); +} + +static s7_pointer check_ref_cfn(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = unchecked_type(p); + if (typ < T_C_FUNCTION_STAR) complain(cur_sc, "%s%s[%d]: not a c-function (type < T_C_FUNCTION_STAR, from T_CFn), 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(cur_sc, "%s%s[%d]: not a c-function or c-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(cur_sc, "%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(cur_sc, "%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(cur_sc, "%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(cur_sc, "%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(cur_sc, "%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_UNDEFINED)) /* unset slots are # */ + complain(cur_sc, "%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(cur_sc, "%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(cur_sc, "%s%s[%d]: subvector is %s (%s)%s?\n", p, func, line, unchecked_type(p)); + if (!is_subvector(p)) complain(cur_sc, "%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(cur_sc, "%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 (!is_free(obj)) + fprintf(stderr, "%s from %s[%d]: %p type is %d?\n", __func__, func, line, obj, unchecked_type(obj)); + else + { + const 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], uses: %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 (is_free(p)) + { + 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; + check_nref(p, func, line); + typ = unchecked_type(p); /* must follow check_nref -- p might be NULL */ + if ((is_multiple_value(p)) && + (!safe_strcmp(func, "mark_slot"))) /* match == multiple-values which causes false error messages */ + complain(cur_sc, "%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, "%s[%d]: odd bits: %s\n", __func__, __LINE__, s = describe_type_bits(cur_sc, p)); free(s);} + if (t_exs_p[typ]) + { + fprintf(stderr, "%s%s[%d]: slot_value is %s?%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_mac(s7_pointer p, const char *func, int32_t line) +{ + if ((!is_any_macro(p)) || (is_c_macro(p))) + complain(cur_sc, "%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(cur_sc, "%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; + check_nref(p, func, line); + typ = unchecked_type(p); + 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; + check_nref(p, func, line); + typ = unchecked_type(p); + 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_scheme *sc, 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 (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(s7_uint 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(s7_uint 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(s7_uint 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, s7_uint role) +{ + char *bits = show_debugger_bits(p); + fprintf(stderr, "%s%s[%d]%s: opt1: %p->%p wants %s, debugger bits are #x%" PRIx64 "%s but expects #x%" PRIx64, + 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, s7_uint 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, s7_uint role) +{ + set_opt1_role(p, role); + set_opt1_is_set(p); +} + +static s7_pointer set_opt1_1(s7_pointer p, s7_pointer x, s7_uint 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 s7_uint 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, (s7_uint)OPT1_HASH); + if (sc->stop_at_error) abort(); + } + return(p->object.sym_cons.hash); +} + +static void set_opt1_hash_1(s7_pointer p, s7_uint 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, s7_uint role) +{ + char *bits = show_debugger_bits(p); + fprintf(stderr, "%s%s[%d]%s: %s opt2: %p->%p wants %s, debugger bits are #x%" PRIx64 "%s but expects #x%" PRIx64 " %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, s7_uint 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, s7_uint 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, s7_uint 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, s7_uint 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, s7_uint 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(); + } + if ((role != OPT2_FN) && (has_fn(p))) + { + fprintf(stderr, "%s[%d]: overwrite has_fn: %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, s7_uint 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, (s7_uint)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, s7_uint role) +{ + char *bits = show_debugger_bits(p); + fprintf(stderr, "%s%s[%d]%s: opt3: %s #x%" 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, s7_uint 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, s7_uint 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, s7_uint 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, s7_uint role) +{ + set_opt3_role(p, role); + set_opt3_is_set(p); +} + +static void set_opt3_1(s7_pointer p, s7_pointer x, s7_uint 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, s7_uint 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, s7_uint 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, s7_uint 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 s7_uint 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, (s7_uint)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, s7_uint 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 s7_uint 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, (s7_uint)OPT3_LEN); + if (sc->stop_at_error) abort(); + } + return(p->object.sym_cons.location); +} + +static void set_opt3_len_1(s7_pointer p, s7_uint 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; + const s7_int 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, "%s[%d]: %p: %s\n", __func__, __LINE__, 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) + { + const 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 ", %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 */ + + +/* -------- wrappers -------- */ + +static s7_pointer wrap_mutable_integer(s7_scheme *sc, s7_int x) /* 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[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, p)); + sc->integer_wrapper_allocs++; +#endif + set_integer(p, x); + sc->integer_wrappers = cdr(sc->integer_wrappers); + return(p); +} + +static s7_pointer wrap_integer(s7_scheme *sc, s7_int x) +{ + if (is_small_int(x)) return(small_int(x)); + return(wrap_mutable_integer(sc, x)); +} + +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[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, p)); + sc->real_wrapper_allocs++; +#endif + set_real(p, x); + sc->real_wrappers = cdr(sc->real_wrappers); + return(p); +} + +#if !WITH_GMP +static s7_pointer wrap_complex(s7_scheme *sc, s7_double rl, s7_double im) +{ + s7_pointer p = car(sc->complex_wrappers); +#if S7_DEBUGGING + if ((full_type(p) & (~T_GC_MARK)) != (T_COMPLEX | T_IMMUTABLE | T_UNHEAP | T_MUTABLE)) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, p)); + sc->complex_wrapper_allocs++; +#endif + set_real_part(p, rl); + set_imag_part(p, im); + sc->complex_wrappers = cdr(sc->complex_wrappers); + return(p); +} + +static s7_pointer wrap_real_or_complex(s7_scheme *sc, s7_double rl, s7_double im) +{ + if (im == 0.0) return(wrap_real(sc, rl)); + return(wrap_complex(sc, rl, im)); +} +#else +#define wrap_complex(Sc, A, B) make_complex(Sc, A, B) +#define wrap_real_or_complex(Sc, A, B) make_complex(Sc, A, B) +#endif + +static s7_pointer wrap_let(s7_scheme *sc, s7_pointer old_let) +{ + s7_pointer p = car(sc->let_wrappers); +#if S7_DEBUGGING + if ((full_type(p) & (~T_GC_MARK)) != (T_LET | T_SAFE_PROCEDURE | T_UNHEAP)) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, p)); + sc->let_wrapper_allocs++; +#endif + let_set_id(p, ++sc->let_number); + let_set_slots(p, slot_end); + let_set_outlet(p, old_let); + sc->let_wrappers = cdr(sc->let_wrappers); + return(p); +} + +static s7_pointer wrap_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer value) +{ + s7_pointer p = car(sc->slot_wrappers); +#if S7_DEBUGGING + if ((full_type(p) & (~T_GC_MARK)) != (T_SLOT | T_UNHEAP)) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, p)); + sc->slot_wrapper_allocs++; +#endif + slot_set_symbol_and_value(p, symbol, value); + sc->slot_wrappers = cdr(sc->slot_wrappers); + return(p); +} + +/* -------- prebuilt lists -------- */ +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; + const s7_int slen = safe_strlen(name); + const 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 */ + const bool not_articled = (article == no_article); + switch (typ) + { + case T_BACRO: return((not_articled) ? "bacro" : "a bacro"); + case T_BACRO_STAR: return((not_articled) ? "bacro*" : "a bacro*"); + case T_BIG_COMPLEX: return((not_articled) ? "big-complex-number": "a big complex number"); + case T_BIG_INTEGER: return((not_articled) ? "big-integer" : "a big integer"); + case T_BIG_RATIO: return((not_articled) ? "big-ratio" : "a big ratio"); + case T_BIG_REAL: return((not_articled) ? "big-real" : "a big real"); + case T_BOOLEAN: return("boolean"); + case T_BYTE_VECTOR: return((not_articled) ? "byte-vector" : "a byte-vector"); + case T_CATCH: return((not_articled) ? "catch" : "a catch"); + case T_CHARACTER: return((not_articled) ? "character" : "a character"); + case T_CLOSURE: return((not_articled) ? "function" : "a function"); + case T_CLOSURE_STAR: return((not_articled) ? "function*" : "a function*"); + case T_COMPLEX: return((not_articled) ? "complex-number" : "a complex number"); + case T_COMPLEX_VECTOR: return((not_articled) ? "complex-vector" : "a complex-vector"); + case T_CONTINUATION: return((not_articled) ? "continuation" : "a continuation"); + case T_COUNTER: return((not_articled) ? "internal-counter" : "an internal counter"); + case T_C_FUNCTION: return((not_articled) ? "c-function" : "a c-function"); + case T_C_FUNCTION_STAR: return((not_articled) ? "c-function*" : "a c-function*"); + case T_C_MACRO: return((not_articled) ? "c-macro" : "a c-macro"); + case T_C_OBJECT: return((not_articled) ? "c-object" : "a c_object"); + case T_C_POINTER: return((not_articled) ? "c-pointer" : "a c-pointer"); + case T_C_RST_NO_REQ_FUNCTION: return((not_articled) ? "c-function" : "a c-function"); + case T_DYNAMIC_WIND: return((not_articled) ? "dynamic-wind" : "a dynamic-wind"); + case T_EOF: return((not_articled) ? "#" : "the end-of-file object"); + case T_FLOAT_VECTOR: return((not_articled) ? "float-vector" : "a float-vector"); + case T_FREE: return((not_articled) ? "free-cell" : "a free cell"); + case T_GOTO: return((not_articled) ? "goto" : "a goto (from call-with-exit)"); + case T_HASH_TABLE: return((not_articled) ? "hash-table" : "a hash-table"); + case T_INPUT_PORT: return((not_articled) ? "input-port" : "an input port"); + case T_INTEGER: return((not_articled) ? "integer" : "an integer"); + case T_INT_VECTOR: return((not_articled) ? "int-vector" : "an int-vector"); + case T_ITERATOR: return((not_articled) ? "iterator" : "an iterator"); + case T_LET: return((not_articled) ? "let" : "a let"); + case T_MACRO: return((not_articled) ? "macro" : "a macro"); + case T_MACRO_STAR: return((not_articled) ? "macro*" : "a macro*"); + case T_NIL: return("nil"); + case T_OUTPUT_PORT: return((not_articled) ? "output-port" : "an output port"); + case T_PAIR: return((not_articled) ? "pair" : "a pair"); + case T_RANDOM_STATE: return((not_articled) ? "random-state" : "a random-state"); + case T_RATIO: return((not_articled) ? "ratio" : "a ratio"); + case T_REAL: return((not_articled) ? "real" : "a real"); + case T_SLOT: return((not_articled) ? "slot" : "a slot (variable binding)"); + case T_STACK: return((not_articled) ? "stack" : "a stack"); + case T_STRING: return((not_articled) ? "string" : "a string"); + case T_SYMBOL: return((not_articled) ? "symbol" : "a symbol"); + case T_SYNTAX: return((not_articled) ? "syntax" : "syntactic"); + case T_UNDEFINED: return((not_articled) ? "undefined" : "an undefined object"); + case T_UNSPECIFIED: return((not_articled) ? "#" : "the unspecified object"); + case T_UNUSED: return((not_articled) ? "#" : "the unused object"); + case T_VECTOR: return((not_articled) ? "vector" : "a vector"); + } + return(NULL); +} + +static s7_pointer find_let(s7_scheme *sc, s7_pointer obj) +{ + if ((S7_DEBUGGING) && (is_let(obj))) {fprintf(stderr, "let passed to find_let: %s\n", display(obj)); if (sc->stop_at_error) abort();} + if (has_closure_let(obj)) return(closure_let(obj)); /* some of these are immutable -- they hold the parameter names */ + switch (type(obj)) + { + case T_C_OBJECT: + if (is_let(c_object_let(obj))) return(c_object_let(obj)); + return(sc->rootlet); + case T_C_POINTER: + if (is_let(c_pointer_info(obj))) return(c_pointer_info(obj)); + return(sc->rootlet); + case T_C_MACRO: case T_C_FUNCTION_STAR: case T_C_FUNCTION: case T_C_RST_NO_REQ_FUNCTION: + return(c_function_let(obj)); + } + return(sc->nil); +} + +s7_pointer s7_function_let(s7_scheme *sc, s7_pointer obj) {return(c_function_let(obj));} + +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 (is_global(symbol)) /* this means the symbol has never been bound 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) +{ + if (!is_let(let)) let = find_let(sc, let); + return(find_method(sc, let, symbol)); +} + +static s7_pointer find_method_with_c_object(s7_scheme *sc, s7_pointer c_obj, s7_pointer symbol) +{ + s7_pointer let = c_object_let(c_obj); + return(find_method(sc, (is_let(let)) ? let : sc->rootlet, 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 obj) /* used only by the error handlers */ +{ + uint8_t typ; + if (has_active_methods(sc, obj)) + { + s7_pointer func = find_method_with_let(sc, obj, sc->class_name_symbol); + if (func != sc->undefined) + return(s7_apply_function(sc, func, set_plist_1(sc, obj))); + if (is_symbol(func)) + return(symbol_name_cell(func)); + } + typ = type(obj); + if (typ < NUM_TYPES) + { + if (typ == T_C_OBJECT) return(c_object_scheme_name(sc, obj)); + 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 no_return 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 */ no_return 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 no_return 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 no_return 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 no_return 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 no_return 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 no_return 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 no_return 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 no_return 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 no_return 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 if_method_exists_return_value(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)); \ + } + +#define if_let_method_exists_return_value(Sc, Let, Method, Args) \ + { \ + s7_pointer _Func_; \ + if ((has_active_methods(Sc, T_Let(Let))) && \ + ((_Func_ = find_method(Sc, Let, Method)) != Sc->undefined)) \ + return(s7_apply_function(Sc, _Func_, Args)); \ + } + +#define if_c_object_method_exists_return_value(Sc, C_Obj, Method, Args) \ + { \ + s7_pointer _Func_; \ + if ((has_active_methods(Sc, T_Obj(C_Obj))) && \ + ((_Func_ = find_method_with_c_object(Sc, C_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); /* perhaps find_and_apply_c_object_method for g_c_object_let */ + 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__); if (sc->stop_at_error) abort();} + 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 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); +} + + +/* # and # */ +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 # 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 #" + #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; /* # 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, #. It is the same as (eq? val #)" + #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 obj) {return(obj != sc->F);} +s7_pointer s7_make_boolean(s7_scheme *sc, bool obj) {return(make_boolean(sc, obj));} + +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? -------------------------------- */ + +static no_return void find_let_error_nr(s7_scheme *sc, s7_pointer caller, s7_pointer let, s7_pointer new_let, s7_int arg_num, s7_pointer args) +{ + if (new_let == sc->rootlet) + { + if ((arg_num > 1) || (is_pair(cdr(args)))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_5(sc, wrap_string(sc, "(~A~{~^ ~$~}) ~:D argument is ~A, but it does not have its own let", 66), + caller, args, wrap_integer(sc, arg_num), object_type_name(sc, let))); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "(~A~{~^ ~$~}) argument is ~A, but it does not have its own let", 62), + caller, args, object_type_name(sc, let))); + } + wrong_type_error_nr(sc, caller, arg_num, s7_list_ref(sc, args, arg_num - 1), wrap_string(sc, "a let or an object that has its own let", 39)); +} + +bool s7_is_immutable(s7_pointer p) {return(is_immutable(p));} +#define has_let_signature(sc) s7_make_signature(sc, 5, sc->is_let_symbol, sc->is_c_object_symbol, sc->is_c_pointer_symbol, sc->is_procedure_symbol, sc->is_macro_symbol) + +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, has_let_signature(sc)) + const s7_pointer obj = car(args); + if (is_symbol(obj)) + { + s7_pointer slot; + if (is_keyword(obj)) return(sc->T); + if (is_pair(cdr(args))) + { + s7_pointer env = cadr(args); + if (!is_let(env)) + { + s7_pointer new_let = find_let(sc, env); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->is_immutable_symbol, env, new_let, 2, args); + env = new_let; + } + if (env == sc->rootlet) + slot = global_slot(obj); + else slot = lookup_slot_from((is_keyword(obj)) ? keyword_symbol(obj) : obj, env); + } + else slot = s7_slot(sc, obj); + if (is_slot(slot)) /* might be # */ + 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(obj)) || (t_immutable_p[type(obj)]) || ((is_any_vector(obj)) && (vector_length(obj) == 0)))); +} + + +/* -------------------------------- immutable! -------------------------------- */ +s7_pointer s7_set_immutable(s7_scheme *sc, s7_pointer p) +{ + if (is_symbol(p)) /* trying to mimic g_immutable */ + { + s7_pointer slot; + if (is_keyword(p)) return(p); + slot = s7_slot(sc, p); + if (is_slot(slot)) + set_immutable_slot(slot); + /* symbol is not set immutable (as below) */ + } + else set_immutable(p); + return(p); +} + +#if (!DISABLE_DEPRECATED) && (S7_DEBUGGING || DISABLE_FILE_OUTPUT || POINTER_32) + s7_pointer s7_immutable(s7_pointer p) {return(s7_set_immutable(cur_sc, p));} +#endif + +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, has_let_signature(sc)) + const s7_pointer obj = car(args); + if (is_symbol(obj)) + { + s7_pointer slot; + if (is_pair(cdr(args))) + { + s7_pointer env = cadr(args); + if ((!is_let(env)) || (env == sc->rootlet)) + { + s7_pointer new_let = find_let(sc, env); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->immutable_symbol, env, new_let, 2, args); + env = new_let; + } + slot = symbol_to_local_slot(sc, (is_keyword(obj)) ? keyword_symbol(obj) : obj, env); /* different from immutable? */ + } + else + { + if (is_keyword(obj)) return(obj); + slot = s7_slot(sc, obj); + } + if (is_slot(slot)) + set_immutable_slot(slot); + return(obj); /* 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); + set_immutable(obj); /* 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(obj); +} + +/* 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) +{ + const s7_int size = sc->protected_objects_size; + block_t *ob = vector_block(sc->protected_objects); + const 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->unused; + sc->protected_objects_free_list[++sc->protected_objects_free_list_loc] = loc; /* added 13-Feb-25 */ + 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 iter) +{ + if (is_weak_hash_iterator(iter)) + { + s7_pointer seq = iterator_sequence(iter); + clear_weak_hash_iterator(iter); + if (unchecked_type(seq) == T_HASH_TABLE) + weak_hash_iters(seq)--; + } +} + +static void process_multivector(s7_scheme *sc, s7_pointer vect) +{ + vdims_t *info = vector_dimension_info(vect); /* 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(vect)); + vector_elements_should_be_freed(info) = false; + } + liberate(sc, info); + vector_set_dimension_info(vect, NULL); + } + liberate(sc, vector_block(vect)); +} + +static void process_input_string_port(s7_scheme *sc, s7_pointer port) +{ +#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(port)) + fprintf(stderr, "%s[%d]: string input port has a filename: %s\n", __func__, __LINE__, port_filename(port)); + if (port_needs_free(port)) + fprintf(stderr, "%s[%d]: string input port needs data release\n", __func__, __LINE__); +#endif + liberate(sc, port_block(port)); +} + +static void free_port_data(s7_scheme *sc, s7_pointer port) +{ + if (port_data(port)) + { + liberate(sc, port_data_block(port)); + port_data_block(port) = NULL; + port_data(port) = NULL; + port_data_size(port) = 0; + } + port_needs_free(port) = false; +} + +static void close_input_function_port(s7_scheme *sc, s7_pointer port); +static void close_output_port(s7_scheme *sc, s7_pointer port); + +static void process_input_port(s7_scheme *sc, s7_pointer port) +{ + if (!port_is_closed(port)) + { + if (is_file_port(port)) + { + if (port_file(port)) + { + fclose(port_file(port)); + port_file(port) = NULL; + }} + else + if (is_function_port(port)) + close_input_function_port(sc, port); + } + if (port_needs_free(port)) + free_port_data(sc, port); + + if (port_filename(port)) + { + liberate(sc, port_filename_block(port)); + port_filename(port) = NULL; + } + liberate(sc, port_block(port)); +} + +static void process_output_port(s7_scheme *sc, s7_pointer port) +{ + close_output_port(sc, port); /* needed for free filename, etc */ + liberate(sc, port_block(port)); + if (port_needs_free(port)) + { + port_needs_free(port) = false; + if (port_data_block(port)) + { + liberate(sc, port_data_block(port)); + port_data_block(port) = NULL; + }} +} + +static void process_continuation(s7_scheme *sc, s7_pointer cc) +{ + continuation_op_stack(cc) = NULL; + liberate_block(sc, continuation_block(cc)); /* 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 z; + int32_t result; + mpq_init(z); + mpq_set_z(z, op2); + result = mpq_cmp(op1, z); + mpq_clear(z); + 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; /* may access s1 internally */ \ + } \ + else if (in_heap(s1)) 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(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))); + + 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 void add_to_gc_list(s7_scheme *sc, gc_list_t *gp, s7_pointer p) +{ +#if S7_DEBUGGING + if ((!in_heap(p)) && (gp != sc->opt1_funcs)) + { + char *str = describe_type_bits(sc, p); + fprintf(stderr, "%s[%d]: %s not in heap, %s\n", __func__, __LINE__, display(p), str); + free(str); + if (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, sc->gensyms, p); + mark_function[T_SYMBOL] = just_mark; +} + +#define add_c_object(sc, p) add_to_gc_list(sc, sc->c_objects, p) +#define add_hash_table(sc, p) add_to_gc_list(sc, sc->hash_tables, p) +#define add_string(sc, p) add_to_gc_list(sc, sc->strings, p) +#define add_input_port(sc, p) add_to_gc_list(sc, sc->input_ports, p) +#define add_input_string_port(sc, p) add_to_gc_list(sc, sc->input_string_ports, p) +#define add_output_port(sc, p) add_to_gc_list(sc, sc->output_ports, p) +#define add_continuation(sc, p) add_to_gc_list(sc, sc->continuations, p) +#define add_undefined(sc, p) add_to_gc_list(sc, sc->undefineds, p) +#define add_vector(sc, p) add_to_gc_list(sc, sc->vectors, p) +#define add_multivector(sc, p) add_to_gc_list(sc, sc->multivectors, p) +#define add_weak_ref(sc, p) add_to_gc_list(sc, sc->weak_refs, p) +#define add_weak_hash_iterator(sc, p) add_to_gc_list(sc, sc->weak_hash_iterators, p) +#define add_opt1_func(sc, p) do {if (!opt1_func_listed(p)) add_to_gc_list(sc, sc->opt1_funcs, p); set_opt1_func_listed(p);} while (0) /* called by set_opt1_lambda_add */ + +#if WITH_GMP +#define add_big_integer(sc, p) add_to_gc_list(sc, sc->big_integers, p) +#define add_big_ratio(sc, p) add_to_gc_list(sc, sc->big_ratios, p) +#define add_big_real(sc, p) add_to_gc_list(sc, sc->big_reals, p) +#define add_big_complex(sc, p) add_to_gc_list(sc, sc->big_complexes, p) +#define add_big_random_state(sc, p) add_to_gc_list(sc, 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, s7_uint 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, T_Clo(setter)); /* T_Clo else no GC protection needed */ + 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, T_Prc(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 vect, s7_int unused_len) {set_mark(vect);} + +static void mark_vector_1(s7_pointer vect, s7_int top) +{ + s7_pointer *tp = (s7_pointer *)(vector_elements(vect)); + s7_pointer *tend, *tend4; + set_mark(vect); + 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 vect, s7_int top) /* for typed vectors with closure setters */ +{ + gc_mark(typed_vector_typer(vect)); + mark_vector_1(vect, top); +} + +static inline void mark_slot(s7_pointer slot) +{ + set_mark(T_Slt(slot)); + gc_mark(slot_value(slot)); + if (slot_has_setter_or_pending_value(slot)) + gc_mark(slot_pending_value_unchecked(slot)); /* setter field == pending_value */ + set_mark(slot_symbol(slot)); +} + +static void mark_let(s7_pointer let) +{ + for (s7_pointer e = let; (e) && (!is_marked(e)); e = let_outlet(e)) + { + set_mark(e); + if (has_dox_slot1(e)) mark_slot(let_dox_slot1(e)); + if ((has_dox_slot2(e)) && (is_slot(let_dox_slot2(e)))) mark_slot(let_dox_slot2(e)); + /* 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 slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (!is_marked(slot)) /* slot value might be the enclosing let */ + mark_slot(slot); + } +} + +static void mark_wrappers(s7_scheme *sc) +{ + s7_pointer p = sc->let_wrappers; + s7_pointer end_p = p; + do { + for (s7_pointer slot = let_slots(car(p)); tis_slot(slot); slot = next_slot(slot)) + if (!is_marked(slot)) mark_slot(slot); + p = cdr(p); + } while (p != end_p); + + /* dox1|2? gensyms? maybe don't wrap gensym-slot */ +} + +static void unmark_wrappers(s7_scheme *sc) +{ + s7_pointer p = sc->let_wrappers; + s7_pointer end_p = p; + do { + for (s7_pointer slot = let_slots(car(p)); tis_slot(slot); slot = next_slot(slot)) clear_mark(slot); + p = cdr(p); + } while (p != end_p); +} + +#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 cp) +{ + set_mark(cp); + gc_mark(c_pointer_type(cp)); + gc_mark(c_pointer_info(cp)); +} + +static void mark_c_proc_star(s7_pointer proc) +{ + set_mark(proc); + if ((!c_func_has_simple_defaults(proc)) && + (c_function_call_args(proc))) /* NULL if not a safe function */ + for (s7_pointer arg = c_function_call_args(proc); 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 clo) +{ + set_mark(clo); + gc_mark(closure_pars(clo)); + gc_mark(closure_body(clo)); + mark_let(closure_let(clo)); + /* because we can't tell if a closure is live, we can't clear closure_let slot_values that are not currently in play (all gc roots are live!) */ + gc_mark(closure_setter_or_map_list(clo)); +} + +static void mark_stack_1(s7_pointer stack, s7_int top) +{ + s7_pointer *tp = (s7_pointer *)(stack_elements(stack)), *tend; + set_mark(stack); + 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 stack) +{ + /* 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(stack, temp_stack_top(stack)); +} + +static void mark_continuation(s7_pointer cc) +{ + set_mark(cc); + if (!is_marked(continuation_stack(cc))) /* can these be cyclic? */ + mark_stack_1(continuation_stack(cc), continuation_stack_top(cc)); + gc_mark(continuation_op_stack(cc)); +} + +static void mark_vector(s7_pointer vect) +{ + if (is_typed_vector(vect)) + typed_vector_gc_mark(vect)(vect, vector_length(vect)); + else mark_vector_1(vect, vector_length(vect)); +} + +static void mark_vector_possibly_shared(s7_pointer vect) +{ + /* 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(vect)) + mark_vector_possibly_shared(subvector_vector(vect)); + + /* 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(vect)) + mark_vector_1(vect, vector_length(vect)); +} + +static void mark_int_or_float_vector(s7_pointer vect) {set_mark(vect);} + +static void mark_int_or_float_vector_possibly_shared(s7_pointer vect) /* also complex_vector */ +{ + if (is_subvector(vect)) + mark_int_or_float_vector_possibly_shared(subvector_vector(vect)); + set_mark(vect); +} + +static void mark_c_object(s7_pointer cobj) +{ + set_mark(cobj); + mark_let(c_object_let(cobj)); /* I think this is guaranteed to be a let, added 5-Apr-25 */ + if (c_object_gc_mark(c_object_sc(cobj), cobj)) /* c_object_sc = s7_scheme pointer */ + (*(c_object_gc_mark(c_object_sc(cobj), cobj)))(c_object_sc(cobj), cobj); + else (*(c_object_mark(c_object_sc(cobj), cobj)))(c_object_value(cobj)); +} + +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 dw) +{ + set_mark(dw); + gc_mark(dynamic_wind_in(dw)); + gc_mark(dynamic_wind_out(dw)); + gc_mark(dynamic_wind_body(dw)); +} + +static void mark_hash_table(s7_pointer table) +{ + set_mark(table); + gc_mark(hash_table_procedures(table)); + if (is_pair(hash_table_procedures(table))) + { + gc_mark(hash_table_key_typer_unchecked(table)); /* unchecked to avoid s7-debugger's reference to sc */ + gc_mark(hash_table_value_typer_unchecked(table)); + } + if (hash_table_entries(table) > 0) + { + const s7_int len = (s7_int)hash_table_size(table); + hash_entry_t **entries = hash_table_elements(table); + hash_entry_t **last = (hash_entry_t **)(entries + len); + + if ((is_weak_hash_table(table)) && + (weak_hash_iters(table) == 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 iter) +{ + set_mark(iter); + gc_mark(iterator_sequence(iter)); + if (has_carrier(iter)) + { + if (iterator_carrier(iter)) + gc_mark(iterator_carrier(iter)); +#if S7_DEBUGGING + else fprintf(stderr, "mark_iterator[%d]: has_carrier set (at line %d), but no carrier!\n", __LINE__, iter->carrier_line); +#endif + } +} + +static void mark_input_port(s7_pointer port) +{ + set_mark(port); + gc_mark(port_string_or_function(port)); +} + +static void mark_output_port(s7_pointer port) +{ + set_mark(port); + if (is_function_port(port)) + gc_mark(port_string_or_function(port)); +} + +static void mark_free(s7_pointer p) {} /* this can happen in make_room_for_cc_stack */ + +static void init_mark_functions(void) +{ + mark_function[T_BACRO] = mark_closure; + mark_function[T_BACRO_STAR] = mark_closure; + mark_function[T_BIG_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_BOOLEAN] = mark_noop; + mark_function[T_BYTE_VECTOR] = just_mark; + mark_function[T_CATCH] = mark_catch; + mark_function[T_CHARACTER] = mark_noop; + mark_function[T_CLOSURE] = mark_closure; + mark_function[T_CLOSURE_STAR] = mark_closure; + mark_function[T_COMPLEX] = just_mark; + mark_function[T_COMPLEX_VECTOR] = mark_int_or_float_vector; + mark_function[T_CONTINUATION] = mark_continuation; + mark_function[T_COUNTER] = mark_counter; + 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_MACRO] = just_mark; + mark_function[T_C_OBJECT] = mark_c_object; + mark_function[T_C_POINTER] = mark_c_pointer; + mark_function[T_C_RST_NO_REQ_FUNCTION] = just_mark; + mark_function[T_DYNAMIC_WIND] = mark_dynamic_wind; + mark_function[T_EOF] = mark_noop; + mark_function[T_FLOAT_VECTOR] = mark_int_or_float_vector; + mark_function[T_FREE] = mark_free; + mark_function[T_GOTO] = just_mark; + mark_function[T_HASH_TABLE] = mark_hash_table; + mark_function[T_INPUT_PORT] = mark_input_port; + mark_function[T_INTEGER] = just_mark; + mark_function[T_INT_VECTOR] = mark_int_or_float_vector; + mark_function[T_ITERATOR] = mark_iterator; + mark_function[T_LET] = mark_let; + mark_function[T_MACRO] = mark_closure; + mark_function[T_MACRO_STAR] = mark_closure; + mark_function[T_NIL] = mark_noop; + mark_function[T_OUTPUT_PORT] = just_mark; /* changed to mark_output_port if output function ports are active */ + mark_function[T_PAIR] = mark_pair; + mark_function[T_RANDOM_STATE] = just_mark; + mark_function[T_RATIO] = just_mark; + mark_function[T_REAL] = just_mark; + mark_function[T_SLOT] = mark_slot; + mark_function[T_STACK] = mark_stack; + mark_function[T_STRING] = just_mark; + mark_function[T_SYMBOL] = mark_noop; /* this changes to just_mark when gensyms are in the heap */ + mark_function[T_SYNTAX] = mark_noop; + mark_function[T_UNDEFINED] = just_mark; + mark_function[T_UNSPECIFIED] = mark_noop; + mark_function[T_UNUSED] = mark_noop; + mark_function[T_VECTOR] = mark_vector; /* this changes if subvector created (similarly below) */ +} + +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 slot = sc->rootlet_slots; tis_slot(slot); slot = next_slot(slot)) + gc_mark(slot_value(slot)); /* 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 + #include +#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 s7_int gc(s7_scheme *sc, const char *func, int32_t line) +#else +static s7_int gc(s7_scheme *sc) +#endif +{ + s7_cell **old_free_heap_top; + + 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->gc_true_calls++; + + 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();} + 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 */ + gc_mark(sc->temp_error_hook); + + gc_mark(sc->v); + 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); + just_mark(sc->read_dims); + + 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 (s7_int 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])) && + (safe_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 (s7_int i = 0; i < sc->setters_loc; i++) + gc_mark(cdr(sc->setters[i])); + + for (s7_int 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 (s7_int 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); + gc_mark(sc->symbol_printer); + + /* 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); + mark_wrappers(sc); + + if (sc->profiling_gensyms) + { + profile_data_t *pd = sc->profile_data; + for (s7_int 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 (s7_int 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, using !=0 is about the same as <0 + * 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); + unmark_wrappers(sc); + + sc->gc_freed = (s7_int)(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); + sc->gc_true_total_time += (sc->gc_end - sc->gc_start); + + if (show_gc_stats(sc)) + { +#if !MS_WINDOWS + 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()); +#else + s7_warn(sc, 256, "gc freed %" ld64 "/%" ld64 "\n", sc->gc_freed, sc->heap_size); +#endif + } + if (show_protected_objects_stats(sc)) + s7_warn(sc, 256, "gc-protected-objects: %" ld64 " in use of %" ld64 "\n", + sc->protected_objects_size - 1 - sc->protected_objects_free_list_loc, + sc->protected_objects_size); + 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, s7_int size, const char *func, int line) +#else +static void resize_heap_to(s7_scheme *sc, s7_int size) +#endif +{ + const s7_int old_size = sc->heap_size; + const s7_int old_free = sc->free_heap_top - sc->free_heap; + +#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, (s7_int)(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 ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) + fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size); + 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; + if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) + fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size); + } + if (sc->heap_size >= sc->max_heap_size) + { + const s7_int new_heap_size = 32 * (s7_int)floor(sc->max_heap_size / 32.0); + if (new_heap_size > old_size) + { + s7_warn(sc, 256, "heap size requested is greater than (*s7* 'max-heap-size); trying %" ld64 "\n", new_heap_size); + sc->heap_size = new_heap_size; + if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) + fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size); + } + else + { + const s7_int new_size = sc->heap_size; + sc->heap_size = old_size; /* needed if user catches this error and (for example) runs (*s7* 'memory-usage) in the error handler */ + 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, new_size), + wrap_integer(sc, sc->max_heap_size))); + 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; + if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) + fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size); + } +#endif + { + s7_cell **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", + (s7_int)(sc->heap_size * sizeof(s7_cell *))); + sc->heap_size = old_size + 64000; + if ((S7_DEBUGGING) && (sc->heap_size >= sc->max_heap_size)) + fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size); + 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?!? */ + + { + s7_cell *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 (s7_int 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++); + }} + { + heap_block_t *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); + } +} + +#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 */ + { +#if S7_DEBUGGING + fprintf(stderr, "%s[%d]: forced resize from %s[%d]\n", __func__, __LINE__, func, line); +#endif + 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! */ + /* describe_gc_strings(sc); */ +#else + gc(sc); +#endif + if ((s7_int)(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) + + 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_pair(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, s7_int 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; +} + +static inline s7_pointer petrify(s7_scheme *sc, s7_pointer x) +{ + const s7_int loc = heap_location(sc, x); + const s7_pointer p = (s7_pointer)alloc_big_pointer(sc, loc); + sc->heap[loc] = p; + (*(sc->free_heap_top++)) = 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 +{ + const s7_int loc = heap_location(sc, x); + sc->heap[loc] = (s7_pointer)alloc_big_pointer(sc, loc); + (*(sc->free_heap_top++)) = 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 byte|int|float|complex_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) +{ + const uint32_t new_size = sc->op_stack_size * 2; + const uint32_t loc = (uint32_t)(sc->op_stack_now - sc->op_stack); + if (new_size > sc->max_stack_size) +#if S7_DEBUGGING + { + fprintf(stderr, "%s%s[%d]: op stack will be too big after resize, %u > %u%s\n", bold_text, __func__, __LINE__, new_size, sc->max_stack_size, unbold_text); + if (sc->stop_at_error) abort(); + } +#else + error_nr(sc, make_symbol(sc, "stack-too-big", 13), + set_elist_3(sc, wrap_string(sc, "op stack has grown past (*s7* 'max-stack-size): ~D > ~D", 55), + wrap_integer(sc, (s7_int)new_size), + wrap_integer(sc, (s7_int)sc->max_stack_size))); +#endif + sc->op_stack = (s7_pointer *)Realloc((void *)(sc->op_stack), new_size * sizeof(s7_pointer)); + for (uint32_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) +{ + /* if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: pop_stack %s\n", func, line, op_names[(opcode_t)stack_top_op(sc)]); */ + 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) +{ + /* if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: pop_stack_no_op %s\n", func, line, op_names[(opcode_t)stack_top_op(sc)]); */ + 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 (S7_DEBUGGING) fprintf(stderr, "%s[%d]: %u push_stack %s\n", func, line, (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start)), op_names[op]); */ + 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%s\n", + bold_text, func, line, op_names[op], + (uint32_t)((intptr_t)(sc->stack_end - sc->stack_start)), + sc->stack_size, display_truncated(code), unbold_text); + s7_show_stack(sc); + } + 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) && (!is_free(args))) 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) do {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) +{ + const s7_uint loc = stack_top(sc); + const 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; + stack_elements(sc->stack) = (s7_pointer *)block_data(nb); + { + s7_pointer *orig = stack_elements(sc->stack); + s7_int i = sc->stack_size; + const 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 op_loc = stack_top(sc) - 1, j = 0; (op_loc >= 3) && (j < sc->max_show_stack_frames); op_loc -= 4, j++) /* s7_int (or s7_uint?) is correct -- not uint32_t */ + fprintf(stderr, " %s\n", op_names[stack_op(sc->stack, op_loc)]); +} + +#if S7_DEBUGGING +void s7_show_full_stack(s7_scheme *sc); +void s7_show_full_stack(s7_scheme *sc) +{ + const bool old_stop = sc->stop_at_error; + if (sc->stack_end >= sc->stack_resize_trigger) + resize_stack_unchecked(sc); + sc->stop_at_error = false; + fprintf(stderr, "stack:\n"); + for (s7_int op_loc = stack_top(sc) - 1, j = 0; (op_loc >= 3) && (j < sc->max_show_stack_frames); op_loc -= 4, j++) + { + fprintf(stderr, " %s: ", op_names[stack_op(sc->stack, op_loc)]); + if (s7_is_valid(sc, stack_code(sc->stack, op_loc))) + fprintf(stderr, "code: %s, ", display_truncated(stack_code(sc->stack, op_loc))); + if (s7_is_valid(sc, stack_args(sc->stack, op_loc))) + fprintf(stderr, "args: %s, ", display_truncated(stack_args(sc->stack, op_loc))); + if ((stack_op(sc->stack, op_loc) != OP_GC_PROTECT) && (s7_is_valid(sc, stack_let(sc->stack, op_loc)))) /* this probably won't work */ + fprintf(stderr, "let: %s", display_truncated(stack_let(sc->stack, op_loc))); + fprintf(stderr, "\n"); + } + sc->stop_at_error = old_stop; +} + +#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) +{ + const 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_3(sc, wrap_string(sc, "stack has grown past (*s7* 'max-stack-size): ~D > ~D", 52), + wrap_integer(sc, new_size), + wrap_integer(sc, sc->max_stack_size))); + /* 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); +} + +#if S7_DEBUGGING + static s7_pointer stack_protected1_1(s7_scheme *sc, opcode_t op, const char *func, int line) + { + if (stack_top_op(sc) != op) + { + fprintf(stderr, "%s[%d]: stack_protected1 %s\n", func, line, op_names[stack_top_op(sc)]); + if (sc->stop_at_error) abort(); + } + return(stack_top_args(sc)); + } + + static s7_pointer stack_protected2_1(s7_scheme *sc, opcode_t op, const char *func, int line) + { + if (stack_top_op(sc) != op) + { + fprintf(stderr, "%s[%d]: stack_protected2 %s\n", func, line, op_names[stack_top_op(sc)]); + if (sc->stop_at_error) abort(); + } + return(stack_top_code(sc)); + } + + static s7_pointer stack_protected3_1(s7_scheme *sc, opcode_t op, const char *func, int line) + { + if (stack_top_op(sc) != op) + { + fprintf(stderr, "%s[%d]: stack_protected3 %s\n", func, line, op_names[stack_top_op(sc)]); + if (sc->stop_at_error) abort(); + } + return(stack_top_let(sc)); + } + + #define stack_protected1(Sc, Op) stack_protected1_1(Sc, Op, __func__, __LINE__) + #define stack_protected2(Sc, Op) stack_protected2_1(Sc, Op, __func__, __LINE__) + #define stack_protected3(Sc, Op) stack_protected3_1(Sc, Op, __func__, __LINE__) + + #define set_stack_protected1(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: set_stack_protected1 %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_top_args(Sc) = Val;} while (0) + #define set_stack_protected2(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: set_stack_protected2 %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_top_code(Sc) = Val;} while (0) + #define set_stack_protected3(Sc, Val, Op) do {if (stack_top_op(Sc) != Op) fprintf(stderr, "%s[%d]: set_stack_protected3 %s\n", __func__, __LINE__, op_names[stack_top_op(Sc)]); stack_top_let(Sc) = Val;} while (0) + +#else + + #define stack_protected1(Sc, Op) stack_top_args(Sc) + #define stack_protected2(Sc, Op) stack_top_code(Sc) + #define stack_protected3(Sc, Op) stack_top_let(Sc) + + #define set_stack_protected1(Sc, Val, Op) stack_top_args(Sc) = Val + #define set_stack_protected2(Sc, Val, Op) stack_top_code(Sc) = Val + #define set_stack_protected3(Sc, Val, Op) stack_top_let(Sc) = Val +#endif + +#define gc_protected1(Sc) stack_protected1(Sc, OP_GC_PROTECT) +#define gc_protected2(Sc) stack_protected2(Sc, OP_GC_PROTECT) +#define gc_protected3(Sc) stack_protected3(Sc, OP_GC_PROTECT) + +#define set_gc_protected1(Sc, Val) set_stack_protected1(Sc, Val, OP_GC_PROTECT) +#define set_gc_protected2(Sc, Val) set_stack_protected2(Sc, Val, OP_GC_PROTECT) +#define set_gc_protected3(Sc, Val) set_stack_protected3(Sc, Val, OP_GC_PROTECT) + +#define map_unwind_list(Sc) stack_protected3(Sc, OP_MAP_UNWIND) +#define set_map_unwind_list(Sc, Val) set_stack_protected3(Sc, Val, OP_MAP_UNWIND) + +#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_gc_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_gc_protected2(Sc, Y);} while (0) + + +/* -------------------------------- symbols -------------------------------- */ +static inline s7_uint raw_string_hash(const uint8_t *key, s7_int len) /* used in symbols, hash-tables */ +{ + if (len <= 8) + { + s7_uint xs[1] = {0}; + memcpy((void *)xs, (const void *)key, len); + return(xs[0]); + } + else + { +#if 0 + s7_uint xs[2] = {0, 0}; + memcpy((void *)xs, (const void *)key, (len > 16) ? 16 : len); + return(xs[0] + xs[1]); +#else + /* this seems to be slightly faster. Using start and end portions is worse. */ + if (len <= 16) + { + s7_uint xs[2] = {0, 0}; + memcpy((void *)xs, (const void *)key, len); + return(xs[0] + xs[1]); + } + else + { + s7_uint xs[3] = {0, 0, 0}; + memcpy((void *)xs, (const void *)key, (len > 24) ? 24 : len); + return(xs[0] + xs[1] + xs[2]); + } +#endif + } +} + +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, s7_uint 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); + const s7_pointer new_sym = (s7_pointer)base; + const s7_pointer str = (s7_pointer)(base + sizeof(s7_cell)); + const 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(new_sym) = T_SYMBOL | T_UNHEAP; + symbol_set_name_cell(new_sym, str); + set_global_slot(new_sym, sc->undefined); /* was sc->nil */ + symbol_info(new_sym) = (block_t *)(base + 3 * sizeof(s7_cell)); + set_initial_value(new_sym, sc->undefined); + symbol_set_local_slot_unchecked_and_unincremented(new_sym, 0LL, sc->undefined); + set_big_symbol_tag(new_sym, 0); + set_small_symbol_tag(new_sym, 0); + symbol_set_shadows(new_sym, 0); + symbol_clear_ctr(new_sym); /* alloc_symbol uses malloc */ + symbol_clear_type(new_sym); + + 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(new_sym, T_IMMUTABLE | T_KEYWORD); + set_optimize_op(str, OP_CONSTANT); + ksym = make_symbol(sc, (name[0] == ':') ? (const char *)(name + 1) : name, len - 1); + keyword_set_symbol(new_sym, 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, new_sym, new_sym); + set_global_slot(new_sym, slot); + set_local_slot(new_sym, slot); + set_immutable_slot(slot); + /* we need to include this keyword in the symbol-table */ + } + full_type(p) = T_PAIR | T_IMMUTABLE | T_UNHEAP; /* add x to the symbol table */ + set_car(p, new_sym); + 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, (s7_uint)len); /* symbol name length, so it ought to fit! */ + pair_set_raw_name(p, string_value(str)); + return(new_sym); +} + +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 or aligned */ + const s7_uint hash = raw_string_hash((const uint8_t *)name, len); + const uint32_t location = hash % SYMBOL_TABLE_SIZE; + + if (len <= 8) + { + for (s7_pointer syms = vector_element(sc->symbol_table, location); is_pair(syms); syms = cdr(syms)) + if ((hash == pair_raw_hash(syms)) && + ((s7_uint)len == pair_raw_len(syms))) + return(car(syms)); + } + else /* checking name[len=='\0' and using strcmp if so was not a big win */ + for (s7_pointer syms = vector_element(sc->symbol_table, location); is_pair(syms); syms = cdr(syms)) + if ((hash == pair_raw_hash(syms)) && + ((s7_uint)len == pair_raw_len(syms)) && + (strings_are_equal_with_length(name, pair_raw_name(syms), len))) /* length here because name might not be null-terminated or aligned */ + return(car(syms)); + 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, s7_uint hash, uint32_t location, s7_int len) +{ + for (s7_pointer syms = vector_element(sc->symbol_table, location); is_pair(syms); syms = cdr(syms)) + if ((hash == pair_raw_hash(syms)) && + (strings_are_equal_with_length(name, pair_raw_name(syms), len))) + return(car(syms)); + return(sc->nil); +} + +s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name) +{ + s7_int len = safe_strlen(name); + s7_uint 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) + + int32_t syms = 0; + s7_pointer *entries = vector_elements(sc->symbol_table); + + /* 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. + * 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 symlist = entries[i]; is_pair(symlist); symlist = cdr(symlist)) + 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))); + { + const s7_pointer vec = make_simple_vector(sc, syms); + s7_pointer *els = vector_elements(vec); + set_is_symbol_table(vec); + for (int32_t i = 0, j = 0; i < SYMBOL_TABLE_SIZE; i++) + for (s7_pointer symlist = entries[i]; is_pair(symlist); symlist = cdr(symlist)) + els[j++] = car(symlist); + 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 # and so on for simplicity -- are there any others? */ + for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) + for (s7_pointer syms = vector_element(sc->symbol_table, i); is_pair(syms); syms = cdr(syms)) + if (symbol_func(symbol_name(car(syms)), data)) + return(true); + return((symbol_func("#t", data)) || (symbol_func("#f", data)) || + (symbol_func("#", data)) || (symbol_func("#", data)) || + (symbol_func("#", 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 syms = vector_element(sc->symbol_table, i); is_pair(syms); syms = cdr(syms)) + if (symbol_func(symbol_name(car(syms)), 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 */ + const uint32_t location = string_hash(symbol_name_cell(sym)) % SYMBOL_TABLE_SIZE; + s7_pointer symbols = vector_element(sc->symbol_table, location); + if (car(symbols) == sym) + vector_element(sc->symbol_table, location) = cdr(symbols); + else + for (s7_pointer syms = cdr(symbols); is_pair(syms); symbols = syms, syms = cdr(syms)) + if (car(syms) == sym) + { + unchecked_set_cdr(symbols, cdr(syms)); /* delete z */ + return; + } +} + +s7_pointer s7_gensym(s7_scheme *sc, const char *prefix) +{ + const 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); + s7_uint 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 so should not be GC'd(?) */ + 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; + s7_int plen; + + /* get symbol name */ + if (is_pair(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; + } + + { + s7_int len = plen + 32; /* why 32 -- we need room for the gensym_counter integer, but (length "9223372036854775807") = 19, see gensym name collision loop below */ + /* it might be better (less predictable) to use a random number instead of gensym_counter, but that looks messy */ + block_t *b = mallocate(sc, len + sizeof(block_t) + 2 * sizeof(s7_cell)); + char *base = (char *)block_data(b); + s7_pointer str = (s7_cell *)base; + s7_pointer stc = (s7_cell *)(base + sizeof(s7_cell)); + block_t *ib = (block_t *)(base + 2 * sizeof(s7_cell)); + char *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 */ + + { + s7_pointer new_gensym; + s7_uint hash; + uint32_t location; + s7_int nlen; + while (true) + { + const 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); /* was T_UNHEAP? 17-Mar-25 */ + 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, new_gensym, T_SYMBOL | T_GENSYM); + symbol_set_name_cell(new_gensym, str); + symbol_info(new_gensym) = ib; + set_global_slot(new_gensym, sc->undefined); + set_initial_value(new_gensym, sc->undefined); + symbol_set_local_slot_unchecked(new_gensym, 0LL, sc->undefined); + symbol_clear_ctr(new_gensym); + set_big_symbol_tag(new_gensym, 0); + set_small_symbol_tag(new_gensym, 0); + symbol_set_shadows(new_gensym, 0); + symbol_clear_type(new_gensym); + gensym_block(new_gensym) = b; + + /* place new symbol in symbol-table */ + if (S7_DEBUGGING) full_type(stc) = 0; + set_full_type(stc, T_PAIR | T_IMMUTABLE); /* was T_UNHEAP? 17-Mar-25 */ + set_car(stc, new_gensym); + 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, (s7_uint)string_length(str)); + pair_set_raw_name(stc, string_value(str)); + + add_gensym(sc, new_gensym); + return(new_gensym); + }} +} + + +/* -------------------------------- 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 s7_pointer nil_string; /* permanent "" */ +/* nil_vector is complicated by the many vector types, and s7test assumes it is mutable! and not eq? to other nil_vectors (watch out for add_vector!) */ + +static Inline s7_pointer inline_make_string_with_length(s7_scheme *sc, const char *str, s7_int len) +{ + s7_pointer new_string; + new_cell(sc, new_string, T_STRING | T_SAFE_PROCEDURE); + string_block(new_string) = inline_mallocate(sc, len + 1); + string_value(new_string) = (char *)block_data(string_block(new_string)); + memcpy((void *)string_value(new_string), (const void *)str, len); + string_value(new_string)[len] = 0; + string_length(new_string) = len; + string_hash(new_string) = 0; + add_string(sc, new_string); + return(new_string); +} + +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) + + const 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) +{ + const 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])); + 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))); +} + +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; + s7_pointer p; + + 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)); + + { /* can't use catstrs_direct here because it stops at embedded null */ + block_t *b = mallocate(sc, len + 1); + char *name = (char *)block_data(b); + s7_pointer sym; + p = args; + for (s7_int cur_len = 0; 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 str1, s7_pointer str2) +{ + char buf[256]; + s7_int len; + if ((!is_string(str1)) || (!is_string(str2))) return(g_symbol(sc, set_plist_2(sc, str1, str2))); + len = string_length(str1) + string_length(str2); + if ((len == 0) || (len >= 256)) return(g_symbol(sc, set_plist_2(sc, str1, str2))); + memcpy((void *)buf, (void *)string_value(str1), string_length(str1)); + memcpy((void *)(buf + string_length(str1)), (void *)string_value(str2), string_length(str2)); + return(mark_as_symbol_from_symbol(inline_make_symbol(sc, buf, len))); +} + +/* -------- symbol-initial-value -------- */ +static s7_pointer g_symbol_initial_value(s7_scheme *sc, s7_pointer args) +{ + #define H_symbol_initial_value "(symbol-initial-value sym) returns the initial binding of the symbol sym" + #define Q_symbol_initial_value s7_make_signature(sc, 2, sc->T, sc->is_symbol_symbol) + + s7_pointer symbol = car(args); + if (!is_symbol(symbol)) /* or is_normal_symbol? now (symbol-initial-value :hi) -> # */ + return(sole_arg_method_or_bust(sc, symbol, sc->symbol_initial_value_symbol, set_plist_1(sc, symbol), sc->type_names[T_SYMBOL])); + return(initial_value(symbol)); +} + +static s7_pointer g_symbol_set_initial_value(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer symbol = car(args), value = cadr(args); + if (!is_symbol(symbol)) + wrong_type_error_nr(sc, wrap_string(sc, "set! symbol-initial-value", 25), 1, symbol, sc->type_names[T_SYMBOL]); + if (initial_value_is_defined(symbol)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set! (symbol-initial-value '~S); it is immutable", 54), symbol)); + set_initial_value(symbol, value); + if (in_heap(value)) add_semipermanent_object(sc, value); + /* should this tie into unlet? */ + return(value); +} + +s7_pointer s7_symbol_initial_value(s7_pointer symbol) {return(initial_value(symbol));} + +static bool is_eq_initial_value(s7_pointer symbol, s7_pointer other) +{ + const s7_pointer init = initial_value(symbol); + if (init == other) return(true); + if (is_c_function(init)) return((is_c_function(other)) && (c_function_data(init) == c_function_data(other))); + if (is_syntax(init)) return((is_syntax(other)) && (syntax_symbol(init) == syntax_symbol(other))); + if (is_unspecified(init)) return(is_unspecified(other)); + if (is_c_macro(init)) return((is_c_macro(other)) && (c_macro_data(init) == c_macro_data(other))); + return(false); +} + +static bool is_eq_initial_c_function_data(s7_pointer symbol, s7_pointer s_func) +{ + return((is_c_function(s_func)) && (c_function_data(s_func) == c_function_data(initial_value(symbol)))); +} + +static void copy_initial_value(s7_scheme *sc, s7_pointer sym) +{ + s7_pointer curval = initial_value(sym); + if (!is_symbol(curval)) /* otherwise we end up with a copied symbol */ + { + s7_pointer newval = alloc_pointer(sc); + memcpy((void *)newval, (void *)curval, sizeof(s7_cell)); + set_is_initial_value(newval); + set_initial_value(sym, newval); + /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, string_value(s7_object_to_string(sc, sym, false)), string_value(s7_object_to_string(sc, newval, false))); */ + } +} + +s7_pointer s7_symbol_set_initial_value(s7_scheme *sc, s7_pointer symbol, s7_pointer value) +{ + if (initial_value(symbol) == sc->undefined) + { + set_initial_value(symbol, value); + /* copy_initial_value(sc, symbol); */ + if (in_heap(value)) add_semipermanent_object(sc, value); + } + return(initial_value(symbol)); +} + + +/* -------- small symbol set -------- */ + +#if S7_DEBUGGING +enum {set_ignore, set_begin, set_end}; + +#define symbol_is_in_small_symbol_set(Sc, Sym) symbol_is_in_small_symbol_set_1(Sc, Sym, __func__, __LINE__) +static bool symbol_is_in_small_symbol_set_1(s7_scheme *sc, s7_pointer sym, const char *func, int line) +{ + if (sc->small_symbol_set_state == set_end) + fprintf(stderr, "%s[%d]: small_symbol_set membership test but it's not running\n", func, line); + return(small_symbol_tag(sym) == sc->small_symbol_tag); +} + +#define add_symbol_to_small_symbol_set(Sc, Sym) add_symbol_to_small_symbol_set_1(Sc, Sym, __func__, __LINE__) +static s7_pointer add_symbol_to_small_symbol_set_1(s7_scheme *sc, s7_pointer sym, const char *func, int line) +{ + if (sc->small_symbol_set_state == set_end) + fprintf(stderr, "%s[%d]: small_symbol_set add member but it's not running\n", func, line); + set_small_symbol_tag(sym, sc->small_symbol_tag); + return(sym); +} + +#define clear_small_symbol_set(Sc) clear_small_symbol_set_1(Sc, set_ignore, __func__, __LINE__) +static void clear_small_symbol_set_1(s7_scheme *sc, int status, const char *func, int line) +{ + /* if running end is ok, begin is an error, if not running end is error, begin is ok */ + if (status == set_begin) + { + if (sc->small_symbol_set_state == set_begin) + { + fprintf(stderr, "%s[%d]: small_symbol_set is running but begin requested (started at %s[%d])\n", + func, line, sc->small_symbol_set_func, sc->small_symbol_set_line); + if (sc->stop_at_error) abort(); + } + sc->small_symbol_set_func = func; + sc->small_symbol_set_line = line; + } + if ((status == set_end) && (sc->small_symbol_set_state == set_end)) + fprintf(stderr, "%s[%d]: small_symbol_set is not running but end requested (started at %s[%d])\n", + func, line, sc->small_symbol_set_func, sc->small_symbol_set_line); + sc->small_symbol_set_state = status; + + if (sc->small_symbol_tag == 0) /* see comment below */ + { + s7_pointer *els = vector_elements(sc->symbol_table); + for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) /* clear old small_symbol_tags */ + for (s7_pointer syms = els[i]; is_pair(syms); syms = cdr(syms)) + set_small_symbol_tag(car(syms), 0); + sc->small_symbol_tag = 1; + } + else sc->small_symbol_tag++; +} + +#define begin_small_symbol_set(Sc) clear_small_symbol_set_1(Sc, set_begin, __func__, __LINE__) +#define end_small_symbol_set(Sc) clear_small_symbol_set_1(Sc, set_end, __func__, __LINE__) + +#else + +#define symbol_is_in_small_symbol_set(Sc, Sym) (small_symbol_tag(Sym) == Sc->small_symbol_tag) + +static /* inline */ s7_pointer add_symbol_to_small_symbol_set(s7_scheme *sc, s7_pointer sym) +{ + set_small_symbol_tag(sym, sc->small_symbol_tag); + return(sym); +} + +static /* inline */ void clear_small_symbol_set(s7_scheme *sc) +{ + if (sc->small_symbol_tag == 0) /* or 2^32 - 1, but that's much slower than checking for 0 -- unsigned wrap around is defined in C */ + { + s7_pointer *els = vector_elements(sc->symbol_table); + for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) /* clear old small_symbol_tags */ + for (s7_pointer syms = els[i]; is_pair(syms); syms = cdr(syms)) + set_small_symbol_tag(car(syms), 0); + sc->small_symbol_tag = 1; + } + else sc->small_symbol_tag++; +} + +#define begin_small_symbol_set(Sc) clear_small_symbol_set(Sc) +#define end_small_symbol_set(Sc) +#endif + +/* -------- big symbol set -------- */ +#define symbol_is_in_big_symbol_set(Sc, Sym) (big_symbol_tag(Sym) == Sc->big_symbol_tag) +#define clear_big_symbol_set(Sc) Sc->big_symbol_tag++ + +static s7_pointer add_symbol_to_big_symbol_set(s7_scheme *sc, s7_pointer sym) +{ + if (symbol_is_in_big_symbol_set(sc, sym)) symbol_shadows(sym)++; else symbol_set_shadows(sym, 0); + set_big_symbol_tag(sym, sc->big_symbol_tag); + return(sym); +} + + +/* -------------------------------- lets/slots -------------------------------- */ +static Inline s7_pointer inline_make_let(s7_scheme *sc, s7_pointer old_let) +{ + s7_pointer new_let; + new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE); + let_set_id(new_let, ++sc->let_number); + let_set_slots(new_let, slot_end); + let_set_outlet(new_let, old_let); + return(new_let); +} + +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 wrap_let_with_slot(s7_scheme *sc, s7_pointer old_let, s7_pointer symbol, s7_pointer value) +{ + s7_pointer let = wrap_let(sc, old_let); /* increments let_number */ + s7_pointer slot = wrap_slot(sc, symbol, value); + symbol_set_local_slot(symbol, sc->let_number, slot); + slot_set_next(slot, slot_end); + let_set_slots(let, slot); + return(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, s7_uint 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 s7_pointer add_slot_unchecked_no_local_slot(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); + return(slot); +} + +#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 inline s7_pointer add_slot_no_local(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) /* no symbol_set_local_slot, no set_local */ +{ + s7_pointer slot; + new_cell(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + 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 add_slot_at_end(s7_scheme *sc, s7_uint 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_checked_at_end(s7_scheme *sc, s7_uint id, s7_pointer last_slot, s7_pointer symbol, s7_pointer value) +{ /* same as above but new_cell is checked */ + s7_pointer slot; + new_cell(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_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, pars = closure_pars(func); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(pars), val1, cadr(pars), val2)); + last_slot = next_slot(let_slots(sc->curlet)); + add_slot_at_end(sc, let_id(sc->curlet), last_slot, caddr(pars), 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, pars = closure_pars(func); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(pars), val1, cadr(pars), val2)); + pars = cddr(pars); + last_slot = next_slot(let_slots(sc->curlet)); + last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(pars), val3); + add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadr(pars), 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, pars = closure_pars(func); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(pars), val1, cadr(pars), val2)); + pars = cddr(pars); + last_slot = next_slot(let_slots(sc->curlet)); + last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(pars), val3); + pars = cdr(pars); + last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(pars), val4); + add_slot_at_end(sc, let_id(sc->curlet), last_slot, cadr(pars), val5); +} + +#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); + s7_int 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); + s7_int 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); + const s7_int 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); + const s7_int 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; + const s7_pointer 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 slot, s7_pointer value) +{ + if (slot_has_setter(slot)) + slot_set_value(slot, call_setter(sc, slot, value)); + else + { + if (is_immutable_slot(slot)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_set_symbol, slot_symbol(slot))); + slot_set_value(slot, value); + } + return(slot_value(slot)); +} + +static s7_pointer let_fill(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer e = car(args); + s7_pointer 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->starlet) + out_of_range_error_nr(sc, sc->fill_symbol, int_one, e, wrap_string(sc, "can't fill! *s7*", 16)); + /* (owlet) copies sc->owlet, so e can't be sc->owlet */ + 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 slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + checked_slot_set_value(sc, slot, val); + return(val); +} + +static s7_int starlet_length(void); + +static s7_int let_length(s7_scheme *sc, s7_pointer e) +{ + /* used by length, applicable_length, copy, and some length optimizations */ + if (e == sc->rootlet) + { + s7_int i = 0; + for (s7_pointer slot = sc->rootlet_slots; tis_slot(slot); i++, slot = next_slot(slot)); + return(i); + } + if (e == sc->starlet) + return(starlet_length()); + if (has_active_methods(sc, e)) + { + s7_pointer length_func = find_method(sc, e, sc->length_symbol); + if (length_func != sc->undefined) + { + s7_pointer num = s7_apply_function(sc, length_func, set_plist_1(sc, e)); + return((s7_is_integer(num)) ? s7_integer(num) : -1); /* ?? */ + }} + { + s7_int i = 0; + for (s7_pointer slot = let_slots(e); tis_slot(slot); i++, slot = next_slot(slot)); + 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 slot = let_slots(lt); tis_slot(slot); slot = next_slot(slot)) + { + s7_pointer val = slot_value(slot); + if ((has_closure_let(val)) && + (in_heap(closure_pars(val)))) + remove_function_from_heap(sc, val); + } + let_set_removed(lt); +} + +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 void remove_function_from_heap(s7_scheme *sc, s7_pointer value) +{ + remove_from_heap(sc, closure_pars(value)); + remove_from_heap(sc, closure_body(value)); /* this is where the compute time goes */ + /* remove closure if it's local to current func (meaning (define f (let ...) (lambda ...)) removes the enclosing let) */ + + { /* not sure this is worth the effort (finds 46 strings during s7test, checks 407 functions) */ + s7_pointer val = funclet_entry(sc, value, sc->local_documentation_symbol); + if ((val) && (is_string(val)) && (in_heap(val))) petrify(sc, val); + } + { + s7_pointer e = closure_let(value); + if ((is_let(e)) && (!let_removed(e)) && (e != sc->shadow_rootlet)) + { + e = let_outlet(e); + if ((is_let(e)) && (!let_removed(e)) && (e != sc->shadow_rootlet)) + { + remove_let_from_heap(sc, e); + e = let_outlet(e); + if ((is_let(e)) && (!let_removed(e)) && (e != sc->shadow_rootlet)) + remove_let_from_heap(sc, e); + }}} +} + +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 add_to_unlet(s7_scheme *sc, s7_pointer symbol) +{ + unlet_entry_t *new_entry = (unlet_entry_t *)permalloc(sc, sizeof(unlet_entry_t)); + new_entry->symbol = symbol; + new_entry->next = sc->unlet_entries; + sc->unlet_entries = new_entry; +} + +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 (is_global(symbol)) /* never defined locally (symbol_id tracks let_id) */ + { + if ((!is_gensym(symbol)) && + (!initial_value_is_defined(symbol)) && + (!in_heap(value)) && /* else initial_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_value, 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?). + * But I don't see any interesting omissions. + */ + { + set_initial_value(symbol, value); + if ((!sc->string_signature) && ((is_c_function(value)) || (is_syntax(value)))) /* syntax probably can't happen here (handled explicitly in syntax procedure) */ + add_to_unlet(sc, symbol); + } + set_local_slot(symbol, slot); + } + 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 slot; + new_cell(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, variable, value); + return(slot); +} + + +/* -------------------------------- 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) + + const s7_pointer result = make_let(sc, sc->curlet); + begin_temp(sc->y, result); + set_is_unlet(result); + if (global_value(sc->else_symbol) != sc->else_symbol) + add_slot_checked_with_id(sc, result, sc->else_symbol, initial_value(sc->else_symbol)); + for (unlet_entry_t *p = sc->unlet_entries; p; p = p->next) + { + s7_pointer sym = p->symbol; + if ((!is_eq_initial_value(sym, 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, result, sym, initial_value(sym)); + } + end_temp(sc->y); + return(result); +} + + +/* -------------------------------- 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 if '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 */ + if_method_exists_return_value(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) +{ + /* if e is not a let, the openlet bit is still set on it (c-pointer etc) */ + 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. e is returned." + #define Q_openlet s7_make_signature(sc, 2, has_let_signature(sc), has_let_signature(sc)) + + const s7_pointer e = car(args); + s7_pointer new_let, func; + if (!is_let(e)) + { + new_let = find_let(sc, e); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->openlet_symbol, e, new_let, 1, args); + } + else new_let = e; + if ((new_let == sc->rootlet) || (new_let == sc->starlet)) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't openlet ~S", 17), e)); + if (is_unlet(new_let)) /* 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, new_let, sc->openlet_symbol)) != sc->undefined)) + return(s7_apply_function(sc, func, args)); + set_has_methods(e); + return(e); /* openlet and coverlet return their argument */ +} + +/* -------------------------------- coverlet -------------------------------- */ +static s7_pointer g_coverlet(s7_scheme *sc, s7_pointer args) +{ + #define H_coverlet "(coverlet e) undoes an earlier openlet. e is returned." + #define Q_coverlet s7_make_signature(sc, 2, has_let_signature(sc), has_let_signature(sc)) + + const s7_pointer e = car(args); + s7_pointer new_let, func; + if (!is_let(e)) + { + new_let = find_let(sc, e); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->coverlet_symbol, e, new_let, 1, args); + } + else new_let = e; + if ((new_let == sc->rootlet) || (new_let == sc->starlet)) + error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "can't coverlet ~S", 17), e)); + if (is_unlet(new_let)) + error_nr(sc, sc->out_of_range_symbol, set_elist_1(sc, wrap_string(sc, "can't coverlet unlet", 20))); + if ((has_active_methods(sc, e)) && + ((func = find_method(sc, new_let, sc->coverlet_symbol)) != sc->undefined)) + return(s7_apply_function(sc, func, args)); + clear_has_methods(e); + return(e); /* mimic openlet in everything */ +} + + +/* -------------------------------- 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 slot = let_slots(old_e); tis_slot(slot); slot = next_slot(slot)) + { + s7_pointer sym = slot_symbol(slot), val = slot_value(slot); + if (is_slot(global_slot(sym))) + set_global_value(sym, val); + else s7_make_slot(sc, sc->rootlet, sym, val); + } + else + if (old_e == sc->starlet) + { + const s7_pointer iter = s7_make_iterator(sc, sc->starlet); + const s7_int gc_loc = gc_protect_1(sc, iter); + iterator_carrier(iter) = cons_unchecked(sc, sc->F, sc->F); + set_has_carrier(iter); /* so carrier is GC protected by mark_iterator */ + while (true) + { + s7_pointer field = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + add_slot_checked_with_id(sc, new_e, car(field), cdr(field)); + } + s7_gc_unprotect_at(sc, gc_loc); + } + else + for (s7_pointer slot = let_slots(old_e); tis_slot(slot); slot = next_slot(slot)) + add_slot_checked_with_id(sc, new_e, slot_symbol(slot), slot_value(slot)); /* not add_slot here because it might run off the free heap end */ +} + +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))) + set_global_value(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, has_let_signature(sc), \ + s7_make_signature(sc, 3, sc->is_pair_symbol, sc->is_symbol_symbol, sc->is_let_symbol), sc->T) + s7_pointer env = car(args); + if (!is_let(env)) + { + s7_pointer new_let = find_let(sc, env); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->varlet_symbol, env, new_let, 1, args); + env = new_let; + } + if ((is_immutable_let(env)) || (env == sc->starlet)) + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't (varlet ~{~S~^ ~}), ~S is immutable", 41), args, env)); + + for (s7_pointer arglist = cdr(args); is_pair(arglist); arglist = cdr(arglist)) + { + s7_pointer sym, val; + const s7_pointer arg = car(arglist); + if (is_symbol(arg)) + { + sym = (is_keyword(arg)) ? keyword_symbol(arg) : arg; + if (!is_pair(cdr(arglist))) + error_nr(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, "varlet: symbol ~S, but no value: ~S", 35), arg, args)); + if (is_constant_symbol(sc, sym)) + wrong_type_error_nr(sc, sc->varlet_symbol, position_of(arglist, args), sym, a_non_constant_symbol_string); + arglist = cdr(arglist); + val = car(arglist); + } + else + if (is_let(arg)) + { + if ((arg != sc->rootlet) && (env != sc->starlet)) /* (varlet (inlet 'a 1) (rootlet)) is trouble */ + { + append_let(sc, env, arg); + if (has_let_set_fallback(arg)) set_has_let_set_fallback(env); + if (has_let_ref_fallback(arg)) set_has_let_ref_fallback(env); + } + continue; + } + else + if (is_pair(arg)) + { + sym = car(arg); + if (!is_symbol(sym)) + wrong_type_error_nr(sc, sc->varlet_symbol, position_of(arglist, args), arg, a_symbol_string); + if (is_constant_symbol(sc, sym)) + wrong_type_error_nr(sc, sc->varlet_symbol, position_of(arglist, args), sym, a_non_constant_symbol_string); + val = cdr(arg); + } + else wrong_type_error_nr(sc, sc->varlet_symbol, position_of(arglist, args), arg, wrap_string(sc, "a symbol, let, or cons", 22)); + + if (env == 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), arg, 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, env); + add_slot_checked_with_id(sc, env, 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(env); +} + + +/* -------------------------------- 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, has_let_signature(sc), sc->is_symbol_symbol) + + s7_pointer e = car(args); + s7_int the_un_id; + if (e != sc->rootlet) + { + if_method_exists_return_value(sc, e, sc->cutlet_symbol, args); + if (!is_let(e)) + { + s7_pointer new_let = find_let(sc, e); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->cutlet_symbol, e, new_let, 1, args); + e = new_let; + }} + if ((is_immutable_let(e)) || (e == sc->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! So use the next (unused) id. + * (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); + set_global_value(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) +{ + const s7_pointer new_e = make_let(sc, e); + set_all_methods(new_e, e); + + if (!is_null(bindings)) + { + s7_pointer slot = NULL; + sc->temp3 = new_e; + for (s7_pointer entries = bindings; is_pair(entries); entries = cdr(entries)) + { + s7_pointer entry = car(entries), sym, val; + + switch (type(entry)) + { + case T_SYMBOL: + sym = (is_keyword(entry)) ? keyword_symbol(entry) : entry; + if (!is_pair(cdr(entries))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A: entry ~S, but no value: ~S", 30), caller, entry, bindings)); + entries = cdr(entries); + val = car(entries); + break; + + case T_PAIR: /* (cons sym val) */ + sym = car(entry); + if (!is_symbol(sym)) + wrong_type_error_nr(sc, caller, 1 + position_of(entries, bindings), entry, a_symbol_string); + if (is_keyword(sym)) + sym = keyword_symbol(sym); + val = cdr(entry); + break; + + case T_LET: + if ((entry == sc->rootlet) || (new_e == sc->starlet)) continue; + append_let(sc, new_e, entry); + if (tis_slot(let_slots(new_e))) /* make sure the end slot (slot) is correct */ + for (slot = let_slots(new_e); tis_slot(next_slot(slot)); slot = next_slot(slot)); /* slot can't be local -- see below */ + continue; + + default: + wrong_type_error_nr(sc, caller, 1 + position_of(entries, bindings), entry, a_symbol_string); + } + if (is_constant_symbol(sc, sym)) + wrong_type_error_nr(sc, caller, 1 + position_of(entries, 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 */ + /* so s7_inlet (which calls sublet) differs from g_inlet? which is correct? */ + /* (define (f1) (with-let (sublet (curlet)) (inlet 'quasiquote 1))) (f1) */ + +#endif + /* here we know new_e is a let and is not rootlet */ + if (!slot) + slot = 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? */ + slot = add_slot_checked_at_end(sc, let_id(new_e), slot, sym, val); + set_local(sym); /* ? */ + } + check_let_fallback(sc, sym, new_e); + } + if ((S7_DEBUGGING) && (sc->temp3 != new_e)) fprintf(stderr, "%s[%d]: temp3: %s\n", __func__, __LINE__, display(sc->temp3)); + 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 (an environment) within the environment 'lt', initializing it with the bindings" + #define Q_sublet Q_varlet + + s7_pointer e = car(args); + if (!is_let(e)) + { + s7_pointer new_let = find_let(sc, e); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->sublet_symbol, e, new_let, 1, args); + e = new_let; + } + 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; + if_let_method_exists_return_value(sc, sc->curlet, sc->sublet_symbol, args); /* curlet is a let so... */ + 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 func, 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(func); +} + + +/* -------------------------------- 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 */ + const s7_pointer new_e = make_let(sc, sc->rootlet); + const s7_int id = let_id(new_e); + + begin_temp(sc->temp6, new_e); + for (s7_pointer x = args, sp = NULL; 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) */ + { + end_temp(sc->temp6); + 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 = add_slot_checked_at_end(sc, id, sp, symbol, cadr(x)); + } + end_temp(sc->temp6); + return(new_e); +} + +static s7_pointer inlet_p_pp(s7_scheme *sc, s7_pointer symbol, s7_pointer value) +{ + 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_defined_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)); + { + s7_pointer new_let; + new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE); + begin_temp(sc->x, new_let); + let_set_id(new_let, ++sc->let_number); + let_set_outlet(new_let, sc->rootlet); + let_set_slots(new_let, slot_end); + add_slot_unchecked(sc, new_let, symbol, value, let_id(new_let)); + end_temp(sc->x); + return(new_let); + } +} + +static s7_pointer internal_inlet(s7_scheme *sc, s7_int num_args, ...) /* used in *->let */ +{ + va_list ap; + const s7_pointer new_e = make_let(sc, sc->rootlet); + const s7_int id = let_id(new_e); + s7_pointer sp = NULL; + + begin_temp(sc->x, new_e); + va_start(ap, num_args); + for (s7_int i = 0; i < num_args; i += 2) + { + s7_pointer symbol = T_Sym(va_arg(ap, s7_pointer)); + s7_pointer value = T_Ext(va_arg(ap, s7_pointer)); + if (!sp) + { + add_slot_unchecked(sc, new_e, symbol, value, id); + sp = let_slots(new_e); + } + else sp = add_slot_at_end(sc, id, sp, symbol, value); + } + va_end(ap); + end_temp(sc->x); + 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 func, 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(func); /* (inlet abs ...) */ + sym = cadar(p); /* looking for (inlet 'a ...) */ + if (!is_symbol(sym)) return(func); /* (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(func); + } + return(sc->simple_inlet); + } + return(func); +} + + +/* -------------------------------- 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, "", 11)); + return(val); +} + +s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let) +{ + if (let == sc->rootlet) + { + begin_temp(sc->temp6, sc->nil); + for (s7_pointer lib = global_value(sc->libraries_symbol); is_pair(lib); lib = cdr(lib)) + sc->temp6 = cons(sc, caar(lib), sc->temp6); + sc->temp6 = cons(sc, cons(sc, sc->libraries_symbol, sc->temp6), sc->nil); + for (s7_pointer slot = sc->rootlet_slots; tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) != sc->libraries_symbol) + sc->temp6 = cons_unchecked(sc, cons(sc, slot_symbol(slot), abbreviate_let(sc, slot_value(slot))), sc->temp6); + { + s7_pointer result = proper_list_reverse_in_place(sc, sc->temp6); + end_temp(sc->temp6); + return(result); + }} + else + { + s7_pointer iter, func; + s7_int gc_loc = -1; + /* need to check make-iterator method before dropping into let->list */ + sc->temp3 = sc->w; + sc->w = sc->nil; + + 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->starlet) /* (let->list *s7*) via 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 (s7_pointer slot = let_slots(let); tis_slot(slot); slot = next_slot(slot)) + sc->w = cons_unchecked(sc, cons(sc, slot_symbol(slot), slot_value(slot)), sc->w); + else + /* (begin (load "mockery.scm") (let ((lt ((*mock-pair* 'mock-pair) 1 2 3))) (format *stderr* "~{~A ~}" lt))) */ + while (true) + { + s7_pointer val = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + sc->w = cons(sc, val, sc->w); + } + sc->w = proper_list_reverse_in_place(sc, sc->w); + if (gc_loc != -1) + s7_gc_unprotect_at(sc, gc_loc); + + { + s7_pointer result = sc->w; + sc->w = sc->temp3; + sc->temp3 = sc->unused; + return(result); + }} +} + +#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, has_let_signature(sc)) + + s7_pointer let = car(args); + if_method_exists_return_value(sc, let, sc->let_to_list_symbol, args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->let_to_list_symbol, let, new_let, 1, args); + /* this is not (let->list (rootlet)) but (say) (let->list func) which defaults in find_let to rootlet */ + let = new_let; + } + return(s7_let_to_list(sc, let)); +} +/* *s7* in gdb: p display(s7_let_to_list(sc, sc->starlet)) */ +#endif + + +/* -------------------------------- let-ref -------------------------------- */ +static s7_pointer call_let_ref_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol) +{ + s7_pointer result; + const s7_pointer val = find_method(sc, let, sc->let_ref_fallback_symbol); + /* (let ((x #f)) (let begin ((x 1234)) (begin 1) 2)) -> stack overflow eventually, but should we try to catch it? */ + if (!is_applicable(val)) return(val); + push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code); + result = s7_apply_function(sc, val, set_qlist_2(sc, let, symbol)); + unstack_gc_protect(sc); + sc->code = T_Pos(stack_end_code(sc)); /* can be # */ + sc->value = T_Ext(stack_end_args(sc)); + return(result); +} + +static s7_pointer call_let_set_fallback(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) +{ + s7_pointer result; + push_stack_no_let(sc, OP_GC_PROTECT, sc->value, sc->code); + result = 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(result); +} + +static s7_pointer g_unlet_disabled(s7_scheme *sc, s7_pointer args) {return(sc->unlet_disabled);} +/* we need a self-id here for let_ref, but it needs to be a real s7_cell, not g_unlet_disabled itself, hence sc->unlet_disabled */ + +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)) + { + s7_pointer new_let; + if (let == sc->unlet_disabled) return(initial_value(symbol)); + new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->let_ref_symbol, let, new_let, 1, set_mlist_2(sc, let, symbol)); + let = new_let; + } + 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. + * What about other let-as-first-arg funcs? + */ + + if (let_id(let) == symbol_id(symbol)) + return(local_value(symbol)); /* this has to follow the rootlet check(?) */ + + if (is_keyword(symbol)) + symbol = keyword_symbol(symbol); + if (let == sc->rootlet) + return((is_slot(global_slot(symbol))) ? global_value(symbol) : sc->undefined); + + for (s7_pointer e = let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(slot_value(slot)); + + 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, has_let_signature(sc), 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 slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + return(slot); + return(sc->undefined); +} + +static s7_pointer let_ref_p_pp(s7_scheme *sc, s7_pointer lt, s7_pointer sym) +{ + if (let_id(lt) == symbol_id(sym)) + return(local_value(sym)); /* see add in tlet! */ + if (lt == sc->rootlet) /* op_implicit_let_ref_c can pass rootlet */ + return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); + for (s7_pointer e = lt; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + return(slot_value(slot)); + if (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_cdr_let_ref(s7_scheme *sc, s7_pointer args) +{ + const 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 (let_id(lt) == symbol_id(sym)) + return(local_value(sym)); + if (lt == sc->rootlet) + return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); + for (s7_pointer slot = let_slots(lt); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + return(slot_value(slot)); + return(let_ref_p_pp(sc, let_outlet(lt), sym)); +} + +static s7_pointer starlet(s7_scheme *sc, s7_int choice); +static s7_pointer g_starlet_ref(s7_scheme *sc, s7_pointer args) {return(starlet(sc, starlet_symbol_id(cadr(args))));} +static s7_pointer g_curlet_ref(s7_scheme *sc, s7_pointer args) {return(lookup(sc, cadr(args)));} +static s7_pointer g_unlet_ref(s7_scheme *sc, s7_pointer args) {return(initial_value(cadr(args)));} + +static s7_pointer g_rootlet_ref(s7_scheme *sc, s7_pointer args) +{ + s7_pointer sym = cadr(args); + return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); +} + +static s7_pointer let_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr) +{ + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if ((is_quoted_symbol(arg2)) && (!is_keyword(cadr(arg2)))) + { + if (is_pair(arg1)) + { + if ((optimize_op(expr) == HOP_SAFE_C_opSq_C) && (car(arg1) == sc->cdr_symbol)) + { + set_opt3_sym(cdr(expr), cadr(arg2)); + return(sc->cdr_let_ref); + } + if (car(arg1) == sc->rootlet_symbol) return(sc->rootlet_ref); + if (car(arg1) == sc->curlet_symbol) return(sc->curlet_ref); + if (car(arg1) == sc->unlet_symbol) + { + set_fn_direct(arg1, g_unlet_disabled); + return(sc->unlet_ref); + }} + if (arg1 == sc->starlet_symbol) return(sc->starlet_ref); /* should *curlet* be added? */ + } + return(func); +} + +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 (initial_value_is_defined(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_2(sc, wrap_string(sc, "~S is immutable in (rootlet)", 28), symbol)); /* 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_2(sc, wrap_string(sc, "~S is immutable in (unlet)", 26), symbol)); + 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 e = let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + { + symbol_increment_ctr(symbol); + return(checked_slot_set_value(sc, slot, 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)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->let_set_symbol, let, new_let, 1, set_plist_3(sc, let, symbol, value)); + let = new_let; + } + 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, has_let_signature(sc), 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 e, s7_pointer sym, s7_pointer val) +{ + if (!is_symbol(sym)) + wrong_type_error_nr(sc, sc->let_set_symbol, 2, sym, a_symbol_string); + return(let_set_1(sc, e, sym, val)); +} + +static s7_pointer g_cdr_let_set(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lt = car(args); + const s7_pointer sym = cadr(args), val = caddr(args); + if (!is_let(lt)) + { + s7_pointer new_let = find_let(sc, lt); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->let_set_symbol, lt, new_let, 1, args); + lt = new_let; + } + if (lt != sc->rootlet) + { + for (s7_pointer e = lt; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + { + slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, val) : val); + return(slot_value(slot)); + } + if ((lt != sc->rootlet) && (has_let_set_fallback(lt))) + return(call_let_set_fallback(sc, lt, sym, val)); + } + { + s7_pointer slot = global_slot(sym); + 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), sym, lt)); + slot_set_value(slot, (slot_has_setter(slot)) ? call_setter(sc, slot, val) : val); + return(slot_value(slot)); + } +} + +static s7_pointer starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val); + +static s7_pointer g_starlet_set(s7_scheme *sc, s7_pointer args) +{ + s7_pointer sym = cadr(args); + if (!is_symbol(sym)) /* (let () (define (func) (let-set! *s7* '(1 . 2) (hash-table))) (func) (func)) */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_3(sc, wrap_string(sc, "(let-set! *s7* ~A ...) second argument is ~A but should be a symbol", 67), + sym, object_type_name(sc, sym))); + if (is_keyword(sym)) + sym = keyword_symbol(sym); + if (starlet_symbol_id(sym) == sl_no_field) + 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(starlet_set_1(sc, sym, caddr(args))); +} + +static s7_pointer g_unlet_set(s7_scheme *sc, s7_pointer args) +{ + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable in (unlet)", 26), cadr(args))); + return(sc->F); +} + +static s7_pointer let_set_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr) +{ + const s7_pointer arg1 = cadr(expr); + if (optimize_op(expr) == HOP_SAFE_C_opSq_CS) + { + const s7_pointer arg2 = caddr(expr), arg3 = cadddr(expr); + if ((car(arg1) == sc->cdr_symbol) && + (is_quoted_symbol(arg2)) && + (!is_possibly_constant(cadr(arg2))) && /* assumes T_Sym */ + (!is_possibly_constant(arg3))) + return(sc->cdr_let_set); + if (car(arg1) == sc->unlet_symbol) + { + set_fn_direct(arg1, g_unlet_disabled); + return(sc->unlet_set); + }} + if (arg1 == sc->starlet_symbol) return(sc->starlet_set); + return(func); +} + + +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); + begin_temp(sc->x, new_e); + if (tis_slot(let_slots(let))) + { + const s7_int id = let_id(new_e); + s7_pointer last_slot = NULL; + for (s7_pointer slot = let_slots(let); tis_slot(slot); slot = next_slot(slot)) + { + s7_pointer p; + new_cell(sc, p, T_SLOT); + slot_set_symbol_and_value(p, slot_symbol(slot), slot_value(slot)); + if (symbol_id(slot_symbol(p)) != id) /* keep shadowing intact */ + symbol_set_local_slot(slot_symbol(slot), id, p); + if (slot_has_setter(slot)) + { + slot_set_setter(p, slot_setter(slot)); + slot_set_has_setter(p); + } + if (last_slot) + slot_set_next(last_slot, p); + else let_set_slots(new_e, p); + slot_set_next(p, slot_end); /* in case GC runs during this loop */ + last_slot = p; + }} + /* 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))))) + */ + end_temp(sc->x); + 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); +} + +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 slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + { + s7_pointer sym = slot_symbol(slot); + if (symbol_id(sym) != sc->let_number) + symbol_set_local_slot_unincremented(sym, sc->let_number, slot); + } +} + +s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e) +{ + const s7_pointer old_e = sc->curlet; + if (is_let(e)) + { + set_curlet(sc, e); + if (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)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->outlet_symbol, let, new_let, 1, set_mlist_1(sc, let)); + let = new_let; + } + return((let == sc->rootlet) ? sc->rootlet : let_outlet(let)); /* rootlet check is needed(!) */ +} + +static s7_pointer g_outlet_unlet(s7_scheme *sc, s7_pointer args) {return(sc->curlet);} + +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, has_let_signature(sc)) + return(outlet_p_p(sc, car(args))); +} + +static s7_pointer outlet_chooser(s7_scheme *sc, s7_pointer func, int32_t num_args, s7_pointer expr) +{ + if ((num_args == 1) && (is_pair(cadr(expr))) && (caadr(expr) == sc->unlet_symbol)) + { + set_fn_direct(cadr(expr), g_unlet_disabled); + return(sc->outlet_unlet); + } + return(func); +} + +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)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, wrap_string(sc, "set! outlet", 11), let, new_let, 1, args); + let = new_let; + } + if (let == sc->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)) + { + s7_pointer new_let = find_let(sc, new_outer); + if (!is_let(new_let)) + find_let_error_nr(sc, wrap_string(sc, "set! outlet", 11), new_outer, new_let, 2, args); + new_outer = new_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 e = new_outer; e; e = let_outlet(e)) + if (let == e) + 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 slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(slot_value(slot)); + + if (is_slot(global_slot(symbol))) + return(global_value(symbol)); +#if WITH_GCC && ((!__cplusplus) || (!__clang__)) + 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(T_Slt(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(T_Slt(local_slot(symbol))); + } + for (; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(T_Slt(slot)); + return(T_Sld(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) /* assumes e is a let */ +{ + if (T_Let(e) == sc->rootlet) + return(global_slot(symbol)); + if (!is_global(symbol)) /* i.e. rootlet is not the desired let, and the symbol might have a local value */ + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(slot); + return(sc->undefined); +} + +s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym) +{ + s7_pointer slot = s7_slot(sc, sym); + return((is_slot(slot)) ? slot_value(slot) : 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 slot = let_slots(let); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + return(slot_value(slot)); + + /* 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))) -> # not 1 */ + return(sc->undefined); /* 29-Nov-17 */ +} + + +/* -------------------------------- symbol->value -------------------------------- */ +#define lookup_global(Sc, Sym) ((is_defined_global(Sym)) ? global_value(Sym) : lookup_checked(Sc, Sym)) + +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, has_let_signature(sc)) + + const 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_pair(cdr(args))) + { + s7_pointer local_let = cadr(args); + 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->rootlet) return((is_slot(global_slot(sym))) ? global_value(sym) : sc->undefined); + if (is_unlet(local_let)) return(initial_value(sym)); + if (local_let == sc->starlet) return(starlet(sc, starlet_symbol_id(sym))); + return(s7_symbol_local_value(sc, sym, local_let)); + } + if (is_defined_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 slot = s7_slot(sc, sym); /* if immutable should this return an error? */ + if (is_slot(slot)) + slot_set_value(slot, val); /* with_hook? */ + return(val); +} + +static s7_pointer g_sv_unlet_ref(s7_scheme *sc, s7_pointer args) {return(initial_value(car(args)));} + +static s7_pointer symbol_to_value_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr) +{ + s7_pointer arg1 = cadr(expr), arg2 = (is_pair(cddr(expr))) ? caddr(expr) : sc->F; + if ((is_quoted_symbol(arg1)) && (!is_keyword(cadr(arg1))) && (is_pair(arg2)) && (car(arg2) == sc->unlet_symbol)) /* old-style (obsolete) unlet as third arg(!) */ + { + set_fn_direct(arg2, g_unlet_disabled); + return(sc->sv_unlet_ref); + } + return(func); +} + + +/* -------------------------------- symbol->dynamic-value -------------------------------- */ +static s7_pointer find_dynamic_value(s7_scheme *sc, s7_pointer e, s7_pointer sym, s7_int *id) +{ + for (; let_id(e) > symbol_id(sym); e = let_outlet(e)); + if (let_id(e) == symbol_id(sym)) + { + (*id) = let_id(e); + return(local_value(sym)); + } + for (; (e) && (let_id(e) > (*id)); e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + { + (*id) = let_id(e); + return(slot_value(slot)); + } + 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) + + const s7_pointer sym = car(args); + s7_pointer val; + s7_int 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_defined_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 (s7_int op_loc = stack_top(sc) - 1; op_loc > 0; op_loc -= 4) + if (is_let_unchecked(stack_let(sc->stack, op_loc))) /* OP_GC_PROTECT let slot can be anything (even free) */ + { + s7_pointer cur_val = find_dynamic_value(sc, stack_let(sc->stack, op_loc), sym, &top_id); + if (cur_val != sc->unused) + val = cur_val; + if (top_id == symbol_id(sym)) + return(val); + } + /* what about call/cc stacks? */ + return((val == sc->unused) ? s7_symbol_value(sc, sym) : val); +} + +static bool direct_memq(const s7_pointer symbol, s7_pointer symbols) +{ + for (s7_pointer syms = symbols; is_pair(syms); syms = cdr(syms)) + if (car(syms) == symbol) + return(true); + return(false); +} + +static bool direct_translucent_member(const s7_pointer symbol, s7_pointer symbols) +{ + for (s7_pointer syms = symbols; is_pair(syms); syms = cdr(syms)) + { + if (car(syms) == symbol) return(true); + if ((is_pair(car(syms))) && (is_translucent(caar(syms))) && (is_pair(cdar(syms))) && (cadar(syms) == 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 syms = symbols; is_pair(syms); syms = cdr(syms)) + if (caar(syms) == 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_big_symbol_set(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_big_symbol_set(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))); /* optimize_syntax pushes :if (and others like () I think) on this list */ +} + +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 */ + begin_temp(sc->y, e); + for (s7_pointer p = lst; is_pair(p); p = cdr(p)) + sc->y = cons(sc, add_symbol_to_big_symbol_set(sc, caar(p)), sc->y); + return_with_end_temp(sc->y); +} + +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 pars; + const s7_int the_un_id = ++sc->let_number; + if (is_normal_symbol(lst)) + { + symbol_set_id(lst, the_un_id); + return(cons(sc, add_symbol_to_big_symbol_set(sc, lst), e)); + } + begin_temp(sc->y, e); + for (pars = lst; is_pair(pars); pars = cdr(pars)) + { + s7_pointer par = car(pars); + if (is_pair(par)) + par = car(par); + if (is_normal_symbol(par)) + { + symbol_set_id(par, the_un_id); + sc->y = cons(sc, add_symbol_to_big_symbol_set(sc, par), sc->y); + }} + if (is_normal_symbol(pars)) /* rest arg */ + { + symbol_set_id(pars, the_un_id); + sc->y = cons(sc, add_symbol_to_big_symbol_set(sc, pars), sc->y); + } + return_with_end_temp(sc->y); +} + +static void clear_all_optimizations(s7_scheme *sc, s7_pointer p) +{ + if (is_unquoted_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 result; + if ((is_pair(car(code))) && (caar(code) == sc->profile_in_symbol)) + return(code); + result = 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(result), OP_PROFILE_IN); + return(result); +} + +static bool tree_has_definer(s7_scheme *sc, s7_pointer tree) +{ + for (s7_pointer p = tree; is_pair(p); p = cdr(p)) + if (tree_has_definer(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); + default: + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: %s?\n", __func__, __LINE__, op_names[op]); + } + return(NULL); +} + +typedef enum {opt_bad, opt_ok, opt_oops} opt_t; +static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e); + +static s7_pointer make_macro(s7_scheme *sc, opcode_t op, bool named) +{ + s7_pointer mac, body, mac_name = NULL; + s7_uint typ; + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %d, %s\n", __func__, __LINE__, named, 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_pars(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_definer(sc, body)) + set_is_definer(mac_name); /* (list-values 'define ...) t101-13 */ + } + clear_big_symbol_set(sc); + if ((!is_either_bacro(mac)) && + (optimize(sc, body, 1, collect_parameters(sc, closure_pars(mac), sc->nil)) == opt_oops)) + clear_all_optimizations(sc, body); + clear_big_symbol_set(sc); + + 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 */ + + /* we can't add the T_EXPANSION bit ourselves if + * ((mac_name) && (!is_bacro(mac_name)) && (!is_expansion(mac_name)) && (sc->curlet == sc->rootlet) && (is_global(mac_name))) + * because the user might reuse mac_name locally later, and our hidden expansion setting will cause the s7 reader to try to + * treat that reuse as a call of the original macro. + */ + return(mac); +} + +static s7_pointer make_closure_unchecked(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_uint type, int32_t arity) +{ + s7_pointer new_func; + new_cell_no_check(sc, new_func, (type | closure_bits(code))); + closure_set_pars(new_func, args); + closure_set_let(new_func, sc->curlet); + closure_set_setter(new_func, sc->F); + closure_set_arity(new_func, arity); + closure_set_body(new_func, code); + if (is_pair(cdr(code))) set_closure_has_multiform(new_func); else set_closure_has_one_form(new_func); + sc->capture_let_counter++; + return(new_func); +} + +static inline s7_pointer make_closure_gc_checked(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_uint type, int32_t arity) /* inline 100>1% tgc, 35=2% texit */ +{ /* used in op_lambda_unchecked to avoid enormous call overhead if using make_closure */ + s7_pointer new_func; + new_cell(sc, new_func, (type | closure_bits(code))); + closure_set_pars(new_func, args); + closure_set_let(new_func, sc->curlet); + closure_set_setter(new_func, sc->F); + closure_set_arity(new_func, arity); + closure_set_body(new_func, code); + if (is_pair(cdr(code))) set_closure_has_multiform(new_func); else set_closure_has_one_form(new_func); + sc->capture_let_counter++; + return(new_func); +} + +static s7_pointer make_closure(s7_scheme *sc, s7_pointer args, s7_pointer code, s7_uint type, int32_t arity) +{ + /* this is called (almost?) every time a lambda form is evaluated, or during letrec, etc */ + s7_pointer new_func; + new_cell(sc, new_func, (type | closure_bits(code))); + closure_set_pars(new_func, args); + closure_set_let(new_func, sc->curlet); + closure_set_setter(new_func, sc->F); + closure_set_arity(new_func, arity); + closure_set_body(new_func, 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, new_func); /* GC protect func during add_trace */ + closure_set_body(new_func, (sc->debug > 1) ? add_trace(sc, code) : add_profile(sc, code)); + set_closure_has_multiform(new_func); + unstack_gc_protect(sc); + } + else + if (is_pair(cdr(code))) + set_closure_has_multiform(new_func); + else set_closure_has_one_form(new_func); + sc->capture_let_counter++; + return(new_func); +} + +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 new_pair; + new_cell_no_check(sc, new_pair, full_type(p) & (TYPE_MASK | T_IMMUTABLE | T_SAFE_PROCEDURE)); + set_car(new_pair, a); + set_cdr(new_pair, b); + return(new_pair); +} + +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)) return((has_pairs) ? TREE_HAS_PAIRS : TREE_NOT_CYCLIC); + + 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)) return((has_pairs) ? TREE_HAS_PAIRS : TREE_NOT_CYCLIC); + + slow = cdr(slow); + if (fast == slow) return(TREE_CYCLIC); + } + return(TREE_HAS_PAIRS); /* not reached */ +} + +/* 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))) + { + const int32_t old_top = sc->tree_pointers_top; + const int32_t 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 new_fnc; + const s7_pointer 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, new_fnc, full_type(fnc) & (~T_COLLECTED)); /* I'm paranoid about that is_collected bit */ + closure_set_pars(new_fnc, closure_pars(fnc)); + closure_set_body(new_fnc, body); + closure_set_setter_or_map_list(new_fnc, closure_setter_or_map_list(fnc)); + closure_set_arity(new_fnc, closure_arity(fnc)); + closure_set_let(new_fnc, closure_let(fnc)); + return(new_fnc); +} + + +/* -------------------------------- 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 #t." + #define Q_is_defined s7_make_signature(sc, 4, sc->is_boolean_symbol, sc->is_symbol_symbol, has_let_signature(sc), 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); + const s7_pointer ignore_globals = (is_pair(cddr(args))) ? caddr(args) : sc->F; + if (!is_let(e)) + { + const s7_pointer new_let = find_let(sc, e); /* returns () if none */ + if (!is_let(new_let)) + find_let_error_nr(sc, sc->is_defined_symbol, e, new_let, 2, args); + if ((new_let == sc->rootlet) && (is_pair(cddr(args))) && (ignore_globals != sc->F)) + { + if (ignore_globals != sc->T) /* signature claims this should be a boolean */ + return(method_or_bust(sc, ignore_globals, sc->is_defined_symbol, args, a_boolean_string, 3)); + return(sc->F); + } + e = new_let; + } + /* if (is_unlet(e)) return(make_boolean(sc, initial_value_is_defined(sym))); */ + /* this ^ is wrong: (with-let (unlet) (define xx 1) (list (defined? 'xx) (defined? 'xx (curlet)))) should be (#t #t) */ + + 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->starlet) + return(make_boolean(sc, starlet_symbol_id(sym) != sl_no_field)); + if (!is_boolean(ignore_globals)) + return(method_or_bust(sc, ignore_globals, sc->is_defined_symbol, args, a_boolean_string, 3)); + if (e == sc->rootlet) /* we checked (let? e) above */ + { + if (ignore_globals == sc->F) + return(make_boolean(sc, is_slot(global_slot(sym)))); /* new_symbol and gensym initialize global_slot to # */ + return(sc->F); + } + if (is_slot(symbol_to_local_slot(sc, sym, T_Let(e)))) return(sc->T); + return((ignore_globals == sc->T) ? sc->F : make_boolean(sc, is_slot(global_slot(sym)))); + } + return((is_defined_global(sym)) ? sc->T : make_boolean(sc, is_slot(s7_slot(sc, sym)))); +} + +static s7_pointer g_is_defined_in_unlet(s7_scheme *sc, s7_pointer args) +{ + s7_pointer sym = car(args); + if (!is_symbol(sym)) + wrong_type_error_nr(sc, sc->is_defined_symbol, 1, car(args), a_symbol_string); + return(make_boolean(sc, initial_value_is_defined(sym))); +} + +static s7_pointer g_is_defined_in_rootlet(s7_scheme *sc, s7_pointer args) /* aimed at lint.scm */ +{ + /* (defined? bigi1 (rootlet)) can be optimized to opt_p_call_sf */ + s7_pointer sym = car(args); + if (!is_symbol(sym)) + wrong_type_error_nr(sc, sc->is_defined_symbol, 1, sym, a_symbol_string); + return(make_boolean(sc, (is_slot(global_slot(sym))) && (global_value(sym) != sc->undefined))); +} + +static s7_pointer is_defined_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 2) + { + const s7_pointer e = caddr(expr); + if ((is_pair(e)) && (is_null(cdr(e)))) + { + if (car(e) == sc->rootlet_symbol) + return(sc->is_defined_in_rootlet); + if (car(e) == sc->unlet_symbol) + { + set_fn_direct(e, g_unlet_disabled); + return(sc->is_defined_in_unlet); + }}} + return(func); +} + +bool s7_is_defined(s7_scheme *sc, const char *name) +{ + s7_pointer symbol = s7_symbol_table_find_name(sc, name); + if (!symbol) return(false); + return(is_slot(s7_slot(sc, symbol))); +} + +static bool is_defined_b_7p(s7_scheme *sc, s7_pointer sym) +{ + if (!is_symbol(sym)) return(method_or_bust(sc, sym, sc->is_defined_symbol, set_plist_1(sc, sym), sc->type_names[T_SYMBOL], 1) != sc->F); + return(is_slot(s7_slot(sc, sym))); +} + +static bool is_defined_b_7pp(s7_scheme *sc, s7_pointer sym, s7_pointer e) {return(g_is_defined(sc, set_plist_2(sc, sym, e)) != sc->F);} + + +void s7_define(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) /* assumes let is a let */ +{ + s7_pointer slot; + if (T_Let(let) == sc->rootlet) let = sc->shadow_rootlet; /* if symbol is a gensym should we issue a warning? */ + slot = symbol_to_local_slot(sc, symbol, let); /* x can be # */ + if (is_slot(slot)) + slot_set_value_with_hook(slot, 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_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) +{ + const s7_pointer sym = make_symbol_with_strlen(sc, name); + s7_define(sc, T_Let(envir), sym, value); + set_immutable(sym); + set_possibly_constant(sym); + set_immutable(global_slot(sym)); /* might also be # */ + set_immutable_slot(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->rootlet, 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) +{ + const 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'; + { + s7_pointer 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) + + const 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 obj = car(args); + if (is_c_pointer(obj)) + return((is_pair(cdr(args))) ? make_boolean(sc, c_pointer_type(obj) == cadr(args)) : sc->T); + if (!has_active_methods(sc, obj)) return(sc->F); + return(apply_boolean_method(sc, obj, 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 cptr, s7_pointer expected_type, const char *caller, s7_int argnum) +{ + if (!is_c_pointer(cptr)) + wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), argnum, cptr, sc->type_names[T_C_POINTER]); + if ((c_pointer(cptr) != NULL) && + (c_pointer_type(cptr) != 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(cptr), 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(cptr), expected_type)); + return(c_pointer(cptr)); +} + +s7_pointer s7_make_c_pointer_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info) +{ + s7_pointer new_cptr; + new_cell(sc, new_cptr, T_C_POINTER); + c_pointer(new_cptr) = ptr; + c_pointer_type(new_cptr) = type; + c_pointer_info(new_cptr) = info; + c_pointer_weak1(new_cptr) = sc->F; + c_pointer_weak2(new_cptr) = sc->F; + return(new_cptr); +} + +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 new_cptr = car(sc->c_pointer_wrappers); +#if S7_DEBUGGING + if ((full_type(new_cptr) & (~T_GC_MARK)) != (T_C_POINTER | T_IMMUTABLE | T_UNHEAP)) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, new_cptr)); + sc->c_pointer_wrapper_allocs++; +#endif + sc->c_pointer_wrappers = cdr(sc->c_pointer_wrappers); + c_pointer(new_cptr) = ptr; + c_pointer_type(new_cptr) = type; + c_pointer_info(new_cptr) = info; + c_pointer_weak1(new_cptr) = sc->F; + c_pointer_weak2(new_cptr) = sc->F; + return(new_cptr); +} + +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) + + const s7_pointer ptr_as_int = car(args); + s7_pointer type = sc->F, info = sc->F, weak1 = sc->F, weak2 = sc->F; + intptr_t cptr; + + if (!s7_is_integer(ptr_as_int)) + return(method_or_bust(sc, ptr_as_int, sc->c_pointer_symbol, args, sc->type_names[T_INTEGER], 1)); + cptr = (intptr_t)s7_integer_clamped_if_gmp(sc, ptr_as_int); /* (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); + }}} + { + s7_pointer cp = s7_make_c_pointer_with_type(sc, (void *)cptr, 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 cptr) +{ + if (!is_c_pointer(cptr)) + return(method_or_bust_p(sc, cptr, sc->c_pointer_info_symbol, sc->type_names[T_C_POINTER])); + return(c_pointer_info(cptr)); +} + +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 cptr) {return((is_c_pointer(cptr)) ? c_pointer_type(cptr) : NULL);} + +static s7_pointer c_pointer_type_p_p(s7_scheme *sc, s7_pointer cptr) +{ + return((is_c_pointer(cptr)) ? c_pointer_type(cptr) : method_or_bust_lp(sc, cptr, 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 cptr) +{ + return((is_c_pointer(cptr)) ? c_pointer_weak1(cptr) : method_or_bust_lp(sc, cptr, 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 cptr) +{ + return((is_c_pointer(cptr)) ? c_pointer_weak2(cptr) : method_or_bust_lp(sc, cptr, 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 cptr = car(args); + if (!is_c_pointer(cptr)) + return(method_or_bust(sc, cptr, 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(cptr))), c_pointer_type(cptr), c_pointer_info(cptr))); +} + + +/* -------------------------------- 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, "%s[%d]: matched_pair not cleared\n", __func__, __LINE__); + fast = cdr(fast); + if (!is_pair(fast)) return(lst); + if (fast == slow) return(lst); + if (is_matched_pair(fast)) fprintf(stderr, "%s[%d]: matched_pair not cleared\n", __func__, __LINE__); + } + 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; end_temp(sc->y); return(check_wrap_return(fast));} while (0) +#else + #define wrap_return(W) do {fast = W; W = sc->unused; end_temp(sc->y); return(fast);} while (0) +#endif + begin_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 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_pair(p2); + if (is_pair(cdr(p1))) + { + p1 = cdr(p1); + p2 = cdr(p2); + if (is_immutable(p1)) set_immutable_pair(p2); + if (p1 == slow) break; + slow = cdr(slow); + }} +} + +static s7_pointer copy_stack(s7_scheme *sc, s7_pointer new_v, s7_pointer old_v, s7_int 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 (s7_int i = 2; i < top; i += 4) + { + const 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 */ + 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 + */ + 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 (s7_int i = 2; i < top; i += 4) + if (is_pair(ov[i])) + { + const 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) */ + 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 e = sc->curlet; e; e = let_outlet(e)) + if ((is_baffle_let(e)) && + (let_baffle_key(e) == 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 e = sc->curlet; e; e = let_outlet(e)) + if (is_baffle_let(e)) + return(let_baffle_key(e)); + 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); + let_set_baffle_key(sc->curlet, sc->baffle_ctr++); + return(false); +} + + +/* -------------------------------- call/cc -------------------------------- */ +static void make_room_for_cc_stack(s7_scheme *sc) +{ + if ((s7_int)(sc->free_heap_top - sc->free_heap) < (s7_int)(sc->heap_size / 32)) /* we probably never need this much space (8 becomes enormous, 512 seems ok) */ + { /* but this doesn't seem to make much difference in timings */ + call_gc(sc); + if ((s7_int)(sc->free_heap_top - sc->free_heap) < (s7_int)(sc->heap_size / 32)) + resize_heap(sc); + } +} + +s7_pointer s7_make_continuation(s7_scheme *sc) +{ + /* precede this with make_room_for_cc_stack(sc); */ + const s7_int loc = stack_top(sc); + const s7_pointer stack = make_simple_vector(sc, loc); + s7_pointer new_cc; + block_t *block; + + set_full_type(stack, T_STACK); + temp_stack_top(stack) = loc; + begin_temp(sc->x, stack); + copy_stack(sc, stack, sc->stack, loc); + + new_cell(sc, new_cc, T_CONTINUATION); + block = mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + continuation_block(new_cc) = block; + continuation_set_stack(new_cc, stack); + continuation_stack_size(new_cc) = vector_length(continuation_stack(new_cc)); + continuation_stack_start(new_cc) = stack_elements(continuation_stack(new_cc)); + continuation_stack_end(new_cc) = (s7_pointer *)(continuation_stack_start(new_cc) + loc); + continuation_op_stack(new_cc) = copy_op_stack(sc); + continuation_op_loc(new_cc) = (int32_t)(sc->op_stack_now - sc->op_stack); + continuation_op_size(new_cc) = sc->op_stack_size; + continuation_key(new_cc) = find_any_baffle(sc); + continuation_name(new_cc) = sc->F; + end_temp(sc->x); + add_continuation(sc, new_cc); + return(new_cc); +} + +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 dynamic_unwind(s7_scheme *sc, s7_pointer func, s7_pointer e); + +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) + */ + const s7_int cc_top = continuation_stack_top(c); + for (s7_int op_loc = stack_top(sc) - 1; (op_loc > 0) && ((op_loc >= cc_top) || (stack_code(sc->stack, op_loc) != stack_code(continuation_stack(c), op_loc))); op_loc -= 4) + { + const opcode_t op = stack_op(sc->stack, op_loc); + switch (op) + { + case OP_DYNAMIC_WIND: + case OP_LET_TEMP_DONE: + { + const s7_pointer code = stack_code(sc->stack, op_loc); + s7_int s_base = 0; + for (s7_int j = 3; j < cc_top; j += 4) + if (((stack_op(continuation_stack(c), j) == OP_DYNAMIC_WIND) || + (stack_op(continuation_stack(c), j) == OP_LET_TEMP_DONE)) && + (code == stack_code(continuation_stack(c), j))) + { + s_base = op_loc; + break; + } + if (s_base == 0) + { + if (op == OP_DYNAMIC_WIND) + { + if (dynamic_wind_state(code) == dwind_body) + { + dynamic_wind_state(code) = dwind_finish; + if (dynamic_wind_out(code) != sc->F) + sc->value = s7_call(sc, dynamic_wind_out(code), sc->nil); + }} + else let_temp_done(sc, stack_args(sc->stack, op_loc), T_Let(stack_let(sc->stack, op_loc))); + }} + break; + + case OP_DYNAMIC_UNWIND: + { + s7_pointer func = stack_code(sc->stack, op_loc); + s7_pointer args = stack_args(sc->stack, op_loc); + if ((is_pair(cdr(args))) && (is_pair(cddr(args))) && (caddr(args) == sc->T)) + dynamic_unwind(sc, func, args); + } + case OP_DYNAMIC_UNWIND_PROFILE: + set_stack_op(sc->stack, op_loc, OP_GC_PROTECT); + break; + + case OP_LET_TEMP_UNWIND: + let_temp_unwind(sc, stack_code(sc->stack, op_loc), stack_args(sc->stack, op_loc)); + break; + + case OP_LET_TEMP_S7_UNWIND: + starlet_set_1(sc, T_Sym(stack_code(sc->stack, op_loc)), stack_args(sc->stack, op_loc)); + break; + + case OP_LET_TEMP_S7_OPENLETS_UNWIND: + sc->has_openlets = (stack_args(sc->stack, op_loc) != sc->F); + break; + + case OP_BARRIER: + if (op_loc > cc_top) /* 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 (op_loc > cc_top) + call_exit_active(stack_args(sc->stack, op_loc)) = false; + break; + + case OP_UNWIND_INPUT: + if (stack_args(sc->stack, op_loc) != sc->unused) + set_current_input_port(sc, stack_args(sc->stack, op_loc)); /* "args" = port that we shadowed */ + break; + + case OP_UNWIND_OUTPUT: + if (stack_args(sc->stack, op_loc) != sc->unused) + set_current_output_port(sc, stack_args(sc->stack, op_loc)); /* "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 (s7_int op_loc = stack_top(sc) - 1; op_loc < cc_top; op_loc += 4) + { + const opcode_t op = stack_op(continuation_stack(c), op_loc); + if (op == OP_DYNAMIC_WIND) + { + s7_pointer dw = T_Dyn(stack_code(continuation_stack(c), op_loc)); + if (dynamic_wind_in(dw) != sc->F) + sc->value = s7_call(sc, dynamic_wind_in(dw), sc->nil); + dynamic_wind_state(dw) = dwind_body; + } + else + if (op == OP_DEACTIVATE_GOTO) + call_exit_active(stack_args(continuation_stack(c), op_loc)) = 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)); + + { + const 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) ...)) evaluates the body with continuer as a way to goto to the continuation of the body" + #define Q_call_cc s7_make_signature(sc, 2, sc->values_symbol, sc->is_procedure_symbol) + + const s7_pointer func = car(args); /* this is the procedure passed to call/cc */ + if (!is_t_procedure(func)) /* this includes continuations */ + { + if_method_exists_return_value(sc, func, sc->call_cc_symbol, args); + if_method_exists_return_value(sc, func, sc->call_with_current_continuation_symbol, args); + sole_arg_wrong_type_error_nr(sc, sc->call_cc_symbol, func, a_procedure_string); + } + if (((!is_closure(func)) || + (closure_arity(func) != 1)) && + (!s7_is_aritable(sc, func, 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), func)); + + make_room_for_cc_stack(sc); + begin_temp(sc->y, s7_make_continuation(sc)); + if ((is_any_closure(func)) && (is_pair(closure_pars(func))) && (is_symbol(car(closure_pars(func))))) + continuation_name(sc->y) = car(closure_pars(func)); + push_stack(sc, OP_APPLY, list_1_unchecked(sc, sc->y), func); /* apply func to continuation */ + end_temp(sc->y); + return(sc->nil); +} + +static void op_call_cc(s7_scheme *sc) /* OP_CALL_CC in eval via optimize_c_function_one_arg */ +{ + make_room_for_cc_stack(sc); + begin_temp(sc->y, s7_make_continuation(sc)); + continuation_name(sc->y) = caar(opt2_pair(sc->code)); /* caadadr(sc->code) */ + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, continuation_name(sc->y), sc->y)); + end_temp(sc->y); + 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 void call_with_exit(s7_scheme *sc) +{ + s7_int op_loc, new_stack_top, quit = 0; + + if (!call_exit_active(sc->code)) + error_nr(sc, sc->invalid_exit_function_symbol, + (is_symbol(call_exit_name(sc->code))) ? + set_elist_2(sc, wrap_string(sc, "call-with-exit exit procedure, ~A, called outside its block", 59), call_exit_name(sc->code)) : + set_elist_1(sc, wrap_string(sc, "call-with-exit exit procedure called outside its block", 54))); + + 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 */ + op_loc = stack_top(sc) - 1; + /* op is entirely op_deactivate_goto tgc, for_each_2|3 tcase, dox_step_o texit, lots of ops s7test.scm */ + /* if (stack_op(sc->stack, op_loc) == OP_DEACTIVATE_GOTO) {call_exit_active(stack_args(sc->stack, op_loc)) = false; goto SET_VALUE;} saves >54 in tgc */ + + do { + switch (stack_op(sc->stack, op_loc)) /* the hit rate here is good; exiters[op] slowed us down! (see tmp) tgc/texit slower, tcase faster */ + { + case OP_DYNAMIC_WIND: + { + const s7_pointer lx = T_Dyn(stack_code(sc->stack, op_loc)); + 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, op_loc, OP_GC_PROTECT); + dynamic_unwind(sc, stack_code(sc->stack, op_loc), stack_args(sc->stack, op_loc)); + 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, op_loc)) = false; + break; + + case OP_LET_TEMP_DONE: + { + s7_pointer old_args = sc->args; + let_temp_done(sc, stack_args(sc->stack, op_loc), T_Let(stack_let(sc->stack, op_loc))); + sc->args = old_args; + } + break; + + case OP_LET_TEMP_UNWIND: + let_temp_unwind(sc, stack_code(sc->stack, op_loc), stack_args(sc->stack, op_loc)); + break; + + case OP_LET_TEMP_S7_UNWIND: + starlet_set_1(sc, T_Sym(stack_code(sc->stack, op_loc)), stack_args(sc->stack, op_loc)); + break; + + case OP_LET_TEMP_S7_OPENLETS_UNWIND: + sc->has_openlets = (stack_args(sc->stack, op_loc) != 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 port = T_Pro(stack_code(sc->stack, op_loc)); /* "code" = port that we opened */ + s7_close_output_port(sc, port); + port = stack_args(sc->stack, op_loc); /* "args" = port that we shadowed, if not # */ + if (port != sc->unused) + set_current_output_port(sc, port); + } + break; + + case OP_UNWIND_INPUT: + s7_close_input_port(sc, T_Pri(stack_code(sc->stack, op_loc))); /* "code" = port that we opened */ + if (stack_args(sc->stack, op_loc) != sc->unused) + set_current_input_port(sc, stack_args(sc->stack, op_loc)); /* "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, op_loc) == OP_MAP_UNWIND)) fprintf(stderr, "%s[%d]: unwind %" ld64 "\n", __func__, __LINE__, sc->map_call_ctr); + break; + } + op_loc -= 4; + } while (op_loc > 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 (s7_int 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 new_goto; + new_cell(sc, new_goto, T_GOTO); + call_exit_goto_loc(new_goto) = stack_top(sc); + call_exit_op_loc(new_goto) = (int32_t)(sc->op_stack_now - sc->op_stack); + call_exit_active(new_goto) = true; + call_exit_name(new_goto) = name; + return(new_goto); +} + +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) + + const s7_pointer func = car(args); + s7_pointer new_goto; + if (is_any_closure(func)) /* lambda or lambda* */ + { + new_goto = make_goto(sc, ((is_pair(closure_pars(func))) && (is_symbol(car(closure_pars(func))))) ? car(closure_pars(func)) : sc->F); + push_stack(sc, OP_DEACTIVATE_GOTO, new_goto, func); /* this means call-with-exit is not tail-recursive */ + push_stack(sc, OP_APPLY, cons_unchecked(sc, new_goto, sc->nil), func); + 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(func)) + return(method_or_bust_p(sc, func, sc->call_with_exit_symbol, 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, "call-with-exit argument should be a function of one argument: ~S", 64), func)); + if (is_continuation(func)) /* (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), func)); + new_goto = make_goto(sc, sc->F); + call_exit_active(new_goto) = false; + return((is_c_function(func)) ? c_function_call(func)(sc, set_plist_1(sc, new_goto)) : s7_apply_function_star(sc, func, set_plist_1(sc, new_goto))); +} + +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)); + /* goto begin */ +} + +static void op_call_with_exit_o(s7_scheme *sc) +{ + op_call_with_exit(sc); + sc->code = car(sc->code); + /* goto eval */ +} + +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 new_string; + new_cell(sc, new_string, T_STRING | T_SAFE_PROCEDURE); + string_block(new_string) = block; + string_value(new_string) = (char *)block_data(block); + string_length(new_string) = len; + string_value(new_string)[len] = '\0'; + string_hash(new_string) = 0; + add_string(sc, new_string); + return(new_string); +} + +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) /* no gcd needed in this case */ +{ + s7_pointer new_ratio; + if (den < 0) + { + if ((num == S7_INT64_MIN) || (den == S7_INT64_MIN)) /* assume no gcd involved */ + return(make_real(sc, (long_double)num / (long_double)den)); + if (den == -1) + return(make_integer(sc, -num)); + new_cell(sc, new_ratio, T_RATIO); + set_numerator(new_ratio, -num); + set_denominator(new_ratio, -den); + } + else + { + if (den == 1) + return(make_integer(sc, num)); + new_cell(sc, new_ratio, T_RATIO); + set_numerator(new_ratio, num); + set_denominator(new_ratio, den); + } + return(new_ratio); +} + +static /* inline */ s7_pointer make_simpler_ratio(s7_scheme *sc, s7_int num, s7_int den) /* no gcd needed, and den > 1 */ +{ + s7_pointer new_ratio; + if ((S7_DEBUGGING) && (den < 2)) fprintf(stderr, "%s[%d]: denominator: %" ld64 "/n", __func__, __LINE__, den); + new_cell(sc, new_ratio, T_RATIO); + set_numerator(new_ratio, num); + set_denominator(new_ratio, den); + return(new_ratio); +} + +static inline s7_pointer make_simpler_ratio_or_integer(s7_scheme *sc, s7_int num, s7_int den) /* nom gcd needed and den > 0 (might be 1) */ +{ + s7_pointer new_ratio; + if ((S7_DEBUGGING) && (den <= 0)) fprintf(stderr, "%s[%d]: denominator: %" ld64 "/n", __func__, __LINE__, den); + if (den == 1) + return(make_integer(sc, num)); + new_cell(sc, new_ratio, T_RATIO); + set_numerator(new_ratio, num); + set_denominator(new_ratio, den); + return(new_ratio); +} + +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 {s7_int ix; double fx;} decode_float_t; + +static double nan_with_payload(s7_int 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) +{ + return(make_real(sc, nan_with_payload(payload))); +} + +static s7_pointer g_nan(s7_scheme *sc, s7_pointer args) +{ + #define H_nan "(nan (int 0)) 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 payload; + if (is_null(args)) return(real_NaN); /* payload defaults to 0 */ + payload = car(args); + if (!is_t_integer(payload)) + return(method_or_bust_p(sc, payload, sc->nan_symbol, sc->type_names[T_INTEGER])); + if (integer(payload) < 0) + sole_arg_out_of_range_error_nr(sc, sc->nan_symbol, set_elist_1(sc, payload), it_is_negative_string); + if (integer(payload) >= NAN_PAYLOAD_LIMIT) + sole_arg_out_of_range_error_nr(sc, sc->nan_symbol, set_elist_1(sc, payload), it_is_too_large_string); + return(make_nan_with_payload(sc, integer(payload))); +} + +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 nan = car(args); + if (!is_t_real(nan)) + return(method_or_bust_p(sc, nan, sc->nan_payload_symbol, sc->type_names[T_REAL])); + if (!is_NaN(real(nan))) /* for complex case, use real-part etc (see s7test.scm) */ + sole_arg_wrong_type_error_nr(sc, sc->nan_payload_symbol, nan, wrap_string(sc, "a NaN", 5)); + return(make_integer(sc, nan_payload(real(nan)))); +} + +/* 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 new_bgi; + new_cell(sc, new_bgi, T_BIG_INTEGER); + big_integer_bgi(new_bgi) = alloc_bigint(sc); + mpz_set(big_integer(new_bgi), val); + add_big_integer(sc, new_bgi); + return(new_bgi); +} + +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 new_bgf; + new_cell(sc, new_bgf, T_BIG_REAL); + big_real_bgf(new_bgf) = alloc_bigflt(sc); + add_big_real(sc, new_bgf); + mpfr_set_z(big_real(new_bgf), val, MPFR_RNDN); + return(new_bgf); +} +#endif + +static s7_pointer mpq_to_big_ratio(s7_scheme *sc, mpq_t val) +{ + s7_pointer new_bgr; + new_cell(sc, new_bgr, T_BIG_RATIO); + big_ratio_bgr(new_bgr) = alloc_bigrat(sc); + add_big_ratio(sc, new_bgr); + mpq_set(big_ratio(new_bgr), val); + return(new_bgr); +} + +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 new_bgf; + new_cell(sc, new_bgf, T_BIG_REAL); + big_real_bgf(new_bgf) = alloc_bigflt(sc); + add_big_real(sc, new_bgf); + mpfr_set_q(big_real(new_bgf), val, MPFR_RNDN); + return(new_bgf); +} +#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 new_bgf; + new_cell(sc, new_bgf, T_BIG_REAL); + add_big_real(sc, new_bgf); + big_real_bgf(new_bgf) = alloc_bigflt(sc); + mpfr_set(big_real(new_bgf), val, MPFR_RNDN); + return(new_bgf); +} + +static s7_pointer mpc_to_number(s7_scheme *sc, mpc_t val) +{ + s7_pointer new_bgc; + if (mpfr_zero_p(mpc_imagref(val))) + return(mpfr_to_big_real(sc, mpc_realref(val))); + new_cell(sc, new_bgc, T_BIG_COMPLEX); + big_complex_bgc(new_bgc) = alloc_bigcmp(sc); + add_big_complex(sc, new_bgc); + mpc_set(big_complex(new_bgc), val, MPC_RNDNN); + return(new_bgc); +} + +/* 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 new_bgi; + new_cell(sc, new_bgi, T_BIG_INTEGER); + big_integer_bgi(new_bgi) = alloc_bigint(sc); + mpz_set_si(big_integer(new_bgi), val); + add_big_integer(sc, new_bgi); + return(new_bgi); +} + +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 new_bgr; + new_cell(sc, new_bgr, T_BIG_RATIO); + big_ratio_bgr(new_bgr) = alloc_bigrat(sc); + add_big_ratio(sc, new_bgr); + mpq_set_si(big_ratio(new_bgr), num, den); + return(new_bgr); +} + +static s7_pointer s7_double_to_big_real(s7_scheme *sc, s7_double rl) +{ + s7_pointer new_bgf; + new_cell(sc, new_bgf, T_BIG_REAL); + big_real_bgf(new_bgf) = alloc_bigflt(sc); + add_big_real(sc, new_bgf); + mpfr_set_d(big_real(new_bgf), rl, MPFR_RNDN); + return(new_bgf); +} + +static s7_pointer s7_double_to_big_complex(s7_scheme *sc, s7_double rl, s7_double im) +{ + s7_pointer new_bgc; + new_cell(sc, new_bgc, T_BIG_COMPLEX); + add_big_complex(sc, new_bgc); + big_complex_bgc(new_bgc) = alloc_bigcmp(sc); + mpc_set_d_d(big_complex(new_bgc), rl, im, MPC_RNDNN); + return(new_bgc); +} + +static s7_pointer big_pi(s7_scheme *sc) +{ + s7_pointer new_bgf; + new_cell(sc, new_bgf, T_BIG_REAL | T_IMMUTABLE); + big_real_bgf(new_bgf) = alloc_bigflt(sc); + add_big_real(sc, new_bgf); + mpfr_const_pi(big_real(new_bgf), MPFR_RNDN); + return(new_bgf); +} + +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 func = find_method_with_let(sc, p, sc->is_integer_symbol); + if (func != sc->undefined) + return(is_true(sc, s7_apply_function(sc, func, 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 new_bgf; + new_cell(sc, new_bgf, T_BIG_REAL); + big_real_bgf(new_bgf) = alloc_bigflt(sc); + add_big_real(sc, new_bgf); + + switch (type(p)) + { + case T_INTEGER: + mpfr_set_si(big_real(new_bgf), 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 s7_int ratios that will still look the same. We have to do the bignum divide by hand. + */ + mpq_set_si(sc->mpq_1, numerator(p), denominator(p)); + mpfr_set_q(big_real(new_bgf), sc->mpq_1, MPFR_RNDN); + break; + default: + mpfr_set_d(big_real(new_bgf), s7_real(p), MPFR_RNDN); + break; + } + return(new_bgf); +} +#endif + +static s7_pointer s7_number_to_big_complex(s7_scheme *sc, s7_pointer p) +{ + s7_pointer new_bgc; + new_cell(sc, new_bgc, T_BIG_COMPLEX); + big_complex_bgc(new_bgc) = alloc_bigcmp(sc); + add_big_complex(sc, new_bgc); + + switch (type(p)) + { + case T_INTEGER: + mpc_set_si(big_complex(new_bgc), 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(new_bgc), sc->mpfr_1, MPC_RNDNN); + break; + case T_REAL: + mpc_set_d(big_complex(new_bgc), s7_real(p), MPC_RNDNN); + break; + default: + mpc_set_d_d(big_complex(new_bgc), real_part(p), imag_part(p), MPC_RNDNN); + break; + } + return(new_bgc); +} + +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(make_nan_with_payload(sc, __LINE__)); + 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(make_nan_with_payload(sc, __LINE__)); + 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(make_nan_with_payload(sc, __LINE__)); + 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(make_nan_with_payload(sc, __LINE__)); + 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(make_nan_with_payload(sc, __LINE__)); + 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(make_nan_with_payload(sc, __LINE__)); + 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 new_bgc; + new_cell(sc, new_bgc, T_BIG_COMPLEX); + big_complex_bgc(new_bgc) = alloc_bigcmp(sc); + add_big_complex(sc, new_bgc); + mpc_set_fr_fr(big_complex(new_bgc), rl ,im, MPC_RNDNN); + return(new_bgc); +} + +static block_t *mpfr_to_string(s7_scheme *sc, mpfr_t val, int32_t radix) +{ + 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)); + { + mp_exp_t expptr; + block_t *b = callocate(sc, sc->bignum_precision + 32); + char *str = mpfr_get_str((char *)block_data(b), &expptr, radix, 0, val, MPFR_RNDN); + int32_t ep = (int32_t)expptr; + s7_int i, 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'; + { + block_t *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) + { + const s7_int len = safe_strlen((char *)block_data(str)); + if (width > len) + { + const 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 new_bgr; + 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, new_bgr, T_BIG_RATIO); + big_ratio_bgr(new_bgr) = alloc_bigrat(sc); + add_big_ratio(sc, new_bgr); + mpq_set(big_ratio(new_bgr), sc->mpq_1); + return(new_bgr); +} + +static s7_pointer string_to_big_real(s7_scheme *sc, const char *str, int32_t radix) +{ + s7_pointer new_bgf; + new_cell(sc, new_bgf, T_BIG_REAL); + big_real_bgf(new_bgf) = alloc_bigflt(sc); + add_big_real(sc, new_bgf); + mpfr_set_str(big_real(new_bgf), str, radix, MPFR_RNDN); + return(new_bgf); +} + +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! + */ + const s7_int d = string_to_integer(dstr, radix, &overflow); + if (!overflow) + { + s7_int n; + if (d == 0) return(make_nan_with_payload(sc, __LINE__)); /* this NaN can end up as a hash-table key -- maybe the payload is confusing? */ + 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); /* gmp version */ + +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 x, s7_pointer y) +{ + /* either or both can be big here, but not neither, and types might not match at all */ + switch (type(x)) + { + case T_INTEGER: + return((is_t_big_integer(y)) && (mpz_cmp_si(big_integer(y), integer(x)) == 0)); + case T_BIG_INTEGER: + 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)); + case T_RATIO: + if (!is_t_big_ratio(y)) return(false); + mpq_set_si(sc->mpq_1, numerator(x), denominator(x)); + return(mpq_equal(sc->mpq_1, big_ratio(y))); + case T_BIG_RATIO: + if (is_t_big_ratio(y)) return(mpq_equal(big_ratio(x), big_ratio(y))); + if (!is_t_ratio(y)) return(false); + 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(x))) return(false); + return((is_t_big_real(y)) && (!mpfr_nan_p(big_real(y))) && (mpfr_cmp_d(big_real(y), real(x)) == 0)); + case T_BIG_REAL: + if (mpfr_nan_p(big_real(x))) return(false); + if (is_t_big_real(y)) return((!mpfr_nan_p(big_real(y))) && (mpfr_equal_p(big_real(x), big_real(y)))); + return((is_t_real(y)) && (!is_NaN(real(y))) && (mpfr_cmp_d(big_real(x), real(y)) == 0)); + case T_COMPLEX: + if ((is_NaN(real_part(x))) || (is_NaN(imag_part(x)))) return(false); + if (!is_t_big_complex(y)) return(false); + if ((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(sc->mpc_1, big_complex(y)) == 0); + case T_BIG_COMPLEX: + 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)) + { + if ((mpfr_nan_p(mpc_realref(big_complex(y)))) || (mpfr_nan_p(mpc_imagref(big_complex(y))))) + return(false); + return(mpc_cmp(big_complex(x), big_complex(y)) == 0); + } + if (is_t_complex(y)) + { + if ((is_NaN(real_part(y))) || (is_NaN(imag_part(y)))) return(false); + mpc_set_d_d(sc->mpc_2, real_part(y), imag_part(y), MPC_RNDNN); + return(mpc_cmp(big_complex(x), 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 s7_ints! */ + +#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(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) +#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 */ + #define _Complex_I 1.0 + #define creal(x) 0.0 + #define cimag(x) 0.0 + #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_1(s7_int u, s7_int v) +{ + /* can't take abs of these 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); +} + +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 (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 < 0) + { + if (u == S7_INT64_MIN) return(c_gcd_1(u, v)); + a = -u; + } + else a = u; + if (v < 0) + { + if (v == S7_INT64_MIN) return(c_gcd_1(u, v)); + b = -v; + } + else b = v; + 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; + const double val = (double)p0 / (double)q0; + + if (((x0 <= val) && (val <= x1)) || (e1 == 0.0) || (e1p == 0.0) || (tries > 100)) + { + if ((q0 == S7_INT64_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, "%s[%d]: %f %" ld64 "/0\n", __func__, __LINE__, ux, p0); + } + if ((S7_DEBUGGING) && (*denom < 0)) fprintf(stderr, "%s[%d]: denominator is %" ld64 "?\n", __func__, __LINE__, *denom); + 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_simpler_ratio_or_integer(sc, numer, denom)); + return(make_real(sc, x)); +} + +s7_pointer s7_make_integer(s7_scheme *sc, s7_int n) +{ + s7_pointer new_int; + if (is_small_int(n)) + return(small_int(n)); + new_cell(sc, new_int, T_INTEGER); + set_integer(new_int, n); + return(new_int); +} + +#if S7_DEBUGGING +#define make_mutable_integer(Sc, N) make_mutable_integer_1(Sc, N, __func__, __LINE__) +static s7_pointer make_mutable_integer_1(s7_scheme *sc, s7_int n, const char *func, int line) +#else +static s7_pointer make_mutable_integer(s7_scheme *sc, s7_int n) +#endif +{ + s7_pointer new_int; + new_cell(sc, new_int, T_INTEGER | T_MUTABLE | T_IMMUTABLE); +#if S7_DEBUGGING + new_int->carrier_line = __LINE__; + new_int->gc_line = line; + new_int->gc_func = func; +#endif + set_integer(new_int, n); + return(new_int); +} + +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); +} + +#if S7_DEBUGGING +#define make_mutable_real(Sc, N) make_mutable_real_1(Sc, N, __func__, __LINE__) +static s7_pointer make_mutable_real_1(s7_scheme *sc, s7_double n, const char *func, int line) +{ + s7_pointer x; + new_cell(sc, x, T_REAL | T_MUTABLE | T_IMMUTABLE); + x->carrier_line = __LINE__; + x->gc_line = line; + x->gc_func = func; + set_real(x, n); + return(x); +} +#else +#define make_mutable_real(Sc, N) s7_make_mutable_real(Sc, N) +#endif + +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); +} + +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_pointer make_mutable_complex(s7_scheme *sc, s7_double rl, s7_double im) +{ + s7_pointer x; + new_cell(sc, x, T_COMPLEX | T_MUTABLE | T_IMMUTABLE); /* do we need to change to real if imag==0? */ + set_real_part(x, rl); + set_imag_part(x, im); + 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 no_return 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 no_return 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) +{ + if (b < 0) + { + if (b == S7_INT64_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 == b) return(int_one); */ + if (a & 1) + return(make_real(sc, (long_double)a / (long_double)b)); + a /= 2; + b /= 2; + } + if (a == S7_INT64_MIN) + { + if (b & 1) + return(make_real(sc, (long_double)a / (long_double)b)); + a /= 2; + b /= 2; + } + a = -a; + b = -b; + } + if (a == S7_INT64_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)); + { + s7_pointer x; + 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, "s7_make_ratio", 13), 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 /* faster startup if 32, but much slower in tbig; also waiting until use to init_pows is faster at startup, but slower in tbig */ +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 */ + 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 mandatory, but now (Oct-2024) the difference is smaller (still a ca. factor of 4): + * in tbig/callgrind with dtoa 6254M, with C's printf stuff instead 24410M + */ + +#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(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) /* const dtoa_np* here and elsewhere is slower! perverse */ +{ + 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); /* unaligned */ + 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); /* unaligned */ + 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; + const bool sign = (n < 0); + s7_int pown; + + if ((radix < 2) || (radix > 16)) + return(0); + if (sign) + { + 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); + } + 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 = (num < 0); + if (sign) + { + if (num == S7_INT64_MIN) + { + (*nlen) = 20; + return((const char *)"-9223372036854775808"); + } + num = -num; /* we need a positive index below */ + } + p = (char *)(sc->int_to_str1 + INT_TO_STR_SIZE - 1); + op = p; + *p-- = '\0'; + do {*p-- = "0123456789"[num % 10]; num /= 10;} while (num); + if (sign) + { + *p = '-'; + (*nlen) = op - p; + return(p); + } + (*nlen) = op - p - 1; + return(++p); +} + +static const char *integer_to_string_no_length(s7_scheme *sc, s7_int num) /* do not free the returned string */ +{ + char *p; + const bool sign = (num < 0); + if (sign) + { + if (num == S7_INT64_MIN) + return("-9223372036854775808"); + num = -num; + } + p = (char *)(sc->int_to_str2 + INT_TO_STR_SIZE - 1); + *p-- = '\0'; + 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'; /* need to retain 'str' as output */ + len = 4; + } + else + 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) + 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)) /* set to 6 in format! need ~,16G to hit this code */ + { + /* (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. + */ + if (obj == real_pi) + { + static const char pi_name[] = "3.141592653589793"; /* array form for ISO C++ */ + (*nlen) = 17; + memcpy((void *)(sc->num_to_str), (void *)pi_name, 17); + return(sc->num_to_str); /* code below assumes we return sc->num_to_str in this case -- ugly! */ + } + 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); + const char *dp = (const 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 *result; + 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 base = cadr(args); + if (s7_is_integer(base)) + radix = s7_integer_clamped_if_gmp(sc, base); + else return(method_or_bust(sc, base, 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, base, 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)); + } + result = number_to_string_base_10(sc, x, 0, sc->float_format_precision, 'g', &nlen, p_write); +#else + if (is_t_integer(x)) + result = integer_to_string(sc, integer(x), &nlen); + else result = number_to_string_base_10(sc, x, 0, sc->float_format_precision, 'g', &nlen, p_write); +#endif + return(inline_make_string_with_length(sc, result, 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 *result; + if (!is_number(p)) + return(method_or_bust_p(sc, p, sc->number_to_string_symbol, a_number_string)); + result = number_to_string_base_10(sc, p, 0, sc->float_format_precision, 'g', &nlen, p_write); + return(inline_make_string_with_length(sc, result, nlen)); +#endif +} + +static s7_pointer number_to_string_p_i(s7_scheme *sc, s7_int p) +{ + s7_int nlen = 0; + const char *result = integer_to_string(sc, p, &nlen); + return(inline_make_string_with_length(sc, result, nlen)); +} +/* not number_to_string_p_d! */ + +static s7_pointer number_to_string_p_pp(s7_scheme *sc, s7_pointer num, s7_pointer base) +{ +#if WITH_GMP + return(g_number_to_string(sc, set_plist_2(sc, num, base))); +#else + s7_int nlen = 0, radix; + block_t *b; + + if (!is_number(num)) + wrong_type_error_nr(sc, sc->number_to_string_symbol, 1, num, a_number_string); + if (!is_t_integer(base)) + wrong_type_error_nr(sc, sc->number_to_string_symbol, 2, base, sc->type_names[T_INTEGER]); + radix = integer(base); + if ((radix < 2) || (radix > 16)) + out_of_range_error_nr(sc, sc->number_to_string_symbol, int_two, base, a_valid_radix_string); + b = number_to_string_with_radix(sc, num, 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 *)Malloc(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 *)Malloc(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; + const 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_pair(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 readers; + if (is_null(cadr(args))) return(sc->nil); + 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 (readers = cadr(args); is_pair(readers); readers = cdr(readers)) + if ((!is_pair(car(readers))) || + (!is_character(caar(readers))) || + (!is_procedure(cdar(readers)))) + 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(readers)) + 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) +{ + const s7_int len = safe_strlen(name); + char *newstr = (char *)Malloc(len + 2); + s7_pointer undef; + new_cell(sc, undef, 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(undef, len + 1); + undefined_name(undef) = newstr; + add_undefined(sc, undef); + return(undef); +} + +static int32_t inchar(s7_pointer port) +{ + int32_t c; + if (is_file_port(port)) + c = fgetc(port_file(port)); /* not uint8_t! -- could be EOF */ + else + { + if (port_data_size(port) <= port_position(port)) + return(EOF); + c = (uint8_t)port_data(port)[port_position(port)++]; + } + if (c == '\n') + port_line_number(port)++; + return(c); +} + +static void backchar(char c, s7_pointer port) +{ + if (c == '\n') + port_line_number(port)--; + if (is_file_port(port)) + ungetc(c, port_file(port)); + else + if (port_position(port) > 0) + port_position(port)--; +} + +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 port) +{ + /* 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 (port) /* #<"..."> which gets here as name="#<" */ + { + const s7_int len = safe_strlen(name); + if ((name[len - 1] != '>') && + (is_input_port(port)) && + (port != sc->standard_input)) + { + if (s7_peek_char(sc, port) != chars[(uint8_t)'"']) /* if not #<"...">, just return it */ + return(make_undefined(sc, name)); + /* PERHAPS: strchr port-data '>'?? it might be # etc -- what would this break? maybe extend section below */ + + if (is_string_port(port)) /* probably unnecessary (see below) */ + { + s7_int c = inchar(port); + const char *pstart = (const char *)(port_data(port) + port_position(port)); + const char *p = strchr(pstart, (int)'"'); + s7_int added_len; + char *buf; + if (!p) + { + backchar(c, port); + 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(port) += added_len; + { + s7_pointer result = make_undefined(sc, (const char *)buf); + free(buf); + return(result); + }}}} + 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 port, 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] == '_') + { + /* we handle #_ before looking at *#readers* below (via check_sharp_readers) because #_ 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)) && (initial_value_is_defined(sym))) +#if 0 + return(initial_value(sym)); +#else + { + if (!is_initial_value(initial_value(sym))) + copy_initial_value(sc, sym); + return(initial_value(sym)); + } +#endif + /* 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_pair(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, port)); /* port here because #<"..."> comes here as "<" so name[1] is '\0'! */ + + switch (name[0]) + { + /* -------- #< ... > -------- */ + case '<': + if (c_strings_are_equal(name, "")) return(sc->unspecified); + if (c_strings_are_equal(name, "")) return(sc->undefined); + if (c_strings_are_equal(name, "")) return(eof_object); + return(unknown_sharp_constant(sc, name, port)); + + /* -------- #o #x #b -------- */ + case 'o': /* #o (octal) */ + case 'x': /* #x (hex) */ + case 'b': /* #b (binary) */ + { + s7_pointer result = make_atom(sc, (char *)(name + 1), (name[0] == 'o') ? 8 : ((name[0] == 'x') ? 16 : 2), NO_SYMBOLS, with_error); + if ((error_if_bad_number) && (result == 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(result); + } + + /* -------- #\... -------- */ + 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 '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 'd': if (c_strings_are_equal(name + 1, "delete")) return(chars[0x7f]); break; + case 'e': if (c_strings_are_equal(name + 1, "escape")) return(chars[0x1b]); break; + case 'l': if (c_strings_are_equal(name + 1, "linefeed")) return(chars[(uint8_t)'\n']); break; + case 'r': if (c_strings_are_equal(name + 1, "return")) return(chars[(uint8_t)'\r']); break; + case 's': if (c_strings_are_equal(name + 1, "space")) return(chars[(uint8_t)' ']); break; + case 't': if (c_strings_are_equal(name + 1, "tab")) return(chars[(uint8_t)'\t']); break; + /* to print something in bold-face: (format *stderr* "~Ahiho~A~%" (string-append (string #\escape) "[1m") (string-append (string #\escape) "[22m")) */ + + case 'x': + /* #\x is just x, but apparently #\x 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); +} + +static const char *radstr[17] = {NULL, NULL, "01", "012", "0123", "01234", "012345", "0123456", "01234567", "012345678", "0123456789", + "0123456789aA", "0123456789aAbB", "0123456789aAbBcC", "0123456789aAbBcCdD", "0123456789aAbBcCdDeE", "0123456789aAbBcCdDeEfF"}; + +#if WITH_GMP +static s7_double string_to_double_with_radix(const char *ur_str, int32_t radix, bool *overflow) +#else +static s7_double string_to_double_with_radix(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 sign = 1, frac_len, int_len, dig, exponent = 0; + const int32_t max_len = s7_int_digits_by_radix[radix]; + s7_int 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; */ + int_len = strspn((const char *)str, radstr[radix]); /* this is faster than the while loop with digits[] */ + str += int_len; + + if (*str == '.') str++; + fpart = str; + /* while (digits[(int32_t)(*str)] < radix) str++; */ + /* frac_len = str - fpart; */ + frac_len = strspn((const char *)str, radstr[radix]); + str += frac_len; + + 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 (int32_t 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 (int32_t 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 (int32_t 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; + s7_int frpart = 0; + + /* 98765432101234567890987654321.0e-20 987654321.012346 + * 98765432101234567890987654321.0e-29 0.98765432101235 + * 98765432101234567890987654321.0e-30 0.098765432101235 + * 98765432101234567890987654321.0e-28 9.8765432101235 + */ + for (int32_t i = 0; i < len; i++) + int_part = digits[(int32_t)(*str++)] + (int_part * radix); + flen = -exponent; + if (flen > max_len) + flen = max_len; + for (int32_t 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 (int32_t 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 (int32_t 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 (int32_t 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 result; + snprintf(buf, len, "", name); + result = make_undefined(sc, (const char *)buf); /* 123123123123123123123123123123 -> +inf.0 originally, but now # */ + liberate(sc, b); + return(result); +} +#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) +{ + const 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, s7_int rl_len) +{ + const 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; + const char sep = sc->number_separator; + s7_int len, j = 0; + + 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 (s7_int i = 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'; + { + s7_pointer result = string_to_number(sc, new_name, radix); + liberate(sc, b); + return(result); + } +} +#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); /* not make_nan_with_payload(sc, __LINE__) here since it says "0" */ + 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. or +/-nan.+/-...i */ + if (local_strncmp(p, "an.", 3)) /* +nan. */ + { + bool overflow = false; + int32_t i; + for (i = 3; is_digit(p[i], 10); i++); + if ((p[i] == '+') || (p[i] == '-')) /* complex case */ + { + s7_int 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)) && /* unaligned */ + ((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; + s7_int 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); + 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); + else + { + if (slash2) /* complex part I think */ + { + /* same as above: 0-0/100000000000000000000000000000000000000i */ + s7_int den; + const s7_int 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)); +#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; + const s7_int 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); /* nan.__LINE__ here seems less than optimal */ + 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))) + { + const 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 0 + if (is_NaN(real(x))) + return((nan_payload(real(x)) > 0) ? x : real_NaN); /* (abs -nan.0) -> +nan.0?? */ +#endif + 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 new_bgr; + 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, new_bgr, T_BIG_RATIO); + big_ratio_bgr(new_bgr) = alloc_bigrat(sc); + add_big_ratio(sc, new_bgr); + mpq_set_num(big_ratio(new_bgr), sc->mpz_1); + mpq_set_den(big_ratio(new_bgr), sc->mpz_2); + return(new_bgr); + } +#else + if (numerator(x) == S7_INT64_MIN) + return(make_ratio(sc, S7_INT64_MAX, denominator(x))); /* not rationalized, so can't call make_simpler_ratio */ +#endif + return(make_simpler_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);} /* TODO: very slow in tcc */ +static s7_int abs_i_i(s7_int x) {return((x < 0) ? (-x) : x);} +/* TODO: (abs|magnitude -9223372036854775808) won't work here */ + + +/* -------------------------------- magnitude -------------------------------- */ +static double my_hypot(double x, double y) +{ + /* useless: if (x == 0.0) return(fabs(y)); if (y == 0.0) return(fabs(x)); if (is_NaN(x)) return(x); if (is_NaN(y)) return(y); */ + if ((fabs(x) < 1.0e6) && (fabs(y) < 1.0e6)) /* max error is ca. e-14 */ + return(sqrt(x * x + y * y)); /* timing diffs: 62 for this form, 107 if just libm's hypot */ + return(hypot(x, y)); /* libm's hypot protects against over/underflow */ +} + +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) < 0) + { + if (integer(x) == S7_INT64_MIN) return(mostfix); + /* (magnitude -9223372036854775808) -> -9223372036854775808 + * same thing happens in abs, lcm and gcd: (gcd -9223372036854775808) -> -9223372036854775808 + */ + return(make_integer(sc, -integer(x))); + } + return(x); + case T_RATIO: + return((numerator(x) < 0) ? make_simpler_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);} +static s7_pointer magnitude_p_z(s7_scheme *sc, s7_pointer z) {return(make_real(sc, my_hypot(real_part(z), imag_part(z))));} + +#if 0 +static s7_pointer magnitude_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ +#if !WITH_GMP + s7_pointer arg = cadr(expr); + if ((is_pair(arg)) && (has_fn(arg)) && (fn_proc(arg) == complex_vector_ref_p_pi)) + set_fn_direct(arg, complex_vector_ref_p_pi_wrapped); +#endif + return(func); +} +#endif + +/* -------------------------------- 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. + */ + + const s7_pointer num = car(args); + rat_locals_t *r = (sc->ratloc) ? sc->ratloc : init_rat_locals_t(sc); + + switch (type(num)) + { + case T_INTEGER: + mpfr_set_si(r->ux, integer(num), MPFR_RNDN); + break; + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(num), denominator(num)); + mpfr_set_q(r->ux, sc->mpq_1, MPFR_RNDN); + break; + case T_REAL: + if (is_NaN(real(num))) + out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, num, it_is_nan_string); + if (is_inf(real(num))) + out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, num, it_is_infinite_string); + mpfr_set_d(r->ux, real(num), MPFR_RNDN); + break; + case T_BIG_INTEGER: + mpfr_set_z(r->ux, big_integer(num), MPFR_RNDN); + break; + case T_BIG_RATIO: + mpfr_set_q(r->ux, big_ratio(num), MPFR_RNDN); + break; + case T_BIG_REAL: + if (mpfr_nan_p(big_real(num))) + out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, num, it_is_nan_string); + if (mpfr_inf_p(big_real(num))) + out_of_range_error_nr(sc, sc->rationalize_symbol, int_one, num, it_is_infinite_string); + mpfr_set(r->ux, big_real(num), MPFR_RNDN); + break; + case T_COMPLEX: case T_BIG_COMPLEX: + wrong_type_error_nr(sc, sc->rationalize_symbol, 1, num, sc->type_names[T_REAL]); + default: + return(method_or_bust(sc, num, 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 + { + const s7_pointer err = cadr(args); + switch (type(err)) + { + case T_INTEGER: + mpfr_set_si(r->error, integer(err), MPFR_RNDN); + break; + case T_RATIO: + mpq_set_si(sc->mpq_1, numerator(err), denominator(err)); + mpfr_set_q(r->error, sc->mpq_1, MPFR_RNDN); + break; + case T_REAL: + if (is_NaN(real(err))) + out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, err, it_is_nan_string); + if (is_inf(real(err))) + return(int_zero); + mpfr_set_d(r->error, real(err), MPFR_RNDN); + break; + case T_BIG_INTEGER: + mpfr_set_z(r->error, big_integer(err), MPFR_RNDN); + break; + case T_BIG_RATIO: + mpfr_set_q(r->error, big_ratio(err), MPFR_RNDN); + break; + case T_BIG_REAL: + if (mpfr_nan_p(big_real(err))) + out_of_range_error_nr(sc, sc->rationalize_symbol, int_two, err, it_is_nan_string); + if (mpfr_inf_p(big_real(err))) + return(int_zero); + mpfr_set(r->error, big_real(err), MPFR_RNDN); + break; + case T_COMPLEX: case T_BIG_COMPLEX: + wrong_type_error_nr(sc, sc->rationalize_symbol, 2, err, sc->type_names[T_REAL]); + default: + return(method_or_bust(sc, err, 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; + const 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 + { + const 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: + { + const 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_simpler_ratio_or_integer(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) + + const 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 new_bgf; + new_cell(sc, new_bgf, T_BIG_REAL); + big_real_bgf(new_bgf) = alloc_bigflt(sc); + add_big_real(sc, new_bgf); + mpc_arg(big_real(new_bgf), big_complex(x), MPFR_RNDN); + return(new_bgf); + } +#endif + default: + return(method_or_bust_p(sc, x, sc->angle_symbol, a_number_string)); + } +} + +static s7_double angle_d_d(s7_double x) {return((is_NaN(x)) ? x : ((x < 0.0) ? M_PI : 0.0));} + + +/* -------------------------------- 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 p; + if (!is_real(x)) + return(method_or_bust(sc, x, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 1)); + if (!is_real(y)) + return(method_or_bust(sc, y, sc->complex_symbol, set_plist_2(sc, x, y), sc->type_names[T_REAL], 2)); + + switch (type(y)) + { + case T_INTEGER: case T_RATIO: case T_REAL: + { + s7_double iz = s7_real(y); + if (iz == 0.0) /* imag-part is 0.0 */ + return(x); + 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(y))) return(x); + new_cell(sc, p, T_BIG_COMPLEX); + big_complex_bgc(p) = alloc_bigcmp(sc); + mpfr_set(mpc_imagref(big_complex(p)), big_real(y), 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(y), MPFR_RNDN); + break; + case T_BIG_INTEGER: + if (mpz_cmp_ui(big_integer(y), 0) == 0) return(x); + new_cell(sc, p, T_BIG_COMPLEX); + big_complex_bgc(p) = alloc_bigcmp(sc); + mpfr_set_z(mpc_imagref(big_complex(p)), big_integer(y), MPFR_RNDN); + break; + } + switch (type(x)) + { + case T_INTEGER: case T_RATIO: case T_REAL: + mpfr_set_d(mpc_realref(big_complex(p)), s7_real(x), MPFR_RNDN); + break; + case T_BIG_REAL: + mpfr_set(mpc_realref(big_complex(p)), big_real(x), MPFR_RNDN); + break; + case T_BIG_RATIO: + mpfr_set_q(mpc_realref(big_complex(p)), big_ratio(x), MPFR_RNDN); + break; + case T_BIG_INTEGER: + mpfr_set_z(mpc_realref(big_complex(p)), big_integer(x), 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 complex_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + if (is_t_real(x)) + { + if (is_t_real(y)) return(wrap_complex(sc, real(x), real(y))); + if (is_t_integer(y)) return(wrap_complex(sc, real(x), (s7_double)integer(y))); + } + else + if (is_t_integer(x)) + { + if (is_t_integer(y)) return(wrap_complex(sc, (s7_double)integer(x), (s7_double)integer(y))); + if (is_t_real(y)) return(wrap_complex(sc, (s7_double)integer(x), real(y))); + } + return(complex_p_pp(sc, x, y)); +} + +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 g_complex_wrapped(s7_scheme *sc, s7_pointer args) {return(complex_p_pp_wrapped(sc, car(args), cadr(args)));} +static s7_pointer complex_p_ii_wrapped(s7_scheme *sc, s7_int x, s7_int y) {return(wrap_complex(sc, (s7_double)x, (s7_double)y));} /* tcomplex p_ii_ok */ +static s7_pointer complex_p_dd_wrapped(s7_scheme *sc, s7_double x, s7_double y) {return(wrap_complex(sc, x, y));} + +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 num = car(args); + if (is_number(num)) + { + 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(num)) + { + case T_INTEGER: return(s7_int_to_big_integer(sc, integer(num))); + case T_RATIO: return(s7_int_to_big_ratio(sc, numerator(num), denominator(num))); + case T_REAL: return(s7_double_to_big_real(sc, real(num))); + case T_COMPLEX: return(s7_double_to_big_complex(sc, real_part(num), imag_part(num))); + default: return(num); + } +#else + return(num); +#endif + } + num = g_string_to_number_1(sc, args, sc->bignum_symbol); + if (is_false(sc, num)) /* (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))); /* car(args) to get original */ +#if WITH_GMP + switch (type(num)) + { + case T_INTEGER: return(s7_int_to_big_integer(sc, integer(num))); + case T_RATIO: return(s7_int_to_big_ratio(sc, numerator(num), denominator(num))); + case T_COMPLEX: return(s7_number_to_big_complex(sc, num)); + case T_REAL: + if (is_NaN(real(num))) return(num); + return(s7_double_to_big_real(sc, real(num))); + /* 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(num); + } +#else + return(num); +#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) +{ + const s7_pointer x = car(args); + s7_pointer base = NULL; + + if (!is_number(x)) + return(method_or_bust(sc, x, sc->log_symbol, args, a_number_string, 1)); + + if (is_pair(cdr(args))) + { + base = cadr(args); + if (!is_number(base)) + return(method_or_bust(sc, base, sc->log_symbol, args, a_number_string, 2)); + } + + if (is_real(x)) + { + s7_pointer result = any_real_to_mpfr(sc, x, sc->mpfr_1); + if (result == real_NaN) return(result); + if ((is_positive(sc, x)) && + ((!base) || + ((is_real(base)) && (is_positive(sc, base))))) + { + if (result) return(result); + mpfr_log(sc->mpfr_1, sc->mpfr_1, MPFR_RNDN); + if (base) + { + result = any_real_to_mpfr(sc, base, sc->mpfr_2); + if (result) + return((result == real_infinity) ? real_zero : result); + if (mpfr_zero_p(sc->mpfr_2)) + out_of_range_error_nr(sc, sc->log_symbol, int_two, base, 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(x)) && ((!base) || (is_rational(base))))) + return(mpfr_to_integer(sc, sc->mpfr_1)); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + }} + if (base) + { + s7_pointer result = any_number_to_mpc(sc, base, sc->mpc_2); + if (result) + return((result == real_infinity) ? real_zero : complex_NaN); + if (mpc_zero_p(sc->mpc_2)) + out_of_range_error_nr(sc, sc->log_symbol, int_two, base, wrap_string(sc, "can't be zero", 13)); + } + { + s7_pointer result = any_number_to_mpc(sc, x, sc->mpc_1); + if (result) + { + if ((result == real_infinity) && (base) && ((is_negative(sc, x)))) + return(make_complex_not_0i(sc, INFINITY, -NAN)); + return((result == real_NaN) ? complex_NaN : result); + }} + mpc_log(sc->mpc_1, sc->mpc_1, MPC_RNDNN); + if (base) + { + 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 + + const 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))) + { + const 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) + /* 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! */ + return(((ix & (ix - 1)) == 0) ? make_integer(sc, (s7_int)s7_round(fx)) : make_real(sc, fx)); + }} + 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))) + { + const s7_double result = log(rational_to_double(sc, x)) / log(rational_to_double(sc, y)); + const s7_int ires = (s7_int)result; + if (result - ires == 0.0) + return(make_integer(sc, ires)); /* (log 8 2) -> 3 or (log 1/8 2) -> -3 */ + if (fabs(result) < RATIONALIZE_LIMIT) + { + s7_int num, den; + if (c_rationalize(result, sc->default_rationalize_error, &num, &den)) + /* && (s7_int_abs(num) < 100) && (s7_int_abs(den) < 100)) *//* why this? */ + return(make_simpler_ratio_or_integer(sc, num, den)); + } + return(make_real(sc, result)); + } + 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 func, 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(func); +} + +/* -------------------------------- 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)));} +/* the optimizer can replace (cos x) = cos_p_p(x) with cos_p_d(x) if x is real, but x might be 0 so (byte? (cos x)) will return different results */ +#endif + +static s7_double cos_d_d(s7_double x) {return(cos(x));} + + +#if !WITH_PURE_S7 +static s7_pointer multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y); + +static s7_pointer g_make_polar(s7_scheme *sc, s7_pointer args) +{ + #define H_make_polar "(make-polar magnitude angle) returns (complex (* magnitude (cos angle)) (* magnitude (sin angle)))" + #define Q_make_polar s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol) + s7_pointer mag = car(args), ang = cadr(args); + if (!s7_is_real(mag)) + method_or_bust_pp(sc, mag, sc->make_polar_symbol, mag, ang, sc->type_names[T_REAL], 1); + if (!s7_is_real(ang)) + method_or_bust_pp(sc, ang, sc->make_polar_symbol, mag, ang, sc->type_names[T_REAL], 2); + return(complex_p_pp(sc, multiply_p_pp(sc, mag, cos_p_p(sc, ang)), multiply_p_pp(sc, mag, sin_p_p(sc, ang)))); +} +#endif + + +/* -------------------------------- 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 x) +{ + if (is_t_real(x)) return(c_asin(sc, real(x))); + switch (type(x)) + { + case T_INTEGER: + if (integer(x) == 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(x))); + case T_RATIO: + return(c_asin(sc, (s7_double)fraction(x))); + 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(x)) > 1.0e7) || + (fabs(imag_part(x)) > 1.0e7)) + { + s7_complex sq1mz, sq1pz, z = to_c_complex(x); + sq1mz = csqrt(1.0 - z); + sq1pz = csqrt(1.0 + z); + return(make_complex(sc, atan(real_part(x) / creal(sq1mz * sq1pz)), asinh(cimag(sq1pz * conj(sq1mz))))); + } + return(c_complex_to_s7(sc, casin(to_c_complex(x)))); +#else + out_of_range_error_nr(sc, sc->asin_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 ASIN_BIG_REAL; + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + goto ASIN_BIG_REAL; + case T_BIG_REAL: + if (mpfr_inf_p(big_real(x))) + { + if (mpfr_cmp_ui(big_real(x), 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(x), 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(x), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_p(sc, x, 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 x) +{ + if (is_t_real(x)) return(c_acos(sc, real(x))); + switch (type(x)) + { + case T_INTEGER: + return((integer(x) == 1) ? int_zero : c_acos(sc, (s7_double)integer(x))); + case T_RATIO: + return(c_acos(sc, (s7_double)fraction(x))); + 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(x)) > 1.0e7) || + (fabs(imag_part(x)) > 1.0e7)) + { + s7_complex sq1mz, sq1pz, z = to_c_complex(x); + 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(x)))); +#else + out_of_range_error_nr(sc, sc->acos_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 ACOS_BIG_REAL; + case T_BIG_RATIO: + mpfr_set_q(sc->mpfr_1, big_ratio(x), MPFR_RNDN); + goto ACOS_BIG_REAL; + case T_BIG_REAL: + if (mpfr_inf_p(big_real(x))) + { + if (mpfr_cmp_ui(big_real(x), 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(x), 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(x), MPC_RNDNN); + return(mpc_to_number(sc, sc->mpc_1)); +#endif + default: + return(method_or_bust_p(sc, x, 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? */ + + const s7_pointer x = car(args); + s7_pointer 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((s7_double)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); + /* this is one place where s7 notices -0.0 != 0.0 -- this is apparently built into atan2, so I guess I'll leave it, but: + * (atan 0.0 0.0): 0.0, (atan 0.0 -0.0): pi, (atan 0 -0.0): pi, (atan 0 -0) 0.0, (atan 0 -0.0): pi. + * so you can sneak up on 0.0 from the left, but you can't fool 0?? + */ + 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_d(s7_double x) {return(atan(x));} +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_RATIO: + case T_REAL: + { + 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_RATIO: + case T_REAL: + { + 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((s7_double)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((s7_double)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); /* needed because otherwise (sqrt +nan.0) -> 0.0-nan.0i ?? */ + 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 s7_int 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) +{ + const s7_pointer x = car(args), y = cadr(args); + s7_pointer result; + 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)); + }} + + result = any_number_to_mpc(sc, y, sc->mpc_2); + if (result == 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 (result) return(complex_NaN); + + if ((is_real(x)) && + (is_real(y)) && + (is_positive(sc, x))) + { + result = any_real_to_mpfr(sc, x, sc->mpfr_1); + if (result) + { + if (result == 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)); + } + + result = any_number_to_mpc(sc, x, sc->mpc_1); + if (result) + { + if ((result == 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)) + { + const 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: + { + const 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 (y & 1) /* (expt -1 odd-int) */ + return(n); /* n == -1 */ + 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: + { + const 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)) + { + const 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 nums = args; is_pair(nums); nums = cdr(nums)) + { + const s7_pointer x = car(nums); + 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 (nums = cdr(nums); is_pair(nums); nums = cdr(nums)) + { + const s7_pointer x1 = car(nums); + if (is_number(x1)) + { + if (!is_rational(x1)) + wrong_type_error_nr(sc, sc->lcm_symbol, position_of(nums, args), x1, a_rational_string); + } + else + if (has_active_methods(sc, x1)) + { + s7_pointer func = find_method_with_let(sc, x1, sc->is_rational_symbol); + if ((func == sc->undefined) || + (is_false(sc, s7_apply_function(sc, func, set_plist_1(sc, x1))))) + wrong_type_error_nr(sc, sc->lcm_symbol, position_of(nums, args), x1, a_rational_string); + } + else wrong_type_error_nr(sc, sc->lcm_symbol, position_of(nums, 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, nums)); +#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, nums)); +#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, nums)); +#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, nums)); +#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 = (nums == 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, nums)); +#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(nums, 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), nums), + a_rational_string, position_of(nums, 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)) + { + const 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; + s7_pointer n_args; + + 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))); + } + + if (is_t_integer(car(args))) + { + n = integer(car(args)); + n_args = cdr(args); + } + else n_args = args; + + for (s7_pointer nums = n_args; is_pair(nums); nums = cdr(nums)) + { + const s7_pointer x = car(nums); + switch (type(x)) + { + case T_INTEGER: + if (integer(x) == S7_INT64_MIN) +#if WITH_GMP + return(big_gcd(sc, n, d, nums)); +#else + { + if ((n == S7_INT64_MIN) && (is_null(cdr(nums)))) /* gcd is supposed to return a positive integer, but we can't take abs(S7_INT64_MIN) */ + sole_arg_out_of_range_error_nr(sc, sc->gcd_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 + { + const 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, nums)); +#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(nums, 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), nums), + a_rational_string, position_of(nums, 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: + { + const 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);} +static s7_pointer floor_p_i(s7_scheme *sc, s7_int x) {return(make_integer(sc, x));} + +#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: + { + const 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);} +static s7_pointer ceiling_p_i(s7_scheme *sc, s7_int x) {return(make_integer(sc, x));} + +#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((s7_double)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: + { + const 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);} +static s7_pointer truncate_p_i(s7_scheme *sc, s7_int x) {return(make_integer(sc, x));} + +#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: + { + const 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))); +} +/* (round (/ ...)) -> real_divide etc (wrapped) -- round_p_p is called in tbit via fx_c_op_opssqq_s_direct */ + +static s7_int round_i_i(s7_int i) {return(i);} +static s7_pointer round_p_i(s7_scheme *sc, s7_int x) {return(make_integer(sc, x));} + +#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))); +#if !WITH_GMP + if (is_t_real(y)) + return(make_real(sc, (long_double)integer(x) + real(y))); +#endif + } + 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, (s7_double)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) + (s7_double)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) + (s7_double)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)); + } +} + +#if !WITH_GMP +static inline s7_pointer add_if_overflow_to_real_wrapped(s7_scheme *sc, s7_int x, s7_int y) +{ +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if (add_overflow(x, y, &val)) + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, y); + return(wrap_real(sc, (long_double)x + (long_double)y)); + } + return(wrap_integer(sc, val)); +#else + return(wrap_integer(sc, x + y)); +#endif +} + +static s7_pointer add_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + /* an experiment -- wraps rather than boxes results */ +#if 1 + if (is_t_integer(x)) + { + if (is_t_integer(y)) + return(add_if_overflow_to_real_wrapped(sc, integer(x), integer(y))); +#if !WITH_GMP + if (is_t_real(y)) + return(wrap_real(sc, (long_double)integer(x) + real(y))); +#endif + } + else + if (is_t_real(x)) + { + if (is_t_real(y)) + return(wrap_real(sc, real(x) + real(y))); + } + else + if ((is_t_complex(x)) && (is_t_complex(y))) + return(wrap_real_or_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); +#endif + switch (type(x)) + { + case T_INTEGER: + switch (type(y)) + { + case T_INTEGER: + return(add_if_overflow_to_real_wrapped(sc, integer(x), integer(y))); + case T_REAL: + return(wrap_real(sc, (long_double)integer(x) + real(y))); + case T_COMPLEX: + return(wrap_complex(sc, (long_double)integer(x) + (long_double)real_part(y), imag_part(y))); + } + + case T_REAL: + switch (type(y)) + { + case T_INTEGER: + return(wrap_real(sc, real(x) + (long_double)integer(y))); + case T_REAL: + return(make_real(sc, real(x) + real(y))); + case T_COMPLEX: + return(wrap_complex(sc, real(x) + real_part(y), imag_part(y))); + } + + case T_COMPLEX: + switch (type(y)) + { + case T_INTEGER: + return(wrap_complex(sc, real_part(x) + integer(y), imag_part(x))); + case T_REAL: + return(wrap_complex(sc, real_part(x) + real(y), imag_part(x))); + case T_COMPLEX: + return(wrap_real_or_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); + }} + return(add_p_pp(sc, x, y)); +} +#else +#define add_p_pp_wrapped add_p_pp +#endif + +static s7_pointer add_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) +{ + if ((is_t_integer(x)) && (is_t_integer(y)) && (is_t_integer(z))) + { +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if ((!add_overflow(integer(x), integer(y), &val)) && + (!add_overflow(val, integer(z), &val))) + return(make_integer(sc, val)); +#if WITH_GMP + mpz_set_si(sc->mpz_1, integer(x)); + mpz_set_si(sc->mpz_2, integer(y)); + mpz_add(sc->mpz_1, sc->mpz_1, sc->mpz_2); + mpz_set_si(sc->mpz_2, integer(z)); + 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(x), integer(y), integer(z)); + return(make_real(sc, (long_double)integer(x) + (long_double)integer(y) + (long_double)integer(z))); +#endif +#else + return(make_integer(sc, integer(x) + integer(y) + integer(z))); +#endif + } + if ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z))) + return(make_real(sc, real(x) + real(y) + real(z))); + { + s7_pointer num = add_p_pp_wrapped(sc, x, y); + sc->error_argnum = 1; + num = add_p_pp(sc, num, z); + sc->error_argnum = 0; + return(num); + } +} + +#if !WITH_GMP +static s7_pointer add_p_ppp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) +{ + if ((is_t_integer(x)) && (is_t_integer(y)) && (is_t_integer(z))) + { +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if ((!add_overflow(integer(x), integer(y), &val)) && + (!add_overflow(val, integer(z), &val))) + return(wrap_integer(sc, val)); + if (WITH_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 " %" ld64 ")\n", integer(x), integer(y), integer(z)); + return(wrap_real(sc, (long_double)integer(x) + (long_double)integer(y) + (long_double)integer(z))); +#else + return(wrap_integer(sc, integer(x) + integer(y) + integer(z))); +#endif + } + if ((is_t_real(x)) && (is_t_real(y)) && (is_t_real(z))) + return(wrap_real(sc, real(x) + real(y) + real(z))); + { + s7_pointer num = add_p_pp_wrapped(sc, x, y); + sc->error_argnum = 1; + num = add_p_pp_wrapped(sc, num, z); + sc->error_argnum = 0; + return(num); + } +} +#else +#define add_p_ppp_wrapped add_p_ppp +#endif + + +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(cdr(p)); p = cdr(p), sc->error_argnum++) + x = add_p_pp_wrapped(sc, x, car(p)); + 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_2_wrapped(s7_scheme *sc, s7_pointer args) {return(add_p_pp_wrapped(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_3_wrapped(s7_scheme *sc, s7_pointer args) {return(add_p_ppp_wrapped(sc, car(args), cadr(args), caddr(args)));} + +static s7_pointer g_add_4(s7_scheme *sc, s7_pointer args) +{ + s7_pointer a1 = add_p_pp_wrapped(sc, car(args), cadr(args)); + s7_pointer p = cddr(args); + sc->error_argnum = 2; + p = add_p_pp(sc, a1, add_p_pp_wrapped(sc, car(p), cadr(p))); + sc->error_argnum = 0; + return(p); +} + +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_pp(sc, x, sc->add_symbol, x, make_integer(sc, y), a_number_string, loc)); + } + return(x); +} + +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, (s7_double)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_pp(sc, x, sc->add_symbol, x, make_real(sc, 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 add_p_dd(s7_scheme *sc, s7_double x1, s7_double x2) {return(make_real(sc, x1 + x2));} /* very few calls */ +static s7_pointer add_p_ii(s7_scheme *sc, s7_int x1, s7_int x2) {return(make_integer(sc, x1 + x2));} /* no calls */ +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 g_random_i(s7_scheme *sc, s7_pointer args); +static s7_pointer g_multiply_2(s7_scheme *sc, s7_pointer args); +static s7_pointer g_multiply_2_wrapped(s7_scheme *sc, s7_pointer args); +static s7_pointer g_subtract_2(s7_scheme *sc, s7_pointer args); +static s7_pointer g_subtract_2_wrapped(s7_scheme *sc, s7_pointer args); + +static s7_pointer add_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + /* (+ s f) (+ (* s s) s) (+ s s) (+ s (* s s)) */ + if (args == 2) + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if ((is_pair(arg1)) && (has_fn(arg1)) && (fn_proc(arg1) == g_multiply_2)) set_fn_direct(arg1, g_multiply_2_wrapped); + if ((is_pair(arg2)) && (has_fn(arg2))) + { + if (fn_proc(arg2) == g_multiply_2) set_fn_direct(arg2, g_multiply_2_wrapped); + if (fn_proc(arg2) == g_subtract_2) set_fn_direct(arg2, g_subtract_2_wrapped); + } + 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); /* i.e. don't evaluate random call beforehand(?) */ + return(sc->add_i_random); + } + if (arg1 == int_one) return(sc->add_1x); + return(sc->add_2); + } + return((args == 3) ? sc->add_3 : ((args == 4) ? sc->add_4 : func)); +} + +/* ---------------------------------------- subtract ---------------------------------------- */ +static s7_pointer negate_p_p(s7_scheme *sc, s7_pointer x) /* can't use "negate" because it confuses C++! */ +{ + switch (type(x)) + { + case T_INTEGER: + if (integer(x) == 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, x, wrap_string(sc, "most-negative-fixnum can't be negated", 37)); +#endif + return(make_integer(sc, -integer(x))); + + case T_RATIO: return(make_simpler_ratio(sc, -numerator(x), denominator(x))); + case T_REAL: return(make_real(sc, -real(x))); + case T_COMPLEX: return(make_complex_not_0i(sc, -real_part(x), -imag_part(x))); + +#if WITH_GMP + case T_BIG_INTEGER: + mpz_neg(sc->mpz_1, big_integer(x)); + return(mpz_to_integer(sc, sc->mpz_1)); + case T_BIG_RATIO: + mpq_neg(sc->mpq_1, big_ratio(x)); + return(mpq_to_canonicalized_rational(sc, sc->mpq_1)); + case T_BIG_REAL: + mpfr_neg(sc->mpfr_1, big_real(x), MPFR_RNDN); + return(mpfr_to_big_real(sc, sc->mpfr_1)); + case T_BIG_COMPLEX: + mpc_neg(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->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, (s7_double)fraction(x) - real(y))); + case T_COMPLEX: + return(make_complex_not_0i(sc, (s7_double)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) - (s7_double)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) - (s7_double)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 negate_p_p_wrapped(s7_scheme *sc, s7_pointer x) /* can't use "negate" because it confuses C++! */ +{ + switch (type(x)) + { + case T_INTEGER: + if (integer(x) == S7_INT64_MIN) + sole_arg_out_of_range_error_nr(sc, sc->subtract_symbol, x, wrap_string(sc, "most-negative-fixnum can't be negated", 37)); + return(wrap_integer(sc, -integer(x))); + case T_REAL: + return(wrap_real(sc, -real(x))); + case T_COMPLEX: + return(wrap_complex(sc, -real_part(x), -imag_part(x))); + } + return(negate_p_p(sc, x)); +} + +#if !WITH_GMP +static s7_pointer subtract_if_overflow_to_real_wrapped(s7_scheme *sc, s7_int x, s7_int y) +{ +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if (subtract_overflow(x, y, &val)) + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", x, y); + return(wrap_real(sc, (long_double)x - (long_double)y)); + } + return(wrap_integer(sc, val)); +#else + return(wrap_integer(sc, x - y)); +#endif +} + +static s7_pointer subtract_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + switch (type(x)) + { + case T_INTEGER: + if (integer(x) == 0) return(negate_p_p_wrapped(sc, y)); + switch (type(y)) + { + case T_INTEGER: return(subtract_if_overflow_to_real_wrapped(sc, integer(x), integer(y))); + case T_REAL: return(wrap_real(sc, (long_double)integer(x) - real(y))); + case T_COMPLEX: return(wrap_complex(sc, (long_double)integer(x) - real_part(y), -imag_part(y))); + } + case T_REAL: + switch (type(y)) + { + case T_INTEGER: return(wrap_real(sc, real(x) - (long_double)integer(y))); /* long_double saves (- 9007199254740996.0 9007199254740995): 1.0 */ + case T_REAL: return(wrap_real(sc, real(x) - real(y))); + case T_COMPLEX: return(wrap_complex(sc, real(x) - real_part(y), -imag_part(y))); + } + case T_COMPLEX: + switch (type(y)) + { + case T_INTEGER: return(wrap_complex(sc, real_part(x) - integer(y), imag_part(x))); + case T_REAL: return(wrap_complex(sc, real_part(x) - real(y), imag_part(x))); + case T_COMPLEX: return(wrap_real_or_complex(sc, real_part(x) - real_part(y), imag_part(x) - imag_part(y))); + }} + return(subtract_p_pp(sc, x, y)); +} +#else +#define subtract_p_pp_wrapped subtract_p_pp +#endif + +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(cdr(p)); p = cdr(p), sc->error_argnum++) + x = subtract_p_pp_wrapped(sc, x, car(p)); + 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_1_wrapped(s7_scheme *sc, s7_pointer args) {return(negate_p_p_wrapped(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_2_wrapped(s7_scheme *sc, s7_pointer args) {return(subtract_p_pp_wrapped(sc, car(args), cadr(args)));} + +static s7_pointer g_subtract_3(s7_scheme *sc, s7_pointer args) /* wrapped version gets no hits */ +{ + s7_pointer x = car(args); + x = subtract_p_pp_wrapped(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 num = car(args); +#if WITH_GMP + return(subtract_p_pp(sc, num, int_one)); +#endif + /* return((is_t_integer(num)) ? make_integer(sc, integer(num) - 1) : minus_c1(sc, num)); */ + return((is_t_integer(num)) ? subtract_if_overflow_to_real_or_big_integer(sc, integer(num), 1) : minus_c1(sc, num)); +} + +static s7_pointer g_subtract_2f(s7_scheme *sc, s7_pointer args) /* (- x f) */ +{ + const s7_pointer x = car(args); + const 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, (s7_double)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) */ +{ + const s7_pointer x = cadr(args); + const 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 - (s7_double)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_pp(sc, x, sc->subtract_symbol, x, make_integer(sc, y), a_number_string, 1)); + } + return(x); +} + +static s7_pointer subtract_chooser(s7_scheme *sc, s7_pointer func, 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 : func); + arg1 = cadr(expr); + arg2 = caddr(expr); + if ((is_pair(arg1)) && (has_fn(arg1))) + { + if (fn_proc(arg1) == g_multiply_2) set_fn_direct(arg1, g_multiply_2_wrapped); + if (fn_proc(arg1) == g_add_2) set_fn_direct(arg1, g_add_2_wrapped); + } + if ((is_pair(arg2)) && (has_fn(arg2)) && (fn_proc(arg2) == g_multiply_2)) set_fn_direct(arg2, g_multiply_2_wrapped); + /* sub_random_i (parallels add_i_random) only occurs in tmap.scm */ + 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 * (s7_double)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, (s7_double)fraction(x) * (s7_double)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, (s7_double)fraction(x) * real(y))); + case T_COMPLEX: + return(make_complex(sc, (s7_double)fraction(x) * real_part(y), (s7_double)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, (s7_double)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) * (s7_double)fraction(y), imag_part(x) * (s7_double)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)); + } +} + +#if !WITH_GMP +static inline s7_pointer multiply_if_overflow_to_real_wrapped(s7_scheme *sc, s7_int x, s7_int y) +{ +#if HAVE_OVERFLOW_CHECKS + s7_int val; + if (multiply_overflow(x, y, &val)) + { + if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y); + return(wrap_real(sc, (s7_double)x * (s7_double)y)); + } + return(wrap_integer(sc, val)); +#else + return(wrap_integer(sc, x * y)); +#endif +} + +static s7_pointer multiply_p_pp_wrapped(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_wrapped(sc, integer(x), integer(y))); + case T_REAL: return(wrap_real(sc, (long_double)integer(x) * real(y))); + case T_COMPLEX: return(wrap_real_or_complex(sc, (long_double)integer(x) * real_part(y), (long_double)integer(x) * imag_part(y))); + } + case T_REAL: + switch (type(y)) + { + case T_INTEGER: return(wrap_real(sc, real(x) * (long_double)integer(y))); + case T_REAL: return(wrap_real(sc, real(x) * real(y))); + case T_COMPLEX: return(wrap_real_or_complex(sc, real(x) * real_part(y), real(x) * imag_part(y))); + } + case T_COMPLEX: + switch (type(y)) + { + case T_INTEGER: return(wrap_real_or_complex(sc, real_part(x) * integer(y), imag_part(x) * integer(y))); + case T_REAL: return(wrap_real_or_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(wrap_real_or_complex(sc, r1 * r2 - i1 * i2, r1 * i2 + r2 * i1)); + }}} + return(multiply_p_pp(sc, x, y)); +} +#else +#define multiply_p_pp_wrapped multiply_p_pp +#endif + +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_wrapped(sc, x, y); + sc->error_argnum = 1; + x = multiply_p_pp(sc, x, z); + sc->error_argnum = 0; + return(x); +} + +static s7_pointer multiply_p_ppp_wrapped(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_wrapped(sc, x, y); + sc->error_argnum = 1; + x = multiply_p_pp_wrapped(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(cdr(p)); p = cdr(p), sc->error_argnum++) + x = multiply_p_pp_wrapped(sc, x, car(p)); + 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_multiply_2_wrapped(s7_scheme *sc, s7_pointer args) {return(multiply_p_pp_wrapped(sc, car(args), cadr(args)));} +static s7_pointer g_multiply_3(s7_scheme *sc, s7_pointer args) {return(multiply_p_ppp(sc, car(args), cadr(args), caddr(args)));} +static s7_pointer g_multiply_3_wrapped(s7_scheme *sc, s7_pointer args) {return(multiply_p_ppp_wrapped(sc, car(args), cadr(args), caddr(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_pp(sc, x, sc->multiply_symbol, x, make_integer(sc, 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_pp(sc, x, sc->multiply_symbol, x, make_real(sc, y), a_number_string, num)); + } + return(x); +} + +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 + fprintf(stderr, "%s[%d]: integer multiply overflow: (* %" ld64 " %" ld64 ")\n", __func__, __LINE__, 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 + fprintf(stderr, "%s[%d]: integer multiply overflow: (* %" ld64 " %" ld64 " %" ld64 ")\n", __func__, __LINE__, 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 func, int32_t args, s7_pointer expr) +{ + s7_pointer arg1, arg2; + if (args < 2) return(func); + arg1 = cadr(expr); + if ((is_pair(arg1)) && (has_fn(arg1))) + { + if (fn_proc(arg1) == g_add_2) set_fn_direct(arg1, g_add_2_wrapped); + if (fn_proc(arg1) == g_add_3) set_fn_direct(arg1, g_add_3_wrapped); + if (fn_proc(arg1) == g_subtract_2) set_fn_direct(arg1, g_subtract_2_wrapped); + if (fn_proc(arg1) == g_subtract_1) set_fn_direct(arg1, g_subtract_1_wrapped); + } + arg2 = caddr(expr); + if ((is_pair(arg2)) && (has_fn(arg2))) + { + if (fn_proc(arg2) == g_add_2) set_fn_direct(arg2, g_add_2_wrapped); + if (fn_proc(arg2) == g_add_3) set_fn_direct(arg2, g_add_3_wrapped); + if (fn_proc(arg2) == g_subtract_2) set_fn_direct(arg2, g_subtract_2_wrapped); + if (fn_proc(arg2) == g_subtract_1) set_fn_direct(arg2, g_subtract_1_wrapped); + } + if (args == 2) return(sc->multiply_2); + if (args == 3) return(sc->multiply_3); + return(func); +} + + +/* ---------------------------------------- divide ---------------------------------------- */ +static s7_pointer complex_invert(s7_scheme *sc, s7_pointer x) +{ + s7_double r2 = real_part(x), i2 = imag_part(x); + s7_double den = (r2 * r2 + i2 * i2); + /* here if x 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: + if_method_exists_return_value(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))); /* make_ratio calls gcd */ + 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 r1 = (s7_double)integer(x), r2 = real_part(y), i2 = imag_part(y); + s7_double 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, (s7_double)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)))) return(y); + if ((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)))) return(y); + if ((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)))) return(y); + if ((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)))) return(y); + if ((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) +{ + const 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) */ + const 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(divide_p_pp(sc, car(args), x)); +} + +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 func, int32_t args, s7_pointer expr) +{ + if (args == 1) return(sc->invert_1); + if (args == 2) + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if ((is_t_real(arg1)) && (real(arg1) == 1.0)) return(sc->invert_x); + if ((is_pair(arg1)) && (has_fn(arg1))) + { + if (fn_proc(arg1) == g_multiply_2) set_fn_direct(arg1, g_multiply_2_wrapped); + else if (fn_proc(arg1) == g_multiply_3) set_fn_direct(arg1, g_multiply_3_wrapped); + } + if ((is_pair(arg2)) && (has_fn(arg2)) && (fn_proc(arg2) == g_multiply_2)) set_fn_direct(arg2, g_multiply_2_wrapped); + return(((is_t_integer(arg2)) && (integer(arg2) == 2)) ? sc->divide_by_2 : sc->divide_2); + } + return(func); +} + + +/* -------------------------------- 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(make_nan_with_payload(sc, __LINE__)); + if (any_real_to_mpfr(sc, y, sc->mpfr_2)) return(make_nan_with_payload(sc, __LINE__)); + 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(make_nan_with_payload(sc, __LINE__)); + 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(make_nan_with_payload(sc, __LINE__)); + 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(make_nan_with_payload(sc, __LINE__)); + /* 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_NaN(y)) return(y); + if (is_inf(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_NaN(x1)) return(x1); + if (is_inf(x1)) return(NAN); /* match remainder_p_pp */ + 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(make_nan_with_payload(sc, __LINE__)); + 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(make_nan_with_payload(sc, __LINE__)); + 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_wrapped(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(make_nan_with_payload(sc, __LINE__)); + } + 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_wrapped(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)) return(x1); + if (is_NaN(x2)) return(x2); + if ((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; + if ((is_t_integer(x)) && (is_t_integer(y))) /* this is nearly always the case */ + return(make_integer(sc, modulo_i_ii(integer(x), integer(y)))); + + 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(make_nan_with_payload(sc, __LINE__)); + 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) || (n2d1 == -1)) /* (modulo 100 -1/2) as above) */ + 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(make_nan_with_payload(sc, __LINE__)); + 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(make_nan_with_payload(sc, __LINE__)); /* 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(make_nan_with_payload(sc, __LINE__)); + 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 func = find_method_with_let(sc, p, sc->is_real_symbol); + if (func != sc->undefined) + return(is_true(sc, s7_apply_function(sc, func, 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 nums = cdr(args); is_pair(nums); nums = cdr(nums)) + x = max_p_pp(sc, x, car(nums)); + 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 func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->max_2 : ((args == 3) ? sc->max_3 : func)); +} + +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(((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 nums = cdr(args); is_pair(nums); nums = cdr(nums)) + x = min_p_pp(sc, x, car(nums)); + 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 func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->min_2 : ((args == 3) ? sc->min_3 : func)); +} + +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) +{ + /* (= float int) here can be confusing if the float is the result of (say) (* 4478554083/3166815962 4478554083/3166815962) -- sometimes + * the extra low order bits are lost somewhere, so it looks like (= 2.0 2) returning #t. Maybe the caller should have used eqv? + */ + 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 func = find_method_with_let(sc, p, sc->is_number_symbol); + if (func != sc->undefined) + return(is_true(sc, s7_apply_function(sc, func, 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) + + const s7_pointer x = car(args); + s7_pointer nums = cdr(args); + if (is_null(cdr(nums))) + return(make_boolean(sc, num_eq_b_7pp(sc, x, car(nums)))); + + for (; is_pair(nums); nums = cdr(nums)) + if (!num_eq_b_7pp(sc, x, car(nums))) + { + for (nums = cdr(nums); is_pair(nums); nums = cdr(nums)) + if (!is_number_via_method(sc, car(nums))) + wrong_type_error_nr(sc, sc->num_eq_symbol, position_of(nums, args), car(nums), 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 func, int32_t args, s7_pointer expr) +{ + s7_pointer arg1, arg2; + if (args != 2) return(func); + arg1 = cadr(expr); + arg2 = caddr(expr); + if ((is_pair(arg1)) && (has_fn(arg1)) && (fn_proc(arg1) == g_add_3)) set_fn_direct(arg1, g_add_3_wrapped); + if (is_t_integer(arg2)) return(sc->num_eq_xi); + return((is_t_integer(arg1)) ? 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) +{ + const 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) +{ + const s7_int y = integer(cadr(args)); + const 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) +{ + const s7_double y = real(cadr(args)); /* chooser below checks is_t_real(y) */ + const 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 func, int32_t args, s7_pointer expr) +{ + s7_pointer arg2; + if (args != 2) return(func); + 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) +{ + const s7_int y = integer(cadr(args)); + const 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) +{ + const s7_pointer nums = cdr(args); + if (is_t_integer(car(nums))) + { + if (integer(car(args)) > integer(car(nums))) + { + if (!is_real_via_method(sc, cadr(nums))) + wrong_type_error_nr(sc, sc->leq_symbol, 3, cadr(nums), sc->type_names[T_REAL]); + return(sc->F); + } + if (is_t_integer(cadr(nums))) + return((integer(car(nums)) > integer(cadr(nums))) ? sc->F : sc->T); + } + return(g_less_or_equal(sc, args)); +} + +static s7_pointer leq_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 2) + { + const s7_pointer 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(func); +} + + +/* ---------------------------------------- > ---------------------------------------- */ +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) +{ + const s7_int y = integer(cadr(args)); + const 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) +{ + const s7_double y = real(cadr(args)); + const 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 */ + const 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 func, int32_t args, s7_pointer expr) +{ + s7_pointer arg2; + if (args != 2) return(func); + 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) +{ + const s7_int y = integer(cadr(args)); + const 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 func, int32_t args, s7_pointer expr) +{ + s7_pointer arg2; + if (args != 2) return(func); + 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((s7_double)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_7p(s7_scheme *sc, s7_pointer x) +{ + if (is_number(x)) return(s7_real_part(x)); + sole_arg_wrong_type_error_nr(sc, 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_7p(s7_scheme *sc, s7_pointer x) +{ + if (is_number(x)) return(s7_imag_part(x)); + sole_arg_wrong_type_error_nr(sc, 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) + + const 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) + + const 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 +#if WITH_GMP + /* return(make_boolean(sc, (is_t_real(p)) || (is_t_big_real(p)))); *//* (float? pi) */ + #define is_t_float(P) (is_t_real(P) || (is_t_big_real(P))) + check_boolean_method(sc, is_t_float, sc->is_float_symbol, args); +#else + /* (float? (openlet (inlet 'x 0.0 'float? (lambda (obj) (and (real? (obj 'x)) (not (exact? (obj 'x)))))))) */ + check_boolean_method(sc, is_t_real, sc->is_float_symbol, args); + /* 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_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 has an infinite real or imaginary part" + #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 x) +{ + if (is_t_integer(x)) + return((integer(x) & 1) == 0); +#if WITH_GMP + if (is_t_big_integer(x)) + return(mpz_even_p(big_integer(x))); +#endif + return(method_or_bust_p(sc, x, 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 x) +{ + if (is_t_integer(x)) + return((integer(x) & 1) == 1); +#if WITH_GMP + if (is_t_big_integer(x)) + return(mpz_odd_p(big_integer(x))); +#endif + return(method_or_bust_p(sc, x, 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 x) +{ + if (is_t_integer(x)) return(integer(x) == 0); + if (is_t_real(x)) return(real(x) == 0.0); +#if WITH_GMP + if (is_number(x)) return(is_zero(x)); +#else + if (is_number(x)) return(false); +#endif + return(method_or_bust_p(sc, x, 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 x) {return(make_boolean(sc, is_zero_b_7p(sc, x)));} +static bool is_zero_i(s7_int i) {return(i == 0);} +static bool is_zero_d(s7_double x) {return(x == 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 x) +{ + if (is_t_integer(x)) return(integer(x) > 0); + if (is_t_real(x)) return(real(x) > 0.0); +#if WITH_GMP + if (is_number(x)) return(is_positive(sc, x)); +#else + if (is_t_ratio(x)) return(numerator(x) > 0); +#endif + return(method_or_bust_p(sc, x, 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 x) {return(make_boolean(sc, is_positive_b_7p(sc, x)));} +static bool is_positive_i(s7_int i) {return(i > 0);} +static bool is_positive_d(s7_double x) {return(x > 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 x) +{ + if (is_t_integer(x)) return(integer(x) < 0); + if (is_t_real(x)) return(real(x) < 0.0); +#if WITH_GMP + if (is_number(x)) return(is_negative(sc, x)); +#else + if (is_t_ratio(x)) return(numerator(x) < 0); +#endif + return(method_or_bust_p(sc, x, 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 x) {return(make_boolean(sc, is_negative_b_7p(sc, x)));} +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_simpler_ratio_or_integer(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 + + const 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 x) +{ + if (!is_number(x)) + return(method_or_bust_p(sc, x, sc->is_exact_symbol, a_number_string) != sc->F); + return(is_rational(x)); +} + + +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 + + const 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 x) +{ + if (!is_number(x)) + return(method_or_bust_p(sc, x, sc->is_inexact_symbol, a_number_string) != sc->F); + return(!is_rational(x)); +} + + +/* ---------------------------------------- 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 + + const s7_pointer num = car(args); + if (is_t_integer(num)) + { + s7_int x = integer(num); + return((x < 0) ? small_int(integer_length(-(x + 1))) : small_int(integer_length(x))); + } +#if WITH_GMP + if (is_t_big_integer(num)) + return(make_integer(sc, mpz_sizeinbase(big_integer(num), 2))); +#endif + return(sole_arg_method_or_bust(sc, num, 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; + const 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 = mpfr_get_z_exp(sc->mpz_1, big_real(x)); + bool 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 -------------------------------- */ + +static bool has_two_int_args(s7_scheme *sc, s7_pointer expr) +{ + /* TODO: this needs to be split into 2 calls on has_one_int, and maybe support (apply int-func...) */ + /* also the global business is wrong if it is currently shadowed */ + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if (is_t_integer(arg1)) + { + if (is_t_integer(arg2)) return(true); + if ((is_pair(arg2)) && (is_symbol(car(arg2))) && (is_defined_global(car(arg2))) && (is_c_function(global_value(car(arg2))))) + { + s7_pointer sig = c_function_signature(global_value(car(arg2))); + if ((is_pair(sig)) && (car(sig) == sc->is_integer_symbol)) return(true); + } + return(false); + } + if ((is_pair(arg1)) && (is_symbol(car(arg1))) && (is_defined_global(car(arg1))) && (is_c_function(global_value(car(arg1))))) + { + s7_pointer sig = c_function_signature(global_value(car(arg1))); + if ((is_pair(sig)) && ((car(sig) == sc->is_integer_symbol) || (car(sig) == sc->is_byte_symbol))) + { + if (is_t_integer(arg2)) return(true); + if ((is_pair(arg2)) && (is_symbol(car(arg2))) && (is_defined_global(car(arg2))) && (is_c_function(global_value(car(arg2))))) + { + sig = c_function_signature(global_value(car(arg2))); + if ((is_pair(sig)) && ((car(sig) == sc->is_integer_symbol) || (car(sig) == sc->is_byte_symbol))) return(true); + }}} + return(false); +} + +#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_pair(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_pair(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);} + +static s7_pointer g_logior_ii(s7_scheme *sc, s7_pointer args) {return(make_integer(sc, integer(car(args)) | integer(cadr(args))));} +static s7_pointer g_logior_2(s7_scheme *sc, s7_pointer args) +{ + s7_pointer arg1 = car(args), arg2 = cadr(args); + if ((is_t_integer(arg1)) && (is_t_integer(arg2))) + return(make_integer(sc, integer(arg1) | integer(arg2))); + return(g_logior(sc, args)); +} + +static s7_pointer logior_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 2) + { + if (has_two_int_args(sc, expr)) return(sc->logior_ii); + return(sc->logior_2); + } + return(func); +} + + +/* -------------------------------- 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_pair(x); x = cdr(x)) + { + const 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_pair(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);} + +static s7_pointer g_logxor_2(s7_scheme *sc, s7_pointer args) +{ + s7_pointer arg1 = car(args), arg2 = cadr(args); + if ((is_t_integer(arg1)) && (is_t_integer(arg2))) + return(make_integer(sc, integer(arg1) ^ integer(arg2))); + return(g_logxor(sc, args)); +} + +static s7_pointer logxor_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) {return((args == 2) ? sc->logxor_2 : func);} + + +/* -------------------------------- 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_pair(x); x = cdr(x)) + { + const 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_pair(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);} + +static s7_pointer g_logand_ii(s7_scheme *sc, s7_pointer args) {return(make_integer(sc, integer(car(args)) & integer(cadr(args))));} +static s7_pointer g_logand_2(s7_scheme *sc, s7_pointer args) +{ + s7_pointer arg1 = car(args), arg2 = cadr(args); + if ((is_t_integer(arg1)) && (is_t_integer(arg2))) + return(make_integer(sc, integer(arg1) & integer(arg2))); + return(g_logand(sc, args)); +} + +static s7_pointer logand_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 2) + { + if (has_two_int_args(sc, expr)) return(sc->logand_ii); + return(sc->logand_2); + } + return(func); +} + + +/* -------------------------------- 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 + + const 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) + + const 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 s7_ints are necessary, else C turns it into an int, gets confused about signs etc */ + return(make_boolean(sc, ((((s7_int)(1LL << (s7_int)index)) & (s7_int)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((((s7_int)(1LL << (s7_int)i2)) & (s7_int)i1) != 0); +} + +static bool logbit_b_7pp(s7_scheme *sc, s7_pointer i1, s7_pointer i2) +{ + if (is_t_integer(i1)) + { + if (is_t_integer(i2)) + return(logbit_b_7ii(sc, integer(i1), integer(i2))); + return(method_or_bust(sc, i2, sc->logbit_symbol, set_plist_2(sc, i1, i2), sc->type_names[T_INTEGER], 2) != sc->F); + } +#if WITH_GMP + return(g_logbit(sc, set_plist_2(sc, i1, i2))); +#else + return(method_or_bust(sc, i1, sc->logbit_symbol, set_plist_2(sc, i1, i2), 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 (arg2 >= S7_INT_BITS) + { + if ((arg1 == -1) && (arg2 == 63)) /* (ash -1 63): most-negative-fixnum */ + return(S7_INT64_MIN); + if (arg1 == 0) return(0); + out_of_range_error_nr(sc, sc->ash_symbol, int_two, wrap_integer(sc, arg2), it_is_too_large_string); + } + if (arg2 < 0) + { + if (arg2 < -S7_INT_BITS) + return((arg1 < 0) ? -1 : 0); /* (ash -31 -100) */ + return(arg1 >> -arg2); + } + /* (ash 9223372036854775807 1) -> -2, anyone using ash must know something about bits */ + 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 */ + const s7_pointer i1 = car(args), i2 = 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(i1)) && /* this includes bignum ints... */ + (s7_is_integer(i2))) + { + s7_int shift; + bool i1_is_big = is_big_number(i1); + int32_t i1_compared_to_zero = 0; + + if (i1_is_big) + i1_compared_to_zero = mpz_cmp_ui(big_integer(i1), 0); + else + if (integer(i1) > 0) + i1_compared_to_zero = 1; + else i1_compared_to_zero = (integer(i1) < 0) ? -1 : 0; + + if (i1_compared_to_zero == 0) + return(int_zero); + + if (is_big_number(i2)) + { + if (!mpz_fits_sint_p(big_integer(i2))) + { + if (mpz_cmp_ui(big_integer(i2), 0) > 0) + out_of_range_error_nr(sc, sc->ash_symbol, int_two, i2, it_is_too_large_string); + + /* here if i1 is negative, we need to return -1 */ + return((i1_compared_to_zero == 1) ? int_zero : minus_one); + } + shift = mpz_get_si(big_integer(i2)); + } + else + { + shift = integer(i2); + if (shift < S7_INT32_MIN) + return((i1_compared_to_zero == 1) ? int_zero : minus_one); + } + if (shift > S7_INT32_MAX) + out_of_range_error_nr(sc, sc->ash_symbol, int_two, i2, it_is_too_large_string); /* gmp calls abort if overflow here */ + + if (is_t_big_integer(i1)) + mpz_set(sc->mpz_1, big_integer(i1)); + else mpz_set_si(sc->mpz_1, integer(i1)); + + 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)); + } +#endif + const 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)))); +} + +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);} + +#if !WITH_GMP +static s7_int ash_i_7ii(s7_scheme *sc, s7_int i1, s7_int i2) {return(c_ash(sc, i1, i2));} +/* this duplication (with c_ash) makes a big difference to callgrind -- why? */ + +static s7_pointer g_ash_ii(s7_scheme *sc, s7_pointer args) {return(make_integer(sc, c_ash(sc, integer(car(args)), integer(cadr(args)))));} + +static s7_pointer g_ash_ic(s7_scheme *sc, s7_pointer args) +{ + s7_pointer x = car(args); + s7_int y = integer(cadr(args)); + if (!s7_is_integer(x)) + return(method_or_bust(sc, x, sc->ash_symbol, args, sc->type_names[T_INTEGER], 1)); + return(make_integer(sc, c_ash(sc, integer(x), y))); +} + +static s7_pointer ash_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 2) + { + s7_pointer arg2 = caddr(expr); + if (has_two_int_args(sc, expr)) return(sc->ash_ii); + if ((is_t_integer(arg2)) && (integer(arg2) > 0) && (integer(arg2) < S7_INT_BITS)) return(sc->ash_ic); + } + return(func); +} +#endif + + +/* -------------------------------- 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 rs, seed; + if (is_null(args)) + seed = s7_int_to_big_integer(sc, 1234); /* ?? */ + else + { + 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, rs, T_RANDOM_STATE); + gmp_randinit_default(random_gmp_state(rs)); /* Mersenne twister */ + gmp_randseed(random_gmp_state(rs), big_integer(seed)); /* this is ridiculously slow! */ + add_big_random_state(sc, rs); + return(rs); +#else + s7_pointer r1, r2, rs; + 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, rs, T_RANDOM_STATE); + random_seed(rs) = (s7_uint)i1; + random_carry(rs) = 1675393560; /* should this be dependent on the seed? */ + return(rs); + } + + 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, rs, T_RANDOM_STATE); + random_seed(rs) = (s7_uint)i1; + random_carry(rs) = (s7_uint)i2; + return(rs); +#endif +} + +#if 0 + PERHAPS: a 64-bit MWC from https://prng.di.unimi.it/#shootout + #define MWC_A1 0xffebb71d94fcdaf9 + /* The state must be initialized so that 0 < c < MWC_A1 - 1. + For simplicity, we suggest to set c = 1 and x to a 64-bit seed. */ + s7_uint x, c; + + s7_uint inline next() { + const s7_uint result = x; // Or, result = x ^ (x << 32) (see above) + const __uint128_t t = MWC_A1 * (__uint128_t)x + c; + x = t; + c = t >> 64; + return result; + } +#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 r) {return(type(r) == 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 rs; + new_cell(sc, rs, T_RANDOM_STATE); + random_seed(rs) = (s7_uint)seed; + random_carry(rs) = (s7_uint)carry; + sc->default_random_state = rs; +#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) + * + * see random_state for 64 bit version of this, L26555 g_random_state + */ + #define RAN_MULT 2131995753UL + + double result; + s7_uint 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) 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: + { + const s7_double x = fraction(num); + s7_double 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 + { + s7_int 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_simpler_ratio_or_integer(sc, numer, denom)); + } + case T_REAL: + return(make_real(sc, real(num) * next_random(r))); + /* (x >> 11) * 0x1.0p-53, (1LL << 50) * 0x1.0p-53) -> .125, here "x" is 64 bits, but isn't this int64 related? */ + 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_p_p_wrapped(s7_scheme *sc, s7_pointer num) +{ +#if !WITH_GMP + if (is_t_integer(num)) + return(wrap_integer(sc, (s7_int)(integer(num) * next_random(sc->default_random_state)))); + if (is_t_real(num)) + return(wrap_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 func, 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(func); +} + +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_wrapped(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 c) +{ + if (!is_character(c)) + return(integer(method_or_bust_p(sc, c, sc->char_to_integer_symbol, sc->type_names[T_CHARACTER]))); + return(character(c)); +} + +static s7_pointer char_to_integer_p_p(s7_scheme *sc, s7_pointer c) +{ + if (!is_character(c)) + return(method_or_bust_p(sc, c, sc->char_to_integer_symbol, sc->type_names[T_CHARACTER])); + return(make_integer(sc, character(c))); +} + +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 doesn't fit in an unsigned byte", 34)); + 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 doesn't fit in an unsigned byte", 34)); /* 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 int digitp(int c) {return(((c >= '0') && (c <= '9')) ? 1 : 0);} + +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[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) = "#"; + chars++; /* now chars[EOF] == chars[-1] == # */ + cells++; /* I tried a version without the cells array using &chars[] everywhere -- decided it was ugly */ + + 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)digitp(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 c) {return(is_character(c));} + +uint8_t s7_character(s7_pointer c) {return(character(c));} + + +/* -------------------------------- 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-ciis_char_symbol); + if (func != sc->undefined) + return(is_true(sc, s7_apply_function(sc, func, set_plist_1(sc, p)))); + } + return(false); +} + +static s7_pointer char_with_error_check(s7_scheme *sc, s7_pointer args_left, s7_pointer args, s7_pointer caller) +{ + for (s7_pointer chrs = cdr(args_left); is_pair(chrs); chrs = cdr(chrs)) /* before returning #f, check for bad trailing arguments */ + if (!is_character_via_method(sc, car(chrs))) + wrong_type_error_nr(sc, caller, position_of(chrs, args), car(chrs), 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 chr = car(args); + if (!is_character(chr)) + return(method_or_bust(sc, chr, sym, args, sc->type_names[T_CHARACTER], 1)); + for (s7_pointer chrs = cdr(args); is_pair(chrs); chr = car(chrs), chrs = cdr(chrs)) + { + if (!is_character(car(chrs))) + return(method_or_bust(sc, car(chrs), sym, set_ulist_1(sc, chr, chrs), sc->type_names[T_CHARACTER], position_of(chrs, args))); + if (charcmp(character(chr), character(car(chrs))) != val) + return(char_with_error_check(sc, chrs, 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 chr = car(args); + if (!is_character(chr)) + return(method_or_bust(sc, chr, sym, args, sc->type_names[T_CHARACTER], 1)); + for (s7_pointer chrs = cdr(args); is_pair(chrs); chr = car(chrs), chrs = cdr(chrs)) + { + if (!is_character(car(chrs))) + return(method_or_bust(sc, car(chrs), sym, set_ulist_1(sc, chr, chrs), sc->type_names[T_CHARACTER], position_of(chrs, args))); + if (charcmp(character(chr), character(car(chrs))) == val) + return(char_with_error_check(sc, chrs, 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 + + const s7_pointer chr = car(args); + if (!is_character(chr)) + return(method_or_bust(sc, chr, sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 1)); + for (s7_pointer chrs = cdr(args); is_pair(chrs); chrs = cdr(chrs)) + { + if (!is_character(car(chrs))) + return(method_or_bust(sc, car(chrs), sc->char_eq_symbol, set_ulist_1(sc, chr, chrs), sc->type_names[T_CHARACTER], position_of(chrs, args))); + if (car(chrs) != chr) + return(char_with_error_check(sc, chrs, 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 "(charpcl_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 */ +static s7_pointer g_simple_char_eq1(s7_scheme *sc, s7_pointer args) +{ + s7_pointer c1 = car(args), c2 = cadr(args); + if (!is_character(c2)) return(method_or_bust(sc, c2, sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 2)); + return(make_boolean(sc, c1 == c2)); /* chars are unique so we can compare pointers */ +} +static s7_pointer g_simple_char_eq2(s7_scheme *sc, s7_pointer args) +{ + s7_pointer c1 = car(args), c2 = cadr(args); + if (!is_character(c1)) return(method_or_bust(sc, c1, sc->char_eq_symbol, args, sc->type_names[T_CHARACTER], 1)); + return(make_boolean(sc, c1 == c2)); +} + +#define check_char2_args(Sc, Caller, C1, C2) \ + do { \ + if (!is_character(C1)) return(method_or_bust(Sc, C1, Caller, set_plist_2(Sc, C1, C2), sc->type_names[T_CHARACTER], 1) != sc->F); \ + if (!is_character(C2)) return(method_or_bust(Sc, C2, Caller, set_plist_2(Sc, C1, C2), sc->type_names[T_CHARACTER], 2) != sc->F); \ + } while (0) + +static bool char_lt_b_unchecked(s7_pointer c1, s7_pointer c2) {return(c1 < c2);} +static bool char_lt_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2) +{ + check_char2_args(sc, sc->char_lt_symbol, c1, c2); + return(c1 < c2); +} + +static bool char_leq_b_unchecked(s7_pointer c1, s7_pointer c2) {return(c1 <= c2);} +static bool char_leq_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2) +{ + check_char2_args(sc, sc->char_leq_symbol, c1, c2); + return(c1 <= c2); +} + +static bool char_gt_b_unchecked(s7_pointer c1, s7_pointer c2) {return(c1 > c2);} +static bool char_gt_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2) +{ + check_char2_args(sc, sc->char_gt_symbol, c1, c2); + return(c1 > c2); +} + +static bool char_geq_b_unchecked(s7_pointer c1, s7_pointer c2) {return(c1 >= c2);} +static bool char_geq_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2) +{ + check_char2_args(sc, sc->char_geq_symbol, c1, c2); + return(c1 >= c2); +} + +static bool char_eq_b_unchecked(s7_pointer c1, s7_pointer c2) {return(c1 == c2);} + +static bool char_eq_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2) +{ + if (!is_character(c1)) return(method_or_bust(sc, c1, sc->char_eq_symbol, set_plist_2(sc, c1, c2), sc->type_names[T_CHARACTER], 1) != sc->F); + if (c1 == c2) return(true); + if (!is_character(c2)) return(method_or_bust(sc, c2, sc->char_eq_symbol, set_plist_2(sc, c1, c2), sc->type_names[T_CHARACTER], 2) != sc->F); + return(false); +} + +static s7_pointer char_eq_p_pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2) +{ + if (!is_character(c1)) return(method_or_bust(sc, c1, sc->char_eq_symbol, set_plist_2(sc, c1, c2), sc->type_names[T_CHARACTER], 1)); + if (c1 == c2) return(sc->T); + if (!is_character(c2)) return(method_or_bust(sc, c2, sc->char_eq_symbol, set_plist_2(sc, c1, c2), 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 func, int32_t args, s7_pointer expr) +{ + if (args != 2) return(func); + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if (returns_char(sc, arg1)) + { + if (returns_char(sc, arg2)) return(sc->simple_char_eq); + return(sc->simple_char_eq1); + } + else + if (returns_char(sc, arg2)) return(sc->simple_char_eq2); + } + return(sc->char_equal_2); +} + +static s7_pointer char_less_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) {return((args == 2) ? sc->char_less_2 : func);} +static s7_pointer char_greater_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) {return((args == 2) ? sc->char_greater_2 : func);} + + +/* -------------------------------- 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 chr = car(args); + if (!is_character(chr)) + return(method_or_bust(sc, chr, sym, args, sc->type_names[T_CHARACTER], 1)); + + for (s7_pointer chrs = cdr(args); is_pair(chrs); chr = car(chrs), chrs = cdr(chrs)) + { + if (!is_character(car(chrs))) + return(method_or_bust(sc, car(chrs), sym, set_ulist_1(sc, chr, chrs), sc->type_names[T_CHARACTER], position_of(chrs, args))); + if (charcmp(upper_character(chr), upper_character(car(chrs))) != val) + return(char_with_error_check(sc, chrs, 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 chr = car(args); + if (!is_character(chr)) + return(method_or_bust(sc, chr, sym, args, sc->type_names[T_CHARACTER], 1)); + for (s7_pointer chrs = cdr(args); is_pair(chrs); chr = car(chrs), chrs = cdr(chrs)) + { + if (!is_character(car(chrs))) + return(method_or_bust(sc, car(chrs), sym, set_ulist_1(sc, chr, chrs), sc->type_names[T_CHARACTER], position_of(chrs, args))); + if (charcmp(upper_character(chr), upper_character(car(chrs))) == val) + return(char_with_error_check(sc, chrs, 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-cipcl_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 c1, s7_pointer c2) {return(upper_character(c1) < upper_character(c2));} +static bool char_ci_lt_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2) +{ + check_char2_args(sc, sc->char_ci_lt_symbol, c1, c2); + return(upper_character(c1) < upper_character(c2)); +} + +static bool char_ci_leq_b_unchecked(s7_pointer c1, s7_pointer c2) {return(upper_character(c1) <= upper_character(c2));} +static bool char_ci_leq_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2) +{ + check_char2_args(sc, sc->char_ci_leq_symbol, c1, c2); + return(upper_character(c1) <= upper_character(c2)); +} + +static bool char_ci_gt_b_unchecked(s7_pointer c1, s7_pointer c2) {return(upper_character(c1) > upper_character(c2));} +static bool char_ci_gt_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2) +{ + check_char2_args(sc, sc->char_ci_gt_symbol, c1, c2); + return(upper_character(c1) > upper_character(c2)); +} + +static bool char_ci_geq_b_unchecked(s7_pointer c1, s7_pointer c2) {return(upper_character(c1) >= upper_character(c2));} +static bool char_ci_geq_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2) +{ + check_char2_args(sc, sc->char_ci_geq_symbol, c1, c2); + return(upper_character(c1) >= upper_character(c2)); +} + +static bool char_ci_eq_b_unchecked(s7_pointer c1, s7_pointer c2) {return(upper_character(c1) == upper_character(c2));} +static bool char_ci_eq_b_7pp(s7_scheme *sc, s7_pointer c1, s7_pointer c2) +{ + check_char2_args(sc, sc->char_ci_eq_symbol, c1, c2); + return(upper_character(c1) == upper_character(c2)); +} + +#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; + 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 chr, s7_pointer str, s7_int start) +{ + if (!is_string(str)) + wrong_type_error_nr(sc, sc->char_position_symbol, 2, str, 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); + { + const char *p; + char c = character(chr); + s7_int len = string_length(str); + const char *porig = string_value(str); + 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; + const char c = character(car(args)); + const 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))) + { + const 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); + { + const char *p = strchr((const char *)(porig + start), (int)c); /* const for g++, see also below */ + return((p) ? make_integer(sc, p - porig) : sc->F); + } +} + +static s7_pointer char_position_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if ((is_character(cadr(expr))) && ((args == 2) || (args == 3))) + return(sc->char_position_csi); + return(func); +} + + +/* -------------------------------- 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) + s7_int start = 0; + const s7_pointer str1 = car(args), str2 = cadr(args); + + if (!is_string(str1)) + return(method_or_bust(sc, str1, sc->string_position_symbol, args, sc->type_names[T_STRING], 1)); + if (!is_string(str2)) + return(method_or_bust(sc, str2, sc->string_position_symbol, args, sc->type_names[T_STRING], 2)); + + if (is_pair(cddr(args))) + { + const 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(str1) == 0) return(sc->F); + if (start >= string_length(str2)) return(sc->F); + { + const char *s1 = string_value(str1); + const char *s2 = string_value(str2); + const char *p2 = strstr((const char *)(s2 + start), s1); /* g++ insists on const */ + 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); +} + + +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) +{ + const 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[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, x)); + sc->string_wrapper_allocs++; +#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 new_string; + block_t *b; + if (len == 0) return(nil_string); + new_cell(sc, new_string, T_STRING); + b = inline_mallocate(sc, len + 1); + string_block(new_string) = b; + string_value(new_string) = (char *)block_data(b); + if (fill != '\0') + local_memset((void *)(string_value(new_string)), fill, len); + string_value(new_string)[len] = 0; + string_hash(new_string) = 0; + string_length(new_string) = len; + add_string(sc, new_string); + return(new_string); +} + +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) +{ + s7_int len = safe_strlen(str); + return((len > 0) ? make_string_with_length(sc, str, len) : 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 new_string; + s7_int len; + if (!str) return(nil_string); + new_string = alloc_pointer(sc); + set_full_type(new_string, T_STRING | T_IMMUTABLE | T_UNHEAP); + set_optimize_op(new_string, OP_CONSTANT); + len = safe_strlen(str); + string_length(new_string) = len; + string_block(new_string) = NULL; + string_value(new_string) = (char *)permalloc(sc, len + 1); + memcpy((void *)string_value(new_string), (const void *)str, len); + string_value(new_string)[len] = 0; + string_hash(new_string) = 0; + return(new_string); +} + +static s7_pointer make_permanent_string(const char *str, s7_int len) /* for (s7) strings outside all s7 GC's */ +{ + s7_pointer new_string = (s7_pointer)Malloc(sizeof(s7_cell)); /* was Calloc 22-May-25 */ + full_type(new_string) = T_STRING | T_IMMUTABLE | T_UNHEAP; /* not set_full_type if calloc'd */ + set_optimize_op(new_string, OP_CONSTANT); + string_length(new_string) = len; + if ((S7_DEBUGGING) && (len != safe_strlen(str))) fprintf(stderr, "%s[%d]: strlen(%s) != %" ld64 "\n", __func__, __LINE__, str, safe_strlen(str)); + string_block(new_string) = NULL; + string_value(new_string) = (char *)str; + string_hash(new_string) = 0; + return(new_string); +} + +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? -- (copy str (make-string 0))! */ + 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_boolean_string = make_permanent_string("a boolean", 9); + a_byte_vector_string = make_permanent_string("a byte-vector", 13); + a_format_port_string = make_permanent_string("#f, #t, (), or an open output port", 34); + a_let_string = make_permanent_string("a let (an environment)", 22); + a_list_string = make_permanent_string("a list", 6); + a_non_constant_symbol_string = make_permanent_string("a non-constant symbol", 21); + a_non_negative_integer_string = make_permanent_string("a non-negative integer", 22); + a_normal_procedure_string = make_permanent_string("a normal procedure", 18); + a_normal_real_string = make_permanent_string("a normal real", 13); + a_number_string = make_permanent_string("a number", 8); + a_procedure_or_a_macro_string = make_permanent_string("a procedure or a macro", 22); + a_procedure_string = make_permanent_string("a procedure", 11); + a_proper_list_string = make_permanent_string("a proper list", 13); + a_random_state_object_string = make_permanent_string("a random-state object", 21); + a_rational_string = make_permanent_string("an integer or a ratio", 21); + a_sequence_string = make_permanent_string("a sequence", 10); + a_symbol_string = make_permanent_string("a symbol", 8); + a_thunk_string = make_permanent_string("a thunk", 7); + a_valid_radix_string = make_permanent_string("it should be between 2 and 16", 29); + an_association_list_string = make_permanent_string("an association list", 19); + an_eq_func_string = make_permanent_string("a procedure that can take two arguments", 39); + an_input_file_port_string = make_permanent_string("an input file port", 18); + an_input_port_string = make_permanent_string("an input port", 13); + an_input_string_port_string = make_permanent_string("an input string port", 20); + 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_file_port_string = make_permanent_string("an output file port", 19); + an_output_port_or_f_string = make_permanent_string("an output port or #f", 20); + an_output_port_string = make_permanent_string("an output port", 14); + an_output_string_port_string = make_permanent_string("an output string port", 21); + an_unsigned_byte_string = make_permanent_string("an unsigned byte", 16); + cant_bind_immutable_string = make_permanent_string("~A: can't bind an immutable object: ~S", 38); + immutable_error_string = make_permanent_string("can't ~S ~S (it is immutable)", 29); + intermediate_too_large_string = make_permanent_string("intermediate result is too large", 32); + it_is_infinite_string = make_permanent_string("it is infinite", 14); + it_is_nan_string = make_permanent_string("NaN usually indicates a numerical error", 39); + it_is_negative_string = make_permanent_string("it is negative", 14); + 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); + parameter_set_twice_string = make_permanent_string("parameter set twice, ~S in ~S", 29); + result_is_too_large_string = make_permanent_string("result is too large", 19); + something_applicable_string = make_permanent_string("a procedure or something applicable", 35); + too_many_indices_string = make_permanent_string("too many indices", 16); +#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) + + const s7_pointer n = car(args); + s7_int len; + if (!s7_is_integer(n)) + { + if_method_exists_return_value(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" */ + { + char fill = s7_character(cadr(args)); + s7_pointer result = make_empty_string(sc, len, fill); + if (fill == '\0') + memclr((void *)string_value(result), (size_t)len); + return(result); + } +} + +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 str = car(args); + if (!is_string(str)) + return(sole_arg_method_or_bust(sc, str, sc->string_length_symbol, args, sc->type_names[T_STRING])); + return(make_integer(sc, string_length(str))); +} + +static s7_int string_length_i_7p(s7_scheme *sc, s7_pointer str) +{ + if (!is_string(str)) + return(integer(method_or_bust_p(sc, str, sc->string_length_symbol, sc->type_names[T_STRING]))); + return(string_length(str)); +} +#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 + + const s7_pointer str = car(args); + if (!is_string(str)) + return(method_or_bust_p(sc, str, sc->string_downcase_symbol, sc->type_names[T_STRING])); + { + const s7_int len = string_length(str); + const s7_pointer newstr = make_empty_string(sc, len, '\0'); + const uint8_t *ostr = (const uint8_t *)string_value(str); + uint8_t *nstr = (uint8_t *)string_value(newstr); + + if (len >= 128) + { + s7_int 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 (s7_int 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 + + const s7_pointer str = car(args); + if (!is_string(str)) + return(method_or_bust_p(sc, str, sc->string_upcase_symbol, sc->type_names[T_STRING])); + + { + const s7_int len = string_length(str); + const s7_pointer newstr = make_empty_string(sc, len, '\0'); + const uint8_t *ostr = (const uint8_t *)string_value(str); + uint8_t *nstr = (uint8_t *)string_value(newstr); + + if (len >= 128) + { + s7_int 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 (s7_int 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 str = car(args); + if (!is_string(str)) + return(method_or_bust(sc, str, sc->string_ref_symbol, args, sc->type_names[T_STRING], 1)); + return(string_ref_1(sc, str, cadr(args))); +} + +static s7_pointer string_ref_p_pi(s7_scheme *sc, s7_pointer str, s7_int index) +{ + if (!is_string(str)) + return(method_or_bust(sc, str, sc->string_ref_symbol, set_plist_2(sc, str, make_integer(sc, index)), sc->type_names[T_STRING], 1)); + if ((index < 0) || (index >= string_length(str))) + out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(chars[((uint8_t *)string_value(str))[index]]); +} + +static s7_pointer string_ref_p_pp(s7_scheme *sc, s7_pointer str, s7_pointer index) +{ + if (!is_string(str)) + return(method_or_bust_pp(sc, str, sc->string_ref_symbol, str, index, sc->type_names[T_STRING], 1)); + return(string_ref_1(sc, str, index)); +} + +static s7_pointer string_ref_p_p0(s7_scheme *sc, s7_pointer str, s7_pointer unused_index) +{ + if (!is_string(str)) + return(method_or_bust_pp(sc, str, sc->string_ref_symbol, str, int_zero, sc->type_names[T_STRING], 1)); + if (string_length(str) <= 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(str))[0]]); +} + +static s7_pointer string_plast_via_method(s7_scheme *sc, s7_pointer str) /* tmock */ +{ + s7_pointer len = method_or_bust_p(sc, str, sc->length_symbol, sc->type_names[T_STRING]); + return(method_or_bust_pp(sc, str, sc->string_ref_symbol, str, make_integer(sc, integer(len) - 1), sc->type_names[T_STRING], 1)); +} + +static s7_pointer string_ref_p_plast(s7_scheme *sc, s7_pointer str, s7_pointer unused_index) +{ + if (!is_string(str)) + return(string_plast_via_method(sc, str)); + if (string_length(str) <= 0) + out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, wrap_integer(sc, string_length(str) - 1), it_is_too_large_string); + return(chars[((uint8_t *)string_value(str))[string_length(str) - 1]]); +} + +static inline s7_pointer string_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer str, s7_int index) +{ + if ((index < 0) || (index >= string_length(str))) + out_of_range_error_nr(sc, sc->string_ref_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(chars[((uint8_t *)string_value(str))[index]]); +} + +static s7_pointer string_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer str, s7_int index) {return(chars[((uint8_t *)string_value(str))[index]]);} + + +/* -------------------------------- 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) + + const s7_pointer strng = car(args), index = cadr(args); + 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); + { + char *str = string_value(strng); + s7_pointer 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 str, s7_int index, s7_pointer chr) +{ + if (!is_string(str)) + wrong_type_error_nr(sc, sc->string_set_symbol, 1, str, sc->type_names[T_STRING]); + if (!is_character(chr)) + wrong_type_error_nr(sc, sc->string_set_symbol, 2, chr, sc->type_names[T_CHARACTER]); + if ((index >= 0) && (index < string_length(str))) + string_value(str)[index] = s7_character(chr); + else out_of_range_error_nr(sc, sc->string_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(chr); +} + +static s7_pointer string_set_p_pip_unchecked(s7_scheme *sc, s7_pointer str, s7_int index, s7_pointer chr) +{ + if ((index >= 0) && (index < string_length(str))) + string_value(str)[index] = s7_character(chr); + else out_of_range_error_nr(sc, sc->string_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(chr); +} + +static s7_pointer string_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer str, s7_int index, s7_pointer chr) +{ + string_value(str)[index] = s7_character(chr); + return(chr); +} + + +/* -------------------------------- string-append -------------------------------- */ +static s7_pointer c_object_length(s7_scheme *sc, s7_pointer obj); + +static bool sequence_is_empty(s7_scheme *sc, s7_pointer seq) /* "is_empty" is taken by C++?? */ +{ + switch (type(seq)) + { + case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_COMPLEX_VECTOR: + case T_VECTOR: return(vector_length(seq) == 0); + case T_NIL: return(true); + case T_PAIR: return(false); + case T_STRING: return(string_length(seq) == 0); + case T_HASH_TABLE: return(hash_table_entries(seq) == 0); + case T_C_OBJECT: return(s7_is_eqv(sc, c_object_length(sc, seq), int_zero)); + case T_LET: if (seq != sc->rootlet) return(!tis_slot(let_slots(seq))); /* (append (rootlet) #f) */ + default: return(false); + } +} + +static s7_int sequence_length(s7_scheme *sc, s7_pointer seq) +{ + switch (type(seq)) + { + case T_PAIR: + { + s7_int len = s7_list_length(sc, seq); + return((len == 0) ? -1 : len); + } + case T_NIL: return(0); + case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_COMPLEX_VECTOR: + case T_VECTOR: return(vector_length(seq)); + case T_STRING: return(string_length(seq)); + case T_HASH_TABLE: return(hash_table_entries(seq)); + case T_LET: return(let_length(sc, seq)); + case T_C_OBJECT: + { + s7_pointer x = c_object_length(sc, seq); + 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 = string_value(newstr); + for (s7_pointer strs = args; strs != stop_arg; strs = cdr(strs)) + { + s7_pointer str = car(strs); + if (is_string(str)) + { + len = string_length(str); + if (len > 0) + { + memcpy(pos, string_value(str), len); + pos += len; + }} + else + if (!sequence_is_empty(sc, str)) + { + char *old_str = string_value(newstr); + string_value(newstr) = pos; + len = sequence_length(sc, str); + s7_copy_1(sc, caller, set_plist_2(sc, str, 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 newstr; + bool just_strings = true; + + if (is_null(args)) + return(nil_string); + + gc_protect_via_stack(sc, args); + /* get length for new string */ + for (s7_pointer strs = args; is_pair(strs); strs = cdr(strs)) + { + const s7_pointer str = car(strs); + if (is_string(str)) + len += string_length(str); + else + { + s7_int newlen; + if (!is_sequence(str)) + { + unstack_gc_protect(sc); + wrong_type_error_nr(sc, caller, position_of(strs, args), str, sc->type_names[T_STRING]); + } + if (has_active_methods(sc, str)) /* look for string-append and if found, cobble up a plausible intermediate call */ + { + const s7_pointer func = find_method_with_let(sc, str, caller); + if (func != sc->undefined) + { + if (len == 0) + { + unstack_gc_protect(sc); + return(s7_apply_function(sc, func, strs)); /* not args (string-append "" "" ...) */ + } + newstr = make_empty_string(sc, len, '\0'); + string_append_2(sc, newstr, args, strs, caller); + unstack_gc_protect(sc); + return(s7_apply_function(sc, func, set_ulist_1(sc, newstr, strs))); + }} + if ((caller == sc->string_append_symbol) || (caller == sc->symbol_symbol)) + { + unstack_gc_protect(sc); + wrong_type_error_nr(sc, caller, position_of(strs, args), str, sc->type_names[T_STRING]); + } + newlen = sequence_length(sc, str); + if (newlen < 0) + { + unstack_gc_protect(sc); + wrong_type_error_nr(sc, caller, position_of(strs, args), str, 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) + { + s7_pointer strs = args; + for (char *pos = string_value(newstr); is_pair(strs); strs = cdr(strs)) + { + len = string_length(car(strs)); + if (len > 0) + { + memcpy(pos, string_value(car(strs)), 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; + const s7_int 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))); + begin_temp(sc->x, s2); /* or temp6 if this collides */ + 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)); + end_temp(sc->x); + 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 func, int32_t args, s7_pointer expr) +{ + check_for_substring_temp(sc, expr); + return((args == 2) ? sc->string_append_2 : func); +} + + +/* -------------------------------- 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 sc->unused if method called but wants to indicate that it gives up -- is this useful?? */ + const 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))) + { + const 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_signature(sc, 4, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol) + + const s7_pointer 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))) + { + s7_pointer p = start_and_end(sc, sc->substring_symbol, args, 2, cdr(args), &start, &end); + if (p != sc->unused) return(p); + } + s = string_value(str); + len = end - start; + if (len == 0) return(nil_string); + { + s7_pointer result = inline_make_string_with_length(sc, (char *)(s + start), len); + string_value(result)[len] = 0; + return(result); + } +} + +static s7_pointer g_substring_uncopied(s7_scheme *sc, s7_pointer args) +{ + #define H_substring_uncopied "(substring-uncopied str start (end (length str))) returns an immutable string sharing the portion of the string str between start and \ +end: (substring-uncopied \"01234\" 1 2) -> \"1\". substring-uncopied does not GC protect the original string; it is intended for very brief uses." + #define Q_substring_uncopied s7_make_signature(sc, 4, sc->is_string_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_integer_symbol) + + const s7_pointer str = car(args); + s7_int start = 0, end; + + if (!is_string(str)) + return(method_or_bust(sc, str, sc->substring_uncopied_symbol, args, sc->type_names[T_STRING], 1)); + end = string_length(str); + if (!is_null(cdr(args))) + { + s7_pointer p = start_and_end(sc, sc->substring_uncopied_symbol, args, 2, cdr(args), &start, &end); + if (p != sc->unused) return(p); + } + 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) already checked in opt */ + if ((end < start) || (end > string_length(str))) + out_of_range_error_nr(sc, sc->substring_uncopied_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_uncopied_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)) + { + const 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_class_and_fn_proc(arg, sc->substring_uncopied); + substrs++; + } + else + if (fn_proc(arg) == g_symbol_to_string) + set_class_and_fn_proc(arg, sc->symbol_to_string_uncopied); + else + if ((fn_proc(arg) == g_get_output_string) && (is_null(cddr(arg)))) + set_class_and_fn_proc(arg, sc->get_output_string_uncopied); + }} +} + +static s7_pointer string_substring_chooser(s7_scheme *sc, s7_pointer func, int32_t unused_args, s7_pointer expr) +{ + /* used by several string functions */ + check_for_substring_temp(sc, expr); + return(func); +} + + +/* -------------------------------- 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) + + const s7_pointer source = car(args); + s7_pointer 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))) + { + if (string_length(source) == 0) return(nil_string); + 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 sourcechar #xf0)) (string (integer->char #x70))) + * and null or lack thereof does not say anything about the string end + */ + const size_t len1 = (size_t)string_length(s1); + const size_t len2 = (size_t)string_length(s2); + const size_t len = (len1 > len2) ? len2 : len1; + const char *str1 = string_value(s1); + const 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 obj) +{ + if (s7_is_string(obj)) + return(true); + if (has_active_methods(sc, obj)) + { + s7_pointer func = find_method_with_let(sc, obj, sc->is_string_symbol); + if (func != sc->undefined) + return(is_true(sc, s7_apply_function(sc, func, set_plist_1(sc, obj)))); + } + return(false); +} + +static s7_pointer g_string_cmp(s7_scheme *sc, s7_pointer args, int32_t val, s7_pointer sym) +{ + s7_pointer str = car(args); + if (!is_string(str)) + return(method_or_bust(sc, str, sym, args, sc->type_names[T_STRING], 1)); + for (s7_pointer strs = cdr(args); is_pair(strs); str = car(strs), strs = cdr(strs)) + { + if (!is_string(car(strs))) + return(method_or_bust(sc, car(strs), sym, set_ulist_1(sc, str, strs), sc->type_names[T_STRING], position_of(strs, args))); + if (scheme_strcmp(str, car(strs)) != val) + { + for (str = cdr(strs); is_pair(str); str = cdr(str)) + if (!is_string_via_method(sc, car(str))) + wrong_type_error_nr(sc, sym, position_of(str, args), car(str), 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 str = car(args); + if (!is_string(str)) + return(method_or_bust(sc, str, sym, args, sc->type_names[T_STRING], 1)); + for (s7_pointer strs = cdr(args); is_pair(strs); str = car(strs), strs = cdr(strs)) + { + if (!is_string(car(strs))) + return(method_or_bust(sc, car(strs), sym, set_ulist_1(sc, str, strs), sc->type_names[T_STRING], position_of(strs, args))); + if (scheme_strcmp(str, car(strs)) == val) + { + for (str = cdr(strs); is_pair(str); str = cdr(str)) + if (!is_string_via_method(sc, car(str))) + wrong_type_error_nr(sc, sym, position_of(str, args), car(str), 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)))); /* unaligned */ +} + +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 str = car(args); + + if (!is_string(str)) + return(method_or_bust(sc, str, sc->string_eq_symbol, args, sc->type_names[T_STRING], 1)); + for (s7_pointer arglist = cdr(args); is_pair(arglist); arglist = cdr(arglist)) + { + s7_pointer p = car(arglist); + if (!is_string(p)) + return(method_or_bust(sc, p, sc->string_eq_symbol, set_ulist_1(sc, str, arglist), sc->type_names[T_STRING], position_of(arglist, args))); + if (!scheme_strings_are_equal(p, str)) + { + for (str = cdr(arglist); is_pair(str); str = cdr(str)) + if (!is_string_via_method(sc, car(str))) + wrong_type_error_nr(sc, sc->string_eq_symbol, position_of(str, args), car(str), sc->type_names[T_STRING]); + return(sc->F); + }} + return(sc->T); +} + +static s7_pointer g_strings_are_less(s7_scheme *sc, s7_pointer args) +{ + #define H_strings_are_less "(stringpcl_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 str1, s7_pointer str2) +{ + if (!is_string(str1)) + return(method_or_bust(sc, str1, sc->string_eq_symbol, set_plist_2(sc, str1, str2), sc->type_names[T_STRING], 1)); + if (!is_string(str2)) + return(method_or_bust(sc, str2, sc->string_eq_symbol, set_plist_2(sc, str1, str2), sc->type_names[T_STRING], 2)); + return(make_boolean(sc, scheme_strings_are_equal(str1, str2))); +} + +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 str1, s7_pointer str2) +{ + if (!is_string(str1)) + return(method_or_bust(sc, str1, sc->string_lt_symbol, set_plist_2(sc, str1, str2), sc->type_names[T_STRING], 1)); + if (!is_string(str2)) + return(method_or_bust(sc, str2, sc->string_lt_symbol, set_plist_2(sc, str1, str2), sc->type_names[T_STRING], 2)); + return(make_boolean(sc, scheme_strcmp(str1, str2) == -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 str1, s7_pointer str2) +{ + if (!is_string(str1)) + return(method_or_bust(sc, str1, sc->string_gt_symbol, set_plist_2(sc, str1, str2), sc->type_names[T_STRING], 1)); + if (!is_string(str2)) + return(method_or_bust(sc, str2, sc->string_gt_symbol, set_plist_2(sc, str1, str2), sc->type_names[T_STRING], 2)); + return(make_boolean(sc, scheme_strcmp(str1, str2) == 1)); +} + +#define check_string2_args(Sc, Caller, Str1, Str2) \ + do { \ + if (!is_string(Str1)) return(method_or_bust(sc, Str1, Caller, set_plist_2(Sc, Str1, Str2), sc->type_names[T_STRING], 1) != Sc->F); \ + if (!is_string(Str2)) return(method_or_bust(sc, Str2, Caller, set_plist_2(Sc, Str1, Str2), sc->type_names[T_STRING], 2) != Sc->F); \ + } while (0) + +static bool string_lt_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcmp(str1, str2) == -1);} +static bool string_lt_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2) +{ + check_string2_args(sc, sc->string_lt_symbol, str1, str2); + return(scheme_strcmp(str1, str2) == -1); +} + +static bool string_leq_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcmp(str1, str2) != 1);} +static bool string_leq_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2) +{ + check_string2_args(sc, sc->string_leq_symbol, str1, str2); + return(scheme_strcmp(str1, str2) != 1); +} + +static bool string_gt_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcmp(str1, str2) == 1);} +static bool string_gt_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2) +{ + check_string2_args(sc, sc->string_gt_symbol, str1, str2); + return(scheme_strcmp(str1, str2) == 1); +} + +static bool string_geq_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcmp(str1, str2) != -1);} +static bool string_geq_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2) +{ + check_string2_args(sc, sc->string_geq_symbol, str1, str2); + return(scheme_strcmp(str1, str2) != -1); +} + +static bool string_eq_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strings_are_equal(str1, str2));} +static bool string_eq_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2) +{ + check_string2_args(sc, sc->string_eq_symbol, str1, str2); + return(scheme_strings_are_equal(str1, str2)); +} + +static s7_pointer string_equal_chooser(s7_scheme *sc, s7_pointer func, 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) : func); +} + +static s7_pointer string_less_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + check_for_substring_temp(sc, expr); + return((args == 2) ? sc->string_less_2 : func); +} + +static s7_pointer string_greater_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + check_for_substring_temp(sc, expr); + return((args == 2) ? sc->string_greater_2 : func); +} + + +#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). + */ + const s7_int len1 = string_length(s1); + const s7_int len2 = string_length(s2); + const 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! */ + const s7_int len = string_length(s1); + const 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 strs = x; is_pair(strs); strs = cdr(strs)) + if (!is_string_via_method(sc, car(strs))) + wrong_type_error_nr(sc, sym, position_of(strs, args), car(strs), 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 str = car(args); + if (!is_string(str)) + return(method_or_bust(sc, str, sym, args, sc->type_names[T_STRING], 1)); + + for (s7_pointer strs = cdr(args); is_pair(strs); str = car(strs), strs = cdr(strs)) + { + if (!is_string(car(strs))) + return(method_or_bust(sc, car(strs), sym, set_ulist_1(sc, str, strs), sc->type_names[T_STRING], position_of(strs, args))); + if (val == 0) + { + if (!scheme_strequal_ci(str, car(strs))) + return(check_rest_are_strings(sc, sym, cdr(strs), args)); + } + else + if (scheme_strcasecmp(str, car(strs)) != val) + return(check_rest_are_strings(sc, sym, cdr(strs), 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 str = car(args); + + if (!is_string(str)) + return(method_or_bust(sc, str, sym, args, sc->type_names[T_STRING], 1)); + for (s7_pointer strs = cdr(args); is_pair(strs); str = car(strs), strs = cdr(strs)) + { + if (!is_string(car(strs))) + return(method_or_bust(sc, car(strs), sym, set_ulist_1(sc, str, strs), sc->type_names[T_STRING], position_of(strs, args))); + if (scheme_strcasecmp(str, car(strs)) == val) + return(check_rest_are_strings(sc, sym, cdr(strs), 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-cipcl_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 str1, s7_pointer str2) {return(scheme_strcasecmp(str1, str2) == -1);} +static bool string_ci_lt_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2) +{ + check_string2_args(sc, sc->string_ci_lt_symbol, str1, str2); + return(scheme_strcasecmp(str1, str2) == -1); +} + +static bool string_ci_leq_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcasecmp(str1, str2) != 1);} +static bool string_ci_leq_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2) +{ + check_string2_args(sc, sc->string_ci_leq_symbol, str1, str2); + return(scheme_strcasecmp(str1, str2) != 1); +} + +static bool string_ci_gt_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcasecmp(str1, str2) == 1);} +static bool string_ci_gt_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2) +{ + check_string2_args(sc, sc->string_ci_gt_symbol, str1, str2); + return(scheme_strcasecmp(str1, str2) == 1); +} + +static bool string_ci_geq_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcasecmp(str1, str2) != -1);} +static bool string_ci_geq_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2) +{ + check_string2_args(sc, sc->string_ci_geq_symbol, str1, str2); + return(scheme_strcasecmp(str1, str2) != -1); +} + +static bool string_ci_eq_b_unchecked(s7_pointer str1, s7_pointer str2) {return(scheme_strcasecmp(str1, str2) == 0);} +static bool string_ci_eq_b_7pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2) +{ + check_string2_args(sc, sc->string_ci_eq_symbol, str1, str2); + return(scheme_strcasecmp(str1, str2) == 0); +} +#endif /* pure s7 */ + + +/* -------------------------------- string-fill! -------------------------------- */ + +static s7_pointer g_string_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) +{ + const s7_pointer str = car(args); + s7_pointer chr; + s7_int start = 0, end; + + if (!is_string(str)) + return(method_or_bust(sc, str, caller, args, sc->type_names[T_STRING], 1)); /* not two methods here */ + if (is_immutable_string(str)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, str)); + + chr = cadr(args); + if (!is_character(chr)) + return(method_or_bust(sc, chr, caller, args, sc->type_names[T_CHARACTER], 2)); + + end = string_length(str); + 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); /* this is what Guile does, and r7rs says end is "exclusive" in these situations, so (string-fill! str #\a 3 3) is a no-op */ + } + if (end == 0) return(chr); + local_memset((void *)(string_value(str) + start), (int32_t)character(chr), end - start); /* not memclr even if chr=#\null! */ /* unaligned */ + return(chr); +} + +#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 str) {return(string_value(str));} + +static s7_pointer g_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym) +{ + int32_t len; + s7_pointer chrs, newstr; + char *str; + + /* get length for new string and check arg types */ + for (len = 0, chrs = args; is_pair(chrs); len++, chrs = cdr(chrs)) + { + const s7_pointer chr = car(chrs); + if (!is_character(chr)) + { + if (has_active_methods(sc, chr)) + { + const s7_pointer func = find_method_with_let(sc, chr, sym); + if (func != sc->undefined) + { + s7_pointer ok_chrs; + if (len == 0) + return(s7_apply_function(sc, func, args)); + newstr = make_empty_string(sc, len, '\0'); + str = string_value(newstr); + ok_chrs = args; + for (int32_t i = 0; ok_chrs != chrs; i++, ok_chrs = cdr(ok_chrs)) + str[i] = character(car(ok_chrs)); + return(g_string_append_1(sc, set_plist_2(sc, newstr, s7_apply_function(sc, func, chrs)), sym)); + }} + wrong_type_error_nr(sc, sym, len + 1, chr, 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); + chrs = args; + for (int32_t i = 0; is_pair(chrs); i++, chrs = cdr(chrs)) + str[i] = character(car(chrs)); + 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 func, int32_t args, s7_pointer expr) +{ + return(((args == 1) && (!is_pair(cadr(expr)))) ? sc->string_c1 : func); +} + +static s7_pointer string_p_p(s7_scheme *sc, s7_pointer c) +{ + s7_pointer str; + if (!is_character(c)) return(g_string_1(sc, set_plist_1(sc, c), sc->string_symbol)); + str = inline_make_empty_string(sc, 1, '\0'); + string_value(str)[0] = character(c); + 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) +{ + if (len == 0) + return(sc->nil); + check_free_heap_size(sc, len); + begin_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); + return_with_end_temp(sc->y); +} + +#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; + const s7_pointer 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))) + { + s7_pointer 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))); + check_free_heap_size(sc, end - start); + begin_temp(sc->y, sc->nil); + for (s7_int i = end - 1; i >= start; i--) + sc->y = cons_unchecked(sc, chars[((uint8_t)string_value(str)[i])], sc->y); + return_with_end_temp(sc->y); +} + +static s7_pointer string_to_list_p_p(s7_scheme *sc, s7_pointer str) +{ + s7_int len; + 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); + if (len > sc->max_list_length) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "string->list length, ~D, is greater than (*s7* 'max-list-length), ~D", 68), + wrap_integer(sc, len), wrap_integer(sc, sc->max_list_length))); + check_free_heap_size(sc, len); + val = (const uint8_t *)string_value(str); + { + s7_pointer result = sc->nil; + for (s7_int i = len - 1; i >= 0; i--) result = cons_unchecked(sc, chars[val[i]], result); + return(result); + } +} +#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 port = car(args); + if ((is_input_port(port)) || (is_output_port(port))) + return(make_boolean(sc, port_is_closed(port))); + if ((port == current_output_port(sc)) && (port == sc->F)) + return(sc->F); + return(method_or_bust_p(sc, port, sc->is_port_closed_symbol, wrap_string(sc, "a port", 6))); +} + +static bool is_port_closed_b_7p(s7_scheme *sc, s7_pointer port) +{ + if ((is_input_port(port)) || (is_output_port(port))) + return(port_is_closed(port)); + if ((port == current_output_port(sc)) && (port == sc->F)) + return(false); + return(method_or_bust_p(sc, port, 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)) + + const 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)); /* both here and below we copy the data, so the returned value can be mutated */ + return(make_string_with_length(sc, (const char *)port_data(port), port_data_size(port))); /* max_string_length? */ +} + +static void resize_string_port_data(s7_scheme *sc, s7_pointer port, s7_int new_size) +{ + const s7_int loc = port_data_size(port); + block_t *nb; + + if (new_size < loc) return; + if (new_size > sc->max_string_port_length) + error_nr(sc, make_symbol(sc, "port-too-big", 12), + set_elist_3(sc, wrap_string(sc, "string port length has grown past (*s7* 'max-string-port-length): ~D > ~D", 73), + wrap_integer(sc, new_size), + wrap_integer(sc, sc->max_string_port_length))); + liberate(sc, port_data_block(port)); /* reallocate has an irrelevant memcpy */ + nb = inline_mallocate(sc, new_size); + port_data_block(port) = nb; + port_data(port) = (uint8_t *)(block_data(nb)); + port_data_size(port) = new_size; +} + + +static s7_pointer set_input_port_string(s7_scheme *sc, s7_pointer port, s7_pointer str) +{ /*assume port is an input string port */ + s7_int str_len; + if ((S7_DEBUGGING) && ((!is_input_port(port)) || (!is_string_port(port)))) + fprintf(stderr, "%s[%d]: %s should be an input string port\n", __func__, __LINE__, display(port)); + 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_len = string_length(str); + 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); + return(str); +} + +static s7_pointer set_output_port_string(s7_scheme *sc, s7_pointer port, s7_pointer str) +{ /*assume port is an output string port */ + s7_int str_len; + if ((S7_DEBUGGING) && ((!is_output_port(port)) || (!is_string_port(port)))) + fprintf(stderr, "%s[%d]: %s should be an output string port\n", __func__, __LINE__, display(port)); + 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_len = string_length(str); + if (port_data_size(port) <= str_len) /* sc->initial_string_port_length is 128 */ + resize_string_port_data(sc, port, str_len * 2); + memcpy((void *)port_data(port), (const void *)string_value(str), str_len); + port_position(port) = str_len; + port_data(port)[str_len] = '\0'; + return(str); +} + +static s7_pointer g_set_port_string(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer port = car(args); + s7_pointer str; + 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)); + 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]); + if (is_input_port(port)) + set_input_port_string(sc, port, str); + else set_output_port_string(sc, port, str); + 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) + + const s7_pointer port = car(args); + if (!is_input_port(port)) + return(method_or_bust_p(sc, port, sc->port_position_symbol, 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) +{ + const s7_pointer port = car(args); + s7_pointer 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)) + + const s7_pointer port = car(args); + if ((!is_input_port(port)) && (!is_output_port(port))) + return(method_or_bust_p(sc, port, sc->port_file_symbol, 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)) /* used to check port_is_closed? */ + 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 port, line; + if ((is_null(car(args))) || + ((is_null(cdr(args))) && (is_t_integer(car(args))))) + port = current_input_port(sc); + else + { + port = car(args); + if (!is_input_port(port)) + wrong_type_error_nr(sc, wrap_string(sc, "set! port-line-number", 21), 1, port, 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(port) = integer(line); + return(line); +} + + +/* -------------------------------- port-filename -------------------------------- */ +const char *s7_port_filename(s7_scheme *sc, s7_pointer port) +{ + if (((is_input_port(port)) || (is_output_port(port))) && + (!port_is_closed(port))) + return(port_filename(port)); + return(NULL); +} + +static s7_pointer port_filename_p_p(s7_scheme *sc, s7_pointer port) +{ + if (((is_input_port(port)) || (is_output_port(port))) && + (!port_is_closed(port))) + { + if (port_filename(port)) + { + if (port_filename_length(port) > 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(port)), wrap_integer(sc, sc->max_string_length))); + return(make_string_with_length(sc, port_filename(port), port_filename_length(port))); /* not wrapper here! */ + } + return(nil_string); + /* otherwise (eval-string (port-filename)) and (string->symbol (port-filename)) segfault */ + } + return(method_or_bust_p(sc, port, 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) + + const 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 */ + if_method_exists_return_value(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) + + const 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 + { + if_method_exists_return_value(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)) + const s7_pointer port = car(args); + const 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 + { + if_method_exists_return_value(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)) + const s7_pointer port = car(args); + const 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 + { + if_method_exists_return_value(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 port; + + if (is_null(args)) + return(make_boolean(sc, (is_input_port(current_input_port(sc))) && (is_string_port(current_input_port(sc))))); + port = car(args); + if (!is_input_port(port)) + return(method_or_bust_p(sc, port, sc->is_char_ready_symbol, an_input_port_string)); + if (port_is_closed(port)) + sole_arg_wrong_type_error_nr(sc, sc->is_char_ready_symbol, port, an_open_input_port_string); + if (!is_function_port(port)) + return(make_boolean(sc, is_string_port(port))); + { + s7_pointer result = (*(port_input_function(port)))(sc, S7_IS_CHAR_READY, port); + if (is_multiple_value(result)) + { + clear_multiple_value(result); + error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port char-ready? returned: ~S", 44), result)); + } + return(make_boolean(sc, (result != 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 port) +{ + if (port_filename(port)) /* for string ports, this is the original input file name */ + { + liberate(sc, port_filename_block(port)); + port_filename(port) = NULL; + } + if (port_file(port)) + { + fclose(port_file(port)); + port_file(port) = NULL; + } + if (port_needs_free(port)) + free_port_data(sc, port); + port_port(port)->pf = &closed_port_functions; + port_set_closed(port, true); + port_position(port) = 0; +} + +static void close_input_string(s7_scheme *sc, s7_pointer port) +{ + if (port_filename(port)) /* for string ports, this is the original input file name */ + { + liberate(sc, port_filename_block(port)); + port_filename(port) = NULL; + } + if (port_needs_free(port)) + free_port_data(sc, port); + port_port(port)->pf = &closed_port_functions; + port_set_closed(port, true); + port_position(port) = 0; +} + +static void close_simple_input_string(s7_scheme *sc, s7_pointer port) +{ +#if S7_DEBUGGING + if (port_filename(port)) fprintf(stderr, "%s: port has a filename\n", __func__); + if (port_needs_free(port)) fprintf(stderr, "%s: port needs free\n", __func__); +#endif + port_port(port)->pf = &closed_port_functions; + port_set_closed(port, true); + port_position(port) = 0; +} + +void s7_close_input_port(s7_scheme *sc, s7_pointer port) {port_close(port)(sc, port);} + + +/* -------------------------------- 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) + + const s7_pointer port = car(args); + if (!is_input_port(port)) + return(method_or_bust_p(sc, port, sc->close_input_port_symbol, an_input_port_string)); + if ((!is_immutable_port(port)) && /* (close-input-port *stdin*) */ + (!is_loader_port(port))) /* top-level unmatched (close-input-port (current-input-port)) should not clobber the loader's input port */ + s7_close_input_port(sc, port); + return(sc->unspecified); +} + + +/* -------------------------------- flush-output-port -------------------------------- */ +static no_return 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 port) +{ + bool result = true; + if ((is_output_port(port)) && /* type=T_OUTPUT_PORT, so this excludes #f */ + (is_file_port(port)) && + (!port_is_closed(port)) && + (port_file(port))) + { + if (port_position(port) > 0) + { + result = (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) == (size_t)port_position(port)); + port_position(port) = 0; + } + if (fflush(port_file(port)) == -1) + file_error_nr(sc, "flush-output-port", strerror(errno), port_filename(port)); + } + 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)) + + const s7_pointer port = (is_null(args)) ? current_output_port(sc) : car(args); + if (!is_output_port(port)) + { + if (port == sc->F) return(port); + if_method_exists_return_value(sc, port, sc->flush_output_port_symbol, args); + sole_arg_wrong_type_error_nr(sc, sc->flush_output_port_symbol, port, an_output_port_or_f_string); + } + if (!s7_flush_output_port(sc, port)) + error_nr(sc, sc->io_error_symbol, set_elist_2(sc, wrap_string(sc, "flush-output-port ~S failed", 27), port)); + return(port); +} + + +/* -------------------------------- close-output-port -------------------------------- */ +static void close_output_file(s7_scheme *sc, s7_pointer port) +{ + if (port_filename(port)) /* only a file output port has a filename(?) */ + { + /* type(port) might be T_FREE -- this is called in sweep if port is free_and_clear */ + if ((S7_DEBUGGING) && (!is_free(port)) && ((!is_output_port(port)) || (!is_file_port(port)))) + fprintf(stderr, "%s[%d]: unexpected port\n", __func__, __LINE__); + liberate(sc, port_filename_block(port)); + port_filename(port) = NULL; + port_filename_length(port) = 0; + } + if (port_file(port)) + { +#if WITH_WARNINGS + if ((port_position(port) > 0) && + (fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)) != (size_t)port_position(port))) + s7_warn(sc, 64, "fwrite trouble in close-output-port\n"); +#else + if (port_position(port) > 0) + fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)); +#endif + if (fflush(port_file(port)) == -1) + s7_warn(sc, 64, "fflush in close-output-port: %s\n", strerror(errno)); + fclose(port_file(port)); + port_file(port) = NULL; + } + port_port(port)->pf = &closed_port_functions; + port_set_closed(port, true); + port_position(port) = 0; +} + +static void close_output_string(s7_scheme *sc, s7_pointer port) +{ + if (port_data(port)) + { + port_data(port) = NULL; + port_data_size(port) = 0; + } + port_port(port)->pf = &closed_port_functions; + port_set_closed(port, true); + port_position(port) = 0; +} + +static void close_output_port(s7_scheme *sc, s7_pointer port) {port_close(port)(sc, port);} + +void s7_close_output_port(s7_scheme *sc, s7_pointer port) +{ + if ((port == sc->F) || (is_immutable_port(port))) return; /* can these happen? */ + close_output_port(sc, port); +} + +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)) + + const s7_pointer port = car(args); + if (!is_output_port(port)) + { + if (port == sc->F) return(sc->unspecified); + if_method_exists_return_value(sc, port, sc->close_output_port_symbol, args); + sole_arg_wrong_type_error_nr(sc, sc->close_output_port_symbol, port, an_output_port_or_f_string); + } + s7_close_output_port(sc, port); + return(sc->unspecified); +} + + +/* -------- read character functions -------- */ + +static int32_t file_read_char(s7_scheme *sc, s7_pointer port) +{ + int32_t c = fgetc(port_file(port)); + if ((c == (int32_t)'\n') && (!is_loader_port(port))) port_line_number(port)++; + return(c); +} + +static int32_t function_read_char(s7_scheme *sc, s7_pointer port) +{ + const s7_pointer result = (*(port_input_function(port)))(sc, S7_READ_CHAR, port); + if (is_eof(result)) return(EOF); + if (!is_character(result)) /* port_input_function might return some non-character */ + { + if (is_multiple_value(result)) + { + clear_multiple_value(result); + error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-char returned: ~S", 42), result)); + } + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-char returned: ~S", 42), result)); + } + return((int32_t)character(result)); /* kinda nutty -- we return chars[this] in g_read_char! */ +} + +static int32_t string_read_char(s7_scheme *sc, s7_pointer port) +{ + uint8_t c; + if (port_data_size(port) <= port_position(port)) return(EOF); + c = (uint8_t)port_data(port)[port_position(port)++]; /* port_string_length is 0 if no port string, port_data is uint8_t* */ + if ((c == (uint8_t)'\n') && (!is_loader_port(port))) port_line_number(port)++; + return(c); +} + +static int32_t output_read_char(s7_scheme *sc, s7_pointer port) /* not reachable I think */ +{ + 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) /* not reachable I think */ +{ + 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 result = (*(port_input_function(port)))(sc, S7_READ_LINE, port); + if (is_multiple_value(result)) + { + clear_multiple_value(result); + error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read-line returned: ~S", 42), result)); + } + return(result); +} + +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); + const 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) + { + s7_int len; + port_line_number(port)++; + i = cur - port_str; + port_position(port) = i + 1; + len = ((with_eol) ? i + 1 : i) - port_start; + if (len == 0) return(nil_string); + return(inline_make_string_with_length(sc, start, len)); + } + 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 port, s7_int new_size) +{ + const s7_int loc = port_data_size(port); + block_t *nb; + if (new_size < loc) return; + if (new_size > sc->max_string_port_length) + error_nr(sc, make_symbol(sc, "port-too-big", 12), + set_elist_3(sc, wrap_string(sc, "string port length has grown past (*s7* 'max-string-port-length): ~D > ~D", 73), + wrap_integer(sc, new_size), + wrap_integer(sc, sc->max_string_port_length))); + nb = reallocate(sc, port_data_block(port), new_size); + port_data_block(port) = nb; + port_data(port) = (uint8_t *)(block_data(nb)); + port_data_size(port) = new_size; +} + +static void string_write_char_resized(s7_scheme *sc, uint8_t c, s7_pointer port) +{ + /* this division looks repetitive, but it is much faster */ + resize_port_data(sc, port, port_data_size(port) * 2); + port_data(port)[port_position(port)++] = c; +} + +static void string_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) +{ + if (port_position(port) < port_data_size(port)) + port_data(port)[port_position(port)++] = c; + else string_write_char_resized(sc, c, port); +} + +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); + memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ +} + +#ifndef OUTPUT_FILE_PORT_LENGTH + #define OUTPUT_FILE_PORT_LENGTH 2048 +#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_length) + { + fwrite((void *)(port_data(port)), 1, sc->output_file_port_length, 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) /* not reachable I think */ +{ + 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 port) +{ + s7_int new_len = port_position(port) + len; /* len is known to be non-zero, str might not be 0-terminated */ + resize_port_data(sc, port, new_len * 2); + memcpy((void *)(port_data(port) + port_position(port)), (const void *)str, len); + port_position(port) = new_len; +} + +static void string_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) +{ + if ((S7_DEBUGGING) && (len == 0)) {fprintf(stderr, "string_write_string len == 0\n"); abort();} + if (port_position(port) + len < port_data_size(port)) + { + memcpy((void *)(port_data(port) + port_position(port)), (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(port) += len; + } + else string_write_string_resized(sc, str, len, port); +} + +static void file_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) +{ + const s7_int new_len = port_position(port) + len; + if (new_len >= sc->output_file_port_length) + { + 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 write-string\n"); +#else + fwrite((void *)(port_data(port)), 1, port_position(port), port_file(port)); +#endif + port_position(port) = 0; + } + fwrite((const void *)str, 1, len, port_file(port)); + } + else + { + memcpy((void *)(port_data(port) + port_position(port)), (const void *)str, len); + port_position(port) = 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); + for (; *s; s++) + (*(port_output_function(port)))(sc, *s, port); + unstack_with(sc, OP_NO_VALUES); + memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ +} + +static void function_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) +{ + push_stack_direct(sc, OP_NO_VALUES); + for (s7_int i = 0; i < len; i++) + (*(port_output_function(port)))(sc, str[i], port); + unstack_with(sc, OP_NO_VALUES); + memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ +} + +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) + const s7_pointer str = car(args); + s7_pointer 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)); + } + if_method_exists_return_value(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 port) +{ + int32_t c; + do (c = fgetc(port_file(port))); while ((c != '\n') && (c != EOF)); + port_line_number(port)++; + return((c == EOF) ? token_eof : token(sc)); +} + +static token_t string_read_semicolon(s7_scheme *sc, s7_pointer port) +{ + const char *str = (const char *)(port_data(port) + port_position(port)); + const char *orig_str = strchr(str, (int)'\n'); + if (!orig_str) + { + port_position(port) = port_data_size(port); + return(token_eof); + } + port_position(port) += (orig_str - str + 1); /* + 1 because strchr leaves orig_str pointing at the newline */ + port_line_number(port)++; + 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 port) +{ + const uint8_t *str = (const uint8_t *)(port_data(port) + port_position(port)); + 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(port)++; + port_position(port) = (c) ? str - port_data(port) : port_data_size(port); + return((int32_t)c); +} + + +/* -------- name readers -------- */ +#define BASE_10 10 + +static s7_pointer file_read_name_or_sharp(s7_scheme *sc, s7_pointer port, 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(port)); /* might return EOF */ + if (c == '\n') + port_line_number(port)++; + + 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(port)--; + ungetc(c, port_file(port)); + } + 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, port, true)); +} + +static s7_pointer file_read_name(s7_scheme *sc, s7_pointer port) {return(file_read_name_or_sharp(sc, port, true));} +static s7_pointer file_read_sharp(s7_scheme *sc, s7_pointer port) {return(file_read_name_or_sharp(sc, port, false));} + +static s7_pointer string_read_name_no_free(s7_scheme *sc, s7_pointer port) +{ + /* sc->strbuf[0] has the first char of the string we're reading */ + const uint8_t *str = (uint8_t *)(port_data(port) + port_position(port)); + + if (char_ok_in_a_name[*str]) + { + s7_int k; + const uint8_t *orig_str = str - 1; + str++; + while (char_ok_in_a_name[*str]) str++; + k = str - orig_str; + if (*str != 0) + port_position(port) += (k - 1); + else port_position(port) = port_data_size(port); + /* 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)); + } + { + s7_pointer 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 port) +{ + /* 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(port) + port_position(port)); + if (char_ok_in_a_name[(uint8_t)*str]) + { + s7_int k; + const char *orig_str = (char *)(str - 1); + str++; + while (char_ok_in_a_name[(uint8_t)(*str)]) {str++;} + k = str - orig_str; + port_position(port) += (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, port, 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(port)++; + } + else sc->strbuf[1] = '\0'; + return(make_sharp_constant(sc, sc->strbuf, WITH_OVERFLOW_ERROR, port, true)); +} + +static s7_pointer string_read_name(s7_scheme *sc, s7_pointer port) +{ + /* 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(port) + port_position(port)); + if (char_ok_in_a_name[*str]) + { + s7_int k; + uint8_t endc; + const uint8_t *orig_str = str - 1; + str++; + while (char_ok_in_a_name[*str]) str++; + k = str - orig_str; + port_position(port) += (k - 1); + if (!number_table[*orig_str]) + return(inline_make_symbol(sc, (const char *)orig_str, k)); + endc = *str; + *str = 0; /* temp end for make_atom */ + 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)); +#if S7_DEBUGGING + sc->blocks_mallocated[PORT_LIST]++; +#endif + 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); + 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)); + const 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_FILE_TO_STRING_PORT_CONVERSION + #define MAX_SIZE_FOR_FILE_TO_STRING_PORT_CONVERSION 10000000 + /* I'd add this to *s7* but it doesn't make much difference unless you're reading a large text file */ +#endif + +static s7_pointer make_input_file(s7_scheme *sc, const char *name, FILE *fp) +{ + return(read_file(sc, fp, name, MAX_SIZE_FOR_FILE_TO_STRING_PORT_CONVERSION, "open")); +} + + +#if !MS_WINDOWS +#include +#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) + + const s7_pointer 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")); + { + s7_pointer 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 s7_pointer alloc_standard_output_port(s7_scheme *sc) +{ + const s7_pointer port = alloc_pointer(sc); + set_full_type(port, T_OUTPUT_PORT | T_IMMUTABLE | T_UNHEAP); + port_port(port) = (port_t *)Calloc(1, sizeof(port_t)); + port_type(port) = file_port; + port_data(port) = NULL; + port_data_block(port) = NULL; + port_set_closed(port, false); + port_line_number(port) = 0; + port_needs_free(port) = false; + return(port); +} + +static void init_standard_ports(s7_scheme *sc) +{ + s7_pointer port; + /* standard output */ + port = alloc_standard_output_port(sc); + port_filename_length(port) = 8; + port_set_filename(sc, port, "*stdout*", 8); + port_file_number(port) = remember_file_name(sc, port_filename(port)); /* these numbers need to be correct for the evaluator (*function* data) */ + port_file(port) = stdout; + port_port(port)->pf = &stdout_functions; + sc->standard_output = port; + + /* standard error */ + port = alloc_standard_output_port(sc); + port_filename_length(port) = 8; + port_set_filename(sc, port, "*stderr*", 8); + port_file_number(port) = remember_file_name(sc, port_filename(port)); + port_file(port) = stderr; + port_port(port)->pf = &stderr_functions; + sc->standard_error = port; + + /* standard input */ + port = alloc_pointer(sc); + set_full_type(port, T_INPUT_PORT | T_IMMUTABLE | T_UNHEAP); + port_port(port) = (port_t *)Calloc(1, sizeof(port_t)); + port_type(port) = file_port; + port_set_closed(port, false); + port_set_string_or_function(port, sc->nil); + port_filename_length(port) = 7; + port_set_filename(sc, port, "*stdin*", 7); + port_file_number(port) = remember_file_name(sc, port_filename(port)); + port_line_number(port) = 0; + port_file(port) = stdin; + port_data_block(port) = NULL; + port_needs_free(port) = false; + port_port(port)->pf = &stdin_functions; + sc->standard_input = port; + + 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 port; + 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, port, T_OUTPUT_PORT); + b = mallocate_port(sc); + port_block(port) = b; + port_port(port) = (port_t *)block_data(b); + port_type(port) = file_port; + port_set_closed(port, false); + port_filename_length(port) = safe_strlen(name); + port_set_filename(sc, port, name, port_filename_length(port)); + port_line_number(port) = 1; + port_file_number(port) = 0; + port_file(port) = fp; + port_needs_free(port) = true; /* hmm -- I think these are freed via s7_close_output_port -> close_output_port */ + port_position(port) = 0; + port_data_size(port) = sc->output_file_port_length; + block = mallocate(sc, sc->output_file_port_length); + port_data_block(port) = block; + port_data(port) = (uint8_t *)(block_data(block)); + port_port(port)->pf = &output_file_functions; + add_output_port(sc, port); + return(port); +} + +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) + + const 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 port; + block_t *b = mallocate_port(sc); + new_cell(sc, port, T_INPUT_PORT); + port_block(port) = b; + port_port(port) = (port_t *)block_data(b); + port_type(port) = string_port; + port_set_closed(port, false); + port_set_string_or_function(port, sc->nil); + port_data(port) = (uint8_t *)input_string; + port_data_block(port) = NULL; + port_data_size(port) = len; + port_position(port) = 0; + port_filename_block(port) = NULL; + port_filename_length(port) = 0; + port_filename(port) = NULL; + port_file_number(port) = 0; + port_line_number(port) = 0; + port_file(port) = NULL; + port_needs_free(port) = 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(port)->pf = &input_string_functions; + add_input_string_port(sc, port); + return(port); +} + +static /* inline */ s7_pointer open_and_protect_input_string(s7_scheme *sc, s7_pointer str) +{ + s7_pointer port = open_input_string(sc, string_value(str), string_length(str)); + port_set_string_or_function(port, str); + return(port); +} + +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 port; + block_t *b = mallocate_port(sc); + block_t *block = inline_mallocate(sc, sc->initial_string_port_length); + new_cell(sc, port, T_OUTPUT_PORT); + port_block(port) = b; + port_port(port) = (port_t *)block_data(b); + port_type(port) = string_port; + port_set_closed(port, false); + port_data_size(port) = sc->initial_string_port_length; + port_data_block(port) = block; + port_data(port) = (uint8_t *)(block_data(block)); + port_data(port)[0] = '\0'; /* in case s7_get_output_string before any output */ + port_position(port) = 0; + port_needs_free(port) = true; + port_filename_block(port) = NULL; + port_filename_length(port) = 0; /* protect against (port-filename (open-output-string)) */ + port_filename(port) = NULL; + port_port(port)->pf = &output_string_functions; + add_output_port(sc, port); + return(port); +} + +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 port) +{ + port_data(port)[port_position(port)] = '\0'; + return((const char *)port_data(port)); +} + +s7_pointer s7_output_string(s7_scheme *sc, s7_pointer port) +{ + port_data(port)[port_position(port)] = '\0'; + if (port_position(port) == 0) return(nil_string); + return(make_string_with_length(sc, (const char *)port_data(port), port_position(port))); +} + +static inline void check_get_output_string_port(s7_scheme *sc, s7_pointer port) +{ + if (port_is_closed(port)) + wrong_type_error_nr(sc, sc->get_output_string_symbol, 1, port, wrap_string(sc, "an active (open) string port", 28)); + if (port_position(port) > 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(port)), 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 port; + bool clear_port = false; + if (is_pair(cdr(args))) + { + s7_pointer clear = cadr(args); + if (!is_boolean(clear)) + wrong_type_error_nr(sc, sc->get_output_string_symbol, 2, clear, sc->type_names[T_BOOLEAN]); + clear_port = (clear == sc->T); + } + port = car(args); + if ((!is_output_port(port)) || (!is_string_port(port))) + { + if (port == sc->F) return(nil_string); + if_method_exists_return_value(sc, port, sc->get_output_string_symbol, args); + wrong_type_error_nr(sc, sc->get_output_string_symbol, 1, port, wrap_string(sc, "an open string output port or #f", 32)); + } + check_get_output_string_port(sc, port); + + if ((clear_port) && + (port_position(port) < port_data_size(port))) + { + block_t *block; + s7_pointer result = block_to_string(sc, port_data_block(port), port_position(port)); + /* this is slightly faster than make_string_with_length(sc, (char *)(port_data(port)), port_position(port)): we're trading a mallocate for a memcpy */ + port_data_size(port) = sc->initial_string_port_length; + block = inline_mallocate(sc, port_data_size(port)); + port_data_block(port) = block; + port_data(port) = (uint8_t *)(block_data(block)); + port_position(port) = 0; + port_data(port)[0] = '\0'; + return(result); + } + if (port_position(port) == 0) return(nil_string); + return(make_string_with_length(sc, (const char *)port_data(port), port_position(port))); +} + +static void op_get_output_string(s7_scheme *sc) +{ + const 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); + + /* nil_string here is tricky (need liberate etc) */ + 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)); + /* block_to_string attaches the port's data_block to the string for later free */ + 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) +{ + const s7_pointer port = car(args); + if ((!is_output_port(port)) || (!is_string_port(port))) + { + if (port == sc->F) return(nil_string); + return(method_or_bust_p(sc, port, sc->get_output_string_symbol, wrap_string(sc, "an output string port", 21))); + } + check_get_output_string_port(sc, port); + port_data(port)[port_position(port)] = '\0'; /* wrap_string can't do this, and (for example) open_input_string wants terminated strings */ + if (port_position(port) == 0) return(nil_string); + return(wrap_string(sc, (const char *)port_data(port), port_position(port))); +} + + +/* -------------------------------- 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_port(s7_scheme *sc, s7_pointer port) +{ + port_port(port)->pf = &closed_port_functions; + port_set_string_or_function(port, sc->closed_input_function); /* from s7_make_function so it is GC-protected */ + port_set_closed(port, 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_port}; + +static void function_port_set_defaults(s7_pointer port) +{ + port_type(port) = function_port; + port_data(port) = NULL; + port_data_block(port) = NULL; + port_set_closed(port, false); + port_needs_free(port) = false; + port_filename_block(port) = NULL; /* next three protect against port-filename misunderstandings */ + port_filename(port) = NULL; + port_filename_length(port) = 0; + port_file_number(port) = 0; + port_line_number(port) = 0; + port_file(port) = 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 port; + block_t *b = mallocate_port(sc); + new_cell(sc, port, T_INPUT_PORT); + port_block(port) = b; + port_port(port) = (port_t *)block_data(b); + function_port_set_defaults(port); + port_set_string_or_function(port, sc->nil); + port_input_function(port) = function; + port_port(port)->pf = &input_function_functions; + add_input_port(sc, port); + return(port); +} + +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; + const s7_pointer func = car(args); + if (!is_any_procedure(func)) /* is_procedure is too lenient: we need to flag (open-input-function (block)) for example */ + return(method_or_bust_p(sc, func, sc->open_input_function_symbol, 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_port(s7_scheme *sc, s7_pointer port) +{ + port_port(port)->pf = &closed_port_functions; + port_set_string_or_function(port, sc->closed_output_function); + port_set_closed(port, 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_port}; + +s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port)) +{ + s7_pointer port; + block_t *b = mallocate_port(sc); + new_cell(sc, port, T_OUTPUT_PORT); + port_block(port) = b; + port_port(port) = (port_t *)block_data(b); + function_port_set_defaults(port); + port_output_function(port) = function; + port_set_string_or_function(port, sc->nil); + port_port(port)->pf = &output_function_functions; + add_output_port(sc, port); + return(port); +} + +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; + const s7_pointer func = car(args); + if (!is_any_procedure(func)) + return(method_or_bust_p(sc, func, sc->open_output_function_symbol, 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) +{ + const 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_pair(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 func, int32_t args, s7_pointer unused_expr) +{ + return((args == 1) ? sc->read_char_1 : func); +} + + +/* -------------------------------- write-char -------------------------------- */ +s7_pointer s7_write_char(s7_scheme *sc, s7_pointer c, s7_pointer port) +{ + if (port != sc->F) + port_write_character(port)(sc, s7_character(c), port); + 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); + if_method_exists_return_value(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. + */ +/* should write-char, write, write-string, display, and newline count newlines for port-line-number? Currently we only accept input ports */ + + +/* -------------------------------- 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)) ? eof_object : 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 result; + const s7_pointer port = (is_pair(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)); + + result = (*(port_input_function(port)))(sc, S7_PEEK_CHAR, port); + if (is_multiple_value(result)) + { + clear_multiple_value(result); + error_nr(sc, sc->bad_result_symbol, + set_elist_2(sc, wrap_string(sc, "input-function-port peek-char returned multiple values: ~S", 58), result)); + } + if (!is_character(result)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "input-function-port peek-char returned: ~S", 42), result)); + return(result); +} + + +/* -------------------------------- 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_pair(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; + const s7_pointer 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); + if_method_exists_return_value(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 #. \ +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_pair(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_pair(cdr(args))) + { + with_eol = (cadr(args) == sc->T); /* sig says boolean? so insist on #t, else we get stuff like (read-line port (c-pointer 0)) */ + if ((!with_eol) && (cadr(args) != sc->F)) + wrong_type_error_nr(sc, sc->read_line_symbol, 2, cadr(args), a_boolean_string); + }} + 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 -------------------------------- */ +#define READ_STRING_LINE_NUMBERS 0 /* 1 adds port-line-number support to read-string, doubling the time it takes */ + +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. + * should this worry about newlines? read-char and read-line keep port-line-number up to date, + * but here we'd need to scan the new string (via strchr?) or xor with \n\n\n\n... up to 8-at-a-time, and count zeros. + */ + #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) + const s7_pointer k = car(args); + s7_pointer 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)) + { + const s7_int pos = port_position(port); + const 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; +#if READ_STRING_LINE_NUMBERS + for (s7_int i = 0; i < len; i++) if (str[i] == '\n') port_line_number(port)++; +#endif + return(s); + } + if (is_file_port(port)) + { + const s7_int len = (s7_int)fread((void *)str, 1, nchars, port_file(port)); + str[len] = '\0'; + string_length(s) = len; +#if READ_STRING_LINE_NUMBERS + for (s7_int i = 0; i < len; i++) if (str[i] == '\n') port_line_number(port)++; +#endif + return(s); + } + for (s7_int i = 0; i < nchars; i++) + { + const 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; +#if READ_STRING_LINE_NUMBERS + if (c == '\n') port_line_number(port)++; +#endif + } + 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)) + sole_arg_wrong_type_error_nr(sc, sc->read_symbol, port, an_input_port_string); + { + const 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); + } +} + +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 # at the end" + #define Q_read s7_make_signature(sc, 2, sc->T, sc->is_input_port_symbol) + + s7_pointer port; + if (is_pair(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 result = (*(port_input_function(port)))(sc, S7_READ, port); + if (is_multiple_value(result)) + { + clear_multiple_value(result); + error_nr(sc, sc->bad_result_symbol, set_elist_2(sc, wrap_string(sc, "input-function-port read returned: ~S", 37), result)); + } + return(result); + } + 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) +{ + const 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); + const 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 + +static block_t *full_filename(s7_scheme *sc, const char *filename) +{ + char *new_name; + block_t *block; + if ((S7_DEBUGGING) && ((!filename) || (!*filename))) fprintf(stderr, "%s[%d]: filename is %s\n", __func__, __LINE__, filename); + if (filename[0] == '/') + { + const s7_int len = safe_strlen(filename); + block = mallocate(sc, len + 1); + new_name = (char *)block_data(block); + memcpy((void *)new_name, (const void *)filename, len); + new_name[len] = '\0'; + } + else + { + char *pwd = getcwd(NULL, 0); /* docs say this means it will return a new string of the right size */ + const size_t pwd_len = safe_strlen(pwd); + const size_t filename_len = safe_strlen(filename); + const s7_int len = pwd_len + filename_len + 2; /* not 1! we need room for the '/' and the terminating 0 */ + block = mallocate(sc, len); + new_name = (char *)block_data(block); + if (pwd) + { + memcpy((void *)new_name, (void *)pwd, pwd_len); + new_name[pwd_len] = '/'; + memcpy((void *)(new_name + pwd_len + 1), (const void *)filename, filename_len); + new_name[pwd_len + filename_len + 1] = '\0'; + free(pwd); + } + else /* isn't this an error? -- perhaps warn about getcwd, strerror(errno) */ + { + memcpy((void *)new_name, (const void *)filename, filename_len); + new_name[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)) */ + const 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, "%s[%d]: pname is null\n", __func__, __LINE__); + 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 */ + { + const 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); + const s7_pointer init_args = let_ref_p_pp(sc, let, make_symbol(sc, "init_args", 9)); + s7_pointer result; + gc_protect_via_stack(sc, init_args); + if (is_pair(init_args)) + { + result = ((dl_func_with_args)init_func)(sc, init_args); + set_gc_protected2(sc, result); + } + /* 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 an s7_cell pointer (scan permallocs and use heap_location?) + */ + ((dl_func)init_func)(sc); + result = sc->F; + } + unstack_gc_protect(sc); + if (pname) liberate(sc, pname); + return(result); + } + 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 or if the optional env is *s7* */ + s7_pointer port; + declare_jump_info(); + TRACK(sc); + if (e == sc->starlet) return(NULL); + /* unlet?? */ + if (!is_let(e)) + { + s7_pointer obj_e = find_let(sc, e); + if (!is_let(obj_e)) + s7_warn(sc, 128, "third argument to s7_load_with_environment is not a let or an object that has a let"); + else e = obj_e; + } +#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 (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 null terminated", 47))); + 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->rootlet)); +} + +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, has_let_signature(sc)) + + const 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)) + { + s7_pointer new_let = find_let(sc, e); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->load_symbol, e, new_let, 2, args); + e = new_let; + } + if (e == sc->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 strs; + 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 (strs = cadr(args); is_pair(strs); strs = cdr(strs)) + if (!is_string(car(strs))) + 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(strs))); + if ((S7_DEBUGGING) && (!is_null(strs))) fprintf(stderr, "%s[%d]: strs: %s\n", __func__, __LINE__, display(args)); +#if 0 + if (!is_null(strs)) + 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))); +#endif + 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 */ + const 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 libs = sc->autoload_names_loc; + const char *name = symbol_name(symbol); + for (s7_int lib = 0, l = 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) + { + s7_pointer p = s7_hash_table_ref(sc, sc->autoload_table, symbol); + if ((p != missing_key_value(sc)) && (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)) + { + if_method_exists_return_value(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_set_immutable(sc, make_string_with_length(sc, string_value(value), string_length(value))))); /* s7_set_immutable to pass arg through */ + if (((is_closure(value)) || (is_closure_star(value))) && + (s7_is_aritable(sc, value, 1))) + return(s7_autoload(sc, sym, value)); + + if_method_exists_return_value(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) + + const s7_pointer sym = car(args); + if (!is_symbol(sym)) + { + if_method_exists_return_value(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)) + { + s7_pointer val = s7_hash_table_ref(sc, sc->autoload_table, sym); + if (val != missing_key_value(sc)) return(val); + } + 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 p = lst, slow = lst; + while (true) + { + if (!is_pair(p)) return(false); + if (sym == car(p)) return(true); + p = cdr(p); + if (!is_pair(p)) return(false); + if (sym == car(p)) return(true); + p = cdr(p); + slow = cdr(slow); + if (p == 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 syms = args; is_pair(syms); syms = cdr(syms)) + { + s7_pointer sym; + if (is_symbol(car(syms))) + sym = car(syms); + else + if ((is_proper_quote(sc, car(syms))) && + (is_symbol(cadar(syms)))) + sym = cadar(syms); + 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(syms))); + } + if (!is_a_feature(sym, s7_symbol_value(sc, sc->features_symbol))) /* if on *features* it's already loaded */ + { + if (sc->is_autoloading) + { + const s7_pointer func = g_autoloader(sc, set_plist_1(sc, sym)); + if (is_false(sc, func)) + { + 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, func)); + if (is_string(func)) + s7_load_with_environment(sc, string_value(func), sc->curlet); + else + if (is_closure(func)) /* func should be a function of one argument, the current (calling) environment */ + s7_call(sc, func, set_ulist_1(sc, sc->curlet, sc->nil)); + } + else s7_warn(sc, 256, "require: can't load %s because (*s7* 'autoloading?) is #f\n", symbol_name(sym)); + }} + 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) + + const s7_pointer sym = car(args); + s7_pointer topf, e; + 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 (e = sc->curlet; let_id(e) > symbol_id(sc->features_symbol); e = let_outlet(e)); + for (; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if ((slot_symbol(slot) == sc->features_symbol) && + (slot_value(slot) != topf) && + (is_a_feature(sym, slot_value(slot)))) + 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 features; + 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 */ + features = global_slot(sc->features_symbol); + else features = 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(features)) && (is_immutable_slot(features))) + s7_warn(sc, 256, "provide: *features* is immutable!\n"); + else + { + const s7_pointer lst = slot_value(s7_t_slot(sc, sc->features_symbol)); /* in either case, we want the current *features* list */ + if (features == 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(features)))) + slot_set_value(features, cons(sc, sym, slot_value(features))); + } + 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 */ +{ + const s7_pointer new_features = cadr(args); + if (is_null(new_features)) return(sc->nil); + if (!is_pair(new_features)) + 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 pair)", 54), new_features)); + if (s7_list_length(sc, new_features) <= 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), new_features)); + for (s7_pointer features = new_features; is_pair(features); features = cdr(features)) + if (!is_symbol(car(features))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "can't set *features* to ~S (each feature should be a symbol)", 60), new_features)); + return(new_features); +} + +static s7_pointer g_libraries_set(s7_scheme *sc, s7_pointer args) /* *libraries* setter */ +{ + const s7_pointer new_libraries = cadr(args); + if (is_null(new_libraries)) return(sc->nil); + if ((!is_pair(new_libraries)) || (s7_list_length(sc, new_libraries) <= 0)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't set *libraries* to ~S", 27), new_libraries)); + for (s7_pointer libraries = new_libraries; is_pair(libraries); libraries = cdr(libraries)) + if ((!is_pair(car(libraries))) || + (!is_string(caar(libraries))) || + (!is_let(cdar(libraries)))) + sole_arg_wrong_type_error_nr(sc, sc->libraries_symbol, car(libraries), wrap_string(sc, "a list of conses of the form (string . let)", 43)); + return(new_libraries); +} + + +/* -------------------------------- 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, has_let_signature(sc)) + + s7_pointer port; + const s7_pointer 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_pair(cdr(args))) + { + s7_pointer e = cadr(args); + if (!is_let(e)) + { + s7_pointer new_let = find_let(sc, e); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->eval_string_symbol, e, new_let, 2, args); + e = new_let; + } + set_curlet(sc, e); + } + begin_temp(sc->temp6, sc->args); /* see t101-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); + end_temp(sc->temp6); + 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) +{ + const s7_pointer proc = cadr(args); + port_set_string_or_function(port, car(args)); + push_stack(sc, OP_UNWIND_INPUT, sc->unused, port); /* # here is a marker (needed) */ + push_stack(sc, OP_APPLY, list_1(sc, port), proc); + 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 */ + + const 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_procedure(proc)) + if_method_exists_return_value(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 + + const 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) +{ + const 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_pars(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 + + const 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 (is_eq_initial_c_function_data(sc->read_symbol, proc)) /* was global_value 11-June-24 */ + { + 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, #, 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 + + const 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) +{ + const 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) +{ + const 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) +{ + const 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) +{ + const 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) +{ + const 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) +{ + const 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 func) +{ + if ((is_c_function(func)) || (is_c_macro(func))) + return(c_function_symbol(func)); /* c_function* uses c_sym slot for arg_names */ + if ((S7_DEBUGGING) && (!is_c_function_star(func))) fprintf(stderr, "%s[%d]: %s is not a c-function-star\n", __func__, __LINE__, display(func)); + return(make_symbol(sc, c_function_name(func), c_function_name_length(func))); /* c_function* */ +} + +#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) +{ + const 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_symbol(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) +{ + const 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 iter, const char *func, int32_t line) +{ + if (!is_let(iterator_sequence(iter))) + { + fprintf(stderr, "%s%s[%d]: let iterator sequence is %s%s\n", + bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); +} + +static s7_pointer titr_pair(s7_scheme *sc, s7_pointer iter, const char *func, int32_t line) +{ + if (!is_pair(iterator_sequence(iter))) + { + fprintf(stderr, "%s%s[%d]: pair iterator sequence is %s%s\n", + bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); +} + +static s7_pointer titr_hash(s7_scheme *sc, s7_pointer iter, const char *func, int32_t line) +{ + if (!is_hash_table(iterator_sequence(iter))) + { + fprintf(stderr, "%s%s[%d]: hash iterator sequence is %s%s\n", + bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); +} + +static s7_pointer titr_len(s7_scheme *sc, s7_pointer iter, const char *func, int32_t line) +{ + if ((is_hash_table(iterator_sequence(iter))) || (is_pair(iterator_sequence(iter)))) + { + fprintf(stderr, "%s%s[%d]: iterator length sequence is %s%s\n", + bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); +} + +static s7_pointer titr_pos(s7_scheme *sc, s7_pointer iter, const char *func, int32_t line) +{ + if (((is_let(iterator_sequence(iter))) && (iterator_sequence(iter) != sc->rootlet) && (iterator_sequence(iter) != sc->starlet)) || + (is_pair(iterator_sequence(iter)))) + { + fprintf(stderr, "%s%s[%d]: iterator-position sequence is %s%s\n", + bold_text, func, line, checked_type_name(sc, unchecked_type(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); +} +#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 iter = car(args); + if (is_iterator(iter)) 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); +} + +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) +{ + 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(sc->iterator_at_end_value);} + +static s7_pointer iterator_quit(s7_scheme *sc, s7_pointer iterator) +{ + iterator_next(iterator) = iterator_finished; + clear_iter_ok(iterator); + return(sc->iterator_at_end_value); +} + +static s7_pointer let_iterate_uncarried(s7_scheme *sc, s7_pointer iterator) +{ + s7_pointer slot = let_iterator_slot(iterator); + if (!tis_slot(slot)) + return(iterator_quit(sc, iterator)); + let_iterator_set_slot(iterator, next_slot(slot)); + return(cons(sc, slot_symbol(slot), slot_value(slot))); +} + +static s7_pointer let_iterate_carried(s7_scheme *sc, s7_pointer iterator) +{ + s7_pointer result, slot = let_iterator_slot(iterator); + if (!tis_slot(slot)) + return(iterator_quit(sc, iterator)); + let_iterator_set_slot(iterator, next_slot(slot)); + result = iterator_carrier(iterator); + set_car(result, slot_symbol(slot)); + set_cdr(result, slot_value(slot)); + return(result); +} + +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 = hash_iterator_entry(iterator); + + if (lst) + { + hash_iterator_entry(iterator) = hash_entry_next(lst); + return(hash_entry_to_cons(sc, lst, iterator_carrier(iterator))); + } + table = iterator_sequence(iterator); /* using iterator_length and hash_table_entries here was slightly slower */ + len = (s7_int)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; + hash_iterator_entry(iterator) = hash_entry_next(x); + return(hash_entry_to_cons(sc, x, iterator_carrier(iterator))); + }} + if (is_weak_hash_table(table)) + { + clear_weak_hash_iterator(iterator); + weak_hash_iters(table)--; + } + return(iterator_quit(sc, iterator)); +} + +static s7_pointer string_iterate(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + return(chars[(uint8_t)(string_value(iterator_sequence(iter))[iterator_position(iter)++])]); + return(iterator_quit(sc, iter)); +} + +static s7_pointer byte_vector_iterate(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + return(small_int(byte_vector(iterator_sequence(iter), iterator_position(iter)++))); + return(iterator_quit(sc, iter)); +} + +static s7_pointer float_vector_iterate_uncarried(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + return(make_real(sc, float_vector(iterator_sequence(iter), iterator_position(iter)++))); + return(iterator_quit(sc, iter)); +} + +static s7_pointer float_vector_iterate_carried(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + { + set_real(iterator_carrier(iter), float_vector(iterator_sequence(iter), iterator_position(iter)++)); + return(iterator_carrier(iter)); + } + clear_mutable_number(iterator_carrier(iter)); + return(iterator_quit(sc, iter)); +} + +static s7_pointer complex_vector_iterate_uncarried(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + return(c_complex_to_s7(sc, complex_vector(iterator_sequence(iter), iterator_position(iter)++))); + return(iterator_quit(sc, iter)); +} + +static s7_pointer complex_vector_iterate_carried(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + { +#if WITH_CLANG_PP + return(c_complex_to_s7(sc, complex_vector(iterator_sequence(iter), iterator_position(iter)++))); +#else + set_a_bi(iterator_carrier(iter), complex_vector(iterator_sequence(iter), iterator_position(iter)++)); + return(iterator_carrier(iter)); +#endif + } + clear_mutable_number(iterator_carrier(iter)); + return(iterator_quit(sc, iter)); +} + +static s7_pointer int_vector_iterate_uncarried(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + return(make_integer(sc, int_vector(iterator_sequence(iter), iterator_position(iter)++))); + return(iterator_quit(sc, iter)); +} + +static s7_pointer int_vector_iterate_carried(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + { + set_integer(iterator_carrier(iter), int_vector(iterator_sequence(iter), iterator_position(iter)++)); + return(iterator_carrier(iter)); + } + clear_mutable_integer(iterator_carrier(iter)); + return(iterator_quit(sc, iter)); +} + +static s7_pointer vector_iterate(s7_scheme *sc, s7_pointer iter) +{ + if (iterator_position(iter) < iterator_length(iter)) + return(vector_element(iterator_sequence(iter), iterator_position(iter)++)); + return(iterator_quit(sc, iter)); +} + +static s7_pointer closure_iterate(s7_scheme *sc, s7_pointer iter) +{ + /* 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 () #)) ; 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 # (always () because iterator func takes no args) + ;(lambda (asd) ()) ; error: make-iterator argument, #, 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(iter), sc->nil); + /* this can't use s7_apply_function -- we need to catch the error handler's longjmp here */ + if (result == sc->iterator_at_end_value) + { + iterator_next(iter) = iterator_finished; + clear_iter_ok(iter); + } + return(result); +} + +static s7_pointer c_object_iterate(s7_scheme *sc, s7_pointer iter) +{ + s7_pointer result, p, cur; + if (iterator_position(iter) >= iterator_length(iter)) + return(iterator_quit(sc, iter)); + p = iterator_sequence(iter); + cur = iterator_carrier(iter); + set_car(cur, p); + set_car(cdr(cur), wrap_integer(sc, iterator_position(iter))); /* was make_integer 7-May-25, c_object_ref->c_object_getter is c_function in scheme? */ + result = (*(c_object_ref(sc, p)))(sc, cur); + iterator_position(iter)++; + if (result == sc->iterator_at_end_value) + { + iterator_next(iter) = iterator_finished; + clear_iter_ok(iter); + } + return(result); +} + +static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer iter); +static s7_pointer pair_iterate(s7_scheme *sc, s7_pointer iter) +{ + s7_pointer result; + if (!is_pair(iterator_current(iter))) return(iterator_quit(sc, iter)); + result = car(iterator_current(iter)); + iterator_current(iter) = cdr(iterator_current(iter)); + if (iterator_current(iter) == pair_iterator_slow(iter)) + iterator_current(iter) = sc->nil; + iterator_next(iter) = pair_iterate_1; + return(result); +} + +static s7_pointer pair_iterate_1(s7_scheme *sc, s7_pointer iter) +{ + s7_pointer result; + if (!is_pair(iterator_current(iter))) return(iterator_quit(sc, iter)); + result = car(iterator_current(iter)); + iterator_current(iter) = cdr(iterator_current(iter)); + if (iterator_current(iter) == pair_iterator_slow(iter)) + iterator_current(iter) = sc->nil; + else pair_iterator_set_slow(iter, cdr(pair_iterator_slow(iter))); + iterator_next(iter) = 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 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 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; + 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; + pair_iterator_set_slow(iter, e); + return(iter); + } + iterator_carrier(iter) = NULL; + if (!is_let(e)) + iterator_position(iter) = 0; + + switch (type(e)) + { + case T_LET: + if (e == sc->rootlet) + { + let_iterator_set_slot(iter, sc->rootlet_slots); + iterator_next(iter) = let_iterate_uncarried; + return(iter); + } + if (e == sc->starlet) + return(starlet_make_iterator(sc, iter)); + { + s7_pointer func = find_make_iterator_method(sc, e, iter); + if (func) return(func); + } + let_iterator_set_slot(iter, let_slots(e)); + iterator_next(iter) = let_iterate_uncarried; + break; + + case T_HASH_TABLE: + hash_iterator_entry(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_uncarried; + break; + + case T_FLOAT_VECTOR: + iterator_length(iter) = vector_length(e); + iterator_next(iter) = float_vector_iterate_uncarried; + break; + + case T_COMPLEX_VECTOR: + iterator_length(iter) = vector_length(e); + iterator_next(iter) = complex_vector_iterate_uncarried; + break; + + case T_NIL: /* (make-iterator #()) -> #, 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)) + { + iterator_carrier(iter) = list_1_unchecked(sc, int_zero); + set_has_carrier(iter); + iterator_next(iter) = closure_iterate; + iterator_length(iter) = (has_active_methods(sc, e)) ? closure_length(sc, e) : S7_INT64_MAX; + } + else + 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); + { + s7_pointer func = find_make_iterator_method(sc, e, iter); + if (func) return(func); + } + iterator_carrier(iter) = list_2_unchecked(sc, e, int_zero); /* if not unchecked, gc protect iter */ + set_has_carrier(iter); + iterator_next(iter) = c_object_iterate; + break; + + default: + 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 (*s7* 'iterator-at-end-value), # by default. In some cases, \ +the iterator either returns two values in a cons (if the sequence is a hash-table, the cons has the key and value), \ +in others the iterator normally returns an s7_cell created for the value (for example, a float-vector stores data as \ +doubles, but for each value, the iterator returns an s7 object). To avoid all this allocation, 'carrier' can be a cons \ +or #t; in the latter case s7 chooses an appropriate value." + #define Q_make_iterator s7_make_signature(sc, 3, sc->is_iterator_symbol, sc->is_sequence_symbol, s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_pair_symbol)) + + /* we need to call s7_make_iterator before fixing up the optional second arg in case let->method */ + const s7_pointer seq = car(args); + const s7_pointer carrier = (is_pair(cdr(args))) ? cadr(args) : NULL; + s7_pointer iter = s7_make_iterator(sc, seq); + + if (carrier) + { + /* no carrier needed if seq is t_vector, byte_vector, string, c-object, nil or list, else cons for hash/let, + * mutable int|float|complex if int|byte|float|complex-vector, but scheme code can't create a mutable number, so use #t as carrier arg. + */ + if (carrier == sc->T) /* #t = conjure up an appropriate carrier */ + { + switch (type(seq)) /* all types that have carriers use iterator_carrier */ + { + case T_INT_VECTOR: + iterator_carrier(iter) = make_mutable_integer(sc, 0); + iterator_next(iter) = int_vector_iterate_carried; + break; + case T_FLOAT_VECTOR: + iterator_carrier(iter) = make_mutable_real(sc, 0.0); + iterator_next(iter) = float_vector_iterate_carried; + break; + case T_COMPLEX_VECTOR: + iterator_carrier(iter) = make_mutable_complex(sc, 0.0, 0.0); + iterator_next(iter) = complex_vector_iterate_carried; + break; + case T_HASH_TABLE: + iterator_carrier(iter) = cons(sc, sc->F, sc->F); + break; + case T_LET: + iterator_carrier(iter) = cons(sc, sc->F, sc->F); + if (seq != sc->starlet) + { + s7_pointer func = find_make_iterator_method(sc, seq, iter); /* (iterate (make-iterator (mock-string #\h #\i) #t)) */ + if (func) iter = func; /* should this free the previous iterator? */ + if (iterator_next(iter) == let_iterate_uncarried) + iterator_next(iter) = let_iterate_carried; + else + if (!iterator_carrier(iter)) + return(iter); /* don't set has_carrier because GC will segfault upon gc_mark(iterator_carrier(iter)) */ + } + break; + default: + return(iter); + } + set_has_carrier(iter); + } + else + { + 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(seq)) && (!is_let(seq))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "make-iterator carrier argument ~S is a pair, but ~S is ~S, not a hash-table or let", 79), + carrier, seq, object_type_name(sc, seq))); + if (seq != sc->rootlet) + { + iterator_carrier(iter) = carrier; + if ((is_let(seq)) && (seq != sc->starlet)) + { + s7_pointer func = find_make_iterator_method(sc, seq, iter); /* mock-hash-table for example */ + if (func) iter = func; /* (iterate (make-iterator (mock-hash-table 'b 2) (list #f))) */ + if (iterator_next(iter) == let_iterate_uncarried) + iterator_next(iter) = let_iterate_carried; + else + if (!iterator_carrier(iter)) + return(iter); /* don't set has_carrier because GC will segfault upon gc_mark(iterator_carrier(iter)) */ + } + set_has_carrier(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 (*s7* 'iterator-at-end-value), # by default." + #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));} + +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? -------------------------------- */ +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 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)); +} + +/* iterator-length and iterator-position run up against the function iterator */ + + +/* -------- 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) +{ + const 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++) + { + const 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) + { + const s7_int len = (s7_int)hash_table_size(top); + hash_entry_t **entries = hash_table_elements(top); + const 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 e = top; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if ((has_structure(slot_value(slot))) && + (collect_shared_info(sc, ci, slot_value(slot), stop_at_print_length))) + { + top_cyclic = true; + if ((is_c_pointer(slot_value(slot))) || + (is_iterator(slot_value(slot))) || + (is_c_object(slot_value(slot)))) + 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 stop_len; + + /* check for simple cases first */ + if (is_pair(top)) + { + s7_pointer p = top; + if (stop_at_print_length) + { + s7_pointer slow = top; + stop_len = sc->print_length; + for (s7_int k = 0; k < stop_len; k += 2) + { + if (!is_pair(p)) break; + if (has_structure(car(p))) {no_problem = false; break;} + p = cdr(p); + if (!is_pair(p)) break; + if (has_structure(car(p))) {no_problem = false; break;} + p = cdr(p); + slow = cdr(slow); + if (p == 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(p); p = cdr(p)) + if (has_structure(car(p))) {no_problem = false; break;} /* perhaps (and (length > 0)) or vector typer etc */ + if ((no_problem) && + (!is_null(p)) && (has_structure(p))) + 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 (s7_int 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 e = top; (no_problem) && (e); e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (has_structure(slot_value(slot))) /* slot_symbol need not be checked? */ + {no_problem = false; break;} + if (no_problem) return(NULL); + } + else + if (is_hash_table(top)) + { + const s7_int len = (s7_int)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 */ + const 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) + { + check_free_heap_size(sc, ci->top); + begin_temp(sc->y, sc->nil); + for (int32_t i = 0; i < ci->top; i++) + sc->y = cons_unchecked(sc, ci->objs[i], sc->y); + return_with_end_temp(sc->y); + }} + 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, "#", 23, port); + } + else + { + if (is_string_port(obj)) + port_write_string(port)(sc, "#", 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, "#", 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 + { + const 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, "#", 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); /* not const for make_atom */ + 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 */ + if ((!is_clean_symbol(obj)) && + (symbol_needs_slashification(sc, obj))) + { + /* this can't work in general if use_write == p_readable: + * (define f (apply lambda (list () (list 'let (list (list (symbol "a b") 3)) (symbol "a b"))))) ; (f) -> 3 + * prints "readably" as "(lambda () (let (((symbol \"a b\") 3)) (symbol \"a b\")))" + * so, 30-May-24 added (*s7* 'symbol-printer). + */ + if (is_any_procedure(sc->symbol_printer)) /* we see p_write here */ + { + const s7_pointer printer = sc->symbol_printer; + s7_pointer result; + sc->symbol_printer = sc->F; /* avoid infinite recursion */ + result = s7_call(sc, printer, set_plist_1(sc, obj)); + if (!is_string(result)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "(*s7* 'symbol-printer) should return a string: ~S", 49), result)); + /* if we restore symbol-printer before the error, and the printer function stupidly returned the bad symbol, infinite loop */ + sc->symbol_printer = printer; + port_write_string(port)(sc, string_value(result), string_length(result), port); + } + else + { + 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) +{ + const s7_int vlen = vector_length(vect); + 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-"; + else + if (is_complex_vector(vect)) + vtyp = "complex-"; + + 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)) + { + const s7_int vlen = vector_length(vect); + s7_pointer *els = vector_elements(vect); + const 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 (( ", 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) + { + const s7_int dimension = vector_rank(vect) - 1; + const 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) + { + const s7_int dimension = vector_rank(vect) - 1; + const 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 ) ", 28, port); + port_write_vector_typer(sc, vect, port); + port_write_string(port)(sc, ") )", 6, port); + }} + else + { + if (is_typed_vector(vect)) + port_write_string(port)(sc, "(let (( ", 11, port); + /* (let ((v (make-vector 3 'a symbol?))) (object->string v :readable)): "(let (( (vector 'a 'a 'a))) (set! (vector-typer ) symbol?) )" */ + + 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 ) ", 28, port); + port_write_vector_typer(sc, vect, port); + port_write_string(port)(sc, ") )", 6, port); + }}} + else /* not readable write */ + { + if (vector_rank(vect) > 1) /* if rank>1, ndims exists */ + { + 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); + 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 s7_int print_vector_length(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write) +{ + const s7_int len = vector_length(vect); + const char *vtype = "r"; /* "const" here for g++ */ + + if (is_int_vector(vect)) vtype = "i"; + else if (is_complex_vector(vect)) vtype = "c"; + else if (is_byte_vector(vect)) vtype = "u"; + if (len == 0) + { + char buf[128]; + s7_int plen; + if (vector_rank(vect) > 1) + plen = (s7_int)catstrs_direct(buf, "#", vtype, pos_int_to_str_direct(sc, vector_ndims(vect)), "d()", (const char *)(const char *)NULL); + else plen = (s7_int)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) + { + char buf[128]; + s7_int plen = (s7_int)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 + if (is_byte_vector(vect)) + port_write_string(port)(sc, "#u(...)", 7, port); + else port_write_string(port)(sc, "#c(...)", 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 *str; + const s7_int len = print_vector_length(sc, vect, port, use_write); + if (len < 0) return; /* actually -1, see above -- this means there's nothing more to print */ + 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; + const s7_int 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); + str = integer_to_string(sc, int_vector(vect, 0), &plen); + port_write_string(port)(sc, str, 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)) + { + str = integer_to_string(sc, int_vector(vect, 0), &plen); + port_write_string(port)(sc, str, 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); + } + str = integer_to_string(sc, int_vector(vect, 0), &plen); + memcpy((void *)(dbuf + new_len), (const void *)str, 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 plen; + bool too_long; + const s7_double *els = float_vector_floats(vect); + const 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 i; + const s7_int vlen = vector_length(vect); + const 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 (s7_int 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 char *complex_to_string_base_10(s7_scheme *sc, s7_complex obj, s7_int width, s7_int precision, + char float_choice, s7_int *nlen, use_write_t choice) +{ + char *imag; + 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; + } + sc->num_to_str[0] = '\0'; + imag = copy_string(number_to_string_base_10(sc, wrap_real(sc, cimag(obj)), 0, precision, float_choice, &len, choice)); + sc->num_to_str[0] = '\0'; + number_to_string_base_10(sc, wrap_real(sc, creal(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) + { + 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); +} + +static void complex_vector_to_port(s7_scheme *sc, s7_pointer vect, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ + #define CV_BUFSIZE 1024 /* some floats can take around 312 bytes */ + bool too_long; + const s7_complex *els = complex_vector_complexes(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 i; + const s7_int vlen = vector_length(vect); + const s7_complex first = els[0]; + for (i = 1; i < vlen; i++) + if (els[i] != first) + break; + if (i == vlen) + { + s7_int plen; + char *num = complex_to_string_base_10(sc, first, 0, sc->float_format_precision, 'g', &plen, use_write); + make_vector_to_port(sc, vect, port); + port_write_string(port)(sc, num, clamp_length(plen, CV_BUFSIZE), 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) + { + s7_int plen; + char *num = complex_to_string_base_10(sc, els[0], 0, sc->float_format_precision, 'g', &plen, use_write); + port_write_string(port)(sc, "#c(", 3, port); + port_write_string(port)(sc, num, clamp_length(plen, CV_BUFSIZE), port); + for (s7_int i = 1; i < len; i++) + { + num = complex_to_string_base_10(sc, els[i], 0, sc->float_format_precision, 'g', &plen, use_write); + port_write_character(port)(sc, ' ', port); + port_write_string(port)(sc, num, clamp_length(plen, CV_BUFSIZE), port); + } + if (too_long) + port_write_string(port)(sc, " ...)", 5, port); + else port_write_character(port)(sc, ')', port); + } + else + { + char buf[CV_BUFSIZE]; + s7_int plen = catstrs_direct(buf, "#c", 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) +{ + bool too_long; + const 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; + const 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) + { + s7_int plen; + const char *str; /* const for integer_to_string */ + make_vector_to_port(sc, vect, port); + str = integer_to_string(sc, byte_vector(vect, 0), &plen); /* only 0..10 start out with names: init_small_ints */ + port_write_string(port)(sc, str, 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) + { + s7_int plen; + const char *str; + port_write_string(port)(sc, "#u(", 3, port); + str = integer_to_string(sc, byte_vector(vect, 0), &plen); + port_write_string(port)(sc, str, plen, port); + for (s7_int i = 1; i < len; i++) + { + char buf[128]; + 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 + { + char buf[128]; + s7_int 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)) + { + const s7_pointer c = chars[(int32_t)((uint8_t)(buf[0]))]; + const 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 */ + if ((true_len > 0) && (!immutable)) + { + port_write_string(port)(sc, "list", 4, port); + for (s7_pointer p = lst; is_pair(p); p = cdr(p)) + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, car(p), port, p_readable, ci); + } + port_write_character(port)(sc, ')', port); + } + else + { + s7_pointer p; + 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 (p = cdr(lst); is_pair(p); p = cdr(p)) + { + if (is_immutable_pair(p)) + { + 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(p), port, p_readable, ci); + } + if (is_null(p)) + port_write_string(port)(sc, " ()", 3, port); + else + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, p, 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_int len; + bool immutable = false; + const 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)) + { + const bool need_new_ci = ((!ci) && (is_pair(cadr(lst)))); + shared_info_t *new_ci = NULL, *temp_ci = NULL; + const 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 p, 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) + { + 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 (( (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 (( (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 */ + } + p = lst; + for (s7_int i = 0; (i < len) && (is_pair(p)); p = cdr(p), i++) + { + if ((has_structure(car(p))) && + (is_cyclic(car(p)))) + port_write_string(port)(sc, " #f", 3, port); + else + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, car(p), port, use_write, ci); + } + if ((is_pair(cdr(p))) && + (peek_shared_ref(ci, cdr(p)) != 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 `(p . 1) (signature (int-vector))) :readable) */ + p = lst; + for (s7_int i = 0; (i < len) && (is_pair(p)); p = cdr(p), i++) + { + int32_t lref; + if ((has_structure(car(p))) && + (is_cyclic(car(p)))) + { + 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(p)); + if (lref == 0) + object_to_port_with_circle_check(sc, car(p), 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(p))) && + ((lref = peek_shared_ref(ci, cdr(p))) != 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_p; + for (end_p = lst; is_pair(end_p); end_p = cdr(end_p)); /* or maybe faster, start at p? */ + /* we can't depend on the loops above to set p 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_p, local_port, use_write, ci); + port_write_string(local_port)(sc, ") ", 2, local_port); + } + if (lst_local) + port_write_string(local_port)(sc, " )", 8, local_port); + } + else simple_list_readable_display(sc, lst, true_len, len, port, ci, immutable); + } + else /* not :readable */ + { + const 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) + { + s7_pointer p; + s7_int i; + for (p = lst, i = 0; (is_pair(p)) && (i < plen) && ((i == 0) || (peek_shared_ref(ci, p) == 0)); i++, p = cdr(p)) + { + ci->ctr++; + if (ci->ctr > sc->print_length) + { + port_write_string(port)(sc, " ...)", 5, port); + return; + } + object_to_port_with_circle_check(sc, car(p), port, not_p_display(use_write), ci); + if (i < (len - 1)) + port_write_character(port)(sc, ' ', port); + } + if (is_not_null(p)) + { + 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, p, port, not_p_display(use_write), ci); + }} + port_write_character(port)(sc, ')', port); + } + else + { + s7_pointer p = lst; + const s7_int len1 = plen - 1; + if (is_string_port(port)) + { + for (s7_int i = 0; (is_pair(p)) && (i < len1); i++, p = cdr(p)) + { + object_to_port(sc, car(p), 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 (s7_int i = 0; (is_pair(p)) && (i < len1); i++, p = cdr(p)) + { + object_to_port(sc, car(p), port, not_p_display(use_write), ci); /* lst free here if unprotected */ + port_write_character(port)(sc, ' ', port); + } + if (is_pair(p)) + { + object_to_port(sc, car(p), port, not_p_display(use_write), ci); + p = cdr(p); + } + if (is_not_null(p)) + { + if (plen < len) + port_write_string(port)(sc, " ...", 4, port); + else + { + port_write_string(port)(sc, ". ", 2, port); + object_to_port(sc, p, 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("#"); /* 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; + 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); + iterator_carrier(iterator) = cons_unchecked(sc, sc->F, sc->F); + set_has_carrier(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 (( ", 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++) + { + const s7_pointer key_val = hash_table_iterate(sc, iterator); + if (key_val == eof_object) break; /* key_val can be # if hash is a weak-hash-table, and a GC happens during this loop */ + { + const s7_pointer key = car(key_val); + const 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++) + { + const s7_pointer key_val = hash_table_iterate(sc, iterator); + if (key_val == eof_object) break; /* key_val can be # if hash is a weak-hash-table, and a GC happens during this loop */ + 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, ") ))", 7, port); + } + else + if (letd) + port_write_string(port)(sc, ") )", 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! ))", 19, port); + } + s7_gc_unprotect_at(sc, gc_iter); + iterator_carrier(iterator) = sc->nil; +} + +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)) + { + const 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, "#', 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 ((!sc->short_print) && (has_active_methods(sc, obj))) /* short_print 14-Dec-24 from stacktrace (see below) */ + { + const s7_pointer print_func = find_method(sc, obj, sc->object_to_string_symbol); + if (print_func != sc->undefined) + { + s7_pointer str; + /* 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)) + str = s7_apply_function(sc, print_func, set_plist_1(sc, obj)); + else str = 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(str)) && + (string_length(str) > 0)) + port_write_string(port)(sc, string_value(str), string_length(str), port); + return; + }} + if (obj == sc->rootlet) {port_write_string(port)(sc, "(rootlet)", 9, port); return;} + if (obj == sc->starlet) {port_write_string(port)(sc, "*s7*", 4, port); return;} + /* if (is_unlet(obj)) {port_write_string(port)(sc, "(unlet)", 7, port); return;} */ /* this is the let created by (unlet), not sc->unlet_entries */ + if (sc->short_print) {port_write_string(port)(sc, "#", 6, port); return;} + + /* circles can happen here: (let ((b #f)) (set! b (curlet)) (curlet)): #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) +{ + const s7_pointer body = closure_body(obj), parlist = closure_pars(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(parlist)) + { + port_write_character(port)(sc, ' ', port); + port_write_string(port)(sc, symbol_name(parlist), symbol_name_length(parlist), port); + port_write_character(port)(sc, ' ', port); + } + else + if (is_pair(parlist)) + { + s7_pointer pars; + port_write_string(port)(sc, " (", 2, port); + for (pars = parlist; is_pair(pars); pars = cdr(pars)) + { + object_to_port(sc, car(pars), port, p_write, NULL); + if (is_pair(cdr(pars))) + port_write_character(port)(sc, ' ', port); + } + if (!is_null(pars)) + { + port_write_string(port)(sc, " . ", 3, port); + object_to_port(sc, pars, port, p_write, NULL); + } + port_write_string(port)(sc, ") ", 2, port); + } + else port_write_string(port)(sc, " () ", 4, port); + + for (s7_pointer 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 slot = let_slots(le); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(slot); + return(NULL); +} + +static bool slot_memq(const s7_pointer symbol, s7_pointer symbols) +{ + for (s7_pointer syms = symbols; is_pair(syms); syms = cdr(syms)) + if (slot_symbol(car(syms)) == symbol) + return(true); + return(false); +} + +static bool arg_memq(const s7_pointer symbol, s7_pointer args) +{ + for (s7_pointer p = args; is_pair(p); p = cdr(p)) + if ((car(p) == symbol) || + ((is_pair(car(p))) && + (caar(p) == 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); + s7_pointer f = s7_symbol_local_value(sc, sym, e); + if (f == closure) + return(sym); + } + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (slot_value(slot) == closure) + return(slot_symbol(slot)); + } + 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 sym = find_closure(sc, closure, closure_let(closure)); + if (is_symbol(sym)) + { + port_write_string(port)(sc, symbol_name(sym), symbol_name_length(sym), port); + return; + } + switch (type(closure)) + { + case T_CLOSURE: port_write_string(port)(sc, "#", 3, port); + else + { + s7_pointer pars = closure_pars(closure); + if (is_symbol(pars)) + { + port_write_string(port)(sc, symbol_name(pars), symbol_name_length(pars), port); + port_write_character(port)(sc, '>', port); /* (lambda a a) -> # */ + } + else + { + s7_pointer sym = car(pars); + if (is_pair(sym)) sym = car(sym); + port_write_character(port)(sc, '(', port); + port_write_string(port)(sc, symbol_name(sym), symbol_name_length(sym), port); + if (!is_null(cdr(pars))) + { + s7_pointer par; + port_write_character(port)(sc, ' ', port); + if (is_pair(cdr(pars))) + { + par = cadr(pars); + if (is_pair(par)) + par = car(par); + else + if (par == sc->rest_keyword) + { + port_write_string(port)(sc, ":rest ", 6, port); + pars = cdr(pars); + par = cadr(pars); + if (is_pair(par)) par = car(par); + }} + else + { + port_write_string(port)(sc, ". ", 2, port); + par = cdr(pars); + } + port_write_string(port)(sc, symbol_name(par), symbol_name_length(par), port); + if ((is_pair(cdr(pars))) && + (!is_null(cddr(pars)))) + 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 sym = find_closure(sc, closure, sc->curlet); + if (is_symbol(sym)) + return(sym); + 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_gc_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) +{ + const 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->temp7 = (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->temp7, port, p_write, NULL); + sc->temp7 = 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) +{ + const s7_pointer body = closure_body(obj); + s7_pointer parlist = closure_pars(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, "#", 41, port); /* not s7_error here! */ + return; + } + if ((!ci) && (is_pair(parlist))) + { /* (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, parlist, false)) + { + free_shared_info(new_ci); + port_write_string(port)(sc, "#", 51, port); /* not s7_error here! */ + return; + } + free_shared_info(new_ci); + }} + if (is_symbol(parlist)) parlist = set_dlist_1(sc, parlist); + pe = closure_let(obj); + + gc_loc = gc_protect_1(sc, sc->nil); + collect_locals(sc, body, pe, parlist, gc_loc); /* collect locals used only here (and below) */ + collect_specials(sc, pe, parlist, gc_loc); + + if (s7_is_dilambda(obj)) + { + setter = closure_setter(obj); + if (has_closure_let(setter)) /* collect args etc so need the parameter list */ + { + parlist = closure_pars(setter); + if (is_symbol(parlist)) parlist = set_dlist_1(sc, parlist); + collect_locals(sc, closure_body(setter), pe, parlist, 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 slots = local_slots; is_pair(slots); slots = cdr(slots)) + { + const s7_pointer slot = car(slots); + 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(slots))) + 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 slots = local_slots; is_pair(slots); slots = cdr(slots)) + { + const s7_pointer slot = car(slots); + 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_pars(obj), body, port); + if (setter) + { + port_write_character(port)(sc, ' ', port); + if (has_closure_let(setter)) + write_closure_readably_1(sc, setter, closure_pars(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 iter, s7_pointer port, use_write_t use_write, shared_info_t *ci) +{ + if (use_write == p_readable) + { + if (iterator_is_at_end(iter)) + { + switch (type(iterator_sequence(iter))) + { + 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_COMPLEX_VECTOR: port_write_string(port)(sc, "(make-iterator #c())", 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(iter))) + 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 + { + const s7_pointer seq = iterator_sequence(iter); + int32_t iter_ref; + if ((ci) && + (is_cyclic(iter)) && + ((iter_ref = peek_shared_ref(ci, iter)) != 0)) + { + /* basically the same as c_pointer_to_port */ + if (!is_cyclic_set(iter)) + { + 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(iter); + return; + }} + + if (is_string(seq)) + { + const s7_int len = string_length(seq) - iterator_position(iter); + if (len == 0) + port_write_string(port)(sc, "(make-iterator \"\")", 18, port); + else + { + const char *iter_str = (const char *)(string_value(seq) + iterator_position(iter)); + 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(iter), port, use_write, ci); + port_write_character(port)(sc, ')', port); + } + else + { + if ((is_let(seq)) && (seq != sc->rootlet) && (seq != sc->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 != let_iterator_slot(iter); slot = next_slot(slot)) + port_write_string(port)(sc, "(iter) ", 7, port); + port_write_string(port)(sc, "iter)", 5, port); + } + else + { + if (iterator_position(iter) > 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(iter) > 0) + { + if (iterator_position(iter) == 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(iter)), + ") 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(iter))) && (is_weak_hash_table(iterator_sequence(iter)))) + str = "weak-hash-table"; + else + if (iterator_sequence(iter) == sc->starlet) + str = "*s7*"; + else str = type_name(sc, iterator_sequence(iter), no_article); + port_write_string(port)(sc, "#', port); + } +} + +static void c_pointer_to_port(s7_scheme *sc, s7_pointer cptr, s7_pointer port, use_write_t use_write, shared_info_t *ci) +{ + #define CP_BUFSIZE 128 + char buf[CP_BUFSIZE]; + int32_t nlen; + if (use_write == p_readable) + { + int32_t ref; + if ((ci) && + (is_cyclic(cptr)) && + ((ref = peek_shared_ref(ci, cptr)) != 0)) + { + port_write_string(port)(sc, "#f", 2, port); + if (!is_cyclic_set(cptr)) + { + 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(cptr)); + port_write_string(ci->init_port)(sc, buf, nlen, ci->init_port); + + if ((c_pointer_type(cptr) != sc->F) || + (c_pointer_info(cptr) != sc->F)) + { + flip_ref(ci, c_pointer_type(cptr)); + + port_write_character(ci->init_port)(sc, ' ', ci->init_port); + object_to_port_with_circle_check(sc, c_pointer_type(cptr), ci->init_port, use_write, ci); + + flip_ref(ci, c_pointer_type(cptr)); + flip_ref(ci, c_pointer_info(cptr)); + + port_write_character(ci->init_port)(sc, ' ', ci->init_port); + object_to_port_with_circle_check(sc, c_pointer_info(cptr), ci->init_port, use_write, ci); + + flip_ref(ci, c_pointer_info(cptr)); + } + port_write_string(ci->init_port)(sc, "))\n", 3, ci->init_port); + set_cyclic_set(cptr); + }} + else + { + nlen = snprintf(buf, CP_BUFSIZE, "(c-pointer %" p64, (intptr_t)c_pointer(cptr)); + port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port); + if ((c_pointer_type(cptr) != sc->F) || + (c_pointer_info(cptr) != sc->F)) + { + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, c_pointer_type(cptr), port, use_write, ci); + port_write_character(port)(sc, ' ', port); + object_to_port_with_circle_check(sc, c_pointer_info(cptr), port, use_write, ci); + } + port_write_character(port)(sc, ')', port); + }} + else + { + if ((is_symbol(c_pointer_type(cptr))) && + (symbol_name_length(c_pointer_type(cptr)) < (CP_BUFSIZE / 2))) + nlen = snprintf(buf, CP_BUFSIZE, "#<%s %p>", symbol_name(c_pointer_type(cptr)), c_pointer(cptr)); + else nlen = snprintf(buf, CP_BUFSIZE, "#", c_pointer(cptr)); + port_write_string(port)(sc, buf, clamp_length(nlen, CP_BUFSIZE), port); + } +} + +static void random_state_to_port(s7_scheme *sc, s7_pointer rs, 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, "#"); + else nlen = snprintf(buf, B_BUFSIZE, "#", rs); +#else + if (use_write == p_readable) + nlen = snprintf(buf, B_BUFSIZE, "(random-state %" PRIu64 " %" PRIu64 ")", random_seed(rs), random_carry(rs)); + else nlen = snprintf(buf, B_BUFSIZE, "#", random_seed(rs), random_carry(rs)); +#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, "", 12, port); + else port_write_string(port)(sc, "", 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 #)", 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, "#", 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) +{ + /* killer overhead here; breaking it into named/unnamed funcs helps only slightly -- still ridiculous overhead according to callgrind */ + const s7_int num = integer(obj); + if ((num < 10) && (num >= 0)) + { + static const char *ones[10] = {"0", "1", "2", "3", "4", "5", "6", "7", "8", "9"}; + if (is_string_port(port)) + { + if (port_position(port) + 1 < port_data_size(port)) + { + memcpy((void *)(port_data(port) + port_position(port)), (void *)ones[num], 1); + port_position(port) += 1; + } + else string_write_string_resized(sc, ones[num], 1, port); + } + else port_write_string(port)(sc, ones[num], 1, port); + } + else + { + s7_int nlen = 0; + const char *str = integer_to_string(sc, integer(obj), &nlen); + port_write_string(port)(sc, str, nlen, port); + } +} + +static void number_to_port(s7_scheme *sc, s7_pointer num, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ + s7_int nlen = 0; + char *str = number_to_string_base_10(sc, num, 0, sc->float_format_precision, 'g', &nlen, use_write); /* was 14 */ + port_write_string(port)(sc, str, nlen, port); +} + +#if WITH_GMP +static void big_number_to_port(s7_scheme *sc, s7_pointer num, 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, num, 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) +{ + if (is_initial_value(obj)) + 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 c, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ + if (use_write == p_display) + port_write_character(port)(sc, character(c), port); + else port_write_string(port)(sc, character_name(c), character_name_length(c), port); +} + +static void closure_to_port(s7_scheme *sc, s7_pointer func, s7_pointer port, use_write_t use_write, shared_info_t *ci) +{ + if (has_active_methods(sc, func)) + { + /* look for object->string method else fallback on ordinary case. + * can't use recursion on closure_let here because then the fallback name is #. + * 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. + */ + const s7_pointer print_func = find_method(sc, closure_let(func), sc->object_to_string_symbol); + if (print_func != sc->undefined) + { + s7_pointer str = s7_apply_function(sc, print_func, set_plist_1(sc, func)); + if (string_length(str) > 0) + port_write_string(port)(sc, string_value(str), string_length(str), port); + return; + }} + if (use_write == p_readable) + write_closure_readably(sc, func, port, ci); + else write_closure_name(sc, func, port); +} + +static void macro_to_port(s7_scheme *sc, s7_pointer func, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ + if (has_active_methods(sc, func)) + { + const s7_pointer print_func = find_method(sc, closure_let(func), sc->object_to_string_symbol); + if (print_func != sc->undefined) + { + s7_pointer str = s7_apply_function(sc, print_func, set_plist_1(sc, func)); + if (string_length(str) > 0) + port_write_string(port)(sc, string_value(str), string_length(str), port); + return; + }} + if (use_write == p_readable) + write_macro_readably(sc, func, port); + else write_closure_name(sc, func, port); +} + +static void c_function_to_port(s7_scheme *sc, s7_pointer func, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ /* includes c_function_star, so c_function_symbol can't be used */ + const s7_int len = c_function_name_length(func); + + if (is_string_port(port)) /* expand port_write_string -> string_write_string, 15 in tauto */ + { + if (len > 0) + { + if (port_position(port) + len + 2 < port_data_size(port)) + { + if (is_initial_value(func)) + port_write_string(port)(sc, "#_", 2, port); + memcpy((void *)(port_data(port) + port_position(port)), (const void *)c_function_name(func), len); + port_position(port) += len; + } + else string_write_string_resized(sc, c_function_name(func), len, port); + } + else port_write_string(port)(sc, "#", 13, port); + } + else + if (len > 0) + { + if (is_initial_value(func)) + port_write_string(port)(sc, "#_", 2, port); + port_write_string(port)(sc, c_function_name(func), len, port); + } + else port_write_string(port)(sc, "#", 13, port); +} + +static void c_macro_to_port(s7_scheme *sc, s7_pointer func, s7_pointer port, use_write_t unused_use_write, shared_info_t *unused_ci) +{ + if (c_macro_name_length(func) > 0) + { + if (is_initial_value(func)) + port_write_string(port)(sc, "#_", 2, port); + port_write_string(port)(sc, c_macro_name(func), c_macro_name_length(func), port); + } + else port_write_string(port)(sc, "#", 10, port); +} + +/* (eval-string (object->string (call-with-exit (lambda (go) go)) :readable)) should at least be readable if use_write == p_readable, + * but the normal form "#" gives a read-error due to the embedded space. So if :readable, we return "#" which + * isn't going to do "the right thing", but at least it doesn't raise a read-error. + */ + +static void continuation_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ + if (is_symbol(continuation_name(obj))) + { + port_write_string(port)(sc, "#', port); + } + else port_write_string(port)(sc, "#", 15, port); +} + +static void goto_to_port(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *unused_ci) +{ + if (is_symbol(call_exit_name(obj))) + { + port_write_string(port)(sc, "#', port); + } + else port_write_string(port)(sc, "#", 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, "#', 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, "#", 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 */ + { + set_mlist_2(sc, obj, (use_write == p_readable) ? sc->readable_keyword : ((use_write == p_write) ? sc->T : sc->F)); + port_display(port)(sc, s7_string((*(c_object_to_string(sc, obj)))(sc, sc->mlist_2)), 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; + const s7_pointer old_w = sc->w; + const s7_pointer obj_list = ((*(c_object_to_list(sc, obj)))(sc, set_mlist_1(sc, obj))); + sc->w = obj_list; + if ((ci) && + (is_cyclic(obj)) && + ((href = peek_shared_ref(ci, obj)) != 0)) + { + s7_pointer p = obj_list; + 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 (s7_pointer 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, "#", 16, port); + else port_write_string(port)(sc, "#", 8, port); +} + +static void init_display_functions(void) +{ + for (int32_t i = 0; i < 256; i++) display_functions[i] = display_fallback; + display_functions[T_BACRO] = macro_to_port; + display_functions[T_BACRO_STAR] = macro_to_port; +#if WITH_GMP + display_functions[T_BIG_COMPLEX] = big_number_to_port; + 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; +#endif + display_functions[T_BOOLEAN] = unique_to_port; + display_functions[T_BYTE_VECTOR] = byte_vector_to_port; + display_functions[T_CATCH] = catch_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_COMPLEX] = number_to_port; + display_functions[T_COMPLEX_VECTOR] = complex_vector_to_port; + display_functions[T_CONTINUATION] = continuation_to_port; + display_functions[T_COUNTER] = counter_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_OBJECT] = c_object_to_port; + display_functions[T_C_POINTER] = c_pointer_to_port; + display_functions[T_C_RST_NO_REQ_FUNCTION] = c_function_to_port; + display_functions[T_DYNAMIC_WIND] = dynamic_wind_to_port; + display_functions[T_EOF] = eof_to_port; + display_functions[T_FLOAT_VECTOR] = float_vector_to_port; + display_functions[T_GOTO] = goto_to_port; + display_functions[T_HASH_TABLE] = hash_table_to_port; + display_functions[T_INPUT_PORT] = input_port_to_port; + display_functions[T_INTEGER] = integer_to_port; + display_functions[T_INT_VECTOR] = int_vector_to_port; + display_functions[T_ITERATOR] = iterator_to_port; + display_functions[T_LET] = let_to_port; + display_functions[T_MACRO] = macro_to_port; + display_functions[T_MACRO_STAR] = macro_to_port; + display_functions[T_NIL] = unique_to_port; + display_functions[T_OUTPUT_PORT] = output_port_to_port; + display_functions[T_PAIR] = pair_to_port; + display_functions[T_RANDOM_STATE] = random_state_to_port; + display_functions[T_RATIO] = number_to_port; + display_functions[T_REAL] = number_to_port; + display_functions[T_SLOT] = internal_slot_to_port; + display_functions[T_STACK] = stack_to_port; + display_functions[T_STRING] = string_to_port; + display_functions[T_SYMBOL] = symbol_to_port; + display_functions[T_SYNTAX] = syntax_to_port; + display_functions[T_UNDEFINED] = undefined_to_port; + display_functions[T_UNSPECIFIED] = unique_to_port; + display_functions[T_UNUSED] = unique_to_port; + display_functions[T_VECTOR] = vector_to_port; +} + +static void object_to_port_with_circle_check_1(s7_scheme *sc, s7_pointer obj, s7_pointer port, use_write_t use_write, shared_info_t *ci) +{ + const int32_t ref = (is_collected(obj)) ? shared_ref(ci, obj) : 0; + if (ref == 0) + object_to_port(sc, obj, 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, obj); + 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, obj, 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, obj, 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) +{ + const s7_int len = FORMAT_PORT_LENGTH; + block_t *block = mallocate(sc, len); + block_t *b = mallocate_port(sc); + const s7_pointer port = alloc_pointer(sc); + set_full_type(port, T_OUTPUT_PORT); + port_block(port) = b; + port_port(port) = (port_t *)block_data(b); + port_type(port) = string_port; + port_set_closed(port, false); + port_data_size(port) = len; + port_next(port) = NULL; + port_data(port) = (uint8_t *)(block_data(block)); + port_data_block(port) = block; + port_data(port)[0] = '\0'; + port_position(port) = 0; + port_needs_free(port) = false; + port_port(port)->pf = &output_string_functions; +#if S7_DEBUGGING + sc->format_ports_allocated++; +#endif + return(port); +} + +static inline s7_pointer open_format_port(s7_scheme *sc) +{ + s7_pointer port = sc->format_ports; + if (!port) return(new_format_port(sc)); + sc->format_ports = (s7_pointer)(port_next(port)); + port_position(port) = 0; + port_data(port)[0] = '\0'; + return(port); +} + +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, result; + + 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)) + result = block_to_string(sc, reallocate(sc, port_data_block(strport), port_position(strport) + 1), port_position(strport)); + else result = block_to_string(sc, port_data_block(strport), port_position(strport)); + restore_format_port(sc, strport); + return(result); +} + +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; + const s7_pointer obj = car(args); + s7_pointer strport; + s7_int out_len, pending_max = S7_INT64_MAX; + const bool old_openlets = sc->has_openlets; + + if (is_pair(cdr(args))) + { + const s7_pointer arg2 = cadr(args); + if (arg2 == sc->F) choice = p_display; + else {if (arg2 == sc->T) choice = p_write; + else {if (arg2 == sc->readable_keyword) choice = p_readable; + else {if (arg2 == sc->display_keyword) choice = p_display; + else {if (arg2 == sc->write_keyword) choice = p_write; + else wrong_type_error_nr(sc, sc->object_to_string_symbol, 2, arg2, wrap_string(sc, "a boolean or :readable", 22));}}}} + + if (is_pair(cddr(args))) + { + const s7_pointer arg3 = caddr(args); + if (!s7_is_integer(arg3)) + { + if (choice == p_readable) /* (object->string #r(1 2 3) :readable "hi") */ + wrong_type_error_nr(sc, sc->object_to_string_symbol, 3, arg3, sc->type_names[T_INTEGER]); + return(method_or_bust(sc, arg3, sc->object_to_string_symbol, args, sc->type_names[T_INTEGER], 3)); + } + if (s7_integer_clamped_if_gmp(sc, arg3) < 0) + out_of_range_error_nr(sc, sc->object_to_string_symbol, int_three, arg3, a_non_negative_integer_string); + pending_max = s7_integer_clamped_if_gmp(sc, arg3); + }} + 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 if_method_exists_return_value(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)'.'; + } + { + s7_pointer result; + if (out_len >= port_data_size(strport)) /* this can happen (but only == I think) */ + result = block_to_string(sc, reallocate(sc, port_data_block(strport), out_len + 1), out_len); + else result = block_to_string(sc, port_data_block(strport), out_len); + restore_format_port(sc, strport); + sc->has_openlets = old_openlets; + return(result); + } +} + + +/* -------------------------------- 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)) + + const s7_pointer port = (is_pair(args)) ? car(args) : current_output_port(sc); + if (!is_output_port(port)) + { + if (port == sc->F) return(newline_char); + if_method_exists_return_value(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); + if_method_exists_return_value(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)) + if_method_exists_return_value(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)); +} + +static s7_pointer g_write_2(s7_scheme *sc, s7_pointer args) {return(write_p_pp(sc, car(args), cadr(args)));} + +static s7_pointer write_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 2) /* not check_for_substring_temp(sc, expr) here -- write returns arg so can be immutable if substring_uncopied */ + return((caddr(expr) == sc->F) ? sc->display_f : sc->write_2); + return(func); +} + + +/* -------------------------------- 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); + if_method_exists_return_value(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); + if_method_exists_return_value(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) +{ /* infinite loop: (display (openlet (inlet 'display display))) -- not specific to display of course */ + #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 func, 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(func); +} + +static s7_pointer display_p_p(s7_scheme *sc, s7_pointer x) +{ + if (current_output_port(sc) == sc->F) return(x); + if_method_exists_return_value(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), in s7 write here == display, Guile write == s7 write */ + + +/* -------------------------------- 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; + const s7_pointer proc = car(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); /* # 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; + const s7_pointer 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); /* # 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; + const s7_pointer 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; + const s7_pointer 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 no_return 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; + const s7_pointer ctrl_str = (fdat->orig_str) ? fdat->orig_str : wrap_string(sc, str, safe_strlen(str)); + const s7_pointer args = (is_elist(ur_args)) ? copy_proper_list(sc, ur_args) : ur_args; + const 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); /* unaligned */ + 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); /* unaligned */ + 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) +{ + 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 *tmp, *padtmp; + block_t *b = NULL; + s7_int nlen = 0; +#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 + { + char *tmp; + block_t *b = NULL; + s7_int nlen = 0; +#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, s7_int start, s7_int end) /* start=i, end=str_len-1, assume ~{...~} */ +{ + s7_int nesting = 1; + for (s7_int k = start + 2; k < end; k++) + if (str[k] == '~') + { + if (str[k + 1] == '}') + { + nesting--; + if (nesting == 0) + return(k - start - 1); + } + else + if (str[k + 1] == '{') + nesting++; + } + return(-1); +} + +static bool format_method(s7_scheme *sc, const char *str, format_data_t *fdat, s7_pointer port) +{ + s7_pointer func; + const s7_pointer 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, "#", 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", 20, str, args, fdat); + if (!s7_is_integer(car(fdat->args))) + format_error_nr(sc, "~N: integer argument required", 29, str, args, fdat); + n = s7_integer_clamped_if_gmp(sc, car(fdat->args)); + if (n < 0) + format_error_nr(sc, "~N value is negative?", 21, str, args, fdat); + if (n > sc->max_string_length) + { /* desperation -- we need some string that will stay around long enough to be reported */ + int bytes = snprintf(sc->strbuf, sc->strbuf_size, "~N value is too big; (*s7* 'max-string-length) is %" ld64, sc->max_string_length); + format_error_nr(sc, sc->strbuf, bytes, 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; + const 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_string_length) + { + int bytes; + if (str[old_i - 1] != ',') + bytes = snprintf(sc->strbuf, sc->strbuf_size, "width is too big; (*s7* 'max-string-length) is %" ld64, sc->max_string_length); + else bytes = snprintf(sc->strbuf, sc->strbuf_size, "precision is too big; (*s7* 'max-string-length) is %" ld64, sc->max_string_length); + format_error_nr(sc, sc->strbuf, bytes, str, fdat->args, fdat); + } + return(width); +} + +static format_data_t *make_fdat(s7_scheme *sc) +{ + format_data_t *fdat = (format_data_t *)Calloc(1, sizeof(format_data_t)); /* not Malloc here! */ + fdat->curly_arg = sc->nil; + return(fdat); +} + +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] = make_fdat(sc); + sc->num_fdats = new_num_fdats; + } + fdat = sc->fdats[sc->format_depth]; +#if 1 + if (fdat->port) /* happens a lot in tform */ + { + close_format_port(sc, fdat->port); + fdat->port = NULL; + } +#endif +#if 0 + /* can happen but requires a lot of effort and is never repeatable! only fdat->curly_arg is GC protected? */ + if (fdat->strport) + { + close_format_port(sc, fdat->strport); + fdat->strport = NULL; + } +#endif + 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_pair(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); use ~NC in s7: (format #f "~NC" 3 #\newline) */ + 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 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)) */ + /* we can't use !s7_is_proper_list(sc, car(fdat->args)) because cyclic lists are ok here */ + 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; + 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))) + { + s7_pointer strport; + const 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 (digitp((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 (digitp((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)) + { + if (port_position(port) == 0) + result = nil_string; + else + { + block_t *block = inline_mallocate(sc, FORMAT_PORT_LENGTH); /* for format port after turning current format block into a string */ + 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)); /* this can happen (s7test, pos/size=128) */ + close_format_port(sc, port); /* i.e. return it to the fdat free list */ + fdat->port = NULL; + return(result); + } + return(nil_string); +} + +static bool is_columnizing(const char *str) /* look for ~t ~,T ~,t */ +{ + const char *p = (const char *)str; + while (*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, ~~ = ~, ~ 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) -> \"1.001000e+02\" (%e in C)\n\ +~F: (format #f \"~F\" 100.1) -> \"100.100000\" (%f in C)\n\ +~G: (format #f \"~G\" 100.1) -> \"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 port = car(args), str; + if (is_null(port)) + { + port = current_output_port(sc); /* () -> (current-output-port) */ + if (port == 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(port)) || /* #f or #t */ + ((is_output_port(port)) && /* (current-output-port) or call-with-open-file arg, etc */ + (!port_is_closed(port))))) + return(method_or_bust(sc, port, 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, (port == sc->T) ? current_output_port(sc) : port, + string_value(str), cddr(args), NULL, !is_output_port(port), 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_nr(s7_scheme *sc, s7_pointer args) /* port == #f, in do body, args already evaluated */ +{ + return(nil_string); +} + +static s7_pointer g_format_just_control_string(s7_scheme *sc, s7_pointer args) +{ + s7_pointer port = car(args); + const s7_pointer str = cadr(args); + if (port == sc->F) + return(str); + + if (is_null(port)) + { + port = current_output_port(sc); + if (port == sc->F) + return(nil_string); + } + if (port == 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(port)) || + (port_is_closed(port))) + return(method_or_bust(sc, port, sc->format_symbol, args, a_format_port_string, 1)); + + if (string_length(str) == 0) + return(nil_string); + + port_write_string(port)(sc, string_value(str), string_length(str), port); + 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 port = car(args), str; + if (is_null(port)) + { + port = current_output_port(sc); + if (port == sc->F) + return(nil_string); + } + if (!((is_boolean(port)) || + ((is_output_port(port)) && /* (current-output-port) or call-with-open-file arg, etc */ + (!port_is_closed(port))))) + return(method_or_bust(sc, port, sc->format_symbol, args, a_format_port_string, 1)); + + str = cadr(args); + sc->format_column = 0; + return(format_to_port_1(sc, (port == sc->T) ? current_output_port(sc) : port, + string_value(str), cddr(args), NULL, + !is_output_port(port), /* i.e. is boolean as 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 func, int32_t args, s7_pointer expr) +{ + if (args > 1) + { + const s7_pointer port = cadr(expr); + const 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 : func); + + 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) && /* (format #f "~a" obj) */ + (port == sc->F) && + (len == 2) && /* "~a" */ + (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(func); +} + + +#if WITH_SYSTEM_EXTRAS +#include + +/* -------------------------------- 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 filename) +{ + if (!is_string(filename)) + sole_arg_wrong_type_error_nr(sc, sc->file_exists_symbol, filename, sc->type_names[T_STRING]); + if (string_length(filename) >= 2) + { + block_t *b = expand_filename(sc, string_value(filename)); + if (b) + { + bool result = file_probe((char *)block_data(b)); + liberate(sc, b); + return(result); + }} + return(file_probe(string_value(filename))); +} + +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) + + const 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 a let 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 return-string) 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 + const s7_pointer name = car(args); + if (!is_string(name)) + return(method_or_bust(sc, name, sc->system_symbol, args, sc->type_names[T_STRING], 2)); + if (is_pair(cdr(args))) + { + const s7_pointer return_string = cadr(args); + if (return_string == 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); +#if S7_DEBUGGING + sc->blocks_mallocated[TOP_BLOCK_LIST]++; +#endif + return(block_to_string(sc, b, cur_len)); + } + return(nil_string); + } + if (return_string != sc->F) + wrong_type_error_nr(sc, sc->system_symbol, 2, return_string, sc->type_names[T_BOOLEAN]); + } + return(make_integer(sc, system(string_value(name)))); +#endif +} + + +#if !MS_WINDOWS +#include + +/* -------------------------------- directory->list -------------------------------- */ +static s7_pointer directory_to_list_1(s7_scheme *sc, const char *dir_name) +{ + DIR *dpos; + begin_temp(sc->y, sc->nil); + if ((dpos = opendir(dir_name))) + { + struct dirent *dirp; + while ((dirp = readdir(dpos))) + sc->y = cons_unchecked(sc, s7_make_string(sc, dirp->d_name), sc->y); + closedir(dpos); + } + return_with_end_temp(sc->y); +} + +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 */ + + const 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; + const 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 /* !ms_windows */ +#endif /* with_system_extras */ + + +/* -------------------------------- lists -------------------------------- */ +s7_pointer s7_cons(s7_scheme *sc, s7_pointer a, s7_pointer b) +{ + s7_pointer p; + new_cell(sc, p, T_PAIR | T_SAFE_PROCEDURE); + set_car(p, a); + set_cdr(p, b); + return(p); +} + +static s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b) +{ + /* apparently slightly faster as a function? */ + s7_pointer p; + new_cell_no_check(sc, p, T_PAIR | T_SAFE_PROCEDURE); + set_car(p, a); + set_cdr(p, b); + return(p); +} + +static s7_pointer semipermanent_cons(s7_scheme *sc, s7_pointer a, s7_pointer b, s7_uint type) +{ + s7_pointer p = alloc_pointer(sc); + set_full_type(p, type | T_UNHEAP); + set_car(p, a); + unchecked_set_cdr(p, b); + return(p); +} + +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 result = sc->nil; + + for (i = 0; i < len; i++) + result = semipermanent_cons(sc, sc->unused, result, T_PAIR | T_IMMUTABLE); + va_start(ap, len); + i = 0; /* or 1? */ + for (s7_pointer p = result; 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(result); +} + +s7_pointer s7_make_circular_signature(s7_scheme *sc, s7_int cycle_point, s7_int len, ...) +{ + va_list ap; + s7_int i; + s7_pointer result = sc->nil, back = NULL, end = NULL; + + for (i = 0; i < len; i++) + result = semipermanent_cons(sc, sc->nil, result, T_PAIR | T_IMMUTABLE); + va_start(ap, len); + i = 0; + for (s7_pointer p = result; 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(result)); + return(result); +} + + +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; + 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)) /* perhaps method? */ + 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) +{ + if (is_list(tree)) + { + 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-leaves: tree is cyclic: ~S", 31), tree)); + return(make_integer(sc, tree_len(sc, tree))); + } + return(method_or_bust_p(sc, tree, sc->tree_leaves_symbol, a_list_string)); +} + +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); /* this happens a lot */ + 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 bool tree_memq_b_7pp(s7_scheme *sc, s7_pointer sym, s7_pointer tree) +{ + if (!is_list(tree)) + { + if (!has_active_methods(sc, tree)) + wrong_type_error_nr(sc, sc->tree_memq_symbol, 2, tree, a_list_string); + return(find_and_apply_method(sc, tree, sc->tree_memq_symbol, set_mlist_2(sc, sym, tree))); + } + return(s7_tree_memq(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) + return(make_boolean(sc, tree_memq_b_7pp(sc, car(args), cadr(args)))); +} + +static /* inline */ bool tree_including_quote_memq(s7_scheme *sc, s7_pointer sym, s7_pointer tree) /* sym need not be a symbol */ +{ + do { + if (sym == car(tree)) + return(true); + if (is_pair(car(tree))) + { + s7_pointer cp = car(tree); + do { + if (sym == car(cp)) + return(true); + if ((is_pair(car(cp))) && (tree_including_quote_memq(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); +} + + +/* ---------------- 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_small_symbol_set(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_small_symbol_set(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)); + } + begin_small_symbol_set(sc); + for (s7_pointer p = syms; is_pair(p); p = cdr(p)) + if (is_symbol(car(p))) + add_symbol_to_small_symbol_set(sc, car(p)); + else non_symbols = true; + { + bool result = pair_set_memq(sc, tree); + end_small_symbol_set(sc); + if (result) 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) + const s7_pointer symbols = car(args), tree = cadr(args); + if (!is_list(symbols)) /* tree_set_memq_b_7pp returns bool, so we have to check car(args) for an openlet first */ + { + if (!has_active_methods(sc, symbols)) + wrong_type_error_nr(sc, sc->tree_set_memq_symbol, 1, symbols, a_list_string); + return(find_and_apply_method(sc, symbols, sc->tree_set_memq_symbol, args)); + } + if (!is_list(tree)) + { + if (!has_active_methods(sc, tree)) + wrong_type_error_nr(sc, sc->tree_set_memq_symbol, 2, tree, a_list_string); + return(find_and_apply_method(sc, tree, sc->tree_set_memq_symbol, args)); + } + return(make_boolean(sc, tree_set_memq_b_7pp(sc, symbols, tree))); +} + +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 (is_quote(car(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)); + begin_small_symbol_set(sc); + for (s7_pointer p = syms; is_pair(p); p = cdr(p)) + add_symbol_to_small_symbol_set(sc, car(p)); + { + bool result = pair_set_memq(sc, tree); + end_small_symbol_set(sc); + return(make_boolean(sc, result)); + } +} + +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 func, 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(func); + return(sc->tree_set_memq_syms); + } + return(func); +} + + +/* ---------------- 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) + const s7_pointer obj = car(args), tree = cadr(args); + s7_pointer 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); + begin_temp(sc->x, lst); + tp = list_1(sc, car(lst)); + begin_temp(sc->temp6, 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; + } + end_temp(sc->temp6); + end_temp(sc->x); + 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) +{ + check_free_heap_size(sc, len + 1); /* using cons_unchecked below, +1 in case we are on the trigger at the end */ + begin_temp(sc->x, sc->nil); + for (s7_int i = 0; i < len; i++) sc->x = cons_unchecked(sc, init, sc->x); + return_with_end_temp(sc->x); +} + +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: break; + } + return(make_big_list(sc, len, init)); +} + +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_pointer p = lst; + for (s7_int i = 0; (i < num) && (is_pair(p)); i++, p = cdr(p)) {} + if (is_pair(p)) return(car(p)); + 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), + set_ulist_1(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 lst = lookup_checked(sc, car(sc->code)); + if (!is_pair(lst)) {sc->last_function = lst; return(false);} + sc->value = list_ref_1(sc, lst, fx_call(sc, cdr(sc->code))); + return(true); +} + +static s7_pointer fx_implicit_pair_ref_a(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer lst = lookup_checked(sc, car(arg)); + if (!is_pair(lst)) + return(s7_apply_function(sc, lst, list_1(sc, fx_call(sc, cdr(arg))))); + return(list_ref_1(sc, lst, 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)) + { + sc->temp9 = indices; /* ulist_1 below is not GC protected */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~$ becomes (apply ~$ ...), but ~$ can't take arguments", 54), + set_ulist_1(sc, obj, sc->temp9), in_obj, in_obj)); + } + return(implicit_index(sc, in_obj, cdr(indices))); +} + +static bool op_implicit_pair_ref_aa(s7_scheme *sc) +{ + s7_pointer index; + s7_pointer lst = lookup_checked(sc, car(sc->code)); + if (!is_pair(lst)) {sc->last_function = lst; return(false);} + sc->args = fx_call(sc, cddr(sc->code)); + index = fx_call(sc, cdr(sc->code)); + sc->value = implicit_pair_index_checked(sc, lst, list_ref_1(sc, lst, index), set_plist_2(sc, index, sc->args)); + return(true); +} + +static s7_pointer list_ref_chooser(s7_scheme *sc, s7_pointer func, 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(func); +} + +static inline s7_pointer list_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer lst, s7_int index) +{ + s7_pointer p = lst; + if (index < 0) + out_of_range_error_nr(sc, sc->list_ref_symbol, int_two, wrap_integer(sc, index), it_is_negative_string); + if (index > sc->max_list_length) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "list-ref index ~D is too large, (*s7* 'max-list-length) is ~D", 61), + wrap_integer(sc, index), wrap_integer(sc, sc->max_list_length))); + 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_ref_symbol, int_two, wrap_integer(sc, index), it_is_too_large_string); + wrong_type_error_nr(sc, sc->list_ref_symbol, 1, lst, a_proper_list_string); + } + return(car(p)); +} + +static s7_pointer list_ref_p_pi(s7_scheme *sc, s7_pointer lst, s7_int index) +{ + if (!is_pair(lst)) + wrong_type_error_nr(sc, sc->list_ref_symbol, 1, lst, sc->type_names[T_PAIR]); + return(list_ref_p_pi_unchecked(sc, lst, index)); +} + +static s7_pointer list_ref_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer index) +{ + if (!is_pair(lst)) + return(g_list_ref(sc, set_plist_2(sc, lst, index))); + if (!s7_is_integer(index)) + wrong_type_error_nr(sc, sc->list_ref_symbol, 1, index, sc->type_names[T_INTEGER]); + return(list_ref_p_pi_unchecked(sc, lst, s7_integer_clamped_if_gmp(sc, index))); +} + + +/* -------------------------------- list-set! -------------------------------- */ +s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, s7_int num, s7_pointer val) +{ + s7_pointer p = lst; + for (s7_int i = 0; (i < num) && (is_pair(p)); i++, p = cdr(p)) {} + if (is_pair(p)) + set_car(p, 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) /* arg_num used here so can't use list_set_index_check */ + out_of_range_error_nr(sc, sc->list_set_symbol, wrap_integer(sc, arg_num), ind, it_is_negative_string); + if (index > sc->max_list_length) /* (list-set! (list 1 2 3) (ash 1 61) 0) */ + error_nr(sc, sc->out_of_range_symbol, + set_elist_4(sc, wrap_string(sc, "list-set! ~:D argument ~D is too large, (*s7* 'max-list-length) is ~D", 69), + wrap_integer(sc, arg_num), ind, wrap_integer(sc, sc->max_list_length))); + + 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 no_return void list_set_index_check_nr(s7_scheme *sc, s7_int index) +{ + if (index < 0) + out_of_range_error_nr(sc, sc->list_set_symbol, int_two, wrap_integer(sc, index), it_is_negative_string); + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "list-set! index ~D is too large, (*s7* 'max-list-length) is ~D", 62), + wrap_integer(sc, index), wrap_integer(sc, sc->max_list_length))); +} + +static inline s7_pointer list_set_p_pip_unchecked(s7_scheme *sc, s7_pointer lst, s7_int index, s7_pointer value) +{ + s7_pointer p = lst; + if ((index < 0) || (index > sc->max_list_length)) list_set_index_check_nr(sc, index); + 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, lst, a_proper_list_string); + } + set_car(p, value); + return(value); +} + +static s7_pointer list_increment_p_pip_unchecked(opt_info *o) +{ + s7_scheme *sc = o->sc; + s7_pointer num = slot_value(o->v[2].p), lst, p, value; + s7_int index = integer(num); + if ((index < 0) || (index > sc->max_list_length)) list_set_index_check_nr(sc, index); + lst = slot_value(o->v[1].p); + p = lst; + 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, lst, a_proper_list_string); + } + value = g_add_xi(sc, car(p), integer(o->v[3].p), index); + set_car(p, value); + return(value); +} + +static s7_pointer list_set_p_pip(s7_scheme *sc, s7_pointer lst, s7_int index, s7_pointer value) /* called in t101-12|14... */ +{ + if (!is_pair(lst)) + wrong_type_error_nr(sc, sc->list_set_symbol, 1, lst, sc->type_names[T_PAIR]); + return(list_set_p_pip_unchecked(sc, lst, index, value)); +} + +static s7_pointer g_list_set_i(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer lst = car(args); + 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)) list_set_index_check_nr(sc, index); + + 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); + } + { + s7_pointer val = caddr(args); + set_car(p, val); + return(val); + } +} + +static s7_pointer list_set_chooser(s7_scheme *sc, s7_pointer func, 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(func); +} + + +/* -------------------------------- list-tail -------------------------------- */ +static s7_pointer list_tail_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer ind) +{ + s7_int i, index; + if (!s7_is_integer(ind)) + return(method_or_bust_pp(sc, ind, sc->list_tail_symbol, lst, ind, sc->type_names[T_INTEGER], 2)); + index = s7_integer_clamped_if_gmp(sc, ind); + + if (!is_list(lst)) /* (list-tail () 0) -> () */ + return(method_or_bust_pp(sc, lst, sc->list_tail_symbol, lst, ind, a_list_string, 1)); + if (index < 0) + out_of_range_error_nr(sc, sc->list_tail_symbol, int_two, wrap_integer(sc, index), it_is_negative_string); + if (index > sc->max_list_length) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "list-tail index ~D is too large, (*s7* 'max-list-length) is ~D", 62), + wrap_integer(sc, index), wrap_integer(sc, sc->max_list_length))); + + 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 p; + new_cell(sc, p, T_PAIR | T_SAFE_PROCEDURE); + set_car(p, car(args)); + set_cdr(p, cadr(args)); + return(p); +} + +static s7_pointer cons_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) +{ + s7_pointer p; + new_cell(sc, p, T_PAIR | T_SAFE_PROCEDURE); + set_car(p, p1); + set_cdr(p, p2); + return(p); +} + + +/* -------- 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 lst) +{ + if (is_pair(lst)) + return(car(lst)); + return(sole_arg_method_or_bust(sc, lst, sc->car_symbol, set_plist_1(sc, lst), 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 lst = car(args), val = cadr(args); + if (!is_mutable_pair(lst)) + return(mutable_method_or_bust(sc, lst, sc->set_car_symbol, args, sc->type_names[T_PAIR], 1)); + set_car(lst, val); + return(val); +} + +static Inline s7_pointer inline_set_car(s7_scheme *sc, s7_pointer lst, s7_pointer value) +{ + if (!is_mutable_pair(lst)) + return(mutable_method_or_bust(sc, lst, sc->set_car_symbol, set_plist_2(sc, lst, value), sc->type_names[T_PAIR], 1)); + set_car(lst, value); + return(value); +} + +static s7_pointer set_car_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer value) {return(inline_set_car(sc, lst, value));} + + +/* -------- 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 lst) +{ + if (is_pair(lst)) + return(cdr(lst)); + return(sole_arg_method_or_bust(sc, lst, sc->cdr_symbol, set_plist_1(sc, lst), 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 lst = car(args); + if (!is_mutable_pair(lst)) + return(mutable_method_or_bust(sc, lst, sc->set_cdr_symbol, args, sc->type_names[T_PAIR], 1)); + set_cdr(lst, cadr(args)); + /* (define (func) (set-cdr! ((lambda (x) (values x x)) (list-values 1)))) (func) (func) ; hung in fx_c_nc, need both func calls and list-value */ + return(cadr(args)); +} + +static Inline s7_pointer inline_set_cdr(s7_scheme *sc, s7_pointer lst, s7_pointer value) +{ + if (!is_mutable_pair(lst)) + return(mutable_method_or_bust(sc, lst, sc->set_cdr_symbol, set_plist_2(sc, lst, value), sc->type_names[T_PAIR], 1)); + set_cdr(lst, value); + return(value); +} + +static s7_pointer set_cdr_p_pp(s7_scheme *sc, s7_pointer lst, s7_pointer value) {return(inline_set_cdr(sc, lst, value));} + + +/* -------- 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 lst) +{ + if ((is_pair(lst)) && (is_pair(car(lst)))) return(caar(lst)); + if (is_pair(lst)) sole_arg_wrong_type_error_nr(sc, sc->caar_symbol, lst, car_a_list_string); + return(sole_arg_method_or_bust(sc, lst, sc->caar_symbol, set_plist_1(sc, lst), 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 lst) +{ + if ((is_pair(lst)) && (is_pair(cdr(lst)))) return(cadr(lst)); + if (is_pair(lst)) sole_arg_wrong_type_error_nr(sc, sc->cadr_symbol, lst, cdr_a_list_string); + return(sole_arg_method_or_bust(sc, lst, sc->cadr_symbol, set_plist_1(sc, lst), 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 lst) +{ + if ((is_pair(lst)) && (is_pair(car(lst)))) return(cdar(lst)); + if (!is_pair(lst)) sole_arg_wrong_type_error_nr(sc, sc->cdar_symbol, lst, car_a_list_string); + return(sole_arg_method_or_bust(sc, lst, sc->cdar_symbol, set_plist_1(sc, lst), 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 lst) +{ + if ((is_pair(lst)) && (is_pair(cdr(lst)))) return(cddr(lst)); + if (is_pair(lst)) sole_arg_wrong_type_error_nr(sc, sc->cddr_symbol, lst, cdr_a_list_string); + return(sole_arg_method_or_bust(sc, lst, sc->cddr_symbol, set_plist_1(sc, lst), 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 lst) +{ + if ((is_pair(lst)) && (is_pair(cdr(lst))) && (is_pair(cadr(lst)))) return(caadr(lst)); + if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caadr_symbol, set_plist_1(sc, lst), 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); + sole_arg_wrong_type_error_nr(sc, sc->caadr_symbol, lst, 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 lst) +{ + if ((is_pair(lst)) && (is_pair(car(lst))) && (is_pair(cdar(lst)))) return(cadar(lst)); + if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->cadar_symbol, set_plist_1(sc, lst), 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); + sole_arg_wrong_type_error_nr(sc, sc->cadar_symbol, lst, 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 lst) +{ + if ((is_pair(lst)) && (is_pair(cdr(lst))) && (is_pair(cddr(lst)))) return(caddr(lst)); + if (!is_pair(lst)) return(sole_arg_method_or_bust(sc, lst, sc->caddr_symbol, set_plist_1(sc, lst), 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); + sole_arg_wrong_type_error_nr(sc, sc->caddr_symbol, lst, 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 lst) +{ + s7_pointer slow = lst; + 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(#) = # (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(lst))) && (is_pair(car(lst)))) return(car(lst)); lst = cdr(lst); if (!is_pair(lst)) return(sc->F)); + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + return(sc->F); /* not reached */ +} + +static s7_pointer assq_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + return((is_pair(lst)) ? s7_assq(sc, obj, lst) : + ((is_null(lst)) ? sc->F : + method_or_bust_pp(sc, lst, sc->assq_symbol, obj, lst, 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 obj, s7_pointer lst) +{ + s7_pointer slow; + if (!is_pair(lst)) + { + if (is_null(lst)) return(sc->F); + return(method_or_bust_pp(sc, lst, sc->assv_symbol, obj, lst, an_association_list_string, 2)); + } + if (is_simple(obj)) + return(s7_assq(sc, obj, lst)); + + slow = lst; + 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(lst))) && (s7_is_eqv(sc, obj, caar(lst)))) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + if ((is_pair(car(lst))) && (s7_is_eqv(sc, obj, caar(lst)))) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + slow = cdr(slow); + if (slow == lst) 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 obj, s7_pointer lst) +{ + s7_pointer slow; + if (!is_pair(lst)) + return(sc->F); + slow = lst; + while (true) + { + if ((is_pair(car(lst))) && (s7_is_equal(sc, obj, caar(lst)))) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + if ((is_pair(car(lst))) && (s7_is_equal(sc, obj, caar(lst)))) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + return(sc->F); +} + +static s7_pointer assoc_1(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer slow = lst; + if (is_string(obj)) + { + while (true) + { + if (is_pair(car(lst))) + { + s7_pointer val = caar(lst); + if ((val == obj) || + ((is_string(val)) && + (scheme_strings_are_equal(obj, val)))) + return(car(lst)); + } + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + if (is_pair(car(lst))) + { + s7_pointer val = caar(lst); + if ((val == obj) || + ((is_string(val)) && + (scheme_strings_are_equal(obj, val)))) + return(car(lst)); + } + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + return(sc->F); + } + while (true) + { + if ((is_pair(car(lst))) && (s7_is_equal(sc, obj, caar(lst)))) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + if ((is_pair(car(lst))) && (s7_is_equal(sc, obj, caar(lst)))) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + slow = cdr(slow); + if (lst == slow) 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_pars(eq_func))) && + (is_pair(cdr(closure_pars(eq_func)))) && /* not dotted arg list */ + (is_null(cddr(closure_pars(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) 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 lst = cadr(args); + if (!is_null(lst)) + { + if (!is_pair(lst)) + return(method_or_bust(sc, lst, sc->assoc_symbol, args, an_association_list_string, 2)); + if (!is_pair(car(lst))) + wrong_type_error_nr(sc, sc->assoc_symbol, 2, lst, an_association_list_string); /* we're assuming caar below so it better exist */ + } + if (is_pair(cddr(args))) + { + const s7_pointer eq_func = caddr(args); + /* here we know lst 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)) + { + const s7_function func = c_function_call(eq_func); + if (func == g_is_eq) return(is_null(lst) ? sc->F : s7_assq(sc, car(args), lst)); + if (func == g_is_eqv) return(assv_p_pp(sc, car(args), lst)); + 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 = lst; is_pair(lst); lst = cdr(lst), slow = cdr(slow)) + { + if (!is_pair(car(lst))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); /* not p */ + set_car(sc->t2_2, caar(lst)); + if (is_true(sc, func(sc, sc->t2_1))) return(car(lst)); + lst = cdr(lst); + if ((!is_pair(lst)) || (lst == slow)) return(sc->F); + if (!is_pair(car(lst))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); + set_car(sc->t2_2, caar(lst)); + if (is_true(sc, func(sc, sc->t2_1))) return(car(lst)); + } + return(sc->F); + } + if (closure_has_two_normal_args(sc, eq_func)) + { + const s7_pointer body = closure_body(eq_func); + if (is_null(lst)) return(sc->F); + if (is_null(cdr(body))) + { + s7_pfunc func; + set_curlet(sc, make_let_with_two_slots(sc, sc->curlet, car(closure_pars(eq_func)), car(args), cadr(closure_pars(eq_func)), sc->F)); + func = s7_bool_optimize(sc, body); + if (func) + { + s7_pointer slowp = lst; + opt_info *o = sc->opts[0]; + s7_pointer slot = next_slot(let_slots(sc->curlet)); + while (true) + { + if (!is_pair(car(lst))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); + slot_set_value(slot, caar(lst)); + if (o->v[0].fb(o)) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + if (!is_pair(car(lst))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, cadr(args), an_association_list_string); + slot_set_value(slot, caar(lst)); + if (o->v[0].fb(o)) return(car(lst)); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + slowp = cdr(slowp); + if (lst == slowp) 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(lst)) return(sc->F); + if ((is_any_macro(eq_func)) && (!is_c_macro(eq_func))) + clear_all_optimizations(sc, closure_body(eq_func)); + { + s7_pointer func_args = list_1(sc, copy_proper_list(sc, args)); + set_opt1_fast(func_args, lst); + set_opt2_slow(func_args, lst); + push_stack(sc, OP_ASSOC_IF, list_1_unchecked(sc, func_args), eq_func); + } + if (needs_copied_args(eq_func)) + push_stack(sc, OP_APPLY, list_2_unchecked(sc, car(args), caar(lst)), eq_func); + else + { + set_car(sc->t2_1, car(args)); + set_car(sc->t2_2, caar(lst)); + push_stack(sc, OP_APPLY, sc->t2_1, eq_func); + } + return(sc->unspecified); + } + if (is_null(lst)) return(sc->F); + { + s7_pointer obj = car(args); + if (is_simple(obj)) + return(s7_assq(sc, obj, lst)); + return(assoc_1(sc, obj, lst)); + } +} + +static s7_pointer assoc_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer p) +{ + if (!is_pair(p)) + { + if (is_null(p)) return(sc->F); + return(method_or_bust(sc, p, sc->assoc_symbol, set_plist_2(sc, obj, p), an_association_list_string, 2)); + } + if (!is_pair(car(p))) wrong_type_error_nr(sc, sc->assoc_symbol, 2, p, an_association_list_string); + if (is_simple(obj)) return(s7_assq(sc, obj, p)); + return(assoc_1(sc, obj, p)); +} + +static bool op_assoc_if(s7_scheme *sc) +{ + const 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 func, 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(func); +} + + +/* ---------------- member, memv, memq ---------------- */ +s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer slow = lst; + while (true) + { + LOOP_4(if (obj == car(lst)) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F)); + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + return(sc->F); +} + +static s7_pointer memq_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + return((is_pair(lst)) ? s7_memq(sc, obj, lst) : + ((is_null(lst)) ? sc->F : method_or_bust_pp(sc, lst, sc->memq_symbol, obj, lst, 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 + + const s7_pointer obj = car(args), lst = cadr(args); + if (is_pair(lst)) + return(s7_memq(sc, obj, lst)); + if (is_null(lst)) + return(sc->F); + return(method_or_bust_pp(sc, lst, sc->memq_symbol, obj, lst, 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) +{ + const s7_pointer obj = car(args), lst = cadr(args); + if (obj == car(lst)) return(lst); + return((obj == cadr(lst)) ? cdr(lst) : sc->F); +} + +static s7_pointer memq_2_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + if (obj == car(lst)) return(lst); + return((obj == cadr(lst)) ? cdr(lst) : sc->F); +} + +static s7_pointer memq_3_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + if (obj == car(lst)) return(lst); + if (obj == cadr(lst)) return(cdr(lst)); + return((obj == caddr(lst)) ? cddr(lst) : sc->F); +} + +static s7_pointer g_memq_3(s7_scheme *sc, s7_pointer args) +{ + s7_pointer lst = cadr(args); + const s7_pointer obj = car(args); + while (true) + { + if (obj == car(lst)) return(lst); /* grandma gcc doesn't want me to include the next line here. */ + lst = cdr(lst); + if (obj == car(lst)) return(lst); + lst = cdr(lst); + if (obj == car(lst)) return(lst); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + } + return(sc->F); +} + +static s7_pointer memq_4_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + while (true) + { + LOOP_4(if (obj == car(lst)) return(lst); lst = cdr(lst)); + if (!is_pair(lst)) 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 */ + const s7_pointer obj = car(args); + s7_pointer lst = cadr(args); + while (true) + { + LOOP_4(if (obj == car(lst)) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F)); + } + return(sc->F); +} + +static s7_pointer memq_chooser(s7_scheme *sc, s7_pointer func, 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(func); +} + +static bool numbers_are_eqv(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ +#if WITH_GMP + if ((is_big_number(x)) || (is_big_number(y))) + return(big_numbers_are_eqv(sc, x, y)); + if (type(x) != type(y)) return(false); +#endif + /* if (type(x) != type(y)) 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(x)) return(integer(x) == integer(y)); + if (is_t_real(x)) return(real(x) == real(y)); /* NaNs are not equal to anything including themselves */ + if (is_t_ratio(x)) return((numerator(x) == numerator(y)) && (denominator(x) == denominator(y))); + if (!is_t_complex(x)) return(false); + return((real_part(x) == real_part(y)) && (imag_part(x) == imag_part(y))); +} + +static s7_pointer memv_number(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer slow = lst; +#if !WITH_GMP + uint8_t obj_type = type(obj); +#endif + while (true) + { +#if WITH_GMP + LOOP_4(if ((is_number(car(lst))) && (numbers_are_eqv(sc, obj, car(lst)))) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F)); +#else + LOOP_4(if ((type(car(lst)) == obj_type) && (numbers_are_eqv(sc, obj, car(lst)))) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F)); +#endif + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + return(sc->F); +} + +static s7_pointer memv_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer p; + if (!is_pair(lst)) + { + if (is_null(lst)) return(sc->F); + return(method_or_bust_pp(sc, lst, sc->memv_symbol, obj, lst, a_list_string, 2)); + } + if (is_simple(obj)) return(s7_memq(sc, obj, lst)); + if (is_number(obj)) return(memv_number(sc, obj, lst)); + + p = lst; + while (true) + { + if (s7_is_eqv(sc, obj, car(lst))) return(lst); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + if (s7_is_eqv(sc, obj, car(lst))) return(lst); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + p = cdr(p); + if (p == lst) 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 obj, s7_pointer lst) +{ + for (s7_pointer p = lst; is_pair(p); p = cdr(p)) + if (s7_is_equal(sc, obj, car(p))) + return(p); + return(sc->F); +} + +static s7_pointer member(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer slow = lst; + if (is_string(obj)) + while (true) + { + if ((obj == car(lst)) || + ((is_string(car(lst))) && + (scheme_strings_are_equal(obj, car(lst))))) + return(lst); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + + if ((obj == car(lst)) || + ((is_string(car(lst))) && + (scheme_strings_are_equal(obj, car(lst))))) + return(lst); + lst = cdr(lst); + if (!is_pair(lst)) return(sc->F); + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + else + while (true) + { + LOOP_4(if (s7_is_equal(sc, obj, car(lst))) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F)); + slow = cdr(slow); + if (lst == slow) 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) 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 lst = cadr(args); + if ((!is_pair(lst)) && (!is_null(lst))) + return(method_or_bust(sc, lst, sc->member_symbol, args, a_list_string, 2)); + + if (is_pair(cddr(args))) + { + const s7_pointer eq_func = caddr(args); + s7_pointer y; + if (is_safe_c_function(eq_func)) + { + s7_function func = c_function_call(eq_func); + if (func == g_is_eq) return(is_null(lst) ? sc->F : s7_memq(sc, car(args), lst)); + 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 = lst; is_pair(lst); lst = cdr(lst), slow = cdr(slow)) + { + set_car(sc->t2_2, car(lst)); + if (is_true(sc, func(sc, sc->t2_1))) return(lst); + if (!is_pair(cdr(lst))) return(sc->F); + lst = cdr(lst); + if (lst == slow) return(sc->F); + set_car(sc->t2_2, car(lst)); + if (is_true(sc, func(sc, sc->t2_1))) return(lst); + } + return(sc->F); + } + if (closure_has_two_normal_args(sc, eq_func)) + { + const s7_pointer body = closure_body(eq_func); + if (is_null(lst)) 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_pars(eq_func)), car(args), cadr(closure_pars(eq_func)), sc->F)); + func = s7_bool_optimize(sc, body); + if (func) + { + opt_info *o = sc->opts[0]; + s7_pointer slot = 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 = lst; is_pair(lst); lst = cdr(lst), slow = cdr(slow)) + { + slot_set_value(slot, car(lst)); + if (fp(o) != sc->F) return(lst); + if (!is_pair(cdr(lst))) return(sc->F); + lst = cdr(lst); + if (lst == slow) return(sc->F); + slot_set_value(slot, car(lst)); + if (fp(o) != sc->F) return(lst); + }} + else + for (s7_pointer slow = lst; is_pair(lst); lst = cdr(lst), slow = cdr(slow)) + { + slot_set_value(slot, car(lst)); + if (o->v[0].fb(o)) return(lst); + if (!is_pair(cdr(lst))) return(sc->F); + lst = cdr(lst); + if (lst == slow) return(sc->F); + slot_set_value(slot, car(lst)); + if (o->v[0].fb(o)) return(lst); + } + 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(lst)) 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, sc->temp9 = copy_proper_list(sc, args)); /* this could probably be handled with a counter cell (cdr here is unused) */ + sc->temp9 = y; + set_opt1_fast(y, lst); + set_opt2_slow(y, lst); + begin_temp(sc->x, y); + push_stack(sc, OP_MEMBER_IF, list_1(sc, y), eq_func); + end_temp(sc->x); + sc->temp9 = sc->unused; + if (needs_copied_args(eq_func)) + push_stack(sc, OP_APPLY, list_2_unchecked(sc, car(args), car(lst)), eq_func); + else + { + set_car(sc->t2_1, car(args)); + set_car(sc->t2_2, car(lst)); + push_stack(sc, OP_APPLY, sc->t2_1, eq_func); + } + return(sc->unspecified); + } + if (is_null(lst)) return(sc->F); + { + s7_pointer obj = car(args); + if (is_simple(obj)) + return(s7_memq(sc, obj, lst)); + /* 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, lst)); + return(member(sc, obj, lst)); + } +} + +static s7_pointer member_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + if (is_null(lst)) return(sc->F); + if (!is_pair(lst)) return(method_or_bust(sc, lst, sc->member_symbol, set_plist_2(sc, obj, lst), a_list_string, 2)); + if (is_simple(obj)) return(s7_memq(sc, obj, lst)); + if (is_number(obj)) return(memv_number(sc, obj, lst)); + return(member(sc, obj, lst)); +} + +static s7_pointer member_chooser(s7_scheme *sc, s7_pointer func, 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(func); +} + +static bool op_member_if(s7_scheme *sc) +{ + const 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 func, 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 : func); +} + +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); + begin_temp(sc->v, p = make_list(sc, num_values, sc->unused)); + 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->v); + return_with_end_temp(sc->v); +} + +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); + begin_temp(sc->v, make_list(sc, num_values, sc->unused)); + va_start(ap, num_values); + for (s7_pointer q = sc->v; 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->v); /* 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->v); + + if (sc->safety > no_safety) + check_list_validity(sc, __func__, sc->v); + return_with_end_temp(sc->v); +} + +static s7_pointer safe_list_1(s7_scheme *sc) +{ + if (!safe_list_is_in_use(sc->safe_lists[1])) + { + sc->current_safe_list = 1; + set_safe_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 (!safe_list_is_in_use(sc->safe_lists[2])) + { + sc->current_safe_list = 2; + set_safe_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) + { + if (!is_pair(sc->safe_lists[num_args])) + sc->safe_lists[num_args] = semipermanent_list(sc, num_args); + if (!safe_list_is_in_use(sc->safe_lists[num_args])) + { + sc->current_safe_list = num_args; + set_safe_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) + { + if (safe_list_is_in_use(sc->safe_lists[num_args])) + return(make_list(sc, num_args, sc->nil)); + + sc->current_safe_list = num_args; + set_safe_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 arglist = args; is_pair(arglist); arglist = cdr(arglist)) /* not dotted */ + { + const s7_pointer p = car(arglist); + s7_pointer 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)) ? arglist : set_ulist_1(sc, tp, arglist))); + } + if (is_null(cdr(arglist))) + { + if (is_null(tp)) + { + /* Guile: (append '() 1): 1, r7rs claims an improper list is the result, yet its own examples contradict that */ + 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(arglist, 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(arglist, 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 + { + const 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(arglist, 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_complex_vector(s7_pointer p) {return(is_complex_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 vec) +{ + s7_pointer typer = typed_vector_typer(vec); + 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 vec) +{ + s7_pointer typer = typed_vector_typer(vec); + return((is_c_function(typer)) ? c_function_name(typer) : symbol_name(typed_vector_typer_symbol(sc, vec))); +} + +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 no_return 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) && /* only use of safety == -1 */ + (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 complex_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(c_complex_to_s7(sc, complex_vector(vec, loc)));} +static s7_pointer byte_vector_getter(s7_scheme *sc, s7_pointer vec, s7_int loc) {return(small_int(byte_vector(vec, 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 complex_vector_setter(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val) +{ + complex_vector(vec, loc) = s7_to_c_complex(val); + return(val); +} + +static s7_pointer byte_vector_setter(s7_scheme *sc, s7_pointer vec, 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(vec, loc) = (uint8_t)byte; + return(val); +} + +static block_t *mallocate_empty_block(s7_scheme *sc) +{ + block_t *b = mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + 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 vect; + block_t *b = mallocate_vector(sc, len * sizeof(s7_pointer)); + new_cell(sc, vect, T_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = b; + vector_elements(vect) = (s7_pointer *)block_data(b); + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = t_vector_getter; + vector_setter(vect) = t_vector_setter; + add_vector(sc, vect); + return(vect); +} + +static inline s7_pointer make_simple_float_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ +{ + s7_pointer vect; + block_t *b = mallocate_vector(sc, len * sizeof(s7_double)); + new_cell(sc, vect, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = b; + float_vector_floats(vect) = (s7_double *)block_data(b); + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = float_vector_getter; + vector_setter(vect) = float_vector_setter; + add_vector(sc, vect); + return(vect); +} + +static inline s7_pointer make_simple_complex_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ +{ + s7_pointer vect; + block_t *b = mallocate_vector(sc, len * sizeof(s7_complex)); + new_cell(sc, vect, T_COMPLEX_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = b; + complex_vector_complexes(vect) = (s7_complex *)block_data(b); + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = complex_vector_getter; + vector_setter(vect) = complex_vector_setter; + add_vector(sc, vect); + return(vect); +} + +static inline s7_pointer make_simple_int_vector(s7_scheme *sc, s7_int len) /* len >= 0 and < max */ +{ + s7_pointer vect; + block_t *b = mallocate_vector(sc, len * sizeof(s7_int)); + new_cell(sc, vect, T_INT_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = b; + int_vector_ints(vect) = (s7_int *)block_data(b); + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = int_vector_getter; + vector_setter(vect) = int_vector_setter; + add_vector(sc, vect); + return(vect); +} + +static s7_pointer make_simple_byte_vector(s7_scheme *sc, s7_int len) +{ + s7_pointer vect; + block_t *b = mallocate_vector(sc, len); /* not inline_mallocate because we need to set block_data to NULL if len==0 */ + new_cell(sc, vect, T_BYTE_VECTOR | T_SAFE_PROCEDURE); + vector_block(vect) = b; + byte_vector_bytes(vect) = (uint8_t *)block_data(b); + vector_length(vect) = len; + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = byte_vector_getter; + vector_setter(vect) = byte_vector_setter; + add_vector(sc, vect); + return(vect); +} + +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 vect; + + 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, vect, typ | T_SAFE_PROCEDURE); + vector_length(vect) = len; + if (len == 0) + { + vector_block(vect) = mallocate_empty_block(sc); + any_vector_elements(vect) = NULL; + if (typ == T_VECTOR) set_has_simple_elements(vect); + } + else + if (typ == T_VECTOR) + { + block_t *b = inline_mallocate(sc, len * sizeof(s7_pointer)); + vector_block(vect) = b; + vector_elements(vect) = (s7_pointer *)block_data(b); + vector_getter(vect) = t_vector_getter; + vector_setter(vect) = t_vector_setter; + if (filled) t_vector_fill(vect, sc->nil); + } + else + if (typ == T_FLOAT_VECTOR) + { + block_t *b = inline_mallocate(sc, len * sizeof(s7_double)); + vector_block(vect) = b; + float_vector_floats(vect) = (s7_double *)block_data(b); + if (filled) + { + if (STEP_8(len)) + memclr64((void *)float_vector_floats(vect), len * sizeof(s7_double)); + else memclr((void *)float_vector_floats(vect), len * sizeof(s7_double)); + } + vector_getter(vect) = float_vector_getter; + vector_setter(vect) = float_vector_setter; + } + else + if (typ == T_INT_VECTOR) + { + block_t *b = inline_mallocate(sc, len * sizeof(s7_int)); + vector_block(vect) = b; + int_vector_ints(vect) = (s7_int *)block_data(b); + if (filled) + { + if (STEP_8(len)) + memclr64((void *)int_vector_ints(vect), len * sizeof(s7_int)); + else memclr((void *)int_vector_ints(vect), len * sizeof(s7_int)); + } + vector_getter(vect) = int_vector_getter; + vector_setter(vect) = int_vector_setter; + } + else + if (typ == T_COMPLEX_VECTOR) + { + block_t *b = inline_mallocate(sc, len * sizeof(s7_complex)); + vector_block(vect) = b; + complex_vector_complexes(vect) = (s7_complex *)block_data(b); + if (filled) + { + if (STEP_8(len)) + memclr64((void *)complex_vector_complexes(vect), len * sizeof(s7_complex)); + else memclr((void *)complex_vector_complexes(vect), len * sizeof(s7_complex)); + } + vector_getter(vect) = complex_vector_getter; + vector_setter(vect) = complex_vector_setter; + } + else /* byte-vector */ + { + block_t *b = mallocate(sc, len); + vector_block(vect) = b; + byte_vector_bytes(vect) = (uint8_t *)block_data(b); + vector_getter(vect) = byte_vector_getter; + vector_setter(vect) = byte_vector_setter; + if (filled) + { + if (STEP_64(len)) + memclr64((void *)(byte_vector_bytes(vect)), len); + else memclr((void *)(byte_vector_bytes(vect)), len); + }} + vector_set_dimension_info(vect, NULL); + return(vect); +} + +#define FILLED true +#define NOT_FILLED false + +s7_pointer s7_make_vector(s7_scheme *sc, s7_int len) +{ + s7_pointer vec = make_vector_1(sc, len, FILLED, T_VECTOR); + add_vector(sc, vec); + return(vec); +} + +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); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + 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); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + 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 vect = make_vector_1(sc, len, FILLED, type); + if (dim_info) + { + vector_set_dimension_info(vect, make_vdims(sc, false, dims, dim_info)); + add_multivector(sc, vect); + } + else add_vector(sc, vect); + return(vect); +} + +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_complex_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info) {return(make_any_vector(sc, T_COMPLEX_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_int_vector_wrapper(s7_scheme *sc, s7_int len, s7_int *data, s7_int dims, s7_int *dim_info, bool free_data) +{ + /* this wraps up a C-allocated/freed int64_t array as an s7 int-vector */ + s7_pointer vect; + block_t *b = mallocate_empty_block(sc); + new_cell(sc, vect, T_INT_VECTOR | T_SAFE_PROCEDURE); + vector_block(vect) = b; + int_vector_ints(vect) = data; + vector_getter(vect) = int_vector_getter; + vector_setter(vect) = int_vector_setter; + vector_length(vect) = len; + if (!dim_info) + { + s7_int di[1]; + di[0] = len; + vector_set_dimension_info(vect, make_vdims(sc, free_data, 1, di)); + } + else vector_set_dimension_info(vect, make_vdims(sc, free_data, dims, dim_info)); + add_multivector(sc, vect); + return(vect); +} + +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 float-vector */ + s7_pointer vect; + block_t *b = mallocate_empty_block(sc); + new_cell(sc, vect, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); + vector_block(vect) = b; + float_vector_floats(vect) = data; + vector_getter(vect) = float_vector_getter; + vector_setter(vect) = float_vector_setter; + vector_length(vect) = len; + if (!dim_info) + { + s7_int di[1]; + di[0] = len; + vector_set_dimension_info(vect, make_vdims(sc, free_data, 1, di)); + } + else vector_set_dimension_info(vect, make_vdims(sc, free_data, dims, dim_info)); + add_multivector(sc, vect); + return(vect); +} + +s7_pointer s7_make_complex_vector_wrapper(s7_scheme *sc, s7_int len, s7_complex *data, s7_int dims, s7_int *dim_info, bool free_data) +{ + /* this wraps up a C-allocated/freed complex array as an s7 complex-vector */ + s7_pointer vect; + block_t *b = mallocate_empty_block(sc); + new_cell(sc, vect, T_COMPLEX_VECTOR | T_SAFE_PROCEDURE); + vector_block(vect) = b; + complex_vector_complexes(vect) = data; + vector_getter(vect) = complex_vector_getter; + vector_setter(vect) = complex_vector_setter; + vector_length(vect) = len; + if (!dim_info) + { + s7_int di[1]; + di[0] = len; + vector_set_dimension_info(vect, make_vdims(sc, free_data, 1, di)); + } + else vector_set_dimension_info(vect, make_vdims(sc, free_data, dims, dim_info)); + add_multivector(sc, vect); + return(vect); +} + + +/* -------------------------------- vector-fill! -------------------------------- */ +static Vectorized void float_vector_fill(s7_pointer vec, s7_double x) +{ + const 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) +{ + const 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) +{ + const 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); +} + +static void complex_vector_fill(s7_pointer vec, s7_complex x) +{ + const s7_int len = vector_length(vec); + if (len == 0) return; + if (x == 0.0) + { + if (STEP_8(len)) + memclr64((void *)complex_vector_complexes(vec), len * sizeof(s7_complex)); + else memclr((void *)complex_vector_complexes(vec), len * sizeof(s7_complex)); + } + else + { + s7_int i = 0, left = len - 8; + s7_complex *orig = complex_vector_complexes(vec); + while (i <= left) + LOOP_8(orig[i++] = x); + for (; i < len; i++) + orig[i] = x; + } +} + +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_COMPLEX_VECTOR: + if (!is_number(obj)) + wrong_type_error_nr(sc, wrap_string(sc, "complex-vector fill!", 20), 2, obj, sc->type_names[T_COMPLEX]); + complex_vector_fill(vec, s7_to_c_complex(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) +{ + const s7_pointer vect = car(args); + s7_pointer fill; + s7_int start = 0, end; + + if (!is_any_vector(vect)) + { + if_method_exists_return_value(sc, vect, 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, vect, sc->type_names[T_VECTOR]); + } + if (is_immutable_vector(vect)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, caller, vect)); + + fill = cadr(args); + if ((is_typed_t_vector(vect)) && + (typed_vector_typer_call(sc, vect, set_plist_1(sc, fill)) == sc->F)) + { + const char *tstr = make_type_name(sc, typed_vector_typer_name(sc, vect), 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(vect)) + { + 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(vect)) || (is_byte_vector(vect))) + { + if (!s7_is_integer(fill)) + return(method_or_bust(sc, fill, caller, args, sc->type_names[T_INTEGER], 2)); + if ((is_byte_vector(vect)) && + ((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)); + } + else + if (is_complex_vector(vect)) + { + if (!is_number(fill)) /* possibly a bignum */ + return(method_or_bust(sc, fill, caller, args, sc->type_names[T_COMPLEX], 2)); + } + end = vector_length(vect); + 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(vect))) + s7_vector_fill(sc, vect, fill); + else + if (is_t_vector(vect)) + for (s7_int i = start; i < end; i++) vector_element(vect, i) = fill; + else + if (is_int_vector(vect)) + { + s7_int k = s7_integer_clamped_if_gmp(sc, fill); + if (k == 0) + memclr((void *)(int_vector_ints(vect) + start), (end - start) * sizeof(s7_int)); + else for (s7_int i = start; i < end; i++) int_vector(vect, i) = k; + } + else + if (is_float_vector(vect)) + { + const s7_double y = s7_real(fill); + if (y == 0.0) + memclr((void *)(float_vector_floats(vect) + start), (end - start) * sizeof(s7_double)); + else + { + s7_double *orig = float_vector_floats(vect); + 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(vect)) + { + const uint8_t k = (uint8_t)s7_integer_clamped_if_gmp(sc, fill); + if (k == 0) + memclr((void *)(byte_vector_bytes(vect) + start), end - start); + else local_memset((void *)(byte_vector_bytes(vect) + start), k, end - start); /* unaligned */ + } + else + if (is_complex_vector(vect)) + { + s7_complex cfill = s7_to_c_complex(fill); + for (s7_int i = start; i < end; i++) complex_vector(vect, i) = cfill; + } + 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++) + { + const s7_pointer vect = car(p); + if (!is_any_vector(vect)) + { + if (has_active_methods(sc, vect)) + { + const s7_pointer func = find_method_with_let(sc, vect, sc->vector_append_symbol); + if (func != sc->undefined) + { + int32_t k; + s7_pointer lst, vec, new_vec, arglist; + if (i == 0) + return(s7_apply_function(sc, func, args)); + sc->temp7 = make_list(sc, i, sc->unused); /* we have to copy the arglist here */ + for (k = 0, arglist = args, lst = sc->temp7; k < i; k++, arglist = cdr(arglist), lst = cdr(lst)) + set_car(lst, car(arglist)); + vec = g_vector_append(sc, sc->temp7); + new_vec = s7_apply_function(sc, func, set_ulist_1(sc, vec, p)); + if ((S7_DEBUGGING) && (!is_pair(sc->temp7))) fprintf(stderr, "%s[%d]: temp7: %s\n", __func__, __LINE__, display(sc->temp7)); + sc->temp7 = sc->unused; + return(new_vec); + }} + wrong_type_error_nr(sc, sc->vector_append_symbol, i + 1, vect, 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 v1, s7_pointer v2) +{ + s7_pointer val; + sc->temp7 = list_2(sc, v1, v2); /* ideally this list would be gc_protected, avoiding temp7 (method call above) */ + val = g_vector_append(sc, sc->temp7); + if ((S7_DEBUGGING) && (!is_pair(sc->temp7))) fprintf(stderr, "%s[%d]: temp7: %s\n", __func__, __LINE__, display(sc->temp7)); + sc->temp7 = sc->unused; + return(val); +} + +static s7_pointer vector_append_p_ppp(s7_scheme *sc, s7_pointer v1, s7_pointer v2, s7_pointer v3) +{ + s7_pointer val; + sc->temp7 = list_3(sc, v1, v2, v3); + val = g_vector_append(sc, sc->temp7); + if ((S7_DEBUGGING) && (!is_pair(sc->temp7))) fprintf(stderr, "%s[%d]: temp7: %s\n", __func__, __LINE__, display(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 value) +{ + 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, value)); + vector_setter(vec)(sc, vec, index, T_Ext(value)); + return(value); +} + +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_complex *s7_complex_vector_elements(s7_pointer vec) {return(complex_vector_complexes(vec));} +s7_complex s7_complex_vector_ref(s7_pointer vec, s7_int index) {return(complex_vector(vec, index));} +s7_complex s7_complex_vector_set(s7_pointer vec, s7_int index, s7_complex value) {complex_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; + const s7_int 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) +{ + const s7_int len = vector_length(vect); + if (len == 0) return(sc->nil); + if (len > sc->max_list_length) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "vector->list length, ~D, is greater than (*s7* 'max-list-length), ~D", 68), + wrap_integer(sc, len), wrap_integer(sc, sc->max_list_length))); + begin_temp(sc->y, sc->nil); + gc_protect_via_stack(sc, vect); + check_free_heap_size(sc, 2 * len); + switch (type(vect)) + { + case T_VECTOR: + 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: + 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: + 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: + 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; + case T_COMPLEX_VECTOR: + for (s7_int i = len - 1; i >= 0; i--) + { + s7_complex z = complex_vector(vect, i); + sc->y = cons_unchecked(sc, make_complex_unchecked(sc, creal(z), cimag(z)), sc->y); + } + break; + } + unstack_gc_protect(sc); + return_with_end_temp(sc->y); +} + +s7_pointer s7_array_to_list(s7_scheme *sc, s7_int num_values, s7_pointer *array) +{ + if (num_values == 0) return(sc->nil); + begin_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); + if (sc->safety > no_safety) + check_list_validity(sc, __func__, sc->y); + return_with_end_temp(sc->y); +} + +#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 start = 0, end; + const s7_pointer 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))) + { + s7_pointer 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); + begin_temp(sc->temp6, sc->nil); + gc_protect_via_stack(sc, vec); + if (is_t_vector(vec)) + for (s7_int i = end - 1; i >= start; i--) sc->temp6 = cons_unchecked(sc, vector_element(vec, i), sc->temp6); + else for (s7_int i = end - 1; i >= start; i--) sc->temp6 = cons_unchecked(sc, vector_getter(vec)(sc, vec, i), sc->temp6); + unstack_gc_protect(sc); + return_with_end_temp(sc->temp6); +} + +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 bv = car(args); + if (!is_byte_vector(bv)) + return(method_or_bust_p(sc, bv, sc->byte_vector_to_string_symbol, sc->type_names[T_BYTE_VECTOR])); + if (byte_vector_length(bv) > 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(bv)), wrap_integer(sc, sc->max_string_length))); + return(s7_copy_1(sc, sc->byte_vector_to_string_symbol, set_plist_2(sc, bv, make_empty_string(sc, byte_vector_length(bv), '\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, end; + 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, "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) + for (s7_int i = 0; is_pair(args); args = cdr(args), i++) + vector_element(vec, i) = car(args); + 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 func, int32_t args, s7_pointer unused_expr) +{ + if (args == 2) return(sc->vector_2); + return((args == 3) ? sc->vector_3 : func); +} + + +/* -------------------------------- 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, bad_end = sc->nil; + const s7_int len = proper_list_length_with_end(args, &bad_end); + if (!is_null(bad_end)) + 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 nums = args; is_pair(nums); nums = cdr(nums), i++) + { + s7_pointer num = car(nums); + if (is_t_real(num)) + float_vector(vec, i) = real(num); + else + if (is_real(num)) /* bignum is ok here */ + float_vector(vec, i) = s7_real(num); + else return(method_or_bust(sc, num, 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, bad_end = sc->nil; + const s7_int len = proper_list_length_with_end(args, &bad_end); + if (!is_null(bad_end)) + 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 arglist = args; is_pair(arglist); arglist = cdr(arglist), i++) + { + s7_pointer num = car(arglist); + if (!s7_is_integer(num)) + return(method_or_bust(sc, num, sc->int_vector_symbol, args, sc->type_names[T_INTEGER], i + 1)); + int_vector(vec, i) = s7_integer_clamped_if_gmp(sc, num); + } + 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, bad_end = sc->nil; + uint8_t *str; + const s7_int len = proper_list_length_with_end(args, &bad_end); + if (!is_null(bad_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 arglist = args; is_pair(arglist); i++, arglist = cdr(arglist)) + { + s7_pointer byte = car(arglist); + 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); +} + +/* -------------------------------- complex-vector? -------------------------------- */ +static s7_pointer g_is_complex_vector(s7_scheme *sc, s7_pointer args) +{ + #define H_is_complex_vector "(complex-vector? obj) returns #t if obj is an homogeneous complex vector" + #define Q_is_complex_vector sc->pl_bt + check_boolean_method(sc, s7_is_complex_vector, sc->is_complex_vector_symbol, args); +} + + +/* -------------------------------- complex-vector -------------------------------- */ +static s7_pointer g_complex_vector(s7_scheme *sc, s7_pointer args) +{ + #define H_complex_vector "(complex-vector ...) returns an homogeneous complex vector whose elements are the arguments" + #define Q_complex_vector s7_make_circular_signature(sc, 1, 2, sc->is_complex_vector_symbol, sc->is_complex_symbol) + + s7_pointer vec, bad_end = sc->nil; + const s7_int len = proper_list_length_with_end(args, &bad_end); + if (!is_null(bad_end)) + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "complex-vector contents list is not a proper list", 49))); + if (len > sc->max_vector_length) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "complex-vector has too many arguments: '~S, but (*s7* 'max-vector-length) is ~D", 79), + args, wrap_integer(sc, sc->max_vector_length))); + vec = make_simple_complex_vector(sc, len); + if (len > 0) + { + s7_int i = 0; + for (s7_pointer arglist = args; is_pair(arglist); arglist = cdr(arglist), i++) + { + s7_pointer num = car(arglist); + if (is_number(num)) + complex_vector(vec, i) = s7_to_c_complex(num); + else return(method_or_bust(sc, num, sc->complex_vector_symbol, args, sc->type_names[T_COMPLEX], i + 1)); + }} + 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 lst = car(args); + if (is_null(lst)) + return(make_simple_vector(sc, 0)); /* was s7_make_vector */ + sc->temp3 = lst; + if (!s7_is_proper_list(sc, lst)) + return(method_or_bust_p(sc, lst, sc->list_to_vector_symbol, a_proper_list_string)); + { + s7_pointer result = g_vector(sc, lst); + sc->temp3 = sc->unused; + return(result); + } +} + +/* -------------------------------- 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 vec) +{ + if (!is_any_vector(vec)) + return(integer(method_or_bust_p(sc, vec, sc->vector_length_symbol, sc->type_names[T_VECTOR]))); + return(vector_length(vec)); +} + +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 vec) {return((is_any_vector(vec)) && (is_subvector(vec)));} + +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) + + const s7_pointer sv = car(args); + if (s7_is_subvector(sv)) + 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_COMPLEX_VECTOR: return(make_integer(sc, (s7_int)(complex_vector_complexes(sv) - complex_vector_complexes(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) +{ + const s7_int dims = vector_ndims(vect) - skip_dims; + s7_pointer subvect; + new_cell(sc, subvect, ((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(subvect) = 0; + vector_block(subvect) = mallocate_empty_block(sc); + any_vector_elements(subvect) = NULL; + vector_getter(subvect) = vector_getter(vect); + vector_setter(subvect) = vector_setter(vect); + if (dims > 1) + { + vdims_t *v = (vdims_t *)mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + 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(subvect, v); + } + else + { + vector_set_dimension_info(subvect, NULL); + subvector_set_vector(subvect, 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(subvect) = (skip_dims > 0) ? vector_offset(vect, skip_dims - 1) : vector_length(vect); + if (is_int_vector(vect)) + int_vector_ints(subvect) = (s7_int *)(int_vector_ints(vect) + index); + else + if (is_float_vector(vect)) + float_vector_floats(subvect) = (s7_double *)(float_vector_floats(vect) + index); + else + if (is_t_vector(vect)) + vector_elements(subvect) = (s7_pointer *)(vector_elements(vect) + index); + else + if (is_byte_vector(subvect)) + byte_vector_bytes(subvect) = (uint8_t *)(byte_vector_bytes(vect) + index); + else complex_vector_complexes(subvect) = (s7_complex *)(complex_vector_complexes(vect) + index); + add_multivector(sc, subvect); + return(subvect); +} + +static inline vdims_t *list_to_vdims(s7_scheme *sc, s7_pointer lst) +{ + s7_int *ds, *os; + const s7_int len = proper_list_length(lst); + 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 (s7_int i = 0; is_pair(lst); i++, lst = cdr(lst)) + ds[i] = s7_integer_clamped_if_gmp(sc, car(lst)); + for (s7_int 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)) + */ + const s7_pointer orig = car(args); + s7_pointer subvect; + 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 */ + { + const 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 */ + { + const 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 */ + { + const 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 dim_list = dims; is_pair(dim_list); dim_list = cdr(dim_list)) + if ((!s7_is_integer(car(dim_list))) || /* (subvector v '((1 2) (3 4))) */ + (s7_integer_clamped_if_gmp(sc, car(dim_list)) > orig_len) || + (s7_integer_clamped_if_gmp(sc, car(dim_list)) < 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_vdims(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, subvect, ((full_type(orig) & (~T_UNHEAP)) & (~T_COLLECTED)) | T_SUBVECTOR | T_SAFE_PROCEDURE); + vector_block(subvect) = mallocate_empty_block(sc); + vector_set_dimension_info(subvect, v); + if (!v) subvector_set_vector(subvect, orig); + vector_length(subvect) = new_len; /* might be less than original length */ + if ((new_len == 0) && (is_t_vector(orig))) set_has_simple_elements(subvect); + vector_getter(subvect) = vector_getter(orig); + vector_setter(subvect) = vector_setter(orig); + + if (is_int_vector(orig)) + int_vector_ints(subvect) = (s7_int *)(int_vector_ints(orig) + offset); + else + if (is_float_vector(orig)) + float_vector_floats(subvect) = (s7_double *)(float_vector_floats(orig) + offset); + else + if (is_t_vector(orig)) + vector_elements(subvect) = (s7_pointer *)(vector_elements(orig) + offset); + else + if (is_byte_vector(orig)) + byte_vector_bytes(subvect) = (uint8_t *)(byte_vector_bytes(orig) + offset); + else complex_vector_complexes(subvect) = (s7_complex *)(complex_vector_complexes(orig) + offset); + add_multivector(sc, subvect); + return(subvect); +} + + +/* -------------------------------- 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 index_list; + for (index_list = indices, i = 0; (is_pair(index_list)) && (i < vector_ndims(vect)); index_list = cdr(index_list), i++) + { + s7_int n; + const s7_pointer ind = car(index_list); + if (!s7_is_integer(ind)) + return(method_or_bust(sc, ind, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], i + 2)); + n = s7_integer_clamped_if_gmp(sc, ind); + if ((n < 0) || (n >= vector_dimension(vect, i))) + out_of_range_error_nr(sc, sc->vector_ref_symbol, wrap_integer(sc, i + 2), ind, (n < 0) ? it_is_negative_string : it_is_too_large_string); + index += n * vector_offset(vect, i); + } + if (is_not_null(index_list)) + { + 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, index_list)); + } + /* if not enough indices, return a subvector covering whatever is left */ + if (i < vector_ndims(vect)) + return(subvector(sc, vect, i, index)); + } + else + { + const s7_pointer ind = 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(ind)) + return(method_or_bust(sc, ind, sc->vector_ref_symbol, set_ulist_1(sc, vect, indices), sc->type_names[T_INTEGER], 2)); + index = s7_integer_clamped_if_gmp(sc, ind); + if ((index < 0) || (index >= vector_length(vect))) + out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, ind, (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 vec, s7_int index) +{ + if ((!is_t_vector(vec)) || + (vector_rank(vec) > 1) || + (index < 0) || (index >= vector_length(vec))) + return(g_vector_ref(sc, set_plist_2(sc, vec, make_integer(sc, index)))); + return(vector_element(vec, index)); +} + +static s7_pointer vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index) /* callable but just barely (tgsl.scm) */ +{ + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(vector_getter(vec)(sc, vec, index)); +} + +static s7_pointer t_vector_ref_p_pi_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index) +{ + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->vector_ref_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(vector_element(vec, index)); +} + +static s7_pointer vector_ref_p_pii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2) +{ + if ((!is_any_vector(vec)) || + (vector_rank(vec) != 2) || + (i1 < 0) || (i2 < 0) || + (i1 >= vector_dimension(vec, 0)) || (i2 >= vector_dimension(vec, 1))) + return(g_vector_ref(sc, set_plist_3(sc, vec, make_integer(sc, i1), make_integer_unchecked(sc, i2)))); + return(vector_getter(vec)(sc, vec, i2 + (i1 * vector_offset(vec, 0)))); +} + +static s7_pointer vector_ref_p_pii_direct(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2) +{ + if ((i1 < 0) || (i2 < 0) || + (i1 >= vector_dimension(vec, 0)) || (i2 >= vector_dimension(vec, 1))) + return(g_vector_ref(sc, set_plist_3(sc, vec, make_integer(sc, i1), make_integer_unchecked(sc, i2)))); + return(vector_element(vec, i2 + (i1 * vector_offset(vec, 0)))); +} + +static s7_pointer t_vector_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index) {return(vector_element(vec, index));} + +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) +{ + const s7_pointer vec = car(args); + s7_pointer 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 func, int32_t args, s7_pointer unused_expr) +{ + if (args == 2) + return(sc->vector_ref_2); + return((args == 3) ? sc->vector_ref_3 : func); +} + + +/* -------------------------------- 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) + + const s7_pointer vec = car(args); + s7_pointer 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 index_list; + index = 0; + for (index_list = cdr(args), i = 0; (is_pair(cdr(index_list))) && (i < vector_ndims(vec)); index_list = cdr(index_list), i++) + { + s7_int n; + const s7_pointer ind = car(index_list); + if (!s7_is_integer(ind)) + return(method_or_bust(sc, ind, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], i + 2)); + n = s7_integer_clamped_if_gmp(sc, ind); + if ((n < 0) || (n >= vector_dimension(vec, i))) + out_of_range_error_nr(sc, sc->vector_set_symbol, wrap_integer(sc, i + 2), ind, (n < 0) ? it_is_negative_string : it_is_too_large_string); + index += n * vector_offset(vec, i); + } + if (is_not_null(cdr(index_list))) + 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(index_list); + } + else + { + const s7_pointer ind = cadr(args); + if (!s7_is_integer(ind)) + return(method_or_bust(sc, ind, sc->vector_set_symbol, args, sc->type_names[T_INTEGER], 2)); + 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, ind, (index < 0) ? it_is_negative_string : it_is_too_large_string); + if (is_not_null(cdddr(args))) + { + const s7_pointer new_vec = vector_getter(vec)(sc, vec, index); + if (!is_any_vector(new_vec)) + 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, new_vec, 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 vec, s7_int index, s7_pointer value) /* almost never called -- see one case in s7test.scm[13736] */ +{ + if ((!is_any_vector(vec)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec))) + return(g_vector_set(sc, set_plist_3(sc, vec, make_integer(sc, index), value))); + if (is_t_vector(vec)) + { + if (is_typed_vector(vec)) return(typed_vector_setter(sc, vec, index, value)); + vector_element(vec, index) = value; + } + else vector_setter(vec)(sc, vec, index, value); + return(value); +} + +static s7_pointer vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if ((index >= 0) && (index < vector_length(vec))) + vector_element(vec, index) = value; + else 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); + return(value); +} + +static s7_pointer vector_set_p_piip(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_pointer value) +{ + if ((!is_any_vector(vec)) || + (vector_rank(vec) != 2) || + (i1 < 0) || (i2 < 0) || + (i1 >= vector_dimension(vec, 0)) || (i2 >= vector_dimension(vec, 1))) + return(g_vector_set(sc, set_plist_4(sc, vec, make_integer(sc, i1), make_integer_unchecked(sc, i2), value))); + if (is_t_vector(vec)) + { + if (is_typed_vector(vec)) + return(typed_vector_setter(sc, vec, i2 + (i1 * vector_offset(vec, 0)), value)); + vector_element(vec, i2 + (i1 * vector_offset(vec, 0))) = value; + } + else vector_setter(vec)(sc, vec, i2 + (i1 * vector_offset(vec, 0)), value); + return(value); +} + +static s7_pointer vector_set_p_piip_direct(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_pointer value) +{ + /* normal untyped vector, rank == 2 */ + if ((i1 < 0) || (i2 < 0) || + (i1 >= vector_dimension(vec, 0)) || (i2 >= vector_dimension(vec, 1))) + return(g_vector_set(sc, set_plist_4(sc, vec, make_integer(sc, i1), make_integer_unchecked(sc, i2), value))); + vector_element(vec, i2 + (i1 * vector_offset(vec, 0))) = value; + return(value); +} + +static s7_pointer typed_vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if ((index >= 0) && (index < vector_length(vec))) + typed_vector_setter(sc, vec, index, value); + else 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); + return(value); +} + +static s7_pointer typed_vector_set_p_piip_direct(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_pointer value) +{ + if ((i1 < 0) || (i2 < 0) || + (i1 >= vector_dimension(vec, 0)) || (i2 >= vector_dimension(vec, 1))) + return(g_vector_set(sc, set_plist_4(sc, vec, make_integer(sc, i1), make_integer_unchecked(sc, i2), value))); + return(typed_vector_setter(sc, vec, i2 + (i1 * vector_offset(vec, 0)), value)); +} + +static s7_pointer t_vector_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_pointer value) {vector_element(vec, index) = value; return(value);} + +static s7_pointer typed_t_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + typed_vector_setter(sc, vec, index, value); + return(value); +} + +static s7_pointer g_vector_set_3(s7_scheme *sc, s7_pointer args) +{ + /* (vector-set! vector index value) */ + const s7_pointer vec = car(args); + s7_pointer ind, 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 ((S7_DEBUGGING) && (is_mutable(ind)) && (is_t_integer(ind))) ind = make_integer(sc, integer(ind)); */ + /* if ((S7_DEBUGGING) && (is_mutable(ind)) && (is_t_integer(ind))) fprintf(stderr, "%s[%d]: skipping make-integer\n", __func__, __LINE__); */ + + 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) +{ + const s7_pointer vec = car(args), ip1 = cadr(args), ip2 = caddr(args); + s7_pointer val; + s7_int i1, i2; + if ((!is_any_vector(vec)) || + (vector_rank(vec) != 2) || (is_immutable_vector(vec)) || + (!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(vec, 0)) || (i2 >= vector_dimension(vec, 1))) + return(g_vector_set(sc, args)); + val = cadddr(args); + if (is_typed_t_vector(vec)) + return(typed_vector_setter(sc, vec, i2 + (i1 * vector_offset(vec, 0)), val)); + if (is_t_vector(vec)) + vector_element(vec, i2 + (i1 * vector_offset(vec, 0))) = val; + else vector_setter(vec)(sc, vec, i2 + (i1 * vector_offset(vec, 0)), val); + return(val); +} + +static s7_pointer vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + if (args == 3) return(sc->vector_set_3); + return((args == 4) ? sc->vector_set_4 : func); +} + + +/* -------------------------------- make-vector -------------------------------- */ +static s7_int multivector_length(s7_scheme *sc, s7_pointer dim_list, s7_pointer caller) +{ + s7_int len = 1; + const s7_int num_dims = s7_list_length(sc, dim_list); + if (num_dims <= 0) /* 0 if circular, negative if dotted */ + wrong_type_error_nr(sc, caller, 1, dim_list, a_proper_list_string); + if (num_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), + dim_list, wrap_integer(sc, sc->max_vector_dimensions))); + for (s7_pointer dims = dim_list; is_pair(dims); dims = cdr(dims)) + { + const s7_pointer dim = car(dims); + if (!s7_is_integer(dim)) + wrong_type_error_nr(sc, caller, position_of(dims, dim_list), dim, sc->type_names[T_INTEGER]); +#if HAVE_OVERFLOW_CHECKS + if (multiply_overflow(len, s7_integer_clamped_if_gmp(sc, dim), &len)) /* or better perhaps len > sc->max_vector_length */ + out_of_range_error_nr(sc, caller, wrap_integer(sc, position_of(dims, dim_list)), dim, it_is_too_large_string); +#else + len *= s7_integer_clamped_if_gmp(sc, dim); +#endif + if (len < 0) + wrong_type_error_nr(sc, caller, position_of(dims, dim_list), dim, a_non_negative_integer_string); + } + return(len); +} + +static void check_vector_typer_c_function(s7_scheme *sc, s7_pointer caller, s7_pointer typf) +{ + const 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); +} + +static inline s7_pointer make_multivector(s7_scheme *sc, s7_pointer vec, s7_pointer x) +{ + vdims_t *v = list_to_vdims(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; + const s7_pointer dims = car(args); + s7_pointer fill = sc->unspecified, typf = sc->T; + int32_t result_type = T_VECTOR; + + if (s7_is_integer(dims)) + { + len = s7_integer_clamped_if_gmp(sc, dims); + if (len < 0) + wrong_type_error_nr(sc, caller, 1, dims, a_non_negative_integer_string); + } + else + { + if (!is_pair(dims)) + return(method_or_bust(sc, dims, caller, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); + if (!s7_is_integer(car(dims))) + wrong_type_error_nr(sc, caller, 1, car(dims), sc->type_names[T_INTEGER]); + len = (is_null(cdr(dims))) ? s7_integer_clamped_if_gmp(sc, car(dims)) : multivector_length(sc, dims, 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; + else + if (caller == sc->make_complex_vector_symbol) + result_type = T_COMPLEX_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 + if (typf == global_value(sc->is_complex_symbol)) + { + if (!is_number(fill)) wrong_type_error_nr(sc, caller, 2, fill, sc->type_names[T_COMPLEX]); + result_type = T_COMPLEX_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))); + } + { + s7_pointer 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(dims)) && + (is_pair(cdr(dims)))) + return(make_multivector(sc, vec, dims)); + 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 #) 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)) /* actually #t here not boolean? */ + 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_pointer size = car(args); /* can be a pair if multiple dimensions */ + s7_int len; + + if ((is_pair(cdr(args))) || (!s7_is_integer(size))) + { + 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, size, 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, size, wrap_real(sc, rational_to_double(sc, init))), sc->make_float_vector_symbol)); + } + else init = real_zero; + if (s7_is_integer(size)) + len = s7_integer_clamped_if_gmp(sc, size); + else + { + if (!is_pair(size)) + return(method_or_bust(sc, size, sc->make_float_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); + len = multivector_length(sc, size, sc->make_float_vector_symbol); + } + { + s7_pointer vect = make_vector_1(sc, len, NOT_FILLED, T_FLOAT_VECTOR); + float_vector_fill(vect, s7_real(init)); + if (!s7_is_integer(size)) + return(make_multivector(sc, vect, size)); + add_vector(sc, vect); + return(vect); + }} + len = s7_integer_clamped_if_gmp(sc, size); + if (len < 0) + out_of_range_error_nr(sc, sc->make_float_vector_symbol, int_one, size, 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))); + { + block_t *arr = mallocate_vector(sc, len * sizeof(s7_double)); + s7_pointer vect; + new_cell(sc, vect, T_FLOAT_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = arr; + float_vector_floats(vect) = (s7_double *)block_data(arr); + if (len > 0) + { + if (STEP_8(len)) + memclr64((void *)float_vector_floats(vect), len * sizeof(s7_double)); + else memclr((void *)float_vector_floats(vect), len * sizeof(s7_double)); + } + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = float_vector_getter; + vector_setter(vect) = float_vector_setter; + add_vector(sc, vect); + return(vect); + } +} + +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-complex-vector -------------------------------- */ +static s7_pointer g_make_complex_vector(s7_scheme *sc, s7_pointer args) +{ + #define H_make_complex_vector "(make-complex-vector len (init 0.0)) returns a complex-vector." + #define Q_make_complex_vector s7_make_signature(sc, 3, \ + sc->is_complex_vector_symbol, s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_pair_symbol), sc->is_complex_symbol) + s7_pointer size = car(args); + s7_int len; + + if ((is_pair(cdr(args))) || (!s7_is_integer(size))) + { + s7_pointer init; + if (is_pair(cdr(args))) + { + init = cadr(args); + if (!is_number(init)) + return(method_or_bust(sc, init, sc->make_complex_vector_symbol, args, sc->type_names[T_COMPLEX], 2)); +#if WITH_GMP + if (s7_is_bignum(init)) + return(g_make_vector_1(sc, set_plist_2(sc, size, init), sc->make_complex_vector_symbol)); +#endif + if (is_rational(init)) + return(g_make_vector_1(sc, set_plist_2(sc, size, wrap_real(sc, rational_to_double(sc, init))), sc->make_complex_vector_symbol)); + } + else init = real_zero; + if (s7_is_integer(size)) + len = s7_integer_clamped_if_gmp(sc, size); + else + { + if (!is_pair(size)) + return(method_or_bust(sc, size, sc->make_complex_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); + len = multivector_length(sc, size, sc->make_complex_vector_symbol); + } + { + s7_pointer vect = make_vector_1(sc, len, NOT_FILLED, T_COMPLEX_VECTOR); + complex_vector_fill(vect, s7_to_c_complex(init)); + if (!s7_is_integer(size)) + return(make_multivector(sc, vect, size)); + add_vector(sc, vect); + return(vect); + }} + len = s7_integer_clamped_if_gmp(sc, size); + if (len < 0) + out_of_range_error_nr(sc, sc->make_complex_vector_symbol, int_one, size, 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-complex-vector first argument ~D is greater than (*s7* 'max-vector-length), ~D", 81), + wrap_integer(sc, len), wrap_integer(sc, sc->max_vector_length))); + { + block_t *arr = mallocate_vector(sc, len * sizeof(s7_complex)); + s7_pointer vect; + new_cell(sc, vect, T_COMPLEX_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = arr; + complex_vector_complexes(vect) = (s7_complex *)block_data(arr); + if (len > 0) + { + if (STEP_8(len)) + memclr64((void *)complex_vector_complexes(vect), len * sizeof(s7_complex)); + else memclr((void *)complex_vector_complexes(vect), len * sizeof(s7_complex)); + } + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = complex_vector_getter; + vector_setter(vect) = complex_vector_setter; + add_vector(sc, vect); + return(vect); + } +} + + +/* -------------------------------- 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_pointer size = car(args); + s7_int len; + + if ((is_pair(cdr(args))) || + (!s7_is_integer(size))) + { + 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(size)) + len = s7_integer_clamped_if_gmp(sc, size); + else + { + if (!is_pair(size)) + return(method_or_bust(sc, size, sc->make_int_vector_symbol, args, wrap_string(sc, "an integer or a list of integers", 32), 1)); + len = multivector_length(sc, size, sc->make_int_vector_symbol); + } + { + s7_pointer vect = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR); + int_vector_fill(vect, s7_integer_clamped_if_gmp(sc, init)); + if (!s7_is_integer(size)) + return(make_multivector(sc, vect, size)); + add_vector(sc, vect); + return(vect); + }} + len = s7_integer_clamped_if_gmp(sc, size); + if (len < 0) + out_of_range_error_nr(sc, sc->make_int_vector_symbol, int_one, size, 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))); + { + block_t *arr = mallocate_vector(sc, len * sizeof(s7_int)); + s7_pointer vect; + new_cell(sc, vect, T_INT_VECTOR | T_SAFE_PROCEDURE); + vector_length(vect) = len; + vector_block(vect) = arr; + int_vector_ints(vect) = (s7_int *)block_data(arr); + if (len > 0) + { + if (STEP_8(len)) + memclr64((void *)int_vector_ints(vect), len * sizeof(s7_int)); + else memclr((void *)int_vector_ints(vect), len * sizeof(s7_int)); + } + vector_set_dimension_info(vect, NULL); + vector_getter(vect) = int_vector_getter; + vector_setter(vect) = int_vector_setter; + add_vector(sc, vect); + return(vect); + } +} + +static s7_pointer make_int_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init) +{ + s7_pointer vec = make_vector_1(sc, len, NOT_FILLED, T_INT_VECTOR); + int_vector_fill(vec, init); + add_vector(sc, vec); + return(vec); +} + + +/* -------------------------------- 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 size = car(args), init; + + if (!is_pair(size)) + { + if (!s7_is_integer(size)) + return(method_or_bust(sc, size, sc->make_byte_vector_symbol, args, sc->type_names[T_INTEGER], 1)); + len = s7_integer_clamped_if_gmp(sc, size); + if (len < 0) + out_of_range_error_nr(sc, sc->make_byte_vector_symbol, int_one, size, 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(size)) + return(g_make_vector_1(sc, set_plist_2(sc, size, init), sc->make_byte_vector_symbol)); + { + s7_pointer result = 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(result)), ib, len); + return(result); + } +} + +static s7_pointer make_byte_vector_p_ii(s7_scheme *sc, s7_int len, s7_int init) +{ + 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); + { + s7_pointer bvect = make_simple_byte_vector(sc, len); + if (len > 0) + local_memset((void *)(byte_vector_bytes(bvect)), init, len); + return(bvect); + } +} + + +/* -------------------------------- 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 vec) {return((s7_int)(vector_rank(vec)));} + +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 vec = car(args); + if (!is_any_vector(vec)) + return(sole_arg_method_or_bust(sc, vec, sc->vector_rank_symbol, args, sc->type_names[T_VECTOR])); + return(make_integer(sc, vector_rank(vec))); +} + + +/* -------------------------------- 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 vec = car(args); + s7_pointer dim = cadr(args); + s7_int n; + if (!is_any_vector(vec)) + return(method_or_bust(sc, vec, sc->vector_dimension_symbol, args, sc->type_names[T_VECTOR], 1)); + if (!s7_is_integer(dim)) + return(method_or_bust(sc, vec, sc->vector_dimension_symbol, args, sc->type_names[T_INTEGER], 2)); + n = s7_integer_clamped_if_gmp(sc, dim); + 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), dim)); + if (n >= vector_rank(vec)) + 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), + dim, wrap_integer(sc, vector_rank(vec)))); + if (vector_has_dimension_info(vec)) + return(make_integer(sc, vector_dimension(vec, n))); + return(make_integer(sc, vector_length(vec))); +} + + +/* -------------------------------- 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 vec = car(args); + if (!is_any_vector(vec)) + return(sole_arg_method_or_bust(sc, vec, sc->vector_dimensions_symbol, args, sc->type_names[T_VECTOR])); + if (vector_rank(vec) == 1) + return(list_1(sc, make_integer(sc, vector_length(vec)))); + begin_temp(sc->y, sc->nil); + for (s7_int i = vector_ndims(vec) - 1; i >= 0; i--) + sc->y = cons(sc, make_integer(sc, vector_dimension(vec, i)), sc->y); + return_with_end_temp(sc->y); +} + + +/* -------------------------------- 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 vec = car(args); + if (!is_any_vector(vec)) + return(sole_arg_method_or_bust(sc, vec, sc->vector_typer_symbol, args, sc->type_names[T_VECTOR])); + if (is_typed_t_vector(vec)) return(typed_vector_typer(vec)); + if (is_float_vector(vec)) return(global_value(sc->is_float_symbol)); + if (is_int_vector(vec)) return(global_value(sc->is_integer_symbol)); + if (is_byte_vector(vec)) return(global_value(sc->is_byte_symbol)); + if (is_complex_vector(vec)) return(global_value(sc->is_number_symbol)); + return(sc->F); +} + +static s7_pointer g_set_vector_typer(s7_scheme *sc, s7_pointer args) +{ + s7_pointer vec = car(args), typer = cadr(args); + + if (!is_any_vector(vec)) + wrong_type_error_nr(sc, wrap_string(sc, "set! vector-typer", 17), 1, vec, sc->type_names[T_VECTOR]); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable so its vector-typer can't be set!", 49), vec)); + if (!is_t_vector(vec)) + { + if (((is_int_vector(vec)) && (typer != global_value(sc->is_integer_symbol))) || + ((is_float_vector(vec)) && (typer != global_value(sc->is_float_symbol))) || + ((is_complex_vector(vec)) && (typer != global_value(sc->is_number_symbol))) || + ((is_byte_vector(vec)) && (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), vec, typer)); + return(typer); + } + if (is_boolean(typer)) + { + if (is_typed_vector(vec)) + { + typed_vector_set_typer(vec, sc->F); + clear_typed_vector(vec); + clear_has_simple_elements(vec); /* 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(vec); + typed_vector_set_typer(vec, typer); + if ((is_c_function(typer)) && + (c_function_has_simple_elements(typer))) + set_has_simple_elements(vec); + else clear_has_simple_elements(vec); /* 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 vals = lst; + for (s7_int i = 0; i < sizes[dimension]; i++, vals = cdr(vals)) + { + if (!is_pair(vals)) + return(MULTIVECTOR_NOT_ENOUGH_ELEMENTS); + if (dimension == (dimensions - 1)) + vector_setter(vec)(sc, vec, flat_ref++, car(vals)); + else + { + flat_ref = traverse_vector_data(sc, vec, flat_ref, dimension + 1, dimensions, sizes, car(vals)); + if (flat_ref < 0) return(flat_ref); + }} + return((is_null(vals)) ? 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 no_return 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 vals = data; + 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))); + 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)))); + + sc->w = sc->nil; + sizes = (s7_int *)Malloc(dims * sizeof(s7_int)); + for (s7_int i = 0; i < dims; i++) + { + sizes[i] = proper_list_length(vals); + sc->w = cons(sc, make_integer(sc, sizes[i]), sc->w); + vals = car(vals); + if ((i < (dims - 1)) && + (!is_pair(vals))) + { + free(sizes); + multivector_error_nr(sc, "we need a list that fully specifies the vector's elements", data); + }} + { + s7_pointer vec = g_make_vector(sc, set_plist_1(sc, sc->w = proper_list_reverse_in_place(sc, sc->w))); + s7_int vec_loc = gc_protect_1(sc, vec); + s7_int err; + 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) +{ + 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) +{ + 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) +{ + 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 s7_pointer g_complex_multivector(s7_scheme *sc, s7_int dims, s7_pointer data) +{ + 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_number(src[i])) + wrong_type_error_nr(sc, wrap_string(sc, "#c(...)", 7), i + 1, src[i], sc->type_names[T_COMPLEX]); + 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_complex_vector_symbol); + return(s7_copy_1(sc, sc->complex_vector_symbol, set_plist_2(sc, sc->value, sc->args))); +} + +static Vectorized s7_pointer s7_vector_copy_1(s7_scheme *sc, s7_pointer old_vec) +{ + const s7_int len = vector_length(old_vec); + s7_pointer new_vec; + + if (is_t_vector(old_vec)) + { + const s7_pointer *src = (const s7_pointer *)vector_elements(old_vec); + s7_pointer *dst; + if ((is_typed_vector(old_vec)) && (len > 0)) /* preserve the type info as well */ + { + if (vector_rank(old_vec) > 1) + new_vec = g_make_vector(sc, set_plist_3(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), + vector_element(old_vec, 0), typed_vector_typer(old_vec))); + else new_vec = g_make_vector(sc, set_plist_3(sc, make_integer(sc, len), + vector_element(old_vec, 0), typed_vector_typer(old_vec))); + } + else + if (vector_rank(old_vec) > 1) + new_vec = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)))); + else new_vec = 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_vec); + for (s7_int i = len; i > 0; i--) *dst++ = *src++; + return(new_vec); + } + if (is_float_vector(old_vec)) + { + const s7_double *src = (s7_double *)float_vector_floats(old_vec); + s7_double *dst; + if (vector_rank(old_vec) > 1) + new_vec = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), real_zero), sc->make_float_vector_symbol); + else new_vec = make_simple_float_vector(sc, len); + dst = (s7_double *)float_vector_floats(new_vec); + for (s7_int i = len; i > 0; i--) *dst++ = *src++; /* same speed as memcpy(dst, src, len * sizeof(s7_double)); */ + return(new_vec); + } + if (is_int_vector(old_vec)) + { + const s7_int *src = (s7_int *)int_vector_ints(old_vec); + s7_int *dst; + if (vector_rank(old_vec) > 1) + new_vec = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), int_zero), sc->make_int_vector_symbol); + else new_vec = make_simple_int_vector(sc, len); + dst = (s7_int *)int_vector_ints(new_vec); + for (s7_int i = len; i > 0; i--) *dst++ = *src++; + return(new_vec); + } + if (is_byte_vector(old_vec)) + { + const uint8_t *src = (const uint8_t *)byte_vector_bytes(old_vec); + uint8_t *dst; + if (vector_rank(old_vec) > 1) + new_vec = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), int_zero), sc->make_byte_vector_symbol); + else new_vec = make_simple_byte_vector(sc, len); + dst = (uint8_t *)byte_vector_bytes(new_vec); + for (s7_int i = len; i > 0; i--) *dst++ = *src++; + return(new_vec); + } + if (is_complex_vector(old_vec)) + { + const s7_complex *src = (s7_complex *)complex_vector_complexes(old_vec); + s7_complex *dst; + if (vector_rank(old_vec) > 1) + new_vec = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, old_vec)), real_zero), sc->make_complex_vector_symbol); + else new_vec = make_simple_complex_vector(sc, len); + dst = (s7_complex *)complex_vector_complexes(new_vec); + for (s7_int i = len; i > 0; i--) *dst++ = *src++; + return(new_vec); + } + return(NULL); +} + +s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vec) {return(s7_vector_copy_1(sc, old_vec));} /* repeated for Vectorized */ + +static s7_pointer univect_ref(s7_scheme *sc, s7_pointer args, s7_pointer caller, int32_t typ) +{ + const s7_pointer vec = car(args); + s7_pointer index; + s7_int ind; + + if (type(vec) != typ) + return(method_or_bust(sc, vec, caller, args, sc->type_names[typ], 1)); + + if (vector_rank(vec) == 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(vec))) + 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 indices; + ind = 0; + for (indices = cdr(args), i = 0; (is_pair(indices)) && (i < vector_ndims(vec)); indices = cdr(indices), i++) + { + s7_int n; + index = car(indices); + 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(indices)) + 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(vec)) + return(subvector(sc, vec, i, ind)); + } + if (typ == T_FLOAT_VECTOR) + return(make_real(sc, float_vector(vec, ind))); + if (typ == T_COMPLEX_VECTOR) + return(make_complex(sc, creal(complex_vector(vec, ind)), cimag(complex_vector(vec, ind)))); + return((typ == T_INT_VECTOR) ? make_integer(sc, int_vector(vec, ind)) : small_int(byte_vector(vec, ind))); +} + +static s7_pointer univect_set(s7_scheme *sc, s7_pointer args, s7_pointer caller, int32_t typ) +{ + const s7_pointer vec = car(args); + s7_pointer 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 indices; + ind = 0; + for (indices = cdr(args), i = 0; (is_pair(cdr(indices))) && (i < vector_ndims(vec)); indices = cdr(indices), i++) + { + s7_int n; + index = car(indices); + 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(indices))) + 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(indices); + } + else + { + s7_pointer indices = cdr(args); + if (is_null(indices)) + 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(indices); + 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(indices))) + 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(indices); + } + + 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 (typ == T_BYTE_VECTOR) + { + 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); + } + else + { + if (!is_number(val)) + return(method_or_bust(sc, val, caller, args, sc->type_names[T_COMPLEX], 3)); + complex_vector(vec, ind) = s7_to_c_complex(val); + } + return(val); +} + + +/* -------------------------------- complex-vector-ref -------------------------------- */ +static s7_pointer g_complex_vector_ref(s7_scheme *sc, s7_pointer args) +{ + #define H_complex_vector_ref "(complex-vector-ref v ...) returns an element of the complex-vector v." + #define Q_complex_vector_ref s7_make_circular_signature(sc, 2, 3, \ + s7_make_signature(sc, 2, sc->is_complex_symbol, sc->is_complex_vector_symbol), \ + sc->is_complex_vector_symbol, sc->is_integer_symbol) + return(univect_ref(sc, args, sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR)); +} + +static s7_pointer complex_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) +{ + s7_int ind; + if (!is_complex_vector(vec)) + return(method_or_bust_pp(sc, vec, sc->complex_vector_ref_symbol, vec, index, sc->type_names[T_COMPLEX_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_ref(sc, set_plist_2(sc, vec, index), sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR)); + if (!s7_is_integer(index)) + return(method_or_bust_pp(sc, index, sc->complex_vector_ref_symbol, vec, index, 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, sc->complex_vector_ref_symbol, int_two, index, (ind < 0) ? it_is_negative_string : it_is_too_large_string); + return(c_complex_to_s7(sc, complex_vector(vec, ind))); +} + +static s7_pointer g_cv_ref_2(s7_scheme *sc, s7_pointer args) {return(complex_vector_ref_p_pp(sc, car(args), cadr(args)));} + +static s7_pointer complex_vector_ref_p_pi(s7_scheme *sc, s7_pointer vec, s7_int index) +{ + if ((!is_complex_vector(vec)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec))) + return(g_complex_vector_ref(sc, set_plist_2(sc, vec, make_integer(sc, index)))); + return(c_complex_to_s7(sc, complex_vector(vec, index))); +} + +static s7_pointer complex_vector_ref_p_pi_wrapped(s7_scheme *sc, s7_pointer vec, s7_int index) +{ + s7_complex z; + if ((!is_complex_vector(vec)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec))) + return(g_complex_vector_ref(sc, set_plist_2(sc, vec, make_integer(sc, index)))); + z = complex_vector(vec, index); + return(wrap_complex(sc, creal(z), cimag(z))); +} + +static s7_pointer complex_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index) {return(c_complex_to_s7(sc, complex_vector(vec, index)));} + +static s7_pointer complex_vector_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->cv_ref_2 : func); +} + + +/* -------------------------------- complex-vector-set! -------------------------------- */ +static s7_pointer g_complex_vector_set(s7_scheme *sc, s7_pointer args) +{ + #define H_complex_vector_set "(complex-vector-set! v i ... value) sets the i-th element of the complex-vector v to value." + #define Q_complex_vector_set s7_make_circular_signature(sc, 3, 4, \ + sc->is_complex_symbol, sc->is_complex_vector_symbol, sc->is_integer_symbol, sc->is_integer_or_number_at_end_symbol) + return(univect_set(sc, args, sc->complex_vector_set_symbol, T_COMPLEX_VECTOR)); +} + + +static s7_pointer complex_vector_set_p_pip(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if ((!is_complex_vector(vec)) || (!is_number(value)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec))) + return(univect_set(sc, set_plist_3(sc, vec, make_integer(sc, index), value), sc->complex_vector_set_symbol, T_COMPLEX_VECTOR)); + complex_vector(vec, index) = s7_to_c_complex(value); + return(value); +} + +static s7_pointer complex_vector_set_p_pip_unchecked(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if ((index >= 0) && (index < vector_length(vec))) + complex_vector(vec, index) = s7_to_c_complex(value); + else out_of_range_error_nr(sc, sc->complex_vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(value); +} + +static s7_pointer complex_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + complex_vector(vec, index) = s7_to_c_complex(value); + return(value); +} + +static s7_pointer complex_vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer index, s7_pointer value) +{ + s7_int i; + if (!is_complex_vector(vec)) + return(method_or_bust_ppp(sc, vec, sc->complex_vector_set_symbol, vec, index, value, sc->type_names[T_COMPLEX_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_set(sc, set_plist_3(sc, vec, index, value), sc->complex_vector_set_symbol, T_COMPLEX_VECTOR)); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->complex_vector_set_symbol, vec)); + if (!s7_is_integer(index)) + return(method_or_bust_ppp(sc, index, sc->complex_vector_set_symbol, vec, index, value, sc->type_names[T_INTEGER], 2)); + if (!s7_is_number(value)) + return(method_or_bust_ppp(sc, value, sc->complex_vector_set_symbol, vec, index, value, sc->type_names[T_COMPLEX], 3)); + i = integer(index); + if ((i < 0) || (i >= vector_length(vec))) + out_of_range_error_nr(sc, sc->complex_vector_set_symbol, int_two, index, (i < 0) ? it_is_negative_string : it_is_too_large_string); + complex_vector(vec, i) = s7_to_c_complex(value); + return(value); +} + +static s7_pointer g_cv_set_3(s7_scheme *sc, s7_pointer args) {return(complex_vector_set_p_ppp(sc, car(args), cadr(args), caddr(args)));} +/* static s7_pointer g_cv_set_3_nr(s7_scheme *sc, s7_pointer args) {return(complex_vector_set_p_ppp_nr(sc, car(args), cadr(args), caddr(args)));} */ + +static s7_pointer complex_vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + return((args == 3) ? sc->cv_set_3 : func); +} + + +/* -------------------------------- 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 vec, s7_pointer index) +{ + s7_int ind; + if (!is_float_vector(vec)) + return(method_or_bust_pp(sc, vec, sc->float_vector_ref_symbol, vec, index, sc->type_names[T_FLOAT_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_ref(sc, set_plist_2(sc, vec, 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, vec, index, 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, 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(vec, 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 vec, s7_int index) +{ + /* according to callgrind, it is faster to split out the bounds check */ + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->float_vector_ref_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(index); +} + +static s7_pointer float_vector_set_p_pip(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if ((!is_float_vector(vec)) || (!is_real(value)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec))) + return(univect_set(sc, set_plist_3(sc, vec, make_integer(sc, index), value), sc->float_vector_set_symbol, T_FLOAT_VECTOR)); + float_vector(vec, index) = s7_real(value); + return(value); +} + +static inline s7_double float_vector_ref_d_7pi(s7_scheme *sc, s7_pointer vec, s7_int index) {return(float_vector(vec, ref_check_index(sc, vec, index)));} +static double float_vector_ref_d_7pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index) {return(float_vector(vec, index));} +static s7_pointer float_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index) {return(make_real(sc, float_vector(vec, index)));} +static s7_pointer float_vector_ref_p_pi_direct_wrapped(s7_scheme *sc, s7_pointer vec, s7_int index) {return(wrap_real(sc, float_vector(vec, index)));} + +static inline s7_double float_vector_ref_d_7pii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 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(vec, 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(vec, i2 + (i1 * vector_offset(vec, 0)))); +} + +static s7_double float_vector_ref_d_7piii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_int i3) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 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(vec, 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(vec, 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(vec, i3 + (i2 * vector_offset(vec, 1)) + (i1 * vector_offset(vec, 0)))); +} + +static s7_pointer float_vector_ref_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->fv_ref_2 : ((args == 3) ? sc->fv_ref_3 : func)); +} + + +/* -------------------------------- 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 sym = cadr(expr), ind = caddr(expr); + if ((is_symbol(sym)) && (!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 sym ind) */ + (is_proper_list_2(sc, cdr(ref))) && + (cadr(ref) == sym) && + (caddr(ref) == ind)) || + ((car(ref) == sym) && /* (sym ind) */ + (is_proper_list_1(sc, cdr(ref))) && + (cadr(ref) == ind))) + return(true); /* else keep looking */ + }} + return(false); +} + +static s7_pointer float_vector_set_chooser(s7_scheme *sc, s7_pointer func, 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(func); +} + +static s7_double float_vector_set_d_7pid_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_double x) {float_vector(vec, index) = x; return(x);} + +static s7_int set_check_index(s7_scheme *sc, s7_pointer vec, s7_int index) +{ + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->float_vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(index); +} + +static s7_double float_vector_set_d_7pid(s7_scheme *sc, s7_pointer vec, s7_int index, s7_double x) {float_vector(vec, set_check_index(sc, vec, index)) = x; return(x);} + +static s7_double float_vector_set_d_7piid(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_double x) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 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(vec, 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(vec, i2 + (i1 * vector_offset(vec, 0))) = x; + return(x); +} + +static s7_double float_vector_set_d_7piiid(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_int i3, s7_double x) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 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(vec, 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(vec, 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(vec, i3 + (i2 * vector_offset(vec, 1)) + (i1 * vector_offset(vec, 0))) = x; + return(x); +} + +static s7_pointer float_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + float_vector(vec, index) = real_to_double(sc, value, "float-vector-set!"); + return(value); +} + +static s7_pointer float_vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer ind, s7_pointer val) +{ + s7_int index; + if ((!is_float_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->float_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->float_vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + if (!is_real(val)) + wrong_type_error_nr(sc, sc->float_vector_set_symbol, 3, val, sc->type_names[T_REAL]); + float_vector(vec, index) = (is_t_real(val)) ? real(val) : s7_real(val); + return(val); +} + +/* -------------------------------- 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 vec, s7_int index) {return(int_vector(vec, index));} +static s7_pointer int_vector_ref_p_pi_direct(s7_scheme *sc, s7_pointer vec, s7_int index) {return(make_integer(sc, int_vector(vec, index)));} +static s7_pointer int_vector_ref_p_pi_direct_wrapped(s7_scheme *sc, s7_pointer vec, s7_int index) {return(wrap_integer(sc, int_vector(vec, index)));} + +static s7_int int_vector_ref_i_7pi(s7_scheme *sc, s7_pointer vec, s7_int index) +{ + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->int_vector_ref_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return(int_vector(vec, index)); +} + +static s7_int int_vector_ref_i_7pii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 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(vec, 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(vec, i2 + (i1 * vector_offset(vec, 0)))); +} + +static s7_int int_vector_ref_i_7piii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_int i3) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 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(vec, 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(vec, 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(vec, i3 + (i2 * vector_offset(vec, 1)) + (i1 * vector_offset(vec, 0)))); +} + +static inline s7_pointer int_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) +{ + s7_int ind; + if (!is_int_vector(vec)) + return(method_or_bust_pp(sc, vec, sc->int_vector_ref_symbol, vec, index, sc->type_names[T_INT_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_ref(sc, set_plist_2(sc, vec, 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, vec, index, 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, 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(vec, 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 func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->iv_ref_2 : ((args == 3) ? sc->iv_ref_3 : func)); +} + + +/* -------------------------------- 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 vec, s7_int index, s7_int x) {int_vector(vec, index) = x; return(x);} + +static s7_pointer int_vector_set_p_pip(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + if ((!is_int_vector(vec)) || (!is_t_integer(value)) || (vector_rank(vec) > 1) || (index < 0) || (index >= vector_length(vec))) + return(univect_set(sc, set_plist_3(sc, vec, make_integer(sc, index), value), sc->int_vector_set_symbol, T_INT_VECTOR)); + int_vector(vec, index) = integer(value); + return(value); +} + +static s7_pointer int_vector_set_p_pip_direct(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer value) +{ + int_vector(vec, index) = s7_integer_clamped_if_gmp(sc, value); + return(value); +} + +static s7_int int_vector_set_i_7pii(s7_scheme *sc, s7_pointer vec, s7_int index, s7_int x) +{ + if ((index < 0) || (index >= vector_length(vec))) + out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + int_vector(vec, index) = x; + return(x); +} + +static s7_int int_vector_set_i_7piii(s7_scheme *sc, s7_pointer vec, s7_int i1, s7_int i2, s7_int i3) +{ + if ((i1 < 0) || (i1 >= vector_dimension(vec, 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(vec, 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(vec, i2 + (i1 * vector_offset(vec, 0))) = i3; + return(i3); +} + +static s7_pointer int_vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer index, s7_pointer value) +{ + if ((is_int_vector(vec)) && (vector_rank(vec) == 1) && (!is_immutable_vector(vec)) && + (is_t_integer(index)) && (is_t_integer(value))) + { + s7_int i = integer(index); + if ((i < 0) || (i >= vector_length(vec))) + 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(vec, i) = integer(value); + } + else + { + if (!is_int_vector(vec)) + return(method_or_bust_ppp(sc, vec, sc->int_vector_set_symbol, vec, index, value, sc->type_names[T_INT_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_set(sc, set_plist_3(sc, vec, index, value), sc->int_vector_set_symbol, T_INT_VECTOR)); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->int_vector_set_symbol, vec)); + /* (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, vec, index, value, sc->type_names[T_INTEGER], 2)); + if (!s7_is_integer(value)) + return(method_or_bust_ppp(sc, value, sc->int_vector_set_symbol, vec, index, value, 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(vec))) + 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(vec, i) = s7_integer_clamped_if_gmp(sc, value); + } +#else + if (S7_DEBUGGING) fprintf(stderr, "fell through %s[%d]\n", __func__, __LINE__); +#endif + } + return(value); +} + +static s7_pointer g_iv_set_3(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer vec = car(args); + s7_pointer index, value; + s7_int ind; + if (!is_int_vector(vec)) + return(method_or_bust(sc, vec, sc->int_vector_set_symbol, args, sc->type_names[T_INT_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_set(sc, args, sc->int_vector_set_symbol, T_INT_VECTOR)); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->int_vector_set_symbol, vec)); + 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(vec))) + 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(vec, ind) = s7_integer_clamped_if_gmp(sc, value); + return(value); +} + +static s7_pointer int_vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 3) ? sc->iv_set_3 : func); +} + + +/* -------------------------------- 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 vec, s7_int index) +{ + if ((index < 0) || (index >= byte_vector_length(vec))) + out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + return((s7_int)((byte_vector(vec, index)))); +} + +static s7_int byte_vector_ref_i_7pii(s7_scheme *sc, s7_pointer vec, s7_int index1, s7_int index2) +{ + if ((index1 < 0) || (index1 >= vector_dimension(vec, 0))) + out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_two, wrap_integer(sc, index1), (index1 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((index2 < 0) || (index2 >= vector_dimension(vec, 1))) + out_of_range_error_nr(sc, sc->byte_vector_ref_symbol, int_three, wrap_integer(sc, index2), (index2 < 0) ? it_is_negative_string : it_is_too_large_string); + return((s7_int)byte_vector(vec, index2 + (index1 * vector_offset(vec, 0)))); +} + +static s7_pointer byte_vector_ref_p_pi_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index) {return(small_int((byte_vector(vec, index))));} +static s7_int byte_vector_ref_i_7pi_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index) {return(byte_vector(vec, index));} + +static s7_pointer g_bv_ref_2(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer vec = car(args); + s7_pointer index; + s7_int ind; + if (!is_byte_vector(vec)) + return(method_or_bust(sc, vec, sc->byte_vector_ref_symbol, args, sc->type_names[T_BYTE_VECTOR], 1)); + if (vector_rank(vec) != 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(vec))) + 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(vec, ind))); +} + +static s7_pointer g_bv_ref_3(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer iv = car(args); + s7_pointer 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 func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->bv_ref_2 : ((args == 3) ? sc->bv_ref_3 : func)); +} + + +/* -------------------------------- 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 vec, s7_int index, s7_int byte) +{ + if (!is_byte_vector(vec)) + wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 1, vec, a_byte_vector_string); + if ((byte < 0) || (byte > 255)) + wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, wrap_integer(sc, byte), an_unsigned_byte_string); + if ((index < 0) || (index >= byte_vector_length(vec))) + out_of_range_error_nr(sc, sc->byte_vector_set_symbol, int_two, wrap_integer(sc, index), (index < 0) ? it_is_negative_string : it_is_too_large_string); + byte_vector(vec, index) = (uint8_t)byte; + return(byte); +} + +static s7_int byte_vector_set_i_7pii_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_int byte) +{ + byte_vector(vec, index) = (uint8_t)byte; + return(byte); +} + +static s7_pointer byte_vector_set_p_pip_direct(s7_scheme *unused_sc, s7_pointer vec, s7_int index, s7_pointer byte) +{ + byte_vector(vec, index) = (uint8_t)s7_integer(byte); + return(byte); +} + +static s7_int byte_vector_set_i_7piii(s7_scheme *sc, s7_pointer vec, s7_int index1, s7_int index2, s7_int byte) +{ + if ((byte < 0) || (byte > 255)) + wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 4, wrap_integer(sc, byte), an_unsigned_byte_string); + if ((index1 < 0) || (index1 >= vector_dimension(vec, 0))) + out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_two, wrap_integer(sc, index1), (index1 < 0) ? it_is_negative_string : it_is_too_large_string); + if ((index2 < 0) || (index2 >= vector_dimension(vec, 1))) + out_of_range_error_nr(sc, sc->int_vector_set_symbol, int_three, wrap_integer(sc, index2), (index2 < 0) ? it_is_negative_string : it_is_too_large_string); + byte_vector(vec, index2 + (index1 * vector_offset(vec, 0))) = byte; + return(byte); +} + +static s7_pointer g_bv_set_3(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer vec = car(args); + s7_pointer index, value; + s7_int ind, byte; + if (!is_byte_vector(vec)) + return(method_or_bust(sc, vec, sc->byte_vector_set_symbol, args, sc->type_names[T_BYTE_VECTOR], 1)); + if (vector_rank(vec) != 1) + return(univect_set(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR)); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->byte_vector_set_symbol, vec)); + 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(vec))) + 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)); + byte = s7_integer_clamped_if_gmp(sc, value); + if ((byte < 0) || (byte > 255)) + wrong_type_error_nr(sc, sc->byte_vector_set_symbol, 3, value, an_unsigned_byte_string); + byte_vector(vec, ind) = (uint8_t)byte; + return(value); +} + +static s7_pointer byte_vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 3) ? sc->bv_set_3 : func); +} + + +/* -------------------------------------------------------------------------------- */ +static bool c_function_is_ok(s7_scheme *sc, s7_pointer x) +{ + s7_pointer func = lookup_unexamined(sc, car(x)); /* lookup_global is usually slower (faster in Snd) */ + if ((func == opt1_cfunc(x)) || + ((func) && (is_any_c_function(func)) && (c_function_class(func) == c_function_class(opt1_cfunc(x))) && (set_opt1_cfunc(x, func)))) + return(true); + sc->last_function = func; + 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 x = real(*((const s7_pointer *)f1)); + s7_double y = real(*((const s7_pointer *)f2)); + if (x < y) return(-1); + return((x > y) ? 1 : 0); +} + +static int32_t int_less_2(const void *f1, const void *f2) +{ + s7_int i1 = integer(*((const s7_pointer *)f1)); + s7_int i2 = integer(*((const s7_pointer *)f2)); + if (i1 < i2) return(-1); + return((i1 > i2) ? 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 str1 = (*((const s7_pointer *)f1)); + s7_pointer str2 = (*((const s7_pointer *)f2)); + return(scheme_strcmp(str1, str2)); +} + +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 c1 = character(*((const s7_pointer *)f1)); + uint8_t c2 = character(*((const s7_pointer *)f2)); + if (c1 < c2) return(-1); + return((c1 > c2) ? 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; + const 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; + const 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 i1 = (*(const s7_pointer *)v1); + s7_pointer i2 = (*(const s7_pointer *)v2); + if ((is_t_integer(i1)) && (is_t_integer(i2))) + return((integer(i1) < integer(i2)) ? -1 : 1); + return((lt_b_7pp((s7_scheme *)arg, i1, i2)) ? -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); +} + +#define OPT_PRINT 0 /* print info about the opt_* optimizations */ +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); +#if OPT_PRINT +#define cell_optimize(Sc, Expr) cell_optimize_with_line(Sc, Expr, __LINE__) +static bool cell_optimize_with_line(s7_scheme *sc, s7_pointer expr, int line); +#else +static bool cell_optimize(s7_scheme *sc, s7_pointer expr); +#endif + +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) + + const s7_pointer data = car(args); + s7_pointer lessp, lx; + s7_int len = 0, n, k; + int32_t (*sort_func)(const void *v1, const void *v2, void *arg); + + /* 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)) + { + const s7_pointer expr = car(closure_body(lessp)); + const s7_pointer pars = closure_pars(lessp); + + if ((is_pair(pars)) && /* closure args not a symbol, etc */ + (!arglist_has_rest(sc, pars))) + { + 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_defined_global(car(expr))) && /* (sort! x (lambda (car y) (car x)...))! */ + (c_function_is_ok(sc, expr))))) + { + const int32_t orig_data = optimize_op(expr); + set_optimize_op(expr, optimize_op(expr) | 1); + if ((optimize_op(expr) == HOP_SAFE_C_SS) && + (car(pars) == cadr(expr)) && + (cadr(pars) == 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) + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + if (((car(arg1) == sc->car_symbol) || (car(arg1) == sc->cdr_symbol)) && + (car(arg1) == car(arg2)) && + (car(pars) == cadr(arg1)) && + (cadr(pars) == cadr(arg2))) /* expr: (< (car a) (car b)) etc */ + { + s7_pointer lp = lookup(sc, car(expr)); + sc->sort_f = s7_b_7pp_function(lp); + if (sc->sort_f) + { + sort_func = ((car(arg1) == sc->car_symbol) ? vector_car_sort : vector_cdr_sort); + lessp = lp; + }}} + set_optimize_op(expr, orig_data); + } + + if (!sort_func) + { + s7_pointer init_val; + const s7_pointer 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(pars), init_val, cadr(pars), 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(pars), sc->F, cadr(pars), 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); + s7_pointer *elements = s7_vector_elements(vec); + gc_protect_2_via_stack(sc, vec, data); + 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: + { + 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); + }} + { + s7_pointer vec = make_simple_vector(sc, len); + s7_pointer *elements = s7_vector_elements(vec); + gc_protect_2_via_stack(sc, vec, data); + if (is_byte_vector(data)) + for (s7_int i = 0; i < len; i++) elements[i] = small_int(chrs[i]); + else for (s7_int 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 (s7_int i = 0; i < len; i++) chrs[i] = (char)integer(elements[i]); + else for (s7_int 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: case T_COMPLEX_VECTOR: + { + len = vector_length(data); + if (len < 2) + return(data); + if ((is_c_function(lessp)) && (!is_complex_vector(data))) /* < and > make no sense in the complex case */ + { + 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 + * 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) + */ + { + s7_pointer vec = make_vector_1(sc, len, FILLED, T_VECTOR); + /* 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. + */ + s7_pointer *elements = s7_vector_elements(vec); + gc_protect_2_via_stack(sc, vec, data); + add_vector(sc, vec); + check_free_heap_size(sc, len); + if (is_float_vector(data)) + for (s7_int i = 0; i < len; i++) elements[i] = make_real_unchecked(sc, float_vector(data, i)); + else + if (is_int_vector(data)) + for (s7_int i = 0; i < len; i++) elements[i] = make_integer_unchecked(sc, int_vector(data, i)); + else for (s7_int i = 0; i < len; i++) elements[i] = c_complex_to_s7(sc, complex_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 (s7_int i = 0; i < len; i++) float_vector(data, i) = real(elements[i]); + else + if (is_int_vector(data)) + for (s7_int i = 0; i < len; i++) int_vector(data, i) = integer(elements[i]); + else for (s7_int i = 0; i < len; i++) complex_vector(data, i) = s7_to_c_complex(elements[i]); + unstack_gc_protect(sc); + return(data); + } + set_car(args, vec); + begin_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 */ + end_temp(sc->y); + }} + 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 */ + begin_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); + end_temp(sc->y); + 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) +{ + const 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) +{ + const s7_pointer *elements = vector_elements(source); + const 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) +{ + const s7_pointer *elements = vector_elements(vect); + const 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) + { + const 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); + const s7_int len = (s7_int)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); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + 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 table) +{ + if (!is_hash_table(table)) + return(integer(method_or_bust_p(sc, table, sc->hash_table_entries_symbol, sc->type_names[T_HASH_TABLE]))); + return(hash_table_entries(table)); +} + + +/* -------------------------------- 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 table = car(args); + if (!is_hash_table(table)) return(sole_arg_method_or_bust(sc, table, sc->hash_table_key_typer_symbol, args, sc->type_names[T_HASH_TABLE])); + if (is_typed_hash_table(table)) return(hash_table_key_typer(table)); + 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 table = car(args); + if (!is_hash_table(table)) return(sole_arg_method_or_bust(sc, table, sc->hash_table_value_typer_symbol, args, sc->type_names[T_HASH_TABLE])); + if (is_typed_hash_table(table)) return(hash_table_value_typer(table)); + return(sc->F); +} + +static s7_pointer make_hash_table_procedures(s7_scheme *sc) +{ + s7_pointer p = cons(sc, sc->T, sc->T); /* checker, mapped */ + set_opt1_any(p, sc->T); /* key */ + set_opt2_any(p, sc->T); /* value */ + return(p); +} + +static s7_pointer copy_hash_table_procedures(s7_scheme *sc, s7_pointer table) +{ + if (is_pair(hash_table_procedures(table))) + { + s7_pointer p = cons(sc, hash_table_procedures_checker(table), hash_table_procedures_mapper(table)); + set_opt1_any(p, hash_table_key_typer(table)); + set_opt2_any(p, hash_table_value_typer(table)); + return(p); + } + return(sc->nil); +} + +static void check_hash_table_typer(s7_scheme *sc, s7_pointer caller, s7_pointer table, 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_has_simple_elements(typer)) + { + if (caller == sc->hash_table_value_typer_symbol) + set_has_simple_values(table); + else + { + set_has_simple_keys(table); + if (symbol_type(c_function_symbol(typer)) != T_FREE) + set_has_hash_key_type(table); + }}} + if (is_null(hash_table_procedures(table))) + hash_table_set_procedures(table, make_hash_table_procedures(sc)); + set_is_typed_hash_table(table); +} + +static s7_pointer g_set_hash_table_key_typer(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer table = car(args), typer = cadr(args); + + if (!is_hash_table(table)) + wrong_type_error_nr(sc, wrap_string(sc, "set! hash_table-key-typer", 25), 1, table, sc->type_names[T_HASH_TABLE]); + if (is_immutable_hash_table(table)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable so its key-typer can't be set!", 46), table)); + + if (is_boolean(typer)) /* remove current typer, if any */ + { + if (is_typed_hash_table(table)) + { + hash_table_set_key_typer(table, sc->T); + clear_has_simple_keys(table); + if (hash_table_value_typer(table) == sc->T) clear_is_typed_hash_table(table); + }} + else + { + check_hash_table_typer(sc, sc->hash_table_key_typer_symbol, table, typer); + hash_table_set_key_typer(table, typer); + } + return(typer); +} + +static s7_pointer g_set_hash_table_value_typer(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer table = car(args), typer = cadr(args); + + if (!is_hash_table(table)) + wrong_type_error_nr(sc, wrap_string(sc, "set! hash_table-value-typer", 27), 1, table, sc->type_names[T_HASH_TABLE]); + if (is_immutable_hash_table(table)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "~S is immutable so its value-typer can't be set!", 48), table)); + + if (is_boolean(typer)) /* remove current typer, if any */ + { + if (is_typed_hash_table(table)) + { + hash_table_set_value_typer(table, sc->T); + clear_has_simple_values(table); + if (hash_table_key_typer(table) == sc->T) clear_is_typed_hash_table(table); + }} + else + { + check_hash_table_typer(sc, sc->hash_table_value_typer_symbol, table, typer); + hash_table_set_value_typer(table, 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; + hash_table_mask(table) = 1; /* we're lying... */ + 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) + + const s7_pointer obj = car(args); + s7_int code; + 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))); + code = default_hash_map[type(obj)](sc, sc->dummy_equal_hash_table, obj); +#ifdef __clang__ + if (code < 0) code = 0; +#endif + return(make_integer(sc, code)); +} + + +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_uint 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_uint loc = hash_loc(sc, table, key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if ((is_syntax(hash_entry_key(entry))) && + (syntax_symbol(hash_entry_key(entry)) == syntax_symbol(key))) /* the opcodes might differ, but the symbols should not */ + return(entry); + return(sc->unentry); +} + +/* ---------------- hash symbols ---------------- */ +static s7_uint 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) +{ + s7_uint loc = pointer_map(key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (key == hash_entry_key(entry)) + return(entry); + return(sc->unentry); +} + + +/* ---------------- hash numbers ---------------- */ +static s7_uint hash_map_int(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_int k = integer(key); + return((k >= 0) ? k : ((k == S7_INT64_MIN) ? S7_INT64_MAX : -k)); +} + +static s7_uint 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_uint hash_float_location(s7_double x) +{ +#if 0 + 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)); +#else + /* if ((x > 1.0e16) || (x < -1.0e16) || (is_NaN(x)) || (is_inf(x))) return(0); */ /* log(DOUBLE_TO_INT64_LIMIT, 10) is about 16 */ + if ((is_NaN(x)) || (is_inf(x))) return(0); + return((s7_uint)floor(fabs(x))); +#if 0 + decode_float_t num; + num.fx = x; + return((s7_uint)(num.ix)); +#endif +#endif +} + /* 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_uint hash_map_real(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return(hash_float_location(real(key))); +} + +static s7_uint hash_complex_location(s7_double x) +{ + return(hash_float_location(x)); /* + hash_float_location(imag_part(key)) -- imag-part confuses epsilon distance calcs */ +} + +static s7_uint hash_map_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return(hash_complex_location(real_part(key))); +} + +#if WITH_GMP +static s7_uint 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_uint 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_uint 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_uint 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_uint 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) +{ + const 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); + } + /* else fprintf(stderr, "%s[%d]: %s != %s\n", __func__, __LINE__, display(key), display(hash_entry_key(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_uint loc1; + const s7_uint hash_mask = hash_table_mask(table); + const s7_uint loc = hash_loc(sc, table, key); + s7_uint 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 result = any_real_to_mpfr(sc, key, sc->mpfr_1); + if (result) 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 + const s7_double keyval = (is_real(key)) ? s7_real(key) : real_part(key); + const s7_double fprobe = fabs(keyval); + const s7_uint iprobe = (s7_uint)floor(fprobe); + const s7_double bin_dist = fprobe - iprobe; +#ifdef __clang__ + s7_uint loc = ((is_NaN(keyval)) || (is_inf(keyval))) ? 0 : iprobe % hash_table_mask(table); +#else + s7_uint loc = iprobe % hash_table_mask(table); +#endif + 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 + { + const s7_uint hash_mask = hash_table_mask(table); + hash_entry_t *entry; +#if WITH_GMP + const s7_int kv = (is_t_integer(key)) ? integer(key) : mpz_get_si(big_integer(key)); +#else + const s7_int kv = integer(key); +#endif + const s7_uint loc = s7_int_abs(kv) % hash_mask; + for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) +#if WITH_GMP + if (is_t_integer(hash_entry_key(entry))) + { + if (integer(hash_entry_key(entry)) == kv) + return(entry); + } + else + if ((is_t_big_integer(hash_entry_key(entry))) && + (mpz_get_si(big_integer(hash_entry_key(entry))) == kv)) + return(entry); +#else + if (integer(hash_entry_key(entry)) == kv) + return(entry); +#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_uint loc; +#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 + loc = hash_float_location(keyval) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + { + if ((is_t_real(hash_entry_key(entry))) && + (keyval == real(hash_entry_key(entry)))) + return(entry); +#if WITH_GMP + if ((is_t_big_real(hash_entry_key(entry))) && + (mpfr_cmp_d(big_real(hash_entry_key(entry)), keyval) == 0) && + (!mpfr_nan_p(big_real(hash_entry_key(entry))))) + return(entry); +#endif + }} + return(sc->unentry); +} + +static hash_entry_t *hash_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_uint loc = hash_loc(sc, table, key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (num_eq_b_7pp(sc, key, hash_entry_key(entry))) + return(entry); + 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 + 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_uint loc = map(sc, table, key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (keyi == integer(hash_entry_key(entry))) /* not in gmp, hash_int as eq_func, what else can key be but t_integer? */ + return(entry); + } + 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_uint 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_uint loc = character(key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (key == hash_entry_key(entry)) + return(entry); + } + return(sc->unentry); +} + +#if !WITH_PURE_S7 +static s7_uint 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_uint loc = hash_loc(sc, table, key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (upper_character(key) == upper_character(hash_entry_key(entry))) + return(entry); + } + return(sc->unentry); +} +#endif + + +/* ---------------- hash strings ---------------- */ +static s7_uint 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 *entry; + const s7_int key_len = string_length(key); + const s7_uint hash_mask = hash_table_mask(table); + s7_uint 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 s7_uint */ + + if (key_len <= 8) + { + for (entry = hash_table_element(table, hash % hash_mask); entry; entry = hash_entry_next(entry)) + if ((hash == string_hash(hash_entry_key(entry))) && + (key_len == string_length(hash_entry_key(entry)))) + return(entry); + } + else + for (entry = hash_table_element(table, hash % hash_mask); entry; entry = hash_entry_next(entry)) + if ((hash == string_hash(hash_entry_key(entry))) && + (key_len == string_length(hash_entry_key(entry))) && /* 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(entry)), key_len))) + return(entry); + } + return(sc->unentry); +} + +#if !WITH_PURE_S7 +static s7_uint 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_uint hash_mask = hash_table_mask(table); + s7_uint hash = hash_map_ci_string(sc, table, key); + for (hash_entry_t *entry = hash_table_element(table, hash % hash_mask); entry; entry = hash_entry_next(entry)) + if (scheme_strequal_ci(key, hash_entry_key(entry))) + return(entry); + } + return(sc->unentry); +} +#endif + + +/* ---------------- hash eq? ---------------- */ +static s7_uint hash_map_nil(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(type(key));} + +static s7_uint 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_uint loc = pointer_map(key) % hash_table_mask(table); /* hash_map_eq */ + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (key == hash_entry_key(entry)) + return(entry); + return(sc->unentry); +} + +/* ---------------- hash eqv? ---------------- */ +static hash_entry_t *hash_eqv(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + hash_entry_t *entry; + const s7_uint loc = hash_loc(sc, table, key) % hash_table_mask(table); + if (is_number(key)) + { +#if WITH_GMP + for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (numbers_are_eqv(sc, key, hash_entry_key(entry))) + return(entry); +#else + uint8_t key_type = type(key); + for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if ((key_type == type(hash_entry_key(entry))) && + (numbers_are_eqv(sc, key, hash_entry_key(entry)))) + return(entry); +#endif + } + else + for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (s7_is_eqv(sc, key, hash_entry_key(entry))) + return(entry); + return(sc->unentry); +} + +/* ---------------- hash equal? ---------------- */ +static s7_uint 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. + */ + const 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); + const s7_int size = (s7_int)hash_table_size(key); + for (s7_int i = 0; i < size; i++) + for (hash_entry_t *entry = els[i]; entry; entry = hash_entry_next(entry)) + { + if (len == 1) + return(((is_sequence_or_iterator(hash_entry_key(entry))) ? 0 : hash_loc(sc, key, hash_entry_key(entry))) + + ((is_sequence_or_iterator(hash_entry_value(entry))) ? 0 : hash_loc(sc, key, hash_entry_value(entry)))); + if (!key1) + { + key1 = hash_entry_key(entry); + val1 = hash_entry_value(entry); + } + 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(entry))) ? 0 : hash_loc(sc, key, hash_entry_key(entry))) + + ((is_sequence_or_iterator(hash_entry_value(entry))) ? 0 : hash_loc(sc, key, hash_entry_value(entry)))); + }} + return(0); /* placate the compiler */ +} + +static s7_uint 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_uint 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_uint hash_map_float_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_uint loc1, loc2; + if (vector_length(key) == 0) return(0); + /* fprintf(stderr, "mask: %" lu64 ", val: %f, loc: %" lu64 "\n", mask, float_vector(key, 0), hash_float_location(float_vector(key, 0))); */ + loc1 = hash_float_location(float_vector(key, 0)); + /* fprintf(stderr, "%s[%d]: loc1: %" lu64 "\n", __func__, __LINE__, loc1); */ + if (vector_length(key) == 1) return(loc1); + loc2 = hash_float_location(float_vector(key, 1)); + return(vector_length(key) + loc1 + loc2); +} + +static s7_uint hash_map_complex_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_uint loc1, loc2; + if (vector_length(key) == 0) return(0); + loc1 = hash_complex_location(creal(complex_vector(key, 0))); + if (vector_length(key) == 1) return(loc1); + loc2 = hash_complex_location(creal(complex_vector(key, 1))); + return(vector_length(key) + loc1 + loc2); +} + +static s7_uint hash_map_vector(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_uint loc1, loc2; + if ((vector_length(key) == 0) || + (is_sequence_or_iterator(vector_element(key, 0)))) + return(vector_length(key)); + loc1 = hash_loc(sc, table, vector_element(key, 0)); + if ((vector_length(key) == 1) || + (is_sequence_or_iterator(vector_element(key, 1)))) + return(loc1); + loc2 = hash_loc(sc, table, vector_element(key, 1)); + return(vector_length(key) + loc1 + loc2); +} + + +static s7_uint hash_map_closure(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + const 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_uint 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_uint loc = hash_loc(sc, table, key) % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (hash_entry_key(entry) == key) + return(entry); + return(sc->unentry); +} + +#define hash_int_abs(x) ((x) >= 0 ? (x) : ((x == S7_INT64_MIN) ? S7_INT64_MAX : -(x))) + +static hash_entry_t *hash_equal_integer(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + const s7_int keyint = integer(key); + const s7_uint loc = hash_int_abs(keyint) % hash_table_mask(table); /* hash_loc -> hash_map_int */ + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + { + if ((is_t_integer(hash_entry_key(entry))) && + (keyint == integer(hash_entry_key(entry)))) + return(entry); +#if WITH_GMP + if ((is_t_big_integer(hash_entry_key(entry))) && + (mpz_cmp_si(big_integer(hash_entry_key(entry)), keyint) == 0)) + return(entry); +#endif + } + return(sc->unentry); +} + +static hash_entry_t *hash_equal_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + const s7_int keynum = numerator(key), keyden = denominator(key); + const s7_uint loc = s7_int_abs(keynum / keyden) % hash_table_mask(table); /* hash_loc -> hash_map_ratio */ + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + { + if ((is_t_ratio(hash_entry_key(entry))) && + (keynum == numerator(hash_entry_key(entry))) && + (keyden == denominator(hash_entry_key(entry)))) + return(entry); +#if WITH_GMP + if ((is_t_big_ratio(hash_entry_key(entry))) && + (keynum == mpz_get_si(mpq_numref(big_ratio(hash_entry_key(entry))))) && + (keyden == mpz_get_si(mpq_denref(big_ratio(hash_entry_key(entry)))))) + return(entry); +#endif + } + return(sc->unentry); +} + +static hash_entry_t *hash_equal_real(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_uint loc; + const 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 *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + { + if ((is_t_real(hash_entry_key(entry))) && + (keydbl == real(hash_entry_key(entry)))) + return(entry); +#if WITH_GMP + if ((is_t_big_real(hash_entry_key(entry))) && + (mpfr_cmp_d(big_real(hash_entry_key(entry)), keydbl) == 0) && + (!mpfr_nan_p(big_real(hash_entry_key(entry))))) + return(entry); +#endif + } + return(sc->unentry); +} + +static hash_entry_t *hash_equal_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + s7_uint loc; + const s7_double keyrl = real_part(key); + const 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 *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + { + if ((is_t_complex(hash_entry_key(entry))) && + (keyrl == real_part(hash_entry_key(entry))) && + (keyim == imag_part(hash_entry_key(entry)))) + return(entry); +#if WITH_GMP + if ((is_t_big_complex(hash_entry_key(entry))) && + (mpfr_cmp_d(mpc_realref(big_complex(hash_entry_key(entry))), keyrl) == 0) && + (mpfr_cmp_d(mpc_imagref(big_complex(hash_entry_key(entry))), keyim) == 0) && + (!mpfr_nan_p(mpc_realref(big_complex(hash_entry_key(entry))))) && + (!mpfr_nan_p(mpc_imagref(big_complex(hash_entry_key(entry)))))) + return(entry); +#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)]; + const s7_uint hash = hash_loc(sc, table, key); + const s7_uint loc = hash % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (key == hash_entry_key(entry)) /* avoid the equal funcs if possible -- this saves in both hash timing tests */ + return(entry); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if ((hash_entry_raw_hash(entry) == hash) && + (equal(sc, key, hash_entry_key(entry), NULL))) + return(entry); + return(sc->unentry); +} + + +/* ---------------- hash c_functions ---------------- */ +static s7_uint 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_uint hash_map_c_pointer(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return(pointer_map(c_pointer(key))); +} + +static s7_uint 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_uint 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))) + { + const s7_function f = c_function_call(hash_table_procedures_checker(table)); + const s7_uint hash = hash_loc(sc, table, key); + const s7_uint loc = hash % hash_table_mask(table); + set_car(sc->t2_1, key); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (hash_entry_raw_hash(entry) == hash) + { + set_car(sc->t2_2, hash_entry_key(entry)); + if (is_true(sc, f(sc, sc->t2_1))) + return(entry); + } + return(sc->unentry); + } + return(hash_equal(sc, table, key)); +} + +static int32_t len_upto_100(s7_pointer p) +{ + int32_t i = 0; + for (; (is_pair(p)) && (i < 100); i++, p = cdr(p)); + return(i); +} + +static s7_uint 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. + */ + const s7_pointer p1 = cdr(key); + s7_uint 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)); /* undefined sanitizer is unhappy here, hash_mask was not a solution */ +} + +static hash_entry_t *hash_closure(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + if (is_pair(hash_table_procedures(table))) + { + const s7_pointer f = hash_table_procedures_checker(table); + const s7_uint hash = hash_loc(sc, table, key); + const s7_uint loc = hash % hash_table_mask(table); + for (hash_entry_t *entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if ((hash_entry_raw_hash(entry) == hash) && + (is_true(sc, s7_call(sc, f, set_plist_2(sc, key, hash_entry_key(entry)))))) + return(entry); + 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 *entry; + s7_uint hash, loc; + + if (is_number(key)) + { +#if WITH_GMP + if (!is_nan_b_7p(sc, key)) + return(hash_number_equivalent(sc, table, key)); +#else + entry = hash_number_equivalent(sc, table, key); + if ((entry != sc->unentry) || (!is_nan_b_7p(sc, key))) + return(entry); +#endif + for (entry = hash_table_element(table, 0); entry; entry = hash_entry_next(entry)) /* NaN is mapped to 0 */ + if (is_nan_b_7p(sc, hash_entry_key(entry))) /* all NaN's are the same to equivalent? */ + return(entry); + return(sc->unentry); + } + hash = hash_loc(sc, table, key); + loc = hash % hash_table_mask(table); + for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (hash_entry_key(entry) == key) + return(entry); + + for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if ((hash_entry_raw_hash(entry) == hash) && + (s7_is_equivalent(sc, hash_entry_key(entry), key))) + return(entry); + 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; + if ((S7_DEBUGGING) && (size <= 1)) fprintf(stderr, "%s[%d]: hash-table size: %" ld64 "\n", __func__, __LINE__, size); + 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_pair(args)) + { + const s7_pointer len = car(args); + if (!s7_is_integer(len)) + return(method_or_bust(sc, len, caller, args, sc->type_names[T_INTEGER], 1)); + size = s7_integer_clamped_if_gmp(sc, len); + 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, len, wrap_string(sc, "it should be a positive integer", 31)); + if ((size > sc->max_vector_length) || + (size >= (1LL << 32LL))) /* s7test tests >= */ + out_of_range_error_nr(sc, caller, int_one, len, it_is_too_large_string); + + if (is_pair(cdr(args))) + { + s7_pointer proc; + const s7_pointer table = s7_make_hash_table(sc, size); + /* check for typers */ + if (is_pair(cddr(args))) + { + const s7_pointer typers = caddr(args); + if (is_pair(typers)) + { + const 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(table, make_hash_table_procedures(sc)); + hash_table_set_key_typer(table, keyp); + hash_table_set_value_typer(table, 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(table); + if (symbol_type(c_function_symbol(keyp)) != T_FREE) + set_has_hash_key_type(table); + /* 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(table); + if (symbol_type(c_function_symbol(valp)) != T_FREE) + set_has_hash_value_type(table); + } + 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(table); + }} + 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(table); + + 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(table) = hash_equal; + return(table); + } + if (c_function_call(proc) == g_is_equivalent) + { + hash_table_checker(table) = hash_equivalent; + hash_table_mapper(table) = equivalent_hash_map; /* needed only by hash_table_equal_1 (checker_locked looks at mapper?!) */ + return(table); + } + if (c_function_call(proc) == g_is_eq) + { + hash_table_checker(table) = hash_eq; + hash_table_mapper(table) = eq_hash_map; + return(table); + } + if (c_function_call(proc) == g_strings_are_equal) + { + hash_table_checker(table) = hash_string; + hash_table_mapper(table) = string_eq_hash_map; + return(table); + } +#if !WITH_PURE_S7 + if (c_function_call(proc) == g_strings_are_ci_equal) + { + hash_table_checker(table) = hash_ci_string; + hash_table_mapper(table) = string_ci_eq_hash_map; + return(table); + } + if (c_function_call(proc) == g_chars_are_ci_equal) + { + hash_table_checker(table) = hash_ci_char; + hash_table_mapper(table) = char_ci_eq_hash_map; + return(table); + } +#endif + if (c_function_call(proc) == g_chars_are_equal) + { + hash_table_checker(table) = hash_char; + hash_table_mapper(table) = char_eq_hash_map; + return(table); + } + if (c_function_call(proc) == g_num_eq) + { + if ((is_typed_hash_table(table)) && + (hash_table_key_typer(table) == global_value(sc->is_integer_symbol))) + hash_table_checker(table) = hash_int; + else hash_table_checker(table) = hash_number_num_eq; + return(table); + } + if (c_function_call(proc) == g_is_eqv) + { + hash_table_checker(table) = hash_eqv; + return(table); + } + 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)) + { + const s7_pointer checker = car(proc), mapper = cdr(proc); + + hash_set_chosen(table); + 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(table) = hash_c_function; + } + else hash_table_checker(table) = hash_closure; + + if (is_any_c_function(mapper)) + { + const 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(table) = c_function_hash_map; + } + else hash_table_mapper(table) = closure_hash_map; + + if (is_null(hash_table_procedures(table))) + hash_table_set_procedures(table, make_hash_table_procedures(sc)); + hash_table_set_procedures_checker(table, car(proc)); /* proc = cadr(args) */ + hash_table_set_procedures_mapper(table, cdr(proc)); + return(table); + } + 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(table); + }}} + 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); + if (is_hash_table(table)) /* (make-weak-hash-table (openlet (inlet 'make-weak-hash-table list))) ! */ + { + set_weak_hash_table(table); + weak_hash_iters(table) = 0; + } + return(table); +} + +static const char *hash_table_checker_name(s7_scheme *sc, s7_pointer table) +{ + if (hash_table_checker(table) == hash_equal) return("equal?"); + if (hash_table_checker(table) == hash_equivalent) return("equivalent?"); + if (hash_table_checker(table) == hash_eq) return("eq?"); + if (hash_table_checker(table) == hash_eqv) return("eqv?"); + if (hash_table_checker(table) == hash_string) return("string=?"); +#if !WITH_PURE_S7 + if (hash_table_checker(table) == hash_ci_string) return("string-ci=?"); + if (hash_table_checker(table) == hash_ci_char) return("char-ci=?"); +#endif + if (hash_table_checker(table) == hash_char) return("char=?"); + if (hash_table_checker(table) == 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_COMPLEX_VECTOR] = hash_map_complex_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; +} + +static void resize_hash_table(s7_scheme *sc, s7_pointer table) +{ + const s7_int entries = hash_table_entries(table); + hash_entry_t **old_els = hash_table_elements(table); + const s7_pointer dproc = hash_table_procedures(table); /* new block_t so we need to pass this across */ + const s7_uint old_size = hash_table_size(table); + const s7_uint new_size = old_size * 4; /* perhaps (old_size < 524288) ? (old_size * 4) : (old_size * 2) */ + const s7_uint hash_mask = new_size - 1; + block_t *np = (block_t *)callocate(sc, new_size * sizeof(hash_entry_t *)); + hash_entry_t **new_els = (hash_entry_t **)(block_data(np)); + hash_table_mask(table) = hash_mask; /* was new_size - 1 14-Jun-21 */ + for (s7_uint i = 0; i < old_size; i++) + { + hash_entry_t *n; + for (hash_entry_t *entry = old_els[i]; entry; entry = n) + { + s7_uint loc = hash_loc(sc, table, hash_entry_key(entry)); + hash_entry_set_raw_hash(entry, loc); + loc %= hash_mask; + n = hash_entry_next(entry); + hash_entry_next(entry) = new_els[loc]; + new_els[loc] = entry; + }} + liberate(sc, hash_table_block(table)); + hash_table_set_block(table, np); + hash_table_elements(table) = new_els; + hash_table_set_procedures(table, dproc); + hash_table_entries(table) = entries; +} + + +/* -------------------------------- 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 table = lookup_checked(sc, car(sc->code)); + if (!is_hash_table(table)) {sc->last_function = table; return(false);} + sc->value = s7_hash_table_ref(sc, table, 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 table = lookup_checked(sc, car(arg)); + if (!is_hash_table(table)) + return(s7_apply_function(sc, table, list_1(sc, fx_call(sc, cdr(arg))))); + return(s7_hash_table_ref(sc, table, fx_call(sc, cdr(arg)))); +} + +static bool op_implicit_hash_table_ref_aa(s7_scheme *sc) +{ + s7_pointer in_obj, out_key; + const 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 func, 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_class_and_fn_proc(key, sc->substring_uncopied); + return(sc->hash_table_ref_2); + } + return(func); +} + + +/* -------------------------------- hash-table-set! -------------------------------- */ +static s7_pointer remove_from_hash_table(s7_scheme *sc, s7_pointer table, const hash_entry_t *p) +{ + hash_entry_t *entry; + s7_uint loc; + + if (p == sc->unentry) return(missing_key_value(sc)); + loc = hash_entry_raw_hash(p) % hash_table_mask(table); + entry = hash_table_element(table, loc); + if (entry == p) + hash_table_element(table, loc) = hash_entry_next(entry); + else + { + hash_entry_t *y; + for (y = entry, entry = hash_entry_next(entry); entry; y = entry, entry = hash_entry_next(entry)) + if (entry == p) + { + hash_entry_next(y) = hash_entry_next(entry); + 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, entry); + return(sc->F); +} + +static void cull_weak_hash_table(s7_scheme *sc, s7_pointer table) +{ + const s7_int len = (s7_int)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 *entry = entries[i]; entry; entry = nxp) + { + nxp = hash_entry_next(entry); + if (is_free_and_clear(hash_entry_key(entry))) + { + if (entry == entries[i]) + { + entries[i] = nxp; + lxp = nxp; + } + else hash_entry_next(lxp) = nxp; + liberate_block(sc, entry); + 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 = entry; + }} +} + +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 + { + const s7_pointer key_func = hash_table_key_typer(table); + if (key_func != sc->T) + { + s7_pointer type_ok; + if (is_c_function(key_func)) + type_ok = c_function_call(key_func)(sc, set_plist_1(sc, key)); + else type_ok = s7_apply_function(sc, key_func, 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 + { + const s7_pointer value_func = hash_table_value_typer(table); + if (value_func != sc->T) + { + s7_pointer type_ok; + if (is_c_function(value_func)) + type_ok = c_function_call(value_func)(sc, set_plist_1(sc, value)); + else type_ok = s7_apply_function(sc, value_func, 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_uint hash_mask, loc; + hash_entry_t *entry; + + if (value == missing_key_value(sc)) /* normally #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); + + entry = (*hash_table_checker(table))(sc, table, key); + if (entry != sc->unentry) + { + hash_entry_set_value(entry, T_Ext(value)); + return(value); + } + /* hash_entry_raw_hash(entry) 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); + + entry = mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + hash_entry_key(entry) = key; + hash_entry_set_value(entry, T_Ext(value)); + hash_entry_set_raw_hash(entry, hash_loc(sc, table, key)); + hash_mask = hash_table_mask(table); + loc = hash_entry_raw_hash(entry) % hash_mask; + hash_entry_next(entry) = hash_table_element(table, loc); + hash_table_element(table, loc) = entry; + 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 table, s7_pointer key, s7_pointer value) +{ + if (!is_mutable_hash_table(table)) /* is_hash_table(p1) is here */ + return(mutable_method_or_bust_ppp(sc, table, sc->hash_table_set_symbol, table, key, value, sc->type_names[T_HASH_TABLE], 1)); + return(s7_hash_table_set(sc, table, key, value)); +} + +static s7_pointer hash_table_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if ((args == 3) && (optimize_op(expr) == HOP_SAFE_C_SSA)) + { + const 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(func); +} + + +/* -------------------------------- hash-table -------------------------------- */ +static inline s7_pointer hash_table_add(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) +{ + const s7_uint hash_mask = hash_table_mask(table); + const s7_uint hash = hash_loc(sc, table, key); + const s7_uint loc = hash % hash_mask; + hash_entry_t *entry; + + 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 */ + + for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if ((hash_entry_raw_hash(entry) == hash) && + (s7_is_equal(sc, hash_entry_key(entry), key))) + return(value); + + entry = mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + hash_entry_key(entry) = key; + hash_entry_set_value(entry, T_Ext(value)); + hash_entry_set_raw_hash(entry, hash); + hash_entry_next(entry) = hash_table_element(table, loc); + hash_table_element(table, loc) = entry; + 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_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))); + { + s7_pointer table = 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) != missing_key_value(sc)) + hash_table_add(sc, table, car(x), car(y)); + return(table); + } +} + +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 table = s7_make_hash_table(sc, sc->default_hash_table_length); + if (cadr(args) != missing_key_value(sc)) /* #f default */ + hash_table_add(sc, table, car(args), cadr(args)); + return(table); +} + + +/* -------------------------------- 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 func, int32_t args, s7_pointer unused_expr) +{ + return((args == 2) ? sc->hash_table_2 : func); +} + +static void check_old_table(s7_scheme *sc, s7_pointer old_table, s7_pointer new_table, s7_int start, s7_int end) +{ + s7_int count = 0; + const s7_int old_len = (s7_int)hash_table_size(old_table); + hash_entry_t **old_lists = hash_table_elements(old_table); + for (s7_int i = 0; i < old_len; i++) + for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry)) + { + if (count >= end) + return; + if (count >= start) + check_hash_types(sc, new_table, hash_entry_key(entry), hash_entry_value(entry)); + } +} + +static s7_pointer hash_table_copy(s7_scheme *sc, s7_pointer old_table, s7_pointer new_table, s7_int start, s7_int end) +{ + const s7_uint old_len = hash_table_size(old_table); + const s7_uint new_mask = hash_table_mask(new_table); + s7_int count = 0; + hash_entry_t **old_lists, **new_lists; + + if (is_typed_hash_table(new_table)) + check_old_table(sc, old_table, new_table, start, end); + + old_lists = hash_table_elements(old_table); + new_lists = hash_table_elements(new_table); + + if (hash_table_entries(new_table) == 0) + { + if ((start == 0) && + ((s7_uint)end >= hash_table_entries(old_table))) + { + if (old_len == hash_table_size(new_table)) + { + for (s7_uint i = 0; i < old_len; i++) + for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry)) + { + hash_entry_t *p = (hash_entry_t *)mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + memcpy((void *)p, (const void *)entry, sizeof(block_t)); + hash_entry_next(p) = new_lists[i]; + new_lists[i] = p; + }} + else + for (s7_uint i = 0; i < old_len; i++) + for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry)) + { + s7_uint loc = hash_entry_raw_hash(entry) % new_mask; + hash_entry_t *p = make_hash_entry(sc, hash_entry_key(entry), hash_entry_value(entry), hash_entry_raw_hash(entry)); + hash_entry_next(p) = new_lists[loc]; + new_lists[loc] = p; + } + hash_table_entries(new_table) = hash_table_entries(old_table); + return(new_table); + } + for (s7_uint i = 0; i < old_len; i++) + for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry)) + { + if (count >= end) + { + hash_table_entries(new_table) = end - start; + return(new_table); + } + if (count >= start) + { + s7_uint loc = hash_entry_raw_hash(entry) % new_mask; + hash_entry_t *p = make_hash_entry(sc, hash_entry_key(entry), hash_entry_value(entry), hash_entry_raw_hash(entry)); + hash_entry_next(p) = new_lists[loc]; + new_lists[loc] = p; + } + count++; + } + hash_table_entries(new_table) = count - start; + return(new_table); + } + /* this can't be optimized much because we have to look for key matches (we're copying old_table into the existing, non-empty new_table) */ + for (s7_uint i = 0; i < old_len; i++) + for (hash_entry_t *entry = old_lists[i]; entry; entry = hash_entry_next(entry)) + { + if (count >= end) + return(new_table); + if (count >= start) + { + hash_entry_t *y = (*hash_table_checker(new_table))(sc, new_table, hash_entry_key(entry)); + if (y != sc->unentry) + hash_entry_set_value(y, hash_entry_value(entry)); + else + { + const s7_uint loc = hash_entry_raw_hash(entry) % new_mask; + hash_entry_t *p = make_hash_entry(sc, hash_entry_key(entry), hash_entry_value(entry), hash_entry_raw_hash(entry)); + hash_entry_next(p) = new_lists[loc]; + new_lists[loc] = p; + hash_table_entries(new_table)++; + if (!hash_chosen(new_table)) + hash_table_set_default_checker(new_table, type(hash_entry_key(entry))); + }} + count++; + } + return(new_table); +} + +static s7_pointer hash_table_fill(s7_scheme *sc, s7_pointer args) +{ + const 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); + const s7_int len = (s7_int)hash_table_size(table); /* minimum len is 2 (see s7_make_hash_table) */ + if (val == missing_key_value(sc)) /* hash-table-ref returns #f (the default) 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) + { + /* save top of entry list, go to end, point end->next at block_list top, reset top to entry_list top -> liberate entire list */ + hash_entry_t *entry = *hp; +#if S7_DEBUGGING + sc->blocks_freed[BLOCK_LIST]++; + while (hash_entry_next(entry)) {entry = hash_entry_next(entry); sc->blocks_freed[BLOCK_LIST]++;} +#else + while (hash_entry_next(entry)) entry = hash_entry_next(entry); +#endif + hash_entry_next(entry) = sc->block_lists[BLOCK_LIST]; + sc->block_lists[BLOCK_LIST] = *hp; + } + hp++; + if (*hp) + { + hash_entry_t *entry = *hp; +#if S7_DEBUGGING + sc->blocks_freed[BLOCK_LIST]++; + while (hash_entry_next(entry)) {entry = hash_entry_next(entry); sc->blocks_freed[BLOCK_LIST]++;} +#else + while (hash_entry_next(entry)) entry = hash_entry_next(entry); +#endif + hash_entry_next(entry) = 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 *entry = entries[i]; entry; entry = hash_entry_next(entry)) + hash_entry_set_value(entry, 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_table) +{ + const s7_int len = (s7_int)hash_table_size(old_table); + hash_entry_t **old_lists = hash_table_elements(old_table); + const s7_pointer new_table = s7_make_hash_table(sc, len); + gc_protect_via_stack(sc, new_table); + + /* old_table 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 *entry = old_lists[i]; entry; entry = hash_entry_next(entry)) + s7_hash_table_set(sc, new_table, hash_entry_value(entry), hash_entry_key(entry)); + + if (is_weak_hash_table(old_table)) /* 17-May-23, not sure it makes sense to reverse a weak-hash-table but... */ + { + set_weak_hash_table(new_table); + weak_hash_iters(new_table) = 0; + } + unstack_gc_protect(sc); + return(new_table); +} + + +/* -------------------------------- functions -------------------------------- */ +bool s7_is_function(s7_pointer p) {return(is_c_function(p));} + +static s7_pointer fallback_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) {return(func);} + +static void s7_function_set_class(s7_scheme *sc, s7_pointer func, s7_pointer base_f) +{ + c_function_class(func) = c_function_class(base_f); + c_function_set_base(func, base_f); +} + +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; + } +#if S7_DEBUGGING + sc->c_functions_allocated++; /* this probably is the same as sc->f_class (c_function_class) */ +#endif + return(&(sc->alloc_function_cells[sc->alloc_function_k++])); +} + +static s7_pointer make_c_function(s7_scheme *sc, const char *name, s7_function f, s7_int req, s7_int opt, bool rst, const char *doc) /* called only in s7_make_function */ +{ + const s7_pointer func = (s7_pointer)alloc_pointer(sc); + set_full_type(func, ((req == 0) && (rst)) ? T_C_RST_NO_REQ_FUNCTION : T_C_FUNCTION); + + c_function_data(func) = alloc_semipermanent_function(sc); + c_function_call(func) = f; /* f is T_App but needs cast */ + c_function_set_base(func, func); + c_function_set_setter(func, sc->F); + if (name) + { + c_function_name(func) = name; /* (procedure-name proc) => (format #f "~A" proc) */ + c_function_name_length(func) = safe_strlen(name); + c_function_set_symbol(func, make_symbol(sc, name, c_function_name_length(func))); /* T_C_FUNCTION_STAR may set later to args */ + } + else + { + c_function_name(func) = NULL; + c_function_name_length(func) = 0; + c_function_set_symbol(func, sc->anon_symbol); + } + c_function_documentation(func) = (doc) ? make_semipermanent_c_string(sc, doc) : NULL; + c_function_set_signature(func, sc->F); + c_function_min_args(func) = req; + c_function_optional_args(func) = opt; /* T_C_FUNCTION_STAR type may be set later, so T_Fst not usable here */ + c_function_max_args(func) = (rst) ? MAX_ARITY : req + opt; + c_function_class(func) = ++sc->f_class; + c_function_chooser(func) = fallback_chooser; + c_function_opt_data(func) = NULL; + c_function_marker(func) = NULL; + c_function_set_let(func, sc->rootlet); + /* this is not the same as the let in (let (...) (lambda ...)) and can't be used that way. The first problem is that in "f" (the s7_function above), + * there is no way to tell which "func" (the current c_function object) caused it to be invoked. The call is of the form (c_function_call(func))(sc, ...). + * Since this usage is very unusual, I don't want to glom up every c_function call with a wrapper that sets/restores the c_function_let. + * The next is that it's easy to call s7_eval_c_string(sc, "(let (...) (lambda ...))" creating a real closure where the let is handled throughout s7. + * The third is that if you're using this style to create generators, use a c-object or iterator to hold the state; the "func" currently is allocated + * in semipermanent memory (see below), so (as throughout c_functions), the assumption is that these are not garbage collected. c_function_let is + * for *function* (find_let) primarily. Maybe if let is not rootlet (see below), pass heap memory? But then we need to free the function data. + * Also if the let is local, it needs to be GC protected by the caller. + */ + return(func); +} + +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 func = make_c_function(sc, name, f, required_args, optional_args, rest_arg, doc); + unheap(sc, func); + return(func); +} + +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 func = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, doc); + set_type_bit(func, T_SAFE_PROCEDURE); + return(func); +} + +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_set_signature(func, signature); + return(func); +} + +s7_pointer s7_make_typed_function_with_environment(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 let) +{ + s7_pointer func = s7_make_typed_function(sc, name, f, required_args, optional_args, rest_arg, doc, signature); + c_function_set_let(func, let); + return(func); +} + + +/* -------------------------------- procedure? -------------------------------- */ +bool s7_is_procedure(s7_pointer obj) {return(is_procedure(obj));} + +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)))); +} + +#if !DISABLE_DEPRECATED +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_pars(p) : sc->nil);} +#endif +s7_pointer s7_lambda_body(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_body(p) : sc->nil);} +s7_pointer s7_lambda_let(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_let(p) : sc->rootlet);} +s7_pointer s7_lambda_parameters(s7_scheme *sc, s7_pointer p) {return((has_closure_let(p)) ? closure_pars(p) : sc->nil);} + + +/* -------------------------------- procedure-arglist -------------------------------- */ +static s7_pointer g_procedure_arglist(s7_scheme *sc, s7_pointer args) +{ + #define H_procedure_arglist "(procedure-arglist func) returns func's arglist" + #define Q_procedure_arglist s7_make_signature(sc, 2, \ + s7_make_signature(sc, 2, sc->is_list_symbol, sc->is_symbol_symbol), \ + s7_make_signature(sc, 2, sc->is_procedure_symbol, sc->is_macro_symbol)) + s7_pointer func = car(args); + if (has_closure_let(func)) return(s7_copy(sc, set_plist_1(sc, closure_pars(func)))); /* closure_pars can be a symbol: (define (f1 . a) a) */ + if_method_exists_return_value(sc, func, sc->procedure_arglist_symbol, set_plist_1(sc, func)); + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "procedure-arglist argument, ~S, is not a scheme function", 56), func)); + return(sc->nil); /* never hit */ +} + + +/* -------------------------------- 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 func = car(args); + + if ((is_symbol(func)) && ((func = s7_symbol_value(sc, func)) == sc->undefined)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "procedure-source arg, '~S, is unbound", 37), func)); + if ((is_c_function(func)) || (is_c_macro(func))) + return(sc->nil); + + if_method_exists_return_value(sc, func, sc->procedure_source_symbol, set_plist_1(sc, func)); + if (has_closure_let(func)) + { + s7_pointer body = closure_body(func); + /* 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(func)), closure_pars(func)), body)); + } + if (!is_procedure(func)) + sole_arg_wrong_type_error_nr(sc, sc->procedure_source_symbol, func, 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) /* does the env parameter make any sense? */ +{ + #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, has_let_signature(sc), 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)) + { + s7_pointer new_let = find_let(sc, e); /* ?? not sure this makes sense */ + if (!is_let(new_let)) + find_let_error_nr(sc, sc->_function__symbol, e, new_let, 1, args); + e = new_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_pars(fval)); + return(sc->F); +} + + +/* -------------------------------- funclet -------------------------------- */ +s7_pointer s7_funclet(s7_scheme *sc, s7_pointer func) {return((has_closure_let(func)) ? closure_let(func) : sc->rootlet);} /* c_function_let(func)?? */ + +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 func = car(args); + if (is_symbol(func)) + { + if ((func = s7_symbol_value(sc, func)) == 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 func here */ + } + if_method_exists_return_value(sc, func, sc->funclet_symbol, args); + if (!((is_any_procedure(func)) || (is_c_object(func)))) + sole_arg_wrong_type_error_nr(sc, sc->funclet_symbol, func, a_procedure_or_a_macro_string); + return(find_let(sc, func)); +} + + +/* -------------------------------- s7_define_function and friends -------------------------------- + * + * all c_func* are semipermanent, but they might be local: (let () (load "libm.scm" (curlet)) ...) + */ + +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 = T_Sym(c_function_symbol(func)); + 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 = T_Sym(c_function_symbol(func)); + 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 = T_Sym(c_function_symbol(func)); + 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; + const s7_pointer func = s7_make_typed_function(sc, name, fnc, 1, optional_args, false, doc, signature); /* includes "safe" bit */ + const s7_pointer sym = T_Sym(c_function_symbol(func)); + s7_define(sc, sc->rootlet, sym, func); + if (sym_to_type != T_FREE) symbol_set_type(sym, sym_to_type); + 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 = T_Sym(c_function_symbol(func)); + if (signature) c_function_set_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 = T_Sym(c_function_symbol(func)); + if (signature) c_function_set_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; + const s7_int len = safe_strlen(arglist); + s7_int gc_loc, n_args; + 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, NULL, fnc, 0, n_args, false, doc); /* null name to turn off the c_function_symbol stuff */ + c_function_name(func) = name; /* (procedure-name proc) => (format #f "~A" proc) */ + c_function_name_length(func) = safe_strlen(name); + + 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); /* mark that the defaults need GC protection */ + /* (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++) + { + const 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)); /* ?? this is the default expr */ + 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); /* can't use c_function_symbol here (clobbered by c_function* args) */ + if (signature) c_function_set_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 = T_Sym(c_function_symbol(func)); + 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); +} + +s7_pointer s7_define_expansion(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 = T_Sym(c_function_symbol(func)); + set_full_type(func, T_C_MACRO | T_EXPANSION | T_DONT_EVAL_ARGS | T_UNHEAP); /* s7_make_function includes T_UNHEAP */ + s7_define(sc, sc->rootlet, sym, func); + set_full_type(sym, full_type(sym) | T_EXPANSION); + return(sym); +} + + +/* -------------------------------- macro? -------------------------------- */ +bool s7_is_macro(s7_scheme *sc, s7_pointer mac) {return(is_any_macro(mac));} +static bool is_macro_b(s7_pointer mac) {return(is_any_macro(mac));} + +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_pars(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 obj) +{ + s7_pointer val; + if (is_symbol(obj)) + { + if (is_keyword(obj)) return(NULL); + if (symbol_has_help(obj)) + return(symbol_help(obj)); + obj = s7_symbol_value(sc, obj); /* this is needed by Snd */ + } + if ((is_any_c_function(obj)) || + (is_c_macro(obj))) + return((const char *)c_function_documentation(obj)); + + if (is_syntax(obj)) + return(syntax_documentation(obj)); + + val = funclet_entry(sc, obj, sc->local_documentation_symbol); + if ((val) && (is_string(val))) + return(string_value(val)); + + if (has_closure_let(obj)) + { + val = closure_body(obj); + 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 obj = car(args); + if (is_symbol(obj)) + { + if ((symbol_has_help(obj)) && + (is_defined_global(obj))) + return(s7_make_string(sc, symbol_help(obj))); + obj = s7_symbol_value(sc, obj); + } + /* (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(obj)) + { + s7_pointer func = funclet_entry(sc, obj, sc->documentation_symbol); + if (func) + return(s7_apply_function(sc, func, args)); + func = closure_body(obj); + 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) */ + if_method_exists_return_value(sc, obj, sc->documentation_symbol, args); + return(s7_make_string(sc, s7_documentation(sc, obj))); +} + +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->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->not_symbol), sc->T) + const char *doc; + if_method_exists_return_value(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->complex_vector_signature = s7_make_circular_signature(sc, 2, 3, sc->is_complex_symbol, sc->is_complex_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->not_symbol), sc->T) + + s7_pointer obj = car(args); + switch (type(obj)) + { + 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(obj)); + + 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, obj, sc->local_signature_symbol); + if (func) return(func); + func = funclet_entry(sc, obj, sc->signature_symbol); + return((func) ? s7_apply_function(sc, func, args) : sc->F); + } + + case T_VECTOR: + if (vector_length(obj) == 0) return(sc->F); /* sig () is #f so sig #() should be #f */ + if (!is_typed_vector(obj)) + return(sc->vector_signature); + { + s7_pointer lst = list_3(sc, typed_vector_typer_symbol(sc, obj), sc->is_vector_symbol, sc->is_integer_symbol); + set_cdddr(lst, cddr(lst)); + return(lst); + } + + case T_FLOAT_VECTOR: return((vector_length(obj) == 0) ? sc->F : sc->float_vector_signature); + case T_COMPLEX_VECTOR: return((vector_length(obj) == 0) ? sc->F : sc->complex_vector_signature); + case T_INT_VECTOR: return((vector_length(obj) == 0) ? sc->F : sc->int_vector_signature); + case T_BYTE_VECTOR: return((vector_length(obj) == 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(obj)) + return(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)))); + return(sc->hash_table_signature); + + case T_ITERATOR: + obj = iterator_sequence(obj); + if ((is_hash_table(obj)) || (is_let(obj))) /* cons returned -- would be nice to include the car/cdr types if known */ + return(list_1(sc, sc->is_pair_symbol)); + obj = g_signature(sc, set_plist_1(sc, obj)); + return(list_1(sc, (is_pair(obj)) ? car(obj) : sc->T)); + + case T_C_OBJECT: + if_c_object_method_exists_return_value(sc, obj, sc->signature_symbol, args); + return(sc->c_object_signature); + + case T_LET: + if_let_method_exists_return_value(sc, obj, 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, obj); + if ((is_slot(slot)) && (slot_has_setter(slot))) + { + s7_pointer setter = slot_setter(slot); + obj = g_signature(sc, set_plist_1(sc, setter)); + if (is_pair(obj)) + return(list_1(sc, car(obj))); + }} + 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 obj) +{ + s7_pointer body; + if (!is_closure(obj)) return(obj); + body = closure_body(obj); + if (is_pair(cdr(body))) return(obj); + if (!is_pair(car(body))) return(sc->F); + return((is_quote(caar(body))) ? sc->F : obj); +} + +static s7_pointer make_baffled_closure(s7_scheme *sc, s7_pointer old_func) +{ + /* for dynamic-wind to protect initial and final functions from call/cc */ + s7_pointer new_func = make_closure_unchecked(sc, sc->nil, closure_body(old_func), type(old_func), 0); /* always preceded by new dw cell */ + s7_pointer let = make_let(sc, closure_let(old_func)); /* let_outlet(let) = closure_let(old_func) */ + set_baffle_let(let); + let_set_baffle_key(let, sc->baffle_ctr++); + closure_set_let(new_func, let); + return(new_func); +} + +static bool is_dwind_thunk(s7_scheme *sc, s7_pointer obj) +{ + switch (type(obj)) + { + 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_pars(obj))); /* 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(obj, 0)); + case T_C_MACRO: + return(c_macro_min_args(obj) == 0); + case T_C_FUNCTION_STAR: case T_GOTO: case T_CONTINUATION: case T_C_RST_NO_REQ_FUNCTION: + return(true); + } + return(obj == sc->F); /* (dynamic-wind #f (lambda () 3) #f) */ +} + +static s7_pointer g_dynamic_wind_unchecked(s7_scheme *sc, s7_pointer args) +{ + s7_pointer dw, init_func, final_func; + + new_cell(sc, dw, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */ + dynamic_wind_in(dw) = closure_or_f(sc, car(args)); + dynamic_wind_body(dw) = cadr(args); + dynamic_wind_out(dw) = closure_or_f(sc, caddr(args)); + push_stack(sc, OP_DYNAMIC_WIND, sc->nil, dw); /* args will be the saved result, code = s7_dynwind_t obj */ + /* do this push_stack early to protect p from allocations in make_baffled_closure */ + init_func = dynamic_wind_in(dw); + if ((is_any_closure(init_func)) && (!is_safe_closure(init_func))) /* wrap this use of init_func in a with-baffle */ + dynamic_wind_in(dw) = make_baffled_closure(sc, init_func); + + final_func = dynamic_wind_out(dw); + if ((is_any_closure(final_func)) && (!is_safe_closure(final_func))) + dynamic_wind_out(dw) = make_baffled_closure(sc, final_func); + + /* 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. + */ + if (init_func != sc->F) + { + dynamic_wind_state(dw) = dwind_init; + push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(dw)); + } + else + { + dynamic_wind_state(dw) = dwind_body; + push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_body(dw)); + } + return(sc->F); +} + +static s7_pointer g_dynamic_wind_init(s7_scheme *sc, s7_pointer args) +{ + s7_pointer dw; + const s7_pointer init_func = closure_or_f(sc, car(args)); + new_cell(sc, dw, T_DYNAMIC_WIND); /* don't mark car/cdr, don't copy */ + dynamic_wind_in(dw) = init_func; + dynamic_wind_body(dw) = cadr(args); + dynamic_wind_out(dw) = sc->F; + if ((is_any_closure(init_func)) && (!is_safe_closure(init_func))) /* wrap this use of init_func in a with-baffle */ + dynamic_wind_in(dw) = make_baffled_closure(sc, init_func); + push_stack(sc, OP_DYNAMIC_WIND, sc->nil, dw); /* args will be the saved result, code = s7_dynwind_t obj */ + dynamic_wind_state(dw) = dwind_init; + push_stack(sc, OP_APPLY, sc->nil, dynamic_wind_in(dw)); + 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) && (is_global(sym))); /* do we need (!sc->in_with_let) ? */ +} + +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 func, 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(func); +} + +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 dw; + push_stack_direct(sc, OP_EVAL_DONE); /* this is ok because we have called setjmp etc */ + sc->args = sc->nil; + new_cell(sc, dw, T_DYNAMIC_WIND); + dynamic_wind_in(dw) = T_Ext(init); + dynamic_wind_body(dw) = T_Ext(body); + dynamic_wind_out(dw) = T_Ext(finish); + push_stack(sc, OP_DYNAMIC_WIND, sc->nil, dw); + if (init != sc->F) + { + dynamic_wind_state(dw) = dwind_init; + sc->code = init; + } + else + { + dynamic_wind_state(dw) = 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) +{ + const 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) +{ + const 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)); +} + +static no_return 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, + set_ulist_1(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);} + + +/* -------------------------------- c-object-type -------------------------------- */ +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 cobj = car(args); + if (!is_c_object(cobj)) + { + if (!has_active_methods(sc, cobj)) + sole_arg_wrong_type_error_nr(sc, sc->c_object_type_symbol, cobj, sc->type_names[T_C_OBJECT]); + return(find_and_apply_method(sc, cobj, sc->c_object_type_symbol, args)); + } + return(make_integer(sc, c_object_type(cobj))); /* this is the c_object_types table index = tag */ +} + +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; + const 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_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; +} + +/* the next three functions would ideally be deprecated, but much old code depends on them (they were accidentally documented forever) */ +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_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; +} + + +/* -------------------------------- c-object-let -------------------------------- */ +s7_pointer s7_c_object_let(s7_pointer obj) {return(c_object_let(obj));} + +static s7_pointer g_c_object_let(s7_scheme *sc, s7_pointer args) +{ + #define H_c_object_let "(c-object-let obj) returns the c_object's local let, if any." + #define Q_c_object_let s7_make_signature(sc, 2, sc->is_let_symbol, sc->is_c_object_symbol) + + s7_pointer cobj = car(args); + if (!is_c_object(cobj)) + { + if (!has_active_methods(sc, cobj)) + sole_arg_wrong_type_error_nr(sc, sc->c_object_let_symbol, cobj, sc->type_names[T_C_OBJECT]); + return(find_and_apply_method(sc, cobj, sc->c_object_let_symbol, args)); + } + return(c_object_let(cobj)); +} + +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 g_c_object_set_let(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer obj = car(args), e = cadr(args); + if (is_immutable(obj)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set ~S's let: it is immutable", 35), obj)); + if (!is_let(e)) + wrong_type_error_nr(sc, make_symbol(sc, "#", 19), 2, e, sc->type_names[T_LET]); + c_object_set_let(obj, e); + return(e); +} + + +/* -------------------------------- c-object-set -------------------------------- */ +static s7_pointer g_c_object_set(s7_scheme *sc, s7_pointer args) /* called in sc->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)); +} + +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 obj; + new_cell(sc, obj, sc->c_object_types[type]->outer_type); + /* c_object_info(obj) = &(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(obj) = type; + c_object_value(obj) = value; + c_object_set_let(obj, T_Let(let)); + c_object_sc(obj) = sc; + if (with_gc) add_c_object(sc, obj); + return(obj); +} + +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)); +} + +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 result = (*(c_object_len(sc, obj)))(sc, set_clist_1(sc, obj)); + if (s7_is_integer(result)) + return(s7_integer_clamped_if_gmp(sc, result)); + return(-1); +} + +static s7_pointer copy_c_object(s7_scheme *sc, s7_pointer args) +{ + s7_pointer obj = car(args); + if_c_object_method_exists_return_value(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) +{ + const 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) +{ + const s7_pointer cobj = lookup_checked(sc, car(sc->code)); + if (!is_c_object(cobj)) {sc->last_function = cobj; return(false);} + set_car(sc->t2_2, fx_call(sc, cdr(sc->code))); + set_car(sc->t2_1, cobj); /* fx_call above might use sc->t2* */ + sc->value = (*(c_object_ref(sc, cobj)))(sc, sc->t2_1); + return(true); +} + +static s7_pointer fx_implicit_c_object_ref_a(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer cobj = lookup_checked(sc, car(arg)); + if (!is_c_object(cobj)) + return(s7_apply_function(sc, cobj, list_1(sc, fx_call(sc, cdr(arg))))); + set_car(sc->t2_2, fx_call(sc, cdr(arg))); + set_car(sc->t2_1, cobj); /* fx_call above might use sc->t2* */ + return((*(c_object_ref(sc, cobj)))(sc, sc->t2_1)); +} + +/* We could add implicit c-pointer ref/set referring to its let, but that seems confusing -- c-object-ref|set! would be different */ + + +/* -------- 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, "#", (const char *)NULL); /* was using #\[, 4-June-25 */ + get_func = s7_make_safe_function(sc, name, getter, get_req_args, get_opt_args, false, documentation); + s7_define(sc, T_Let(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->rootlet, 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_set_signature(get_func, get_sig); + if (set_sig) c_function_set_signature(set_func, set_sig); + return(get_func); +} + + +/* -------------------------------- dilambda? -------------------------------- */ +bool s7_is_dilambda(s7_pointer func) +{ + if (has_closure_let(func)) + return(is_any_procedure(closure_setter_or_map_list(func))); /* type >= T_CLOSURE (excludes goto/continuation) */ + if (is_any_c_function(func)) + return(is_any_procedure(c_function_setter(func))); /* type >= T_C_FUNCTION_STAR */ + if (is_c_macro(func)) + return(is_any_procedure(c_macro_setter(func))); + 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) + + const s7_pointer getter = car(args), setter = cadr(args); + if (!is_any_procedure(getter)) + wrong_type_error_nr(sc, sc->dilambda_symbol, 1, getter, a_procedure_or_a_macro_string); + 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 clo, s7_pointer clo_args) +{ + /* clo_args is unprocessed -- it is exactly the list as used in the closure[*] definition */ + int32_t len; + if (is_symbol(clo_args)) /* any number of args is ok */ + return(cons(sc, int_zero, max_arity)); + if (closure_arity_unknown(clo)) + closure_set_arity(clo, s7_list_length(sc, clo_args)); + len = closure_arity(clo); + 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 clo, s7_pointer args) +{ + if (closure_arity_unknown(clo)) + { + if (is_null(args)) + closure_set_arity(clo, 0); + else + if ((is_symbol(args)) || (allows_other_keys(args))) + closure_set_arity(clo, -1); + else + { + s7_pointer pars; + int32_t i; + for (i = 0, pars = args; is_pair(pars); i++, pars = cdr(pars)) /* is_pair(pars) so (f1 a . b) will end with b not null */ + if (car(pars) == sc->rest_keyword) + break; + closure_set_arity(clo, ((is_null(pars)) ? i : -1)); /* see below */ + }} +} + +static s7_pointer closure_star_arity_to_cons(s7_scheme *sc, s7_pointer clo, s7_pointer clo_args) +{ + closure_star_arity_1(sc, clo, clo_args); + return((closure_arity(clo) == -1) ? cons(sc, int_zero, max_arity) : cons(sc, int_zero, make_integer(sc, closure_arity(clo)))); +} + +static int32_t closure_arity_to_int(s7_scheme *sc, s7_pointer clo) +{ + /* not lambda* here */ + if (closure_arity_unknown(clo)) + { + int32_t i; + s7_pointer pars = closure_pars(clo); + for (i = 0; is_pair(pars); i++, pars = cdr(pars)) {}; + if (is_null(pars)) + closure_set_arity(clo, i); + else + { + if (i == 0) + return(-1); + closure_set_arity(clo, -i); + }} + return(closure_arity(clo)); +} + +static int32_t closure_star_arity_to_int(s7_scheme *sc, s7_pointer clo) +{ + /* not lambda here */ + closure_star_arity_1(sc, clo, closure_pars(clo)); + return(closure_arity(clo)); +} + +s7_pointer s7_arity(s7_scheme *sc, s7_pointer clo) +{ + switch (type(clo)) + { + case T_C_FUNCTION: + return(cons(sc, make_integer(sc, c_function_min_args(clo)), make_integer_unchecked(sc, c_function_max_args(clo)))); + case T_C_RST_NO_REQ_FUNCTION: + return(cons(sc, int_zero, max_arity)); + case T_C_FUNCTION_STAR: + return(cons(sc, int_zero, make_integer(sc, c_function_max_args(clo)))); + case T_MACRO: case T_BACRO: case T_CLOSURE: + return(closure_arity_to_cons(sc, clo, closure_pars(clo))); + case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR: + return(closure_star_arity_to_cons(sc, clo, closure_pars(clo))); + case T_C_MACRO: + return(cons(sc, make_integer(sc, c_macro_min_args(clo)), make_integer_unchecked(sc, c_macro_max_args(clo)))); + case T_GOTO: case T_CONTINUATION: + return(cons(sc, int_zero, max_arity)); + case T_STRING: + return((string_length(clo) == 0) ? sc->F : cons(sc, int_one, int_one)); + case T_LET: + return(cons(sc, int_one, int_one)); + case T_C_OBJECT: + if_c_object_method_exists_return_value(sc, clo, sc->arity_symbol, set_plist_1(sc, clo)); + return((is_safe_procedure(clo)) ? cons(sc, int_zero, max_arity) : sc->F); + case T_VECTOR: + if (vector_length(clo) == 0) return(sc->F); + if (has_simple_elements(clo)) return(cons(sc, int_one, make_integer(sc, vector_rank(clo)))); + return(cons(sc, int_one, max_arity)); + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + return((vector_length(clo) == 0) ? sc->F : cons(sc, int_one, make_integer(sc, vector_rank(clo)))); + 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(clo)), (syntax_max_args(clo) == MAX_ARITY) ? max_arity : small_int(syntax_max_args(clo)))); + } + return(sc->F); +} + +static s7_pointer g_arity(s7_scheme *sc, s7_pointer args) /* arity-uncopied could use sc->ulist */ +{ + #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) + /* if_method_exists_return_value(sc, p, sc->arity_symbol, args); */ + return(s7_arity(sc, car(args))); +} + + +/* -------------------------------- aritable? -------------------------------- */ +static bool closure_is_aritable(s7_scheme *sc, s7_pointer clo, s7_pointer clo_args, int32_t args) +{ + /* clo_args is unprocessed -- it is exactly the list as used in the closure definition */ + s7_int len; + if (args == 0) return(!is_pair(clo_args)); + if (is_symbol(clo_args)) return(true); /* any number of args is ok */ + len = closure_arity(clo); + if (len == CLOSURE_ARITY_NOT_SET) + { + len = s7_list_length(sc, clo_args); + closure_set_arity(clo, 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 clo, s7_pointer clo_args, int32_t args) +{ + if (is_symbol(clo_args)) + return(true); + closure_star_arity_1(sc, clo, clo_args); + return((closure_arity(clo) == -1) || (args <= closure_arity(clo))); +} + +bool s7_is_aritable(s7_scheme *sc, s7_pointer clo, s7_int args) +{ + switch (type(clo)) + { + case T_C_FUNCTION: + return(c_function_is_aritable(clo, args)); + case T_C_RST_NO_REQ_FUNCTION: + if (has_even_args(clo)) return((args & 1) == 0); + return(true); + case T_C_FUNCTION_STAR: + return(c_function_max_args(clo) >= args); + case T_MACRO: case T_BACRO: case T_CLOSURE: + return(closure_is_aritable(sc, clo, closure_pars(clo), args)); + case T_MACRO_STAR: case T_BACRO_STAR: case T_CLOSURE_STAR: + return(closure_star_is_aritable(sc, clo, closure_pars(clo), args)); + case T_C_MACRO: + return((c_macro_min_args(clo) <= args) && (c_macro_max_args(clo) >= args)); + case T_GOTO: case T_CONTINUATION: + return(true); + case T_STRING: + return((args == 1) && (string_length(clo) > 0)); /* ("" 0) -> error */ + case T_C_OBJECT: + { + s7_pointer func; + if ((has_active_methods(sc, clo)) && + ((func = find_method_with_c_object(sc, clo, sc->is_aritable_symbol)) != sc->undefined)) + return(s7_apply_function(sc, func, set_plist_2(sc, clo, make_integer(sc, args))) != sc->F); + return((is_safe_procedure(clo)) && (args == 1)); /* can we get the arity from clo? */ + } + case T_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + return((args > 0) && + (vector_length(clo) > 0) && /* (#() 0) -> error */ + (args <= vector_rank(clo))); + case T_LET: case T_HASH_TABLE: case T_PAIR: /* for hash-table, this refers to the implicit ref (table 'key) */ + return(args == 1); + case T_ITERATOR: + return(args == 0); + case T_SYNTAX: + return((args >= syntax_min_args(clo)) && (args <= syntax_max_args(clo))); + } + 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 func, s7_pointer num_args) {return(g_is_aritable(sc, set_plist_2(sc, func, num_args)) != sc->F);} + +static int32_t arity_to_int(s7_scheme *sc, s7_pointer clo) +{ + int32_t args; + switch (type(clo)) + { + case T_C_FUNCTION: case T_C_FUNCTION_STAR: + return(c_function_max_args(clo)); + case T_C_RST_NO_REQ_FUNCTION: + return(MAX_ARITY); + case T_MACRO: case T_BACRO: case T_CLOSURE: + args = closure_arity_to_int(sc, clo); + 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, clo); + return((args < 0) ? MAX_ARITY : args); + case T_C_MACRO: return(c_macro_max_args(clo)); + /* 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 seq) {return(is_simple_sequence(seq));} + + +/* -------------------------------- setter ------------------------------------------------ */ +static s7_pointer b_simple_setter(s7_scheme *sc, int32_t typer, s7_pointer args) /* see bool_defun -> define_bool_function */ +{ + 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)); +} + +/* these are for the simplified setter designation: (let ((x 1)) (set! (setter 'x) integer?) (set! x 3.14)) -> error */ + +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_byte_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_BYTE_VECTOR, 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_c_pointer_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_C_POINTER, 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_continuation_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_CONTINUATION, 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_float_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_FLOAT_VECTOR, args));} +static s7_pointer b_is_complex_vector_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_COMPLEX_VECTOR, args));} +static s7_pointer b_is_goto_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_GOTO, 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_input_port_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_INPUT_PORT, 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_iterator_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_ITERATOR, 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_null_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_NIL, 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_pair_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_PAIR, 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_string_setter(s7_scheme *sc, s7_pointer args) {return(b_simple_setter(sc, T_STRING, 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_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));} + +#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_byte_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_byte, args, "an unsigned byte", 16);} +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_dilambda_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, s7_is_dilambda, args, "a dilambda", 10);} +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_gensym_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_gensym, args, "a gensym", 8);} +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_keyword_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_symbol_and_keyword, args, "a keyword", 9);} +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_macro_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_macro, args, "a macro", 7);} +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_openlet_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, has_methods, args, "an open let", 11);} +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_rational_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_rational, args, "a rational", 10);} +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_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_vector_setter(s7_scheme *sc, s7_pointer args) {b_setter(sc, is_any_vector, args, "a vector", 8);} +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 clo) +{ + if (is_any_procedure(closure_setter_or_map_list(clo))) /* setter already known */ + return(closure_setter(clo)); + if (is_pair(closure_setter_or_map_list(clo))) /* it's a map_list masquerading as a setter */ + return(sc->F); + if (!closure_no_setter(clo)) + { + const s7_pointer setter = funclet_entry(sc, clo, sc->local_setter_symbol); /* look for +setter+, save value as closure_setter(clo) */ + if (setter) + { + if (setter == sc->F) + { + closure_set_no_setter(clo); + return(sc->F); + } + if (!is_any_procedure(setter)) + sole_arg_wrong_type_error_nr(sc, sc->setter_symbol, clo, wrap_string(sc, "a procedure or a reasonable facsimile thereof", 45)); + closure_set_setter(clo, setter); + return(setter); + } + /* 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(clo); + } + return(sc->F); +} + +static s7_pointer symbol_setter(s7_scheme *sc, s7_pointer sym, s7_pointer e) +{ + s7_pointer slot; + 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); + { + s7_pointer 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 obj, s7_pointer e) +{ + if (!is_let(e)) + { + s7_pointer new_let = find_let(sc, e); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->setter_symbol, e, new_let, 2, set_mlist_2(sc, obj, e)); + e = new_let; + } + 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(lambda_setter(sc, obj)); + + case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_RST_NO_REQ_FUNCTION: + return(c_function_setter(obj)); + + case T_C_MACRO: + return(c_macro_setter(obj)); + + case T_C_OBJECT: + if_c_object_method_exists_return_value(sc, obj, sc->setter_symbol, set_plist_2(sc, obj, e)); + return((c_object_set(sc, obj) == 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: + if_let_method_exists_return_value(sc, obj, sc->setter_symbol, set_plist_2(sc, obj, 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(obj))) ? closure_setter(iterator_sequence(obj)) : 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_COMPLEX_VECTOR: return(global_value(sc->complex_vector_set_symbol)); + case T_SLOT: return((slot_has_setter(obj)) ? slot_setter(obj) : sc->F); + case T_SYMBOL: return(symbol_setter(sc, obj, e)); /* (setter symbol let) */ + } + /* wrong_type_error_nr(sc, sc->setter_symbol, 1, obj, 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, has_let_signature(sc)) + 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));} + +static s7_pointer g_restore_setter(s7_scheme *sc, s7_pointer args) {closure_set_setter(caar(args), cadar(args)); return(cadar(args));} +/* see dynamic_unwind below -- it passes us list_2(sc, stack_args, sc->value) so we ignore cadr(args) */ + + +/* -------------------------------- set-setter -------------------------------- */ +static void protect_setter(s7_scheme *sc, s7_pointer sym, s7_pointer setter) +{ + s7_int loc; + if (sc->protected_setters_size == sc->protected_setters_loc) + { + const s7_int size = sc->protected_setters_size; + const s7_int new_size = 2 * size; + block_t *ob = vector_block(sc->protected_setters); /* ob is liberated by reallocate below */ + 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); /* ob is liberated by reallocate below */ + 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) = setter; /* has_closure => T_Prc[Clo?](setter) 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) ...))): args is (x (inlet 'x 1) #) */ + func = caddr(args); + if (e == sc->rootlet) + slot = global_slot(sym); + else + { + if (!is_let(e)) + { + s7_pointer new_let = find_let(sc, e); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, wrap_string(sc, "set! setter", 11), e, new_let, 2, args); + e = new_let; + } + slot = lookup_slot_with_let(sc, sym, e); + }} + else + { + slot = s7_slot(sc, sym); /* (set! (setter 'x) (lambda (s v) ...)): args is: (x #) */ + 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) +{ + const s7_pointer obj = car(args), setter = cadr(args); + if (is_symbol(obj)) /* has to precede cadr(args) checks, (set! (setter 'x let) ...) where setter is caddr(args) */ + return(symbol_set_setter(sc, obj, args)); + if (obj == sc->starlet) + wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, obj, wrap_string(sc, "something other than *s7*", 25)); + + 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), 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: + closure_set_setter(obj, setter); + if (setter == sc->F) + closure_set_no_setter(obj); + break; + + case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_RST_NO_REQ_FUNCTION: + if (obj == 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 (obj == 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(obj, setter); + /* below: not any_closure or any_macro because that include c-macros: + * twice: (catch #t (lambda () (let () (define (func) (set! (setter map) quasiquote)) (func))) (lambda (t i) 'error)) -> c-macro case! + */ + if (has_closure_let(setter)) + add_setter(sc, obj, setter); + break; + + case T_C_MACRO: + c_macro_set_setter(obj, setter); + if (has_closure_let(setter)) + add_setter(sc, obj, setter); + break; + + default: /* (set! (setter 4) ...) or p==continuation etc */ + wrong_type_error_nr(sc, wrap_string(sc, "set! setter", 11), 1, obj, wrap_string(sc, "a symbol, a procedure, or a macro", 33)); + } + return(setter); +} + +s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer obj, s7_pointer setter) +{ + if (is_symbol(obj)) + { + if (slot_has_setter(global_slot(obj))) + for (s7_int index = 0; index < sc->protected_setters_loc; index++) + if (vector_element(sc->protected_setter_symbols, index) == obj) + { + const 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(obj), 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(obj)); + if (!is_c_function(setter)) protect_setter(sc, obj, T_Clo(setter)); /* these don't need GC protection */ + slot_set_setter(global_slot(obj), setter); + if (s7_is_aritable(sc, setter, 3)) + set_has_let_arg(setter); + return(setter); + } + slot_set_setter(global_slot(obj), sc->F); + return(sc->F); + } + return(g_set_setter(sc, set_plist_2(sc, obj, 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)) + * which does not call the setter presumably because the set! has been optimized to ignore it -- set the 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 */ +{ + const s7_pointer func = slot_setter(slot); + 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->temp9 = (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) */ + /* the following s7_call can clobber the temp var (perhaps setter is calling implicit set!?) */ + { + s7_pointer result = s7_call(sc, func, sc->temp9); + sc->temp9 = sc->unused; + return(result); + } +} + +static s7_pointer bind_symbol_with_setter(s7_scheme *sc, opcode_t op, s7_pointer symbol, s7_pointer new_value) +{ + const 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 */ +} + + +/* -------------------------------- 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 '(())) #) should return #t */ +} + +bool s7_is_eqv(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ +#if WITH_GMP + if ((is_big_number(x)) || (is_big_number(y))) return(big_numbers_are_eqv(sc, x, y)); +#endif + if (type(x) != type(y)) return(false); + if ((x == y) && (!is_number(x))) /* if x is NaN, x == y doesn't mean (eqv? x y) */ + return(true); /* x == y means (let ((x "a")) (let ((y x)) (eqv? x y))) is #t */ + if (is_number(x)) return(numbers_are_eqv(sc, x, y)); + if (is_unspecified(x)) return(true); /* types are the same so we know y 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 = (s7_int)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)) + { + const s7_pointer key = hash_entry_key(p); + const s7_uint hash = hash_loc(sc, y, key); + const s7_uint loc = hash % hash_table_mask(y); + hash_entry_t *entry; + + for (entry = hash_table_element(y, loc); entry; entry = hash_entry_next(entry)) + if ((hash_entry_raw_hash(entry) == hash) && + (eqf(sc, hash_entry_key(entry), key, nci))) + break; + if (!entry) + return(false); + if (!eqf(sc, hash_entry_value(p), hash_entry_value(entry), 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 x_slot, s7_pointer y_let, shared_info_t *nci) +{ + for (s7_pointer e = y_let; e; e = let_outlet(e)) + for (s7_pointer y_slot = let_slots(e); tis_slot(y_slot); y_slot = next_slot(y_slot)) + if (slot_symbol(x_slot) == slot_symbol(y_slot)) /* we know something will match */ + return(is_equal_1(sc, slot_value(x_slot), slot_value(y_slot), nci)); + return(false); +} + +static bool slots_equivalent_match(s7_scheme *sc, s7_pointer x_slot, s7_pointer y_let, shared_info_t *nci) +{ + for (s7_pointer e = y_let; e; e = let_outlet(e)) + for (s7_pointer y_slot = let_slots(e); tis_slot(y_slot); y_slot = next_slot(y_slot)) + if (slot_symbol(x_slot) == slot_symbol(y_slot)) /* we know something will match */ + return(is_equivalent_1(sc, slot_value(x_slot), slot_value(y_slot), nci)); + return(false); +} + +static bool let_equal_1(s7_scheme *sc, s7_pointer x_let, s7_pointer y_let, shared_info_t *ci, bool equivalent) +{ + shared_info_t *nci = ci; + int32_t x_len, y_len; + + if ((!is_let(y_let)) || (x_let == sc->rootlet) || (y_let == sc->rootlet)) /* (equal? (rootlet) (rootlet)) is checked in let_equal below */ + return(false); + + if ((ci) && (equal_ref(sc, x_let, y_let, ci))) return(true); + + clear_small_symbol_set(sc); /* not begin, slots_match below calls equal_1 -> let_equal_1 */ + x_len = 0; + for (s7_pointer e = x_let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (!symbol_is_in_small_symbol_set(sc, slot_symbol(slot))) + { + add_symbol_to_small_symbol_set(sc, slot_symbol(slot)); + x_len++; + } + + for (s7_pointer e = y_let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (!symbol_is_in_small_symbol_set(sc, slot_symbol(slot))) /* symbol in y, not in x */ + return(false); + y_len = 0; + for (s7_pointer e = y_let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (small_symbol_tag(slot_symbol(slot)) != 0) + { + y_len++; + set_small_symbol_tag(slot_symbol(slot), 0); + } + if (x_len != y_len) /* symbol in x, not in y */ + return(false); + + if (!nci) nci = clear_shared_info(sc->circle_info); + + for (s7_pointer e = x_let; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (small_symbol_tag(slot_symbol(slot)) == 0) /* unshadowed */ + { + set_small_symbol_tag(slot_symbol(slot), sc->small_symbol_tag); /* values don't match */ + if (((!equivalent) && (!slots_match(sc, slot, y_let, nci))) || + ((equivalent) && (!slots_equivalent_match(sc, slot, y_let, nci)))) + return(false); + } + return(true); +} + +static bool let_equal(s7_scheme *sc, s7_pointer x_let, s7_pointer y_let, shared_info_t *ci) +{ + /* x_let == y_let if all unshadowed vars match, leaving aside the rootlet, so that for any local variable, we get the same value in either x_let or y_let */ + return((x_let == y_let) || (let_equal_1(sc, x_let, y_let, ci, false))); +} + +/* what should these do if there are setters? */ +static bool let_equivalent(s7_scheme *sc, s7_pointer x_let, s7_pointer y_let, shared_info_t *ci) +{ + if (x_let == y_let) return(true); + if (!is_global(sc->is_equivalent_symbol)) + { + check_equivalent_method(sc, x_let, y_let); + check_equivalent_method(sc, y_let, x_let); + } + return(let_equal_1(sc, x_let, y_let, 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_pars(x), closure_pars(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) +{ + 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); + { + s7_pointer px, py; + 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) +{ + 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); + { + s7_pointer px, py; + 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_equivalent(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) +{ + const 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_equivalent(s7_pointer x, s7_pointer y) +{ + const 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); +} + +static bool fv_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_int len) +{ + const s7_double *arr1 = float_vector_floats(x), *arr2 = float_vector_floats(y); + const s7_double fudge = sc->equivalent_float_epsilon; + if (fudge == 0.0) + { + for (s7_int 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 (s7_int i = 0; i < len; ) + LOOP_4(if (!floats_are_equivalent(sc, arr1[i], arr2[i])) return(false); i++); + else + for (s7_int i = 0; i < len; i++) + if (!floats_are_equivalent(sc, arr1[i], arr2[i])) + return(false); + return(true); +} + +static bool cv_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_int len) +{ + const s7_complex *arr1 = complex_vector_complexes(x), *arr2 = complex_vector_complexes(y); + const s7_double fudge = sc->equivalent_float_epsilon; + if (fudge == 0.0) + { + for (s7_int i = 0; i < len; i++) + if (((creal(arr1[i]) != creal(arr2[i])) || (cimag(arr1[i]) != cimag(arr2[i]))) && + ((!is_NaN(creal(arr1[i]))) || (!is_NaN(creal(arr2[i]))) || (!is_NaN(cimag(arr1[i]))) || (!is_NaN(cimag(arr2[i]))))) + return(false); + } + else + if ((len & 0x3) == 0) + for (s7_int i = 0; i < len; ) + LOOP_4(if ((!floats_are_equivalent(sc, creal(arr1[i]), creal(arr2[i]))) || (!floats_are_equivalent(sc, cimag(arr1[i]), cimag(arr2[i])))) return(false); i++); + else + for (s7_int i = 0; i < len; i++) + if ((!floats_are_equivalent(sc, creal(arr1[i]), creal(arr2[i]))) || (!floats_are_equivalent(sc, cimag(arr1[i]), cimag(arr2[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_equivalent(y, x)); + if ((is_byte_vector(x)) && (is_int_vector(y))) + return(biv_equivalent(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); + } + /* splitting out the typed_vector_typer case is only slightly faster (5% and much trickier) */ + 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_equivalent(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 complex_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + s7_int len; + if (!is_complex_vector(y)) + return(vector_equal(sc, x, y, ci)); + base_vector_equal(sc, x, y); + for (s7_int i = 0; i < len; i++) + if (complex_vector(x, i) != complex_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 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); /* different from vector_equal, (equal? (make-vector '(0 1)) (make-vector '(1 0))): #f, but #t if equivalent? */ + 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_equivalent(y, x)); + if ((is_byte_vector(x)) && (is_int_vector(y))) + return(biv_equivalent(x, y)); + for (s7_int 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)) + return(fv_equivalent(sc, x, y, len)); + if (is_int_vector(x)) + return(iv_equivalent(int_vector_ints(x), int_vector_ints(y), len)); + if (is_byte_vector(x)) + return(byte_vector_equal_1(sc, x, y)); + if (is_complex_vector(x)) + return(cv_equivalent(sc, x, y, len)); + + 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_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; + + 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: case T_COMPLEX_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)) : + ((is_byte_vector(x_seq)) ? (byte_vector_equal(sc, x_seq, y_seq, ci)) : + (complex_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); + { + s7_pointer xs, ys; + 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 (x_seq == sc->rootlet) + { + if (y_seq != sc->rootlet) return(false); + return(iterator_position(x) == iterator_position(y)); + } + if (x_seq == sc->starlet) + { + if (y_seq != sc->starlet) return(false); + return(iterator_position(x) == iterator_position(y)); + } + 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); + + /* let_iterator_slot will be NULL at end */ + if (is_slot_end(let_iterator_slot(x))) return(is_slot_end(let_iterator_slot(y))); + if (is_slot_end(let_iterator_slot(y))) return(false); /* not needed but seems clearer */ + { + s7_pointer xs, ys; + 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 == let_iterator_slot(x)) + return(ys == let_iterator_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), (s7_double)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), (s7_double)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), (s7_double)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), (s7_double)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 bool c_function_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return((is_c_function(y)) && (c_function_data(x) == c_function_data(y)));} +static bool c_macro_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) {return((is_c_macro(y)) && (c_macro_data(x) == c_macro_data(y)));} + +static void init_equals(void) +{ + for (int32_t i = 0; i < NUM_TYPES; i++) {equals[i] = eq_equal; equivalents[i] = eq_equal;} + equals[T_BACRO] = closure_equal; + equals[T_BACRO_STAR] = closure_equal; +#if WITH_GMP + equals[T_BIG_COMPLEX] = big_complex_equal; + equals[T_BIG_INTEGER] = big_integer_equal; + equals[T_BIG_RATIO] = big_ratio_equal; + equals[T_BIG_REAL] = big_real_equal; +#endif + equals[T_BYTE_VECTOR] = byte_vector_equal; + equals[T_CLOSURE] = closure_equal; + equals[T_CLOSURE_STAR] = closure_equal; + equals[T_COMPLEX] = complex_equal; + equals[T_C_MACRO] = c_macro_equal; + equals[T_C_FUNCTION] = c_function_equal; + equals[T_C_RST_NO_REQ_FUNCTION] = c_function_equal; + equals[T_C_OBJECT] = c_objects_are_equal; + equals[T_C_POINTER] = c_pointer_equal; + equals[T_FLOAT_VECTOR] = float_vector_equal; + equals[T_COMPLEX_VECTOR] = complex_vector_equal; + equals[T_HASH_TABLE] = hash_table_equal; + equals[T_INPUT_PORT] = port_equal; + equals[T_INTEGER] = integer_equal; + equals[T_INT_VECTOR] = int_vector_equal; + equals[T_ITERATOR] = iterator_equal; + equals[T_LET] = let_equal; + equals[T_MACRO] = closure_equal; + equals[T_MACRO_STAR] = closure_equal; + equals[T_OUTPUT_PORT] = port_equal; + equals[T_PAIR] = pair_equal; + equals[T_RANDOM_STATE] = random_state_equal; + equals[T_RATIO] = fraction_equal; + equals[T_REAL] = real_equal; + equals[T_STRING] = string_equal; + equals[T_SYMBOL] = eq_equal; + equals[T_SYNTAX] = syntax_equal; + equals[T_UNDEFINED] = undefined_equal; + equals[T_UNSPECIFIED] = unspecified_equal; + equals[T_VECTOR] = vector_equal; + + equivalents[T_BACRO] = closure_equivalent; + equivalents[T_BACRO_STAR] = closure_equivalent; +#if WITH_GMP + equivalents[T_BIG_COMPLEX] = big_complex_equivalent; + equivalents[T_BIG_INTEGER] = big_integer_equivalent; + equivalents[T_BIG_RATIO] = big_ratio_equivalent; + equivalents[T_BIG_REAL] = big_real_equivalent; +#endif + equivalents[T_BYTE_VECTOR] = vector_equivalent; + equivalents[T_CLOSURE] = closure_equivalent; + equivalents[T_CLOSURE_STAR] = closure_equivalent; + equivalents[T_COMPLEX] = complex_equivalent; + equivalents[T_C_MACRO] = c_macro_equal; + equivalents[T_C_FUNCTION] = c_function_equal; + equivalents[T_C_RST_NO_REQ_FUNCTION] = c_function_equal; + equivalents[T_C_OBJECT] = c_objects_are_equivalent; + equivalents[T_C_POINTER] = c_pointer_equivalent; + equivalents[T_FLOAT_VECTOR] = vector_equivalent; + equivalents[T_COMPLEX_VECTOR] = vector_equivalent; + equivalents[T_HASH_TABLE] = hash_table_equivalent; + equivalents[T_INPUT_PORT] = port_equivalent; + equivalents[T_INTEGER] = integer_equivalent; + equivalents[T_INT_VECTOR] = vector_equivalent; + equivalents[T_ITERATOR] = iterator_equivalent; + equivalents[T_LET] = let_equivalent; + equivalents[T_MACRO] = closure_equivalent; + equivalents[T_MACRO_STAR] = closure_equivalent; + equivalents[T_OUTPUT_PORT] = port_equivalent; + equivalents[T_PAIR] = pair_equivalent; + equivalents[T_RANDOM_STATE] = random_state_equal; + equivalents[T_RATIO] = fraction_equivalent; + equivalents[T_REAL] = real_equivalent; + equivalents[T_STRING] = string_equal; + equivalents[T_SYMBOL] = symbol_equivalent; + equivalents[T_SYNTAX] = syntax_equal; + equivalents[T_UNDEFINED] = undefined_equal; + equivalents[T_UNSPECIFIED] = unspecified_equal; + equivalents[T_VECTOR] = vector_equivalent; +} + +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 vec) {return(make_integer(sc, vector_length(vec)));} +static s7_pointer str_length(s7_scheme *sc, s7_pointer str) {return(make_integer(sc, string_length(str)));} +static s7_pointer bv_length(s7_scheme *sc, s7_pointer bv) {return(make_integer(sc, byte_vector_length(bv)));} +static s7_pointer h_length(s7_scheme *sc, s7_pointer table) {return(make_integer(sc, hash_table_size(table)));} +static s7_pointer iter_length(s7_scheme *sc, s7_pointer iter) {return(s7_length(sc, iterator_sequence(iter)));} + +static s7_pointer c_obj_length(s7_scheme *sc, s7_pointer cobj) +{ + if (!is_global(sc->length_symbol)) + if_c_object_method_exists_return_value(sc, cobj, sc->length_symbol, set_plist_1(sc, cobj)); + return(c_object_length(sc, cobj)); +} + +static s7_pointer lt_length(s7_scheme *sc, s7_pointer let) +{ + if (!is_global(sc->length_symbol)) + if_let_method_exists_return_value(sc, let, sc->length_symbol, set_plist_1(sc, let)); + return(make_integer(sc, let_length(sc, let))); +} + +static s7_pointer fnc_length(s7_scheme *sc, s7_pointer func) +{ + return((has_active_methods(sc, func)) ? make_integer(sc, closure_length(sc, func)) : 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 rs) {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_COMPLEX_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 obj) {return((*length_functions[unchecked_type(obj)])(sc, obj));} + +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))); +} + + +/* -------------------------------- copy -------------------------------- */ +static s7_pointer string_setter(s7_scheme *sc, s7_pointer str, s7_int loc, s7_pointer chr) +{ + if (is_character(chr)) + { + string_value(str)[loc] = s7_character(chr); + return(chr); + } + set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not a character", 25)); /* TODO: why not set_elist_3, and cadr=caller? */ + set_caddr(sc->elist_3, chr); + 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 cobj, s7_int loc, s7_pointer val) +{ + return((*(c_object_set(sc, cobj)))(sc, with_list_t3(cobj, wrap_mutable_integer(sc, loc), val))); /* was make_integer 14-Nov-23 */ +} + +static s7_pointer c_object_getter(s7_scheme *sc, s7_pointer cobj, s7_int loc) +{ + return((*(c_object_ref(sc, cobj)))(sc, set_plist_2(sc, cobj, wrap_mutable_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 table, 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)); /* TODO: what about cadr? */ + set_caddr(sc->elist_3, val); + error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); + } + return(s7_hash_table_set(sc, table, car(val), cdr(val))); +} + +static s7_pointer copy_hash_table(s7_scheme *sc, s7_pointer source) +{ + const s7_pointer new_table = s7_make_hash_table(sc, hash_table_size(source)); + gc_protect_via_stack(sc, new_table); + hash_table_checker(new_table) = hash_table_checker(source); + if (hash_chosen(source)) hash_set_chosen(new_table); + hash_table_mapper(new_table) = hash_table_mapper(source); + hash_table_set_procedures(new_table, copy_hash_table_procedures(sc, source)); + hash_table_copy(sc, source, new_table, 0, hash_table_entries(source)); + if (is_typed_hash_table(source)) + { + set_is_typed_hash_table(new_table); + if (has_hash_key_type(source)) set_has_hash_key_type(new_table); + if (has_hash_value_type(source)) set_has_hash_value_type(new_table); + if (has_simple_keys(source)) set_has_simple_keys(new_table); + if (has_simple_values(source)) set_has_simple_values(new_table); + } + if (is_weak_hash_table(source)) /* 16-May-23 */ + { + set_weak_hash_table(new_table); + weak_hash_iters(new_table) = 0; + } + unstack_gc_protect(sc); + return(new_table); +} + +static s7_pointer copy_vector(s7_scheme *sc, s7_pointer source) +{ + const 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) /* (copy str) */ +{ + s7_pointer dest; + switch (type(source)) + { + case T_STRING: + if (string_length(source) == 0) return(nil_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: + if_let_method_exists_return_value(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: + if_method_exists_return_value(sc, source, sc->copy_symbol, args); + return(copy_closure(sc, source)); + + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_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 = wrap_mutable_integer(sc, 0); + s7_pointer mj = wrap_mutable_integer(sc, 0); + 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); + } + 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 */ + const 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_COMPLEX_VECTOR: + memcpy((void *)((complex_vector_complexes(dest)) + dest_start), (void *)((complex_vector_complexes(source)) + source_start), source_len * sizeof(s7_complex)); + 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 new_table; + gc_protect_via_stack(sc, source); + new_table = 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(new_table); + } + + default: + return(dest); + } + return(NULL); +} + +static no_return 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 no_return 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) + + const s7_pointer source = car(args); + s7_pointer dest; + s7_int 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: case T_COMPLEX_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) */ + } + if_c_object_method_exists_return_value(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); + if_let_method_exists_return_value(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->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_no_local(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_no_local(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: + if (is_complex_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_COMPLEX_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->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 result = copy_to_same_type(sc, dest, source, 0, source_len, start); + if (result) return(result); + } + + switch (type(source)) + { + case T_PAIR: + { + s7_pointer p = source; + if (start > 0) + for (s7_int 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) + { + s7_pointer dp = source; + for (s7_int 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 (s7_int 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 (s7_int i = start, j = 0; i < end; i++, j++, p = cdr(p)) + els[j] = car(p); + } + else + { + gc_protect_via_stack(sc, source); + for (s7_int i = start, j = 0; i < end; i++, j++, p = cdr(p)) + set(sc, dest, j, car(p)); + unstack_gc_protect(sc); + } + return(dest); + } + + case T_LET: + if (source == sc->starlet) /* *s7* */ /* this could be more direct via starlet_make_iterator, but it hardly matters */ + { + s7_pointer iter = s7_make_iterator(sc, sc->starlet); + s7_int gc_loc = gc_protect_1(sc, iter); + for (s7_int 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 = dest; + for (s7_int i = start; (i < end) && (is_pair(p)); i++, p = cdr(p)) /* i = start is redundant? also below */ + { + s7_pointer val = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + set_car(p, val); + }} + else + for (s7_int 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 (s7_int i = 0; i < start; i++) slot = next_slot(slot); + if (is_pair(dest)) + { + s7_pointer p = dest; + check_free_heap_size(sc, end - start); + for (s7_int i = start; (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_no_local(sc, dest, slot_symbol(slot), slot_value(slot)); + } + else + for (s7_int i = start; i < end; i++, slot = next_slot(slot)) + add_slot_no_local(sc, dest, slot_symbol(slot), slot_value(slot)); + } + else + if (is_hash_table(dest)) + for (s7_int 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 (s7_int 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 (s7_int 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 *entry = NULL; + + while (skip > 0) + { + while (!entry) entry = elements[++loc]; + skip--; + entry = hash_entry_next(entry); + } + if (is_pair(dest)) + { + s7_pointer p = dest; + check_free_heap_size(sc, end - start); + for (s7_int i = start; (i < end) && (is_pair(p)); i++, p = cdr(p)) + { + while (!entry) entry = elements[++loc]; + set_car(p, cons_unchecked(sc, hash_entry_key(entry), hash_entry_value(entry))); + entry = hash_entry_next(entry); + }} + else + if (is_let(dest)) + { + for (s7_int i = start; i < end; i++) + { + s7_pointer symbol; + while (!entry) entry = elements[++loc]; + symbol = hash_entry_key(entry); + 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_no_local(sc, dest, symbol, hash_entry_value(entry)); /* ...unchecked... if size ok */ + entry = hash_entry_next(entry); + }} + else + { + check_free_heap_size(sc, end - start); + for (s7_int i = start, j = 0; i < end; i++, j++) + { + while (!entry) entry = elements[++loc]; + set(sc, dest, j, cons_unchecked(sc, hash_entry_key(entry), hash_entry_value(entry))); + entry = hash_entry_next(entry); + }} + return(dest); + } + + case T_VECTOR: + { + s7_pointer *vals = vector_elements(source); + if (is_float_vector(dest)) + { + s7_double *dst = float_vector_floats(dest); + for (s7_int 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 (s7_int 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_complex_vector(dest)) + { + s7_complex *dst = complex_vector_complexes(dest); + for (s7_int i = start, j = 0; i < end; i++, j++) + { + if (!s7_is_number(vals[i])) + copy_element_error_nr(sc, caller, i + 1, vals[i], T_COMPLEX); + dst[j] = s7_to_c_complex(vals[i]); + } + return(dest); + } + if (is_string(dest)) + { + char *dst = string_value(dest); + for (s7_int 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 (s7_int 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_COMPLEX_VECTOR: + if ((is_t_vector(dest)) && (!is_typed_vector(dest))) + { + const s7_complex *src = complex_vector_complexes(source); + s7_pointer *dst = vector_elements(dest); + check_free_heap_size(sc, end - start); + for (s7_int i = start, j = 0; i < end; i++, j++) + dst[j] = c_complex_to_s7(sc, src[i]); + return(dest); + } + break; + + case T_FLOAT_VECTOR: + /* int-vector destination can't normally work, fractional parts get rounded away */ + if ((is_t_vector(dest)) && (!is_typed_vector(dest))) + { + const s7_double *src = float_vector_floats(source); + s7_pointer *dst = vector_elements(dest); + check_free_heap_size(sc, end - start); + for (s7_int i = start, j = 0; i < end; i++, j++) + dst[j] = make_real_unchecked(sc, src[i]); + return(dest); + } + break; + + case T_INT_VECTOR: + { + const s7_int *src = int_vector_ints(source); + if (is_float_vector(dest)) + { + s7_double *dst = float_vector_floats(dest); + for (s7_int 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 (s7_int i = start, j = 0; i < end; i++, j++) + dst[j] = make_integer_unchecked(sc, src[i]); + return(dest); + } + if (is_string(dest)) + { + for (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 = dest; + if (is_float_vector(source)) + { + const s7_double *els = float_vector_floats(source); + check_free_heap_size(sc, end - start); + for (s7_int i = start; (i < end) && (is_pair(p)); i++, p = cdr(p)) + set_car(p, make_real_unchecked(sc, els[i])); + } + else + if (is_int_vector(source)) + { + const s7_int *els = int_vector_ints(source); + check_free_heap_size(sc, end - start); + for (s7_int i = start; (i < end) && (is_pair(p)); i++, p = cdr(p)) + set_car(p, make_integer_unchecked(sc, els[i])); + } + else + for (s7_int i = start; (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 (s7_int 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 lst, 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 */ + begin_temp(sc->y, list_1(sc, car(a))); + for (lst = cdr(a), p = a; is_pair(lst); lst = cdr(lst), p = cdr(p)) + { + sc->y = cons(sc, car(lst), sc->y); + if (is_pair(cdr(lst))) + { + lst = cdr(lst); + sc->y = cons_unchecked(sc, car(lst), sc->y); + } + if (lst == p) /* this can take awhile to notice there's a cycle, but what does the caller expect? */ + break; + } + sc->y = (is_null(lst)) ? sc->y : cons(sc, lst, sc->y); /* ?? this means that (reverse '(1 2 . 3)) returns '(3 2 1) -- we used to return () here */ + return_with_end_temp(sc->y); +} + +/* 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 str) +{ + s7_pointer new_str; + char *dest; + const char *source = string_value(str); + const s7_int len = string_length(str); + const char *end = (char *)(source + len); + new_str = make_empty_string(sc, len, '\0'); + dest = (char *)(string_value(new_str) + len); + while (source < end) *(--dest) = *source++; + return(new_str); +} + +static s7_pointer byte_vector_reverse(s7_scheme *sc, s7_pointer bv) +{ + s7_pointer new_bv; + uint8_t *dest; + const uint8_t *source = byte_vector_bytes(bv); + const s7_int len = byte_vector_length(bv); + const uint8_t *end = (const uint8_t *)(source + len); + new_bv = make_simple_byte_vector(sc, len); + dest = (uint8_t *)(byte_vector_bytes(new_bv) + len); + while (source < end) *(--dest) = *source++; + return(new_bv); +} + +static s7_pointer int_vector_reverse(s7_scheme *sc, s7_pointer iv) +{ + s7_pointer new_iv; + s7_int *dest; + const s7_int *source = int_vector_ints(iv); + const s7_int len = vector_length(iv); + const s7_int *end = (s7_int *)(source + len); + if (vector_rank(iv) > 1) + new_iv = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, iv)), int_zero), sc->make_int_vector_symbol); + else new_iv = make_simple_int_vector(sc, len); + dest = (s7_int *)(int_vector_ints(new_iv) + len); + while (source < end) *(--dest) = *source++; + return(new_iv); +} + +static s7_pointer float_vector_reverse(s7_scheme *sc, s7_pointer fv) +{ + s7_pointer new_fv; + s7_double *dest; + const s7_double *source = float_vector_floats(fv); + const s7_int len = vector_length(fv); + const s7_double *end = (s7_double *)(source + len); + if (vector_rank(fv) > 1) + new_fv = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, fv)), real_zero), sc->make_float_vector_symbol); + else new_fv = make_simple_float_vector(sc, len); + dest = (s7_double *)(float_vector_floats(new_fv) + len); + while (source < end) *(--dest) = *source++; + return(new_fv); +} + +static s7_pointer complex_vector_reverse(s7_scheme *sc, s7_pointer cv) +{ + s7_pointer new_cv; + s7_complex *dest; + const s7_complex *source = complex_vector_complexes(cv); + const s7_int len = vector_length(cv); + const s7_complex *end = (s7_complex *)(source + len); + if (vector_rank(cv) > 1) + new_cv = g_make_vector_1(sc, set_plist_2(sc, g_vector_dimensions(sc, set_plist_1(sc, cv)), real_zero), sc->make_complex_vector_symbol); + else new_cv = make_simple_complex_vector(sc, len); + dest = (s7_complex *)(complex_vector_complexes(new_cv) + len); + while (source < end) *(--dest) = *source++; + return(new_cv); +} + +static s7_pointer vector_reverse(s7_scheme *sc, s7_pointer vect) +{ + s7_pointer new_vect; + s7_pointer *dest; + const s7_pointer *source = vector_elements(vect); + const s7_int len = vector_length(vect); + const s7_pointer *end = (s7_pointer *)(source + len); + if (vector_rank(vect) > 1) + new_vect = g_make_vector(sc, set_plist_1(sc, g_vector_dimensions(sc, set_plist_1(sc, vect)))); + else new_vect = make_simple_vector(sc, len); + dest = (s7_pointer *)(vector_elements(new_vect) + len); + while (source < end) *(--dest) = *source++; + if (is_typed_vector(vect)) + { + set_typed_vector(new_vect); + typed_vector_set_typer(new_vect, typed_vector_typer(vect)); + if (has_simple_elements(vect)) set_has_simple_elements(new_vect); + } + return(new_vect); +} + +static s7_pointer reverse_p_p(s7_scheme *sc, s7_pointer obj) +{ + sc->temp3 = obj; + if (is_pair(obj)) return(s7_reverse(sc, obj)); /* by far the most common case */ + switch (type(obj)) + { + case T_NIL: return(sc->nil); + /* case T_PAIR: return(s7_reverse(sc, obj)); */ + case T_STRING: return(string_reverse(sc, obj)); + case T_BYTE_VECTOR: return(byte_vector_reverse(sc, obj)); + case T_INT_VECTOR: return(int_vector_reverse(sc, obj)); + case T_FLOAT_VECTOR: return(float_vector_reverse(sc, obj)); + case T_COMPLEX_VECTOR: return(complex_vector_reverse(sc, obj)); + case T_VECTOR: return(vector_reverse(sc, obj)); + case T_HASH_TABLE: return(hash_table_reverse(sc, obj)); + case T_C_OBJECT: + if_c_object_method_exists_return_value(sc, obj, sc->reverse_symbol, set_plist_1(sc, obj)); + if (!c_object_reverse(sc, obj)) + syntax_error_nr(sc, "attempt to reverse ~S?", 22, obj); + return((*(c_object_reverse(sc, obj)))(sc, set_plist_1(sc, obj))); + case T_LET: + if_let_method_exists_return_value(sc, obj, sc->reverse_symbol, set_plist_1(sc, obj)); + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "can't reverse let: ~S", 21), obj)); + default: + return(method_or_bust_p(sc, obj, 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 str) +{ + s7_int len; + uint8_t *bytes; + if (is_string(str)) + { + len = string_length(str); + bytes = (uint8_t *)string_value(str); + } + else + { + len = byte_vector_length(str); + bytes = byte_vector_bytes(str); + } + if (len < 2) return(str); + if (is_immutable(str)) /* "" might be immutable but we want (reverse! "") to return "" */ + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, str)); + +#if (defined(__linux__)) && (defined(__GLIBC__)) /* need byteswp.h */ + /* this code (from StackOverflow with changes) is much faster: */ +#include + 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(str); +} + +static s7_pointer int_vector_reverse_in_place(s7_scheme *sc, s7_pointer vec) +{ + const s7_int len = vector_length(vec); + if (len < 2) + return(vec); /* (reverse! #i()) -> #i() independent of immutable bit */ + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, vec)); + { + s7_int *ints1 = int_vector_ints(vec); + s7_int *ints2 = (s7_int *)(ints1 + len - 1); + if ((len & 0x3f) == 0) /* 63 for 2 32's */ + while (ints1 < ints2) + { + s7_int c; + LOOP_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c); + LOOP_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c); + LOOP_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c); + LOOP_8(c = *ints1; *ints1++ = *ints2; *ints2-- = 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 (ints1 < ints2) + { + s7_int c; + LOOP_8(c = *ints1; *ints1++ = *ints2; *ints2-- = c); + } + else while (ints1 < ints2) {s7_int c; c = *ints1; *ints1++ = *ints2; *ints2-- = c;} + } + return(vec); +} + +static s7_pointer float_vector_reverse_in_place(s7_scheme *sc, s7_pointer fv) +{ + const s7_int len = vector_length(fv); + if (len < 2) return(fv); + if (is_immutable_vector(fv)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, fv)); + { + s7_double *flts1 = float_vector_floats(fv); + s7_double *flts2 = (s7_double *)(flts1 + len - 1); + if ((len & 0x3f) == 0) /* 63 for 2 32's */ + while (flts1 < flts2) + { + s7_double x; + LOOP_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x); + LOOP_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x); + LOOP_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x); + LOOP_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x); + } + else + if ((len & 0xf) == 0) + while (flts1 < flts2) + { + s7_double x; + LOOP_8(x = *flts1; *flts1++ = *flts2; *flts2-- = x); + } + else while (flts1 < flts2) {s7_double x; x = *flts1; *flts1++ = *flts2; *flts2-- = x;} + } + return(fv); +} + +static s7_pointer complex_vector_reverse_in_place(s7_scheme *sc, s7_pointer cv) +{ + const s7_int len = vector_length(cv); + s7_complex *cmplx1 = complex_vector_complexes(cv), *cmplx2; + if (len < 2) return(cv); + if (is_immutable_vector(cv)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, cv)); + cmplx2 = (s7_complex *)(cmplx1 + len - 1); + while (cmplx1 < cmplx2) {s7_complex z; z = *cmplx1; *cmplx1++ = *cmplx2; *cmplx2-- = z;} + return(cv); +} + +static s7_pointer vector_reverse_in_place(s7_scheme *sc, s7_pointer vec) +{ + const s7_int len = vector_length(vec); + if (len < 2) return(vec); + if (is_immutable_vector(vec)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, vec)); + { + s7_pointer *vect1 = vector_elements(vec); + s7_pointer *vect2 = (s7_pointer *)(vect1 + len - 1); + if ((len & 0x3f) == 0) /* 63 for 2 32's */ + while (vect1 < vect2) + { + s7_pointer c; + LOOP_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c); + LOOP_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c); + LOOP_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c); + LOOP_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c); + } + else + if ((len & 0xf) == 0) + while (vect1 < vect2) + { + s7_pointer c; + LOOP_8(c = *vect1; *vect1++ = *vect2; *vect2-- = c); + } + else while (vect1 < vect2) {s7_pointer c; c = *vect1; *vect1++ = *vect2; *vect2-- = c;} + } + return(vec); +} + +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)) */ + const s7_pointer obj = car(args); + switch (type(obj)) + { + case T_NIL: /* (reverse! ()) -> () */ + return(sc->nil); + + case T_PAIR: + if (is_immutable_pair(obj)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, obj)); + { + s7_pointer lst = any_list_reverse_in_place(sc, sc->nil, obj); + if (is_null(lst)) + { + if (!s7_is_proper_list(sc, obj)) + 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(lst); + } + /* (reverse! obj) 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! obj (reverse! obj)) + * 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, obj)); + case T_INT_VECTOR: return(int_vector_reverse_in_place(sc, obj)); + case T_FLOAT_VECTOR: return(float_vector_reverse_in_place(sc, obj)); + case T_COMPLEX_VECTOR: return(complex_vector_reverse_in_place(sc, obj)); + case T_VECTOR: return(vector_reverse_in_place(sc, obj)); + + default: + if (is_immutable(obj)) + { + if (is_simple_sequence(obj)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, obj)); + sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, obj, a_sequence_string); + } + if ((is_simple_sequence(obj)) && + (!has_active_methods(sc, obj))) + sole_arg_wrong_type_error_nr(sc, sc->reverseb_symbol, obj, wrap_string(sc, "a vector, string, or list", 25)); + return(method_or_bust_p(sc, obj, sc->reverseb_symbol, a_sequence_string)); + } + return(obj); +} + + +/* -------------------------------- 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 */ + const s7_pointer obj = car(args); + const s7_pointer val = cadr(args); + 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))); + + 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 lst = obj, slow = obj; ; i++) + { + if ((end > 0) && (i >= end)) + return(val); + if (i >= start) set_car(lst, val); + if (!is_pair(cdr(lst))) + { + if (!is_null(cdr(lst))) + set_cdr(lst, val); + return(val); + } + lst = cdr(lst); + if ((i & 1) != 0) slow = cdr(slow); + if (lst == slow) + 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! + */ + const s7_pointer obj = car(args); + switch (type(obj)) + { + 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: case T_COMPLEX_VECTOR: + return(g_vector_fill_1(sc, sc->fill_symbol, args)); + + case T_LET: + if_let_method_exists_return_value(sc, obj, sc->fill_symbol, args); + return(let_fill(sc, args)); + + case T_C_OBJECT: + if_c_object_method_exists_return_value(sc, obj, sc->fill_symbol, args); + if (!c_object_fill(sc, obj)) /* default is NULL (s7_make_c_type) */ + syntax_error_nr(sc, "attempt to fill ~S?", 19, obj); + return((*(c_object_fill(sc, obj)))(sc, args)); + + default: + if_method_exists_return_value(sc, obj, sc->fill_symbol, args); + } + wrong_type_error_nr(sc, sc->fill_symbol, 1, obj, 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 seqs = args; + s7_int len = 0; + for (s7_int i = 1; is_pair(seqs); seqs = cdr(seqs), i++) + { + const s7_pointer seq = car(seqs); + const 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 = args, pargs, vtyper = NULL; + s7_pointer *v_elements = NULL; + s7_double *fv_elements = NULL; + s7_complex *cv_elements = NULL; + s7_int *iv_elements = NULL; + uint8_t *byte_elements = NULL; + s7_int len; + bool typed; + + gc_protect_via_stack(sc, args); + len = total_sequence_length(sc, args, caller, (typ == T_VECTOR) ? T_FREE : ((typ == T_COMPLEX_VECTOR) ? T_COMPLEX : ((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_gc_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 + if (typ == T_COMPLEX_VECTOR) + cv_elements = complex_vector_complexes(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_gc_protected3(sc, pargs); + for (s7_int i = 0; is_pair(p); p = cdr(p)) /* in-place copy by goofing (temporarily) with new_vec's elements pointer */ + { + const s7_pointer x = car(p); + const 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 + if (typ == T_COMPLEX_VECTOR) + complex_vector_complexes(new_vec) = (s7_complex *)(cv_elements + i); + else byte_vector_bytes(new_vec) = (uint8_t *)(byte_elements + i); + }} + /* unstack_gc_protect(sc); */ + 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 + if (typ == T_COMPLEX_VECTOR) + complex_vector_complexes(new_vec) = cv_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_table, key_typer = NULL, value_typer = NULL; + bool typed = true; + gc_protect_via_stack(sc, args); + check_stack_size(sc); + new_table = s7_make_hash_table(sc, sc->default_hash_table_length); + set_gc_protected2(sc, new_table); + for (s7_pointer seqs = args; is_pair(seqs); seqs = cdr(seqs)) + { + const s7_pointer seq = car(seqs); + if (!sequence_is_empty(sc, seq)) + { + /* perhaps check seq-length+hash_table_entries(new_table) > sc->max_vector_length here? */ + s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, seq, new_table)); + 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_table, make_hash_table_procedures(sc)); + set_is_typed_hash_table(new_table); + hash_table_set_key_typer(new_table, key_typer); + hash_table_set_value_typer(new_table, 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_table); + weak_hash_iters(new_table) = 0; + } + set_plist_2(sc, sc->nil, sc->nil); + unstack_gc_protect(sc); + return(new_table); +} + +static s7_pointer let_append(s7_scheme *sc, s7_pointer args) +{ + s7_pointer new_let; + const s7_pointer e = car(args); + if_let_method_exists_return_value(sc, e, sc->append_symbol, args); + gc_protect_via_stack(sc, args); + new_let = make_let(sc, sc->rootlet); + set_gc_protected2(sc, new_let); + for (s7_pointer seqs = args; is_pair(seqs); seqs = cdr(seqs)) + if (!sequence_is_empty(sc, car(seqs))) + s7_copy_1(sc, sc->append_symbol, set_plist_2(sc, car(seqs), 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 ) -> */ + 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: case T_COMPLEX_VECTOR: + return(vector_append(sc, args, type(car(args)), sc->append_symbol)); + case T_C_OBJECT: if_c_object_method_exists_return_value(sc, car(args), sc->append_symbol, args); break; + default: if_method_exists_return_value(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; + if ((!is_pair(b)) && (!is_null(b))) + return(g_list_append(sc, list_2(sc, a, b))); + sc->temp9 = a; /* tempx? */ + q = list_1(sc, car(a)); + begin_temp(sc->temp6, q); + p = cdr(a); + np = q; + for (s7_pointer op = a; (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))); + } + end_temp(sc->temp6); + if (!is_null(p)) + wrong_type_error_nr(sc, sc->append_symbol, 1, a, a_proper_list_string); + sc->temp9 = sc->unused; + set_cdr(np, b); + 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 func, int32_t args, s7_pointer unused_expr) +{ + if (args == 2) return(sc->append_2); + return(func); +} + + +/* -------------------------------- object->let -------------------------------- */ +static s7_pointer byte_vector_to_list(s7_scheme *sc, const uint8_t *str, s7_int len) +{ + if (len == 0) return(sc->nil); + check_free_heap_size(sc, len); + begin_temp(sc->y, sc->nil); + for (s7_int i = len - 1; i >= 0; i--) + sc->y = cons_unchecked(sc, small_int((uint32_t)(str[i])), sc->y); + return_with_end_temp(sc->y); +} + +static s7_pointer hash_table_to_list(s7_scheme *sc, s7_pointer obj) +{ + s7_pointer iterator; + if (hash_table_entries(obj) == 0) return(sc->nil); + iterator = s7_make_iterator(sc, obj); + gc_protect_via_stack(sc, iterator); + begin_temp(sc->y, sc->nil); + while (true) + { + s7_pointer entry = s7_iterate(sc, iterator); + if (iterator_is_at_end(iterator)) break; + sc->y = cons(sc, entry, sc->y); + } + unstack_gc_protect(sc); + return_with_end_temp(sc->y); +} + +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) + { + const s7_pointer val = s7_iterate(sc, obj); + if ((val == sc->iterator_at_end_value) && + (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 */ +{ + s7_int len; + s7_pointer cobj_len, lst, lst2, ref_index, result; + s7_int gc_lst2; + + if (c_object_to_list(sc, obj)) + return((*(c_object_to_list(sc, obj)))(sc, set_plist_1(sc, obj))); + + cobj_len = c_object_length(sc, obj); + if (!s7_is_integer(cobj_len)) return(sc->F); + len = s7_integer_clamped_if_gmp(sc, cobj_len); + if (len < 0) return(sc->F); + if (len == 0) return(sc->nil); + + result = make_list(sc, len, sc->nil); + sc->temp7 = result; + ref_index = wrap_mutable_integer(sc, 0); /* was make_mutable_integer 17-Nov-23 */ + lst2 = list_2_unchecked(sc, obj, ref_index); + gc_lst2 = gc_protect_1(sc, lst2); + lst = result; + for (s7_int i = 0; i < len; i++, lst = cdr(lst)) + { + set_integer(ref_index, i); + set_car(lst, (*(c_object_ref(sc, obj)))(sc, lst2)); + } + s7_gc_unprotect_at(sc, gc_lst2); + 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: case T_COMPLEX_VECTOR: + return(s7_vector_to_list(sc, obj)); + case T_LET: +#if !WITH_PURE_S7 + if_let_method_exists_return_value(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 sym) +{ + const s7_pointer let = internal_inlet(sc, 4, sc->value_symbol, sym, + sc->type_symbol, (is_keyword(sym)) ? sc->is_keyword_symbol : + ((is_gensym(sym)) ? sc->is_gensym_symbol : sc->is_symbol_symbol)); + if (!is_keyword(sym)) + { + const s7_int gc_loc = gc_protect_1(sc, let); + const s7_pointer val = s7_symbol_value(sc, sym); + 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, sym, sc->curlet)); + s7_varlet(sc, let, sc->is_mutable_symbol, make_boolean(sc, !is_immutable_symbol(sym))); + if (!is_undefined(val)) + { + const char *doc = s7_documentation(sc, sym); + 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 rs) +{ +#if WITH_GMP + return(internal_inlet(sc, 4, sc->value_symbol, rs, 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, rs, + sc->type_symbol, sc->is_random_state_symbol, + sc->seed_symbol, make_integer(sc, random_seed(rs)), + sc->carry_symbol, make_integer(sc, random_carry(rs)))); +#endif +} + +static s7_pointer vector_to_let(s7_scheme *sc, s7_pointer vec) +{ + 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, vec, + sc->type_symbol, (is_subvector(vec)) ? cons(sc, sc->is_subvector_symbol, s7_type_of(sc, subvector_vector(vec))) : s7_type_of(sc, vec), + sc->size_symbol, s7_length(sc, vec), + sc->dimensions_symbol, g_vector_dimensions(sc, set_plist_1(sc, vec)), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_vector(vec))); + gc_protect_via_stack(sc, let); + if (is_subvector(vec)) + { + s7_int pos = 0; + switch (type(vec)) /* 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(vec) - vector_elements(subvector_vector(vec)))); break; + case T_INT_VECTOR: pos = (s7_int)((intptr_t)(int_vector_ints(vec) - int_vector_ints(subvector_vector(vec)))); break; + case T_FLOAT_VECTOR: pos = (s7_int)((intptr_t)(float_vector_floats(vec) - float_vector_floats(subvector_vector(vec)))); break; + case T_COMPLEX_VECTOR: pos = (s7_int)((intptr_t)(complex_vector_complexes(vec) - complex_vector_complexes(subvector_vector(vec)))); break; + case T_BYTE_VECTOR: pos = (s7_int)((intptr_t)(byte_vector_bytes(vec) - byte_vector_bytes(subvector_vector(vec)))); break; + } + s7_varlet(sc, let, sc->position_symbol, make_integer(sc, pos)); + s7_varlet(sc, let, sc->original_vector_symbol, subvector_vector(vec)); + } + if (is_typed_t_vector(vec)) + s7_varlet(sc, let, sc->signature_symbol, g_signature(sc, set_plist_1(sc, vec))); + +#if S7_DEBUGGING + if ((is_t_vector(vec)) && (is_symbol_table(vec))) /* (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 entries; + s7_pointer syms = vector_element(sc->symbol_table, i); + for (entries = 0; is_pair(syms); syms = cdr(syms), entries++); + if (entries == 0) zeros++; else + if (entries == 1) ones++; else + if (entries == 2) twos++; else + biggies++; + if (entries > max_len) max_len = entries; + } + s7_varlet(sc, let, make_symbol(sc, "stats:empty|1|2|n|most", 22), + 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 table) +{ + if ((hash_table_checker(table) == hash_eq) || + (hash_table_checker(table) == hash_c_function) || + (hash_table_checker(table) == hash_closure) || + (hash_table_checker(table) == hash_equal_eq) || + (hash_table_checker(table) == hash_equal_syntax) || + (hash_table_checker(table) == hash_symbol)) + s7_varlet(sc, let, sc->function_symbol, sc->is_eq_symbol); + else + if (hash_table_checker(table) == hash_eqv) + s7_varlet(sc, let, sc->function_symbol, sc->is_eqv_symbol); + else + if ((hash_table_checker(table) == hash_equal) || + (hash_table_checker(table) == hash_empty)) + s7_varlet(sc, let, sc->function_symbol, sc->is_equal_symbol); + else + if (hash_table_checker(table) == hash_equivalent) + s7_varlet(sc, let, sc->function_symbol, sc->is_equivalent_symbol); + else + if ((hash_table_checker(table) == hash_number_num_eq) || + (hash_table_checker(table) == hash_int) || + (hash_table_checker(table) == hash_float)) + s7_varlet(sc, let, sc->function_symbol, sc->num_eq_symbol); + else + if (hash_table_checker(table) == hash_string) + s7_varlet(sc, let, sc->function_symbol, sc->string_eq_symbol); + else + if (hash_table_checker(table) == hash_char) + s7_varlet(sc, let, sc->function_symbol, sc->char_eq_symbol); +#if !WITH_PURE_S7 + else + if (hash_table_checker(table) == hash_ci_char) + s7_varlet(sc, let, sc->function_symbol, sc->char_ci_eq_symbol); + else + if (hash_table_checker(table) == 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 table) +{ + 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, table, + sc->type_symbol, sc->is_hash_table_symbol, + sc->size_symbol, s7_length(sc, table), + sc->entries_symbol, make_integer(sc, hash_table_entries(table)), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_hash_table(table))); + gc_loc = gc_protect_1(sc, let); + if (is_weak_hash_table(table)) + s7_varlet(sc, let, sc->weak_symbol, sc->T); + + if (is_typed_hash_table(table)) + { + const s7_pointer checker = hash_table_procedures_checker(table); + if (checker == sc->T) /* perhaps typed because typers were set, but not checker/mapper */ + hash_table_checker_to_let(sc, let, table); + else s7_varlet(sc, let, sc->function_symbol, list_2(sc, checker, hash_table_procedures_mapper(table))); + s7_varlet(sc, let, sc->signature_symbol, + (is_typed_hash_table(table)) ? + list_3(sc, + hash_table_typer_symbol(sc, hash_table_value_typer(table)), + sc->is_hash_table_symbol, + hash_table_typer_symbol(sc, hash_table_key_typer(table))) : + sc->hash_table_signature); + } + else hash_table_checker_to_let(sc, let, table); + +#if S7_DEBUGGING + if (hash_table_entries(table) > 0) + { + s7_int max_len = 0, zeros = 0, ones = 0, twos = 0, biggies = 0; + const s7_int hash_len = (s7_int)hash_table_size(table); + for (s7_int i = 0; i < hash_len; i++) + { + hash_entry_t *entry = hash_table_element(table, i); + s7_int entries; + for (entries = 0; entry; entry = hash_entry_next(entry), entries++); + if (entries == 0) zeros++; else + if (entries == 1) ones++; else + if (entries == 2) twos++; else + biggies++; + if (entries > max_len) max_len = entries; + } + s7_varlet(sc, let, make_symbol(sc, "hash-stats:empty|1|2|n|most", 27), + 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 iter) +{ + s7_pointer let; + const s7_pointer seq = iterator_sequence(iter); + 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, iter, + sc->type_symbol, sc->is_iterator_symbol, + sc->at_end_symbol, make_boolean(sc, iterator_is_at_end(iter)), + sc->sequence_symbol, iterator_sequence(iter)); + 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, iter)); + 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(iter))); + else + if (is_pair(seq)) + s7_varlet(sc, let, sc->position_symbol, iterator_current(iter)); + unstack_gc_protect(sc); + return(let); +} + +static s7_pointer let_to_let(s7_scheme *sc, s7_pointer let) +{ + /* 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 new_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); + } + new_let = internal_inlet(sc, 12, sc->value_symbol, let, + sc->type_symbol, sc->is_let_symbol, + sc->size_symbol, s7_length(sc, let), + sc->open_symbol, make_boolean(sc, is_openlet(let)), + sc->outlet_symbol, (let == sc->rootlet) ? sc->nil : let_outlet(let), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_let(let))); + gc_loc = gc_protect_1(sc, new_let); + if (let == sc->rootlet) + s7_varlet(sc, new_let, sc->alias_symbol, sc->rootlet_symbol); + else /* owlet can't happen, I think -- it is always copied first */ + if (is_funclet(let)) + { + s7_varlet(sc, new_let, sc->function_symbol, funclet_function(let)); + if ((has_let_file(let)) && + (let_file(let) <= (s7_int)sc->file_names_top) && + (let_line(let) > 0) && + (let_line(let) < 1000000)) + { + s7_varlet(sc, new_let, sc->file_symbol, sc->file_names[let_file(let)]); + s7_varlet(sc, new_let, sc->line_symbol, make_integer(sc, let_line(let))); + }} + else + if (let == sc->starlet) + { + const s7_pointer iter = s7_make_iterator(sc, let); + const s7_int gc_loc1 = gc_protect_1(sc, iter); + while (true) + { + s7_pointer starlet_field = s7_iterate(sc, iter); + if (iterator_is_at_end(iter)) break; + s7_varlet(sc, new_let, car(starlet_field), cdr(starlet_field)); + } + s7_gc_unprotect_at(sc, gc_loc1); + } + if (has_active_methods(sc, let)) + { + s7_pointer func = find_method(sc, let, sc->object_to_let_symbol); + if (func != sc->undefined) + s7_apply_function(sc, func, set_plist_2(sc, let, new_let)); + } + s7_gc_unprotect_at(sc, gc_loc); + return(new_let); +} + +static s7_pointer c_object_to_let(s7_scheme *sc, s7_pointer cobj) +{ + s7_pointer let; + const s7_pointer clet = c_object_let(cobj); + if (!sc->class_symbol) + sc->class_symbol = make_symbol(sc, "class", 5); + let = internal_inlet(sc, 8, sc->value_symbol, cobj, + sc->type_symbol, sc->is_c_object_symbol, + sc->c_object_type_symbol, make_integer(sc, c_object_type(cobj)), + sc->c_object_let_symbol, clet); + gc_protect_via_stack(sc, let); + g_varlet(sc, set_plist_3(sc, let, sc->class_symbol, c_object_type_to_let(sc, cobj))); + if ((is_let(clet)) && + ((has_active_methods(sc, clet)) || (has_active_methods(sc, cobj)))) + { + 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, cobj, let)); + } + unstack_gc_protect(sc); + return(let); +} + +static s7_pointer port_to_let(s7_scheme *sc, s7_pointer port) /* 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, port, + /* port as 'value means it will say "(closed)" when subsequently the let is displayed */ + sc->type_symbol, (is_input_port(port)) ? sc->is_input_port_symbol : sc->is_output_port_symbol, + sc->port_type_symbol, (is_string_port(port)) ? sc->string_symbol : ((is_file_port(port)) ? sc->file_symbol : sc->function_symbol), + sc->closed_symbol, make_boolean(sc, port_is_closed(port)), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable_port(port))); + gc_loc = gc_protect_1(sc, let); + if (is_file_port(port)) + { + s7_varlet(sc, let, sc->file_symbol, g_port_filename(sc, set_plist_1(sc, port))); + if (is_input_port(port)) + s7_varlet(sc, let, sc->line_symbol, g_port_line_number(sc, set_plist_1(sc, port))); +#if !MS_WINDOWS + if ((!port_is_closed(port)) && (port != sc->standard_error) && (port != sc->standard_input) && (port != sc->standard_output)) + { + struct stat sb; + s7_varlet(sc, let, sc->file_symbol, make_integer(sc, fileno(port_file(port)))); + if (fstat(fileno(port_file(port)), &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(port)) && /* file port might not have a data buffer */ + (port_data(port)) && + (port_data_size(port) > 0)) + { + s7_int pos = port_position(port), size = port_data_size(port); + s7_varlet(sc, let, sc->size_symbol, make_integer(sc, size)); + s7_varlet(sc, let, sc->position_symbol, make_integer(sc, pos)); + /* 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. + * This field is confusing; perhaps show a window around the current data position? + */ + { + const char *data = (const char *)port_data(port); + char data_str[24], str[24]; + int32_t i, bytes, lim = (size > 16) ? 16 : size; + for (i = 0; i < lim; i++) data_str[i] = data[i]; + data_str[i] = '\0'; + bytes = snprintf(str, 24, "%s%s", data_str, (size > 16) ? "..." : ""); + s7_varlet(sc, let, sc->data_symbol, make_string_with_length(sc, str, bytes)); + }} + if (is_function_port(port)) + s7_varlet(sc, let, sc->function_symbol, port_string_or_function(port)); + s7_gc_unprotect_at(sc, gc_loc); + return(let); +} + +static s7_pointer closure_to_let(s7_scheme *sc, s7_pointer func) +{ + const char *doc = s7_documentation(sc, func); + const s7_pointer sig = s7_signature(sc, func); + const s7_pointer let = internal_inlet(sc, 8, sc->value_symbol, func, + sc->type_symbol, (is_t_procedure(func)) ? sc->is_procedure_symbol : sc->is_macro_symbol, + sc->arity_symbol, s7_arity(sc, func), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable(func))); + 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(func))) + { + s7_pointer flet = closure_let(func); + 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_or_map_list(func) != sc->F) + s7_varlet(sc, let, sc->local_setter_symbol, closure_setter_or_map_list(func)); + + 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(func)), closure_pars(func)), + closure_body(func))); + unstack_gc_protect(sc); + return(let); +} + +static s7_pointer c_pointer_to_let(s7_scheme *sc, s7_pointer cptr) +{ + /* 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, cptr, + sc->type_symbol, sc->is_c_pointer_symbol, + sc->pointer_symbol, make_integer(sc, (s7_int)((intptr_t)c_pointer(cptr))), + sc->c_type_symbol, c_pointer_type(cptr), + sc->info_symbol, c_pointer_info(cptr))); +} + +static s7_pointer c_function_to_let(s7_scheme *sc, s7_pointer cfunc) +{ + const char *doc = s7_documentation(sc, cfunc); + const s7_pointer sig = c_function_signature(cfunc); + const s7_pointer let = internal_inlet(sc, 8, sc->value_symbol, cfunc, + sc->type_symbol, (is_t_procedure(cfunc)) ? sc->is_procedure_symbol : sc->is_macro_symbol, + sc->arity_symbol, s7_arity(sc, cfunc), + sc->is_mutable_symbol, make_boolean(sc, !is_immutable(cfunc))); + 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(cfunc) != sc->F) /* c_macro_setter is the same underlying field */ + s7_varlet(sc, let, sc->local_setter_symbol, c_function_setter(cfunc)); + unstack_gc_protect(sc); + return(let); +} + +static s7_pointer goto_to_let(s7_scheme *sc, s7_pointer go) +{ + /* 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(go))) + return(internal_inlet(sc, 8, sc->value_symbol, go, sc->type_symbol, sc->is_goto_symbol, + sc->active_symbol, make_boolean(sc, call_exit_active(go)), + sc->name_symbol, call_exit_name(go))); + return(internal_inlet(sc, 6, sc->value_symbol, go, sc->type_symbol, sc->is_goto_symbol, + sc->active_symbol, make_boolean(sc, call_exit_active(go)))); +} + +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_INPUT_PORT: + case T_OUTPUT_PORT: return(port_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: case T_COMPLEX_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_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, s7_int loc, s7_pointer e) +{ + return((loc > 0) && + ((stack_let(sc->stack, loc) == e) || + (stacktrace_find_let(sc, loc - 4, e)))); +} + +static s7_int stacktrace_find_error_hook_quit(s7_scheme *sc) +{ + for (s7_int op_loc = stack_top(sc) - 1; op_loc >= 3; op_loc -= 4) + if (stack_op(sc->stack, op_loc) == OP_ERROR_HOOK_QUIT) + return(op_loc); + return(-1); +} + +static bool stacktrace_in_error_handler(s7_scheme *sc, s7_int 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 func = s7_symbol_value(sc, sym); + return((is_procedure(func)) && + (hook_has_functions(sc->error_hook)) && + (direct_memq(func, 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_small_symbol_set(sc, code)) && + (!is_slot(global_slot(code)))) + { + const s7_pointer val = s7_symbol_local_value(sc, code, e); + add_symbol_to_small_symbol_set(sc, code); + if ((val) && + (val != sc->undefined) && + (!is_any_macro(val)) && + (type(val) < T_CONTINUATION)) + { + char *objstr, *str; + s7_pointer objp; + s7_int new_note_len, notes_max; + bool new_notes_line = false; + const bool old_short_print = sc->short_print; + const s7_int old_len = sc->print_length; + s7_int 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) + { + const 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 = " "; + const 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 caller, 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(caller)) && + (caller != car(code))) + { + newlen = symbol_name_length(caller) + errlen + 10; + newp = mallocate(sc, newlen); + newstr = (char *)block_data(newp); /* newstr[0] = '\0'; */ + errlen = catstrs_direct(newstr, symbol_name(caller), ": ", 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 */ + const 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; + s7_int loc, frames = 0; + s7_int top = (sc->stack_end - sc->stack_start) / 4; /* (*s7* 'stack_top), not stack_top(sc)! */ + begin_small_symbol_set(sc); + + if (stacktrace_in_error_handler(sc, top)) + { + const s7_pointer err_code = slot_value(sc->error_code); + if ((is_pair(err_code)) && + (!tree_is_cyclic(sc, err_code))) + { + char *notes = NULL; + const s7_pointer current_let = let_outlet(sc->owlet); + const s7_pointer errstr = s7_object_to_string(sc, err_code, false); + const s7_pointer caller = 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, caller, 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--) + { + const s7_int true_loc = (loc + 1) * 4 - 1; + const s7_pointer code = stack_code(sc->stack, true_loc); + if ((is_pair(code)) && + (!tree_is_cyclic(sc, code))) + { + const s7_pointer codep = s7_object_to_string(sc, code, false); + if (string_length(codep) > 0) + { + const char *codestr = string_value(codep); + if ((!local_strcmp(codestr, "(result)")) && + (!local_strcmp(codestr, "(#f)")) && + (!strstr(codestr, "(stacktrace)")) && + (!strstr(codestr, "(stacktrace "))) + { + const s7_pointer e = stack_let(sc->stack, true_loc); /* might not be let (gc stack protection etc) */ + const 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) + { + end_small_symbol_set(sc); + 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); + }}}}} + end_small_symbol_set(sc); + 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 45) (total-cols 80) (note-col 45) 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) + + /* now: 30, 45, 80, 45, #f and applied here as well as in s7_stacktrace, 22-Jan-25 */ + #define ST_MAX_FRAMES 30 + #define ST_CODE_COLS 45 + #define ST_TOTAL_COLS 80 + #define ST_NOTES_START_COL 45 + #define ST_AS_COMMENT false + + s7_int max_frames = s7_integer_clamped_if_gmp(sc, car(sc->stacktrace_defaults)); + s7_int code_cols = s7_integer_clamped_if_gmp(sc, cadr(sc->stacktrace_defaults)); + s7_int total_cols = s7_integer_clamped_if_gmp(sc, caddr(sc->stacktrace_defaults)); + s7_int notes_start_col = s7_integer_clamped_if_gmp(sc, cadddr(sc->stacktrace_defaults)); + bool as_comment = s7_boolean(sc, s7_list_ref(sc, sc->stacktrace_defaults, 4)); + + 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 = ST_MAX_FRAMES; + 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 = ST_CODE_COLS; + 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 = ST_TOTAL_COLS; + 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 = ST_NOTES_START_COL; + 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 + const 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)); + if ((S7_DEBUGGING) && (op != OP_BEGIN_NO_HOOK) && (op != OP_BEGIN_HOOK)) + fprintf(stderr, "%s[%d]: swap %s in %s\n", __func__, __LINE__, 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) +{ + const 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) + { + const 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; + const s7_int pos = integer(car(args)); + if (sc->profile == 0) return(sc-> F); + + e = find_funclet(sc, cadr(args)); + if ((is_let(e)) && + (is_symbol(funclet_function(e)))) + { + const s7_pointer func_name = funclet_function(e); + s7_int *v; + profile_data_t *pd = sc->profile_data; + if (pos >= pd->size) + { + const 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 new_list, vs, vi, vn, vf, vl, matches; + profile_data_t *pd = sc->profile_data; + if ((!pd) || (pd->top == 0)) return(sc->F); + new_list = make_list(sc, 7, sc->F); + set_car(sc->elist_7, new_list); /* protect new_list */ + set_car(new_list, vs = make_simple_vector(sc, pd->top)); + set_car(cdr(new_list), vi = make_simple_int_vector(sc, pd->top * pd_block_size)); + set_car(cddr(new_list), make_integer(sc, ticks_per_second())); + { + s7_pointer mid_list = cdddr(new_list); + set_car(mid_list, vn = make_simple_vector(sc, pd->top)); + set_car(cdr(mid_list), vf = make_simple_vector(sc, pd->top)); + set_car(cddr(mid_list), vl = make_simple_int_vector(sc, pd->top)); + matches = cdddr(mid_list); + } + set_car(matches, sc->nil); + for (s7_int 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 (s7_int 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)); + set_car(sc->elist_7, sc->unused); + return(new_list); +} + +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 args) +{ + return(s7_apply_function(sc, func, set_plist_2(sc, args, sc->value))); /* s7_apply_function returns sc->value */ +} + +static s7_pointer g_dynamic_unwind(s7_scheme *sc, s7_pointer args) /* not fool-proof!! */ +{ + #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, 4, sc->is_procedure_symbol, sc->is_procedure_symbol, sc->T, sc->is_boolean_symbol) + + const s7_pointer func = car(args); + const s7_pointer dw_call = (is_pair(cddr(args))) ? caddr(args) : sc->F; + if (!is_boolean(dw_call)) + wrong_type_error_nr(sc, sc->dynamic_unwind_symbol, 2, dw_call, a_boolean_string); + 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, copy_proper_list(sc, cdr(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 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))) if_let_method_exists_return_value(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 + */ + { + s7_pointer new_catch; + new_cell(sc, new_catch, T_CATCH); + catch_tag(new_catch) = car(args); + catch_goto_loc(new_catch) = stack_top(sc); + catch_op_loc(new_catch) = (int32_t)(sc->op_stack_now - sc->op_stack); + catch_set_handler(new_catch, err); + catch_cstack(new_catch) = sc->goto_start; + push_stack(sc, (intptr_t)((is_any_macro(err)) ? OP_CATCH_2 : OP_CATCH), args, new_catch); + } + 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_pars(proc))) + set_curlet(sc, make_let_with_slot(sc, closure_let(proc), closure_pars(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 new_catch, 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, new_catch, T_CATCH); + catch_tag(new_catch) = tag; + catch_goto_loc(new_catch) = stack_top(sc); + catch_op_loc(new_catch) = (int32_t)(sc->op_stack_now - sc->op_stack); + catch_set_handler(new_catch, error_handler); + catch_cstack(new_catch) = 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(new_catch) = &new_goto_start; + if (SHOW_EVAL_OPS) fprintf(stderr, " longjmp call %s\n", display_truncated(body)); + push_stack(sc, OP_CATCH, error_handler, new_catch); + 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 new_catch, tag; + const s7_pointer ptag = cadr(sc->code), args = cddr(sc->code); + + /* defer making the error lambda */ + if (!is_pair(ptag)) /* (catch #t ...) or (catch sym ...) */ + tag = (is_symbol(ptag)) ? lookup_checked(sc, ptag) : ptag; + else tag = cadr(ptag); /* (catch 'sym ...) */ + + new_cell(sc, new_catch, T_CATCH); /* the catch object sitting on the stack */ + catch_tag(new_catch) = tag; + catch_goto_loc(new_catch) = stack_top(sc); + catch_op_loc(new_catch) = sc->op_stack_now - sc->op_stack; + catch_set_handler(new_catch, cdadr(args)); /* not yet a closure... */ + catch_cstack(new_catch) = sc->goto_start; + push_stack(sc, OP_CATCH_1, sc->code, new_catch); /* 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 new_catch; + new_cell(sc, new_catch, T_CATCH); + catch_tag(new_catch) = sc->T; + catch_goto_loc(new_catch) = stack_top(sc); + catch_op_loc(new_catch) = sc->op_stack_now - sc->op_stack; + catch_set_handler(new_catch, sc->nil); + catch_cstack(new_catch) = sc->goto_start; + push_stack(sc, OP_CATCH_ALL, opt2_con(sc->code), new_catch); /* 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 */ + const s7_pointer e = make_let(sc, sc->rootlet); + begin_temp(sc->x, 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 + end_temp(sc->x); + return(e); +} + +#if WITH_HISTORY +static s7_pointer sanitize_history(s7_scheme *sc, s7_pointer code) +{ + begin_small_symbol_set(sc); /* make a list of words banned from the history */ + add_symbol_to_small_symbol_set(sc, sc->starlet_symbol); + add_symbol_to_small_symbol_set(sc, sc->eval_symbol); + add_symbol_to_small_symbol_set(sc, make_symbol(sc, "debug", 5)); + add_symbol_to_small_symbol_set(sc, make_symbol(sc, "trace-in", 8)); + add_symbol_to_small_symbol_set(sc, make_symbol(sc, "trace-out", 9)); + add_symbol_to_small_symbol_set(sc, sc->dynamic_unwind_symbol); + add_symbol_to_small_symbol_set(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; + } + end_small_symbol_set(sc); + 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; + const 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, sanitize_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 slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (is_pair(slot_value(slot))) + { + const s7_pointer new_list = copy_any_list(sc, slot_value(slot)); + slot_set_value(slot, 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) +{ + const 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) +{ + /* 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)) + */ + const 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) +{ + const s7_pointer catcher = T_Cat(stack_code(sc->stack, catch_loc)); + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + if ((catch_tag(catcher) == sc->T) || /* the normal case */ + (catch_tag(catcher) == type) || + (type == sc->T)) + { + const opcode_t op = stack_op(sc->stack, catch_loc); + s7_pointer error_body, error_pars; + const s7_pointer error_func = catch_handler(catcher); + const s7_uint loc = catch_goto_loc(catcher); + + begin_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_pars = car(error_func); + } + else + if (is_closure(error_func)) + { + error_body = closure_body(error_func); + error_pars = closure_pars(error_func); + } + else + { + error_body = NULL; + error_pars = NULL; + } + if ((error_body) && (is_null(cdr(error_body)))) + { + s7_pointer val = NULL; + error_body = car(error_body); + if (is_pair(error_body)) + { + if (is_quote(car(error_body))) + val = cadr(error_body); + else + if ((car(error_body) == sc->car_symbol) && + (is_pair(cdr(error_body))) && /* catch: (lambda args (car args)) */ + (cadr(error_body) == error_pars)) + val = type; + } + else + if (!is_symbol(error_body)) + val = error_body; /* not pair or symbol */ + else + if (error_body == error_pars) + val = list_2(sc, type, info); + else + if (is_keyword(error_body)) + val = error_body; + else + if ((is_pair(error_pars)) && + (error_body == car(error_pars))) + val = type; + if (val) + { + 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 = val; + end_temp(sc->y); + 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 new_func; + new_cell(sc, new_func, T_CLOSURE); + closure_set_pars(new_func, car(error_func)); + closure_set_body(new_func, cdr(error_func)); + closure_set_setter(new_func, sc->F); + closure_set_arity(new_func, CLOSURE_ARITY_NOT_SET); + closure_set_let(new_func, sc->temp4); + sc->code = new_func; + 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; + end_temp(sc->y); + 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; + end_temp(sc->y); + 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) +{ + const s7_pointer dw = T_Dyn(stack_code(sc->stack, catch_loc)); + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + if (dynamic_wind_state(dw) == dwind_body) + { + dynamic_wind_state(dw) = dwind_finish; /* make sure an uncaught error in the exit thunk doesn't cause us to loop */ + if (dynamic_wind_out(dw) != sc->F) + sc->value = s7_call(sc, dynamic_wind_out(dw), sc->nil); + } + return(false); +} + +static bool catch_out_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + s7_pointer port = 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, port); + port = stack_args(sc->stack, catch_loc); /* "args" = port that we shadowed, if not # */ + if (port != sc->unused) + set_current_output_port(sc, port); + return(false); +} + +static bool catch_in_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + s7_pointer port = T_Pri(stack_code(sc->stack, catch_loc)); /* "code" = port that we opened */ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + s7_close_input_port(sc, port); + port = stack_args(sc->stack, catch_loc); /* "args" = port that we shadowed, if not # */ + if (port != sc->unused) + set_current_input_port(sc, port); + return(false); +} + +static bool catch_read_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + 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) +{ + 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) +{ /* 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 || S7_DEBUGGING) 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) +{ /* from op_error_hook_quit */ + 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 */ + sc->reset_error_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) +{ + 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) +{ + 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 catch_let_temporarily_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + 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) +{ + const s7_pointer slot = stack_code(sc->stack, catch_loc); + const 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) +{ + const s7_pointer symbol = T_Sym(stack_code(sc->stack, catch_loc)); + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + if (starlet_symbol_id(symbol) != sl_no_field) /* we could be unwinding from an error that the symbol is not defined in *s7*! */ + starlet_set_1(sc, symbol, stack_args(sc->stack, catch_loc)); + return(false); +} + +static bool catch_let_temp_s7_openlets_unwind_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + 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) +{ + /* 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); +} + +static bool catch_load_close_function(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info) +{ + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + if ((S7_DEBUGGING) && (!is_loader_port(current_input_port(sc)))) fprintf(stderr, "%s[%d]: %s not loading?\n", __func__, __LINE__, display(current_input_port(sc))); + if (SHOW_EVAL_OPS) fprintf(stderr, "%s closing %s\n", __func__, display(current_input_port(sc))); + + /* this looks like catch_eval_function */ + s7_close_input_port(sc, current_input_port(sc)); + pop_input_port(sc); + /* sc->current_file = NULL; */ + return(false); +} + +typedef bool (*catch_function_t)(s7_scheme *sc, s7_int catch_loc, s7_pointer type, s7_pointer info); +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_BARRIER] = catch_barrier_function; + catchers[OP_CATCH] = catch_1_function; + catchers[OP_CATCH_1] = catch_1_function; + catchers[OP_CATCH_2] = catch_2_function; + catchers[OP_CATCH_ALL] = catch_all_function; + catchers[OP_DEACTIVATE_GOTO] = catch_goto_function; + catchers[OP_DYNAMIC_UNWIND] = catch_dynamic_unwind_function; + catchers[OP_DYNAMIC_WIND] = catch_dynamic_wind_function; + catchers[OP_ERROR_HOOK_QUIT] = catch_error_hook_function; + catchers[OP_EVAL_STRING] = catch_eval_function; + catchers[OP_GET_OUTPUT_STRING] = catch_out_function; + catchers[OP_LET_TEMP_DONE] = catch_let_temporarily_function; + catchers[OP_LET_TEMP_S7_OPENLETS_UNWIND] = catch_let_temp_s7_openlets_unwind_function; + catchers[OP_LET_TEMP_S7_UNWIND] = catch_let_temp_s7_unwind_function; + catchers[OP_LET_TEMP_UNWIND] = catch_let_temp_unwind_function; + catchers[OP_MAP_UNWIND] = catch_map_unwind_function; + catchers[OP_READ_DONE] = catch_read_function; /* perhaps an error during (read) */ + catchers[OP_UNWIND_INPUT] = catch_in_function; + catchers[OP_UNWIND_OUTPUT] = catch_out_function; + catchers[OP_LOAD_CLOSE_AND_POP_IF_EOF] = catch_load_close_function; + /* do we need one for load_return_if_eof? */ +} + +/* -------------------------------- 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) + + const 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 (s7_int op_loc = stack_top(sc) - 5; op_loc >= 3; op_loc -= 4) /* look for a catcher */ + { + catch_function_t catcher = catchers[stack_op(sc->stack, op_loc)]; + if ((catcher) && + (catcher(sc, op_loc, type, info))) + { + if (sc->longjmp_ok) LongJmp(*(sc->goto_start), throw_jump); + return(sc->value); + }} + if (is_let(car(args))) + if_let_method_exists_return_value(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 no_return void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) +{ /* half the reported compute time here is in the longjmp after the catcher runs */ + s7_pointer cur_code = current_code(sc); +#if WITH_HISTORY + if ((is_free(cur_code)) || (cur_code == sc->unused)) cur_code = sc->F; +#endif + + 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->do_body_p = NULL; +#if S7_DEBUGGING + sc->small_symbol_set_state = set_ignore; + sc->big_symbol_set_state = set_ignore; + sc->v = sc->unused; + sc->x = sc->unused; + sc->y = sc->unused; + sc->temp3 = sc->unused; + sc->temp6 = sc->unused; + sc->temp7 = sc->unused; + sc->temp9 = sc->unused; +#endif + 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_safe_list_in_use(sc->safe_lists[sc->current_safe_list]); /* clears 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) + { + int32_t i = 0; + sc->cur_code = (sc->using_history1) ? sc->eval_history2 : sc->eval_history1; + sc->using_history1 = (!sc->using_history1); + for (s7_pointer p = sc->cur_code; i < sc->history_size; i++, p = cdr(p)) car(p) = sc->nil; + } +#endif + if (is_pair(cur_code)) /* not redundant -- maybe use unchecked_type here */ + { + s7_int line = -1, file, position; + if (has_location(cur_code)) /* ignore callgrind! this is the normal case */ + { + 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))) && (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; + /* p itself never has the line/file info */ + 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 (s7_int op_loc = stack_top(sc) - 1; op_loc >= 3; op_loc -= 4) + { + catch_function_t catcher = catchers[stack_op(sc->stack, op_loc)]; + if ((SHOW_EVAL_OPS) && (catcher)) {fprintf(stderr, "before catch:\n"); s7_show_stack(sc);} + if ((catcher) && + (catcher(sc, op_loc, type, info))) + { + 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 ((!(sc->reset_error_hook)) && + (hook_has_functions(sc->error_hook))) + { + const 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->temp_error_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->temp_error_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 + { + const 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)), '~'))) + { + const 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 port = sc->input_port_stack[sc->input_port_stack_loc - 1]; + if ((is_input_port(port)) && + (port_file(port) != stdin) && + (!port_is_closed(port))) + { + filename = port_filename(port); + line = port_line_number(port); + 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; + sc->reset_error_hook = false; /* ?? */ + } + 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 no_return 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. + */ + const s7_pointer port = 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 start, end, slen, size; + char *recent_input = NULL; + + /* we can run off the end in cases like (eval-string "(. . ,.)") or (eval-string " (@ . ,.)") */ + if (port_position(port) >= port_data_size(port)) + port_position(port) = port_data_size(port) - 1; + + /* start at current position and look back a few chars */ + start = port_position(port); + for (s7_int j = 0; (start > 0) && (j < QUOTE_SIZE); start--, j++) + if ((port_data(port)[start] == '\0') || (port_data(port)[start] == '\n') || (port_data(port)[start] == '\r')) + break; + + /* start at current position and look ahead a few chars */ + size = port_data_size(port); + end = port_position(port); + for (s7_int j = 0; (end < size) && (j < QUOTE_SIZE); end++, j++) + if ((port_data(port)[end] == '\0') || (port_data(port)[end] == '\n') || (port_data(port)[end] == '\r')) + break; + + 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 (s7_int i = 0; i < (slen + 8); i++) recent_input[i] = '.'; + recent_input[3] = ' '; + recent_input[slen + 4] = ' '; + for (s7_int i = 0; i < slen; i++) recent_input[i + 4] = port_data(port)[start + i]; + } + + if ((port_line_number(port) > 0) && + (port_filename(port))) + { + const s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + port_filename_length(port) + safe_strlen(sc->current_file) + 64; + const s7_pointer str = make_empty_string(sc, len, '\0'); + char *msg = string_value(str); + string_length(str) = snprintf(msg, len, "%s: %s %s[%u], last top-level form at: %s[%" ld64 "]", + errmsg, (recent_input) ? recent_input : "", port_filename(port), port_line_number(port), + sc->current_file, sc->current_line); + if (recent_input) free(recent_input); + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); + } + else + { + const s7_int len = safe_strlen(recent_input) + safe_strlen(errmsg) + safe_strlen(sc->current_file) + 64; + const s7_pointer str = make_empty_string(sc, len, '\0'); + char *msg = string_value(str); + if ((sc->current_file) && + (sc->current_line >= 0)) + string_length(str) = 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(str) = 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, str)); + }}} + + if ((port_line_number(port) > 0) && + (port_filename(port))) + { + s7_int nlen; + const s7_int len = safe_strlen(errmsg) + port_filename_length(port) + safe_strlen(sc->current_file) + 128; + const s7_pointer str = make_empty_string(sc, len, '\0'); + char *msg = string_value(str); + 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(port), port_line_number(port), + 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(port), port_line_number(port), + sc->current_file, sc->current_line); + string_length(str) = nlen; + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); + } + 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 no_return void read_error_nr(s7_scheme *sc, const char *errmsg) {read_error_1_nr(sc, errmsg, false);} +static no_return 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) +{ + const 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) +{ + const s7_int len = sc->print_length; + const s7_int old_max_len = sc->objstr_max_len; + sc->objstr_max_len = len + 2; + { + s7_pointer result = s7_object_to_string(sc, p, false); + sc->objstr_max_len = old_max_len; + if (string_length(result) > len) + truncate_string(string_value(result), len, p_display); /* only use of truncate_string */ + return(result); + } +} + +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 cur_line = (uint32_t)pair_line_number(p); + if (cur_line > 0) + { + if (line == 0) /* first line number we encounter will be the current reader location (i.e. the end of the form) */ + line = cur_line; + else + if (cur_line < line) + return(p); + }} + tp = tree_descend(sc, car(p), line); + return((tp) ? tp : tree_descend(sc, cdr(p), line)); +} + +static no_return void missing_close_paren_error_nr(s7_scheme *sc) +{ + char *syntax_msg = NULL; + const s7_pointer port = 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(port) > 0) && + (port_filename(port))) + { + set_integer(slot_value(sc->error_line), port_line_number(port)); + set_integer(slot_value(sc->error_position), port_position(port)); + slot_set_value(sc->error_file, wrap_string(sc, port_filename(port), port_filename_length(port))); + } + 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)) + { + const s7_pointer p = tree_descend(sc, sc->args, 0); + if ((p) && (is_pair(p)) && + (has_location(p))) + { + const s7_pointer strp = object_to_string_truncated(sc, p); + const char *form = string_value(strp); + const s7_int form_len = string_length(strp); + const 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(port) > 0) && + (port_filename(port))) + { + s7_int nlen; + const s7_int len = port_filename_length(port) + safe_strlen(sc->current_file) + safe_strlen(syntax_msg) + 128; + const s7_pointer str = make_empty_string(sc, len, '\0'); + char *msg = string_value(str); + if (syntax_msg) + { + nlen = snprintf(msg, len, "missing close paren, %s[%u], last top-level form at %s[%" ld64 "]\n%s", + port_filename(port), port_line_number(port), + 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(port), port_line_number(port), + sc->current_file, sc->current_line); + string_length(str) = nlen; + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); + } + if (syntax_msg) + { + s7_int len = safe_strlen(syntax_msg) + 128; + const s7_pointer str = make_empty_string(sc, len, '\0'); + char *msg = string_value(str); + len = catstrs(msg, len, "missing close paren\n", syntax_msg, "\n", (char *)NULL); + free(syntax_msg); + string_length(str) = len; + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); + } + if ((is_input_port(port)) && + (!port_is_closed(port)) && + (port_data(port)) && + (port_position(port) > 0)) + { + const s7_pointer str = make_empty_string(sc, 128, '\0'); + const s7_int pos = port_position(port); + s7_int start = pos - 40; + char *msg = string_value(str); + memcpy((void *)msg, (const void *)"missing close paren: ", 21); + if (start < 0) start = 0; + memcpy((void *)(msg + 21), (void *)(port_data(port) + start), pos - start); + string_length(str) = 21 + pos - start; + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); + } + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, wrap_string(sc, "missing close paren", 19))); +} + +static no_return 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->temp_error_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 '# 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); +} + + +/* -------------------------------- 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); +} + +static s7_pointer g_hook_functions(s7_scheme *sc, s7_pointer args) +{ + #define H_hook_functions "(hook-functions hook) gets or sets the list of functions associated with the hook" + #define Q_hook_functions s7_make_signature(sc, 2, sc->is_list_symbol, sc->is_procedure_symbol) + s7_pointer hook = car(args), slot; + if (!is_any_closure(hook)) /* closure* -> closure if no args */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "hook-functions hook must be a procedure created by make-hook: ~S", 64), hook)); + slot = lookup_slot_from(sc->body_symbol, closure_let(hook)); + return((is_slot(slot)) ? slot_value(slot) : sc->nil); +} + +static s7_pointer g_hook_set_functions(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer hook = car(args); + s7_pointer lst, p; + if (!is_any_closure(hook)) /* closure* -> closure if no args */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "set! hook-functions hook must be a procedure created by make-hook: ~S", 69), hook)); + lst = cadr(args); + for (p = lst; is_pair(p); p = cdr(p)) + if ((!is_any_procedure(car(p))) || (!s7_is_aritable(sc, car(p), 1))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "new hook-functions value must be nil or a list of functions, each accepting one argument: ~S", 92), lst)); + if (!is_null(p)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "new hook-functions value must be nil or a a proper list: ~S", 59), lst)); + { + s7_pointer slot = lookup_slot_from(sc->body_symbol, closure_let(hook)); + if (is_slot(slot)) slot_set_value(slot, lst); + } + return(lst); +} + + +/* -------------------------------- 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 + */ + const opcode_t op = sc->cur_op; + push_stack_direct(sc, OP_BARRIER); + sc->begin_hook(sc, &result); + if (result) + { + const 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 #) + * 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); + begin_temp(sc->y, p = cons(sc, car(d), cdr(d))); + 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_with_end_temp(sc->y); +} + +static no_return 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 + */ + const 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_pair(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; + const 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 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: + { + s7_pointer result = 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(result); + } + case T_COMPLEX_VECTOR: + { + s7_pointer result = univect_ref(sc, set_ulist_1(sc, obj, indices), sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR); + set_car(sc->u1_1, sc->F); + return(result); + } + case T_INT_VECTOR: + { + s7_pointer result = 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(result); + } + case T_BYTE_VECTOR: + { + s7_pointer result = 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(result); + } + 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: + { + s7_pointer result = (*(c_object_ref(sc, obj)))(sc, set_ulist_1(sc, obj, indices)); + set_car(sc->u1_1, sc->F); + return(result); + } + 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, /* ((list (lambda (x) (values x x))) 0 1) */ + set_elist_3(sc, wrap_string(sc, "can't call an unsafe function implicitly: ~S ~S", 47), obj, indices)); + check_stack_size(sc); + sc->temp9 = 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->temp9); + if ((S7_DEBUGGING) && (!is_pair(sc->temp9))) fprintf(stderr, "%s[%d]: temp9: %s\n", __func__, __LINE__, display(sc->temp9)); + sc->temp9 = 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: /* probably something like ((list abs) 0 -1) */ + return(apply_c_function_unopt(sc, obj, indices)); + + case T_C_RST_NO_REQ_FUNCTION: + if (!is_safe_procedure(obj)) /* values in particular */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "can't call an unsafe procedure implicitly: ~S ~S", 48), obj, indices)); + 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->temp9 = indices; /* (needs_copied_args(obj)) ? copy_proper_list(sc, indices) : indices; */ /* do not use sc->args here! */ + /* the following s7_call can clobber the temp var */ + sc->value = s7_call(sc, obj, sc->temp9); + sc->temp9 = 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; + s7_pointer arg, par, call_args; + const s7_pointer func = sc->code; + s7_pointer *df; + const 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_small_symbol_set + */ + 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 pars; + int32_t j; + for (j = 0, pars = call_args; j < n_args; j++, pars = cdr(pars)) + 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(pars)) + { + 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(pars), 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(pars); + karg = cdr(karg); + set_car(pars, 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, par; + const s7_pointer func = sc->code; + const 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; /* this protection is needed, see snd-test.scm test 8 */ + 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; + sc->z = sc->unused; + 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, has_let_signature(sc)) + + if (is_pair(cdr(args))) + { + s7_pointer e = cadr(args); + if (!is_let(e)) + { + s7_pointer new_let = find_let(sc, e); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->eval_symbol, e, new_let, 2, args); + e = new_let; + } + 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_BACRO] = sc->is_macro_symbol; + sc->type_to_typers[T_BACRO_STAR] = sc->is_macro_symbol; + sc->type_to_typers[T_BIG_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_BOOLEAN] = sc->is_boolean_symbol; + sc->type_to_typers[T_BYTE_VECTOR] = sc->is_byte_vector_symbol; + sc->type_to_typers[T_CATCH] = sc->F; + sc->type_to_typers[T_CHARACTER] = sc->is_char_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_COMPLEX] = sc->is_complex_symbol; + sc->type_to_typers[T_CONTINUATION] = sc->is_continuation_symbol; + sc->type_to_typers[T_COUNTER] = sc->F; + sc->type_to_typers[T_FREE] = sc->error_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_MACRO] = sc->is_macro_symbol; + sc->type_to_typers[T_C_OBJECT] = sc->is_c_object_symbol; + sc->type_to_typers[T_C_POINTER] = sc->is_c_pointer_symbol; + sc->type_to_typers[T_C_RST_NO_REQ_FUNCTION] = sc->is_procedure_symbol; + sc->type_to_typers[T_DYNAMIC_WIND] = sc->F; + sc->type_to_typers[T_EOF] = sc->is_eof_object_symbol; + sc->type_to_typers[T_FLOAT_VECTOR] = sc->is_float_vector_symbol; + sc->type_to_typers[T_COMPLEX_VECTOR] = sc->is_complex_vector_symbol; + sc->type_to_typers[T_FREE] = sc->F; + sc->type_to_typers[T_GOTO] = sc->is_goto_symbol; + sc->type_to_typers[T_HASH_TABLE] = sc->is_hash_table_symbol; + sc->type_to_typers[T_INPUT_PORT] = sc->is_input_port_symbol; + sc->type_to_typers[T_INTEGER] = sc->is_integer_symbol; + sc->type_to_typers[T_INT_VECTOR] = sc->is_int_vector_symbol; + sc->type_to_typers[T_ITERATOR] = sc->is_iterator_symbol; + sc->type_to_typers[T_LET] = sc->is_let_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_NIL] = sc->is_null_symbol; + sc->type_to_typers[T_OUTPUT_PORT] = sc->is_output_port_symbol; + sc->type_to_typers[T_PAIR] = sc->is_pair_symbol; + sc->type_to_typers[T_RANDOM_STATE] = sc->is_random_state_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_SLOT] = sc->F; + sc->type_to_typers[T_STACK] = sc->F; + sc->type_to_typers[T_STRING] = sc->is_string_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_UNDEFINED] = sc->is_undefined_symbol; + sc->type_to_typers[T_UNSPECIFIED] = sc->is_unspecified_symbol; + sc->type_to_typers[T_UNUSED] = sc->F; + sc->type_to_typers[T_VECTOR] = sc->is_vector_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 gc_list_t *call_c_object_frees(s7_scheme *sc) +{ + gc_list_t *gp = sc->c_objects; + for (s7_int i = 0; i < gp->loc; i++) + { + s7_pointer cobj = gp->list[i]; + if (c_object_gc_free(sc, cobj)) + (*(c_object_gc_free(sc, cobj)))(sc, cobj); + else (*(c_object_free(sc, cobj)))(c_object_value(cobj)); + } + return(gp); +} + +static s7_pointer g_exit(s7_scheme *sc, s7_pointer args) +{ + #define H_exit "(exit obj cobj) exits s7. 'obj', the value passed to libc's exit, can be an integer or #t=success (0) or #f=fail (1). \ +'cobj' is a boolean (defaults to #f), #t causes exit to call all active c-object gc_free functions." + #define Q_exit s7_make_signature(sc, 3, sc->T, sc->T, sc->is_boolean_symbol) + + /* calling s7_eval_c_string in an atexit function seems to be problematic -- it works, but args can be changed? */ + /* r7rs.pdf says exit checks the stack for dynamic-winds and runs the "after" functions, if any, + * and that it allows 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 (s7_int op_loc = stack_top(sc) - 1; op_loc > 0; op_loc -= 4) + if (stack_op(sc->stack, op_loc) == OP_DYNAMIC_WIND) + { + s7_pointer dwind = T_Dyn(stack_code(sc->stack, op_loc)); + 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); + }} + /* another case that Victor Lazzarini mentioned: there's no easy way in s7 to ask that all c-object free methods be run before exiting. + * I think I'll add that code here under an optional second argument. + */ + if ((is_pair(args)) && (is_pair(cdr(args)))) + { + s7_pointer cobj = cadr(args); + if (!is_boolean(cobj)) + wrong_type_error_nr(sc, sc->exit_symbol, 2, cobj, a_boolean_string); + if (cobj == sc->T) + call_c_object_frees(sc); + } + 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 */ + { + s7_pointer 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_t_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(); + /* this usually signals a problem with enviroments (or arglists if optimize_lambda) */ + } +} + +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_t_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_t_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_t_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_defined_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), opt1_con(cdr(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) + + +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 +} + +static s7_pointer fx_random_i_wrapped(s7_scheme *sc, s7_pointer arg) +{ +#if WITH_GMP + return(g_random_i(sc, cdr(arg))); +#else + return(wrap_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(opt1_con(cdr(arg))), 1));} +static s7_pointer fx_add_fs(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, lookup(sc, caddr(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(opt1_con(cdr(arg))), 1));} +static s7_pointer fx_add_ft(s7_scheme *sc, s7_pointer arg) {return(g_add_xf(sc, t_lookup(sc, caddr(arg), arg), real(cadr(arg)), 2));} + + +#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) + + +#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 = 0; \ + if (!add_overflow(integer(x), integer(opt1_con(cdr(arg))), &val)) \ + return(make_integer(sc, val)); \ + } \ + else return(make_integer(sc, integer(x) + integer(opt1_con(cdr(arg))))); \ + } \ + return(add_p_pp(sc, x, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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)); \ + } +/* overflow check here slows tleft by about 35 out of ca 750, parallel add case does not check + * (define most-negative-fixnum (*s7* 'most-negative-fixnum)) + * (display (let ((f (lambda () (let ((S (- most-negative-fixnum 1))) S)))) (f))) (newline) + * -> 9223372036854775807 or (checked) -9223372036854776000.0 + */ + +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 = 0; \ + if (!subtract_overflow(integer(x), integer(opt1_con(cdr(arg))), &val)) \ + return(make_integer(sc, val)); \ + } \ + else return(make_integer(sc, integer(x) - integer(opt1_con(cdr(arg))))); \ + } \ + return(subtract_p_pp(sc, x, opt1_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(opt1_con(cdr(arg))))); /* caddr(arg) */ \ + return(g_subtract_2f(sc, set_plist_2(sc, x, opt1_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, opt1_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, caddr(arg)); + switch (type(x)) + { + case T_INTEGER: return(make_real(sc, n - integer(x))); + case T_RATIO: return(make_real(sc, n - (s7_double)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) == opt1_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 num = u_lookup(sc, cadr(arg), arg); + if (is_t_integer(num)) return(make_boolean(sc, integer(num) > 0)); + return(make_boolean(sc, is_positive_b_7p(sc, num))); +} + +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 p = Lookup(sc, cadr(arg), arg); \ + return((is_t_complex(p)) ? make_real(sc, real_part(p)) : real_part_p_p(sc, p)); \ + } + +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 p = Lookup(sc, cadr(arg), arg); \ + return((is_t_complex(p)) ? make_real(sc, imag_part(p)) : imag_part_p_p(sc, p)); \ + } + +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 */ + const s7_int ilen = integer(opt3_con(arg)); /* is_t_integer checked in fx_choose */ + const 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)) == (s7_uint)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_ITERATOR: + { + s7_pointer len = s7_length(sc, iterator_sequence(val)); + return(make_boolean(sc, (is_t_integer(len)) && (integer(len) == ilen))); + } + case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_COMPLEX_VECTOR: + return(make_boolean(sc, vector_length(val) == 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) +{ + const s7_int ilen = integer(opt3_con(arg)); /* caddr(arg) */ + const 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)) < (s7_uint)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_ITERATOR: + { + s7_pointer len = s7_length(sc, iterator_sequence(val)); + return(make_boolean(sc, (is_t_integer(len)) && (integer(len) < ilen))); + } + case T_BYTE_VECTOR: case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_COMPLEX_VECTOR: + return(make_boolean(sc, vector_length(val) < 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, opt1_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)), opt1_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(opt1_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(opt1_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(opt1_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), opt1_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(opt1_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)), opt1_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)), opt1_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), opt1_con(cdr(arg))));} +static s7_pointer fx_leq_sc(s7_scheme *sc, s7_pointer arg) {return(leq_p_pp(sc, lookup(sc, cadr(arg)), opt1_con(cdr(arg))));} +static s7_pointer fx_lt_sc(s7_scheme *sc, s7_pointer arg) {return(lt_p_pp(sc, lookup(sc, cadr(arg)), opt1_con(cdr(arg))));} +static s7_pointer fx_gt_sc(s7_scheme *sc, s7_pointer arg) {return(gt_p_pp(sc, lookup(sc, cadr(arg)), opt1_con(cdr(arg))));} +static s7_pointer fx_geq_sc(s7_scheme *sc, s7_pointer arg) {return(geq_p_pp(sc, lookup(sc, cadr(arg)), opt1_con(cdr(arg))));} +static s7_pointer fx_list_sc(s7_scheme *sc, s7_pointer arg) {return(list_2(sc, lookup(sc, cadr(arg)), opt1_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 == opt1_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, caddr(arg), 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, caddr(arg), arg))); +} + +static s7_pointer fx_cons_cs(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt1_con(cdr(arg)), lookup(sc, caddr(arg))));} +static s7_pointer fx_cons_ct(s7_scheme *sc, s7_pointer arg) {return(cons(sc, opt1_con(cdr(arg)), t_lookup(sc, caddr(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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_sym(cdr(arg)))));} */ +static s7_pointer fx_multiply_fs(s7_scheme *sc, s7_pointer arg) {return(g_mul_xf(sc, lookup(sc, caddr(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(opt1_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(opt1_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(opt1_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(opt1_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(opt1_con(cdr(arg))), 1));} +static s7_pointer fx_multiply_is(s7_scheme *sc, s7_pointer arg) {return(g_mul_xi(sc, lookup(sc, caddr(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, caddr(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, opt1_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_wrapped(s7_scheme *sc, s7_pointer x) +{ + if (is_t_real(x)) return(wrap_real(sc, real(x) * real(x))); +#if WITH_GMP + return(multiply_p_pp(sc, x, x)); +#else + if (is_t_integer(x)) + return(multiply_if_overflow_to_real_wrapped(sc, integer(x), integer(x))); + if (is_t_complex(x)) + return(wrap_complex(sc, real_part(x) * real_part(x) - imag_part(x) * imag_part(x), 2.0 * real_part(x) * imag_part(x))); + return(fx_sqr_1(sc, 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, arg=(+ (* x x) (* y y)) */ +{ + sc->temp5 = fx_sqr_wrapped(sc, lookup(sc, car(opt1_pair(cdr(arg))))); /* cadadr(arg) */ + return(add_p_pp(sc, sc->temp5, fx_sqr_wrapped(sc, lookup(sc, car(opt3_pair(arg)))))); /* cadaddr(arg) */ +} + +static s7_pointer fx_hypot(s7_scheme *sc, s7_pointer arg) /* (sqrt (+ (* x x) (* y y))) */ +{ + sc->temp5 = fx_sqr_wrapped(sc, lookup(sc, opt1_sym(cdr(arg)))); /* cadadadr(arg) ! -> x */ + return(sqrt_p_p(sc, add_p_pp_wrapped(sc, sc->temp5, fx_sqr_wrapped(sc, lookup(sc, opt3_sym(cdr(arg))))))); /* cadaddadr(arg) -> y */ +} + +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_wrapped(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_wrapped(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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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(opt1_sym(cdr(arg)))));} + +static s7_pointer fx_gt_tT(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num1 = t_lookup(sc, cadr(arg), arg); + s7_pointer num2 = T_lookup(sc, opt1_sym(cdr(arg)), arg); + return(((is_t_integer(num1)) && (is_t_integer(num2))) ? make_boolean(sc, integer(num1) > integer(num2)) : gt_p_pp(sc, num1, num2)); +} + +#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(opt1_con(cdr(arg))))); \ + if (is_t_real(x)) return(make_boolean(sc, real(x) > integer(opt1_con(cdr(arg))))); \ + return(g_greater_xi(sc, set_plist_2(sc, x, opt1_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, opt1_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, opt1_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, opt1_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(opt1_con(cdr(arg))))); \ + return(g_leq_xi(sc, set_plist_2(sc, x, opt1_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, opt1_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, opt1_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, opt1_sym(cdr(arg)))));} + +static s7_pointer fx_lt_gsg(s7_scheme *sc, s7_pointer arg) /* gsg is much faster than sss */ +{ + const s7_pointer v1 = lookup_global(sc, cadr(arg)); + const s7_pointer v2 = lookup(sc, opt1_sym(cdr(arg))); /* caddr(arg) */ + const 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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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(opt1_con(cdr(arg))))); + return(g_less_xf(sc, set_plist_2(sc, x, opt1_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(opt1_con(cdr(arg))))); \ + return(g_less_xi(sc, set_plist_2(sc, x, opt1_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(opt1_con(cdr(arg))))); + return(g_geq_xf(sc, set_plist_2(sc, x, opt1_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(opt1_con(cdr(arg))))); \ + return(g_geq_xi(sc, set_plist_2(sc, x, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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_cdr_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 slot = let_slots(lt); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + return(slot_value(slot)); + 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 = opt1_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))))); +} + +#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 arg1 = cadr(arg); \ + set_car(sc->t1_1, fn_proc(arg1)(sc, with_list_t1(Lookup(sc, cadr(arg1), arg1)))); \ + 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; + const s7_pointer 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; + const s7_pointer 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 arg1 = cadr(arg); \ + set_car(sc->t1_1, Lookup(sc, cadr(arg1), arg)); \ + return((fn_proc(arg1)(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 result = (is_pair(p)) ? car(p) : g_car(sc, set_plist_1(sc, p)); + return((result == 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)); \ + 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, opt1_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) \ + { \ + const s7_pointer arg1 = cadr(arg); \ + set_car(sc->t2_1, Lookup(sc, cadr(arg1), arg1)); \ + set_car(sc->t2_2, opt1_con(cdr(arg1))); \ + return(fn_proc(arg)(sc, with_list_t1(fn_proc(arg1)(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) +{ + const 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) +{ + const s7_pointer arg1 = cadr(arg); + set_car(sc->t2_1, lookup(sc, cadr(arg1))); + set_car(sc->t2_2, opt1_con(cdr(arg1))); + return((fn_proc(arg1)(sc, sc->t2_1) == sc->F) ? sc->T : sc->F); +} + +static s7_pointer fx_c_opcsq(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg1 = cadr(arg); + set_car(sc->t2_2, lookup(sc, caddr(arg1))); + set_car(sc->t2_1, opt1_con(cdr(arg1))); /* cadr(arg1) or cadadr */ + return(fn_proc(arg)(sc, with_list_t1(fn_proc(arg1)(sc, sc->t2_1)))); +} + +static s7_pointer fx_c_opcsq_c(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg1 = cadr(arg); + set_car(sc->t2_2, lookup(sc, caddr(arg1))); + set_car(sc->t2_1, opt1_con(cdr(arg1))); /* cadr(arg1) or cadadr */ + set_car(sc->t2_1, fn_proc(arg1)(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) +{ + const s7_pointer arg1 = cadr(arg); + set_car(sc->t2_2, lookup(sc, caddr(arg1))); + set_car(sc->t2_1, opt1_con(cdr(arg1))); /* cadr(arg1) or cadadr */ + set_car(sc->t2_1, fn_proc(arg1)(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) +{ + const s7_pointer arg1 = cadr(arg); + set_car(sc->t2_1, lookup(sc, cadr(arg1))); + set_car(sc->t2_2, lookup(sc, opt1_sym(cdr(arg1)))); + set_car(sc->t2_1, fn_proc(arg1)(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 arg1_p = 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(arg1_p)), lookup(sc, opt1_sym(arg1_p))), + lookup(sc, caddr(arg)))); +} + +static s7_pointer fx_add_mul_opssq_s(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg1_p = opt3_pair(arg); /* cdadr(arg) */ + const s7_pointer a = lookup(sc, car(arg1_p)); + const s7_pointer b = lookup(sc, opt1_sym(arg1_p)); + const 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_wrapped(sc, a, b), c)); +} + +static s7_pointer fx_cons_cons_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg1_p = opt3_pair(arg); /* cdadr(arg) */ + return(cons_unchecked(sc, cons(sc, lookup(sc, car(arg1_p)), lookup(sc, opt1_sym(arg1_p))), lookup(sc, caddr(arg)))); +} + +#define fx_add_sqr_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer num1 = Lookup(sc, car(opt3_pair(arg)), arg); \ + s7_pointer num2 = lookup(sc, caddr(arg)); \ + if ((is_t_complex(num1)) && (is_t_complex(num2))) \ + { \ + s7_double r = real_part(num1), i = imag_part(num1); \ + return(make_complex(sc, real_part(num2) + r * r - i * i, imag_part(num2) + 2.0 * r * i)); \ + } \ + return(add_p_pp(sc, fx_sqr_wrapped(sc, num1), num2)); \ + } + +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 arg1_p = opt3_pair(arg); /* cdadr(arg) */ + s7_pointer num1 = lookup(sc, car(arg1_p)); + s7_pointer num2 = lookup(sc, opt1_sym(arg1_p)); + s7_pointer num3 = lookup(sc, caddr(arg)); + if ((is_t_real(num1)) && (is_t_real(num2)) && (is_t_real(num3))) return(make_real(sc, real(num3) + real(num1) - real(num2))); + return(add_p_pp(sc, subtract_p_pp_wrapped(sc, num1, num2), num3)); +} + +static s7_pointer fx_add_sub_tu_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num1 = t_lookup(sc, car(cdadr(arg)), arg); + s7_pointer num2 = u_lookup(sc, cadr(cdadr(arg)), arg); + s7_pointer num3 = lookup(sc, caddr(arg)); + if ((is_t_real(num1)) && (is_t_real(num2)) && (is_t_real(num3))) return(make_real(sc, real(num3) + real(num1) - real(num2))); + return(add_p_pp(sc, subtract_p_pp_wrapped(sc, num1, num2), num3)); +} + +static s7_pointer fx_gt_add_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg1_p = opt3_pair(arg); /* cdadr(arg) */ + s7_pointer x1 = lookup(sc, car(arg1_p)); + s7_pointer x2 = lookup(sc, opt1_sym(arg1_p)); + 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_wrapped(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_wrapped(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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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_wrapped(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))))); +} + +static inline s7_pointer fx_vref_vref_3(s7_scheme *sc, s7_pointer v1, s7_pointer num1, s7_pointer num2) +{ + if ((is_t_integer(num1)) && (is_t_integer(num2)) && ((is_t_vector(v1)) && (vector_rank(v1) == 1))) + { + s7_int index1 = integer(num1), index2 = integer(num2); + if ((index1 >= 0) && (index2 >= 0) && (index1 < vector_length(v1))) + { + s7_pointer v2 = vector_element(v1, index1); + if ((is_t_vector(v2)) && (vector_rank(v2) == 1) && (index2 < vector_length(v2))) + return(vector_element(v2, index2)); + }} + return(vector_ref_p_pp(sc, vector_ref_p_pp(sc, v1, num1), num2)); +} + +#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, opt1_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) +{ + const s7_pointer arg1 = cadr(arg); + set_car(sc->t2_1, lookup(sc, cadr(arg1))); + set_car(sc->t2_2, opt1_con(cdr(arg1))); + set_car(sc->t2_1, fn_proc(arg1)(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) \ + { \ + const s7_pointer arg1 = cadr(arg); \ + set_car(sc->t2_1, Lookup1(sc, cadr(arg1), arg1)); \ + set_car(sc->t2_2, Lookup2(sc, opt1_sym(cdr(arg1)), arg1)); \ + set_car(sc->t2_1, fn_proc(arg1)(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 arg1 = cadr(arg); + return(((s7_p_pp_t)opt3_direct(arg))(sc, fn_proc(arg1)(sc, set_plist_2(sc, lookup(sc, cadr(arg1)), t_lookup(sc, caddr(arg1), 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 arg1 = cadr(arg); \ + set_car(sc->t2_1, fn_proc(arg1)(sc, with_list_t1(Lookup1(sc, cadr(arg1), 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 lst = 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(lst)) return(lst); lst = cdr(lst); if (!is_pair(lst)) return(sc->F)); + return(sc->F); +} + +static s7_pointer fx_memq_car_s_2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer lst = 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(lst)) return(lst); + return((obj == cadr(lst)) ? cdr(lst) : sc->F); +} + +static s7_pointer fx_c_s_opssq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg2 = caddr(arg); + set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t2(lookup(sc, cadr(arg2)), lookup(sc, opt1_sym(cdr(arg2)))))); + 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 p_arg2 = 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(p_arg2)), Lookup2(sc, opt1_sym(p_arg2), p_arg2)))); \ + } + +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, opt1_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, opt1_sym(opt3_pair(arg)), arg)))); +} + +static s7_pointer fx_c_c_opssq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg2 = caddr(arg); + set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t2(lookup(sc, cadr(arg2)), lookup(sc, opt1_sym(cdr(arg2)))))); + set_car(sc->t2_1, cadr(arg)); /* currently ( 'a ) 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_wrapped(sc, x1, x2))); +} + +#define fx_c_s_opscq_any(Name, Lookup1, Lookup2) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + const s7_pointer arg2 = caddr(arg); \ + set_car(sc->t2_1, Lookup2(sc, cadr(arg2), arg)); \ + set_car(sc->t2_2, opt1_con(cdr(arg2))); \ + set_car(sc->t2_2, fn_proc(arg2)(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 vec = lookup(sc, cadr(arg)); + if ((is_t_integer(i)) && (is_t_vector(vec)) && (vector_rank(vec) == 1)) + { + s7_int index = integer(i) + 1; + if ((index >= 0) && (vector_length(vec) > index)) + return(vector_element(vec, index)); + } + return(vector_ref_p_pp(sc, vec, 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 arg2 = caddr(arg); + set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t1(lookup(sc, cadr(arg2))))); + 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 arg2 = opt3_pair(arg); /* caddr(arg) */ + set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t1(lookup(sc, cadr(arg2))))); + 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 argp = cdr(arg); + gc_protect_via_stack(sc, fn_proc(car(argp))(sc, with_list_t1(lookup(sc, cadar(argp))))); + argp = cadr(argp); + set_car(sc->t2_2, fn_proc(argp)(sc, with_list_t1(lookup(sc, cadr(argp))))); + set_car(sc->t2_1, gc_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 argp = cdr(arg); + gc_protect_via_stack(sc, fn_proc(car(argp))(sc, with_list_t1(lookup(sc, cadar(argp))))); + argp = cadr(argp); + set_car(sc->t2_1, lookup(sc, cadr(argp))); + set_car(sc->t2_2, lookup(sc, opt1_sym(cdr(argp)))); /* caddr(argp) */ + set_car(sc->t2_2, fn_proc(argp)(sc, sc->t2_1)); + set_car(sc->t2_1, gc_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 argp = cdr(arg); + return(((s7_p_pp_t)opt3_direct(arg))(sc, + ((s7_p_p_t)opt2_direct(argp))(sc, lookup(sc, cadar(argp))), + ((s7_p_pp_t)opt3_direct(argp))(sc, t_lookup(sc, opt2_sym(cdr(argp)), arg), u_lookup(sc, opt1_sym(argp), arg)))); +} + +static s7_pointer fx_num_eq_car_v_add_tu(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg)); + s7_pointer num2 = t_lookup(sc, opt2_sym(cddr(arg)), arg); + s7_pointer num3 = u_lookup(sc, opt1_sym(cdr(arg)), arg); + if ((is_t_integer(num1)) && (is_t_integer(num2)) && (is_t_integer(num3))) + return(make_boolean(sc, integer(num1) == (integer(num2) + integer(num3)))); + return(make_boolean(sc, num_eq_b_7pp(sc, num1, add_p_pp_wrapped(sc, num2, num3)))); +} + +static s7_pointer fx_num_eq_car_v_subtract_tu(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num1 = car_p_p(sc, v_lookup(sc, cadadr(arg), arg)); + s7_pointer num2 = t_lookup(sc, opt2_sym(cddr(arg)), arg); + s7_pointer num3 = u_lookup(sc, opt1_sym(cdr(arg)), arg); + if ((is_t_integer(num1)) && (is_t_integer(num2)) && (is_t_integer(num3))) + return(make_boolean(sc, integer(num1) == (integer(num2) - integer(num3)))); + return(make_boolean(sc, num_eq_b_7pp(sc, num1, subtract_p_pp_wrapped(sc, num2, num3)))); +} + +static s7_pointer fx_c_opssq_opsq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer argp = cdr(arg); + set_car(sc->t2_1, lookup(sc, cadar(argp))); + set_car(sc->t2_2, lookup(sc, opt1_sym(cdar(argp)))); + gc_protect_via_stack(sc, fn_proc(car(argp))(sc, sc->t2_1)); + argp = cadr(argp); + set_car(sc->t2_2, fn_proc(argp)(sc, with_list_t1(lookup(sc, cadr(argp))))); + set_car(sc->t2_1, gc_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 argp = cdr(arg); + set_car(sc->t2_1, lookup(sc, cadar(argp))); + set_car(sc->t2_2, lookup(sc, opt1_sym(cdar(argp)))); + gc_protect_via_stack(sc, fn_proc(car(argp))(sc, sc->t2_1)); + argp = cadr(argp); + set_car(sc->t2_1, lookup(sc, cadr(argp))); + set_car(sc->t2_2, lookup(sc, opt1_sym(cdr(argp)))); + set_car(sc->t2_2, fn_proc(argp)(sc, sc->t2_1)); + set_car(sc->t2_1, gc_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_wrapped(sc, s1, s2); + return(subtract_p_pp(sc, multiply_p_pp_wrapped(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_wrapped(sc, s1, s2); + return(add_p_pp(sc, multiply_p_pp_wrapped(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_wrapped(sc, s1, s2); + return(multiply_p_pp(sc, subtract_p_pp_wrapped(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_wrapped(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))); + a1 = opt1_pair(cdr(arg)); /* cdadr(arg) */ + return(lt_p_pp(sc, subtract_p_pp_wrapped(sc, lookup(sc, car(a1)), lookup(sc, cadr(a1))), sc->temp5)); +} + +static s7_pointer fx_sub_vref2(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg1p = cdadr(arg); + const s7_pointer vec = lookup(sc, car(arg1p)); + const s7_pointer num1 = lookup(sc, cadr(arg1p)); + const s7_pointer num2 = lookup(sc, opt3_sym(arg)); /* caddaddr(arg) */ + if ((is_t_integer(num1)) && (is_t_integer(num2)) && ((is_t_vector(vec)) && (vector_rank(vec) == 1))) + { + s7_int index1 = integer(num1), index2 = integer(num2); + if ((index1 >= 0) && (index1 <= vector_length(vec)) && (index2 >= 0) && (index2 < vector_length(vec))) + return(subtract_p_pp(sc, vector_ref_p_pi(sc, vec, index1), vector_ref_p_pi(sc, vec, index2))); + } + return(subtract_p_pp(sc, vector_ref_p_pp(sc, vec, num1), vector_ref_p_pp(sc, vec, num2))); +} + +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 result; + 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, gc_protected1(sc)); + result = fn_proc(arg)(sc, sc->t3_1); + unstack_gc_protect(sc); + return(result); +} + +#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 result; + /* 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(gc_protected1(sc))); + set_car(sc->t2_2, gc_protected2(sc)); + result = fn_proc(arg)(sc, sc->t2_1); + unstack_gc_protect(sc); + /* (define (f0) (write (vector 1.0) (openlet (inlet 'write for-each)))) or worse, + * (define L (openlet (inlet 'write for-each))) (define (f) (write (vector 1.0) L)) + * will segfault (probably) because the for-each pushes an operator on the stack, expecting to continue in eval, but + * write is a safe function that the optimizer thinks can ignore such stuff. s7.html warns about this -- the signatures should be compatible. + * Maybe openlet (or inlet?) should warn about for-each, map, member, and assoc. + * We could check first that stack_top_op == OP_GC_PROTECT and not unstack if it isn't, but there is nothing special to fx_c_aa in that regard. + */ + return(result); +} + +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 num = fx_call(sc, cdr(arg)); + if (is_t_integer(num)) return(subtract_if_overflow_to_real_or_big_integer(sc, integer(num), 1)); + if (is_t_real(num)) return(make_real(sc, real(num) - 1.0)); + return(subtract_p_pp(sc, num, int_one)); +} + +static s7_pointer fx_add_a1(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num = fx_call(sc, cdr(arg)); + if (is_t_integer(num)) return(add_if_overflow_to_real_or_big_integer(sc, integer(num), 1)); + if (is_t_real(num)) return(make_real(sc, real(num) + 1.0)); + return(add_p_pp(sc, num, int_one)); +} + +static s7_pointer fx_lt_ad(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer num = fx_call(sc, cdr(arg)); + if (is_t_real(num)) return(make_boolean(sc, real(num) < real(opt3_con(arg)))); + if (is_t_integer(num)) return(make_boolean(sc, integer(num) < real(opt3_con(arg)))); + return(make_boolean(sc, lt_b_7pp(sc, num, 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_multiply_sa_wrapped(s7_scheme *sc, s7_pointer arg) /* experiment */ +{ + 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(wrap_real(sc, real(x1) * real(x2))); + return(multiply_p_pp_wrapped(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; + const 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))) /* (define (func) (let ((f (lambda (a) a))) (f (+ (*s7* 'most-positive-fixnum) (*))))) (func) */ + return(add_if_overflow_to_real_or_big_integer(sc, integer(x1), integer(x2))); + return(add_p_pp(sc, x1, x2)); +} + +static s7_pointer fx_multiply_aa(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x2; + const 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 result; + /* 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, gc_protected2(sc)); + set_car(sc->t3_1, gc_protected1(sc)); + result = fn_proc(arg)(sc, sc->t3_1); + unstack_gc_protect(sc); + return(result); +} + +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 arg1 = cadr(arg); + set_car(sc->t1_1, fx_call(sc, cdr(arg1))); + return(fn_proc(arg)(sc, with_list_t1(fn_proc(arg1)(sc, sc->t1_1)))); +} + +static s7_pointer fx_c_opaaq(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg1 = cadr(arg); + s7_pointer result; + /* check_stack_size(sc); */ + gc_protect_via_stack(sc, fx_call(sc, cdr(arg1))); + set_car(sc->t2_2, fx_call(sc, cddr(arg1))); + set_car(sc->t2_1, gc_protected1(sc)); + result = fn_proc(arg1)(sc, sc->t2_1); + set_gc_protected2(sc, result); /* might be a big list etc (see s7test.scm fx_c_opaaq test) */ + result = fn_proc(arg)(sc, with_list_t1(result)); + unstack_gc_protect(sc); + return(result); +} + +static s7_pointer fx_c_opsaq(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer arg1 = cadr(arg); + set_car(sc->t2_2, fx_call(sc, cddr(arg1))); + set_car(sc->t2_1, lookup(sc, cadr(arg1))); + return(fn_proc(arg)(sc, with_list_t1(fn_proc(arg1)(sc, sc->t2_1)))); +} + +static s7_pointer fx_c_opaaaq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer arg1 = cadr(code); + gc_protect_2_via_stack(sc, fx_call(sc, cdr(arg1)), fx_call(sc, opt3_pair(arg1))); /* cddr(arg) */ + set_car(sc->t3_3, fx_call(sc, cdr(opt3_pair(arg1)))); + set_car(sc->t3_1, gc_protected1(sc)); + set_car(sc->t3_2, gc_protected2(sc)); + { + s7_pointer result = fn_proc(code)(sc, with_list_t1(fn_proc(arg1)(sc, sc->t3_1))); + unstack_gc_protect(sc); + return(result); + } +} + +static s7_pointer fx_c_s_opaaq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer arg2 = caddr(code); + gc_protect_via_stack(sc, fx_call(sc, cdr(arg2))); + set_car(sc->t2_2, fx_call(sc, cddr(arg2))); + set_car(sc->t2_1, gc_protected1(sc)); + set_car(sc->t2_2, fn_proc(arg2)(sc, sc->t2_1)); + set_car(sc->t2_1, lookup(sc, cadr(code))); + { + s7_pointer result = fn_proc(code)(sc, sc->t2_1); + unstack_gc_protect(sc); + return(result); + } +} + +static s7_pointer fx_c_4a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer arg = cdr(code), result; + check_stack_size(sc); /* t718 pp cycles #f */ + gc_protect_2_via_stack(sc, fx_call(sc, arg), fx_call(sc, cdr(arg))); + arg = cddr(arg); + set_gc_protected3(sc, fx_call(sc, arg)); + set_car(sc->t3_3, fx_call(sc, cdr(arg))); + set_car(sc->t3_2, gc_protected3(sc)); + set_car(sc->t3_1, gc_protected2(sc)); + set_car(sc->t4_1, gc_protected1(sc)); + result = fn_proc(code)(sc, sc->t4_1); + unstack_gc_protect(sc); + set_car(sc->t4_1, sc->F); + return(result); +} + +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?? */ + const s7_pointer arg = cdr(code); + s7_pointer result; + set_car(sc->t4_1, fx_call(sc, arg)); + set_car(sc->t3_1, fx_call(sc, cdr(arg))); + 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) */ + result = fn_proc(code)(sc, sc->t4_1); + set_car(sc->t4_1, sc->F); + return(result); +} + +static s7_pointer fx_c_c_opscq(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer arg2 = caddr(arg); + set_car(sc->t2_1, lookup(sc, cadr(arg2))); + set_car(sc->t2_2, opt1_con(cdr(arg2))); + set_car(sc->t2_2, fn_proc(arg2)(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) +{ + const s7_pointer arg2 = caddr(arg); + set_car(sc->t2_2, lookup(sc, caddr(arg2))); + set_car(sc->t2_1, opt1_con(cdr(arg2))); /* cadr(arg2) or cadadr */ + set_car(sc->t2_2, fn_proc(arg2)(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) +{ + const s7_pointer arg = opt1_pair(cdr(code)); + set_car(sc->t2_1, lookup(sc, cadr(arg))); + set_car(sc->t2_2, lookup(sc, opt1_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 result; + const s7_pointer 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))); + result = fn_proc(arg)(sc, lst); + if (in_heap(lst)) unstack_gc_protect(sc); + else clear_safe_list_in_use(lst); + return(result); +} + +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 result; + const s7_pointer 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)); + } + result = fn_proc(code)(sc, lst); + if (in_heap(lst)) unstack_gc_protect(sc); + else clear_safe_list_in_use(lst); + return(result); +} + +static s7_pointer fx_inlet_ca(s7_scheme *sc, s7_pointer code) +{ + s7_pointer new_e, sp = NULL; + s7_int 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. + */ + for (s7_pointer lst = cdr(code); is_pair(lst); lst = cddr(lst)) + { + s7_pointer symbol = car(lst), 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(lst)); /* it's necessary to do this first, before add_slot_unchecked */ + if (!sp) + sp = add_slot_unchecked_no_local_slot(sc, new_e, symbol, value); + 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 slot = let_slots(new_e); tis_slot(slot); slot = next_slot(slot)) + symbol_set_local_slot_unincremented(slot_symbol(slot), id, slot); /* was symbol_set_id(slot_symbol(slot), id) */ + unstack_gc_protect(sc); + return(new_e); +} + +static s7_pointer fx_c_na(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer args, p; + const s7_pointer 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_safe_list_in_use(val); + return(p); +} + +static s7_pointer fx_vector_ns(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer args = cdr(arg); + const 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); + const s7_pointer vec = make_simple_vector(sc, opt3_arglen(cdr(arg))); /* was s7_make_vector */ + s7_pointer *els = vector_elements(vec); + gc_protect_via_stack(sc, vec); + t_vector_fill(vec, 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 = vec; /* full-s7test 12262 list_p_p case */ + unstack_gc_protect(sc); + return(vec); +} + +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_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 val = sc->T; + for (s7_pointer p = cdr(arg); (is_pair(p)) && (val != sc->F); p = cdr(p)) /* in lg, 5/6 args appears to predominate */ + val = fx_call(sc, p); + return(val); +} + +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 val = fn_proc(cadr(arg))(sc, with_list_t1(lookup(sc, opt3_sym(cdr(arg))))); /* cadadr(arg) */ + return((val != sc->F) ? val : fn_proc(caddr(arg))(sc, sc->t1_1)); +} + +static s7_pointer fx_or_s_type_2(s7_scheme *sc, s7_pointer arg) +{ + int32_t val = type(lookup(sc, opt3_sym(cdr(arg)))); /* cadadr(arg)) */ + return(make_boolean(sc, (val == opt3_int(arg)) || (val == 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 val = sc->F; + for (s7_pointer p = cdr(arg); (is_pair(p)) && (val == sc->F); p = cdr(p)) + val = fx_call(sc, p); + return(val); +} + +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) +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer 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(func)); + result = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_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 */ +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), lookup(sc, opt2_sym(code)))); + result = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_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 */ +{ + const s7_pointer func = opt1_lambda(code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), lookup(sc, opt2_sym(code)))); + return(fx_call(sc, closure_body(func))); +} + +static s7_pointer fx_safe_closure_t_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), t_lookup(sc, opt2_sym(code), code))); + result = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_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)); + /* better but slower: return(add_if_overflow_to_real_or_big_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) +{ + const s7_pointer p = cdr(arg); + const s7_pointer val = fx_proc(cdar(p))(sc, car(p)); + sc->value = val; + set_car(sc->t2_2, fx_proc(cdadr(p))(sc, cadr(p))); + set_car(sc->t2_1, val); + return(fn_proc(arg)(sc, sc->t2_1)); +} + +static s7_pointer fx_safe_closure_a_to_sc(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer func = opt1_lambda(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(func)))(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 */ +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), lookup(sc, opt2_sym(code)))); + code = cdar(closure_body(func)); + 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, gc_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 */ +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), lookup(sc, opt2_sym(code)))); + code = cdar(closure_body(func)); + 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, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); +} + +static s7_pointer fx_safe_closure_a_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cdr(code)))); + result = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); +} + +static s7_pointer op_safe_closure_a_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cdr(code)))); + return(fx_call(sc, closure_body(func))); +} + +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) +{ + const s7_pointer func = opt1_lambda(code); + const s7_pointer and_arg = cdar(closure_body(func)); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), 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, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); +} + +static s7_pointer fx_safe_closure_ss_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)))); + result = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); +} + +static s7_pointer op_safe_closure_ss_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)))); + return(fx_call(sc, closure_body(func))); +} + +static s7_pointer fx_safe_closure_3s_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + s7_pointer result; + gc_protect_via_stack(sc, sc->curlet); + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code)))); + result = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_protected1(sc)); + unstack_gc_protect(sc); + return(result); +} + +static s7_pointer op_safe_closure_3s_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), lookup(sc, cadr(code)), lookup(sc, opt2_sym(code)), lookup(sc, opt3_sym(code)))); + return(fx_call(sc, closure_body(func))); +} + +static s7_pointer fx_safe_closure_aa_a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer p = cdr(code); + const s7_pointer func = 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(func), fx_call(sc, p), gc_protected2(sc))); + p = fx_call(sc, closure_body(func)); + set_curlet(sc, gc_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 fx_implicit_starlet_ref_s(s7_scheme *sc, s7_pointer arg) {return(starlet(sc, opt3_int(arg)));} +static s7_pointer fx_implicit_starlet_print_length(s7_scheme *sc, s7_pointer arg) {return(make_integer(sc, sc->print_length));} +static s7_pointer fx_implicit_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 expr) +{ + if (!is_pair(expr)) return(true); + if ((is_optimized(expr)) && /* this is needed. In check_tc, for example, is_fxable can be confused by early optimize_op */ + (fx_function[optimize_op(expr)])) + return(true); + return(is_proper_quote(sc, expr)); +} + +static int32_t fx_count(s7_scheme *sc, s7_pointer expr) +{ + int32_t count = 0; + for (s7_pointer p = cdr(expr); 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_normal_symbol(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_defined_global(P)) && (is_eq_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, const s7_pointer holder, const s7_pointer cur_env, safe_sym_t *checker) /* , const char *func, int32_t line) */ +{ + const 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) && (is_global(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_defined_global(arg)) ? fx_g : ((checker(sc, arg, cur_env)) ? fx_s : fx_unsafe_s)); + } + return(fx_c); + } + if (is_optimized(arg)) + { + const s7_pointer head = car(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 + if (fn_proc(arg) == g_cons) + { + set_opt1_con(cdr(arg), caddr(arg)); + return(fx_cons_cc); + } + return((fn_proc(arg) == g_random_i) ? fx_random_i : fx_c_nc); + + case OP_OR_2A: + { + const s7_pointer arg2p = cddr(arg); + if (fx_proc(arg2p) == fx_and_2a) {set_opt3_pair(arg, cdar(arg2p)); return(fx_or_and_2a);} + if (fx_proc(arg2p) == fx_and_3a) {set_opt3_pair(arg, cdar(arg2p)); return(fx_or_and_3a);} + if ((fx_proc(arg2p) == fx_not_is_symbol_s) && (fx_proc(arg2p) == fx_is_keyword_s) && (cadr(cadadr(arg)) == cadar(arg2p))) + { + /* (or (not (symbol? body)) (keyword? body)) */ + set_opt3_sym(arg, cadar(arg2p)); + return(fx_not_symbol_or_keyword); + } + return(fx_or_2a); + } + + case HOP_SAFE_C_S: + if (is_unchanged_global(head)) /* mus-copy would work here but in tgen (for example) it's loading generators.scm with local mus-copy methods */ + { + uint8_t typ; + if (head == sc->cdr_symbol) return(fx_cdr_s); + if (head == sc->car_symbol) return(fx_car_s); + if (head == sc->cadr_symbol) return(fx_cadr_s); + if (head == sc->cddr_symbol) return(fx_cddr_s); + if (head == sc->is_null_symbol) return(fx_is_null_s); + if (head == sc->is_pair_symbol) return(fx_is_pair_s); + if (head == sc->is_symbol_symbol) return(fx_is_symbol_s); + if (head == sc->is_eof_object_symbol) return(fx_is_eof_s); + if (head == sc->is_integer_symbol) return(fx_is_integer_s); + if (head == sc->is_string_symbol) return(fx_is_string_s); + if (head == sc->not_symbol) return(fx_not_s); + if (head == sc->is_proper_list_symbol) return(fx_is_proper_list_s); + if (head == sc->is_vector_symbol) return(fx_is_vector_s); + if (head == sc->is_keyword_symbol) return(fx_is_keyword_s); + if (head == sc->is_procedure_symbol) return(fx_is_procedure_s); + if (head == sc->length_symbol) return(fx_length_s); + /* not read_char here... */ + typ = symbol_type(head); + 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 (is_global(c_function_name_to_symbol(sc, global_value(head)))) + { + s7_p_p_t func = s7_p_p_function(global_value(head)); + if (func) + { + set_opt2_direct(cdr(arg), (s7_pointer)func); + if (func == real_part_p_p) return(fx_real_part_s); + if (func == imag_part_p_p) return(fx_imag_part_s); + if (func == iterate_p_p) return(fx_iterate_s); + if (func == car_p_p) return(fx_car_s); /* can happen if (define var-name car) etc */ + return((is_defined_global(cadr(arg))) ? fx_c_g_direct : fx_c_s_direct); + }}} + return((is_defined_global(cadr(arg))) ? fx_c_g : fx_c_s); + + case HOP_SAFE_C_SS: + { + s7_function func = fn_proc(arg); + if (func == g_cons) return(fx_cons_ss); + if (fx_matches(head, sc->num_eq_symbol)) return(fx_num_eq_ss); + if (func == g_geq_2) return(fx_geq_ss); + if (func == g_greater_2) return(fx_gt_ss); + if (func == g_leq_2) return(fx_leq_ss); + if (func == g_less_2) return((is_defined_global(caddr(arg))) ? fx_lt_sg : fx_lt_ss); + if ((fx_matches(head, sc->multiply_symbol)) && (cadr(arg) == caddr(arg))) return(fx_sqr_s); + if (func == g_is_eq) return(fx_is_eq_ss); + if (func == g_multiply_2) return(fx_multiply_ss); + if (func == g_add_2) return(fx_add_ss); + if (func == g_subtract_2) return(fx_subtract_ss); + if (func == g_hash_table_ref_2) return(fx_hash_table_ref_ss); + + if (is_global_and_has_func(head, s7_p_pp_function)) + { + if (head == sc->assq_symbol) return(fx_assq_ss); + if (head == sc->memq_symbol) return(fx_memq_ss); + if (head == sc->vector_ref_symbol) return(fx_vref_ss); + if (head == sc->string_ref_symbol) return(fx_sref_ss); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(head)))); + 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(head, 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(head)))); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_p_function(global_value(caadr(arg))))); + return(((head == 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_defined_global(cadr(arg))) && (is_defined_global(cadddr(arg)))) return(fx_lt_gsg); + if (is_global_and_has_func(head, s7_p_ppp_function)) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(head)))); + return(fx_c_sss_direct); + } + return(fx_c_sss); + + case HOP_SAFE_C_SSA: + if (is_global_and_has_func(head, s7_p_ppp_function)) + { + set_opt2_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(head)))); + return(fx_c_ssa_direct); + } + return(fx_c_ssa); + + case HOP_SAFE_C_SCS: + if (is_global_and_has_func(head, s7_p_ppp_function)) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_ppp_function(global_value(head)))); + 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: + { + const 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(head, s7_p_pp_function)) && + (is_global_and_has_func(car(s2), s7_p_pp_function))) + { + const s7_pointer arg1p = cdr(arg); + set_opt2_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(head)))); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(car(s2))))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, (s7_pointer)add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, (s7_pointer)subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, (s7_pointer)multiply_p_pp_wrapped); + set_opt3_pair(arg, cdr(s2)); + if (car(s2) == sc->vector_ref_symbol) + { + if (head == sc->geq_symbol) return(fx_geq_s_vref); /* ? */ + if (head == sc->is_eq_symbol) return(fx_is_eq_s_vref); /* ? */ + if (head == sc->hash_table_ref_symbol) return(fx_href_s_vref); /* tbig */ + if (head == sc->let_ref_symbol) return(fx_lref_s_vref); + if ((is_defined_global(cadr(arg))) && (is_defined_global(cadr(s2))) && (head == sc->vector_ref_symbol)) return(fx_vref_g_vref_gs); + } + if ((head == sc->vector_ref_symbol) && (car(s2) == sc->add_symbol)) return(fx_vref_s_add); /* ~b */ + return(fx_c_s_opssq_direct); + } + return(fx_c_s_opssq); + } + + case HOP_SAFE_C_opSSq_S: + if ((is_global_and_has_func(head, s7_p_pp_function)) && + (is_global_and_has_func(caadr(arg), s7_p_pp_function))) + { + /* op_c_opgsq_t */ + const s7_pointer arg1p = cdr(arg), arg1 = cadr(arg); + set_opt2_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(head)))); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(caar(arg1p))))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, (s7_pointer)add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, (s7_pointer)subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, (s7_pointer)multiply_p_pp_wrapped); + set_opt3_pair(arg, cdar(arg1p)); + if (car(arg1) == sc->vector_ref_symbol) + { + if (head == sc->gt_symbol) return(fx_gt_vref_s); /* ? */ + if (head == sc->vector_ref_symbol) return(fx_vref_vref_ss_s); /* b */ + } + if (head == sc->add_symbol) + { + if ((car(arg1) == sc->multiply_symbol) && (cadr(arg1) == caddr(arg1))) return(fx_add_sqr_s); /* (* s s) */ + if (car(arg1) == sc->subtract_symbol) return(fx_add_sub_s); + } + if ((head == sc->cons_symbol) && (car(arg1) == sc->cons_symbol)) return(fx_cons_cons_s); + /* also div(sub)[2] mul(div) */ + return(((head == sc->gt_symbol) && (car(arg1) == sc->add_symbol)) ? fx_gt_add_s : + (((head == sc->add_symbol) && (car(arg1) == sc->multiply_symbol)) ? fx_add_mul_opssq_s : fx_c_opssq_s_direct)); + } + return(fx_c_opssq_s); + + case HOP_SAFE_C_opSSq_opSSq: + { + const s7_pointer arg1 = cadr(arg), arg2 = caddr(arg); + set_opt3_pair(arg, cdr(arg2)); + if ((fx_matches(car(arg1), sc->multiply_symbol)) && (car(arg2) == sc->multiply_symbol)) + { + set_opt1_pair(cdr(arg), cdr(arg1)); + if (head == sc->subtract_symbol) return(fx_sub_mul_mul); + if (head == sc->add_symbol) + return(((cadr(arg1) == caddr(arg1)) && (cadr(arg2) == caddr(arg2))) ? fx_add_sqr_sqr : fx_add_mul_mul); + } + if ((fx_matches(car(arg1), sc->subtract_symbol)) && (car(arg2) == sc->subtract_symbol)) + { + set_opt1_pair(cdr(arg), cdr(arg1)); + if (head == sc->multiply_symbol) return(fx_mul_sub_sub); + if (head == sc->lt_symbol) return(fx_lt_sub2); + } + if ((fx_matches(head, sc->subtract_symbol)) && + (fx_matches(car(arg1), sc->vector_ref_symbol)) && + (car(arg2) == sc->vector_ref_symbol) && + (cadr(arg1) == cadr(arg2))) + { + 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))) + { + const s7_pointer arg_sym = cadadr(arg), arg_head = caadr(arg); + if (fx_matches(head, sc->is_pair_symbol)) + { + if (arg_head == sc->car_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_pair_car_s);} /* (pair? ...) is ok, so loc can be sym? 7 in lg */ + if (arg_head == sc->cdr_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_pair_cdr_s);} + if (arg_head == sc->cadr_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_pair_cadr_s);} + if (arg_head == sc->cddr_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_pair_cddr_s);} + } + if (fx_matches(head, sc->is_null_symbol)) + { + if (arg_head == sc->cdr_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_null_cdr_s);} + if (arg_head == sc->cadr_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_null_cadr_s);} + if (arg_head == sc->cddr_symbol) {set_opt3_sym(arg, arg_sym); return(fx_is_null_cddr_s);} + } + if ((fx_matches(head, sc->is_symbol_symbol)) && + (caadr(arg) == sc->cadr_symbol)) + {set_opt3_sym(arg, arg_sym); return(fx_is_symbol_cadr_s);} + + if (fx_matches(head, sc->not_symbol)) + { + if (arg_head == sc->is_pair_symbol) {set_opt3_sym(arg, arg_sym); return(fx_not_is_pair_s);} + if (arg_head == sc->is_null_symbol) {set_opt3_sym(arg, arg_sym); return(fx_not_is_null_s);} + if (arg_head == sc->is_symbol_symbol) {set_opt3_sym(arg, arg_sym); return(fx_not_is_symbol_s);} + return(fx_not_opsq); + } + if ((fx_matches(head, sc->floor_symbol)) && (arg_head == sc->sqrt_symbol)) + {set_opt3_sym(arg, arg_sym); return(fx_floor_sqrt_s);} + } + if (is_unchanged_global(head)) /* (? (op arg)) where (op arg) might return a let with a ? method etc */ + { /* other possibility: fx_c_a */ + const uint8_t typ = symbol_type(head); + 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(head)) + { + const s7_pointer arg2 = caddr(arg); + if (head == sc->add_symbol) + { + if (is_t_real(arg2)) return(fx_add_sf); + if (is_t_integer(arg2)) return((integer(arg2) == 1) ? fx_add_s1 : fx_add_si); + } + if (head == sc->subtract_symbol) + { + if (is_t_real(arg2)) return(fx_subtract_sf); + if (is_t_integer(arg2)) return((integer(arg2) == 1) ? fx_subtract_s1 : fx_subtract_si); + } + if (head == sc->multiply_symbol) + { + if (is_t_real(arg2)) return(fx_multiply_sf); + if (is_t_integer(arg2)) return(fx_multiply_si); + } + if ((fn_proc(arg) == g_memq_2) && (is_pair(arg2))) return(fx_memq_sq_2); + if ((fn_proc(arg) == g_is_eq) && (!is_unspecified(arg2))) return(fx_is_eq_sc); + + if ((is_t_integer(arg2)) && (s7_p_pi_function(global_value(head)))) + { + if (head == sc->num_eq_symbol) return((integer(arg2) == 0) ? fx_num_eq_s0 : fx_num_eq_si); + if (head == sc->lt_symbol) return(fx_lt_si); + if (head == sc->leq_symbol) return(fx_leq_si); + if (head == sc->gt_symbol) return(fx_gt_si); + if (head == sc->geq_symbol) return(fx_geq_si); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pi_function(global_value(head)))); + return(fx_c_si_direct); + } + if ((is_t_real(arg2)) && (real(arg2) == 0.0) && (head == sc->num_eq_symbol)) return(fx_num_eq_s0f); + if ((s7_p_pp_function(global_value(head))) && (fn_proc(arg) != g_divide_by_2)) + { + if (head == sc->memq_symbol) + { + if ((is_pair(arg2)) && (is_proper_list_3(sc, cadr(arg2)))) return(fx_memq_sc_3); + return(fx_memq_sc); + } + if ((head == sc->char_eq_symbol) && (is_character(arg2))) return(fx_char_eq_sc); /* maybe fx_char_eq_newline */ + if (head == sc->lt_symbol) return(fx_lt_sc); /* integer case handled above */ + if (head == sc->leq_symbol) return(fx_leq_sc); + if (head == sc->gt_symbol) return(fx_gt_sc); + if (head == sc->geq_symbol) return(fx_geq_sc); + if (head == sc->list_symbol) return(fx_list_sc); + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(head)))); + return(fx_c_sc_direct); + }} + return(fx_c_sc); + + case HOP_SAFE_C_CS: + if (is_unchanged_global(head)) + { + const s7_pointer arg1 = cadr(arg), arg2 = caddr(arg); + if (head == sc->cons_symbol) return(fx_cons_cs); + if ((head == sc->add_symbol) && (is_t_real(arg1))) return(fx_add_fs); + if ((head == sc->subtract_symbol) && (is_t_real(arg1))) return(fx_subtract_fs); + if ((head == sc->num_eq_symbol) && (arg1 == int_zero)) + { + set_opt3_sym(arg, arg2); /* opt3_location is in use, but the num_eq is ok, so only symbol might care about that info? */ + return(fx_num_eq_0s); + } + if (head == sc->multiply_symbol) + { + if (is_t_real(arg1)) return(fx_multiply_fs); + if (is_t_integer(arg1)) return(fx_multiply_is); + }} + return(fx_c_cs); + + case HOP_SAFE_C_S_opSq: + { + const s7_pointer arg1p = cdr(arg), arg2 = caddr(arg); + if (fx_matches(car(arg2), sc->car_symbol)) + { + set_opt2_sym(arg1p, cadr(arg2)); + if (fx_matches(head, sc->hash_table_ref_symbol)) return(fx_hash_table_ref_car); + return(fx_matches(head, sc->add_symbol) ? fx_add_s_car_s : fx_c_s_car_s); + } + if ((is_global_and_has_func(head, s7_p_pp_function)) && + (is_global_and_has_func(car(arg2), s7_p_p_function))) + { + if ((head == sc->cons_symbol) && (car(arg2) == sc->cdr_symbol)) {set_opt2_sym(cdr(arg), cadr(arg2)); return(fx_cons_s_cdr_s);} + set_opt1_sym(arg1p, cadr(arg2)); + set_opt2_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(head)))); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_p_function(global_value(car(arg2))))); /* arg opt3 only location, but no change in callgrind */ + if (opt3_direct(arg1p) == (s7_pointer)random_p_p) set_opt3_direct(cdr(arg), (s7_pointer)random_p_p_wrapped); + return(fx_c_s_opsq_direct); + }} + return(fx_c_s_opsq); + + case HOP_SAFE_C_C_opSq: + if (is_global_and_has_func(head, s7_p_pp_function)) + { + const 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(head)))); + 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(head)) + { + const s7_pointer arg1p = cdr(arg), arg1 = cadr(arg), arg2 = caddr(arg); + if ((head == sc->memq_symbol) && + (fx_matches(car(arg1), sc->car_symbol)) && + (is_proper_quote(sc, arg2)) && + (is_pair(cadr(arg2)))) + return((s7_list_length(sc, opt2_con(arg1p)) == 2) ? fx_memq_car_s_2 : fx_memq_car_s); + + if (head == sc->is_eq_symbol) + { + if (((fx_matches(car(arg1), sc->car_symbol)) || (fx_matches(car(arg1), sc->caar_symbol))) && + (is_proper_quote(sc, arg2))) + { + set_opt3_sym(arg1p, cadr(arg1)); + set_opt2_con(arg1p, cadr(arg2)); + return((car(arg1) == sc->car_symbol) ? fx_is_eq_car_sq : fx_is_eq_caar_sq); + }} + if (((head == sc->lt_symbol) || (head == sc->num_eq_symbol)) && + (is_t_integer(arg2)) && + (fx_matches(car(arg1), sc->length_symbol))) + { + set_opt3_sym(arg1p, cadr(arg1)); + set_opt3_con(arg, arg2); + return((head == 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(head, 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(head, sc->not_symbol)) + { + if (fn_proc(cadr(arg)) == g_is_eq) + { + const s7_pointer arg1 = cadr(arg); + set_opt3_sym(arg, cadr(arg1)); + set_opt3_con(cdr(arg), (is_pair(caddr(arg1))) ? cadaddr(arg1) : caddr(arg1)); + 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(head, s7_p_pp_function)) + { + const s7_pointer arg1p = cdr(arg), arg2 = caddr(arg); + if ((is_global_and_has_func(car(arg2), s7_p_pi_function)) && + (is_t_integer(caddr(arg2)))) + { + set_opt2_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(head)))); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_pi_function(global_value(car(arg2))))); + set_opt3_sym(arg, cadr(arg2)); + set_opt1_con(arg1p, caddr(arg2)); + if (head == 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 ((head == 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(arg1p, (s7_pointer)(s7_p_pp_function(global_value(head)))); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(car(arg2))))); + set_opt3_sym(arg, cadr(arg2)); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, (s7_pointer)add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, (s7_pointer)subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, (s7_pointer)multiply_p_pp_wrapped); + set_opt1_con(arg1p, (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(head, 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(head, s7_p_p_function)) && + (is_global_and_has_func(caadr(arg), s7_p_pp_function))) + { + const s7_pointer arg1p = cdr(arg); + set_opt2_direct(arg1p, (s7_pointer)(s7_p_p_function(global_value(head)))); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(caar(arg1p))))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, (s7_pointer)add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, (s7_pointer)subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, (s7_pointer)multiply_p_pp_wrapped); + return(fx_c_opssq_direct); + } + return(fx_c_opssq); + + case HOP_SAFE_C_C_opSSq: + { + const s7_pointer arg1p = cdr(arg), s2 = caddr(arg); + if ((fx_matches(car(s2), sc->multiply_symbol)) && (cadr(s2) == caddr(s2))) + return(fx_c_c_sqr); + if ((is_small_real(car(arg1p))) && + (is_global_and_has_func(head, s7_p_dd_function)) && + (is_global_and_has_func(car(s2), s7_d_pd_function))) /* not * currently (this is for clm) */ + { + set_opt3_direct(arg1p, s7_d_pd_function(global_value(car(s2)))); + set_opt2_direct(arg1p, s7_p_dd_function(global_value(head))); + set_opt3_sym(arg, cadr(s2)); + set_opt1_sym(arg1p, caddr(s2)); + return(fx_c_nc_opssq_direct); + } + if ((is_global_and_has_func(head, s7_p_pp_function)) && + (is_global_and_has_func(car(s2), s7_p_pp_function))) + { + set_opt2_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(head)))); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(caaddr(arg))))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, (s7_pointer)add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, (s7_pointer)subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, (s7_pointer)multiply_p_pp_wrapped); + set_opt3_sym(arg, cadr(s2)); + set_opt1_sym(arg1p, caddr(s2)); + if ((is_t_real(car(arg1p))) && (head == car(s2)) && (head == 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: + { + const s7_pointer arg1p = cdr(arg), arg1 = cadr(arg), arg2 = caddr(arg); + if ((is_global_and_has_func(head, s7_p_pp_function)) && + (is_global_and_has_func(car(arg1), s7_p_p_function)) && + (is_global_and_has_func(car(arg2), s7_p_p_function))) + { + set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(global_value(head)))); + set_opt2_direct(arg1p, (s7_pointer)(s7_p_p_function(global_value(car(arg1))))); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_p_function(global_value(car(arg2))))); + if ((car(arg1) == car(arg2)) && ((car(arg1) == sc->cdr_symbol) || (car(arg1) == sc->car_symbol))) + { + set_opt1_sym(arg1p, cadr(arg1)); + set_opt2_sym(arg1p, cadr(arg2)); /* usable because we know func is cdr|car */ + return((car(arg1) == sc->cdr_symbol) ? fx_cdr_s_cdr_s : fx_car_s_car_s); + } + set_opt1_sym(arg1p, cadr(arg2)); /* 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(head, sc->not_symbol)) ? fx_not_op_s_opsqq : fx_c_op_s_opsqq); + + case HOP_SAFE_C_op_opSSqq_S: + { + const s7_pointer arg1p = cdr(arg), arg1 = cadr(arg); + if ((is_global_and_has_func(head, s7_p_pp_function)) && + (is_global_and_has_func(car(arg1), s7_p_p_function)) && + (is_global_and_has_func(caadr(arg1), s7_p_pp_function))) + { + set_opt3_direct(arg, (s7_pointer)(s7_p_pp_function(global_value(head)))); + set_opt2_direct(arg1p, (s7_pointer)(s7_p_p_function(global_value(car(arg1))))); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(caadr(arg1))))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, (s7_pointer)add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, (s7_pointer)subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, (s7_pointer)multiply_p_pp_wrapped); + + return(fx_c_op_opssqq_s_direct); + }} + return(fx_c_op_opssqq_s); + + case HOP_SAFE_C_A: + if (fx_matches(head, 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(head, s7_p_p_function)) + { + set_opt3_direct(arg, (s7_pointer)(s7_p_p_function(global_value(head)))); + if ((head == sc->sqrt_symbol) && (fx_proc(cdr(arg)) == fx_add_sqr_sqr)) + { + set_opt1_sym(cdr(arg), cadr(cadr(cadr(arg)))); /* opt1_cfunc(arg) is set */ + set_opt3_sym(cdr(arg), cadr(caddr(cadr(arg)))); /* opt3(arg) is sqrt_p_p but used to be clobbered anyway */ + return(fx_hypot); + } + 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(head, sc->is_eq_symbol)) return(fx_is_eq_ac); + if (is_global_and_has_func(head, s7_p_pp_function)) + { + const s7_pointer arg1p = cdr(arg); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(head)))); + if ((opt3_direct(arg1p) == (s7_pointer)string_ref_p_pp) && (is_t_integer(caddr(arg))) && (integer(caddr(arg)) == 0)) + set_opt3_direct(arg1p, string_ref_p_p0); + if (opt3_direct(arg1p) == (s7_pointer)memq_p_pp) + { + if (fn_proc(arg) == g_memq_2) + set_opt3_direct(arg1p, (s7_pointer)memq_2_p_pp); + else + if ((is_pair(caddr(arg))) && (is_proper_list_3(sc, cadaddr(arg)))) + set_opt3_direct(arg1p, memq_3_p_pp); + else + if (fn_proc(arg) == g_memq_4) + set_opt3_direct(arg1p, memq_4_p_pp); /* this does not parallel 2 and 3 above (sigh) */ + } + else + if ((is_t_real(opt3_con(arg))) && (opt3_direct(arg1p) == (s7_pointer)lt_p_pp)) + return(fx_lt_ad); + if ((is_t_integer(opt3_con(arg))) && (s7_p_pi_function(global_value(head)))) + { + set_opt3_direct(arg1p, (s7_pointer)(s7_p_pi_function(global_value(head)))); + if (integer(opt3_con(arg)) == 1) + { + if (opt3_direct(arg1p) == (s7_pointer)g_sub_xi) + return(fx_sub_a1); + else + if (opt3_direct(arg1p) == (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: + + if ((!WITH_GMP) && (fx_proc(cddr(arg)) == fx_random_i)) set_fx_direct(cddr(arg), fx_random_i_wrapped); + return((fn_proc(arg) == g_cons) ? fx_cons_ca : fx_c_ca); + + case HOP_SAFE_C_SA: + if ((!WITH_GMP) && (fx_proc(cddr(arg)) == fx_random_i)) set_fx_direct(cddr(arg), fx_random_i_wrapped); + 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(head, s7_p_pp_function)) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(head)))); + 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(head, s7_p_pp_function)) + { + set_opt3_direct(cdr(arg), (s7_pointer)(s7_p_pp_function(global_value(head)))); + 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: + { + const s7_pointer body = car(closure_body(opt1_lambda(arg))); + const s7_pointer par = car(closure_pars(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) == par)) /* (lambda (x) (and (pair? x) (pair? (cdr x)))) */ + 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_cdr_let_ref) && + (cadadr(body) == par)) /* (lambda (v) (cdr v)) -- many cases in lint.scm */ + { + set_opt2_sym(cdr(arg), cadaddr(body)); + return(fx_cdr_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: + { + const 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_STARLET_REF_S: + if (opt3_int(arg) == sl_print_length) return(fx_implicit_starlet_print_length); + if (opt3_int(arg) == sl_safety) return(fx_implicit_starlet_safety); + return(fx_implicit_starlet_ref_s); + + case HOP_C: + if ((is_unchanged_global(head)) && (head == 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) +{ + const s7_pointer p = car(tree); + const s7_function pfunc = fx_proc(tree); + if (is_symbol(p)) + { + if ((pfunc == fx_s) || (pfunc == 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)))) + { + const s7_pointer arg1 = cadr(p); + if (arg1 == var1) + { + if ((pfunc == fx_c_s) || (pfunc == fx_c_o)) return(with_fx(tree, fx_c_T)); /* fx_c_T_direct got no hits */ + if ((pfunc == fx_car_s) || (pfunc == fx_car_o)) return(with_fx(tree, fx_car_T)); + if ((pfunc == fx_cdr_s) || (pfunc == fx_cdr_o)) return(with_fx(tree, fx_cdr_T)); + if (pfunc == fx_is_null_s) return(with_fx(tree, fx_is_null_T)); + if (pfunc == fx_iterate_o) return(with_fx(tree, fx_iterate_T)); + if (pfunc == fx_subtract_s1) return(with_fx(tree, fx_subtract_T1)); + if (pfunc == fx_add_s1) return(with_fx(tree, fx_add_T1)); + if (pfunc == fx_c_sca) return(with_fx(tree, fx_c_Tca)); + if ((pfunc == fx_num_eq_si) || (pfunc == fx_num_eq_s0) || (pfunc == fx_num_eq_oi)) return(with_fx(tree, fx_num_eq_Ti)); + /* if (pfunc == 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 (pfunc == fx_multiply_ss) return(with_fx(tree, fx_multiply_Ts)); */ /* this also can be fooled? */ + if ((pfunc == fx_c_scs_direct) && (cadddr(p) == var2)) return(with_fx(tree, fx_c_TcU_direct)); + if ((pfunc == fx_hash_table_ref_ss) && (var3 == caddr(p))) return(with_fx(tree, fx_hash_table_ref_TV)); + if ((pfunc == fx_geq_ss) && (var2 == caddr(p))) return(with_fx(tree, fx_geq_TU)); + } + else + if (arg1 == var2) + { + if (pfunc == fx_subtract_s1) return(with_fx(tree, fx_subtract_U1)); + if (pfunc == fx_add_s1) return(with_fx(tree, fx_add_U1)); + if ((pfunc == fx_car_s) || (pfunc == fx_car_o)) return(with_fx(tree, fx_car_U)); + if ((pfunc == fx_cdr_s) || (pfunc == fx_cdr_o)) return(with_fx(tree, fx_cdr_U)); + } + else + if (arg1 == var3) + { + if ((pfunc == fx_c_s) || (pfunc == fx_c_o)) return(with_fx(tree, fx_c_V)); + if (pfunc == fx_add_s1) return(with_fx(tree, fx_add_V1)); + } + else + if (is_pair(cddr(p))) + { + if (caddr(p) == var1) + { + if ((pfunc == fx_num_eq_ts) || (pfunc == fx_num_eq_to)) return(with_fx(tree, fx_num_eq_tT)); + if ((pfunc == fx_gt_ts) || (pfunc == fx_gt_to)) return(with_fx(tree, fx_gt_tT)); + if (pfunc == fx_lt_ts) return(with_fx(tree, fx_lt_tT)); + if ((pfunc == fx_geq_ts) || (pfunc == fx_geq_to)) return(with_fx(tree, fx_geq_tT)); + } + else + if (caddr(p) == var2) + { + if (pfunc == fx_c_ts) return(with_fx(tree, fx_c_tU)); + if (pfunc == fx_cons_ts) return(with_fx(tree, fx_cons_tU)); + if (pfunc == fx_c_ts_direct) return(with_fx(tree, fx_c_tU_direct)); + if (pfunc == fx_lt_ts) return(with_fx(tree, fx_lt_tU)); + if (pfunc == fx_num_eq_us) return(with_fx(tree, fx_num_eq_uU)); + if (pfunc == fx_num_eq_vs) return(with_fx(tree, fx_num_eq_vU)); + } + else + if ((pfunc == fx_add_sqr_s) && (cadr(arg1) == 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, const s7_pointer tree, const s7_pointer var1, const s7_pointer var2, const s7_pointer var3, bool more_vars) +{ + const s7_pointer p = car(tree); + s7_function pfunc; + 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_defined_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); + pfunc = fx_proc(tree); + switch (optimize_op(p)) + { + case HOP_SAFE_C_S: + if (cadr(p) == var1) + { + if (pfunc == fx_c_s) return(with_fx(tree, fx_c_t)); + if (pfunc == 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 (pfunc == fx_car_s) return(with_fx(tree, fx_car_t)); + if (pfunc == fx_cdr_s) return(with_fx(tree, fx_cdr_t)); + if (pfunc == fx_cddr_s) return(with_fx(tree, fx_cddr_t)); + if (pfunc == fx_cadr_s) return(with_fx(tree, fx_cadr_t)); + if (pfunc == fx_not_s) return(with_fx(tree, fx_not_t)); + if (pfunc == fx_is_null_s) return(with_fx(tree, fx_is_null_t)); + if (pfunc == fx_is_pair_s) return(with_fx(tree, fx_is_pair_t)); + if (pfunc == fx_is_symbol_s) return(with_fx(tree, fx_is_symbol_t)); + if (pfunc == fx_is_eof_s) return(with_fx(tree, fx_is_eof_t)); + if (pfunc == fx_is_string_s) return(with_fx(tree, fx_is_string_t)); + if (pfunc == fx_is_vector_s) return(with_fx(tree, fx_is_vector_t)); + if (pfunc == fx_is_integer_s) return(with_fx(tree, fx_is_integer_t)); + if (pfunc == fx_is_procedure_s) return(with_fx(tree, fx_is_procedure_t)); + if (pfunc == fx_is_type_s) return(with_fx(tree, fx_is_type_t)); + if (pfunc == fx_length_s) return(with_fx(tree, fx_length_t)); + if (pfunc == fx_real_part_s) return(with_fx(tree, fx_real_part_t)); + if (pfunc == fx_imag_part_s) return(with_fx(tree, fx_imag_part_t)); + return(false); + } + if (cadr(p) == var2) + { + if (pfunc == 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 (pfunc == 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 (pfunc == fx_cdr_s) return(with_fx(tree, fx_cdr_u)); + if (pfunc == fx_cadr_s) return(with_fx(tree, fx_cadr_u)); + if (pfunc == fx_cddr_s) return(with_fx(tree, fx_cddr_u)); + if (pfunc == fx_car_s) return(with_fx(tree, fx_car_u)); + if (pfunc == fx_is_null_s) return(with_fx(tree, fx_is_null_u)); + if (pfunc == fx_is_type_s) return(with_fx(tree, fx_is_type_u)); + if (pfunc == fx_is_pair_s) return(with_fx(tree, fx_is_pair_u)); + if (pfunc == fx_is_symbol_s) return(with_fx(tree, fx_is_symbol_u)); + if (pfunc == fx_is_eof_s) return(with_fx(tree, fx_is_eof_u)); + return(false); + } + if (cadr(p) == var3) + { + if (pfunc == fx_cdr_s) return(with_fx(tree, fx_cdr_v)); + if (pfunc == fx_is_null_s) return(with_fx(tree, fx_is_null_v)); + if (pfunc == fx_is_pair_s) return(with_fx(tree, fx_is_pair_v)); + if (pfunc == fx_c_s) return(with_fx(tree, fx_c_v)); + if (pfunc == fx_c_s_direct) return(with_fx(tree, fx_c_v_direct)); + return(false); + } + if (!more_vars) + { + if (pfunc == fx_is_null_s) return(with_fx(tree, fx_is_null_o)); + if (pfunc == fx_car_s) return(with_fx(tree, fx_car_o)); + if (pfunc == fx_cdr_s) return(with_fx(tree, fx_cdr_o)); + if (pfunc == fx_cadr_s) return(with_fx(tree, fx_cadr_o)); + if (pfunc == fx_cddr_s) return(with_fx(tree, fx_cddr_o)); + if (pfunc == fx_iterate_s) return(with_fx(tree, fx_iterate_o)); + if (pfunc == fx_not_s) return(with_fx(tree, fx_not_o)); + if (pfunc == fx_c_s_direct) return(with_fx(tree, fx_c_o_direct)); + if (pfunc == fx_c_s) return(with_fx(tree, fx_c_o)); + } + break; + + case HOP_SAFE_C_SC: + if (cadr(p) == var1) + { + if ((pfunc == fx_char_eq_sc) || (fn_proc(p) == g_char_equal_2)) return(with_fx(tree, fx_char_eq_tc)); + if (pfunc == fx_c_sc) return(with_fx(tree, fx_c_tc)); + if (pfunc == 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 (pfunc == fx_leq_si) return(with_fx(tree, fx_leq_ti)); + if (pfunc == fx_gt_si) return(with_fx(tree, fx_gt_ti)); + + if (pfunc == 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 (pfunc == 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 (pfunc == fx_is_eq_sc) return(with_fx(tree, fx_is_eq_tc)); + if (pfunc == fx_add_s1) return(with_fx(tree, fx_add_t1)); + if (pfunc == fx_add_si) return(with_fx(tree, fx_add_ti)); + if (pfunc == fx_subtract_s1) return(with_fx(tree, fx_subtract_t1)); + if (pfunc == fx_subtract_si) return(with_fx(tree, fx_subtract_ti)); + if (pfunc == fx_subtract_sf) return(with_fx(tree, fx_subtract_tf)); + if (pfunc == fx_multiply_sf) return(with_fx(tree, fx_multiply_tf)); + if (pfunc == fx_multiply_si) return(with_fx(tree, fx_multiply_ti)); + if (pfunc == 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 (pfunc == fx_num_eq_si) return(with_fx(tree, fx_num_eq_ti)); + if (pfunc == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_t0)); + if (pfunc == fx_memq_sc) return(with_fx(tree, fx_memq_tc)); + return(false); + } + if (cadr(p) == var2) + { + if (pfunc == fx_c_sc) return(with_fx(tree, fx_c_uc)); + if (pfunc == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_u0)); + if (pfunc == fx_num_eq_si) return(with_fx(tree, fx_num_eq_ui)); + if (pfunc == fx_add_s1) return(with_fx(tree, fx_add_u1)); + if (pfunc == fx_subtract_s1) return(with_fx(tree, fx_subtract_u1)); + if (pfunc == fx_subtract_si) return(with_fx(tree, fx_subtract_ui)); + if (pfunc == fx_multiply_si) return(with_fx(tree, fx_multiply_ui)); + if (pfunc == fx_is_eq_sc) return(with_fx(tree, fx_is_eq_uc)); + if (pfunc == fx_leq_si) return(with_fx(tree, fx_leq_ui)); + if (pfunc == fx_gt_si) return(with_fx(tree, fx_gt_ui)); + return(false); + } + if (cadr(p) == var3) + { + if (pfunc == fx_num_eq_s0) return(with_fx(tree, fx_num_eq_v0)); + if (pfunc == fx_num_eq_si) return(with_fx(tree, fx_num_eq_vi)); + if (pfunc == fx_add_s1) return(with_fx(tree, fx_add_v1)); + if (pfunc == fx_subtract_s1) return(with_fx(tree, fx_subtract_v1)); + if (pfunc == fx_leq_si) return(with_fx(tree, fx_leq_vi)); + if (pfunc == fx_c_sc) return(with_fx(tree, fx_c_vc)); + return(false); + } + if (!more_vars) + { + if (pfunc == fx_num_eq_si) return(with_fx(tree, fx_num_eq_oi)); + if ((pfunc == 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 (pfunc == fx_multiply_is) return(with_fx(tree, fx_multiply_it)); + if (pfunc == fx_add_fs) return(with_fx(tree, fx_add_ft)); + if (pfunc == 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) && (pfunc == fx_c_cs)) return(with_fx(tree, fx_c_cu)); + break; + + case HOP_SAFE_C_SS: + { + const s7_pointer arg1 = cadr(p), arg2 = caddr(p); + if (arg1 == var1) + { + if (pfunc == fx_c_ss) return(with_fx(tree, (arg2 == var2) ? fx_c_tu : fx_c_ts)); + if (pfunc == fx_c_ss_direct) return(with_fx(tree, (arg2 == var2) ? fx_c_tu_direct : fx_c_ts_direct)); + if (pfunc == fx_add_ss) return(with_fx(tree, (arg2 == var2) ? fx_add_tu : fx_add_ts)); + if (pfunc == fx_subtract_ss) return(with_fx(tree, (arg2 == var2) ? fx_subtract_tu : fx_subtract_ts)); + if (pfunc == fx_cons_ss) return(with_fx(tree, (arg2 == var2) ? fx_cons_tu : fx_cons_ts)); + if (arg2 == var2) + { + if (pfunc == fx_gt_ss) return(with_fx(tree, fx_gt_tu)); + if (pfunc == fx_lt_ss) return(with_fx(tree, fx_lt_tu)); + if (pfunc == fx_leq_ss) return(with_fx(tree, fx_leq_tu)); + if (pfunc == fx_geq_ss) return(with_fx(tree, fx_geq_tu)); + if (pfunc == fx_multiply_ss) return(with_fx(tree, fx_multiply_tu)); + if (pfunc == fx_num_eq_ss) return(with_fx(tree, fx_num_eq_tu)); + if (pfunc == fx_memq_ss) return(with_fx(tree, fx_memq_tu)); + } + if (pfunc == fx_multiply_ss) return(with_fx(tree, fx_multiply_ts)); + if (pfunc == fx_num_eq_ss) + { + if (arg2 == var3) return(with_fx(tree, fx_num_eq_tv)); + if (is_defined_global(arg2)) return(with_fx(tree, fx_num_eq_tg)); + if ((!more_vars) && (o_var_ok(arg2, var1, var2, var3))) return(with_fx(tree, fx_num_eq_to)); + return(with_fx(tree, fx_num_eq_ts)); + } + if (pfunc == fx_geq_ss) + { + if ((!more_vars) && (o_var_ok(arg2, var1, var2, var3))) return(with_fx(tree, fx_geq_to)); + return(with_fx(tree, fx_geq_ts)); + } + if (pfunc == fx_leq_ss) return(with_fx(tree, fx_leq_ts)); + if (pfunc == fx_lt_ss) return(with_fx(tree, fx_lt_ts)); + if (pfunc == fx_lt_sg) return(with_fx(tree, fx_lt_tg)); + if (pfunc == fx_gt_ss) + { + if (is_defined_global(arg2)) return(with_fx(tree, fx_gt_tg)); + if ((!more_vars) && (o_var_ok(arg2, var1, var2, var3))) return(with_fx(tree, fx_gt_to)); + return(with_fx(tree, fx_gt_ts)); + } + if (pfunc == fx_sqr_s) return(with_fx(tree, fx_sqr_t)); + if (pfunc == fx_is_eq_ss) + { + if (arg2 == var2) return(with_fx(tree, fx_is_eq_tu)); + if ((!more_vars) && (arg2 != var3) && (arg2 != var1)) return(with_fx(tree, fx_is_eq_to)); + return(with_fx(tree, fx_is_eq_ts)); + } + if (pfunc == fx_vref_ss) + { + if (arg2 == var2) return(with_fx(tree, fx_vref_tu)); + return(with_fx(tree, fx_vref_ts)); + }} + if (arg2 == var1) + { + if (pfunc == fx_c_ss) return(with_fx(tree, fx_c_st)); + if (pfunc == fx_c_ss_direct) {return(with_fx(tree, (is_defined_global(arg1)) ? fx_c_gt_direct : fx_c_st_direct));} + if (pfunc == fx_hash_table_ref_ss) return(with_fx(tree, fx_hash_table_ref_st)); + if (pfunc == fx_cons_ss) return(with_fx(tree, fx_cons_st)); + if (pfunc == fx_vref_ss) + { + if (is_defined_global(arg1)) return(with_fx(tree, fx_vref_gt)); + if ((!more_vars) && (arg1 != var2) && (arg1 != var3)) return(with_fx(tree, fx_vref_ot)); + return(with_fx(tree, fx_vref_st)); + } + if ((pfunc == fx_gt_ss) && (arg1 == var2)) return(with_fx(tree, fx_gt_ut)); + if ((pfunc == fx_lt_ss) && (arg1 == var2)) return(with_fx(tree, fx_lt_ut)); + if (pfunc == fx_geq_ss) + { + if ((!more_vars) && (o_var_ok(arg1, var1, var2, var3))) return(with_fx(tree, fx_geq_ot)); + return(with_fx(tree, fx_geq_st)); + }} + if (arg1 == var2) + { + if (pfunc == fx_geq_ss) return(with_fx(tree, fx_geq_us)); + if (pfunc == fx_num_eq_ss) return(with_fx(tree, (arg2 == var1) ? fx_num_eq_ut : fx_num_eq_us)); + if (pfunc == fx_add_ss) return(with_fx(tree, (arg2 == var1) ? fx_add_ut : ((arg2 == var3) ? fx_add_uv : fx_add_us))); + if (pfunc == fx_subtract_ss) return(with_fx(tree, (arg2 == var1) ? fx_subtract_ut : fx_subtract_us)); + if (arg2 == var3) return(with_fx(tree, fx_c_uv)); + } + if ((arg2 == var2) && (pfunc == fx_sref_ss)) return(with_fx(tree, fx_sref_su)); + if (arg1 == var3) + { + if (pfunc == fx_num_eq_ss) return(with_fx(tree, fx_num_eq_vs)); + if ((pfunc == fx_add_ss) && (arg2 == var2)) return(with_fx(tree, fx_add_vu)); + if (pfunc == fx_geq_ss) return(with_fx(tree, ((!more_vars) && (o_var_ok(arg2, 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, (pfunc == fx_c_sa_direct) ? fx_c_ua_direct : fx_c_ua)); + break; + + case HOP_SAFE_C_SCS: + if (cadr(p) == var1) + { + if (pfunc == fx_c_scs) return(with_fx(tree, fx_c_tcs)); + if (pfunc == 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) && ((pfunc == fx_c_sss) || (pfunc == fx_c_sss_direct)))) + return(with_fx(tree, (cadddr(p) == var3) ? ((pfunc == 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) 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 (pfunc == fx_is_pair_car_s) return(with_fx(tree, fx_is_pair_car_t)); + if (pfunc == fx_is_pair_cdr_s) return(with_fx(tree, fx_is_pair_cdr_t)); + if (pfunc == fx_is_pair_cadr_s) return(with_fx(tree, fx_is_pair_cadr_t)); + if (pfunc == fx_is_symbol_cadr_s) return(with_fx(tree, fx_is_symbol_cadr_t)); + if (pfunc == fx_is_pair_cddr_s) return(with_fx(tree, fx_is_pair_cddr_t)); + if (pfunc == fx_is_null_cdr_s) return(with_fx(tree, fx_is_null_cdr_t)); + if (pfunc == fx_is_null_cadr_s) return(with_fx(tree, fx_is_null_cadr_t)); + if (pfunc == fx_is_null_cddr_s) return(with_fx(tree, fx_is_null_cddr_t)); + if (pfunc == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_t)); + if (pfunc == fx_not_is_null_s) return(with_fx(tree, fx_not_is_null_t)); + if (pfunc == fx_not_is_symbol_s) return(with_fx(tree, fx_not_is_symbol_t)); + if (pfunc == 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 (pfunc == 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 (pfunc == fx_c_car_s) return(with_fx(tree, fx_c_car_t)); + if (pfunc == fx_c_cdr_s) return(with_fx(tree, fx_c_cdr_t)); + if (pfunc == fx_is_type_opsq) return(with_fx(tree, fx_is_type_optq)); + if (pfunc == 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 (pfunc == fx_c_car_s) return(with_fx(tree, fx_c_car_u)); + if (pfunc == fx_not_is_null_s) return(with_fx(tree, fx_not_is_null_u)); + if (pfunc == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_u)); + if (pfunc == fx_is_pair_cdr_s) return(with_fx(tree, fx_is_pair_cdr_u)); + } + if (cadadr(p) == var3) + { + if (pfunc == fx_not_is_pair_s) return(with_fx(tree, fx_not_is_pair_v)); + } + break; + + case HOP_SAFE_C_opSq_S: + { + const s7_pointer arg1p = cdr(p), arg1 = cadr(p), arg2 = caddr(p); + if (cadr(arg1) == var1) + { + if (pfunc == fx_c_opsq_s) + { + if ((is_global_and_has_func(car(p), s7_p_pp_function)) && + (is_global_and_has_func(car(arg1), s7_p_p_function))) + { + set_opt2_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_p_function(global_value(car(arg1))))); + return(with_fx(tree, fx_c_optq_s_direct)); + } + return(with_fx(tree, fx_c_optq_s)); + } + if (pfunc == fx_c_opsq_s_direct) return(with_fx(tree, fx_c_optq_s_direct)); + if (pfunc == fx_cons_car_s_s) + { + set_opt1_sym(arg1p, var1); + return(with_fx(tree, (arg2 == var3) ? fx_cons_car_t_v : fx_cons_car_t_s)); + }} + if (cadr(arg1) == var2) + { + if ((pfunc == fx_c_opsq_s) && (arg2 == var1)) + { + if ((is_global_and_has_func(car(p), s7_p_pp_function)) && + (is_global_and_has_func(car(arg1), s7_p_p_function))) /* (memq (car sequence) items) lint */ + { + set_opt2_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_p_function(global_value(car(arg1))))); + return(with_fx(tree, (car(p) == sc->cons_symbol) ? + ((car(arg1) == 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 (((pfunc == fx_c_opsq_s_direct) || (pfunc == fx_cons_car_s_s)) && + (arg2 == var1)) + return(with_fx(tree, (car(p) == sc->cons_symbol) ? + ((car(arg1) == sc->car_symbol) ? fx_cons_car_u_t : fx_cons_opuq_t) : fx_c_opuq_t_direct)); + }} + break; + + case HOP_SAFE_C_S_opSq: + { + const s7_pointer arg2_arg = cadaddr(p); + if (cadr(p) == var1) + { + if (arg2_arg == var2) + { + if (pfunc == fx_c_s_car_s) return(with_fx(tree, fx_c_t_car_u)); + if (pfunc == fx_c_s_opsq_direct) return(with_fx(tree, fx_c_t_opuq_direct)); + } + if (arg2_arg == var3) + { + if (pfunc == fx_add_s_car_s) return(with_fx(tree, fx_add_t_car_v)); + if (pfunc == fx_c_s_car_s) return(with_fx(tree, fx_c_t_car_v)); /* ideally eq_p_pp not g_is_eq */ + } + if (pfunc == fx_c_s_opsq_direct) return(with_fx(tree, fx_c_t_opsq_direct)); + } + if (cadr(p) == var2) + { + if ((pfunc == fx_add_s_car_s) && (arg2_arg == var1)) return(with_fx(tree, fx_add_u_car_t)); + if ((pfunc == fx_c_s_opsq_direct) && (arg2_arg == var3)) return(with_fx(tree, fx_c_u_opvq_direct)); + } + if ((arg2_arg == var1) && (pfunc == fx_c_s_car_s)) return(with_fx(tree, fx_c_s_car_t)); + } + break; + + case HOP_SAFE_C_opSq_opSq: + { + const s7_pointer arg1 = cadr(p), arg2 = caddr(p); + if ((pfunc == fx_c_opsq_opsq_direct) && (cadr(arg1) == var1) && (cadr(arg2) == var1)) + { + /* p: (set-car! (cadr lst) (cdr lst)), var1: lst */ + set_opt1_sym(cdr(p), cadr(arg1)); + return(with_fx(tree, fx_c_optq_optq_direct)); /* opuq got few hits */ + } + if (((pfunc == fx_c_opsq_opsq_direct) || (pfunc == fx_car_s_car_s)) && + ((car(arg1) == sc->car_symbol) && (car(arg2) == sc->car_symbol))) + { + /* lt.scm: p: (list (car p) (car q)), var1: p, var2: q */ + set_opt1_sym(cdr(p), cadr(arg1)); + set_opt2_sym(cdr(p), cadr(arg2)); + return(with_fx(tree, ((cadr(arg1) == var1) && (cadr(arg2) == 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 (pfunc == fx_is_eq_car_sq) return(with_fx(tree, fx_is_eq_car_tq)); + if ((pfunc == fx_c_opsq_c) || (pfunc == fx_c_optq_c)) + { + if (fn_proc(p) != g_cdr_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: + { + const s7_pointer arg1 = cadr(p); + if (pfunc == fx_c_opssq) + { + if (caddr(arg1) == var1) return(with_fx(tree, fx_c_opstq)); + if ((cadr(arg1) == var1) && (caddr(arg1) == var2)) return(with_fx(tree, fx_c_optuq)); + } + if (pfunc == fx_c_opssq_direct) + { + if ((cadr(arg1) == var1) && (caddr(arg1) == var2)) return(with_fx(tree, fx_c_optuq_direct)); + if (caddr(arg1) == 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(cadr(arg1), var1, var2, var3))) + return(with_fx(tree, fx_is_zero_remainder_o)); + return(with_fx(tree, fx_c_opstq_direct)); + }} + if ((cadr(arg1) == var2) && (pfunc == fx_not_opssq) && (caddadr(p) == var1)) + { + set_fx_direct(tree, (fn_proc(arg1) == 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 ((pfunc == fx_c_opssq_c) && (caddadr(p) == var1)) + { + if (is_global_and_has_func(car(p), s7_p_pp_function)) + { + 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 (pfunc == fx_c_s_opscq_direct) return(with_fx(tree, (cadaddr(p) == var2) ? fx_c_t_opucq_direct : fx_c_t_opscq_direct)); + if ((pfunc == 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 (pfunc == fx_c_s_opsiq_direct) return(with_fx(tree, fx_c_u_optiq_direct)); + if (pfunc == fx_c_s_opscq) return(with_fx(tree, fx_c_u_optcq)); + } + break; + + case HOP_SAFE_C_opSq_CS: + if ((cadadr(p) == var1) && (pfunc == fx_c_opsq_cs) && (cadddr(p) == var2)) return(with_fx(tree, fx_c_optq_cu)); + break; + + case HOP_SAFE_C_opSq_opSSq: + { + const s7_pointer arg1p = cdr(p), arg1 = cadr(p), arg2 = caddr(p); + if ((pfunc == fx_c_opsq_opssq) && (cadr(arg2) == var1) && (caddr(arg2) == var2) && + (is_global_and_has_func(car(p), s7_p_pp_function)) && + (is_global_and_has_func(car(arg1), s7_p_p_function)) && + (is_global_and_has_func(car(arg2), s7_p_pp_function))) + { + set_opt3_direct(p, (s7_pointer)(s7_p_pp_function(global_value(car(p))))); + set_opt2_direct(arg1p, (s7_pointer)(s7_p_p_function(global_value(car(arg1))))); + set_opt3_direct(arg1p, (s7_pointer)(s7_p_pp_function(global_value(car(arg2))))); + set_opt1_sym(arg1p, var2); /* caddaddr(p) */ + set_opt2_sym(cddr(p), var1); + if ((car(p) == sc->num_eq_symbol) && (car(arg1) == sc->car_symbol) && (cadr(arg1) == var3)) + { + if (car(arg2) == sc->add_symbol) return(with_fx(tree, fx_num_eq_car_v_add_tu)); + if (car(arg2) == 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: + { + const s7_pointer s1 = cadadr(p), s2 = caddadr(p); + if (pfunc == fx_vref_vref_ss_s) + { + s7_pointer s3 = caddr(p); + if ((s3 == var1) && (is_defined_global(s1))) + { + if ((!more_vars) && (o_var_ok(s2, var1, var2, var3))) return(with_fx(tree, fx_vref_vref_go_t)); + return(with_fx(tree, fx_vref_vref_gs_t)); + } + if ((s1 == var1) && (s2 == var2) && (s3 == var3)) return(with_fx(tree, fx_vref_vref_tu_v)); + } + if ((pfunc == fx_gt_add_s) && (s1 == var1) && (s2 == var2)) + return(with_fx(tree, fx_gt_add_tu_s)); + if ((pfunc == fx_add_sub_s) && (s1 == var1) && (s2 == 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_defined_global(cadr(p)) && (is_defined_global(cadaddr(p))))) + { + set_opt3_pair(p, cdaddr(p)); + return(with_fx(tree, fx_vref_g_vref_gt)); + } + if (pfunc == fx_c_s_opssq_direct) return(with_fx(tree, fx_c_s_opstq_direct)); + } + if ((pfunc == 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 (((pfunc == fx_c_ac) || (pfunc == 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) && (pfunc == 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 ((pfunc == 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)))) + { + const s7_pointer arg3p = cdddr(p); + set_opt1_sym(cdr(p), cadadr(p)); + if ((fx_proc(arg3p) == fx_is_null_cddr_t) || (fx_proc(arg3p) == fx_is_null_cddr_s)) + return(with_fx(tree, fx_len2_t)); + if ((fx_proc(arg3p) == fx_is_pair_cddr_t) || (fx_proc(arg3p) == 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 base_func, opt_func_t typ, void *opt_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_ip", "o_d_pd", "o_d_7p", "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(base_func)) + { + fprintf(stderr, "%s[%d]: %s is not a c_function\n", __func__, __LINE__, display(base_func)); + if (sc->stop_at_error) abort(); + } + else + if (c_function_opt_data(base_func)) + for (opt_funcs_t *p = c_function_opt_data(base_func); p; p = p->next) + { + if (p->typ == typ) + fprintf(stderr, "%s[%d]: %s has a function of type %d (%s)\n", + __func__, __LINE__, display(base_func), typ, o_names[typ]); + if (p->func == opt_func) + fprintf(stderr, "%s[%d]: %s already has this function as type %d %s (current: %d %s)\n", + __func__, __LINE__, display(base_func), p->typ, o_names[p->typ], typ, o_names[typ]); + } +#endif + op = alloc_semipermanent_opt_func(sc); + op->typ = typ; + op->func = opt_func; + op->next = c_function_opt_data(base_func); + c_function_opt_data(base_func) = op; +} + +static void *opt_func(s7_pointer base_func, opt_func_t typ) +{ + if (is_c_function(base_func)) + for (opt_funcs_t *p = c_function_opt_data(base_func); 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));} + +static void s7_set_d_7p_function(s7_scheme *sc, s7_pointer f, s7_d_7p_t df) {add_opt_func(sc, f, o_d_7p, (void *)df);} +static s7_d_7p_t s7_d_7p_function(s7_pointer f) {return((s7_d_7p_t)opt_func(f, o_d_7p));} + +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));} + +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_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-- + +#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); +} + +#define return_bool(Sc, Bool, Expr) return(return_bool_1(Sc, Bool, Expr, __func__, __LINE__)) +static bool return_bool_1(s7_scheme *sc, bool ok, s7_pointer expr, const char *func, int32_t line) +{ + if (expr) + fprintf(stderr, " %s%s[%d]%s: %s\n", (ok) ? bold_text blue_text : "", func, line, (ok)? unbold_text uncolor_text : "", display_truncated(expr)); + else fprintf(stderr, " %s%s[%d]%s: %s\n", (ok) ? blue_text : "", func, line, (ok)? uncolor_text : "", (ok) ? "true" : "false"); + return(ok); +} +#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) +#define return_bool(Sc, Bool, Expr) return(Bool) +#endif + +static s7_pointer opt_integer_symbol(s7_scheme *sc, s7_pointer sym) +{ + if (is_symbol(sym)) + { + s7_pointer slot = s7_slot(sc, sym); + if ((is_slot(slot)) && /* here and below, p can be # (if in rootlet) */ + (is_t_integer(slot_value(slot)))) + return(slot); + } + return(NULL); +} + +static s7_pointer opt_real_symbol(s7_scheme *sc, s7_pointer sym) +{ + if (is_symbol(sym)) + { + s7_pointer slot = s7_slot(sc, sym); + if ((is_slot(slot)) && + (is_small_real(slot_value(slot)))) + return(slot); + } + return(NULL); +} + +static s7_pointer opt_float_symbol(s7_scheme *sc, s7_pointer sym) +{ + if (is_symbol(sym)) + { + s7_pointer slot = s7_slot(sc, sym); + if ((is_slot(slot)) && + (is_t_real(slot_value(slot)))) + return(slot); + } + return(NULL); +} + +static s7_pointer opt_simple_symbol(s7_scheme *sc, s7_pointer sym) +{ + s7_pointer slot = s7_slot(sc, sym); + if ((is_slot(slot)) && + (!has_methods(slot_value(slot)))) + return(slot); + 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 expr) +{ + opt_info *opc; + s7_pointer p; + if (is_t_integer(expr)) + { + opc = alloc_opt_info(sc); + opc->v[1].i = integer(expr); + opc->v[0].fi = opt_i_c; + return_true(sc, expr); + } + p = opt_integer_symbol(sc, expr); + if (!p) return_false(sc, expr); + opc = alloc_opt_info(sc); + opc->v[1].p = p; + opc->v[0].fi = opt_i_s; + return_true(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + const 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; + const s7_pointer arg1 = cadr(expr); + const 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, expr); + } + 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, expr); + } + if (int_optimize(sc, cdr(expr))) + { + 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, expr); + } + sc->pc = start; + } + if (!is_t_ratio(arg1)) + { + const 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, expr); + } + p = opt_float_symbol(sc, arg1); + if (p) + { + opc->v[1].p = p; + opc->v[0].fi = opt_i_d_s; + return_true(sc, expr); + } + if (float_optimize(sc, cdr(expr))) + { + opc->v[0].fi = opt_i_7d_f; + opc->v[4].fd = sc->opts[start]->v[0].fd; + return_true(sc, expr); + } + sc->pc = start; + }} + ipf = s7_i_7p_function(s_func); + if (ipf) + { + opc->v[2].i_7p_f = ipf; + if (cell_optimize(sc, cdr(expr))) + { + 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, expr); + } + sc->pc = start; + } + return_false(sc, expr); +} + + +/* -------- 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, const s7_pointer expr) +{ + s7_pointer sig; + s7_i_7pi_t pfunc = s7_i_7pi_function(s_func); + if (!pfunc) + { + if ((is_eq_initial_c_function_data(sc->vector_ref_symbol, s_func)) && + (is_normal_symbol(cadr(expr)))) /* (vector-ref )? */ + { + const s7_pointer v_slot = s7_slot(sc, cadr(expr)); + if (is_slot(v_slot)) + { + s7_pointer vec = slot_value(v_slot); + if (is_int_vector(vec)) + { + 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(vec)) + { + pfunc = byte_vector_ref_i_7pi; + s_func = initial_value(sc->byte_vector_ref_symbol); + }}} + if (!pfunc) return_false(sc, expr); + } + sig = c_function_signature(s_func); + if (is_pair(sig)) + { + s7_pointer slot; + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const 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, expr); + 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, expr); + + 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, expr); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + opc->v[0].fi = opt_i_7pi_sf; + opc->v[5].fi = opc->v[4].o1->v[0].fi; + return_true(sc, expr); + } + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + const 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, expr); + } + sig = c_function_signature(s_func); + if (is_pair(sig)) + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const 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, expr); + } + 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, expr); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + 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, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + /* 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(expr) == sc->modulo_symbol) && + (integer(arg2) > 1)) + opc->v[3].i_ii_f = modulo_i_ii_unchecked; + else + { + if (car(expr) == 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, expr); + } + + /* 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, expr); + } + if (int_optimize(sc, cddr(expr))) + { + 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, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + /* 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(expr))) + { + 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, expr);} + if (opc->v[3].i_ii_f == multiply_i_ii) {opc->v[0].fi = opt_i_ii_fc_mul; return_true(sc, expr);} + 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, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + /* arg1 not integer or symbol, arg2 not integer */ + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + 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, expr); + } + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + const int32_t start = sc->pc; + const s7_i_iii_t ifunc = s7_i_iii_function(s_func); + if (!ifunc) return_false(sc, expr); + opc->v[10].o1 = sc->opts[start]; + if (int_optimize(sc, cdr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + opc->v[4].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(expr))) + { + 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, expr); + }}} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- 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, valp); + } + 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; + const s7_pointer vect = slot_value(settee); + const 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) + { + const 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, valp); + 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, valp); + } + 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) || (is_eq_initial_value(target, symfunc))); +} + +static bool i_7pii_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + s7_pointer sig; + const s7_i_7pii_t pfunc = s7_i_7pii_function(s_func); + if (!pfunc) return_false(sc, expr); + sig = c_function_signature(s_func); + if ((is_pair(sig)) && + (is_symbol(cadr(expr)))) + { + s7_pointer slot, fname = car(expr); + + 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(expr), cddr(expr), NULL, cdddr(expr))); + + slot = opt_types_match(sc, cadr(sig), cadr(expr)); + if (slot) + { + s7_pointer arg2, p; + const 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, expr); + + arg2 = caddr(expr); + p = opt_integer_symbol(sc, arg2); + if (p) + { + opc->v[2].p = p; + p = opt_integer_symbol(sc, cadddr(expr)); + 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, expr); + } + if (int_optimize(sc, cdddr(expr))) + { + 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, expr); + } + return_false(sc, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(expr))) + { + 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, expr); + }} + sc->pc = start; + }} + return_false(sc, expr); +} + +static bool i_7piii_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_i_7piii_t f = s7_i_7piii_function(s_func); + if ((f) && (is_symbol(cadr(expr)))) + { + s7_pointer settee; + if ((is_target_or_its_alias(car(expr), s_func, sc->int_vector_set_symbol)) || + (is_target_or_its_alias(car(expr), s_func, sc->byte_vector_set_symbol))) + return(opt_int_vector_set(sc, (car(expr) == sc->int_vector_set_symbol) ? 1 : 0, opc, cadr(expr), cddr(expr), cdddr(expr), cddddr(expr))); + + settee = s7_slot(sc, cadr(expr)); + 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(expr), cdddr(expr), cddddr(expr))); + }}} + return_false(sc, expr); +} + +/* -------- 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 expr) +{ + s7_pointer p; + const s7_pointer head = car(expr); + int32_t cur_len; + const int32_t start = sc->pc; + for (cur_len = 0, p = cdr(expr); (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, expr); + } + sc->pc = start; + return_false(sc, expr); +} + + +/* -------- 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 expr, int32_t len) +{ + if ((car(expr) == sc->set_symbol) && + (len == 3)) + { + const s7_pointer arg1 = cadr(expr); + opt_info *opc = alloc_opt_info(sc); + if (is_symbol(arg1)) /* (set! i 3) */ + { + s7_pointer settee; + if (is_immutable(arg1)) + return_false(sc, expr); + 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))) && + ((is_eq_initial_c_function_data(sc->is_integer_symbol, slot_setter(settee))) || + (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(expr))) + { + if (set_i_i_f_combinable(sc, opc)) + return_true(sc, expr); + 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, expr); + }}} + 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(expr))); + if (is_null(cdddr(arg1))) + return(opt_int_vector_set(sc, -1, opc, car(arg1), cdr(arg1), cddr(arg1), cddr(expr))); + }} + return_false(sc, expr); +} + +static bool i_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer expr, int32_t len) +{ + const s7_pointer obj = slot_value(s_slot); + if ((is_int_vector(obj)) || (is_byte_vector(obj))) + { + const 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(expr)); + 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, expr); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(expr))) + return_false(sc, expr); + 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, expr); + } + 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(expr)); + if (slot) + { + opc->v[2].p = slot; + slot = opt_integer_symbol(sc, caddr(expr)); + if (!slot) + return_false(sc, expr); + 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, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + 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, expr); + }}}} + return_false(sc, expr); +} + + +/* ------------------------------------- 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 expr) +{ + s7_pointer p; + if (is_small_real(expr)) + { + opt_info *opc = alloc_opt_info(sc); + opc->v[1].x = s7_number_to_real(sc, expr); + opc->v[0].fd = opt_d_c; + return_true(sc, expr); + } + p = opt_real_symbol(sc, expr); + 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, expr); + } + return_false(sc, expr); +} + +/* -------- 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! */ +{ + const 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, const s7_pointer s_func, const s7_pointer expr) +{ + s7_d_7d_t func7 = NULL; + const int32_t start = sc->pc; + const 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; + const s7_pointer arg1 = cadr(expr); + 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(expr) == sc->random_symbol) || + (car(expr) == sc->sin_symbol) || (car(expr) == sc->cos_symbol))) + return_false(sc, expr); + 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, expr); + } + 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, expr); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + 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, expr); + } + sc->pc = start; + } + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + s7_pointer sig; + const s7_d_v_t flt_func = s7_d_v_function(s_func); + if (!flt_func) return_false(sc, expr); + sig = c_function_signature(s_func); + if ((is_pair(sig)) && + (is_symbol(cadr(sig))) && + (is_symbol(cadr(expr)))) /* look for (oscil g) */ + { + s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(expr)); + 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, expr); + }} + return_false(sc, expr); +} + +/* -------- 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 s7_double opt_d_7p_s(opt_info *o) {return(o->v[3].d_7p_f(o->sc, slot_value(o->v[1].p)));} +static s7_double opt_d_7p_f(opt_info *o) {return(o->v[3].d_7p_f(o->sc, o->v[5].fp(o->v[4].o1)));} + +static bool d_p_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const int32_t start = sc->pc; + const s7_d_p_t dpf = s7_d_p_function(s_func); /* mostly clm gens */ + s7_d_7p_t d7pf; + if (!dpf) d7pf = s7_d_7p_function(s_func); + if ((!dpf) && (!d7pf)) + return_false(sc, expr); + if (dpf) opc->v[3].d_p_f = dpf; else opc->v[3].d_7p_f = d7pf; + if (is_symbol(cadr(expr))) + { + s7_pointer slot = opt_simple_symbol(sc, cadr(expr)); + if (!slot) + return_false(sc, expr); + opc->v[1].p = slot; + opc->v[0].fd = (dpf) ? opt_d_p_s : opt_d_7p_s; + return_true(sc, expr); + } + opc->v[4].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + opc->v[0].fd = (dpf) ? opt_d_p_f : opt_d_7p_f; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + return_true(sc, expr); + } + sc->pc = start; + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer expr) +{ + /* float-vector-ref is checked for a 1D float-vector arg, but other callers should do type checking */ + const 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 ((is_eq_initial_c_function_data(sc->vector_ref_symbol, s_func)) && (is_normal_symbol(cadr(expr)))) /* (vector-ref )? */ + { + const s7_pointer v_slot = s7_slot(sc, cadr(expr)); + if (is_slot(v_slot)) + { + const s7_pointer vec = slot_value(v_slot); + if ((is_float_vector(vec)) || + ((is_typed_t_vector(vec)) && (typed_vector_typer_symbol(sc, vec) == sc->is_float_symbol))) + { + ifunc = float_vector_ref_d_7pi; + if (is_float_vector(vec)) s_func = initial_value(sc->float_vector_ref_symbol); + }}} + if (!ifunc) return_false(sc, expr); + } + opc->v[3].d_7pi_f = ifunc; + if (is_symbol(cadr(expr))) /* (float-vector-ref v i) */ + { + s7_pointer arg2, p, obj; + opc->v[1].p = s7_slot(sc, cadr(expr)); + if (!is_slot(opc->v[1].p)) return_false(sc, expr); + + obj = slot_value(opc->v[1].p); + if ((is_target_or_its_alias(car(expr), 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, expr); /* but if it's e.g. (block-ref...), go on */ + + arg2 = caddr(expr); + 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, expr); + } + p = opt_integer_symbol(sc, arg2); + if (!p) + return_false(sc, expr); + opc->v[2].p = p; + opc->v[0].fd = opt_d_7pi_ss; + if (is_target_or_its_alias(car(expr), 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, expr); + } + if (int_optimize(sc, cddr(expr))) + { + 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, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + if ((is_target_or_its_alias(car(expr), s_func, sc->float_vector_ref_symbol)) && + ((!is_float_vector(cadr(expr))) || + (vector_rank(cadr(expr)) > 1))) /* (float-vector-ref #r2d((.1 .2) (.3 .4)) 3) */ + return_false(sc, expr); + + if (cell_optimize(sc, cdr(expr))) + { + opt_info *o2 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + 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, expr); + }} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_d_ip_t pfunc = s7_d_ip_function(s_func); + if ((pfunc) && (is_symbol(caddr(expr)))) + { + s7_pointer p = opt_integer_symbol(sc, cadr(expr)); + if (p) + { + opc->v[3].d_ip_f = pfunc; + opc->v[1].p = p; + opc->v[2].p = s7_t_slot(sc, caddr(expr)); + 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, expr); + }}} + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + if (is_symbol(cadr(expr))) + { + const s7_d_pd_t func = s7_d_pd_function(s_func); + if (func) + { + s7_pointer p; + const s7_pointer arg2 = caddr(expr); + const int32_t start = sc->pc; + opc->v[3].d_pd_f = func; + opc->v[1].p = s7_t_slot(sc, cadr(expr)); + if (!is_slot(opc->v[1].p)) return_false(sc, expr); + p = opt_float_symbol(sc, arg2); + if (p) + { + opc->v[2].p = p; + opc->v[0].fd = opt_d_pd_ss; + return_true(sc, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + opc->v[0].fd = opt_d_pd_sf; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + return_true(sc, expr); + } + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + s7_pointer sig; + s7_d_vd_t vfunc; + if (!is_symbol(cadr(expr))) return_false(sc, expr); + vfunc = s7_d_vd_function(s_func); + if (!vfunc) + return_false(sc, expr); + sig = c_function_signature(s_func); + if ((is_pair(sig)) && + (is_symbol(cadr(sig)))) + { + s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(expr)); + if (slot) + { + const s7_pointer arg2 = caddr(expr); + const 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, expr); + } + opc->v[2].p = s7_t_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, expr); + } + if (!float_optimize(sc, cddr(expr))) + return_false(sc, expr); + if (d_vd_f_combinable(sc, start)) + return_true(sc, expr); + 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, expr); + }} + else /* is pair arg2 */ + { + if (float_optimize(sc, cddr(expr))) + { + 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, expr); + 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, expr); + } + sc->pc = start; + }}} + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr, bool expr_case) +{ + s7_pointer p; + const int32_t start = sc->pc; + const s7_d_id_t flt_func = s7_d_id_function(s_func); + if (!flt_func) return_false(sc, expr); + opc->v[3].d_id_f = flt_func; + p = opt_integer_symbol(sc, cadr(expr)); + if (p) + { + const s7_pointer arg2 = caddr(expr); + 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, expr); + } + if ((cadr(expr) == arg2) && (flt_func == multiply_d_id)) + { + opc->v[0].fd = opt_d_i2_mul; + return_true(sc, expr); + } + p = opt_float_symbol(sc, arg2); + if (p) + { + opc->v[0].fd = opt_d_id_ss; + opc->v[2].p = p; + return_true(sc, expr); + } + if (float_optimize(sc, cddr(expr))) + { + if (d_id_sf_combinable(sc, opc)) + return_true(sc, expr); + 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, expr); + } + sc->pc = start; + } + if (is_t_integer(cadr(expr))) + { + if (float_optimize(sc, cddr(expr))) + { + opc->v[0].fd = opt_d_id_cf; + opc->v[1].i = integer(cadr(expr)); + opc->v[4].o1 = sc->opts[start]; + opc->v[5].fd = sc->opts[start]->v[0].fd; + return_true(sc, expr); + } + sc->pc = start; + } + if (!expr_case) return_false(sc, expr); + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[0].fd = opt_d_id_ff; + return_true(sc, expr); + } + sc->pc = start; + } + return_false(sc, expr); +} + +static bool d_id_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + return(d_id_ok_1(sc, opc, s_func, expr, 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, const s7_pointer s_func, const s7_pointer expr) +{ + s7_pointer slot; + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const 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, expr); + } + 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, expr); + 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, expr); + } + 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, expr); + } + if (float_optimize(sc, cddr(expr))) + { + opc->v[1].x = s7_number_to_real(sc, arg1); + if (d_dd_call_combinable(sc, opc, func)) + return_true(sc, expr); + 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, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + /* 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, expr); + } + 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, expr); + } + if (float_optimize(sc, cddr(expr))) + { + if (d_dd_sf_combinable(sc, opc, func)) + return_true(sc, expr); + 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, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + /* 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, expr, false)); + + o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + 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, expr); + } + 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, expr); + } + slot = opt_float_symbol(sc, arg2); + if (slot) + { + opc->v[1].p = slot; + if (d_dd_fs_combinable(sc, opc, func)) + return_true(sc, expr); + 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, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + 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, expr); + 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, expr); + } + 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, expr); + } + 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, expr); + } + 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, expr); + }} + 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, expr); + }} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + const int32_t start = sc->pc; + s7_pointer slot; + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const s7_d_ddd_t f = s7_d_ddd_function(s_func); + if (!f) return_false(sc, expr); + 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) + { + const s7_pointer arg3 = cadddr(expr); + 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, expr); + } + if (float_optimize(sc, cdddr(expr))) + { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[0].fd = opt_d_ddd_ssf; + return_true(sc, expr); + } + sc->pc = start; + } + if (float_optimize(sc, cddr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + 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, expr); + }} + sc->pc = start; + } + if (float_optimize(sc, cdr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + opc->v[5].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + if (d_ddd_fff_combinable(sc, opc, start)) + return_true(sc, expr); + 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, expr); + }}} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_d_7pid_t f = s7_d_7pid_function(s_func); + if ((f) && (is_symbol(cadr(expr)))) + { + s7_pointer slot; + const s7_pointer head = car(expr); + const 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(expr), cddr(expr), NULL, NULL, cdddr(expr))); + + opc->v[1].p = s7_slot(sc, cadr(expr)); + if (!is_slot(opc->v[1].p)) return_false(sc, expr); + opc->v[10].o1 = sc->opts[start]; + if (is_slot(opc->v[1].p)) + { + slot = opt_integer_symbol(sc, caddr(expr)); + if (slot) + { + opc->v[2].p = slot; + slot = opt_float_symbol(sc, cadddr(expr)); + if (slot) + { + opc->v[3].p = slot; + opc->v[0].fd = opt_d_7pid_sss; + return_true(sc, expr); + } + if (float_optimize(sc, cdddr(expr))) + { + opc->v[11].fd = sc->opts[start]->v[0].fd; + if (d_7pid_ssf_combinable(sc, opc)) + return_true(sc, expr); + opc->v[0].fd = opt_d_7pid_ssf; + return_true(sc, expr); + } + sc->pc = start; + } + if (int_optimize(sc, cddr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + 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, expr); + }} + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_d_7pii_t ifunc = s7_d_7pii_function(s_func); + if ((ifunc == float_vector_ref_d_7pii) && + (is_symbol(cadr(expr)))) + { + s7_pointer slot; + const int32_t start = sc->pc; + opc->v[1].p = s7_slot(sc, cadr(expr)); + 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, expr); + + opc->v[4].d_7pii_f = ifunc; /* currently pointless */ + slot = opt_integer_symbol(sc, cadddr(expr)); + if (slot) + { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, caddr(expr)); + 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, expr); + } + if (is_t_integer(caddr(expr))) + { + opc->v[2].i = integer(caddr(expr)); + opc->v[0].fd = opt_d_7pii_scs; + return_true(sc, expr); + }} + opc->v[10].o1 = sc->opts[start]; + if (int_optimize(sc, cddr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(expr))) + { + 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, expr); + }} + sc->pc = start; + } + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_d_7piid_t func = s7_d_7piid_function(s_func); + if ((func) && + (is_symbol(cadr(expr)))) + { + opc->v[4].d_7piid_f = func; + if (is_target_or_its_alias(car(expr), s_func, sc->float_vector_set_symbol)) + return(opt_float_vector_set(sc, opc, cadr(expr), cddr(expr), cdddr(expr), NULL, cddddr(expr))); + } + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + if ((s_func == global_value(sc->float_vector_ref_symbol)) && + (is_symbol(cadr(expr)))) + { + s7_pointer slot; + opc->v[1].p = s7_slot(sc, cadr(expr)); + 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, expr); + slot = opt_integer_symbol(sc, car(cddddr(expr))); + if (slot) + { + opc->v[5].p = slot; + slot = opt_integer_symbol(sc, cadddr(expr)); + if (slot) + { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, caddr(expr)); + if (slot) + { + const 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, expr); + }}}} + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + if ((s_func == global_value(sc->float_vector_set_symbol)) && + (is_symbol(cadr(expr)))) + { + if (is_target_or_its_alias(car(expr), s_func, sc->float_vector_set_symbol)) + return(opt_float_vector_set(sc, opc, cadr(expr), cddr(expr), cdddr(expr), cddddr(expr), cdr(cddddr(expr)))); + } + return_false(sc, expr); +} + +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) +{ + const s7_pointer settee = s7_slot(sc, v); + if ((is_slot(settee)) && + (!is_immutable(slot_value(settee)))) + { + s7_pointer slot; + const s7_pointer vect = slot_value(settee); + const int32_t start = sc->pc; + opc->v[1].p = settee; + if (!is_float_vector(vect)) return_false(sc, vect); + 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, indexp1); + } + 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, valp); + 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, indexp1); + } + if ((indexp3) && + (vector_rank(vect) == 3)) + { + 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, const s7_pointer s_func, const s7_pointer expr) +{ + if ((is_symbol(cadr(expr))) && + (is_symbol(caddr(expr)))) + { + s7_pointer sig; + const s7_d_vid_t flt = s7_d_vid_function(s_func); + if (!flt) return_false(sc, expr); + opc->v[4].d_vid_f = flt; + sig = c_function_signature(s_func); + if (is_pair(sig)) + { + const int32_t start = sc->pc; + const s7_pointer vslot = opt_types_match(sc, cadr(sig), cadr(expr)); + 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(expr)); + if ((slot) && + (float_optimize(sc, cdddr(expr)))) + { + 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, expr); + }} + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_d_vdd_t flt = s7_d_vdd_function(s_func); + if (flt) + { + const s7_pointer sig = c_function_signature(s_func); + opc->v[4].d_vdd_f = flt; + if (is_pair(sig)) + { + const s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(expr)); + if (slot) + { + const int32_t start = sc->pc; + opc->v[10].o1 = sc->opts[start]; + if (float_optimize(sc, cddr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + 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, expr); + }} + sc->pc = start; + }}} + return_false(sc, expr); +} + + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_d_dddd_t f = s7_d_dddd_function(s_func); + if (!f) return_false(sc, expr); + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + opc->v[4].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + opc->v[2].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddddr(expr))) + { + 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, expr); + }}}} + return_false(sc, expr); +} + +/* -------- 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 expr) +{ + const s7_pointer head = car(expr); + const 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(expr); (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, expr); + }} + sc->pc = start; + return_false(sc, expr); +} + + +/* -------- 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 expr, int32_t len) +{ + if ((len == 3) && + (car(expr) == sc->set_symbol)) + { + const s7_pointer arg1 = cadr(expr); + opt_info *opc = alloc_opt_info(sc); + if (is_symbol(arg1)) + { + s7_pointer settee; + if (is_immutable(arg1)) return_false(sc, expr); + 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))) && + ((is_eq_initial_c_function_data(sc->is_float_symbol, slot_setter(settee))) || + (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(expr))) && + (float_optimize(sc, cddr(expr)))) + { /* 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(expr)); */ + opc->v[2].o1 = o1; + opc->v[3].fd = o1->v[0].fd; + return_true(sc, expr); + }}} + 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(expr))); + if (is_null(cdddr(arg1))) + return(opt_float_vector_set(sc, opc, car(arg1), cdr(arg1), cddr(arg1), NULL, cddr(expr))); + }} + return_false(sc, expr); +} + +static bool d_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer expr, int32_t len) +{ + s7_pointer slot; + const s7_pointer 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(expr)); + 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, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(expr))) + return_false(sc, expr); + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[0].fd = opt_d_7pi_sf; + return_true(sc, expr); + } + 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(expr)); + if (slot) + { + opc->v[2].p = slot; + slot = opt_integer_symbol(sc, caddr(expr)); + 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, expr); + }} + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + 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, expr); + }}} + if ((len == 4) && + (vector_rank(obj) == 3)) + { + opt_info *opc = alloc_opt_info(sc); + opc->v[1].p = s_slot; + slot = opt_integer_symbol(sc, cadr(expr)); + if (slot) + { + opc->v[2].p = slot; + slot = opt_integer_symbol(sc, caddr(expr)); + if (slot) + { + opc->v[3].p = slot; + slot = opt_integer_symbol(sc, cadddr(expr)); + 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, expr); + }}}}} + if ((is_c_object(obj)) && + (len == 2)) + { + const s7_pointer getf = c_object_getf(sc, obj); + if (is_c_function(getf)) /* default is #f */ + { + const 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(expr)); + if (slot) + { + opc->v[0].fd = opt_d_7pi_ss; + opc->v[2].p = slot; + return_true(sc, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[0].fd = opt_d_7pi_sf; + return_true(sc, expr); + }}}} + return_false(sc, expr); +} + + +/* -------------------------------- 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 expr) +{ + s7_pointer p; + if (!is_symbol(expr)) return_false(sc, expr); /* i.e. use cell_optimize */ + p = opt_simple_symbol(sc, expr); + 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, expr); + } + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr, const s7_pointer arg_type) +{ + s7_b_p_t bpf = NULL; + s7_b_7p_t bpf7 = NULL; + opt_info *opc = alloc_opt_info(sc); + const int32_t cur_index = sc->pc; + + if ((arg_type == sc->is_integer_symbol) || (arg_type == sc->is_byte_symbol)) + { + const s7_b_i_t bif = s7_b_i_function(s_func); + if (bif) + { + opc->v[2].b_i_f = bif; + if (is_symbol(cadr(expr))) + { + opc->v[1].p = s7_t_slot(sc, cadr(expr)); + opc->v[0].fb = opt_b_i_s; + return_true(sc, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + opt_info *o1 = sc->opts[sc->pc - 1]; + if ((car(expr) == 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, expr); + } + opc->v[0].fb = opt_b_i_f; + opc->v[11].fi = opc->v[10].o1->v[0].fi; + return_true(sc, expr); + }}} + else + if (arg_type == sc->is_float_symbol) + { + const s7_b_d_t bdf = s7_b_d_function(s_func); + if (bdf) + { + opc->v[2].b_d_f = bdf; + if (is_symbol(cadr(expr))) + { + opc->v[1].p = s7_t_slot(sc, cadr(expr)); + opc->v[0].fb = (bdf == is_positive_d) ? opt_b_d_s_is_positive : opt_b_d_s; + return_true(sc, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + opc->v[0].fb = opt_b_d_f; + opc->v[11].fd = opc->v[10].o1->v[0].fd; + return_true(sc, expr); + }}} + 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(expr))) + { + const s7_pointer p = opt_simple_symbol(sc, cadr(expr)); + if (!p) return_false(sc, expr); + 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, expr); + } + opc->v[3].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + 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, expr); + }} + return_false(sc, expr); +} + + +/* -------- b_pp -------- */ +static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) +{ + s7_pointer slot; + const s7_pointer arg = car(argp); + if (is_pair(arg)) + { + if (is_symbol(car(arg))) + { + if ((is_slot(global_slot(car(arg)))) && + ((is_global(car(arg))) || + (s7_t_slot(sc, car(arg)) == global_slot(car(arg))))) + { + const s7_pointer a_func = global_value(car(arg)); + if (is_c_function(a_func)) + { + const 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_complex_symbol) || + ((is_pair(car(sig))) && (direct_memq(sc->is_complex_symbol, car(sig))))) + return(sc->is_complex_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)) + { + const 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 */ + { + const s7_pointer v_slot = s7_slot(sc, cadr(arg)); /* (vector-ref not-a-var ...) -> is_slot check, not # */ + if (is_slot(v_slot)) + { + const s7_pointer vec = slot_value(v_slot); + if (car(arg) == sc->vector_ref_symbol) + { + if (is_int_vector(vec)) return(sc->is_integer_symbol); + if (is_float_vector(vec)) return(sc->is_float_symbol); + if (is_complex_vector(vec)) return(sc->is_complex_symbol); + if (is_byte_vector(vec)) return(sc->is_byte_symbol); + if (is_typed_t_vector(vec)) return(typed_vector_typer_symbol(sc, vec)); /* includes closure name ?? */ + } + else + if ((is_hash_table(vec)) && (is_typed_hash_table(vec)) && (is_c_function(hash_table_value_typer(vec)))) + return(c_function_symbol(hash_table_value_typer(vec))); + }} + 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))) + { + const 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 p = o->v[9].fp(o->v[8].o1); return(o->v[3].b_7pp_f(o->sc, p, o->v[11].fp(o->v[10].o1)));} +static bool opt_b_pp_ff(opt_info *o) {s7_pointer p = o->v[9].fp(o->v[8].o1); return(o->v[3].b_pp_f(p, 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, const s7_pointer s_func, const s7_pointer expr, 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(expr)); + s7_pointer arg2_type = opt_arg_type(sc, cddr(expr)); + 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, const s7_pointer s_func, const s7_pointer expr, s7_pointer arg1, s7_pointer arg2, bool bpf_case) +{ + const 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)) + { + const 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, expr); + }} + if (is_symbol(arg1)) + { + opc->v[1].p = opt_simple_symbol(sc, arg1); + if (!opc->v[1].p) + return_false(sc, expr); + 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, expr, opt_b_pp_sc); + return_true(sc, expr); + } + if (cell_optimize(sc, cddr(expr))) + { + 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, expr, 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, expr); + } + 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(expr))) + { + opc->v[1].p = s7_slot(sc, arg2); /* can be # */ + if ((!is_slot(opc->v[1].p)) || + (has_methods(slot_value(opc->v[1].p)))) + return_false(sc, expr); + 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, expr, opt_b_pp_fs); + return_true(sc, expr); + } + sc->pc = cur_index; + } + o1 = sc->opts[sc->pc]; /* used below opc->v[8].o1 etc */ + if (cell_optimize(sc, cdr(expr))) + { + opc->v[10].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + if (b_pp_ff_combinable(sc, opc, bpf_case)) + return_true(sc, expr); + 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, expr, 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, expr); + }} + return_false(sc, expr); +} + +/* -------- 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 p = o->v[11].fp(o->v[10].o1); return(o->v[2].b_pi_f(o->sc, p, o->v[9].fi(o->v[8].o1)));} + +static bool b_pi_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, s7_pointer arg2) +{ + const 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(expr))) + { + 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_t_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, expr); + } + if (is_t_integer(arg2)) + { + opc->v[1].i = integer(arg2); + opc->v[0].fb = opt_b_pi_fi; + return_true(sc, expr); + } + if (int_optimize(sc, cddr(expr))) + { + opc->v[0].fb = opt_b_pi_ff; + opc->v[8].o1 = o1; + opc->v[9].fp = o1->v[0].fp; + return_true(sc, expr); + }}} + return_false(sc, expr); +} + + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr, s7_pointer arg1, s7_pointer arg2) +{ + const s7_b_dd_t bif = s7_b_dd_function(s_func); + const int32_t cur_index = sc->pc; + if (!bif) return_false(sc, expr); + opc->v[3].b_dd_f = bif; + if (is_symbol(arg1)) + { + opc->v[1].p = s7_t_slot(sc, arg1); + if (is_symbol(arg2)) + { + opc->v[2].p = s7_t_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, expr); + } + 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, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + opc->v[0].fb = opt_b_dd_sf; + return_true(sc, expr); + }} + sc->pc = cur_index; + opc->v[10].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + opc->v[11].fd = opc->v[10].o1->v[0].fd; + if (is_symbol(arg2)) + { + opc->v[1].p = s7_t_slot(sc, arg2); + opc->v[0].fb = (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs; + return_true(sc, expr); + } + 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, expr); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + opc->v[9].fd = opc->v[8].o1->v[0].fd; + opc->v[0].fb = opt_b_dd_ff; + return_true(sc, expr); + }} + sc->pc = cur_index; + return_false(sc, expr); +} + + +/* -------- 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)) & ((s7_int)(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, const s7_pointer s_func, const s7_pointer expr, s7_pointer arg1, s7_pointer arg2) +{ + const 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, expr); + } + 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_t_slot(sc, arg1); + if (is_symbol(arg2)) + { + opc->v[2].p = s7_t_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, expr); + } + if (is_t_integer(arg2)) + { + const 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, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if ((bif) && (int_optimize(sc, cddr(expr)))) + { + 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, expr); + } + return_false(sc, expr); + } + if (!bif) return_false(sc, expr); + + if (is_symbol(arg2)) + { + opc->v[10].o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(expr))) + return_false(sc, expr); + opc->v[11].fi = opc->v[10].o1->v[0].fi; + opc->v[2].p = s7_t_slot(sc, arg2); + opc->v[0].fb = opt_b_ii_fs; + return_true(sc, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + 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, expr); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + opc->v[9].fi = opc->v[8].o1->v[0].fi; + opc->v[0].fb = opt_b_ii_ff; + return_true(sc, expr); + }} + return_false(sc, expr); +} + +/* -------- 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 expr, int32_t len, int32_t is_and) +{ + opt_info *opc = alloc_opt_info(sc); + s7_pointer p = cdr(expr); + if (len == 3) + { + opt_info *o1 = sc->opts[sc->pc]; + if (bool_optimize_nw(sc, cdr(expr))) + { + opt_info *o2 = sc->opts[sc->pc]; + if (bool_optimize_nw(sc, cddr(expr))) + { + 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, expr); + }} + return_false(sc, expr); + } + 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, expr); + opc->v[0].fb = (is_and) ? opt_and_any_b : opt_or_any_b; + return_true(sc, expr); +} + +static bool opt_b_and(s7_scheme *sc, s7_pointer expr, int32_t len) {return(opt_b_or_and(sc, expr, len, true));} +static bool opt_b_or(s7_scheme *sc, s7_pointer expr, int32_t len) {return(opt_b_or_and(sc, expr, 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 expr) +{ + s7_pointer p; + opt_info *opc; + if (!is_symbol(expr)) + { + opc = alloc_opt_info(sc); + opc->v[1].p = expr; + opc->v[0].fp = opt_p_c; + return_true(sc, expr); + } + p = opt_simple_symbol(sc, expr); + if (!p) + return_false(sc, expr); + opc = alloc_opt_info(sc); + opc->v[1].p = p; + opc->v[0].fp = opt_p_s; + return_true(sc, expr); +} + +/* -------- p -------- */ +#define is_opt_safe(P) ((optimize_op(P) >= OP_SAFE_C_S) && (!is_unknown_op(optimize_op(P)))) + +#define cf_call(Sc, expr, S_func, Num) \ + (((is_optimized(expr)) && (is_opt_safe(expr))) ? fn_proc(expr) : c_function_call(c_function_chooser(S_func)(Sc, S_func, Num, expr))) /* 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, const s7_pointer s_func, const s7_pointer expr) +{ + const 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, expr); + } + if ((is_safe_procedure(s_func)) && + (c_function_min_args(s_func) == 0)) + { + opc->v[1].call = cf_call(sc, expr, s_func, 0); + opc->v[0].fp = opt_p_call; + return_true(sc, expr); + } + return_false(sc, expr); +} + +/* -------- 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_random(opt_info *o) {return(random_p_p(o->sc, slot_value(o->v[1].p)));} +static s7_pointer opt_p_p_s_random_wrapped(opt_info *o) {return(random_p_p_wrapped(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_z_f_magnitude(opt_info *o) {return(magnitude_p_z(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(opt_info *o); +static s7_pointer opt_p_pi_sf(opt_info *o); +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, const s7_pointer s_func, const s7_pointer expr) +{ + s7_p_p_t ppf; + const int32_t start = sc->pc; + const s7_pointer arg1 = cadr(expr); + if (is_t_integer(arg1)) + { + const 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, expr); + } + 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, expr); + }} + if (is_t_real(arg1)) + { + const 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, expr); + } + 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, expr); + }} + 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(expr)) && + (fn_proc(expr) == 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, expr); + 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) : + ((ppf == random_p_p) ? opt_p_p_s_random : opt_p_p_s))); + return_true(sc, expr); + } + 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, expr); + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + if (!p_p_f_combinable(sc, opc)) + { + s7_pointer (*fp)(opt_info *o); + if ((ppf == magnitude_p_p) && + ((o1->v[0].fp == opt_p_pi_ss) || (o1->v[0].fp == opt_p_pi_sf)) && + (o1->v[3].p_pi_f == complex_vector_ref_p_pi)) + { + o1->v[3].p_pi_f = complex_vector_ref_p_pi_wrapped; + opc->v[0].fp = opt_p_z_f_magnitude; + } + else + 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(expr) == 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, expr); + }} + + sc->pc = start; + if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 1))) + { + opc->v[2].call = cf_call(sc, expr, s_func, 1); + if (is_symbol(arg1)) + { + const 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, expr); + }} + else + { + opt_info *o1; + if (!is_pair(arg1)) + { + opc->v[1].p = arg1; + opc->v[0].fp = opt_p_call_c; + return_true(sc, expr); + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + 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, expr); + }}} + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + s7_pointer p; + const s7_p_i_t ifunc = s7_p_i_function(s_func); + if (!ifunc) return_false(sc, expr); + p = opt_integer_symbol(sc, cadr(expr)); + 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, expr); + } + if (int_optimize(sc, cdr(expr))) + { + 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, expr); + } + sc->pc = pstart; + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + s7_pointer p2; + const s7_p_ii_t ifunc = s7_p_ii_function(s_func); + if (!ifunc) return_false(sc, expr); + p2 = opt_integer_symbol(sc, caddr(expr)); + if (p2) + { + const s7_pointer p1 = opt_integer_symbol(sc, cadr(expr)); + 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, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + 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, expr); + } + sc->pc = pstart; + return_false(sc, expr); + } + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + 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, expr); + }} + sc->pc = pstart; + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + s7_pointer p; + opt_info *o1; + const s7_p_d_t ifunc = s7_p_d_function(s_func); + if (!ifunc) return_false(sc, expr); + p = opt_float_symbol(sc, cadr(expr)); + 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, expr); + } + if ((is_number(cadr(expr))) && (!is_t_real(cadr(expr)))) + return_false(sc, expr); + o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + 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, expr); + } + sc->pc = pstart; + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + s7_pointer slot; + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const s7_p_dd_t ifunc = s7_p_dd_function(s_func); + if (!ifunc) return_false(sc, expr); + 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, expr); + } + 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, expr); + }} + 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, expr); + }} + sc->pc = pstart; + return_false(sc, expr); +} + +/* -------- 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_cvref_direct(opt_info *o) {return(complex_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_scheme *sc, s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = unchecked_type(T_Slt(p)); + if (!has_loop_end(p)) complain(sc, "%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(sc, 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_COMPLEX_VECTOR: + if (((!expr) || (car(expr) == sc->complex_vector_ref_symbol) || (car(expr) == sc->vector_ref_symbol)) && + (loop_end(slot) <= vector_length(obj))) + opc->v[3].p_pi_f = complex_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 == complex_vector_ref_p_pi_direct) ? opt_p_pi_ss_cvref_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 expr) +{ + s7_pointer obj = NULL, slot1, checker = NULL; + opt_info *o1; + const s7_p_pi_t func = s7_p_pi_function(s_func); + if (!func) return_false(sc, expr); + /* here we know cadr is a symbol */ + slot1 = opt_simple_symbol(sc, cadr(expr)); + if (!slot1) + return_false(sc, expr); + if ((is_any_vector(slot_value(slot1))) && + (vector_rank(slot_value(slot1)) > 1)) + return_false(sc, expr); + + opc->v[3].p_pi_f = func; + opc->v[1].p = slot1; + + if (is_symbol(cadr(sig))) + checker = cadr(sig); + + obj = slot_value(opc->v[1].p); + if ((s7_p_pi_unchecked_function(s_func)) && + (checker)) + { + 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(expr)); + if (slot1) + { + opc->v[2].p = slot1; + if ((obj) && /* this depends above on s7_p_pi_unchecked_function, but none of the typed vectors have one?? */ + (has_loop_end(slot1))) + check_unchecked(sc, obj, slot1, opc, expr); + fixup_p_pi_ss(opc); + return_true(sc, expr); + } + if (is_t_integer(caddr(expr))) + { + opc->v[2].i = integer(caddr(expr)); + 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, expr); + } + o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + 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, expr); + } + return_false(sc, expr); +} + +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, gc_protected1(sc), gc_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; + const s7_pointer s1 = slot_value(o1->v[1].p); + s7_pointer s3 = slot_value(o2->v[1].p); + const 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_gc_protected2(sc, f4); + set_gc_protected2(sc, multiply_p_pp_wrapped(sc, s3, f4)); + set_gc_protected1(sc, multiply_p_pp_wrapped(sc, s1, f2)); + s3 = (add_case) ? add_p_pp(sc, gc_protected1(sc), gc_protected2(sc)) : subtract_p_pp(sc, gc_protected1(sc), gc_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, T_Let(let)); + if (is_slot(slot)) + { + opc->v[2].p = slot; + opc->v[0].fp = opt_p_pp_slot_ref; + } +} + +static s7_pointer opt_p_curlet_ref(opt_info *o) {return(slot_value(o->v[1].p));} +static s7_pointer opt_p_unlet_ref(opt_info *o) {return(o->v[1].p);} +static s7_pointer opt_p_rootlet_ref(opt_info *o) {return(global_value(o->v[1].p));} + +static bool opt_unlet_rootlet_ref(s7_scheme *sc, opt_info *opc, s7_pointer arg1, s7_pointer sym, s7_pointer expr) +{ + if (car(arg1) == sc->rootlet_symbol) + { + if (!is_slot(global_slot(sym))) + { + opc->v[0].fp = opt_p_c; + opc->v[1].p = sc->undefined; + return_true(sc, expr); + }} + if (car(arg1) == sc->curlet_symbol) + { + s7_pointer p = opt_simple_symbol(sc, sym); + if (!p) return_false(sc, expr); + opc->v[0].fp = opt_p_curlet_ref; + return(true); + } + opc->v[0].fp = (car(arg1) == sc->rootlet_symbol) ? opt_p_rootlet_ref : opt_p_unlet_ref; + opc->v[1].p = (car(arg1) == sc->unlet_symbol) ? initial_value(sym) : sym; + return_true(sc, expr); +} + +static bool p_pp_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const s7_p_pp_t func = s7_p_pp_function(s_func); + if (!func) return_false(sc, expr); + opc->v[3].p_pp_f = func; + if (is_symbol(arg1)) + { + s7_pointer obj; + const s7_pointer slot = opt_simple_symbol(sc, arg1); + if (!slot) + { + sc->pc = pstart; + return_false(sc, expr); + } + obj = slot_value(slot); + if ((is_any_vector(obj)) && (vector_rank(obj) > 1)) + { + sc->pc = pstart; + return_false(sc, expr); + } + 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, expr); + } + sc->pc = pstart; + return_false(sc, expr); + } + 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)); /* expr: (let-ref L 'a), can't be keyword here (handled above) */ + return_true(sc, expr); + } + if (cell_optimize(sc, cddr(expr))) + { + 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, expr); + }} + 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, expr); + } + 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, expr); + } + sc->pc = pstart; + return_false(sc, expr); + }} + + if ((car(expr) == sc->let_ref_symbol) && (is_pair(arg1)) && + ((is_symbol_and_keyword(arg2)) || ((is_quoted_symbol(arg2)))) && + ((car(arg1) == sc->unlet_symbol) || (car(arg1) == sc->rootlet_symbol) || (car(arg1) == sc->curlet_symbol))) + return(opt_unlet_rootlet_ref(sc, opc, arg1, (is_pair(arg2)) ? cadr(arg2) : keyword_symbol(arg2), expr)); + + if (cell_optimize(sc, cdr(expr))) + { + 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; + if (opc->v[5].fp == opt_p_p_s_random) opc->v[5].fp = opt_p_p_s_random_wrapped; + return_true(sc, expr); + } + sc->pc = pstart; + return_false(sc, expr); + } + if ((!is_pair(arg2)) || + (is_proper_quote(sc, arg2))) + { + if (is_t_integer(arg2)) + { + const 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, expr); + }} + 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, expr); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + 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, expr); + }}} + sc->pc = pstart; + return_false(sc, expr); +} + +/* -------- 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, gc_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, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + if ((is_safe_procedure(s_func)) && (c_function_is_aritable(s_func, 2))) + { + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + opc->v[3].call = cf_call(sc, expr, 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, expr); + } + if (is_symbol(arg1)) + { + opc->v[1].p = s7_slot(sc, arg1); /* can be # */ + 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, expr); + } + sc->pc = pstart; + return_false(sc, expr); + } + if (!is_pair(arg2)) + { + opc->v[2].p = arg2; + opc->v[0].fp = opt_p_call_sc; + return_true(sc, expr); + } + if (cell_optimize(sc, cddr(expr))) + { + 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, expr); + }} + else + { + sc->pc = pstart; + return_false(sc, expr); + }} + opc->v[10].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + 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, expr); + } + sc->pc = pstart; + return_false(sc, expr); + } + if ((!is_pair(arg2)) || (is_proper_quote(sc, arg2))) /* (char-civ[0].fp = opt_p_call_fc; + opc->v[2].p = (is_pair(arg2)) ? cadr(arg2) : arg2; + check_opc_vector_wraps(opc); + return_true(sc, expr); + } + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + 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, expr); + }}} + sc->pc = pstart; + return_false(sc, expr); +} + + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + s7_pointer obj, slot1, obj1, sig, checker = NULL, val_type; + const s7_p_pip_t func = s7_p_pip_function(s_func); + if (!func) return_false(sc, expr); + 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(expr)); + if (!is_slot(slot1)) return_false(sc, expr); + obj1 = slot_value(slot1); + if ((has_methods(obj1)) || (is_immutable(obj1))) return_false(sc, expr); + if ((is_any_vector(obj1)) && (vector_rank(obj1) > 1)) return_false(sc, expr); + val_type = opt_arg_type(sc, cdddr(expr)); + 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(expr))) + { + const int32_t start = sc->pc; + const s7_pointer arg3 = cadddr(expr); /* see val_type above */ + const s7_pointer slot2 = opt_integer_symbol(sc, caddr(expr)); + 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, expr); + 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, expr); + 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, expr); + if (loop_end(slot2) <= vector_length(obj)) + opc->v[3].p_pip_f = float_vector_set_p_pip_direct; + break; + case T_COMPLEX_VECTOR: + if ((val_type != sc->is_complex_symbol) && (val_type != sc->is_real_symbol)) return_false(sc, expr); + if (loop_end(slot2) <= vector_length(obj)) + opc->v[3].p_pip_f = complex_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, expr); + }} + 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, expr); + } + if (cell_optimize(sc, cdddr(expr))) + { + if (p_pip_ssf_combinable(sc, opc, start)) + return_true(sc, expr); + 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, expr); + }}} + else /* not symbol caddr */ + { + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(expr))) + { + 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, expr); + }}} + return_false(sc, expr); +} + +/* -------- 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, indexp1); +} + +static bool p_piip_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_p_piip_t func = s7_p_piip_function(s_func); + if ((func) && (s_func == global_value(sc->vector_set_symbol)) && (is_symbol(cadr(expr)))) + { + s7_pointer obj; + const s7_pointer slot1 = s7_slot(sc, cadr(expr)); + if (!is_slot(slot1)) return_false(sc, expr); + obj = slot_value(slot1); + if ((has_methods(obj)) || (is_immutable(obj))) return_false(sc, expr); + 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(expr), cdddr(expr), cddddr(expr), obj)); + }} + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_p_pii_t func = s7_p_pii_function(s_func); + if ((func) && + (is_symbol(cadr(expr)))) + { + s7_pointer obj; + const s7_pointer slot1 = s7_slot(sc, cadr(expr)); + if (!is_slot(slot1)) return_false(sc, expr); + obj = slot_value(slot1); + if ((has_methods(obj)) || (is_immutable(obj))) return_false(sc, expr); + if ((is_t_vector(obj)) && + (vector_rank(obj) == 2)) + { + s7_pointer slot, indexp1 = cddr(expr), indexp2 = cdddr(expr); + 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, expr); + }} + 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, expr); + }}}} + return_false(sc, expr); +} + +/* -------- 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, const s7_pointer s_func, const s7_pointer expr) +{ + const int32_t start = sc->pc; + const s7_p_ppi_t ifunc = s7_p_ppi_function(s_func); + if (!ifunc) return_false(sc, expr); + opc->v[3].p_ppi_f = ifunc; + if ((is_character(cadr(expr))) && + (is_symbol(caddr(expr))) && + (int_optimize(sc, cdddr(expr)))) + { + const s7_pointer slot = opt_simple_symbol(sc, caddr(expr)); + if (slot) + { + opc->v[2].p = cadr(expr); + 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, expr); + }} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- 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 result; + 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))); + result = o->v[3].p_ppp_f(o->sc, slot_value(o->v[1].p), gc_protected1(sc), gc_protected2(sc)); + unstack_gc_protect(sc); + return(result); +} + +static s7_pointer opt_p_ppp_fff(opt_info *o) +{ + s7_pointer result; + 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))); + result = o->v[3].p_ppp_f(sc, gc_protected1(sc), gc_protected2(sc), o->v[5].fp(o->v[4].o1)); + unstack_gc_protect(sc); + return(result); +} + +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) /* timp tmisc */ +{ + s7_pointer slot = lookup_slot_with_let(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) /* timp tref */ +{ + s7_pointer slot = lookup_slot_with_let(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) /* timp */ +{ + s7_pointer slot = lookup_slot_with_let(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, const s7_pointer s_func, const s7_pointer expr) +{ + const s7_pointer arg1 = cadr(expr); + const s7_pointer arg2 = caddr(expr); + const s7_pointer arg3 = cadddr(expr); + const int32_t start = sc->pc; + const s7_p_ppp_t func = s7_p_ppp_function(s_func); + if (!func) return_false(sc, expr); + 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, expr); + + obj = slot_value(slot); + if ((is_any_vector(obj)) && + (vector_rank(obj) > 1)) + return_false(sc, expr); + + if (is_target_or_its_alias(car(expr), s_func, sc->hash_table_set_symbol)) + { + if ((!is_hash_table(obj)) || (is_immutable_hash_table(obj))) + return_false(sc, expr); + } + else + if ((is_target_or_its_alias(car(expr), s_func, sc->let_set_symbol)) && + ((!is_let(obj)) || (is_immutable(obj)))) + return_false(sc, expr); + + 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, expr); + } + slot = opt_simple_symbol(sc, arg2); + if (slot) + { + const s7_pointer arg2_val = slot_value(slot); + opc->v[2].p = 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, expr); + }} + 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_val))) /* (let-set! L3 :x 0) */ + use_ppc_slot_set(sc, opc, obj, (is_keyword(arg2_val)) ? keyword_symbol(arg2_val) : arg2_val, opc->v[4].p); + return_true(sc, expr); + } + if (optimize_op(expr) == HOP_HASH_TABLE_INCREMENT) + { + opc->v[0].fp = opt_p_ppp_hash_table_increment; + opc->v[5].p = expr; + return_true(sc, expr); + } + if (cell_optimize(sc, cdddr(expr))) + { + 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_val)) && (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_val)); + + if ((sc->do_body_p == expr) && (is_complex_vector(obj)) && (is_pair(arg3)) && + (car(arg3) == sc->complex_symbol) && (car(expr) == sc->complex_vector_set_symbol)) + { + if (opc->v[4].o1->v[3].p_pp_f == complex_p_pp) + opc->v[4].o1->v[3].p_pp_f = complex_p_pp_wrapped; + else + if (opc->v[4].o1->v[3].p_dd_f == complex_p_dd) + opc->v[4].o1->v[3].p_dd_f = complex_p_dd_wrapped; + else + if (opc->v[4].o1->v[3].p_ii_f == complex_p_ii) /* (complex-vector-set! cv1 i (complex i i)) */ + opc->v[4].o1->v[3].p_ii_f = complex_p_ii_wrapped; + /* opc->v[3].p_ppp_f = complex_vector_set_p_ppp and fn_proc(arg3) == g_complex_wrapped */ + /* p_pip case is different! o->v[9].fp(o->v[8].o1 */ + } + + return_true(sc, expr); + } + sc->pc = start; + }} + if ((is_proper_quote(sc, arg2)) && + (is_symbol(arg3))) + { + const 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, expr); + }} + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + opt_info *o2 = sc->opts[sc->pc]; + if (is_symbol(arg3)) + { + const 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, expr); + }} + 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, expr); + + if (cell_optimize(sc, cdddr(expr))) + { + 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, expr); + } + 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, expr); + }}} + else /* arg1 not symbol */ + { + opc->v[10].o1 = sc->opts[start]; + if (cell_optimize(sc, cdr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + opc->v[4].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(expr))) + { + 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, expr); + }}}} + sc->pc = start; + return_false(sc, expr); +} + + +/* -------- 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_scs(opt_info *o) +{ + return(o->v[4].call(o->sc, set_plist_3(o->sc, slot_value(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 result; + 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)); + result = o->v[11].fp(o->v[10].o1); /* not combinable into next */ + result = o->v[2].call(sc, set_plist_3(sc, gc_protected1(sc), gc_protected2(sc), result)); + unstack_gc_protect(sc); + return(result); +} + +static bool p_call_ppp_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) +{ + const 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; + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); + 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, expr); + /* arg1 ok as symbol */ + if ((is_code_constant(sc, arg2)) && (is_normal_symbol(arg3))) + { + s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) + { + opc->v[2].p = arg2; + opc->v[3].p = val_slot; + opc->v[4].call = cf_call(sc, expr, s_func, 3); + if ((sc->do_body_p == expr) && (arg1 == sc->F) && (car(expr) == sc->format_symbol)) + opc->v[4].call = g_format_nr; + opc->v[0].fp = opt_p_call_scs; + return_true(sc, expr); + }}} + else return_false(sc, expr); /* 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))) + { + const s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) + { + opc->v[1].p = arg1; + opc->v[2].p = (is_pair(arg2)) ? cadr(arg2) : arg2; + opc->v[3].p = val_slot; + opc->v[4].call = cf_call(sc, expr, s_func, 3); + if ((sc->do_body_p == expr) && (arg1 == sc->F) && (car(expr) == sc->format_symbol)) + opc->v[4].call = g_format_nr; + opc->v[0].fp = opt_p_call_ccs; + return_true(sc, expr); + }} + opc->v[1].p = arg1; + if (s_func == global_value(sc->vector_ref_symbol)) + return_false(sc, expr); + } + 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, expr, s_func, 3); + opc->v[0].fp = (is_slot(opc->v[1].p)) ? opt_p_call_sss : opt_p_call_css; + return_true(sc, expr); + }} + else + if (is_slot(opc->v[1].p)) + { + const int32_t start1 = sc->pc; + if ((cf_call(sc, expr, 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(expr)))) + { + 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, expr); + } + sc->pc = start1; + if (cell_optimize(sc, cdddr(expr))) + { + opc->v[4].call = cf_call(sc, expr, 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, expr); + }}}}} + if (s_func == global_value(sc->vector_ref_symbol)) return_false(sc, expr); + if (cell_optimize(sc, cdr(expr))) + { + opt_info *o2 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + opt_info *o3 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(expr))) + { + opc->v[2].call = cf_call(sc, expr, 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, expr); + }}}} + sc->pc = start; + return_false(sc, expr); +} + + +/* -------- 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_safe_list_in_use(val); + return(arg); +} + +static s7_pointer opt_p_call_4g(opt_info *o) +{ + s7_scheme *sc = o->sc; + opt_info *o1 = o->v[0 + P_CALL_O1].o1; + opt_info *o2 = o->v[1 + P_CALL_O1].o1; + opt_info *o3 = o->v[2 + P_CALL_O1].o1; + opt_info *o4 = o->v[3 + P_CALL_O1].o1; + return(o->v[2].call(o->sc, set_plist_4(sc, o1->v[0].fp(o1), o2->v[0].fp(o2), o3->v[0].fp(o3), o4->v[0].fp(o4)))); +} + +static bool p_call_any_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t len) +{ + if ((len < (NUM_VUNIONS - P_CALL_O1)) && + (is_safe_procedure(s_func)) && + (c_function_is_aritable(s_func, len - 1))) + { + bool safe = true; + s7_pointer p = cdr(expr); /* (vector-set! v k i 2) gets here, as does (float-vector-set! v k i n (+ 0.0 i3 k3 n)) from tvect */ + opc->v[1].i = (len - 1); /* also ccff in cb.scm I think */ + 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_pair(car(p))) safe = false; + } + if (is_null(p)) + { + opc->v[0].fp = ((len == 5) && (safe)) ? opt_p_call_4g : opt_p_call_any; + opc->v[2].call = cf_call(sc, expr, s_func, len - 1); + return_true(sc, expr); + }} + return_false(sc, expr); +} + + +/* -------- 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 void fx_annotate_arg(s7_scheme *sc, s7_pointer arg, s7_pointer e); + +static bool p_fx_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer expr) +{ + s7_function f = ((is_pair(car(expr))) && (has_fx(car(expr)))) ? fx_proc(car(expr)) : NULL; +#if 0 + /* this is slower! -- fx choices are pessimal here */ + if ((!f) && (is_fxable(sc, car(expr)))) {fx_annotate_arg(sc, expr, sc->curlet); if (has_fx(expr)) f = fx_proc(expr);} +#endif + if (!f) return_false(sc, expr); + opc->v[0].fp = opt_p_fx_any; + opc->v[1].call = f; + opc->v[2].p = car(expr); + return_true(sc, expr); +} + + +/* -------- p_implicit -------- */ + +static bool p_implicit_ok(s7_scheme *sc, s7_pointer s_slot, s7_pointer expr, int32_t len) +{ + const s7_pointer obj = slot_value(s_slot); + const s7_pointer arg1 = (len > 1) ? cadr(expr) : sc->F; + opt_info *opc; + int32_t start; + + if ((!is_simple_sequence(obj)) || (len < 2)) /* was is_sequence? */ + return_false(sc, expr); + + 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, expr); /* no pi_ref because ref assumes pp */ + + case T_VECTOR: + if (vector_rank(obj) != 1) + return_false(sc, expr); + 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: case T_COMPLEX_VECTOR: + if (vector_rank(obj) != 1) + return_false(sc, expr); + opc->v[3].p_pi_f = vector_ref_p_pi_unchecked; + break; + + default: + return_false(sc, expr); + } + /* now v3.p_pi|pp.f is set */ + if (is_symbol(arg1)) + { + const 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, expr); /* 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, expr); + } + 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) -> # */ + return_true(sc, expr); + }} + 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, expr); + } + o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(expr))) + return_false(sc, expr); + opc->v[0].fp = opt_p_pi_sf; + opc->v[4].o1 = o1; + opc->v[5].fi = o1->v[0].fi; + return_true(sc, expr); + } + + 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, expr); + } + + if (cell_optimize(sc, cdr(expr))) + { /* 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, expr); + }}} /* len==2 */ + else + { /* len > 2 */ + if ((is_t_vector(obj)) && (len == 3) && (vector_rank(obj) == 2)) + { + s7_pointer slot = opt_integer_symbol(sc, caddr(expr)); + 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, expr); + }} + opc->v[10].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + 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, expr); + }} + 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 = expr; + 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, expr); /* (* 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_COMPLEX_VECTOR: opc->v[2].call = g_complex_vector_ref; break; + case T_VECTOR: opc->v[2].call = g_vector_ref; break; + default: return_false(sc, expr); + } + return_true(sc, expr); + }}} + return_false(sc, expr); +} + +/* -------- cell_quote -------- */ +static bool opt_cell_quote(s7_scheme *sc, s7_pointer expr) +{ + opt_info *opc; + if (!is_null(cddr(expr))) return_false(sc, expr); + opc = alloc_opt_info(sc); + opc->v[1].p = cadr(expr); + opc->v[0].fp = opt_p_c; + return_true(sc, expr); +} + +/* -------- cell_set -------- */ +static s7_pointer opt_set_p_p_f(opt_info *o) +{ + s7_pointer val = o->v[4].fp(o->v[3].o1); + slot_set_value(o->v[1].p, val); + return(val); +} + +static s7_pointer opt_set_p_p_f_with_setter(opt_info *o) +{ + s7_pointer val = 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), val); + slot_set_value(o->v[1].p, val); + return(val); +} + +static s7_pointer opt_set_input_port_string_p_p_f(opt_info *o) +{ + s7_pointer val = o->v[4].fp(o->v[3].o1); /* the string */ + s7_pointer port = slot_value(o->v[2].p); + if (!is_input_port(port)) wrong_type_error_nr(o->sc, o->sc->port_string_symbol, 1, port, an_input_port_string); + set_input_port_string(o->sc, port, val); + return(val); +} + +static s7_pointer opt_set_output_port_string_p_p_f(opt_info *o) +{ + s7_pointer val = o->v[4].fp(o->v[3].o1); /* the string */ + s7_pointer port = slot_value(o->v[2].p); + if (!is_output_port(port)) wrong_type_error_nr(o->sc, o->sc->port_string_symbol, 1, port, an_input_port_string); + set_output_port_string(o->sc, port, val); + return(val); +} + +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 val = make_integer(o->sc, o->v[6].fi(o->v[5].o1)); + slot_set_value(o->v[1].p, val); + return(val); +} +/* 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 (see tmp) (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? + */ + +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 val = make_real(o->sc, o->v[5].fd(o->v[4].o1)); + slot_set_value(o->v[1].p, val); + return(val); +} + +static s7_pointer opt_set_p_d_f_sf_add(opt_info *o) +{ + s7_pointer val = make_real(o->sc, opt_d_dd_sf_add(o->v[4].o1)); + slot_set_value(o->v[1].p, val); + return(val); +} + +static s7_pointer opt_set_p_d_fm_sf_add(opt_info *o) +{ + s7_double val = opt_d_dd_sf_add(o->v[4].o1); + check_mutability(o->sc, o, __func__, __LINE__); + set_real(slot_value(o->v[1].p), val); + 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 val = make_integer(o->sc, i); + slot_set_value(o->v[1].p, val); + return(val); +} + +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 val = make_integer(o->sc, i); + slot_set_value(o->v[1].p, val); + return(val); +} + +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 val = make_integer(o->sc, i); + slot_set_value(o->v[1].p, val); + return(val); +} + +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 val = make_integer(o->sc, i); + slot_set_value(o->v[1].p, val); + return(val); +} + +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 expr, opt_info *opc, int32_t start_pc) +{ + const s7_pointer code = sc->code; + /* if we're optimizing do, sc->code is (sometimes) ((vars...) (end...) expr) where expr 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-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 expr -- 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, expr, 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 vars = car(code); is_pair(vars); vars = cdr(vars)) + { + const s7_pointer binding = car(vars); + if ((is_proper_list_2(sc, binding)) && + (car(binding) == 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(expr))) + { + 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, expr); + }}} + return_false(sc, expr); +} + +static s7_pointer opt_starlet_set(opt_info *o) +{ + s7_pointer val = o->v[3].fp(o->v[2].o1); + return(starlet_set_1(o->sc, o->v[1].p, val)); +} + +static s7_pointer opt_starlet_set_i(opt_info *o) +{ + return(starlet_set_1(o->sc, o->v[1].p, o->v[2].p)); +} + +static bool opt_cell_set(s7_scheme *sc, s7_pointer expr) /* len == 3 here (p_syntax_ok) */ +{ + opt_info *opc = alloc_opt_info(sc); + const s7_pointer target = cadr(expr); + const s7_pointer value = caddr(expr); + if (OPT_PRINT) fprintf(stderr, " opt_cell_set[%d]: %s, target: %s\n", __LINE__, display(expr), display(target)); + 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, expr); + + settee = s7_slot(sc, target); + if ((is_slot(settee)) && + (!is_immutable_slot(settee)) && + (!is_syntax(slot_value(settee)))) + { + const int32_t start_pc = sc->pc; + const 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(expr))) && + (cell_optimize(sc, cddr(expr)))) + { + 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, expr); + } + return_false(sc, expr); + } + + if (stype == sc->is_integer_symbol) + { + if (is_symbol(value)) + { + const 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, expr); + }} + else + { + opc->v[5].o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cddr(expr))) + return(check_type_uncertainty(sc, target, expr, 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, expr); + } + return_false(sc, expr); + } + 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, expr); + } + if (is_symbol(caddr(expr))) + { + const 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, expr); + }} + else + { + if ((is_pair(value)) && + (float_optimize(sc, cddr(expr)))) + { + 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, expr); + } + return(check_type_uncertainty(sc, target, expr, opc, start_pc)); + } + return_false(sc, expr); + } + + atype = opt_arg_type(sc, cddr(expr)); + if ((is_some_number(sc, atype)) && (!is_some_number(sc, stype))) + return_false(sc, expr); + 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, expr); + if (cell_optimize(sc, cddr(expr))) + { + 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, expr); + }} + return_false(sc, expr); + } + 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_type; + const s7_pointer index = cadr(target); + const s7_pointer s_slot = s7_slot(sc, car(target)); + if (!is_slot(s_slot)) return_false(sc, expr); + obj = slot_value(s_slot); + opc->v[1].p = s_slot; + + if (!is_mutable_sequence(obj)) /* includes *s7* because *s7* itself is immutable? */ + { + /* a ridiculous experiment... */ + if ((car(target) == sc->port_string_symbol) && + (is_eq_initial_c_function_data(car(target), obj)) && + (is_normal_symbol(index)) && + (opt_arg_type(sc, cddr(expr)) == sc->is_string_symbol)) + { + const s7_pointer port_type = opt_arg_type(sc, cdr(target)); + if ((port_type == sc->is_input_port_symbol) || (port_type == sc->is_output_port_symbol)) + { + const int32_t start_pc = sc->pc; + opc->v[2].p = s7_t_slot(sc, index); + if ((is_slot(opc->v[2].p)) && (is_string_port(slot_value(opc->v[2].p))) && (cell_optimize(sc, cddr(expr)))) + { + opc->v[3].o1 = sc->opts[start_pc]; + opc->v[4].fp = sc->opts[start_pc]->v[0].fp; + opc->v[0].fp = (port_type == sc->is_input_port_symbol) ? opt_set_input_port_string_p_p_f : opt_set_output_port_string_p_p_f; + return_true(sc, expr); + }}} + if (obj == sc->starlet) /* *s7* is open (for let_set_fallback?) */ + { + if ((is_symbol_and_keyword(index)) || (is_quoted_symbol(index))) + { + s7_pointer sym = (is_quoted_symbol(index)) ? cadr(index) : keyword_symbol(index); + if (starlet_symbol_id(sym) != sl_no_field) + { + opc->v[1].p = sym; + if (is_t_integer(caddr(expr))) + { + opc->v[0].fp = opt_starlet_set_i; + opc->v[2].p = caddr(expr); + return_true(sc, expr); + } + opc->v[2].o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + opc->v[0].fp = opt_starlet_set; + opc->v[3].fp = opc->v[2].o1->v[0].fp; + return_true(sc, expr); + }}}} + return_false(sc, expr); + } + + 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, expr); + val_type = opt_arg_type(sc, cddr(expr)); + if (val_type != sc->is_char_symbol) + return_false(sc, expr); + 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, expr); + if (is_null(cddr(target))) + { + if (vector_rank(obj) != 1) return_false(sc, expr); + 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, expr); + 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(expr), 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(expr))) + { + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; + return_true(sc, expr); + } + return_false(sc, expr); + + case T_COMPLEX_VECTOR: + if (index_type != sc->is_integer_symbol) return_false(sc, expr); + if (is_null(cddr(target))) + { + if (vector_rank(obj) != 1) return_false(sc, expr); + opc->v[3].p_pip_f = complex_vector_set_p_pip_unchecked; + } + else return_false(sc, expr); + break; + + 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(expr))) + { + opc->v[O_WRAP].fi = opc->v[0].fi; + opc->v[0].fp = i_to_p; + return_true(sc, expr); + } + return_false(sc, expr); + + 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 */ + const s7_d_7pid_t func = s7_d_7pid_function(c_object_setf(sc, obj)); + if (func) + { + const s7_pointer slot = opt_integer_symbol(sc, index); + opc->v[4].d_7pid_f = func; + opc->v[10].o1 = sc->opts[sc->pc]; + if (slot) + { + if (float_optimize(sc, cddr(expr))) + { + 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, expr); + }} + else + if (int_optimize(sc, cdr(target))) + { + opc->v[8].o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + 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, expr); + }}}} + return_false(sc, expr); + + case T_PAIR: + if (index_type != sc->is_integer_symbol) return_false(sc, expr); /* (let ((tf13 '(()))) (define (f) (do ((i 0 (+ i 1))) ((= i 1)) (set! (tf13 letrec*) 0))) (f)) */ + if (is_pair(cddr(target))) return_false(sc, expr); + 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_pair(cdr(value))) && (is_pair(cadr(value))) && (is_pair(cddr(value))) && + (is_t_integer(caddr(value))) && (is_null(cdddr(value))) && (is_symbol(index)) && + (car(target) == (caadr(value))) && (is_pair(cdadr(value))) && (is_null(cddadr(value))) && (index == cadadr(value))) + { + const 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, expr); + }}} + break; + + case T_HASH_TABLE: + if (is_pair(cddr(target))) return_false(sc, expr); + 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, expr); + if ((is_symbol_and_keyword(index)) || + ((is_quoted_symbol(index)))) + 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, expr); + } + if (is_symbol(index)) + { + int32_t start = sc->pc; + const 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_complex_vector(obj)) && + (loop_end(opc->v[2].p) <= vector_length(obj))) + { + opc->v[3].p_pip_f = complex_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)) + { + const 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, expr); + } + 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, expr); + 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, expr); + }} + 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, expr); + } + 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, expr); + opc->v[0].fp = opt_p_ppp_ssc; + return_true(sc, expr); + } + if (cell_optimize(sc, cddr(expr))) + { + 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, expr); + opc->v[0].fp = opt_p_pip_ssf; + return_true(sc, expr); + } + 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, expr); + opc->v[0].fp = opt_p_ppp_ssf; + return_true(sc, expr); + }}} + 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(expr))) + { + 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, expr); + }} + return_false(sc, expr); + } + if (is_quoted_symbol(index)) + { + if (is_symbol(value)) + { + const s7_pointer val_slot = opt_simple_symbol(sc, value); + if (val_slot) + { + opc->v[2].p = cadr(index); + 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, cadr(index), val_slot); + return_true(sc, expr); + }} + if ((!is_pair(value)) && (is_let(obj)) && (opc->v[3].p_ppp_f == let_set_1) && + (use_ppc_slot_set(sc, opc, obj, cadr(index), value))) + return_true(sc, expr); + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(target))) + { + opt_info *o2; + if (is_symbol(value)) + { + const 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, expr); + }} + o2 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + opc->v[0].fp = opt_p_ppp_sff; + if ((is_let(obj)) && (is_quoted_symbol(index)) && (opc->v[3].p_ppp_f == let_set_1) && /* (set! (L3 'x) (+ (L3 'x) 1)) */ + (use_ppf_slot_set(sc, opc, obj, cadr(index)))) + { + opc->v[4].o1 = o2; + opc->v[5].fp = opc->v[4].o1->v[0].fp; + return_true(sc, expr); + } + 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, expr); + }}}} + return_false(sc, expr); +} + + +/* -------- 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 expr, int32_t len) +{ + opt_info *opc; + s7_pointer p = cdr(expr); + if (len > (NUM_VUNIONS - 3)) return_false(sc, expr); + opc = alloc_opt_info(sc); + for (int32_t i = 2; is_pair(p); i++, p = cdr(p)) + { + opt_info *start = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, expr); + 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, expr); +} + +/* -------- 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 expr, int32_t len) +{ + s7_pointer p; + int32_t k; + opt_info *opc; + if (len > (NUM_VUNIONS - 6)) + return_false(sc, expr); + opc = alloc_opt_info(sc); + opc->v[3].o1 = sc->opts[sc->pc]; + if (!bool_optimize(sc, cdr(expr))) + return_false(sc, expr); + for (k = 5, p = cddr(expr); is_pair(p); k++, p = cdr(p)) + { + opt_info *start = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, expr); + 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(expr) == 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, expr); +} + +/* -------- 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)) + return(cond_value(o1)); + } + 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; + return(o1->v[0].fp(o1)); +} + +static bool opt_cell_cond(s7_scheme *sc, s7_pointer expr) +{ + /* 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); + const int32_t start_pc = sc->pc; + for (s7_pointer clauses = cdr(expr); is_pair(clauses); clauses = cdr(clauses), branches++) + { + opt_info *opc; + s7_pointer clause = car(clauses), 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, expr); + } + if (branches == 2) + { + if ((max_blen == 1) && + ((car(last_clause) == sc->T) || + ((car(last_clause) == sc->else_symbol) && (is_global(sc->else_symbol))))) + { + 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, expr); + }} + top->v[2].i = branches; + top->v[0].fp = opt_cond; + return_true(sc, expr); +} + +/* -------- 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 expr, int32_t len) +{ + opt_info *opc = alloc_opt_info(sc); + if (len == 3) + { + opc->v[0].fp = ((car(expr) == sc->or_symbol) ? opt_or_pp : opt_and_pp); + opc->v[10].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdr(expr))) + return_false(sc, expr); + opc->v[11].fp = opc->v[10].o1->v[0].fp; + opc->v[8].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cddr(expr))) + return_false(sc, expr); + opc->v[9].fp = opc->v[8].o1->v[0].fp; + return_true(sc, expr); + } + if ((len > 1) && (len < (NUM_VUNIONS - 4))) + { + s7_pointer p = cdr(expr); + opc->v[1].i = (len - 1); + opc->v[0].fp = ((car(expr) == 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, expr); + } + return_true(sc, expr); + } + return_false(sc, expr); +} + +/* -------- 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 expr, 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(expr))) && /* (not arg) */ + (caadr(expr) == sc->not_symbol)) + { + if (bool_optimize(sc, cdadr(expr))) + { + opt_info *top = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + 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, expr); + } + 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, expr); + } + 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, expr); + } + 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, expr); + } + 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, expr); + } + opc->v[4].o1 = bop; + opc->v[5].fb = bop->v[0].fb; + opc->v[0].fp = opt_if_nbp; + return_true(sc, expr); + }}} + else + if (bool_optimize(sc, cdr(expr))) + { + opt_info *top = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + 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, expr); + } + 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, expr); + } + 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, expr); + }} + return_false(sc, expr); + } + if (len == 4) + { + if (bool_optimize(sc, cdr(expr))) + { + opt_info *top = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + 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(expr))) + { + 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, expr); + }}}} + return_false(sc, expr); +} + +/* -------- 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; + const int32_t lim = o->v[1].i; + s7_scheme *sc = o->sc; + const s7_pointer selector = o1->v[0].fp(o1); + + if (is_simple(selector)) + { + for (int32_t ctr = CASE_O1; ctr < lim; ctr++) + { + s7_pointer p; + o1 = o->v[ctr].o1; + for (p = o1->v[CASE_CLAUSE_KEYS].p; is_pair(p); p = cdr(p)) + if (selector == car(p)) + return(case_value(o1)); + if (p == sc->else_symbol) + return(case_value(o1)); + }} + else + for (int32_t ctr = CASE_O1; ctr < lim; ctr++) + { + s7_pointer p; + o1 = o->v[ctr].o1; + for (p = o1->v[CASE_CLAUSE_KEYS].p; is_pair(p); p = cdr(p)) + if (s7_is_eqv(sc, selector, car(p))) + return(case_value(o1)); + if (p == sc->else_symbol) + return(case_value(o1)); + } + return(sc->unspecified); +} + +static bool opt_cell_case(s7_scheme *sc, s7_pointer expr) +{ + /* 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(expr))) /* selector */ + return_false(sc, expr); + for (ctr = CASE_O1, p = cddr(expr); (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, expr); +} + +/* -------- 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 expr, int32_t len) +{ + s7_pointer vars; + if (len <= 2) return_false(sc, expr); + vars = cadr(expr); + 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)))) + { + s7_pointer p; + opt_info *opc = alloc_opt_info(sc); + opc->v[1].p = s7_t_slot(sc, caaadr(expr)); + if (!is_slot(opc->v[1].p)) return_false(sc, expr); + opc->v[4].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdaadr(expr))) + return_false(sc, expr); + + p = cddr(expr); + for (int32_t i = LET_TEMP_O1; is_pair(p); i++, p = cdr(p)) + { + opc->v[i].o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, expr); + } + opc->v[2].i = len - 2; + opc->v[0].fp = opt_let_temporarily; + return_true(sc, expr); + } + return_false(sc, expr); +} + +/* -------- 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 slot = let_slots(lt); tis_slot(slot); slot = next_slot(slot)) + slot_set_pending_value(slot, eof_object); /* gc needs a legit value here */ +} + +static void let_clear_has_pending_value(s7_scheme *sc, s7_pointer lt) +{ + for (s7_pointer slot = let_slots(lt); tis_slot(slot); slot = next_slot(slot)) + slot_clear_has_pending_value(slot); +} + +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); + const opt_info *body = do_any_body(o); + const opt_info *inits = do_any_inits(o); + const opt_info *steps = do_any_steps(o); + const opt_info *results = do_any_results(o); + const int32_t len = do_body_length(o); /* len=6 tlist, 6|7 tbig, 0 tvect */ + s7_pointer slot, result; + s7_scheme *sc = o->sc; + opt_info *os[NUM_VUNIONS]; + opt_info_fp fp[NUM_VUNIONS]; + const s7_pointer old_e = sc->curlet; + gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + /* init */ + slot = let_slots(sc->curlet); + for (int32_t k = 0; tis_slot(slot); k++, slot = next_slot(slot)) + { + o1 = inits->v[k].o1; + slot_set_value(slot, o1->v[0].fp(o1)); + } + let_set_has_pending_value(sc->curlet); + for (int32_t 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 (int32_t i = 0; i < len; i++) fp[i](os[i]); + /* step (let not let*) */ + slot = let_slots(sc->curlet); + for (int32_t k = 0; tis_slot(slot); k++, slot = next_slot(slot)) + if (has_stepper(slot)) + { + o1 = steps->v[k].o1; + slot_simply_set_pending_value(slot, o1->v[0].fp(o1)); + } + for (s7_pointer slot1 = let_slots(sc->curlet); tis_slot(slot1); slot1 = next_slot(slot1)) + if (has_stepper(slot1)) + slot_set_value(slot1, slot_pending_value(slot1)); + } + /* result */ + result = sc->T; + for (int32_t 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 return-expr */ + opt_info *o1; + opt_info *ostart = do_any_test(o); + opt_info *ostep = o->v[9].o1; + const opt_info *inits = do_any_inits(o); + opt_info *body = do_any_body(o); + s7_pointer slot, result, stepper = NULL; + s7_scheme *sc = o->sc; + const s7_pointer old_e = sc->curlet; + gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + slot = let_slots(sc->curlet); + for (int32_t k = 0; tis_slot(slot); k++, slot = next_slot(slot)) + { + o1 = inits->v[k].o1; + slot_set_value(slot, o1->v[0].fp(o1)); + if (has_stepper(slot)) stepper = slot; + } + 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 return-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; + const opt_info *inits = do_any_inits(o); + opt_info *body = do_any_body(o); + s7_pointer (*fp)(opt_info *o) = body->v[0].fp; + s7_pointer slot, result, stepper = NULL, si; + s7_scheme *sc = o->sc; + s7_int end, incr; + const s7_pointer old_e = sc->curlet; + gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + slot = let_slots(sc->curlet); + for (int32_t k = 0; tis_slot(slot); k++, slot = next_slot(slot)) + { + o1 = inits->v[k].o1; + slot_set_value(slot, o1->v[0].fp(o1)); + if (has_stepper(slot)) stepper = slot; + } + 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); + const int32_t len = do_body_length(o); + s7_scheme *sc = o->sc; + bool (*fb)(opt_info *o) = ostart->v[0].fb; + const 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 + { + const 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 slot = let_slots(do_curlet(o)); + s7_scheme *sc = o->sc; + const s7_pointer old_e = sc->curlet; + gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + slot_set_value(slot, o1->v[0].fp(o1)); + if ((o->v[8].i == 1) && + (is_t_integer(slot_value(slot)))) + { + 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(slot))); + slot_set_value(slot, 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); + clear_mutable_integer(step_val); + 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(slot, 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); + const int32_t len = do_body_length(o); + s7_pointer slot = let_slots(do_curlet(o)); + s7_scheme *sc = o->sc; + const s7_pointer old_e = sc->curlet; + gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + slot_set_value(slot, 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(slot, 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(slot, 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(slot, 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); + const 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 slot = let_dox1_value(do_curlet(o)); + s7_scheme *sc = o->sc; + const s7_pointer old_e = sc->curlet; + gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + set_integer(slot, 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(slot) < end) + { + e1->v[0].fp(e1); + e2->v[0].fp(e2); + integer(slot)++; + }} + else + while (integer(slot) < end) /* tbig sg */ + { + for (int32_t i = 0; i < len; i++) + { + o1 = body->v[i].o1; + o1->v[0].fp(o1); + } + integer(slot)++; + } + 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 slot = let_slots(do_curlet(o)); + s7_scheme *sc = o->sc; + s7_pointer (*fp)(opt_info *o); + const s7_pointer old_e = sc->curlet; + gc_protect_via_stack(sc, old_e); + set_curlet(sc, do_curlet(o)); + slot_set_value(slot, 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(slot))) + { + if (o1->v[3].fb(o1->v[2].o1)) + o1->v[5].fp(o1->v[4].o1); + slot_set_value(slot, cdr(slot_value(slot))); + } + else + while (!is_null(slot_value(slot))) + { + fp(o1); + slot_set_value(slot, cdr(slot_value(slot))); + } + 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; + const 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) /* is this code dead? does it belong above? */ + { /* 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)) + { + s7_pointer (*setter)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) = o1->v[5].p_pip_f; + s7_pointer (*getter)(s7_scheme *sc, s7_pointer p1, s7_int i1) = o1->v[6].p_pi_f; + if (((setter == float_vector_set_p_pip_direct) && (getter == float_vector_ref_p_pi_direct)) || + ((setter == complex_vector_set_p_pip_direct) && (getter == complex_vector_ref_p_pi_direct)) || + ((setter == int_vector_set_p_pip_direct) && (getter == int_vector_ref_p_pi_direct)) || + ((setter == string_set_p_pip_direct) && (getter == string_ref_p_pi_direct)) || + ((setter == byte_vector_set_p_pip_direct) && (getter == 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)))); + clear_mutable_integer(ival); + } + 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; + const 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) +{ + while (true) + { + s7_pointer p = car(tree); + if (is_setter(p)) return(true); + if ((is_unquoted_pair(p)) && + (tree_has_setters(sc, p))) + return(true); + tree = cdr(tree); + if (!is_pair(tree)) break; + } + return(is_setter(tree)); +} + +#define DO_PRINT 0 +#if DO_PRINT +#define do_is_safe(Sc, Body, Stepper, Var_list, Step_vars, Has_set) do_is_safe_1(Sc, Body, Stepper, Var_list, Step_vars, Has_set, __func__, __LINE__) +static bool do_is_safe_1(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, s7_pointer step_vars, bool *has_set, const char *funcly, int linely); +#else +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); +#endif + +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_t_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_t_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 expr, int32_t len) +{ + opt_info *opc; + s7_pointer endp, let = NULL; + const s7_pointer old_e = sc->curlet; + const s7_pointer vars = (is_pair(cdr(expr))) ? cadr(expr) : sc->nil; + const int32_t body_len = len - 3; + int32_t var_len, body_index, step_len, return_exprs, 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, expr); + if (body_len > SIZE_O) return_false(sc, expr); + if (!s7_is_proper_list(sc, vars)) return_false(sc, expr); + var_len = proper_list_length(vars); + step_len = var_len; + endp = caddr(expr); + if (!is_pair(endp)) return_false(sc, expr); + if ((is_pair(vars)) && (is_pair(car(vars))) && (is_pair(cdar(vars))) && (is_pair(cddar(vars)))) /* expr is the do form */ + { + const s7_pointer old_code = sc->code; + sc->code = expr; /* the do form here could be totally messed up: e.g. (do () '2) in s7test */ + if (!do_passes_safety_check(sc, cdddr(expr), caar(vars), vars, &has_set)) + { + sc->code = old_code; + if (DO_PRINT) fprintf(stderr, "%s[%d]: return(false) because do_passes_safety_check is unhappy: %s\n", __func__, __LINE__, display(expr)); + return_false(sc, expr); + } + sc->code = old_code; + } + + 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)))...") + */ + begin_small_symbol_set(sc); + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const s7_pointer var = car(p); + if ((is_pair(var)) && + (is_symbol(car(var))) && + (is_pair(cdr(var)))) + { + const s7_pointer sym = car(var); + if (is_constant_symbol(sc, sym)) + {end_small_symbol_set(sc); return_false(sc, expr);} + if (symbol_is_in_small_symbol_set(sc, sym)) + syntax_error_nr(sc, "duplicate identifier in do: ~A", 30, var); + add_symbol_to_small_symbol_set(sc, sym); + add_slot(sc, let, sym, sc->undefined); + } + else {end_small_symbol_set(sc); return_false(sc, expr);} + } + end_small_symbol_set(sc); + if (tis_slot(let_slots(let))) + let_set_slots(let, reverse_slots(let_slots(let))); + + /* inits */ + { + s7_pointer slot = let_slots(let); + init_pc = sc->pc; + { + s7_pointer p = vars; + for (int32_t k = 0; (is_pair(p)) && (k < SIZE_O); k++, p = cdr(p), slot = next_slot(slot)) + { + const 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, expr); + if (is_pair(cddr(var))) + { + set_has_stepper(slot); + if (!is_null(cdddr(var))) + return_false(sc, expr); + } + else + { + step_len--; + if (!is_null(cddr(var))) + return_false(sc, expr); + } + /* 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_t_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 (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const 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, expr); + }}}} + + /* end test */ + end_test_pc = sc->pc; + if (!bool_optimize_nw(sc, endp)) + { + unstack_gc_protect(sc); /* not pop_stack! */ + set_curlet(sc, old_e); + return_false(sc, expr); + } + { + const s7_pointer stop = car(endp); + 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))))) + { + const 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; + if (car(stop) == sc->gt_symbol) lim++; + for (s7_pointer p = vars, 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)) + { + const 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) + { + const s7_pointer slot2 = opt_integer_symbol(sc, cadr(stop)); + if ((slot2) && + (stop_is_safe(sc, cadr(stop), cddr(expr)))) /* b_fft in tfft.scm */ + { + set_has_loop_end(slot2); + set_loop_end(slot2, lim); + }}}}} + + /* body */ + body_index = sc->pc; + { + s7_pointer p = cdddr(expr); + for (int32_t i = 3, k = 0; i < len; k++, i++, p = cdr(p)) + { + opt_info *start = sc->opts[sc->pc]; + body_o[k] = start; + sc->do_body_p = car(p); /* a horrible kludge, but I have run out of type bits for pairs */ + if (i < 5) opc->v[i + 7].o1 = start; + if (!cell_optimize(sc, p)) + break; + oo_idp_nr_fixup(start); + } + sc->do_body_p = NULL; + if (!is_null(p)) + { + unstack_gc_protect(sc); + set_curlet(sc, old_e); + return_false(sc, expr); + }} + + /* 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; + { + s7_pointer p = vars; + for (int32_t k = 0; is_pair(p); k++, p = cdr(p)) + { + const 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, expr); + }} + + /* result */ + if (!is_list(cdr(endp))) + { + unstack_gc_protect(sc); + set_curlet(sc, old_e); + return_false(sc, expr); + } + { + s7_pointer p = cdr(endp); + for (return_exprs = 0; (is_pair(p)) && (return_exprs < SIZE_O); p = cdr(p), return_exprs++) + { + return_o[return_exprs] = 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, expr); + }} + + do_curlet_unchecked(opc) = T_Let(let); + do_body_length(opc) = len - 3; + do_result_length(opc) = return_exprs; + opc->v[9].o1 = sc->opts[step_pc]; + set_curlet(sc, old_e); + + if ((var_len == 0) && (return_exprs == 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 (int32_t k = 0; k < body_len; k++) + body->v[k].o1 = body_o[k]; + do_no_vars_body(opc) = body; + } + return_true(sc, expr); + } + opc->v[8].i = 0; + if (body_len == 1) + { + const s7_pointer expr3 = cadddr(expr); + if ((is_pair(expr3)) && + ((is_c_function(car(expr3))) || + (is_safe_setter(car(expr3))) || + ((car(expr3) == sc->set_symbol) && + (cadr(expr3) != caar(vars))) || /* caadr: (stepper init ...) */ + ((car(expr3) == sc->vector_set_symbol) && + (is_null(cddddr(expr3))) && + (is_code_constant(sc, cadddr(expr3)))))) + opc->v[8].i = 1; /* checked in opt_do_1 */ + } + if ((var_len != 1) || (step_len != 1) || (return_exprs != 0)) + { + opt_info *inits; + opc->v[0].fp = ((step_len == 1) && (body_len == 1) && (return_exprs == 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 (int32_t 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 (int32_t k = 0; k < body_len; k++) + body->v[k].o1 = body_o[k]; + do_any_body(opc) = body; + + result = alloc_opt_info(sc); + for (int32_t k = 0; k < return_exprs; k++) + result->v[k].o1 = return_o[k]; + do_any_results(opc) = result; + + step = alloc_opt_info(sc); + for (int32_t 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, expr); + } + + opc->v[0].fp = (body_len == 1) ? opt_do_1 : opt_do_n; + { + const s7_pointer ind = caar(vars); + const s7_pointer ind_step = caddar(vars); + const s7_pointer end = caaddr(expr); + if (body_len == 1) /* opt_do_1 */ + do_any_body(opc) = sc->opts[body_index]; + else + { + opt_info *body = alloc_opt_info(sc); + for (int32_t 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(expr), ind, vars, &has_set))) + { + const s7_pointer slot = let_slots(let); + let_set_dox_slot1(let, slot); + let_set_dox_slot2_unchecked(let, (is_symbol(caddr(end))) ? s7_t_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 */ + { + const 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(expr), ind, vars, &has_set))) + opc->v[0].fp = opt_do_list_simple; + }} + return_true(sc, expr); +} + +static bool p_syntax_ok(s7_scheme *sc, s7_pointer expr, int32_t len) +{ + const s7_pointer func = lookup_global(sc, car(expr)); + opcode_t op; + if (OPT_PRINT) fprintf(stderr, " p_syntax_ok[%d]: %s\n", __LINE__, display(expr)); + if (!is_syntax(func)) {clear_syntactic(expr); return_false(sc, expr);} + /* 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(expr))) && (is_null(cddr(expr)))) return(opt_cell_quote(sc, expr)); break; + case OP_SET: if (len == 3) return(opt_cell_set(sc, expr)); break; + case OP_BEGIN: if (len > 1) return(opt_cell_begin(sc, expr, len)); break; + case OP_WHEN: + case OP_UNLESS: if (len > 2) return(opt_cell_when(sc, expr, len)); break; + case OP_COND: if (len > 1) return(opt_cell_cond(sc, expr)); break; + case OP_CASE: if (len > 2) return(opt_cell_case(sc, expr)); break; + case OP_AND: + case OP_OR: return(opt_cell_and(sc, expr, len)); + case OP_IF: return(opt_cell_if(sc, expr, len)); + case OP_DO: return(opt_cell_do(sc, expr, len)); + case OP_LET_TEMPORARILY: return(opt_cell_let_temporarily(sc, expr, 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, expr); +} + + +/* -------------------------------------------------------------------------------- */ +static bool float_optimize_1(s7_scheme *sc, s7_pointer form) +{ + const s7_pointer expr = car(form); + s7_pointer head, s_func, s_slot = NULL; + s7_int len; + if (OPT_PRINT) fprintf(stderr, " float_optimize[%d] %s\n", __LINE__, display(form)); + if (WITH_GMP) return(false); + + if (!is_pair(expr)) /* wrap constants/symbols */ + return_bool(sc, opt_float_not_pair(sc, expr), expr); + head = car(expr); + len = s7_list_length(sc, expr); + if (is_symbol(head)) + { + if ((is_syntactic_symbol(head)) || + (is_syntactic_pair(expr))) + return_bool(sc, d_syntax_ok(sc, expr, len), expr); + + s_slot = s7_slot(sc, head); + if (!is_slot(s_slot)) return_false(sc, expr); + s_func = slot_value(s_slot); + } + else + if (is_c_function(head)) + s_func = head; + else return_false(sc, expr); + + if (is_c_function(s_func)) + { + opt_info *opc = alloc_opt_info(sc); + switch (len) + { + case 1: + return_bool(sc, d_ok(sc, opc, s_func), expr); + case 2: /* (f v) or (f d): (env e) or (abs x) */ + return_bool(sc, ((d_d_ok(sc, opc, s_func, expr)) || + (d_v_ok(sc, opc, s_func, expr)) || + (d_p_ok(sc, opc, s_func, expr))), expr); + case 3: + return_bool(sc, ((d_dd_ok(sc, opc, s_func, expr)) || + (d_id_ok(sc, opc, s_func, expr)) || + (d_vd_ok(sc, opc, s_func, expr)) || + (d_pd_ok(sc, opc, s_func, expr)) || + (d_ip_ok(sc, opc, s_func, expr)) || + (d_7pi_ok(sc, opc, s_func, expr))), expr); + case 4: + return_bool(sc, ((d_ddd_ok(sc, opc, s_func, expr)) || + (d_7pid_ok(sc, opc, s_func, expr)) || + (d_vid_ok(sc, opc, s_func, expr)) || + (d_vdd_ok(sc, opc, s_func, expr)) || + (d_7pii_ok(sc, opc, s_func, expr))), expr); + case 5: + return_bool(sc, ((d_dddd_ok(sc, opc, s_func, expr)) || + (d_7piid_ok(sc, opc, s_func, expr)) || + (d_7piii_ok(sc, opc, s_func, expr))), expr); + case 6: + if (d_7piiid_ok(sc, opc, s_func, expr)) + return_true(sc, expr); + /* fall through */ + + default: + return_bool(sc, d_add_any_ok(sc, opc, expr), expr); + }} + else + { + if ((is_macro(s_func)) && (!no_cell_opt(form))) + { + const 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) || (is_eq_initial_c_function_data(sc->list_values_symbol, caar(body))))) + { + const s7_pointer result = s7_macroexpand(sc, s_func, cdar(form)); + if (result == sc->F) return_false(sc, expr); + return(float_optimize(sc, set_plist_1(sc, result))); + }} + if (!s_slot) return_false(sc, expr); + return_bool(sc, d_implicit_ok(sc, s_slot, expr, len), expr); + } + return_false(sc, expr); +} + +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 form) +{ + const s7_pointer expr = car(form); + s7_pointer head, s_func, s_slot = NULL; + s7_int len; + + if (OPT_PRINT) fprintf(stderr, " int_optimize %s\n", display(form)); + if (WITH_GMP) return(false); + + if (!is_pair(expr)) /* wrap constants/symbols */ + return_bool(sc, opt_int_not_pair(sc, expr), expr); + head = car(expr); + len = s7_list_length(sc, expr); + if (is_symbol(head)) + { + if ((is_syntactic_symbol(head)) || + (is_syntactic_pair(expr))) + return_bool(sc, i_syntax_ok(sc, expr, len), expr); + s_slot = s7_slot(sc, head); + if (!is_slot(s_slot)) return_false(sc, expr); + s_func = slot_value(s_slot); + } + else + if (is_c_function(head)) + s_func = head; + else return_false(sc, expr); + + if (is_c_function(s_func)) + { + opt_info *opc = alloc_opt_info(sc); + switch (len) + { + case 2: + return_bool(sc, i_idp_ok(sc, opc, s_func, expr), expr); + case 3: + return_bool(sc, ((i_ii_ok(sc, opc, s_func, expr)) || + (i_7pi_ok(sc, opc, s_func, expr))), expr); + case 4: + return_bool(sc, ((i_iii_ok(sc, opc, s_func, expr)) || + (i_7pii_ok(sc, opc, s_func, expr))), expr); + case 5: + { + int32_t pstart = sc->pc; + if (i_7piii_ok(sc, opc, s_func, expr)) + return_true(sc, expr); + sc->pc = pstart; + } + /* fall through */ + default: + return_bool(sc, (((head == sc->add_symbol) || + (head == sc->multiply_symbol)) && + (i_add_any_ok(sc, opc, expr))), expr); + }} + else + { +#if 0 + /* if (is_closure(s_func)) and body is one expr and safe, we could pull out the body, substitute pars for args, int_optimize that */ + /* check for simple args and no definers/binders first (can't int-optimize them anyway) */ + if ((is_closure(s_func)) && (is_safe_closure(s_func)) && (!no_cell_opt(form))) + { + const s7_pointer body = closure_body(s_func); + if ((is_null(cdr(body))) && (is_pair(car(body)))) /* this hits every test in s7test! */ + { + if (caar(body) != sc->let_symbol) + fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(body), display(form)); + /* see s7test (f3 123) -- expansion can lead to funclet confusion -- same in macros? but this would not be int_optimizable */ + /* timing tests don't get many useful hits */ + }} +#endif + if ((is_macro(s_func)) && (!no_cell_opt(form))) + { + const 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) || (is_eq_initial_c_function_data(sc->list_values_symbol, caar(body))))) + { + s7_pointer result = s7_macroexpand(sc, s_func, cdar(form)); /* cdar(form) = arglist */ + if (result == sc->F) return_false(sc, expr); + return(int_optimize(sc, set_plist_1(sc, result))); + }} + if (!s_slot) return_false(sc, expr); + return_bool(sc, i_implicit_ok(sc, s_slot, expr, len), expr); + } + return_false(sc, expr); +} + +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, const s7_pointer s_func, const s7_pointer expr, int32_t pstart, s7_pointer form) +{ + const s7_pointer sig = c_function_signature(s_func); + if (is_symbol(cadr(expr))) + { + 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, expr)) + return_true(sc, expr); + + if ((car(sig) == sc->is_float_symbol) || + (car(sig) == sc->is_real_symbol)) + { + const s7_d_7pi_t func = s7_d_7pi_function(s_func); + if (func) + { + sc->pc = pstart - 1; + if (float_optimize(sc, form)) + { + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; + return_true(sc, expr); + }}} + sc->pc = pstart; + }} + { + const s7_i_ii_t ifunc = s7_i_ii_function(s_func); + sc->pc = pstart - 1; + if ((ifunc) && + (int_optimize(sc, form))) + { + 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, expr); + }} + sc->pc = pstart; + return_bool(sc, ((p_ii_ok(sc, opc, s_func, expr, pstart)) || + (p_dd_ok(sc, opc, s_func, expr, pstart)) || + (p_pp_ok(sc, opc, s_func, expr, pstart)) || + (p_call_pp_ok(sc, opc, s_func, expr, pstart))), expr); +} + +static bool p_3x_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + const s7_pointer sig = c_function_signature(s_func); + if (is_symbol(cadr(expr))) + { + if ((is_pair(sig)) && (is_pair(cdr(sig))) && (is_pair(cddr(sig))) && + (caddr(sig) == sc->is_integer_symbol)) + { + 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, expr))) + { + /* 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, expr); + } + + 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, expr))) + { + opc->v[O_WRAP].fi = opc->v[0].fi; + opc->v[0].fp = i_to_p; + return_true(sc, expr); + } + sc->pc = pstart; + + if (p_pii_ok(sc, opc, s_func, expr)) + return_true(sc, expr); + if (p_pip_ok(sc, opc, s_func, expr)) + return_true(sc, expr); + }} + return_bool(sc, ((p_ppi_ok(sc, opc, s_func, expr)) || + (p_ppp_ok(sc, opc, s_func, expr)) || + (p_call_ppp_ok(sc, opc, s_func, expr))), expr); +} + +static bool p_4x_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + const s7_pointer head = car(expr); + const s7_int len = s7_list_length(sc, expr); + + if ((is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) && + (d_7piid_ok(sc, opc, s_func, expr))) + { + 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, expr); + } + if ((is_target_or_its_alias(head, s_func, sc->float_vector_ref_symbol)) && + (d_7piii_ok(sc, opc, s_func, expr))) + { + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; + return_true(sc, expr); + } + if (i_7piii_ok(sc, opc, s_func, expr)) + { + opc->v[O_WRAP].fi = opc->v[0].fi; + opc->v[0].fp = i_to_p; + return_true(sc, expr); + } + if (is_target_or_its_alias(head, s_func, sc->int_vector_set_symbol)) + return_false(sc, expr); + if (p_piip_ok(sc, opc, s_func, expr)) + return_true(sc, expr); + sc->pc = pstart; + if (s_func == global_value(sc->vector_ref_symbol)) + { + s7_pointer obj; + if (!is_symbol(cadr(expr))) return_false(sc, expr); + obj = lookup_unexamined(sc, cadr(expr)); /* was lookup_from (to avoid the unbound variable check) */ + if ((!obj) || (!is_any_vector(obj)) || (vector_rank(obj) != 3)) + return_false(sc, expr); + } + return_bool(sc, p_call_any_ok(sc, opc, s_func, expr, len), expr); +} + +static bool p_5x_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr, int32_t pstart) +{ + const s7_pointer head = car(expr); + if ((is_target_or_its_alias(head, s_func, sc->float_vector_set_symbol)) && + (d_7piiid_ok(sc, opc, s_func, expr))) + { + opc->v[O_WRAP].fd = opc->v[0].fd; + opc->v[0].fp = d_to_p; + return_true(sc, expr); + } + return_false(sc, expr); +} + +#if OPT_PRINT +static bool cell_optimize_1(s7_scheme *sc, s7_pointer form, int line) +#else +static bool cell_optimize_1(s7_scheme *sc, s7_pointer form) +#endif +{ + const s7_pointer expr = car(form); + s7_pointer head, s_func, s_slot = NULL; + s7_int len; +#if OPT_PRINT /* needed due to line arg */ + fprintf(stderr, " cell_optimize[%d] %s\n", line, display(form)); +#endif + if (WITH_GMP) return(false); + if (!is_pair(expr)) /* wrap constants/symbols */ + return(opt_cell_not_pair(sc, expr)); + + head = car(expr); + len = s7_list_length(sc, expr); + if (is_symbol(head)) + { + if ((is_syntactic_symbol(head)) || + (is_syntactic_pair(expr))) /* this can be wrong! */ + return_bool(sc, p_syntax_ok(sc, expr, len), expr); + + s_slot = s7_slot(sc, head); + if (!is_slot(s_slot)) return_false(sc, expr); + 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 */ + if ((head == sc->quote_function) && + ((is_pair(cdr(expr))) && (is_null(cddr(expr))))) + return_bool(sc, opt_cell_quote(sc, expr), expr); + + /* 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 */ + /* but this is not safe if there's a let-set! or (set! (let...)...) in the body and this let-ref is the car */ + if (is_pair(head)) + { + s7_pointer let, 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 + if (((car(head) == sc->unlet_symbol) || (car(head) == sc->rootlet_symbol)) && (is_pair(cdr(expr)))) /* ((unlet) :abs) */ + { + sym = cadr(expr); + if ((is_symbol_and_keyword(sym)) || (is_quoted_symbol(sym))) + return_bool(sc, opt_unlet_rootlet_ref(sc, alloc_opt_info(sc), head, (is_pair(sym)) ? cadr(sym) : keyword_symbol(sym), expr), expr); + return_false(sc, expr); + } + else return_false(sc, expr); + if ((is_symbol(let)) && ((is_symbol_and_keyword(sym)) || (is_quoted_symbol(sym)))) + { + const s7_pointer slot = s7_t_slot(sc, let); + if (!is_slot(slot)) return_false(sc, expr); + let = slot_value(slot); + if ((!is_let(let)) || (has_let_ref_fallback(let))) return_false(sc, expr); + sym = (is_pair(sym)) ? cadr(sym) : keyword_symbol(sym); + s_func = let_ref_p_pp(sc, let, sym); + } + else return_false(sc, expr); + } + else return_false(sc, expr); + } + if (is_c_function(s_func)) + { + opt_info *opc = alloc_opt_info(sc); + switch (len) + { + case 1: return_bool(sc, p_ok(sc, opc, s_func, expr), expr); + case 2: return_bool(sc, ((p_i_ok(sc, opc, s_func, expr, sc->pc)) || + (p_d_ok(sc, opc, s_func, expr, sc->pc)) || + (p_p_ok(sc, opc, s_func, expr))), expr); + case 3: return_bool(sc, p_2x_ok(sc, opc, s_func, expr, sc->pc, form), expr); + case 4: return_bool(sc, p_3x_ok(sc, opc, s_func, expr, sc->pc), expr); + case 5: return_bool(sc, p_4x_ok(sc, opc, s_func, expr, sc->pc), expr); + case 6: if (p_5x_ok(sc, opc, s_func, expr, sc->pc)) return_true(sc, expr); + /* fall through */ + default: return_bool(sc, p_call_any_ok(sc, opc, s_func, expr, len), expr); /* >3D vector-set etc */ + }} + else + { + if (is_closure(s_func)) + { + opt_info *opc = alloc_opt_info(sc); + if (p_fx_any_ok(sc, opc, form)) + return_true(sc, expr); + } + if (is_macro(s_func)) + return_false(sc, expr); /* macroexpand+cell_optimize here restarts the optimize process (this refers to int|float_optimize macro expansion) */ + if (!s_slot) return_false(sc, expr); + return_bool(sc, p_implicit_ok(sc, s_slot, expr, len), expr); + } + return_false(sc, expr); +} + +#if OPT_PRINT +static bool cell_optimize_with_line(s7_scheme *sc, s7_pointer expr, int line) {return((cell_optimize_1(sc, expr, line)) && (sc->pc < OPTS_SIZE));} +#else +static bool cell_optimize(s7_scheme *sc, s7_pointer expr) {return((cell_optimize_1(sc, expr)) && (sc->pc < OPTS_SIZE));} +#endif + +static bool bool_optimize_nw_1(s7_scheme *sc, s7_pointer form) +{ + const s7_pointer expr = car(form); + s7_pointer head, s_func = NULL; + s7_int len; + if (!is_pair(expr)) /* wrap constants/symbols */ + return_bool(sc, opt_bool_not_pair(sc, expr), expr); + + head = car(expr); + len = s7_list_length(sc, expr); + if (is_symbol(head)) + { + if ((is_syntactic_symbol(head)) || + (is_syntactic_pair(expr))) + { + if (head == sc->and_symbol) + return_bool(sc, opt_b_and(sc, expr, len), expr); + if (head == sc->or_symbol) + return_bool(sc, opt_b_or(sc, expr, len), expr); + return_false(sc, expr); + } + s_func = lookup_unexamined(sc, head); + } + else + if (is_c_function(head)) + s_func = head; + else return_false(sc, expr); + + if (!s_func) return_false(sc, expr); + if (is_c_function(s_func)) + { + if ((is_symbol(head)) && (!is_global(head))) /* (float-vector? (block)) -- both safe c_funcs, but this is a method invocation */ + return_false(sc, expr); + switch (len) + { + case 2: + return_bool(sc, b_idp_ok(sc, s_func, expr, opt_arg_type(sc, cdr(expr))), expr); + case 3: + { + s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + s7_pointer sig1 = opt_arg_type(sc, cdr(expr)); + s7_pointer sig2 = opt_arg_type(sc, cddr(expr)); + 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, expr, arg1, arg2))) + return_true(sc, expr); + sc->pc = cur_index; + if (b_pi_ok(sc, opc, s_func, expr, arg2)) + return_true(sc, expr); + sc->pc = cur_index; + } + + if ((sig1 == sc->is_float_symbol) && + (sig2 == sc->is_float_symbol) && + (b_dd_ok(sc, opc, s_func, expr, arg1, arg2))) + return_true(sc, expr); + 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, expr, arg1, arg2, bpf)); + }} + break; + default: break; + }} + return_false(sc, expr); +} + +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) +{ + const 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, expr); + if (wrapper->v[O_WRAP].fp) /* (when (+ i 1) ...) */ + return_false(sc, expr); + 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(sc, expr); + 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-optimize in scheme */ +{ + s7_pfunc func; + s7_pointer code = car(args), result = sc->undefined; + gc_protect_via_stack(sc, code); + func = s7_optimize(sc, code); + if (func) result = func(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) +{ + if (OPT_PRINT) fprintf(stderr, " s7_cell_optimize %s\n", display(expr)); + 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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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, opt1_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(opt1_con(cdr(expr)))); + return(g_leq_xi(sc, set_plist_2(sc, x, opt1_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(opt1_con(cdr(expr)))); + return(g_leq_xi(sc, set_plist_2(sc, x, opt1_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 new_counter; + new_cell(sc, new_counter, T_COUNTER); + counter_set_result(new_counter, sc->nil); + if ((S7_DEBUGGING) && (!is_iterator(iter)) && (!is_pair(iter))) fprintf(stderr, "%s[%d]: %s?\n", __func__, __LINE__, display(iter)); + counter_set_list(new_counter, iter); /* iterator -- here it's always either an iterator or a pair */ + counter_set_capture(new_counter, 0); /* will be capture_let_counter */ + counter_set_let(new_counter, sc->rootlet); /* will be the saved let */ + counter_set_slots(new_counter, slot_end); /* local let slots before body is evalled */ + stack_set_has_counters(sc->stack); + return(new_counter); +} + +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_mappable(iter)) wrong_type_error_nr(sc, caller, i, iter, a_sequence_string); + sc->z = (is_iterator(iter)) ? cons(sc, iter, sc->z) : cons(sc, s7_make_iterator(sc, iter), sc->z); + } + if ((S7_DEBUGGING) && (sc->temp3 != args)) fprintf(stderr, "%s[%d]: temp3: %s\n", __func__, __LINE__, display(sc->temp3)); + sc->temp3 = sc->unused; + p = proper_list_reverse_in_place(sc, sc->z); + sc->z = sc->unused; + return(p); +} + +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 clo, s7_pointer seq) /* one sequence arg */ +{ + const s7_pointer body = closure_body(clo); + 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; + const s7_pointer old_e = sc->curlet, pars = closure_pars(clo); + const s7_pointer val = seq_init(sc, seq); + s7_pointer slot, result = NULL; + + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(clo), (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, clo, seq); + sc->map_call_ctr++; + if (is_pair(seq)) + { + for (s7_pointer vals = seq, slow_vals = vals; is_pair(vals); ) + { + slot_set_value(slot, car(vals)); + func(sc); + vals = cdr(vals); + if (is_pair(vals)) + { + slot_set_value(slot, car(vals)); + func(sc); + vals = cdr(vals); + slow_vals = cdr(slow_vals); + if (vals == slow_vals) break; + }} + result = sc->unspecified; + } + else + if (is_float_vector(seq)) + { + const s7_double *vals = float_vector_floats(seq); + const s7_int len = vector_length(seq); + if ((len > MUTLIM) && + (!tree_has_setters(sc, body))) + { + const s7_pointer sv = wrap_real(sc, 0.0); /* maybe make_mutable_real(sc, 0.0)? */ + 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 (s7_int 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 (s7_int 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 (s7_int i = 0; i < len; i++) {set_real(sv, vals[i]); fp(o);} + } + else for (s7_int i = 0; i < len; i++) {set_real(sv, vals[i]); func(sc);} + } + else for (s7_int i = 0; i < len; i++) {slot_set_value(slot, make_real(sc, vals[i])); func(sc);} + result = sc->unspecified; + } + else + if (is_int_vector(seq)) + { + const s7_int *vals = int_vector_ints(seq); + const s7_int len = vector_length(seq); + if ((len > MUTLIM) && + (!tree_has_setters(sc, body))) + { + const s7_pointer sv = wrap_mutable_integer(sc, 0); /* make_mutable_integer? -- can we assume c_funcs won't use wrappers? */ + 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 (s7_int i = 0; i < len; i++) {set_integer(sv, vals[i]); fi(o);} + } + else for (s7_int i = 0; i < len; i++) {set_integer(sv, vals[i]); func(sc);} + } + else for (s7_int i = 0; i < len; i++) {slot_set_value(slot, make_integer(sc, vals[i])); func(sc);} + result = sc->unspecified; + } + else + if (is_t_vector(seq)) + { + const s7_pointer *vals = vector_elements(seq); + const s7_int 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 (s7_int i = 0; i < len; i++) {slot_set_value(slot, vals[i]); fp(o);}} + else for (s7_int i = 0; i < len; i++) {slot_set_value(slot, vals[i]); func(sc);} + result = sc->unspecified; + } + else + if (is_string(seq)) + { + const char *str = string_value(seq); + const 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);} + result = sc->unspecified; + } + else + if (is_byte_vector(seq)) + { + const uint8_t *vals = (const uint8_t *)byte_vector_bytes(seq); + const s7_int 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 (s7_int i = 0; i < len; i++) {slot_set_value(slot, small_int(vals[i])); fi(o);}} + else for (s7_int i = 0; i < len; i++) {slot_set_value(slot, small_int(vals[i])); func(sc);} + result = sc->unspecified; + } + if (result) + return(clear_for_each(sc)); + if (!is_mappable(seq)) + wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string); + if (!is_iterator(seq)) + { + seq = s7_make_iterator(sc, seq); + set_stack_protected2(sc, seq, OP_MAP_UNWIND); + } + /* 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 # */ + else /* not func -- unneeded "else" but otherwise confusing code */ + { + set_no_cell_opt(body); + set_curlet(sc, old_e); + }} + + /* using op+1 to hop costs more here (and in map) than it saves */ + if ((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, clo); + return(sc->unspecified); + } + + if (!is_mappable(seq)) + wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq, a_sequence_string); + begin_temp(sc->v, (is_iterator(seq)) ? seq : s7_make_iterator(sc, seq)); + push_stack(sc, OP_FOR_EACH_1, inline_make_counter(sc, sc->v), clo); + end_temp(sc->v); + 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_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); /* see map_closure_2 below -- gc_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_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + }}} +} + +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_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + }} +} + +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_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + }} +} + +static s7_pointer g_for_each_closure_2(s7_scheme *sc, s7_pointer clo, s7_pointer seq1, s7_pointer seq2) +{ + s7_pointer body = closure_body(clo); + if (!no_cell_opt(body)) + { + s7_pfunc func = NULL; + const s7_pointer olde = sc->curlet, pars = closure_pars(clo); + s7_pointer slot1, slot2; + const s7_pointer val1 = seq_init(sc, seq1); + const s7_pointer val2 = seq_init(sc, seq2); + set_curlet(sc, make_let_with_two_slots(sc, closure_let(clo), + (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 result = NULL; + push_stack_no_let(sc, OP_MAP_UNWIND, clo, 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); + result = 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); + result = sc->unspecified; + } + else + if ((is_string(seq1)) && (is_string(seq2))) + { + map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, true); + result = sc->unspecified; + } + sc->map_call_ctr--; + unstack_with(sc, OP_MAP_UNWIND); + set_curlet(sc, olde); + if (result) return(result); + set_no_cell_opt(body); + } + else /* not func */ + { + set_no_cell_opt(body); + set_curlet(sc, olde); + }} + + if (!is_mappable(seq1)) wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq1, a_sequence_string); /* is_mappable includes is_iterator */ + if (!is_mappable(seq2)) wrong_type_error_nr(sc, sc->for_each_symbol, 3, seq2, a_sequence_string); + + sc->z = (is_iterator(seq1)) ? seq1 : s7_make_iterator(sc, seq1); + sc->z = (is_iterator(seq2)) ? list_2(sc, sc->z, seq2) : list_2(sc, sc->z, s7_make_iterator(sc, seq2)); + push_stack(sc, OP_FOR_EACH, cons_unchecked(sc, sc->z, make_list(sc, 2, sc->nil)), clo); + 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) + + const s7_pointer clo = car(args); + const s7_int len = proper_list_length(cdr(args)); + bool arity_ok = false; + + /* try the normal case first */ + sc->value = clo; + if (is_closure(clo)) /* not lambda* that might get confused about arg names */ + { + if ((len == 1) && + (is_pair(closure_pars(clo))) && + (is_null(cdr(closure_pars(clo))))) + arity_ok = true; + } + else + if (is_c_object(clo)) /* see note in g_map; s7_is_aritable can clobber sc->args=plist=args */ + args = copy_proper_list(sc, args); + else + if (!is_applicable(clo)) + return(method_or_bust(sc, clo, sc->for_each_symbol, args, something_applicable_string, 1)); + + if ((!arity_ok) && + (!s7_is_aritable(sc, clo, 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), clo, 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(clo)) + { + s7_function func; + s7_pointer iters; + + const s7_p_p_t fp = s7_p_p_function(clo); /* s7_b_p_t would work if we could cast it, and others (return value is discarded) */ + 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))) + { + const s7_pointer vec = cadr(args); + const s7_int vlen = vector_length(vec); + if (is_float_vector(vec)) + { + s7_pointer rl = wrap_real(sc, 0.0); /* maybe make_mutable_real(sc, 0.0) -- not sure this is safe */ + begin_temp(sc->x, rl); + for (s7_int i = 0; i < vlen; i++) + { + set_real(rl, float_vector(vec, i)); + fp(sc, rl); + } + end_temp(sc->x); + } + else + if (is_int_vector(vec)) + { + s7_pointer iv = wrap_mutable_integer(sc, 0); /* make_mutable_integer? */ + begin_temp(sc->x, iv); + for (s7_int i = 0; i < vlen; i++) + { + set_integer(iv, int_vector(vec, i)); + fp(sc, iv); + } + end_temp(sc->x); + } + else + for (s7_int i = 0; i < vlen; i++) + fp(sc, vector_getter(vec)(sc, vec, i)); /* LOOP_4 here gains almost nothing */ + return(sc->unspecified); + } + if (is_string(cadr(args))) + { + const s7_pointer str = cadr(args); + const char *s = string_value(str); + const 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(clo); /* 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) + { + const s7_pointer iter = caar(sc->z), fargs = cdr(sc->z); + sc->z = sc->unused; + while (true) + { + set_car(fargs, s7_iterate(sc, iter)); + if (iterator_is_at_end(iter)) + { + /* 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); + sc->z = sc->unused; + return(sc->unspecified); + } + func(sc, fargs); + }} + iters = sc->z; + sc->z = sc->unused; + while (true) + { + for (s7_pointer iterp = car(iters), fargs = cdr(iters); is_pair(iterp); iterp = cdr(iterp), fargs = cdr(fargs)) + { + set_car(fargs, s7_iterate(sc, car(iterp))); + if (iterator_is_at_end(car(iterp))) + { + 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(clo)) && + (closure_arity_to_int(sc, clo) == 1) && + (!is_constant_symbol(sc, car(closure_pars(clo))))) || + ((is_closure_star(clo)) && + (closure_star_arity_to_int(sc, clo) == 1) && + (!is_constant_symbol(sc, (is_pair(car(closure_pars(clo)))) ? caar(closure_pars(clo)) : car(closure_pars(clo))))))) + return(g_for_each_closure(sc, clo, 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)), clo); + sc->z = sc->unused; + return(sc->unspecified); +} + +static bool op_for_each(s7_scheme *sc) +{ + const s7_pointer iterators = car(sc->args); + const s7_pointer saved_args = cdr(sc->args); + sc->temp9 = saved_args; + for (s7_pointer args = saved_args, iters = iterators; is_pair(args); args = cdr(args), iters = cdr(iters)) + { + set_car(args, s7_iterate(sc, car(iters))); + if (iterator_is_at_end(car(iters))) + { + sc->value = sc->unspecified; + sc->temp9 = sc->unused; + return(true); + }} + push_stack_direct(sc, OP_FOR_EACH); + sc->args = (needs_copied_args(sc->code)) ? copy_proper_list(sc, saved_args) : saved_args; + sc->temp9 = sc->unused; + 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 a let 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 */ +{ + const s7_pointer counter = sc->args; + s7_pointer code; + const s7_pointer p = counter_list(counter); + const s7_pointer arg = s7_iterate(sc, p); + if (iterator_is_at_end(p)) + { + sc->value = sc->unspecified; + return(true); + } + code = T_Clo(sc->code); + if (counter_capture(counter) != sc->capture_let_counter) + { + const s7_pointer sym = car(closure_pars(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 */ +{ + const s7_pointer c = sc->args; + const 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; + 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; + 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) + { + const s7_pointer pars = closure_pars(sc->code); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(sc->code), (is_pair(car(pars))) ? caar(pars) : car(pars), 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 clo, s7_pointer seq) /* one sequence argument */ +{ + const s7_pointer body = closure_body(clo); + sc->value = clo; + + if (!no_cell_opt(body)) + { + s7_pfunc func = NULL; + const s7_pointer old_e = sc->curlet, pars = closure_pars(clo); + s7_pointer slot; + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(clo), (is_pair(car(pars))) ? caar(pars) : car(pars), seq_init(sc, seq))); + slot = let_slots(sc->curlet); + + if (sc->map_call_ctr == 0) + { + if (is_null(cdr(body))) + func = s7_cell_optimize(sc, body, false); + else + if (is_null(cddr(body))) + { + set_ulist_1(sc, sc->begin_symbol, body); + func = s7_cell_optimize(sc, set_clist_1(sc, sc->u1_1), false); /* list_1 8-Apr-21 */ + }} + if (func) + { + s7_pointer val, result = NULL; /* val could be localized */ + push_stack_no_let(sc, OP_MAP_UNWIND, clo, seq); + sc->map_call_ctr++; + if (is_pair(seq)) + { + set_map_unwind_list(sc, sc->nil); + for (s7_pointer fast = seq, slow = seq; is_pair(fast); fast = cdr(fast), slow = cdr(slow)) + { + slot_set_value(slot, car(fast)); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + if (is_pair(cdr(fast))) + { + fast = cdr(fast); + if (fast == slow) break; + slot_set_value(slot, car(fast)); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + }} + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if (is_float_vector(seq)) + { + const s7_double *vals = float_vector_floats(seq); + const s7_int len = vector_length(seq); + set_map_unwind_list(sc, sc->nil); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, make_real(sc, vals[i])); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + } + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if (is_int_vector(seq)) + { + const s7_int *vals = int_vector_ints(seq); + const s7_int len = vector_length(seq); + set_map_unwind_list(sc, sc->nil); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, make_integer(sc, vals[i])); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + } + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if (is_complex_vector(seq)) + { + const s7_complex *vals = complex_vector_complexes(seq); + const s7_int len = vector_length(seq); + set_map_unwind_list(sc, sc->nil); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, c_complex_to_s7(sc, vals[i])); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + } + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if (is_t_vector(seq)) + { + const s7_pointer *vals = vector_elements(seq); + const s7_int len = vector_length(seq); + set_map_unwind_list(sc, sc->nil); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, vals[i]); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + } + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if (is_string(seq)) + { + const s7_int len = string_length(seq); + const char *str = string_value(seq); + set_map_unwind_list(sc, sc->nil); + for (s7_int i = 0; i < len; i++) + { + slot_set_value(slot, chars[(uint8_t)(str[i])]); + val = func(sc); + if (val != sc->no_value) set_map_unwind_list(sc, cons(sc, val, map_unwind_list(sc))); + } + result = proper_list_reverse_in_place(sc, map_unwind_list(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 (result) return(result); + } + set_no_cell_opt(body); + set_curlet(sc, old_e); + } + if ((is_null(cdr(body))) && + (is_pair(seq))) + { + /* here we need to check for a setter, and if any, push with dynamic-unwind, then restore later. + * (let ((hk (make-hook 'x))) (define (func) (map hk (list 0 6))) (set! (setter hk) (lambda (y) y)) (func)) + */ + if (is_any_procedure(closure_setter_or_map_list(clo))) /* should we restore #f? */ + push_stack(sc, OP_DYNAMIC_UNWIND, list_3(sc, clo, closure_setter(clo), sc->T), sc->restore_setter); + /* the passed list will be car(args) when dynamic_unwind calls (f . args) */ + /* all this complexity because there is no place to store the "slow" version of seq for circular list checks */ + closure_set_map_list(clo, seq); + push_stack(sc, OP_MAP_2, inline_make_counter(sc, seq), clo); + return(sc->unspecified); + } + if (!is_mappable(seq)) wrong_type_error_nr(sc, sc->map_symbol, 2, seq, a_sequence_string); + begin_temp(sc->v, (is_iterator(seq)) ? seq : s7_make_iterator(sc, seq)); + push_stack(sc, OP_MAP_1, inline_make_counter(sc, sc->v), clo); + end_temp(sc->v); + return(sc->nil); +} + +static s7_pointer g_map_closure_2(s7_scheme *sc, s7_pointer clo, s7_pointer seq1, s7_pointer seq2) /* two sequences */ +{ + const s7_pointer body = closure_body(clo); + if (!no_cell_opt(body)) + { + s7_pfunc func = NULL; + const s7_pointer old_e = sc->curlet, pars = closure_pars(clo); + s7_pointer slot1, slot2; + const s7_pointer val1 = seq_init(sc, seq1); + const s7_pointer val2 = seq_init(sc, seq2); + set_curlet(sc, make_let_with_two_slots(sc, closure_let(clo), + (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 result = NULL; + push_stack_no_let(sc, OP_MAP_UNWIND, clo, seq1); + sc->map_call_ctr++; + if ((is_pair(seq1)) && (is_pair(seq2))) + { + set_map_unwind_list(sc, sc->nil); + map_or_for_each_closure_pair_2(sc, func, seq1, seq2, slot1, slot2, false); /* builds result on gc_protected3 */ + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if ((is_any_vector(seq1)) && (is_any_vector(seq2))) + { + set_map_unwind_list(sc, sc->nil); + map_or_for_each_closure_vector_2(sc, func, seq1, seq2, slot1, slot2, false); + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + else + if ((is_string(seq1)) && (is_string(seq2))) + { + set_map_unwind_list(sc, sc->nil); + map_or_for_each_closure_string_2(sc, func, seq1, seq2, slot1, slot2, false); + result = proper_list_reverse_in_place(sc, map_unwind_list(sc)); + } + sc->map_call_ctr--; + unstack_with(sc, OP_MAP_UNWIND); + set_curlet(sc, old_e); + if (result) return(result); + set_no_cell_opt(body); + } + else /* not func */ + { + set_no_cell_opt(body); + set_curlet(sc, old_e); + }} + + if (!is_mappable(seq1)) wrong_type_error_nr(sc, sc->for_each_symbol, 2, seq1, a_sequence_string); + if (!is_mappable(seq2)) wrong_type_error_nr(sc, sc->for_each_symbol, 3, seq2, a_sequence_string); + + sc->z = (is_iterator(seq1)) ? seq1 : s7_make_iterator(sc, seq1); + sc->z = (is_iterator(seq2)) ? list_2(sc, sc->z, seq2) : list_2(sc, sc->z, s7_make_iterator(sc, seq2)); + + push_stack(sc, OP_MAP, inline_make_counter(sc, sc->z), clo); + 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 ...)) e.g. f=append -> use safe_list for map output list here? also for ( (map...)) + * but less savings if mapped func would have used the same safe_list? + */ + s7_pointer p; + const s7_pointer clo = car(args); + s7_int len; + bool got_nil = false; + + for (len = 0, p = cdr(args); is_pair(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(clo)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(clo, len)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_4(sc, wrap_string(sc, "map ~A: ~D argument~P?", 22), clo, 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(clo)) + { + s7_pointer val, val1, old_args, iter_list; + const s7_function func = c_function_call(clo); + if (is_pair(cadr(args))) + { + if (len == 1) + { + const s7_p_p_t fp = s7_p_p_function(clo); + 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 fval = fp(sc, car(fast)); + if (fval != sc->no_value) set_car(val, cons(sc, fval, car(val))); + if (is_pair(cdr(fast))) + { + fast = cdr(fast); + if (fast == slow) break; + fval = fp(sc, car(fast)); + if (fval != sc->no_value) set_car(val, cons(sc, fval, car(val))); + }} + unstack_gc_protect(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }} + if ((len == 2) && (is_pair(caddr(args)))) + { + const s7_p_pp_t fp = s7_p_pp_function(clo); + 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 fval = fp(sc, car(fast1), car(fast2)); + if (fval != sc->no_value) set_car(val, cons(sc, fval, 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; + fval = fp(sc, car(fast1), car(fast2)); + if (fval != sc->no_value) set_car(val, cons(sc, fval, car(val))); + }} + unstack_gc_protect(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }}} + if ((is_string(cadr(args))) && (len == 1)) + { + const s7_p_p_t fp = s7_p_p_function(clo); + 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 fval = fp(sc, chars[(uint8_t)(s[i])]); + if (fval != sc->no_value) set_car(val, cons(sc, fval, car(val))); + } + unstack_gc_protect(sc); + return(proper_list_reverse_in_place(sc, car(val))); + }} + if ((is_any_vector(cadr(args))) && (len == 1)) + { + const s7_p_p_t fp = s7_p_p_function(clo); + if (fp) + { + const 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 fval = fp(sc, vector_getter(vec)(sc, vec, i)); + if (fval != sc->no_value) set_car(val, cons(sc, fval, 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 fval; + for (s7_pointer iters = iter_list, y = cdr(val1); is_pair(iters); iters = cdr(iters), y = cdr(y)) + { + set_car(y, s7_iterate(sc, car(iters))); + if (iterator_is_at_end(car(iters))) + { + unstack_gc_protect(sc); + sc->args = T_Pos(old_args); /* can be # or # */ + return(proper_list_reverse_in_place(sc, car(val))); + }} + fval = 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 (fval != sc->no_value) + set_car(val, cons(sc, fval, car(val))); + }} + + else /* not safe procedure */ + if ((clo == 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: + { + const int32_t fargs = (is_closure(clo)) ? closure_arity_to_int(sc, clo) : closure_star_arity_to_int(sc, clo); + if ((len == 1) && + (fargs == 1) && + (!is_constant_symbol(sc, (is_pair(car(closure_pars(clo)))) ? caar(closure_pars(clo)) : car(closure_pars(clo))))) + { + if (got_nil) return(sc->nil); + if (is_closure_star(clo)) + return(g_map_closure(sc, clo, cadr(args))); + + begin_temp(sc->v, (!is_iterator(cadr(args))) ? s7_make_iterator(sc, cadr(args)) : cadr(args)); + push_stack(sc, OP_MAP_1, inline_make_counter(sc, sc->v), clo); + end_temp(sc->v); + symbol_increment_ctr(car(closure_pars(clo))); + return(sc->nil); + } + if (((fargs >= 0) && (fargs < len)) || + ((is_closure(clo)) && (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), clo, 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->temp9 = args; + + default: + if (!is_applicable(clo)) + return(method_or_bust(sc, clo, sc->map_symbol, args, something_applicable_string, 1)); + if ((!is_pair(clo)) && + (!s7_is_aritable(sc, clo, 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), clo)); + 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), clo); + sc->z = sc->unused; + return(sc->nil); +} + +static bool op_map(s7_scheme *sc) +{ + const s7_pointer counter = sc->args; + sc->z = sc->nil; /* can't use preset args list here (as in for-each): (map list '(a b c)) */ + for (s7_pointer iters = counter_list(counter); is_pair(iters); iters = cdr(iters)) + { + s7_pointer val = s7_iterate(sc, car(iters)); + if (iterator_is_at_end(car(iters))) + { + sc->value = proper_list_reverse_in_place(sc, counter_result(counter)); + sc->z = sc->unused; + return(true); + } + sc->z = cons(sc, val, sc->z); + } + push_stack_direct(sc, OP_MAP_GATHER); + sc->args = proper_list_reverse_in_place(sc, sc->z); + sc->z = 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) +{ + const s7_pointer args = sc->args, code = sc->code; + const s7_pointer p = counter_list(args); + const s7_pointer val = s7_iterate(sc, p); + if (iterator_is_at_end(p)) + { + sc->value = proper_list_reverse_in_place(sc, counter_result(args)); + return(true); + } + push_stack_direct(sc, OP_MAP_GATHER_1); + if (counter_capture(args) != sc->capture_let_counter) + { + const s7_pointer pars = closure_pars(code); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(code), (is_pair(car(pars))) ? caar(pars) : car(pars), val)); + 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), val)); + } + sc->code = T_Pair(closure_body(code)); + return(false); +} + +static bool op_map_2(s7_scheme *sc) /* possibly inline lg */ +{ + s7_pointer cur_args; + const s7_pointer c = sc->args, code = sc->code; + { + const s7_pointer p = counter_list(c); + if (!is_pair(p)) + { + sc->value = proper_list_reverse_in_place(sc, counter_result(c)); + return(true); + } + cur_args = 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)); + 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) + { + s7_pointer pars = closure_pars(code); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(code), (is_pair(car(pars))) ? caar(pars) : car(pars), cur_args)); + 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), cur_args)); + } + 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 + if ((is_mutable(sc->value)) && (is_t_integer(sc->value))) + counter_set_result(sc->args, cons(sc, make_integer(sc, integer(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 Inline s7_pointer apply_mv(s7_scheme *sc, bool use_safe) +{ + 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_safe_list_in_use(sc->args); + return(sc->value); +} + +static Inline s7_pointer apply_mv_no_safe_list(s7_scheme *sc) +{ + 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_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; + const 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 p1 = sc->value; is_pair(p1); p1 = cdr(p1), lst = cdr(lst)) set_car(lst, car(p1)); + } + return(apply_mv(sc, use_safe)); +} + +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; + const s7_pointer val = sc->args; + const 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 p1 = sc->value; is_pair(p1); p1 = cdr(p1), lst = cdr(lst)) set_car(lst, car(p1)); + set_car(lst, val); + } + return(apply_mv(sc, use_safe)); +} + +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; + const 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 p1 = sc->value; is_pair(p1); p1 = cdr(p1), lst = cdr(lst)) set_car(lst, car(p1)); + set_car(lst, val); + } + return(apply_mv(sc, use_safe)); +} + +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 plist_3 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; + const 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 p1 = sc->value; is_pair(p1); p1 = cdr(p1), lst = cdr(lst)) set_car(lst, car(p1)); + set_car(lst, fx_call(sc, cddr(sc->code))); + } + return(apply_mv(sc, use_safe)); +} + +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 */ + return(apply_mv_no_safe_list(sc)); +} + +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 */ + return(apply_mv_no_safe_list(sc)); +} + +static s7_pointer op_safe_c_3p_mv(s7_scheme *sc, s7_pointer args) +{ + begin_temp(sc->x, copy_proper_list(sc, args)); + sc->x = cons(sc, sc->unused, sc->x); + return_with_end_temp(sc->x); +} + +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); + return(apply_mv_no_safe_list(sc)); +} + +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 + */ + return(apply_mv_no_safe_list(sc)); +} + +static s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args) +{ + s7_pointer arglist; + 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 + */ + begin_temp(sc->y, args); + for (arglist = args; is_pair(cdr(arglist)); arglist = cdr(arglist)) + set_stack_top_args(sc, cons(sc, car(arglist), stack_top_args(sc))); + end_temp(sc->y); + return(car(arglist)); + + 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 (arglist = args; is_pair(cddr(arglist)); arglist = cdr(arglist)) + set_stack_top_args(sc, cons(sc, car(arglist), stack_top_args(sc))); + set_stack_top_code(sc, car(arglist)); + return(cadr(arglist)); + + /* handle implicit set! */ + case OP_EVAL_SET1_NO_MV: /* (set! (fnc) ) where evaluation of returned multiple values */ + case OP_EVAL_SET2_NO_MV: /* (set! (fnc ) ), = 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 = args is mv */ + set_stack_top_op(sc, OP_EVAL_SET2_MV); + return(args); /* ?? */ + case OP_EVAL_SET3: /* here = 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); + /* to s7test some rainy day: (fop24 (fop24-1 x) (fop24-1 (+ x 1)) x x (values x x)) (128 128) */ + 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=# */ + 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)) */ + /* this code assumes op_let_1 is building a list of values stored in sc->args etc */ + 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 (arglist = args; is_pair(cdr(arglist)); arglist = cdr(arglist)) + if (car(arglist) == sc->F) + return(sc->F); + return(car(arglist)); + + case OP_OR_P1: + for (arglist = args; is_pair(cdr(arglist)); arglist = cdr(arglist)) + if (car(arglist) != sc->F) + return(car(arglist)); + return(car(arglist)); + + 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: + { + const s7_pointer old_value = sc->value; + const 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: + /* (test (+ (let ((x 0)) (do ((i (values 0) (+ i 1))) (((values = i 10)) (values x 2 3)) (set! x (+ x i)))) 4) 54) ; (+ 45 2 3 4) = 54 + stack: + gc_protect, sc->code: (values x 2 3), args (the "c" in c_pc_1): '(45 2 3), sc->value: #t + safe_c_pc_1 + catch + let_one_p_old_1 + */ + 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) ...)? */ + { + const opcode_t s_op = stack_top4_op(sc); + if ((S7_DEBUGGING) && (SHOW_EVAL_OPS == 1)) /* the == 1 business is for clang++ */ + 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) + { + begin_temp(sc->y, args); + for (arglist = args; is_pair(cdr(arglist)); arglist = cdr(arglist)) + stack_top4_args(sc) = cons(sc, car(arglist), stack_top4_args(sc)); + end_temp(sc->y); + 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(arglist))); + return(car(arglist)); + } + /* 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 (arglist = args; is_pair(cdr(arglist)); arglist = cdr(arglist)) + stack_top4_args(sc) = cons(sc, car(arglist), stack_top4_args(sc)); + pop_stack_no_op(sc); /* need GC protection in loop above, so do this afterwards */ + return(car(arglist)); /* 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 gives up: %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 -------------------------------- */ +static s7_pointer g_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)); +} + +s7_pointer s7_values(s7_scheme *sc, s7_pointer args) +{ + if (is_null(args)) + return(sc->no_value); + if (is_null(cdr(args))) + return(car(args)); + if (sc->stack_start >= sc->stack_end) /* s7_values called when no s7 stack (ffitest.c for example) */ + { + set_multiple_value(args); + return(args); + } + return(splice_in_values(sc, args)); +} + +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 func, int32_t args, s7_pointer unused_expr) +{ + if (args > 1) return(sc->values_uncopied); /* splice_in_values */ + return(func); +} + +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); + begin_temp(sc->x, 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); + } + end_temp(sc->x); + 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 # (see s7test) */ + /* but (list-values ) will complain or get into an infinite recursion in copy_tree, so it should not use copy_tree */ + + s7_pointer arglist; + bool checked = false; + for (arglist = args; is_pair(arglist); arglist = cdr(arglist)) + if (is_pair(car(arglist))) + { + if (is_checked(car(arglist))) + checked = true; + } + else + if (car(arglist) == sc->no_value) /* unchecked_car|cdr unrolled here is not faster */ + break; + if (is_null(arglist)) + { + if (!checked) /* (!tree_has_definer(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)) /* immutable if unheaped sometimes! (tset.scm typed-let) */ + return(copy_proper_list(sc, args)); + return(args); + } + begin_temp(sc->temp6, 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 */ + end_temp(sc->temp6); + 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 " 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 func, 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(func); + 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 arg; /* apply-values takes 1 arg: ,@a -> (apply-values a) */ + if (is_null(args)) return(sc->no_value); + arg = car(args); + if (is_null(arg)) return(sc->no_value); + if (!s7_is_proper_list(sc, arg)) apply_list_error_nr(sc, arg); + if (is_null(cdr(arg))) return(car(arg)); /* needs to follow previous because it might not be a pair: (apply-values 2) */ + set_needs_copied_args(arg); + return(splice_in_values(sc, arg)); + /* 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 lst, slow; + for (lst = form, slow = form; is_pair(lst); lst = cdr(lst), slow = cdr(slow)) + { + if (is_pair(car(lst))) + { + if (!is_simple_code(sc, car(lst))) + return(false); + } + else + if (car(lst) == sc->unquote_symbol) + return(false); + lst = cdr(lst); + if (!is_pair(lst)) return(is_null(lst)); + if (lst == slow) return(false); + if (is_pair(car(lst))) + { + if (!is_simple_code(sc, car(lst))) + return(false); + } + else + if (car(lst) == sc->unquote_symbol) + return(false); + } + return(is_null(lst)); +} + +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_pointer orig, bq; + const s7_pointer 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; /* temp6? */ + for (s7_int 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) + { + s7_int i = 0; + for (orig = form, bq = cdr(sc->w); 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) */ + { + s7_int i = 0; + len--; + for (orig = form, bq = cdr(sc->w); 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 ": 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) + const s7_pointer a = car(args), b = cadr(args); + s7_pointer p, tp, np; + if (is_null(a)) return(b); + if (!is_pair(a)) /* (apply ``(x . 1) '(0 1 2)) so a=1, b=2 */ + wrong_type_error_nr(sc, sc->quasiquote_symbol, 1, a, a_list_string); + 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_set_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_set_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 func = global_value(sym); + c_function_chooser(func) = chooser; + return(func); +} + +static void init_choosers(s7_scheme *sc) +{ + s7_pointer func; + + /* + */ + func = set_function_chooser(sc->add_symbol, add_chooser); + sc->add_class = c_function_class(func); + sc->add_2 = make_function_with_class(sc, func, "+", g_add_2, 2, 0, false); + sc->add_3 = make_function_with_class(sc, func, "+", g_add_3, 3, 0, false); + sc->add_4 = make_function_with_class(sc, func, "+", g_add_4, 4, 0, false); + sc->add_1x = make_function_with_class(sc, func, "+", g_add_1x, 2, 0, false); + sc->add_x1 = make_function_with_class(sc, func, "+", g_add_x1, 2, 0, false); + sc->add_i_random = make_function_with_class(sc, func, "+", g_add_i_random, 2, 0, false); + + /* - */ + func = set_function_chooser(sc->subtract_symbol, subtract_chooser); + sc->subtract_class = c_function_class(func); + sc->subtract_1 = make_function_with_class(sc, func, "-", g_subtract_1, 1, 0, false); + sc->subtract_2 = make_function_with_class(sc, func, "-", g_subtract_2, 2, 0, false); + sc->subtract_3 = make_function_with_class(sc, func, "-", g_subtract_3, 3, 0, false); + sc->subtract_x1 = make_function_with_class(sc, func, "-", g_subtract_x1, 2, 0, false); + sc->subtract_2f = make_function_with_class(sc, func, "-", g_subtract_2f, 2, 0, false); + sc->subtract_f2 = make_function_with_class(sc, func, "-", g_subtract_f2, 2, 0, false); + + /* * */ + func = set_function_chooser(sc->multiply_symbol, multiply_chooser); + sc->multiply_class = c_function_class(func); + sc->multiply_2 = make_function_with_class(sc, func, "*", g_multiply_2, 2, 0, false); + sc->multiply_3 = make_function_with_class(sc, func, "*", g_multiply_3, 3, 0, false); + + /* / */ + func = set_function_chooser(sc->divide_symbol, divide_chooser); + sc->invert_1 = make_function_with_class(sc, func, "/", g_invert_1, 1, 0, false); + sc->divide_2 = make_function_with_class(sc, func, "/", g_divide_2, 2, 0, false); + sc->invert_x = make_function_with_class(sc, func, "/", g_invert_x, 2, 0, false); + sc->divide_by_2 = make_function_with_class(sc, func, "/", g_divide_by_2, 2, 0, false); + + /* = */ + func = set_function_chooser(sc->num_eq_symbol, num_eq_chooser); + sc->num_eq_class = c_function_class(func); + sc->num_eq_2 = make_function_with_class(sc, func, "=", g_num_eq_2, 2, 0, false); + sc->num_eq_xi = make_function_with_class(sc, func, "=", g_num_eq_xi, 2, 0, false); + sc->num_eq_ix = make_function_with_class(sc, func, "=", g_num_eq_ix, 2, 0, false); + + /* min */ + func = set_function_chooser(sc->min_symbol, min_chooser); + sc->min_2 = make_function_with_class(sc, func, "min", g_min_2, 2, 0, false); + sc->min_3 = make_function_with_class(sc, func, "min", g_min_3, 3, 0, false); + + /* max */ + func = set_function_chooser(sc->max_symbol, max_chooser); + sc->max_2 = make_function_with_class(sc, func, "max", g_max_2, 2, 0, false); + sc->max_3 = make_function_with_class(sc, func, "max", g_max_3, 3, 0, false); + + /* < */ + func = set_function_chooser(sc->lt_symbol, less_chooser); + sc->less_xi = make_function_with_class(sc, func, "<", g_less_xi, 2, 0, false); + sc->less_x0 = make_function_with_class(sc, func, "<", g_less_x0, 2, 0, false); + sc->less_xf = make_function_with_class(sc, func, "<", g_less_xf, 2, 0, false); + sc->less_2 = make_function_with_class(sc, func, "<", g_less_2, 2, 0, false); + + /* > */ + func = set_function_chooser(sc->gt_symbol, greater_chooser); + sc->greater_xi = make_function_with_class(sc, func, ">", g_greater_xi, 2, 0, false); + sc->greater_xf = make_function_with_class(sc, func, ">", g_greater_xf, 2, 0, false); + sc->greater_2 = make_function_with_class(sc, func, ">", g_greater_2, 2, 0, false); + + /* <= */ + func = set_function_chooser(sc->leq_symbol, leq_chooser); + sc->leq_xi = make_function_with_class(sc, func, "<=", g_leq_xi, 2, 0, false); + sc->leq_2 = make_function_with_class(sc, func, "<=", g_leq_2, 2, 0, false); + sc->leq_ixx = make_function_with_class(sc, func, "<=", g_leq_ixx, 3, 0, false); + + /* >= */ + func = set_function_chooser(sc->geq_symbol, geq_chooser); + sc->geq_xi = make_function_with_class(sc, func, ">=", g_geq_xi, 2, 0, false); + sc->geq_xf = make_function_with_class(sc, func, ">=", g_geq_xf, 2, 0, false); + sc->geq_2 = make_function_with_class(sc, func, ">=", g_geq_2, 2, 0, false); + + /* log */ + func = set_function_chooser(sc->log_symbol, log_chooser); + sc->int_log2 = make_function_with_class(sc, func, "log", g_int_log2, 2, 0, false); + + /* logior */ + func = set_function_chooser(sc->logior_symbol, logior_chooser); + sc->logior_2 = make_function_with_class(sc, func, "logior", g_logior_2, 2, 0, false); + sc->logior_ii = make_function_with_class(sc, func, "logior", g_logior_ii, 2, 0, false); + + /* logand */ + func = set_function_chooser(sc->logand_symbol, logand_chooser); + sc->logand_2 = make_function_with_class(sc, func, "logand", g_logand_2, 2, 0, false); + sc->logand_ii = make_function_with_class(sc, func, "logand", g_logand_ii, 2, 0, false); + + /* logxor */ + func = set_function_chooser(sc->logxor_symbol, logxor_chooser); + sc->logxor_2 = make_function_with_class(sc, func, "logxor", g_logxor_2, 2, 0, false); + +#if !WITH_GMP + /* ash */ + func = set_function_chooser(sc->ash_symbol, ash_chooser); + sc->ash_ii = make_function_with_class(sc, func, "ash", g_ash_ii, 2, 0, false); + sc->ash_ic = make_function_with_class(sc, func, "ash", g_ash_ic, 2, 0, false); +#endif + + /* random */ + func = set_function_chooser(sc->random_symbol, random_chooser); + sc->random_1 = make_function_with_class(sc, func, "random", g_random_1, 1, 0, false); + sc->random_i = make_function_with_class(sc, func, "random", g_random_i, 1, 0, false); + sc->random_f = make_function_with_class(sc, func, "random", g_random_f, 1, 0, false); + + /* defined? */ + func = set_function_chooser(sc->is_defined_symbol, is_defined_chooser); + sc->is_defined_in_rootlet = make_function_with_class(sc, func, "defined?", g_is_defined_in_rootlet, 2, 0, false); + sc->is_defined_in_unlet = make_function_with_class(sc, func, "defined?", g_is_defined_in_unlet, 2, 0, false); + + /* char=? */ + func = set_function_chooser(sc->char_eq_symbol, char_equal_chooser); + sc->simple_char_eq = make_function_with_class(sc, func, "char=?", g_simple_char_eq, 2, 0, false); + sc->simple_char_eq1 = make_function_with_class(sc, func, "char=?", g_simple_char_eq1, 2, 0, false); + sc->simple_char_eq2 = make_function_with_class(sc, func, "char=?", g_simple_char_eq2, 2, 0, false); + sc->char_equal_2 = make_function_with_class(sc, func, "char=?", g_char_equal_2, 2, 0, false); + + /* char>? */ + func = set_function_chooser(sc->char_gt_symbol, char_greater_chooser); + sc->char_greater_2 = make_function_with_class(sc, func, "char>?", g_char_greater_2, 2, 0, false); + + /* charchar_lt_symbol, char_less_chooser); + sc->char_less_2 = make_function_with_class(sc, func, "charread_char_symbol, read_char_chooser); + sc->read_char_1 = make_function_with_class(sc, func, "read-char", g_read_char_1, 1, 0, false); + + /* char-position */ + func = set_function_chooser(sc->char_position_symbol, char_position_chooser); + sc->char_position_csi = make_function_with_class(sc, func, "char-position", g_char_position_csi, 2, 1, false); + + /* string=? */ + func = set_function_chooser(sc->string_eq_symbol, string_equal_chooser); + sc->string_equal_2 = make_function_with_class(sc, func, "string=?", g_string_equal_2, 2, 0, false); + sc->string_equal_2c = make_function_with_class(sc, func, "string=?", g_string_equal_2c, 2, 0, false); + + /* substring */ + /* sc->substring_uncopied = s7_make_safe_function(sc, "substring", g_substring_uncopied, 1, 2, false, NULL); */ /* now exported to Scheme 28-May-24 */ + sc->substring_uncopied = global_value(sc->substring_uncopied_symbol); + s7_function_set_class(sc, sc->substring_uncopied, global_value(sc->substring_symbol)); + + /* string>? */ + func = set_function_chooser(sc->string_gt_symbol, string_greater_chooser); + sc->string_greater_2 = make_function_with_class(sc, func, "string>?", g_string_greater_2, 2, 0, false); + + /* stringstring_lt_symbol, string_less_chooser); + sc->string_less_2 = make_function_with_class(sc, func, "stringstring_symbol, string_chooser); + sc->string_c1 = make_function_with_class(sc, func, "string", g_string_c1, 1, 0, false); + + /* string-append */ + func = set_function_chooser(sc->string_append_symbol, string_append_chooser); + sc->string_append_2 = make_function_with_class(sc, func, "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 + * length et al? + */ + + /* symbol->string */ + func = 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, func); + + /* symbol->value */ + func = global_value(sc->symbol_to_value_symbol); + set_function_chooser(sc->symbol_to_value_symbol, symbol_to_value_chooser); + sc->sv_unlet_ref = make_function_with_class(sc, func, "symbol->value", g_sv_unlet_ref, 1, 1, false); + + /* display */ + func = set_function_chooser(sc->display_symbol, display_chooser); + sc->display_f = make_function_with_class(sc, func, "display", g_display_f, 2, 0, false); + sc->display_2 = make_function_with_class(sc, func, "display", g_display_2, 2, 0, false); + + /* write */ + func = set_function_chooser(sc->write_symbol, write_chooser); + sc->write_2 = make_function_with_class(sc, func, "write", g_write_2, 2, 0, false); + + /* vector */ + func = set_function_chooser(sc->vector_symbol, vector_chooser); + sc->vector_2 = make_function_with_class(sc, func, "vector", g_vector_2, 2, 0, false); + sc->vector_3 = make_function_with_class(sc, func, "vector", g_vector_3, 3, 0, false); + + /* vector-ref */ + func = set_function_chooser(sc->vector_ref_symbol, vector_ref_chooser); + sc->vector_ref_2 = make_function_with_class(sc, func, "vector-ref", g_vector_ref_2, 2, 0, false); + sc->vector_ref_3 = make_function_with_class(sc, func, "vector-ref", g_vector_ref_3, 3, 0, false); + + /* vector-set! */ + func = set_function_chooser(sc->vector_set_symbol, vector_set_chooser); + sc->vector_set_3 = make_function_with_class(sc, func, "vector-set!", g_vector_set_3, 3, 0, false); + sc->vector_set_4 = make_function_with_class(sc, func, "vector-set!", g_vector_set_4, 4, 0, false); + + /* complex-vector-ref */ + func = set_function_chooser(sc->complex_vector_ref_symbol, complex_vector_ref_chooser); + sc->cv_ref_2 = make_function_with_class(sc, func, "complex-vector-ref", g_cv_ref_2, 2, 0, false); + + /* complex-vector-set */ + func = set_function_chooser(sc->complex_vector_set_symbol, complex_vector_set_chooser); + sc->cv_set_3 = make_function_with_class(sc, func, "complex-vector-set!", g_cv_set_3, 3, 0, false); + sc->complex_wrapped = make_function_with_class(sc, func, "complex", g_complex_wrapped, 2, 0, false); /* not used currently? */ + + /* float-vector-ref */ + func = set_function_chooser(sc->float_vector_ref_symbol, float_vector_ref_chooser); + sc->fv_ref_2 = make_function_with_class(sc, func, "float-vector-ref", g_fv_ref_2, 2, 0, false); + sc->fv_ref_3 = make_function_with_class(sc, func, "float-vector-ref", g_fv_ref_3, 3, 0, false); + + /* float-vector-set */ + func = set_function_chooser(sc->float_vector_set_symbol, float_vector_set_chooser); + sc->fv_set_3 = make_function_with_class(sc, func, "float-vector-set!", g_fv_set_3, 3, 0, false); + sc->fv_set_unchecked = make_function_with_class(sc, func, "float-vector-set!", g_fv_set_unchecked, 3, 0, false); + + /* int-vector-ref */ + func = set_function_chooser(sc->int_vector_ref_symbol, int_vector_ref_chooser); + sc->iv_ref_2 = make_function_with_class(sc, func, "int-vector-ref", g_iv_ref_2, 2, 0, false); + sc->iv_ref_3 = make_function_with_class(sc, func, "int-vector-ref", g_iv_ref_3, 3, 0, false); + + /* int-vector-set */ + func = set_function_chooser(sc->int_vector_set_symbol, int_vector_set_chooser); + sc->iv_set_3 = make_function_with_class(sc, func, "int-vector-set!", g_iv_set_3, 3, 0, false); + + /* byte-vector-ref */ + func = set_function_chooser(sc->byte_vector_ref_symbol, byte_vector_ref_chooser); + sc->bv_ref_2 = make_function_with_class(sc, func, "byte-vector-ref", g_bv_ref_2, 2, 0, false); + sc->bv_ref_3 = make_function_with_class(sc, func, "byte-vector-ref", g_bv_ref_3, 3, 0, false); + + /* byte-vector-set */ + func = set_function_chooser(sc->byte_vector_set_symbol, byte_vector_set_chooser); + sc->bv_set_3 = make_function_with_class(sc, func, "byte-vector-set!", g_bv_set_3, 3, 0, false); + + /* list-set! */ + func = set_function_chooser(sc->list_set_symbol, list_set_chooser); + sc->list_set_i = make_function_with_class(sc, func, "list-set!", g_list_set_i, 3, 0, false); + + /* hash-table-ref */ + func = set_function_chooser(sc->hash_table_ref_symbol, hash_table_ref_chooser); + sc->hash_table_ref_2 = make_function_with_class(sc, func, "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 */ + func = set_function_chooser(sc->hash_table_symbol, hash_table_chooser); + sc->hash_table_2 = make_function_with_class(sc, func, "hash-table", g_hash_table_2, 2, 0, false); + + /* format */ + func = set_function_chooser(sc->format_symbol, format_chooser); + sc->format_f = make_function_with_class(sc, func, "format", g_format_f, 1, 0, true); + /* sc->format_nr = make_function_with_class(sc, func, "format", g_format_nr, 1, 0, true); */ + sc->format_no_column = make_function_with_class(sc, func, "format", g_format_no_column, 1, 0, true); + sc->format_just_control_string = make_function_with_class(sc, func, "format", g_format_just_control_string, 2, 0, false); + sc->format_as_objstr = make_function_with_class(sc, func, "format", g_format_as_objstr, 3, 0, true); + + /* list */ + func = set_function_chooser(sc->list_symbol, list_chooser); + sc->list_0 = make_function_with_class(sc, func, "list", g_list_0, 0, 0, false); + sc->list_1 = make_function_with_class(sc, func, "list", g_list_1, 1, 0, false); + sc->list_2 = make_function_with_class(sc, func, "list", g_list_2, 2, 0, false); + sc->list_3 = make_function_with_class(sc, func, "list", g_list_3, 3, 0, false); + sc->list_4 = make_function_with_class(sc, func, "list", g_list_4, 4, 0, false); + + /* append */ + func = set_function_chooser(sc->append_symbol, append_chooser); + sc->append_2 = make_function_with_class(sc, func, "append", g_append_2, 2, 0, false); + + /* list-ref */ + func = set_function_chooser(sc->list_ref_symbol, list_ref_chooser); + sc->list_ref_at_0 = make_function_with_class(sc, func, "list", g_list_ref_at_0, 2, 0, false); + sc->list_ref_at_1 = make_function_with_class(sc, func, "list", g_list_ref_at_1, 2, 0, false); + sc->list_ref_at_2 = make_function_with_class(sc, func, "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 */ + func = set_function_chooser(sc->memq_symbol, memq_chooser); /* in pure-s7, use member here */ + sc->memq_2 = make_function_with_class(sc, func, "memq", g_memq_2, 2, 0, false); + sc->memq_3 = make_function_with_class(sc, func, "memq", g_memq_3, 2, 0, false); + sc->memq_4 = make_function_with_class(sc, func, "memq", g_memq_4, 2, 0, false); + sc->memq_any = make_function_with_class(sc, func, "memq", g_memq_any, 2, 0, false); + + /* tree-set-memq */ + func = set_function_chooser(sc->tree_set_memq_symbol, tree_set_memq_chooser); + sc->tree_set_memq_syms = make_function_with_class(sc, func, "tree-set-memq", g_tree_set_memq_syms, 2, 0, false); + + /* dynamic-wind */ + func = set_function_chooser(sc->dynamic_wind_symbol, dynamic_wind_chooser); + sc->dynamic_wind_unchecked = make_unsafe_function_with_class(sc, func, "dynamic-wind", g_dynamic_wind_unchecked, 3, 0, false); + sc->dynamic_wind_body = make_unsafe_function_with_class(sc, func, "dynamic-wind", g_dynamic_wind_body, 3, 0, false); + sc->dynamic_wind_init = make_unsafe_function_with_class(sc, func, "dynamic-wind", g_dynamic_wind_init, 3, 0, false); + + /* unlet */ + sc->unlet_disabled = make_function_with_class(sc, global_value(sc->unlet_symbol), "unlet", g_unlet_disabled, 0, 0, false); + + /* outlet */ + func = set_function_chooser(sc->outlet_symbol, outlet_chooser); + sc->outlet_unlet = make_function_with_class(sc, func, "outlet", g_outlet_unlet, 1, 0, false); + + /* inlet */ + func = set_function_chooser(sc->inlet_symbol, inlet_chooser); + sc->simple_inlet = make_function_with_class(sc, func, "inlet", g_simple_inlet, 0, 0, true); + + /* sublet */ + func = set_function_chooser(sc->sublet_symbol, sublet_chooser); + sc->sublet_curlet = make_function_with_class(sc, func, "sublet", g_sublet_curlet, 3, 0, false); + + /* let-ref */ + func = set_function_chooser(sc->let_ref_symbol, let_ref_chooser); + sc->cdr_let_ref = make_function_with_class(sc, func, "let-ref", g_cdr_let_ref, 2, 0, false); + sc->starlet_ref = make_function_with_class(sc, func, "let-ref", g_starlet_ref, 2, 0, false); + sc->rootlet_ref = make_function_with_class(sc, func, "let-ref", g_rootlet_ref, 2, 0, false); + sc->curlet_ref = make_function_with_class(sc, func, "let-ref", g_curlet_ref, 2, 0, false); + sc->unlet_ref = make_function_with_class(sc, func, "let-ref", g_unlet_ref, 2, 0, false); + + /* let-set */ + func = set_function_chooser(sc->let_set_symbol, let_set_chooser); + sc->cdr_let_set = make_function_with_class(sc, func, "let-set!", g_cdr_let_set, 3, 0, false); + sc->unlet_set = make_function_with_class(sc, func, "let-set!", g_unlet_set, 3, 0, false); + sc->starlet_set = make_function_with_class(sc, func, "let-set!", g_starlet_set, 3, 0, false); + + /* values */ + func = set_function_chooser(sc->values_symbol, values_chooser); + sc->values_uncopied = make_unsafe_function_with_class(sc, func, "values", splice_in_values, 0, 0, true); + + /* list-values */ + func = set_function_chooser(sc->list_values_symbol, list_values_chooser); + sc->simple_list_values = make_function_with_class(sc, func, "list-values", g_simple_list_values, 0, 0, true); + + sc->restore_setter = s7_make_function(sc, "#", g_restore_setter, 1, 0, false, "map closure-setter restoration (for dynamic-unwind)"); +} + + +/* ---------------- *unbound-variable-hook* ---------------- */ +#if !DISABLE_AUTOLOAD +static s7_pointer loaded_library(s7_scheme *sc, const char *file) +{ + for (s7_pointer libs = global_value(sc->libraries_symbol); is_pair(libs); libs = cdr(libs)) + if (local_strcmp(file, string_value(caar(libs)))) + return(cdar(libs)); + return(sc->nil); +} +#endif + +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 */ + } +} + +#define WITH_LEVEN 1 +#if WITH_LEVEN +static int levenshtein(const char *s1, int len1, const char *s2, int len2) +{ + /* PERHAPS: don't allocate/free these arrays -- but this isn't called much */ + int i, j, val; + int **distance; + /* if (abs(len1 - len2) > 1) return(100); */ + /* if (!s1) return(100); */ /* can't happen in this context */ + /* if (!s2) return(100); */ + distance = (int **)calloc(len2 + 1, sizeof(int *)); + for (i = 0; i <= len2; i++) distance[i] = (int *)calloc(len1 + 1, sizeof(int)); + for (j = 0; j <= len1; j++) distance[0][j] = j; + for (i = 0; i <= len2; i++) distance[i][0] = i; + for (i = 1; i <= len2; i++) + for (j = 1; j <= len1; j++) + { + int c1, c2, c3; + c1 = distance[i][j - 1] + 1; + c2 = distance[i - 1][j] + 1; + c3 = distance[i - 1][j - 1] + ((s2[i - 1] == s1[j - 1]) ? 0 : 1); + if (c1 > c2) c1 = c2; + if (c1 > c3) c1 = c3; + distance[i][j] = c1; + } + val = distance[len2][len1]; + for (i = 0; i <= len2; i++) free(distance[i]); + free(distance); + return(val); +} +#endif + +static no_return 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 (starlet_symbol_id(T_Sym(sym)) != sl_no_field) + { + if (err_code) + error_nr(sc, sc->unbound_variable_symbol, + set_elist_4(sc, wrap_string(sc, "unbound variable ~S in ~S, perhaps you meant (*s7* '~S)?", 56), sym, err_code, sym)); + error_nr(sc, sc->unbound_variable_symbol, + set_elist_3(sc, wrap_string(sc, "unbound variable ~S, perhaps you meant (*s7* '~S)?", 50), sym, sym)); + } + + /* fprintf(stderr, "%s: %s in %s %" ld64 "\n", __func__, display(sym), (err_code) ? display(err_code) : "no code", (err_code && (has_location(err_code))) ? pair_line_number(err_code) : -1); */ +#if WITH_LEVEN + { + const char *sym_name = symbol_name(sym); + const s7_int sym_len = symbol_name_length(sym); + int32_t min_diff = (sym_len == 1) ? 0 : ((sym_len == 2) ? 2 : 3); + if (min_diff > 0) + { + /* check let chain */ + s7_pointer min_sym = NULL; + for (s7_pointer e = sc->curlet; e; e = let_outlet(e)) + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + { + int32_t diff; + s7_pointer cur_sym = slot_symbol(slot); + if (s7_int_abs(sym_len - symbol_name_length(cur_sym)) < 2) + { + diff = levenshtein(sym_name, sym_len, symbol_name(cur_sym), symbol_name_length(cur_sym)); + if (sym_name[0] != symbol_name(cur_sym)[0]) diff++; + if (diff < min_diff) + { + min_diff = diff; + min_sym = cur_sym; + }}} + if ((!min_sym) && (err_code) && (is_pair(err_code)) && + (sym == car(err_code)) && (sym_len < 22)) /* don't treat these as common variables */ + { /* perhaps also check that the suggested new name actually fits the rest of err_code!: "char -> caar (char #\a)" */ + /* check main symbols, from t865.scm */ + static const char *main_names[447] = { + "<=", ">=", "gc", "if", "pi", "do", "or", + "cos", "not", "ash", "exp", "sym", "nan", "tan", "map", "gcd", "car", "max", "abs", "lcm", "cdr", "let", "min", "sin", "eq?", "and", "log", + "acos", "assv", "eval", "cons", "help", "let*", "list", "*s7*", "sqrt", "memq", "exit", "expt", "assq", "nan?", "when", "read", "odd?", "let?", + "load", "atan", "asin", "cond", "set!", "caar", "eqv?", "cadr", "cdar", "cddr", "tanh", "sinh", "case", "cosh", "copy", "memv", "else", + "error", "round", "inlet", "unlet", "throw", "owlet", "list?", "index", "atanh", "asinh", "assoc", "apply", "fill!", "even?", "angle", "pair?", + "char?", "caadr", "caddr", "cdadr", "cdddr", "bacro", "macro", "acosh", "zero?", "caaar", "cadar", "cdaar", "cddar", "goto?", "real?", "arity", + "byte?", "abort", "catch", "null?", "sort!", "write", "begin", "quote", "floor", + "define", "float?", "format", "vector", "bignum", "unless", "symbol", "values", "member", "lambda", "logxor", "system", "logand", "modulo", + "length", "char?", "caadar", "caddar", "cdadar", "cdddar", "exact?", "bacro*", "macro*", "string", + "equal?", "letrec", "getenv", "macro?", "caaaar", "cadaar", "gensym", "caaddr", "cdaaar", "cadddr", "cddaar", "varlet", "cdaddr", "cddddr", + "result", "random", "logior", "caaadr", "cadadr", "cdaadr", "cddadr", "lognot", "sublet", "curlet", "cutlet", "outlet", + "letrec*", "complex", "unquote", "reverse", "string?", "indices", "let-ref", "gensym?", "require", "define*", "call/cc", + "newline", "char<=?", "vector?", "char>=?", "funclet", "display", "rootlet", "logbit?", "lambda*", "bignum?", "provide", "symbol?", + "iterate", "openlet", "ceiling", "syntax?", "type-of", "number?", + "quotient", "dilambda", "complex?", "reverse!", "string?", "integer?", "funclet?", "let-set!", "inexact?", "boolean?", "with-let", "openlet?", "truncate", "string=?", + "list-ref", "coverlet", "for-each", + "substring", "imag-part", "signature", "constant?", "hook-args", "remainder", "dilambda?", "read-byte", "read-char", "infinite?", + "sequence?", "magnitude", "peek-char", "char-ci>?", "iterator?", "numerator", "rational?", "char-ci=?", "subvector", "list-set!", + "negative?", "provided?", "string<=?", "char-cilist", "make-hook", "string>=?", "positive?", "c-object?", "port-file", "hash-code", + "int-vector", "write-char", "undefined?", "quasiquote", "make-polar", "stacktrace", "write-byte", "c-pointer?", "hash-table", "profile-in", + "immutable!", "*function*", "immutable?", "string-ref", "char-ci>=?", "file-mtime", + "subvector?", "char-ci<=?", "directory?", "tree-count", "procedure?", "vector-ref", + "object->let", "with-baffle", "make-string", "denominator", "tree-leaves", "vector-set!", "int-vector?", "vector-rank", + "eval-string", "hash-table?", "rationalize", "string-ci?", "input-port?", + "macroexpand", "eof-object?", "port-string", "char-ready?", "cond-expand", "string-set!", "make-vector", "read-string", + "char-upcase", "string-copy", "equivalent?", "nan-payload", "list-values", "reader-cond", "byte-vector", "delete-file", + "float-vector", "define-bacro", "symbol-table", "string-ci<=?", "list->string", "string-ci>=?", "apply-values", "file-exists?", "c-object-let", + "unspecified?", "define-macro", "string-fill!", "list->vector", "port-closed?", "tree-cyclic?", "dynamic-wind", "string->list", "byte-vector?", + "write-string", "vector-fill!", "proper-list?", "random-state", "output-port?", "vector->list", "vector-typer", + "string-append", "string-upcase", "port-position", "define-macro*", "tree-set-memq", "string-length", "vector-append", "documentation", + "char-downcase", "char->integer", "integer->char", "char-position", "c-object-type", "random-state?", "vector-length", "port-filename", + "symbol->value", "char-numeric?", "float-vector?", "define-bacro*", "make-iterator", "pair-filename", "continuation?", + "hook-functions", "c-pointer-type", "exact->inexact", "c-pointer-info", "integer-length", "string->symbol", "symbol->string", "complex-vector", + "inexact->exact", "emergency-exit", "string->number", "number->string", "int-vector-ref", "dynamic-unwind", "object->string", "call-with-exit", + "hash-table-ref", + "c-pointer-weak2", "directory->list", "symbol->keyword", "open-input-file", "c-pointer->list", "let-temporarily", "keyword->symbol", + "byte-vector-ref", "c-pointer-weak1", "string-position", "int-vector-set!", "make-int-vector", "hash-table-set!", + "string->keyword", "weak-hash-table", "string-downcase", "define-constant", "complex-vector?", "make-hash-table", + "iterator-at-end?", "char-lower-case?", "subvector-vector", "procedure-source", "call-with-values", "close-input-port", + "make-byte-vector", "float-vector-ref", "char-alphabetic?", "make-rectangular", "cyclic-sequences", "port-line-number", + "byte-vector-set!", "weak-hash-table?", "char-whitespace?", "open-output-file", "define-expansion", "char-upper-case?", "pair-line-number", + "vector-dimension", + "open-input-string", "get-output-string", "iterator-sequence", "make-float-vector", "close-output-port", "flush-output-port", + "define-expansion*", "float-vector-set!", "procedure-arglist", "vector-dimensions", + "open-output-string", "substring-uncopied", "complex-vector-ref", "subvector-position", "hash-table-entries", "random-state->list", + "current-input-port", "current-error-port", + "string->byte-vector", "byte-vector->string", "multiple-value-bind", "complex-vector-set!", "open-input-function", "current-output-port", + "with-output-to-file", "make-complex-vector", + "with-input-from-file", "hash-table-key-typer", "symbol-initial-value", "make-weak-hash-table", "integer-decode-float", "open-output-function", + "call-with-input-file", + "with-output-to-string", "call-with-output-file", "symbol->dynamic-value", + "set-current-error-port", "call-with-input-string", "set-current-input-port", "hash-table-value-typer", "with-input-from-string", + "set-current-output-port", "call-with-output-string", NULL}; + static const int32_t main_names_index[23] = {0, 7, 27, 62, 103, 157, 186, 208, 246, 268, 299, 324, 347, 364, + 383, 403, 413, 421, 429, 436, 441, 444, 446}; /* 446==NULL, 7858 - 3576 bytes */ + int32_t i, start = main_names_index[sym_len - 2], end = main_names_index[sym_len - 1]; + /* for (i = 0; i < 23; i++) fprintf(stderr, "%s\n", main_names[main_names_index[i]]); */ + for (i = start; i < end; i++) + { + int32_t diff = levenshtein(sym_name, sym_len, main_names[i], sym_len) + 1; /* perhaps same but i+/-1 as well */ + if (sym_name[0] != main_names[i][0]) diff++; + if (diff < min_diff) + { + min_diff = diff; + min_sym = make_symbol(sc, main_names[i], sym_len); + }}} + if (min_sym) + { + /* if (S7_DEBUGGING) fprintf(stderr, " leven: %s -> %s %s (%d)\n", display(sym), display(min_sym), (err_code) ? display(err_code) : "no code", min_diff); */ + if (err_code) + error_nr(sc, sc->unbound_variable_symbol, set_elist_4(sc, wrap_string(sc, "unbound variable ~S in ~S, perhaps ~S?", 38), sym, err_code, min_sym)); + error_nr(sc, sc->unbound_variable_symbol, set_elist_3(sc, wrap_string(sc, "unbound variable ~S, perhaps ~S?", 32), sym, min_sym)); + }}} +#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); + const s7_pointer value = sc->value; + const s7_pointer code = sc->code; + const s7_pointer current_let = sc->curlet; + /* 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. + */ + const s7_pointer args = (sc->args) ? sc->args : sc->nil; + s7_pointer result = sc->undefined; + sc->temp9 = cur_code; + 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_2(sc, value, cur_code)))); /* not s7_list (debugger checks) */ + sc->temp9 = sc->unused; + 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->rootlet, 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... + */ + const 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->rootlet, 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_) */ + const s7_pointer old_hook = sc->unbound_variable_hook; + const 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 # or #! */ + sc->code = code; + set_curlet(sc, current_let); + 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_class_and_fn_proc(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))) + { + const bool safe_case = is_safe_closure(func); + const s7_pointer body = closure_body(func); + const bool one_form = is_null(cdr(body)); + + if (is_immutable(func)) hop = 1; + if (is_null(closure_pars(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_ok); + } + /* 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_ok : opt_bad); + } + if (is_symbol(closure_pars(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_pars(func), NULL, NULL, false); + } + set_safe_optimize_op(expr, hop + OP_SAFE_THUNK_ANY); + return(opt_ok); + } + set_unsafe_optimize_op(expr, hop + OP_THUNK_ANY); /* "thunk" because here it is called with no args, I guess */ + return(opt_bad); + } + 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_bad); + } + if (is_c_function(func)) + { + if (c_function_min_args(func) != 0) + return(opt_bad); + if ((hop == 0) && (is_global(car(expr)))) hop = 1; /* not good: (define + *) clears hop earlier */ + if ((is_safe_procedure(func)) || (c_function_call(func) == g_values)) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_NC); + choose_c_function(sc, expr, func, 0); + return(opt_ok); + } + set_unsafe_optimize_op(expr, hop + OP_C); + choose_c_function(sc, expr, func, 0); + return(opt_bad); + } + if (is_c_function_star(func)) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_STAR); + set_class_and_fn_proc(expr, func); + return(opt_ok); + } + return(opt_bad); +} + +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 combine_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 combine_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 combine_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 combine_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 combine_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 combine_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 symbol_is_safe(s7_scheme *sc, s7_pointer arg, s7_pointer e) +{ + if (is_symbol(arg)) /* maybe normal here but check clo* key (see below) */ + { + if (is_keyword(arg)) return(true); + if (sc->in_with_let) return(pair_symbol_is_safe(sc, arg, e)); + if (is_slot(global_slot(arg))) return(true); + if ((!symbol_is_in_big_symbol_set(sc, arg)) && + (!arg_findable(sc, arg, e))) + return(false); + } + return(true); +} + + +static bool safe_c_aa_to_ag_ga(s7_scheme *sc, s7_pointer arg, int32_t hop) +{ + const s7_pointer arg1p = cdr(arg), arg2p = cddr(arg); + if (fx_proc(arg2p) == fx_s) {set_opt3_sym(arg, car(arg2p)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AS); return(true);} + if (fx_proc(arg1p) == fx_s) {set_opt3_sym(arg, car(arg1p)); set_safe_optimize_op(arg, hop + OP_SAFE_C_SA); return(true);} + if (fx_proc(arg2p) == fx_c) {set_opt3_con(arg, car(arg2p)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} + if (fx_proc(arg1p) == fx_c) {set_opt3_con(arg, car(arg1p)); set_safe_optimize_op(arg, hop + OP_SAFE_C_CA); return(true);} + if (fx_proc(arg2p) == fx_q) {set_opt3_con(arg, cadar(arg2p)); set_safe_optimize_op(arg, hop + OP_SAFE_C_AC); return(true);} + if (fx_proc(arg1p) == fx_q) {set_opt3_con(arg, cadar(arg1p)); 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_ok); +} + +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_class_and_fn_proc(expr, func); + return(opt_ok); + } + if ((is_closure(func)) && + (!arglist_has_rest(sc, closure_pars(func)))) + { + const s7_pointer body = closure_body(func); + const 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_bad); + } + if ((is_closure_star(func)) && + (lambda_has_simple_defaults(func)) && + (closure_star_arity_to_int(sc, func) >= n_args) && + (!arglist_has_rest(sc, closure_pars(func)))) + { + bool safe_case = is_safe_closure(func); + set_unsafely_optimized(expr); + if (n_args == 1) + set_optimize_op(expr, ((safe_case) ? OP_SAFE_CLOSURE_STAR_A : OP_CLOSURE_STAR_A)); + else + if (closure_star_arity_to_int(sc, func) == 2) + set_optimize_op(expr, ((safe_case) ? ((is_null(cdr(closure_body(func)))) ? OP_SAFE_CLOSURE_STAR_AA_O : /* aa_a was not faster */ + OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_NA)); + else set_optimize_op(expr, (safe_case) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA); + set_opt1_lambda_add(expr, func); + } + return(opt_bad); +} + +static inline s7_pointer find_uncomplicated_symbol(s7_scheme *sc, s7_pointer symbol, s7_pointer let) +{ + s7_pointer e; + s7_int id; + + if ((symbol_is_in_big_symbol_set(sc, symbol)) && + (direct_memq(symbol, let))) /* it's probably a local variable reference */ + return(sc->nil); + /* ((!symbol_is_in_big_symbol_set(sc, symbol)) && (direct_memq(symbol, let))) 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 big_symbol_set when recursive call is encountered) -- tricky to fix + */ + + if (is_defined_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_big_symbol_set(sc, symbol_to_keyword(sc, symbol)))) + return(sc->nil); + + for (e = sc->curlet, id = symbol_id(symbol); let_id(e) > id; e = let_outlet(e)); + for (; e; e = let_outlet(e)) + { + if (let_id(e) == id) return(local_slot(symbol)); + for (s7_pointer slot = let_slots(e); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(slot); + } + return(global_slot(symbol)); /* it's no longer global perhaps (local definition now inaccessible) */ +} + +static bool tree_has_escaper(s7_scheme *sc, s7_pointer tree, s7_pointer cc) +{ + if (is_pair(tree)) + { + if (is_escaper(car(tree))) return(true); + if ((is_pair(car(tree))) && (tree_has_escaper(sc, car(tree), cc))) return(true); + for (s7_pointer p = cdr(tree); is_pair(p); p = cdr(p)) + { + if (car(p) == cc) return(true); + if ((is_pair(car(p))) && (tree_has_escaper(sc, car(p), cc))) return(true); + }} + else + if (tree == cc) return(true); + return(false); +} + +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) +{ + /* "sym" is a symbol here. c_functions set hop=1 in optimize_expression */ + return(((!sc->in_with_let) && + (!is_maybe_shadowed(sym)) && + (is_global(sym))) ? 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) +{ + const s7_pointer arg1 = cadr(expr); + const 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, func_is_safe: %d, pairs: %d, hop: %d\n", __func__, __LINE__, display_truncated(expr), func_is_safe, pairs, hop); + if (pairs == 0) + { + if ((func_is_safe) || (c_function_call(func) == g_values)) /* 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_ok); + } + /* 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_bad); + } + /* pairs == 1 */ + if (bad_pairs == 0) + { + if (func_is_safe) + { + const int32_t op = combine_ops(sc, expr, combine_p, arg1, NULL); + if ((hop == 1) && (!op_has_hop(arg1)) && (is_symbol(car(arg1))) && (is_maybe_shadowed(car(arg1)))) /* else maybe c_function with even_args bit! */ + { + hop = 0; + if (!is_symbol(car(expr))) /* calling op was optimized to #_ previously, but now we notice its argument is problematic?! */ + set_car(expr, c_function_symbol(car(expr))); + /* maybe symbol_initial_value(...) -- but both can differ from global_value, (set! abs 32) (#_abs -1) */ + /* maybe return(opt_bad); or dependent on is_maybe_shadowed? */ + /* probably not the right way to fix this (s7test tc_or_a_and_a_a_la), but (define + *) needs this */ + } + 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); +#if 0 + /* works, not much impact? TODO: see check_c_aa, optimize_func_one|two|three_args for safe_c_functions */ + /* also, need wrapped field c_proc_t so this doesn't need to check each case by hand */ + if (has_fn(arg1)) + { + if (fn_proc(arg1) == g_multiply_2) set_fn_direct(arg1, g_multiply_2_wrapped); + if (fn_proc(arg1) == g_subtract_2) set_fn_direct(arg1, g_subtract_2_wrapped); + if (fn_proc(arg1) == g_add_2) set_fn_direct(arg1, g_add_2_wrapped); + } +#endif + return(opt_ok); + } + 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_bad); + }} + 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_ok); + } + set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_A : OP_C_A)); + choose_c_function(sc, expr, func, 1); + return(opt_bad); + } + /* 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); + /* (call/cc (lambda (return) (do ((i 0 (+ i 1))) ((= i 10)) (if (= i 3) (return 32))))) */ +#if 1 + /* 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. + * But we can notice that embedded use? lambda(*)/m|bacro(*), curlet + * But just quitting on lambda seems over enthusiastic -- lambda is used for with-output-*, call/exit, dynwind etc + * see t861 for examples. + */ + { + const s7_pointer arg_func = cadr(expr); + if ((car(arg_func) == sc->lambda_symbol) && + (is_pair(cdr(arg_func))) && (is_pair(cadr(arg_func))) && (is_normal_symbol(caadr(arg_func)))) + { + const s7_pointer cc = caadr(arg_func); + if ((!tree_has_escaper(sc, cddr(arg_func), cc)) && + ((caddr(arg_func) != cc) || (is_pair(cdddr(arg_func))))) /* (call/cc (lambda (return) return)) */ + { + set_unsafe_optimize_op(expr, (is_null(cdddr(lambda_expr))) ? OP_CALL_WITH_EXIT_O : OP_CALL_WITH_EXIT); + /* fprintf(stderr, "call/exit: %s\n", display(expr)); */ + } + /* else fprintf(stderr, "has cc: %s\n", display(cddr(arg_func))); */ + }} +#endif + } + 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_bad); + } + /* choose_c_function(sc, expr, func, 1); */ + /* clear_has_fn(expr); */ /* ??? this wipes out the choose_c_function=set_c_function call?? */ + 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_bad); + } + 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_bad); + }}}} + 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_bad); +} + +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, "%s[%d]: omit %s: %s\n", __func__, __LINE__, 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) +{ + const 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_pars(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) + { + const 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_pars(func)), NULL, NULL, false); + return(opt_ok); +} + +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)); /* fx(body) cases here are rare (make-index) */ + else + if (!safe_case) + set_optimize_op(expr, hop + OP_CLOSURE_A_O); + else + { + const 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_pars(func)) == cadar(body))) + { + const 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_pars(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_bad); + set_opt3_arglen(cdr(expr), args); + set_opt1_lambda_add(expr, func); + fx_annotate_args(sc, cdr(expr), e); + if (is_safe_closure(func)) + { + const 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_pars(func), NULL, NULL, false); + } + set_safe_optimize_op(expr, hop + OP_ANY_CLOSURE_SYM); + return(opt_ok); + } + set_unsafe_optimize_op(expr, hop + OP_ANY_CLOSURE_SYM); + return(opt_bad); +} + +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_bad); + set_opt3_arglen(cdr(expr), args); + set_opt1_lambda_add(expr, func); + fx_annotate_args(sc, cdr(expr), e); + if (is_safe_closure(func)) + { + const 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_pars(func)), cdr(closure_pars(func)), NULL, false); + } + set_safe_optimize_op(expr, hop + OP_ANY_CLOSURE_A_SYM); + return(opt_ok); + } + set_unsafe_optimize_op(expr, hop + OP_ANY_CLOSURE_A_SYM); + return(opt_bad); +} + +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; + const s7_pointer arg1 = cadr(expr); + const int32_t arit = closure_arity_to_int(sc, func); + if (arit != 1) + { + if (is_symbol(closure_pars(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_pars(func))))) + return(optimize_closure_a_sym(sc, expr, func, hop, 1, e)); + return(opt_bad); + } + 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_bad); + } + 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_ok); + set_unsafely_optimized(expr); + return(opt_bad); + } + 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_bad); /* don't check is_optimized here for opt_ok */ +} + +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) && + ((!symbol_is_safe(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_bad); + } + + 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_bad); + 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_pars(func))) + return(opt_bad); + if (fx_count(sc, expr) == 1) + { + const 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_pars(func))))) + set_optimize_op(expr, hop + OP_SAFE_CLOSURE_STAR_A1); + else + if (lambda_has_simple_defaults(func)) + { + if (arglist_has_rest(sc, closure_pars(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_bad); + + 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) && (is_global(car(expr)))))) 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_class_and_fn_proc(expr, func); + return(opt_ok); + } + break; + + case T_PAIR: case T_VECTOR: case T_INT_VECTOR: case T_BYTE_VECTOR: case T_FLOAT_VECTOR: case T_COMPLEX_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_ok); + } + break; + + case T_LET: + /* implicit function/c-object -> (f 'a) if f is a function is a function call, not a funclet or c-object-let reference, ((funclet f) 'a). + * c-pointer might work, but it's too similar to c-object, and you can always use ((c-pointer-info p) 'a). + */ + 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->starlet) /* (*s7* ...), sc->starlet is a let */ + { + set_safe_optimize_op(expr, OP_IMPLICIT_STARLET_REF_S); + set_opt3_int(expr, starlet_symbol_id(sym)); + return(opt_ok); + } + set_opt3_con(expr, sym); + set_unsafe_optimize_op(expr, OP_IMPLICIT_LET_REF_C); + return(opt_ok); + } + /* 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_ok); + } + break; + + default: + break; + } + return((is_optimized(expr)) ? opt_ok : opt_bad); +} + +static bool unsafe_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer e) +{ + s7_pointer slot; + if (!is_symbol(sym)) return(false); + slot = find_uncomplicated_symbol(sc, sym, e); /* how to catch local c-funcs here? */ + if (!is_slot(slot)) return(false); + return(is_safe_c_function(slot_value(slot))); +} + +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_bad); +} + +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_bad); +} + +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 clo, s7_pointer code, int32_t hop) +{ + const int32_t arity = closure_star_arity_to_int(sc, clo); + const bool safe_case = is_safe_closure(clo); + const s7_pointer arg1 = cadr(code); + s7_pointer par1 = car(closure_pars(clo)); + + 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(clo)) && (arity == 2)) + set_optimize_op(code, hop + ((safe_case) ? ((is_null(cdr(closure_body(clo)))) ? OP_SAFE_CLOSURE_STAR_AA_O : OP_SAFE_CLOSURE_STAR_AA) : OP_CLOSURE_STAR_NA)); + else set_optimize_op(code, hop + ((safe_case) ? 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) +{ + const s7_pointer arg1p = cdr(expr), 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 ((!symbol_is_safe(sc, arg1, e)) || + (!symbol_is_safe(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, arg1p, e); + return(wrap_bad_args(sc, func, expr, 2, hop, e)); + } + return(opt_bad); + } + /* end of bad symbol wrappers */ + + if (is_c_function(func) && (c_function_is_aritable(func, 2))) + { + /* this is a mess */ + const 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_opt1_sym(arg1p, arg2); + } + else + if (is_normal_symbol(arg1)) + { + set_opt1_con(arg1p, arg2); + set_optimize_op(expr, hop + OP_SAFE_C_SC); + } + else + { + set_opt1_con(arg1p, arg1); /* set_opt2_sym(arg1p, arg2); */ + set_optimize_op(expr, hop + OP_SAFE_C_CS); + } + set_optimized(expr); + choose_c_function(sc, expr, func, 2); + return(opt_ok); + } + + 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_opt1_sym(arg1p, 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, arg1p, e); + set_opt3_arglen(arg1p, 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_opt1_con(arg1p, arg2); + } + else + { + set_opt1_con(arg1p, arg1); /* set_opt2_sym(arg1p, arg2); */ + set_optimize_op(expr, hop + OP_SAFE_C_CS); + }} + return(opt_ok); + } + else + if ((symbols == 1) && (is_normal_symbol(arg1))) /* arg2 must be constant since pairs==0 */ + { + set_optimize_op(expr, hop + OP_C_SC); + set_opt3_con(arg1p, arg2); /* a very small optimization! */ + }} + return(opt_bad); + } + + /* pairs != 0 */ + if ((bad_pairs == 0) && + (pairs == 2)) + { + if ((func_is_safe) || + ((is_maybe_safe(func)) && (two_args_ok(sc, expr, e)))) + { + const int32_t op = combine_ops(sc, expr, combine_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_defined_global(caadr(expr))) && (is_defined_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(arg1p, 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(arg1p) 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, arg1p, e); + set_opt3_arglen(arg1p, 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(arg1p, 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_ok); + }} + + 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)) ? combine_ps : combine_pc; + op = combine_ops(sc, expr, orig_op, arg1, arg2); + } + else + { + orig_op = (is_normal_symbol(arg1)) ? combine_sp : combine_cp; + op = combine_ops(sc, expr, orig_op, arg1, arg2); + } + + if ((hop == 1) && + (((is_pair(arg2)) && (!op_has_hop(arg2)) && (is_symbol(car(arg2))) && (is_maybe_shadowed(car(arg2)))) || + ((is_pair(arg1)) && (!op_has_hop(arg1)) && (is_symbol(car(arg1))) && (is_maybe_shadowed(car(arg1)))))) + { + hop = 0; + if (!is_symbol(car(expr))) + set_car(expr, c_function_symbol(car(expr))); /* maybe symbol_initial_value(...) */ + } + /* arg2 case: (let () (define (func) (let ((i 0)) (define + *) (quotient 10001 (+ i 1)))) (func)) -> division by zero error */ + /* arg1 case: (let () (define (func) (let ((i 0)) (define + *) (remainder (+ i 1) 101))) (func)) ; 0 */ + + if ((((op == OP_SAFE_C_SP) || (op == OP_SAFE_C_CP)) && + (is_fxable(sc, arg2))) || + (((op == OP_SAFE_C_PS) || (op == OP_SAFE_C_PC)) && + (is_fxable(sc, arg1)))) + { + fx_annotate_args(sc, arg1p, 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(arg1p, arg1); + } + else + if (op == OP_SAFE_C_PC) + set_opt3_con(arg1p, arg2); + } + choose_c_function(sc, expr, func, 2); + return(opt_ok); + }} + + 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_opt1_con(arg1p, cadr(arg2)); + set_optimize_op(expr, hop + OP_SAFE_C_SC); + } + else + { + set_opt1_con(arg1p, cadr(arg1)); /* set_opt2_sym(arg1p, arg2); */ + set_optimize_op(expr, hop + OP_SAFE_C_CS); + } + choose_c_function(sc, expr, func, 2); + return(opt_ok); + } + if ((pairs == 1) && (is_pair(arg2))) /* QC never happens */ + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_CQ); + set_opt2_con(arg1p, cadr(arg2)); + choose_c_function(sc, expr, func, 2); + return(opt_ok); + } + 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, arg1p, e); + set_opt3_arglen(arg1p, 2); + choose_c_function(sc, expr, func, 2); + return(opt_bad); + }} + + 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(arg1p, 2); + } + fx_annotate_args(sc, arg1p, e); + choose_c_function(sc, expr, func, 2); + return((func_is_safe) ? opt_ok : opt_bad); + } + + 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_ok); + set_unsafe(expr); + return(opt_bad); + } + 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(arg1p, arg2); + } + else + { + set_optimize_op(expr, hop + OP_SAFE_C_CP); + opt_sp_1(sc, c_function_call(func), expr); + set_opt3_any(arg1p, arg1); + } + choose_c_function(sc, expr, func, 2); + if (bad_pairs == 0) + return(opt_ok); + set_unsafe(expr); + return(opt_bad); + }} + + 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(arg1p, cadr(arg1)); + set_opt2_con(arg1p, cadr(arg2)); + choose_c_function(sc, expr, func, 2); + return(opt_ok); + }} + 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, arg1p, 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_bad); + } + 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(arg1p, cadr(arg1)); + } + else + { + set_optimize_op(expr, hop + OP_SAFE_C_PC); + set_opt3_con(arg1p, cadr(arg2)); + } + set_unsafely_optimized(expr); + choose_c_function(sc, expr, func, 2); + return(opt_bad); + }} + + 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, arg1p, e); + set_opt3_arglen(arg1p, 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_bad); + } + 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_bad); + } + set_unsafe_optimize_op(expr, hop + OP_C_AP); + fx_annotate_arg(sc, arg1p, e); + } + choose_c_function(sc, expr, func, 2); + return(opt_bad); + } + + 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 small_symbol_set */ + /* 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_bad); + }} + 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; + const int32_t arit = closure_arity_to_int(sc, func); + + if (arit != 2) + { + if (is_symbol(closure_pars(func))) + return(optimize_closure_sym(sc, expr, func, hop, 2, e)); + if ((arit == -1) && (is_symbol(cdr(closure_pars(func))))) /* (define (f a . b) ...) */ + return(optimize_closure_a_sym(sc, expr, func, hop, 2, e)); + return(opt_bad); + } + 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_pars(func)), cadr(closure_pars(func)), NULL, false); + set_safe_optimize_op(expr, hop + OP_SAFE_CLOSURE_SS_A); + /* fx_annotate_args(sc, arg1p, e); */ + set_closure_one_form_fx_arg(func); + return(opt_ok); + } + return(opt_bad); + } + 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_bad); + }} + + if ((!arglist_has_rest(sc, closure_pars(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, arg1p, e); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 2); + return(opt_ok); + } + fx_annotate_args(sc, arg1p, e); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 2); + return(opt_bad); + } + + if (is_fxable(sc, arg1)) + { + set_unsafely_optimized(expr); + fx_annotate_arg(sc, arg1p, 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(arg1p, 2); /* for op_unknown_np */ + return(opt_bad); + } + + 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); + /* 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_bad); + } + + 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(arg1p, 2); /* for op_unknown_np */ + return(opt_bad); + } + + 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(arg1p, 2); /* for op_unknown_np */ + return(opt_bad); + } + + if (is_closure_star(func)) + { + if (!closure_star_is_aritable(sc, func, closure_pars(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_pars=(), 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, arg1p, e); + set_opt1_lambda_add(expr, func); + return(opt_bad); + }} + + 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) && (is_global(car(expr)))))) hop = 1; + set_optimized(expr); + set_optimize_op(expr, hop + OP_SAFE_C_STAR_AA); /* k+c? = cc */ + fx_annotate_args(sc, arg1p, e); + set_opt3_arglen(arg1p, 2); + set_class_and_fn_proc(expr, func); + return(opt_ok); + } + + 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, arg1p, e); + set_opt3_arglen(arg1p, 2); + return(opt_ok); + } + return((is_optimized(expr)) ? opt_ok : opt_bad); +} + +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) +{ + const s7_pointer arg1p = cdr(expr), 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(arg1p); + if (symbols == 3) + { + set_optimize_op(expr, hop + OP_SAFE_C_SSS); + set_opt1_sym(arg1p, arg2); + set_opt2_sym(arg1p, arg3); + } + else + if (symbols == 2) + if (!is_normal_symbol(arg1)) + { + set_optimize_op(expr, hop + OP_SAFE_C_CSS); + set_opt1_sym(arg1p, arg2); + set_opt2_sym(arg1p, arg3); + } + else + if (!is_normal_symbol(arg3)) + { + set_opt2_con(arg1p, arg3); + set_opt1_sym(arg1p, arg2); + set_optimize_op(expr, hop + OP_SAFE_C_SSC); + } + else + { + set_opt1_con(arg1p, arg2); + set_opt2_sym(arg1p, arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCS); + } + else + if (is_normal_symbol(arg1)) + { + set_opt1_con(arg1p, arg2); + set_opt2_con(arg1p, arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCC); + } + else + if (is_normal_symbol(arg2)) + { + set_opt1_sym(arg1p, arg2); + set_opt2_con(arg1p, arg3); + set_opt3_con(arg1p, arg1); + set_optimize_op(expr, hop + OP_SAFE_C_CSC); + } + else + { + set_opt1_sym(arg1p, arg3); + set_opt2_con(arg1p, arg2); + set_opt3_con(arg1p, arg1); + set_optimize_op(expr, hop + OP_SAFE_C_CCS); + }} + choose_c_function(sc, expr, func, 3); + return(opt_ok); + } + + /* 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(arg1p, cadr(arg2)); /* fx_c_scs uses opt1_con */ + clear_has_fx(arg1p); /* (s7test safe_c_func_three_args) this is used above -- maybe just clear it at the top? */ + set_opt2_sym(arg1p, arg3); + set_optimize_op(expr, hop + OP_SAFE_C_SCS); /* used to be SQS */ + choose_c_function(sc, expr, func, 3); + return(opt_ok); + } + 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(arg1p, cadr(arg2)); /* opt1_con is T_Exs (unchecked) */ + set_opt2_sym(arg1p, arg3); + set_opt3_sym(arg1p, cadr(arg1)); + choose_c_function(sc, expr, func, 3); + return(opt_ok); + } + 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(arg1p, arg2); + set_opt2_con(arg1p, arg3); + set_opt3_con(arg1p, cadr(arg1)); + choose_c_function(sc, expr, func, 3); + return(opt_ok); + }}} + + fx_annotate_args(sc, arg1p, e); + set_opt3_arglen(arg1p, 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(arg1p); /* 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_ok); + } + return(opt_bad); /* 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) +{ + const s7_pointer arg1p = cdr(expr), arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); + if ((quotes > 0) && + (direct_memq(sc->quote_symbol, e))) + return(opt_oops); + if ((!symbol_is_safe(sc, arg1, e)) || + (!symbol_is_safe(sc, arg2, e)) || + (!symbol_is_safe(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, arg1p, e); + set_opt3_arglen(arg1p, 3); + if (is_c_function(func)) + { + if (is_safe_procedure(func)) + { + set_safe_optimize_op(expr, hop + OP_SAFE_C_AAA); + set_opt3_pair(arg1p, 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_class_and_fn_proc(expr, func); + return(opt_ok); + } + if ((is_closure(func)) && + (closure_arity_to_int(sc, func) == 3) && + (!arglist_has_rest(sc, closure_pars(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_bad); + } + 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_bad); + } /* 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_ok) + return(opt_ok); + 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_bad); + } + 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, arg1p, e); + set_opt3_arglen(arg1p, 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(arg1p) == 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_bad); + } + + /* (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))))) + { + const 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_class_and_fn_proc(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; + /* clear_has_fn(expr); *//* ??? this cancels the set_c_function call?? */ + set_opt2_con(expr, error_result); /* for op_c_catch_all|_a -> stack */ + + set_opt1_pair(arg1p, 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(arg1p, 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_bad); + }}} + + 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 small_symbol_set */ + 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_bad); + }} + + 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)) + { + const int32_t arit = closure_arity_to_int(sc, func); + if (arit != 3) + { + if (is_symbol(closure_pars(func))) + return(optimize_closure_sym(sc, expr, func, hop, 3, e)); + return(opt_bad); + } + if (is_immutable(func)) hop = 1; + + if (symbols == 3) + { + const s7_pointer body = closure_body(func); + const bool one_form = is_null(cdr(body)); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 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_pars(func)), cadr(closure_pars(func)), caddr(closure_pars(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_ok); + } + set_unsafe_optimize_op(expr, hop + ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)); + return(opt_bad); + } + + 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, arg1p, e); + if (is_fx_treeable(arg1p)) + fx_tree(sc, closure_body(func), car(closure_pars(func)), cadr(closure_pars(func)), caddr(closure_pars(func)), false); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 3); + return(opt_bad); + } + 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_bad); + 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, arg1p, e); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 3); + return(opt_bad); + }} + + 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, arg1p, e); + set_opt3_arglen(arg1p, 3); + set_class_and_fn_proc(expr, func); + return(opt_ok); + } + /* implicit_vector_3a doesn't happen */ + + if (bad_pairs > quotes) return(opt_bad); + return((is_optimized(expr)) ? opt_ok : opt_bad); +} + +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)) && + (!symbol_is_in_big_symbol_set(sc, 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) +{ + const s7_pointer arg1p = cdr(expr); + 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_ok); + } + if (symbols == args) + { + if (symbols_are_safe(sc, arg1p, 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, arg1p, e); + } + set_opt3_arglen(arg1p, args); + choose_c_function(sc, expr, func, args); + return(opt_ok); + }} + + 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, arg1p, e); + set_opt3_arglen(arg1p, args); + choose_c_function(sc, expr, func, args); + + for (p = arg1p; (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 = arg1p; is_pair(p); p = cddr(p)) + { + clear_has_fx(p); + set_opt2_con(p, (is_pair(car(p))) ? cadar(p) : car(p)); + }} + return(opt_ok); + } + 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, arg1p, e); + set_opt3_arglen(arg1p, 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_bad); + } + return(set_any_c_np(sc, func, expr, e, args, hop + OP_ANY_C_NP)); /* was num_args=3! 2-Sep-20 */ + } + + { + const bool func_is_closure = is_closure(func); + if (func_is_closure) + { + const int32_t arit = closure_arity_to_int(sc, func); + if (arit != args) + { + if (is_symbol(closure_pars(func))) + return(optimize_closure_sym(sc, expr, func, hop, args, e)); + return(opt_bad); + } + if (is_immutable(func)) hop = 1; + + if (fx_count(sc, expr) == args) + { + const 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, arg1p, e); + set_opt3_arglen(arg1p, args); + set_opt1_lambda_add(expr, func); + + if ((symbols == args) && + (symbols_are_safe(sc, arg1p, 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_bad); + } + 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_bad); + + 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, arg1p, e); + set_opt3_arglen(arg1p, args); + set_class_and_fn_proc(expr, func); + return(opt_ok); + } + 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, arg1p, e); + set_opt3_arglen(arg1p, args); + set_opt1_lambda_add(expr, func); + return(opt_bad); + }} + return((is_optimized(expr)) ? opt_ok : opt_bad); +} + +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_normal_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)) + { + const s7_pointer init = cadar(p); + const s7_pointer var = caar(p); /* (define (f) (let ((+ -)) (with-let (curlet) (#_integer? (+))))) (f) */ + if ((initial_value_is_defined(var)) && /* is_normal_symbol is checked above in vars_syntax_ok */ + (is_slot(global_slot(var))) && (is_c_function(global_value(var)))) + { /* this is ridiculous. TODO: vars_opt_ok needs to be smarter! */ + return(false); + } + if ((is_pair(init)) && + (!is_checked(init)) && + (optimize_expression(sc, init, hop, e, false) == opt_oops)) + return(false); + } + return(true); +} + +static void cleanup_big_symbol_set(s7_scheme *sc, s7_pointer orig_e, s7_pointer cur_e) +{ + for (s7_pointer p = cur_e; ((is_pair(p)) && (p != orig_e)); p = cdr(p)) + { + s7_pointer sym = car(p); + if (is_symbol(sym)) + { + if (symbol_shadows(sym) > 0) + symbol_shadows(sym)--; + else set_big_symbol_tag(sym, 0); + }} +} + +static opt_t optimize_syntax(s7_scheme *sc, s7_pointer expr, s7_pointer func, int32_t hop, s7_pointer e, bool export_ok) +{ + const opcode_t op = syntax_opcode(func); + s7_pointer body = cdr(expr), vars; + const s7_pointer init_e = e; + bool body_export_ok = true; + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, e: %s, op: %s, hop: %d, export_ok: %d\n", __func__, __LINE__, + display_truncated(expr), display(func), display(e), op_names[op], hop, export_ok); + sc->w = e; + switch (op) + { + case OP_QUOTE: + case OP_MACROEXPAND: + if (is_proper_list_1(sc, body)) + { + cleanup_big_symbol_set(sc, init_e, e); + return(opt_bad); + } + return(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) */ + { + cleanup_big_symbol_set(sc, init_e, e); + return(opt_bad); + } + 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_big_symbol_set(sc, car(var)), e); + sc->w = e; + } + if (is_symbol(cadr(expr))) + { + e = cons(sc, add_symbol_to_big_symbol_set(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)) + { + const 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)) + { + const 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: + cleanup_big_symbol_set(sc, init_e, e); + return(opt_bad); + + 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 + * define et al here can be #_define, not the symbol 'define + */ + vars = cadr(expr); + body = cddr(expr); + if (is_pair(vars)) + { + if ((export_ok) && + (is_symbol(car(vars)))) + { + add_symbol_to_big_symbol_set(sc, car(vars)); + if ((is_pair(e)) && (car(e) != sc->if_keyword)) + set_cdr(e, cons(sc, car(vars), cdr(e))); /* export it */ + else e = cons(sc, car(vars), e); + } + e = collect_parameters(sc, cdr(vars), e); + body_export_ok = export_ok; + } + else /* vars must be a symbol */ + { + if (!is_symbol(vars)) return(opt_oops); /* (define 1 2) */ + + /* 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. + */ + if (initial_value_is_defined(vars)) + { + if ((SHOW_EVAL_OPS) && (!is_maybe_shadowed(vars))) fprintf(stderr, " %s set maybe shadowed\n", display(vars)); + set_is_maybe_shadowed(vars); + } + sc->temp7 = 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->temp7 = sc->unused; + return(opt_oops); + } + sc->temp7 = sc->unused; + if (export_ok) + { + if ((is_pair(e)) && (car(e) != sc->if_keyword)) + set_cdr(e, cons(sc, vars, cdr(e))); /* export it */ + cleanup_big_symbol_set(sc, init_e, e); + } + return(opt_bad); + } + 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)))) + { + const 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->starlet_symbol)) + { + cleanup_big_symbol_set(sc, init_e, e); + return(opt_ok); + } + cleanup_big_symbol_set(sc, init_e, e); + return(opt_bad); + + 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. + */ + { + const bool old_with_let = sc->in_with_let; + sc->temp9 = e; + clear_big_symbol_set(sc); + 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; + sc->temp9 = sc->unused; + return(opt_oops); + } + sc->in_with_let = old_with_let; + cleanup_big_symbol_set(sc, init_e, e); + sc->temp9 = sc->unused; + return(opt_bad); + } + + 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); + cleanup_big_symbol_set(sc, init_e, e); + return(opt_bad); + + 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))) + { + const 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)) {cleanup_big_symbol_set(sc, init_e, e); return(opt_bad);} + 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)); + } + cleanup_big_symbol_set(sc, init_e, e); + return(opt_ok); + + 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->temp7 = 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->temp7 = sc->unused; + return(opt_oops); + } + sc->temp7 = sc->unused; + + if ((hop == 1) && + ((is_syntax(car(expr))) || + (is_global(car(expr))))) + { + if (op == OP_IF) + { + const s7_pointer test = cdr(expr); + s7_pointer b1, b2, p; + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + { + cleanup_big_symbol_set(sc, init_e, e); + return(opt_bad); + } + if (!is_null(p)) return(opt_oops); + if ((is_pair(cdr(test))) && (is_pair(cddr(test))) && (!is_null(cdddr(test)))) + return(opt_oops); + + for (s7_pointer p1 = cdr(expr); is_pair(p1); p1 = cdr(p1)) + set_fx_direct(p1, fx_choose(sc, p1, 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)); + cleanup_big_symbol_set(sc, init_e, e); + return(opt_ok); + } + 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)); + cleanup_big_symbol_set(sc, init_e, e); + return(opt_ok); + } + 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); + cleanup_big_symbol_set(sc, init_e, e); + return(opt_ok); + } + 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)); + }} + cleanup_big_symbol_set(sc, init_e, e); + return(opt_ok); + } + else + { + if ((op == OP_OR) || (op == OP_AND)) + { + int32_t args = 0, 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))) + { + cleanup_big_symbol_set(sc, init_e, e); + return(opt_bad); + } + if (!is_null(p)) return(opt_oops); + for (s7_pointer p1 = cdr(expr); is_pair(p1); p1 = cdr(p1), args++) /* this only applies to or/and */ + if (is_pair(car(p1))) + { + pairs++; + if ((c_s_is_ok) && + ((!is_h_safe_c_s(car(p1))) || + ((sym) && (sym != cadar(p1))))) + c_s_is_ok = false; + else sym = (is_pair(cdar(p1))) ? cadar(p1) : 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_defined_global(caadr(expr))) && + ((is_symbol(caaddr(expr))) && (symbol_type(caaddr(expr)) > 0) && (is_defined_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); + } + cleanup_big_symbol_set(sc, init_e, e); + return(opt_ok); + } + + for (s7_pointer p1 = cdr(expr); is_pair(p1); p1 = cdr(p1)) + set_fx_direct(p1, fx_choose(sc, p1, 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); + } + cleanup_big_symbol_set(sc, init_e, e); + return(opt_ok); + } + 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); + cleanup_big_symbol_set(sc, init_e, e); + return(opt_ok); + } + else + if (op == OP_BEGIN) + { + s7_pointer p; + if (!is_pair(cdr(expr))) {cleanup_big_symbol_set(sc, init_e, e); return(opt_bad);} + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + { + cleanup_big_symbol_set(sc, init_e, e); + return(opt_bad); + } + if (!is_null(p)) return(opt_oops); + for (s7_pointer p1 = cdr(expr); is_pair(p1); p1 = cdr(p1)) + set_fx_direct(p1, fx_choose(sc, p1, e, pair_symbol_is_safe)); + set_safe_optimize_op(expr, ((is_pair(cddr(expr))) && (is_null(cdddr(expr)))) ? OP_BEGIN_AA : OP_BEGIN_NA); + cleanup_big_symbol_set(sc, init_e, e); + return(opt_ok); + }}} /* fully fxable lets don't happen much: even let-2a-a is scarcely used */ + cleanup_big_symbol_set(sc, init_e, e); + return(opt_bad); +} + +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, hop: %d\n", __func__, __LINE__, display_truncated(expr), display(func), hop); + for (p = cdr(expr); is_pair(p); p = cdr(p), args++) /* check the calling expression */ + { + const s7_pointer arg = car(p); + if (is_normal_symbol(arg)) /* for opt func */ + symbols++; + else + if (is_pair(arg)) + { + pairs++; + if (!is_checked(arg)) + { + opt_t result; + if ((is_pair(car(arg))) && (caar(arg) == sc->let_symbol)) + result = opt_bad; + else result = optimize_expression(sc, arg, orig_hop, e, false); + if (result == opt_bad) + { + bad_pairs++; + if (is_proper_quote(sc, arg)) + quotes++; + } + else + if (result == opt_oops) + return(opt_oops); + } + else + if ((!is_optimized(arg)) || + (is_unsafe(arg))) + { + bad_pairs++; + if (is_proper_quote(sc, arg)) + 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_bad, 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) +{ + const s7_pointer head = car(expr), args = cdr(expr); + const int32_t orig_hop = hop; + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s, e: %s, hop: %d\n", __func__, __LINE__, display_truncated(expr), display(e), hop); + set_checked(expr); + + if (is_symbol(head)) + { + s7_pointer slot; + if (is_syntactic_symbol(head)) + { + if (!is_pair(args)) + return(opt_oops); + return(optimize_syntax(sc, expr, T_Syn(global_value(head)), hop, e, export_ok)); + } + slot = find_uncomplicated_symbol(sc, head, e); /* local vars (recursive calls too??) are considered complicated */ + if (is_slot(slot)) + { + const s7_pointer func = slot_value(slot); + if (is_syntax(func)) /* not is_syntactic -- here we have the value */ + return((is_pair(args)) ? 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_bad); + + /* 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 (is_maybe_shadowed(head)) fprintf(stderr, "%d: is_maybe_shadowed: %s in %s\n", __LINE__, display(head), display(expr)); */ + if ((hop != 0) && + ((is_maybe_shadowed(head)) || /* for globals that are possibly clobbered at run-time (i.e. not yet) */ + (((is_any_closure(func)) || /* see use-redef in s7test -- I'm not sure about this */ + ((!is_global(head)) && + ((!is_slot(global_slot(head))) || + (global_value(head) != func)))) && + (!is_immutable(head)) && /* 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_defined_global(head) 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) && /* head is not in e or global */ + (big_symbol_tag(head) == 0)) /* and we haven't looked it up earlier */ + { + const s7_pointer port = current_input_port(sc); + if ((is_input_port(port)) && + (port_file(port) != stdin) && + (!port_is_closed(port)) && + (port_filename(port))) + s7_warn(sc, 1024, "%s might be undefined (%s %u)\n", display(head), port_filename(port), port_line_number(port)); + else s7_warn(sc, 1024, "; %s might be undefined\n", display(head)); + set_big_symbol_tag(head, 1); /* one warning is enough */ + } + + /* head 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 = args; is_pair(p); p = cdr(p), len++) + { + const s7_pointer arg = car(p); + if (is_pair(arg)) + { + pairs++; + if ((!is_checked(arg)) && + (optimize_expression(sc, arg, hop, e, false) == opt_oops)) + return(opt_oops); + } + else + if (is_symbol(arg)) + 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_bad); + } + if (len == 1) + { + if (!is_quote(head)) /* !! 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, args, e); /* g->a later if closure */ + return(opt_bad); + } + if (len == 2) + { + set_unsafely_optimized(expr); + set_optimize_op(expr, OP_UNKNOWN_GG); + return(opt_bad); + } + if (len >= 3) + { + if (len == symbols) + { + set_unsafe_optimize_op(expr, OP_UNKNOWN_NS); + set_opt3_arglen(args, len); + return(opt_bad); + } + if (fx_count(sc, expr) == len) + { + set_unsafe_optimize_op(expr, OP_UNKNOWN_NA); + set_opt3_arglen(args, len); + return(opt_bad); + }}} + else /* pairs != 0 */ + { + const s7_pointer arg1 = cadr(expr); + if ((pairs == 1) && (len == 1)) + { + if ((is_quote(head)) && + (direct_memq(sc->quote_symbol, e))) + return(opt_oops); + + if (is_fxable(sc, arg1)) + { + set_opt3_arglen(args, 1); + fx_annotate_arg(sc, args, e); + set_unsafe_optimize_op(expr, OP_UNKNOWN_A); + return(opt_bad); + }} + 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(args, len); + if (len <= 2) fx_annotate_args(sc, args, e); + return(opt_bad); + } + set_unsafe_optimize_op(expr, OP_UNKNOWN_NP); + set_opt3_arglen(args, len); + return(opt_bad); + }}}} + 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)))) */ + + if ((head == sc->quote_function) && (is_pair(args))) /* very common */ + return(optimize_syntax(sc, expr, sc->quote_function, hop, e, export_ok)); + + if (is_c_function(head)) /* (#_abs x) etc */ + return(optimize_funcs(sc, expr, head, /* (direct_memq(c_function_symbol(head), e)) ? 0 : */ 1, orig_hop, e)); + + if (is_syntax(head)) /* (#_cond...) etc */ + { + if (!is_pair(args)) + return(opt_oops); + return(optimize_syntax(sc, expr, head, orig_hop, e, export_ok)); + } + if (is_any_macro(head)) + return(opt_bad); + + /* 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 (s7_pointer 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_bad); +} + +static opt_t optimize(s7_scheme *sc, s7_pointer code, int32_t hop, s7_pointer e) +{ + s7_pointer expr; + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s, e: %s, hop: %d\n", __func__, __LINE__, display_truncated(code), display(e), hop); + for (expr = code; (is_pair(expr)) && (!is_checked(expr)); expr = cdr(expr)) + { + const s7_pointer obj = car(expr); + set_checked(expr); + if (is_pair(obj)) + { + if ((!is_checked(obj)) && + (optimize_expression(sc, obj, hop, e, true) == opt_oops)) + { + s7_pointer p; + for (p = cdr(expr); 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 + 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(expr)) + syntax_error_nr(sc, "stray dot in function body: ~S", 30, code); + return(opt_bad); +} + + +static s7_pointer key_or_constant_arg(s7_scheme *sc, s7_pointer arg) +{ + bool key = is_symbol_and_keyword(arg); + return(wrap_string(sc, (key) ? "keyword" : "constant", (key) ? 7 : 8)); + /* maybe better, but there is no sc->keyword_symbol: return((is_symbol_and_keyword(arg)) ? sc->keyword_symbol : sc->constant_symbol); */ +} + +static void check_lambda_args(s7_scheme *sc, s7_pointer args, int32_t *arity, s7_pointer form) +{ + 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_5(sc, wrap_string(sc, "~A parameter is a ~A: (~S ~S ...)", 33), + car(form), key_or_constant_arg(sc, args), 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; + } + begin_small_symbol_set(sc); + for (i = 0; is_pair(args); i++, args = cdr(args)) + { + const s7_pointer arg = car(args); + if (is_constant(sc, arg)) /* (lambda (pi) pi), constant here means not a symbol */ + { + if (is_pair(arg)) /* (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_5(sc, wrap_string(sc, "~A parameter ~S is a pair (perhaps use lambda*?): (~S ~S ...)", 61), + car(form), arg, car(form), cadr(form))); + if ((arg == sc->rest_keyword) && + ((car(form) == sc->define_symbol) || (car(form) == sc->lambda_symbol))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_6(sc, wrap_string(sc, "~A parameter is ~S? (~S ~S ...), perhaps use ~S", 47), + car(form), arg, 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_6(sc, wrap_string(sc, "~A parameter ~S is a ~A: (~S ~S ...)", 36), + car(form), arg, key_or_constant_arg(sc, arg), car(form), cadr(form))); + } + if (symbol_is_in_small_symbol_set(sc, arg)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter ~S is used twice in the parameter list, (~S ~S ...)", 64), + car(form), arg, car(form), cadr(form))); + add_symbol_to_small_symbol_set(sc, arg); + set_local(arg); + } + if (is_not_null(args)) + { + if ((is_symbol(args)) && (symbol_is_in_small_symbol_set(sc, args))) + error_nr(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, "~A :rest parameter ~S is used earlier in the parameter list", 59), car(form), args)); + if (is_constant(sc, args)) /* (lambda (a . 0.0) a) or (lambda (a . :b) a) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_6(sc, wrap_string(sc, "~A :rest parameter ~S is a ~A in (~S ~S ...)", 44), + car(form), args, key_or_constant_arg(sc, args), car(form), cadr(form))); + i = -i - 1; + } + end_small_symbol_set(sc); + 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, pars; + 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_5(sc, wrap_string(sc, "~A parameter is a ~A: (~S ~S ...)", 33), + car(form), key_or_constant_arg(sc, args), car(form), cadr(form))); + if (is_symbol(args)) set_local(args); + return(args); + } + + has_defaults = false; + top = args; + begin_small_symbol_set(sc); + pars = args; + for (s7_pointer v = args; is_pair(pars); v = pars, pars = cdr(pars)) + { + const s7_pointer cur_par = car(pars); + if (is_pair(cur_par)) + { + has_defaults = true; + if (is_constant(sc, car(cur_par))) /* (lambda* ((:a 1)) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_6(sc, wrap_string(sc, "~A parameter ~S is a ~A: (~S ~S ...)", 36), + car(form), car(cur_par), key_or_constant_arg(sc, car(cur_par)), car(form), cadr(form))); + if (symbol_is_in_small_symbol_set(sc, car(cur_par))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter ~S is used twice in the parameter list, (~S ~S ...)", 64), + car(form), car(cur_par), car(form), cadr(form))); + add_symbol_to_small_symbol_set(sc, car(cur_par)); + if (!is_pair(cdr(cur_par))) + { + if (is_null(cdr(cur_par))) /* (lambda* ((a)) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter ~S default value missing in (~S ~S ...)", 52), + car(form), cur_par, car(form), cadr(form))); + error_nr(sc, sc->syntax_error_symbol, /* (lambda* ((a . 0.0)) a) */ + set_elist_5(sc, wrap_string(sc, "~A parameter ~S is a dotted pair in (~S ~S ...)", 47), + car(form), cur_par, car(form), cadr(form))); + } + if ((is_pair(cadr(cur_par))) && /* (lambda* ((a (quote . -1))) ...) */ + (s7_list_length(sc, cadr(cur_par)) < 0)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter ~S default value is not a proper list in (~S ~S ...)", 65), + car(form), cur_par, car(form), cadr(form))); + if (is_not_null(cddr(cur_par))) /* (lambda* ((a 0.0 'hi)) a) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter ~S has multiple default values in (~S ~S ...)", 58), + car(form), cur_par, car(form), cadr(form))); + set_local(car(cur_par)); + } + else + if (cur_par != sc->rest_keyword) + { + if (is_constant(sc, cur_par)) + { + if (cur_par != sc->allow_other_keys_keyword) + error_nr(sc, sc->syntax_error_symbol, /* (lambda* (pi) ...) */ + set_elist_6(sc, wrap_string(sc, "~A parameter ~S is a ~A: (~S ~S ...)", 36), + car(form), cur_par, key_or_constant_arg(sc, cur_par), car(form), cadr(form))); + if (is_not_null(cdr(pars))) /* (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 (pars == 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_small_symbol_set(sc, cur_par)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A parameter ~S is used twice in the parameter list, (~S ~S ...)", 64), + car(form), cur_par, car(form), cadr(form))); + add_symbol_to_small_symbol_set(sc, cur_par); + if (!is_keyword(cur_par)) set_local(cur_par); + } + else + { + has_defaults = true; + if (!is_pair(cdr(pars))) /* (lambda* (:rest) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A :rest parameter missing in (~S ~S ...)", 41), + car(form), car(form), cadr(form))); + if (!is_symbol(cadr(pars))) /* (lambda* (:rest (a 1)) ...) */ + { + if (!is_pair(cadr(pars))) /* (lambda* (:rest 1) ...) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_5(sc, wrap_string(sc, "~A :rest parameter is not a symbol: ~S in (~S ~S ...)", 53), + car(form), pars, car(form), cadr(form))); + error_nr(sc, sc->syntax_error_symbol, /* (lambda* (:rest '(1 2)) 1) */ + set_elist_5(sc, wrap_string(sc, "~A :rest parameter can't have a default value: ~S in (~S ~S ...)", 64), + car(form), pars, car(form), cadr(form))); + } + if (is_constant(sc, cadr(pars))) /* (lambda* (a :rest x) ...) where x is locally a constant */ + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_5(sc, wrap_string(sc, "~A: ~S is immutable, so it can't be the :rest parameter name: (~S ~S ...)", 73), + car(form), cadr(pars), car(form), cadr(form))); + set_local(cadr(pars)); + }} + if (is_not_null(pars)) + { + if ((is_symbol(pars)) && (symbol_is_in_small_symbol_set(sc, pars))) + error_nr(sc, sc->syntax_error_symbol, set_elist_3(sc, wrap_string(sc, "~A :rest parameter ~S is used earlier in the parameter list", 59), car(form), pars)); + if (is_constant(sc, pars)) /* (lambda* (a 0.0) a) or (lambda* (a :b) a) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_6(sc, wrap_string(sc, "~A :rest parameter ~S is a ~A, (~S ~S ...)", 42), + car(form), pars, key_or_constant_arg(sc, pars), car(form), cadr(form))); + if (is_symbol(pars)) + set_local(pars); + } + else + if ((body) && (!has_defaults) && (is_pair(args))) + set_has_no_defaults(body); + end_small_symbol_set(sc); + 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 form, bool at_end) /* called only from body_is_safe */ +{ + const s7_pointer expr = car(form); + body_t result = very_safe_body; + + if (is_symbol_and_syntactic(expr)) + { + if (!is_pair(cdr(form))) return(unsafe_body); + switch (symbol_syntax_op_checked(form)) + /* 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(form), at_end)); + + case OP_MACROEXPAND: + return(unsafe_body); + + case OP_QUOTE: case OP_QUOTE_UNCHECKED: + return(((!is_pair(cdr(form))) || (!is_null(cddr(form)))) ? unsafe_body : very_safe_body); /* (quote . 1) or (quote 1 2) etc */ + + case OP_IF: + if (!is_pair(cddr(form))) return(unsafe_body); + if (is_pair(cadr(form))) + { + result = form_is_safe(sc, func, cadr(form), false); + if (result == unsafe_body) return(unsafe_body); + } + if (is_pair(caddr(form))) + { + result = min_body(result, form_is_safe(sc, func, caddr(form), at_end)); + if (result == unsafe_body) return(unsafe_body); + } + if ((is_pair(cdddr(form))) && + (is_pair(cadddr(form)))) + return(min_body(result, form_is_safe(sc, func, cadddr(form), at_end))); + return(result); + + case OP_WHEN: case OP_UNLESS: + if (!is_pair(cddr(form))) return(unsafe_body); + if (is_pair(cadr(form))) + { + result = form_is_safe(sc, func, cadr(form), false); + if (result == unsafe_body) return(unsafe_body); + } + return(min_body(result, body_is_safe(sc, func, cddr(form), at_end))); + + case OP_COND: + { + bool follow = false; + s7_pointer clauses = cdr(form); + for (s7_pointer sp = form; is_pair(clauses); clauses = cdr(clauses)) + { + const s7_pointer clause = car(clauses); + if (!is_pair(clause)) return(unsafe_body); + if (is_pair(car(clause))) + { + result = min_body(result, form_is_safe(sc, func, car(clause), false)); + if (result == unsafe_body) return(unsafe_body); + } + if (is_pair(cdr(clause))) + { + result = min_body(result, body_is_safe(sc, func, cdr(clause), at_end)); + if (result == unsafe_body) return(unsafe_body); + } + if (follow) {sp = cdr(sp); if (clauses == sp) return(unsafe_body);} + follow = (!follow); + } + return((is_null(clauses)) ? result : unsafe_body); + } + + case OP_CASE: + { + bool follow = false; + s7_pointer sp; + if (!is_pair(cddr(form))) return(unsafe_body); + if (is_pair(cadr(form))) + { + result = form_is_safe(sc, func, cadr(form), false); + if (result == unsafe_body) return(unsafe_body); + } + sp = cdr(form); + for (s7_pointer clauses = cdr(sp); is_pair(clauses); clauses = cdr(clauses)) + { + if (!is_pair(car(clauses))) return(unsafe_body); + if (is_pair(cdar(clauses))) + { + result = min_body(result, body_is_safe(sc, func, cdar(clauses), at_end)); /* null cdar(p) ok here */ + if (result == unsafe_body) return(unsafe_body); + } + if (follow) {sp = cdr(sp); if (clauses == 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(form))) return(unsafe_body); + if (cadr(form) == func) return(unsafe_body); + + /* car(form) is set!, cadr(form) is settee or obj, caddr(form) is val */ + if (is_pair(caddr(form))) + { + result = form_is_safe(sc, func, caddr(form), false); + if (result == unsafe_body) return(unsafe_body); + } + return((is_pair(cadr(form))) ? min_body(result, form_is_safe(sc, func, cadr(form), false)) : result); + /* not OP_DEFINE even in simple cases (safe_closure assumes constant funclet) */ + + case OP_WITH_LET: + if (!is_pair(cddr(form))) return(unsafe_body); + return((is_pair(cadr(form))) ? unsafe_body : min_body(body_is_safe(sc, sc->F, cddr(form), 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(form))) return(unsafe_body); + for (s7_pointer vars = cadr(form); is_pair(vars); vars = cdr(vars)) + { + if ((!is_pair(car(vars))) || + (!is_pair(cdar(vars)))) + return(unsafe_body); + if (is_pair(cadar(vars))) + { + result = min_body(result, form_is_safe(sc, sc->F, cadar(vars), false)); + if (result == unsafe_body) return(unsafe_body); + }} + return(min_body(result, body_is_safe(sc, sc->F, cddr(form), 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, vars = cadr(form), body = cddr(form); + 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(form); + body = cdddr(form); + if (is_symbol(func)) + add_symbol_to_small_symbol_set(sc, func); + } + else let_name = func; + + for (s7_pointer sp = NULL; is_pair(vars); vars = cdr(vars)) + { + const s7_pointer let_var = car(vars); + s7_pointer 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_small_symbol_set(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(form))) return(unsafe_body); + if (is_pair(cadr(form))) + { + s7_pointer vars = cadr(form); + s7_pointer sp = vars; + for (bool follow = false; is_pair(vars); vars = cdr(vars)) + { + const 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_small_symbol_set(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(form))) + result = min_body(result, body_is_safe(sc, func, caddr(form), at_end)); + return(min_body(result, body_is_safe(sc, func, cdddr(form), 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(form) is not syntactic */ + { + if (expr == func) /* try to catch tail call, expr is car(form) */ + { + bool follow = false; + s7_pointer sp = form, p; + sc->got_rec = true; /* (walk (car tree)) lint and almost all others in s7test */ + set_rec_tc_args(sc, proper_list_length(cdr(form))); + if (!at_end) {result = recur_body; sc->not_tc = true;} + for (p = cdr(form); 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(form))); + return(result); + } + if (result != unsafe_body) result = recur_body; + return(result); + } + if (is_symbol(expr)) /* expr=car(form) */ + { + s7_pointer head_f, f_slot; + bool c_safe; + + if (symbol_is_in_small_symbol_set(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); + + head_f = slot_value(f_slot); + if (is_c_function(head_f)) + { + if ((expr == sc->apply_symbol) && (is_pair(cdr(form))) && (is_symbol(cadr(form)))) /* (apply ...) */ + { + s7_pointer apply_f = lookup_unexamined(sc, cadr(form)); /* "unexamined" to skip unbound_variable */ + c_safe = ((apply_f) && /* (apply_f != sc->undefined) && */ + ((is_safe_c_function(apply_f)) || + ((is_closure(apply_f)) && (is_very_safe_closure(apply_f))))); + } + else c_safe = (is_safe_or_scope_safe_procedure(head_f)); + } + else c_safe = false; + + result = ((is_simple_sequence(head_f)) || /* was is_sequence? */ + ((is_closure(head_f)) && (is_very_safe_closure(head_f))) || + ((c_safe) && ((is_immutable_slot(f_slot)) || (is_defined_global(expr))))) ? very_safe_body : safe_body; + + if ((c_safe) || + ((is_any_closure(head_f)) && (is_safe_closure(head_f))) || + (is_simple_sequence(head_f))) /* was is_sequence? */ + { + bool follow = false; + s7_pointer sp = form, p = cdr(form); + + 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(head_f)) && (is_scope_safe(head_f)) && + (caar(p) == sc->lambda_symbol)) + { + s7_pointer argp, lbody; + body_t lresult; + + if (!is_pair(cdar(p))) /* (lambda . /) */ + return(unsafe_body); + argp = cadar(p); + lbody = cddar(p); + for (s7_pointer q = argp; is_pair(q); q = cdr(q)) + { + if (!is_symbol(car(q))) + return(unsafe_body); + add_symbol_to_small_symbol_set(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(form)))) + return(result); + + if (expr == sc->values_symbol) /* (values) is safe, as is (values x) if x is: (values (define...)) */ + { + if (is_null(cdr(form))) return(result); + if ((is_pair(cdr(form))) && (is_null(cddr(form)))) + return((is_pair(cadr(form))) ? min_body(result, form_is_safe(sc, func, cadr(form), false)) : result); + }} + else + if (expr == sc->quote_function) + return(((!is_pair(cdr(form))) || (!is_null(cddr(form)))) ? 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 forms = body; + body_t result = very_safe_body; + for (s7_pointer sp = body; is_pair(forms); forms = cdr(forms)) + { + if (is_pair(car(forms))) + { + result = min_body(result, form_is_safe(sc, func, car(forms), (at_end) && (is_null(cdr(forms))))); + if (result == unsafe_body) return(unsafe_body); + } + if (forms != body) /* checking for cycles -- this can happen (t101-1.scm) */ + { + if (follow) {sp = cdr(sp); if (forms == sp) return(unsafe_body);} + follow = (!follow); + }} + return((is_null(forms)) ? result : unsafe_body); +} + +static body_t wrapped_body_is_safe(s7_scheme *sc, s7_pointer func, s7_pointer body, bool at_end) +{ + body_t result; + begin_small_symbol_set(sc); + result = body_is_safe(sc, func, body, at_end); + end_small_symbol_set(sc); + return(result); +} + +static bool tree_has_definer_or_binder(s7_scheme *sc, s7_pointer tree) +{ + for (s7_pointer p = tree; is_pair(p); p = cdr(p)) + if (tree_has_definer_or_binder(sc, car(p))) + return(true); + return((is_symbol(tree)) && + (is_definer_or_binder(tree))); +} + +#define rec_test_clause(p) opt2_pair(p) +#define rec_done_clause(p) opt1_pair(p) +#define rec_call_clause(p) opt3_pair(p) +#define rec_set_test_clause(p, c) set_opt2_pair(p, T_Pair(c)) /* these check T_Lst in set_opt2_pair, but here we want pairs */ +#define rec_set_done_clause(p, c) set_opt1_pair(p, T_Pair(c)) +#define rec_set_call_clause(p, c) set_opt3_pair(p, T_Pair(c)) + +static bool check_recur_if_and_cond(s7_scheme *sc, const s7_pointer name, int32_t pars, s7_pointer args, s7_pointer body) +{ + const bool if_case = car(body) == sc->if_symbol; + const s7_pointer test = (if_case) ? cadr(body) : caadr(body); /* (if test...) or (cond ((test...))) */ + /* if ((S7_DEBUGGING) && ((pars < 1) || (pars > 3))) fprintf(stderr, "%s[%d]: pars: %d\n", __func__, __LINE__, pars); */ + if (is_fxable(sc, test)) /* pars prechecked to be 1 <= pars <= 3 */ + { + const s7_pointer true_p = (if_case) ? caddr(body) : cadr(cadr(body)); + const s7_pointer false_p = (if_case) ? cadddr(body) : cadr(caddr(body)); + int true_case = -1; + if ((!if_case) && + ((!is_proper_list_2(sc, cadr(body))) || /* if !if_case, we want (cond (a b) (else|#t c)) */ + (!is_proper_list_2(sc, caddr(body))))) + return(false); + if ((is_fxable(sc, true_p)) && (is_proper_list_3(sc, false_p)) && (is_h_optimized(false_p))) /* the c-op -- true_p is done*/ + true_case = 0; + else + if ((is_fxable(sc, false_p)) && (is_proper_list_3(sc, true_p)) && (is_h_optimized(true_p))) /* true_p is call */ + true_case = 1; + if (true_case >= 0) /* (if expr z (op (name x) (name y))) or (if expr (op (name...)...) z */ + { + const bool true_quits = (true_case == 0); + const s7_pointer calls = true_quits ? cdr(false_p) : cdr(true_p); + const s7_pointer call1 = car(calls); + const s7_pointer call2 = cadr(calls); + bool call1_fxable; + + if ((((pars == 1) && (is_proper_list_2(sc, call1)) && (is_proper_list_2(sc, call2))) || + ((pars == 2) && (is_proper_list_3(sc, call1)) && (is_proper_list_3(sc, call2))) || + ((pars == 3) && (is_proper_list_4(sc, call1)) && (is_proper_list_4(sc, call2)))) && + (car(call1) == name) && (car(call2) == name) && + (is_fxable(sc, cadr(call1))) && (is_fxable(sc, cadr(call2))) && + ((pars == 1) || ((is_fxable(sc, caddr(call1))) && (is_fxable(sc, caddr(call2))))) && + ((pars <= 2) || ((is_fxable(sc, cadddr(call1))) && (is_fxable(sc, cadddr(call2)))))) + { + rec_set_test_clause(body, (if_case) ? cdr(body) : cadr(body)); + rec_set_done_clause(body, (true_quits) ? ((if_case) ? cddr(body) : cdadr(body)) : ((if_case) ? cdddr(body) : cdaddr(body))); + rec_set_call_clause(body, car((true_quits) ? ((if_case) ? cdddr(body) : cdaddr(body)) : ((if_case) ? cddr(body) : cdadr(body)))); + if (true_quits) set_true_is_done(body); + set_safe_optimize_op(body, (pars == 1) ? OP_RECUR_IF_A_A_opLA_LAq : + ((pars == 2) ? OP_RECUR_IF_A_A_opL2A_L2Aq : OP_RECUR_IF_A_A_opL3A_L3Aq)); + fx_annotate_args(sc, cdr(call1), args); + fx_annotate_args(sc, cdr(call2), args); + fx_annotate_arg(sc, rec_test_clause(body), args); + fx_annotate_arg(sc, rec_done_clause(body), args); + fx_tree(sc, cdr(body), car(args), (pars >= 2) ? cadr(args) : NULL, (pars == 3) ? caddr(args) : NULL, false); + return(true); + } + + call1_fxable = is_fxable(sc, call1); + if (((call1_fxable) && + (((pars == 1) && (is_proper_list_2(sc, call2))) || + ((pars == 2) && (is_proper_list_3(sc, call2))) || + ((pars == 3) && (is_proper_list_4(sc, call2)))) && + (car(call2) == name) && (is_fxable(sc, cadr(call2))) && + ((pars == 1) || (is_fxable(sc, caddr(call2)))) && + ((pars <= 2) || (is_fxable(sc, cadddr(call2))))) || + ((is_fxable(sc, call2)) && + (((pars == 1) && (is_proper_list_2(sc, call1))) || + ((pars == 2) && (is_proper_list_3(sc, call1))) || + ((pars == 3) && (is_proper_list_4(sc, call1)))) && + (car(call1) == name) && (is_fxable(sc, cadr(call1))) && + ((pars == 1) || (is_fxable(sc, caddr(call1)))) && + ((pars <= 2) || (is_fxable(sc, cadddr(call1)))))) + { + rec_set_test_clause(body, (if_case) ? cdr(body) : cadr(body)); + rec_set_done_clause(body, (true_quits) ? ((if_case) ? cddr(body) : cdadr(body)) : ((if_case) ? cdddr(body) : cdaddr(body))); + rec_set_call_clause(body, car((true_quits) ? ((if_case) ? cdddr(body) : cdaddr(body)) : ((if_case) ? cddr(body) : cdadr(body)))); + rec_set_call_clause(rec_call_clause(body), (call1_fxable) ? caddr(rec_call_clause(body)) : cadr(rec_call_clause(body))); + if (call1_fxable) set_a_is_cadr(rec_call_clause(body)); + if (true_quits) set_true_is_done(body); + set_safe_optimize_op(body, (pars == 1) ? OP_RECUR_IF_A_A_opA_LAq : + ((pars == 2) ? OP_RECUR_IF_A_A_opA_L2Aq : OP_RECUR_IF_A_A_opA_L3Aq)); + fx_annotate_arg(sc, (call1_fxable) ? calls : cdr(calls), args); /* call1 == car(calls) */ + fx_annotate_args(sc, (call1_fxable) ? cdr(call2) : cdr(call1), args); + fx_annotate_arg(sc, rec_test_clause(body), args); + fx_annotate_arg(sc, rec_done_clause(body), args); + fx_tree(sc, cdr(body), car(args), (pars >= 2) ? cadr(args) : NULL, (pars == 3) ? caddr(args) : NULL, false); + return(true); + }}} + return(false); +} + +static bool check_recur_if(s7_scheme *sc, const s7_pointer name, int32_t pars, s7_pointer args, s7_pointer body) +{ + const s7_pointer test = cadr(body); + if (is_fxable(sc, test)) /* if_(A)... */ + { + const s7_pointer obody = cddr(body); + s7_pointer call = NULL; + const s7_pointer true_p = car(obody); /* if_a_(A)... */ + const s7_pointer false_p = cadr(obody); /* if_a_a_(A) */ + + if ((pars <= 3) && + (is_fxable(sc, true_p)) && + (is_proper_list_4(sc, false_p))) + { + if (car(false_p) == sc->if_symbol) /* if_a_a_(if...) */ + { + const s7_pointer test2 = cadr(false_p); + const s7_pointer true2 = caddr(false_p); + const s7_pointer false2 = cadddr(false_p); + if ((is_fxable(sc, test2)) && + (is_proper_list_3(sc, false2)) && /* opa_l2aq or opl2a_l2aq */ + (is_h_optimized(false2))) /* the c-op */ + { + const s7_pointer la1 = cadr(false2); + const s7_pointer la2 = caddr(false2); + if ((is_fxable(sc, true2)) && + (((pars == 1) && (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2))) || + ((pars == 2) && (is_proper_list_3(sc, la1)) && (is_proper_list_3(sc, la2))) || + ((pars == 3) && (is_proper_list_4(sc, la1)) && (is_proper_list_4(sc, la2)))) && + (car(la1) == name) && (car(la2) == name) && + (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && + ((pars == 1) || ((is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2))))) && + ((pars <= 2) || ((is_fxable(sc, cadddr(la1))) && (is_fxable(sc, cadddr(la2)))))) + { + set_safe_optimize_op(body, (pars == 1) ? OP_RECUR_IF_A_A_IF_A_A_opLA_LAq : + ((pars == 2) ? OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq : OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq)); + 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), (pars >= 2) ? cadr(args) : NULL, (pars == 3) ? caddr(args) : NULL, false); + + rec_set_done_clause(body, cdr(false_p)); /* opt1 */ + rec_set_test_clause(body, cdr(body)); /* opt2 */ + rec_set_call_clause(body, false2); /* opt3 */ + rec_set_call_clause(false2, cdr(la2)); + + return(true); + } + if ((pars == 2) && (is_fxable(sc, cadr(false2))) && + (is_proper_list_3(sc, true2)) && (car(true2) == name) && (is_fxable(sc, cadr(true2))) && (is_fxable(sc, caddr(true2))) && + (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_IF_A_A_IF_A_L2A_opA_L2Aq); + 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_l2a_op(A).. */ + fx_annotate_args(sc, cdr(la2), args); /* if_a_a_if_a_l2a_opa_l(AA)q */ + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + rec_set_call_clause(body, false2); + rec_set_call_clause(false2, la2); + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cddr(body)); + rec_set_done_clause(cdr(body), cdr(cadddr(body))); + return(true); + }}} + + if (car(false_p) == sc->and_symbol) + { + const s7_pointer a1 = cadr(false_p); + const s7_pointer a2 = caddr(false_p); + const 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_L2A_L2A); + 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_l2a_l(AA) */ + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + rec_set_call_clause(body, false_p); + return(true); + }}} + + /* this is ok, but no cond */ + 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)))) + call = false_p; /* if_a_a_call */ + 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)))) + call = true_p; /* if_a_call_a */ + + if ((call) && (pars == 1) && (is_pair(cdddr(call))) && (is_null(cddddr(call)))) /* 3 args */ + { + const s7_pointer la1 = cadr(call); + const s7_pointer la2 = caddr(call); + const s7_pointer la3 = cadddr(call); + 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)))) + { + set_safe_optimize_op(body, OP_RECUR_IF_A_A_opLA_LA_LAq); /* these two need cond? */ + fx_annotate_arg(sc, cdr(la1), args); + } + else + if (is_fxable(sc, la1)) + { + set_safe_optimize_op(body, OP_RECUR_IF_A_A_opA_LA_LAq); + fx_annotate_arg(sc, cdr(call), args); + } + else return(false); + fx_annotate_arg(sc, cdr(body), args); /* test */ + if (call == cadddr(body)) + { + set_true_is_done(body); + fx_annotate_arg(sc, cddr(body), args); /* result */ + } + else fx_annotate_arg(sc, cdddr(body), args); + fx_annotate_arg(sc, cdr(la2), args); /* call args 2 and 3 */ + fx_annotate_arg(sc, cdr(la3), args); + fx_tree(sc, cdr(body), car(args), NULL, NULL, false); + rec_set_call_clause(body, call); + rec_set_call_clause(call, la3); + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, (true_is_done(body)) ? cddr(body) : cdddr(body)); + return(true); + }}} /* if (is_fxable(sc, test)) at top */ + return(false); +} + +static bool check_recur(s7_scheme *sc, s7_pointer name, int32_t pars, s7_pointer args, s7_pointer body) +{ + /* if (proper_list_length(args) != pars) return(false); */ + if ((((car(body) == sc->if_symbol) && (proper_list_length(body) == 4)) || /* (if a a opla) */ + ((car(body) == sc->cond_symbol) && (proper_list_length(body) == 3) && + ((caaddr(body) == sc->else_symbol) || (caaddr(body) == sc->T)))) && /* (cond ((a a)) (else|#t opla)) */ + (pars > 0) && (pars <= 3) && + (check_recur_if_and_cond(sc, name, pars, args, body))) + return(true); + + if ((car(body) == sc->if_symbol) && + (proper_list_length(body) == 4)) + return(check_recur_if(sc, name, pars, args, body)); + + if ((car(body) == sc->and_symbol) && + (pars == 2) && + (proper_list_length(body) == 3) && + (proper_list_length(caddr(body)) == 4) && + (caaddr(body) == sc->or_symbol) && + (is_fxable(sc, cadr(body)))) + { + const s7_pointer or_p = caddr(body); + const s7_pointer la1 = caddr(or_p); + const 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_L2A_L2A); + 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); + rec_set_call_clause(body, or_p); + return(true); + }} + + if (car(body) == sc->cond_symbol) + { + const s7_pointer clause = cadr(body); + s7_pointer 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); + const 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->T) || + ((car(la_clause) == sc->else_symbol) && (is_global(sc->else_symbol)))) && + (is_pair(cadr(la_clause)))) + { + la_clause = cadr(la_clause); /* (c_op arg (recur par)) or (c_op (recur) (recur)) or (op|l a l2a) */ + if (is_proper_list_2(sc, cdr(la_clause))) + { + if (is_h_optimized(la_clause)) + { + if ((is_fxable(sc, cadr(la_clause))) && + (len == 4) && (pars == 2) && + (is_proper_list_3(sc, cadr(clause2))) && + (caadr(clause2) == name)) + { + const s7_pointer la = caddr(la_clause); + if ((is_pair(la)) && (car(la) == name) && (is_pair(cdr(la))) && (is_fxable(sc, cadr(la))) && + (is_pair(cddr(la))) && (is_fxable(sc, caddr(la))) && (is_null(cdddr(la)))) + { + const s7_pointer l2a = cadr(clause2); + if ((is_fxable(sc, cadr(l2a))) && /* args to first l2a */ + (is_fxable(sc, caddr(l2a)))) + { + set_safe_optimize_op(body, OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq); + fx_annotate_arg(sc, clause2, args); + fx_annotate_args(sc, cdr(l2a), args); + rec_set_call_clause(body, la_clause); + rec_set_test_clause(body, cadr(body)); + rec_set_done_clause(body, cdadr(body)); + rec_set_done_clause(cdr(body), caddr(body)); + } + 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), cadr(args), NULL, false); + rec_set_call_clause(la_clause, la); + return(true); + }} + else + { + if ((len == 4) && + (is_fxable(sc, cadr(clause2)))) + { + const s7_pointer la1 = cadr(la_clause); + const s7_pointer la2 = caddr(la_clause); + bool happy = false; + + if ((((pars == 1) && (is_proper_list_2(sc, la1)) && (is_proper_list_2(sc, la2))) || + ((pars == 2) && (is_proper_list_3(sc, la1)) && (is_proper_list_3(sc, la2))) || + ((pars == 3) && (is_proper_list_4(sc, la1)) && (is_proper_list_4(sc, la2)))) && + (car(la1) == name) && (car(la2) == name) && + (is_fxable(sc, cadr(la1))) && (is_fxable(sc, cadr(la2))) && + ((pars == 1) || ((is_fxable(sc, caddr(la1))) && (is_fxable(sc, caddr(la2))))) && + ((pars <= 2) || ((is_fxable(sc, cadddr(la1))) && (is_fxable(sc, cadddr(la2)))))) + { + set_safe_optimize_op(body, (pars == 1) ? OP_RECUR_IF_A_A_IF_A_A_opLA_LAq : + ((pars == 2) ? OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq : OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq)); + fx_annotate_args(sc, cdr(la1), args); + rec_set_done_clause(body, caddr(body)); /* opt1 -- not "done" */ + rec_set_test_clause(body, cadr(body)); /* opt2 */ + happy = true; + } + else + if ((pars == 2) && (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_A_opA_L2Aq); /* see if_a_a_if_a_l2a_opa_l2a, first l2a->a */ + fx_annotate_arg(sc, cdr(la_clause), args); + happy = true; + } + if (happy) + { + 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), (pars > 1) ? cadr(args) : NULL, (pars == 3) ? caddr(args) : NULL, false); + rec_set_call_clause(body, la_clause); /* opt3 */ + rec_set_call_clause(la_clause, cdr(la2)); + return(true); + }}}} + else + { + if (clause2) + { + const s7_pointer l2a = cadr(clause2); + if ((pars == 2) && (len == 4) && + (is_proper_list_3(sc, l2a)) && (car(l2a) == name) && (is_fxable(sc, cadr(l2a))) && (is_fxable(sc, caddr(l2a)))) + { + const s7_pointer la1 = cadr(la_clause); + const 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_L2A_LopA_L2Aq); + fx_annotate_args(sc, clause, args); + fx_annotate_arg(sc, clause2, args); + fx_annotate_args(sc, cdr(l2a), 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); + rec_set_call_clause(body, la_clause); + rec_set_call_clause(la_clause, cdr(la2)); + return(true); + }}}}}}}} + return(false); +} + +static bool check_tc_when(s7_scheme *sc, const s7_pointer name, int32_t pars, s7_pointer args, s7_pointer body) +{ + const s7_pointer test_expr = cadr(body); /* car(body) == sc->when_symbol or sc->unless_symbol */ + 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)) + { + const s7_pointer l2a = car(p); + set_opt3_pair(body, p); + if ((is_pair(cdr(l2a))) && (is_fxable(sc, cadr(l2a)))) + { + if (is_null(cddr(l2a))) + { + if (pars != 1) return(false); + set_safe_optimize_op(body, OP_TC_WHEN_LA); + } + else + if (is_fxable(sc, caddr(l2a))) + { + if (is_null(cdddr(l2a))) + { + if (pars != 2) return(false); + set_safe_optimize_op(body, OP_TC_WHEN_L2A); + } + else + if ((pars == 3) && (is_fxable(sc, cadddr(l2a))) && (is_null(cddddr(l2a)))) + set_safe_optimize_op(body, OP_TC_WHEN_L3A); + else return(false); + } + if (car(body) == sc->unless_symbol) set_true_is_done(body); + fx_annotate_arg(sc, cdr(body), args); + for (s7_pointer p1 = cddr(body); is_pair(cdr(p1)); p1 = cdr(p1)) + fx_annotate_arg(sc, p1, args); + fx_annotate_args(sc, cdr(l2a), args); + fx_tree(sc, cdr(body), car(args), (pars > 1) ? cadr(args) : NULL, (pars > 2) ? caddr(args) : NULL, false); + return(true); + }}} + return(false); +} + +static bool check_tc_case(s7_scheme *sc, s7_pointer name, s7_pointer arg_names, s7_pointer body) +{ + /* pars == 1|2|3, opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */ + /* it might be useful to add int keys and no-else-clause */ + s7_pointer clauses; + s7_int len; + const s7_int pars = proper_list_length(arg_names); + 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))) /* one key */ + { + if (!is_simple(caar(clause))) /* || (is_t_integer(caar(clause))))) need eqv here for ints */ + return(false); + set_opt1_any(clauses, caar(clause)); /* save clause key as opt1_any */ + } + 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, arg_names); + set_opt2_any(clauses, result); /* fx'd result expr is opt2_any */ + } + else + { + const s7_int local_pars = proper_list_length(cdar(result)); + if ((caar(result) == name) && + (((pars == 1) && (local_pars == 1)) || ((pars == 2) && (local_pars == 2)) || ((pars == 3) && (local_pars == 3))) && + (is_fxable(sc, cadar(result))) && + ((pars == 1) || (is_fxable(sc, caddar(result)))) && + ((pars <= 2) || (is_fxable(sc, car(cdddar(result)))))) + { + set_has_tc(car(result)); + set_opt2_any(clauses, car(result)); + fx_annotate_args(sc, cdar(result), arg_names); + } + 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, (pars == 1) ? OP_TC_CASE_LA : ((pars == 2) ? OP_TC_CASE_L2A : OP_TC_CASE_L3A)); + set_opt3_arglen(cdr(body), len); + fx_annotate_arg(sc, cdr(body), arg_names); + fx_tree(sc, cdr(body), car(arg_names), (pars == 1) ? NULL : cadr(arg_names), (pars <= 2) ? NULL : caddr(arg_names), false); /* check_tc limits pars to <= 3 */ + if (results_fxable) set_optimized(body); + return(results_fxable); +} + +static bool check_tc_cond_n(s7_scheme *sc, const s7_pointer name, int32_t pars, s7_pointer args, s7_pointer cond_form) +{ + bool all_fxable = true; + for (s7_pointer p = cdr(cond_form); is_pair(p); p = cdr(p)) + { + const 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->T) && + ((car(clause) != sc->else_symbol) || (!is_global(sc->else_symbol)))) || + ((tree_count(sc, name, clause, 0) == 1) && + (name != caadr(clause)))) + 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 != pars) + return(false); + }} + else return(false); + } + set_optimize_op(cond_form, OP_TC_COND_N); /* body=cond_form?? */ + set_opt3_arglen(cdr(cond_form), pars); /* same */ + for (s7_pointer p = cdr(cond_form); is_pair(p); p = cdr(p)) + { + const s7_pointer clause = car(p); + const s7_pointer result = cadr(clause); + fx_annotate_arg(sc, clause, args); + if ((is_pair(result)) && (car(result) == name)) /* pars = args checked above */ + { + 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; + if (pars > 0) + fx_tree(sc, clause, car(args), (pars > 1) ? cadr(args) : NULL, (pars > 2) ? caddr(args) : NULL, pars > 3); + } + if (all_fxable) set_optimized(cond_form); + return(all_fxable); +} + +static bool check_tc_cond(s7_scheme *sc, s7_pointer name, int32_t pars, s7_pointer args, s7_pointer body) +{ + s7_pointer p = cdr(body); + const s7_pointer clause1 = car(p); + const s7_int names = tree_count(sc, name, body, 0); + const s7_int body_len = proper_list_length(body); + + if ((!is_proper_list_2(sc, clause1)) || (!is_fxable(sc, car(clause1)))) /* cond_a... */ + return(false); + + p = cdr(p); + if ((pars < 4) && (names == 1) && (body_len == 3)) + { + if (((caar(p) == sc->T) || ((caar(p) == sc->else_symbol) && (is_global(sc->else_symbol))))) + { /* body len=3, (cond clause1 else */ + const s7_pointer else_clause = cdar(p); + if (tree_count(sc, name, body, 0) != 1) return(false); + 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))) && + (((pars == 1) && (is_null(cddr(la)))) || + ((pars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la)))) || + ((pars == 3) && (is_pair(cddr(la))) && (is_pair(cdddr(la))) && (is_null(cdr(cdddr(la)))) && + (is_fxable(sc, caddr(la))) && (is_fxable(sc, cadddr(la)))))) + { + const bool zs_fxable = is_fxable(sc, cadr(clause1)); + set_optimize_op(body, (pars == 1) ? OP_TC_IF_A_Z_LA : ((pars == 2) ? OP_TC_IF_A_Z_L2A : OP_TC_IF_A_Z_L3A)); + if (zs_fxable) fx_annotate_arg(sc, cdr(clause1), args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), (pars < 2) ? NULL : cadr(args), (pars < 3) ? NULL : caddr(args), false); + if (zs_fxable) set_optimized(body); + rec_set_test_clause(body, cadr(body)); + rec_set_done_clause(body, cdadr(body)); + rec_set_call_clause(body, cdadr(caddr(body))); + set_true_is_done(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))) && + (((pars == 1) && (is_null(cddr(la)))) || + ((pars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_fxable(sc, caddr(la)))) || + ((pars == 3) && (is_pair(cddr(la))) && (is_pair(cdddr(la))) && (is_null(cdr(cdddr(la)))) && + (is_fxable(sc, caddr(la))) && (is_fxable(sc, cadddr(la)))))) + { + const bool zs_fxable = is_fxable(sc, car(else_clause)); + set_optimize_op(body, (pars == 1) ? OP_TC_IF_A_Z_LA : ((pars == 2) ? OP_TC_IF_A_Z_L2A : OP_TC_IF_A_Z_L3A)); + if (zs_fxable) fx_annotate_arg(sc, else_clause, args); + fx_annotate_args(sc, cdr(la), args); + fx_tree(sc, cdr(body), car(args), (pars < 2) ? NULL : cadr(args), (pars < 3) ? NULL : caddr(args), false); + if (zs_fxable) set_optimized(body); + rec_set_test_clause(body, cadr(body)); + rec_set_done_clause(body, cdaddr(body)); + rec_set_call_clause(body, cdadr(cadr(body))); + return(zs_fxable); + }}}} + return(false); + }} /* end body len=3, (cond clause1 else */ + + if ((pars < 4) && (body_len == 4)) + { + const s7_pointer clause2 = car(p); + if ((is_proper_list_2(sc, clause2)) && + (is_fxable(sc, car(clause2)))) + { + const s7_pointer else_p = cdr(p); + const s7_pointer else_clause = car(else_p); + + if ((is_proper_list_2(sc, else_clause)) && + ((car(else_clause) == sc->T) || ((car(else_clause) == sc->else_symbol) && (is_global(sc->else_symbol))))) + { + bool zs_fxable = true; + if ((pars == 2) && /* ...l2a_l2a 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_L2A_L2A); + 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)); /* done_clause?? */ + if (zs_fxable) set_optimized(body); + return(zs_fxable); + } + + if ((names == 1) && /* needed to filter out cond_a_a_a_l2a_opa_l2a */ + + (((is_pair(cadr(else_clause))) && (caadr(else_clause) == name) && + (is_pair(cdadr(else_clause))) && (is_fxable(sc, cadadr(else_clause))) && + (((pars == 1) && (is_null(cddadr(else_clause)))) || + ((pars == 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))) && + (((pars == 1) && (is_null(cddadr(clause2)))) || + ((pars == 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 (pars == 1) + { + if ((is_pair(cadr(else_clause))) && (caadr(else_clause) == name)) + set_optimize_op(body, OP_TC_IF_A_Z_IF_A_Z_LA); + else + { + set_optimize_op(body, OP_TC_IF_A_Z_IF_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_IF_A_Z_IF_A_Z_L2A); + } + else + { + set_optimize_op(body, OP_TC_IF_A_Z_IF_A_L2A_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), (pars == 2) ? cadr(args) : NULL, NULL, false); + if (zs_fxable) set_optimized(body); + return(zs_fxable); + }}}} + return(check_tc_cond_n(sc, name, pars, args, body)); +} + +static bool check_tc_let(s7_scheme *sc, const s7_pointer name, int32_t pars, s7_pointer args, s7_pointer body) +{ + const s7_pointer let_body = caddr(body); /* body: (let ((x (- y 1))) (if (<= x 0) 0 (f1 (- x 1)))) etc */ + if (((pars == 2) && ((car(let_body) == sc->if_symbol) || (car(let_body) == sc->when_symbol) || (car(let_body) == sc->unless_symbol))) || + ((pars == 1) && (car(let_body) == sc->if_symbol))) + { + const 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)))) + { + const s7_pointer l2a = cadddr(let_body); + if ((is_pair(l2a)) && /* else caddr is l2a and cadddr is z */ + (car(l2a) == name) && + (((pars == 1) && (is_proper_list_2(sc, l2a))) || + ((pars == 2) && (is_proper_list_3(sc, l2a)) && (is_safe_fxable(sc, caddr(l2a))))) && + (is_fxable(sc, cadr(l2a)))) + { + bool z_fxable; + set_optimize_op(body, (pars == 1) ? OP_TC_LET_IF_A_Z_LA : OP_TC_LET_IF_A_Z_L2A); + fx_annotate_arg(sc, cdaadr(body), args); /* let var binding, caadr: (x (- y 1)) etc */ + fx_tree(sc, cdaadr(body), car(args), (pars == 1) ? NULL : cadr(args), NULL, false); /* these are references to l2a args, applied to the let var binding */ + fx_annotate_arg(sc, cdr(let_body), args); /* test_expr */ + fx_annotate_args(sc, cdr(l2a), 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), (pars == 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)) + { + const s7_pointer l2a = car(p); + if ((is_fxable(sc, cadr(l2a))) && + (is_safe_fxable(sc, caddr(l2a)))) + { + set_optimize_op(body, OP_TC_LET_WHEN_L2A); + fx_annotate_arg(sc, cdaadr(body), args); /* outer var */ + fx_annotate_arg(sc, cdr(let_body), args); /* test */ + for (s7_pointer p1 = cddr(let_body); is_pair(cdr(p1)); p1 = cdr(p1)) + fx_annotate_arg(sc, p1, args); + fx_annotate_args(sc, cdr(l2a), 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) /* pars=#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)) + { + const 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->T) && + ((car(clause) != sc->else_symbol) || (!is_global(sc->else_symbol)))) + 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 != pars) + return(false); + }} + else return(false); + } + /* cond form looks ok, body here is the let form */ + set_optimize_op(body, OP_TC_LET_COND); + set_opt3_arglen(cdr(body), pars); + fx_annotate_arg(sc, cdaadr(body), args); /* let var */ + if (pars > 0) + fx_tree(sc, cdaadr(body), car(args), (pars > 1) ? cadr(args) : NULL, (pars > 2) ? caddr(args) : NULL, pars > 3); + var_name = caaadr(body); + for (s7_pointer p = cdr(let_body); is_pair(p); p = cdr(p)) + { + const s7_pointer clause = car(p); + const 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 (pars > 0) + fx_tree_outer(sc, clause, car(args), (pars > 1) ? cadr(args) : NULL, (pars > 2) ? caddr(args) : NULL, pars > 3); + } + if (all_fxable) set_optimized(body); + return(all_fxable); + } + return(false); +} + +/* tc lets can be let* or let+pars 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 pars, s7_pointer args, s7_pointer body) +{ + if (!is_pair(body)) return(false); + + if (((pars == 1) || (pars == 2) || (pars == 3)) && + ((car(body) == sc->and_symbol) || (car(body) == sc->or_symbol)) && + (is_pair(cdr(body))) && + (is_fxable(sc, cadr(body))) && + (is_pair(cddr(body)))) + { + const 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)))) + { + const s7_int len = proper_list_length(orx); + if ((len == 3) || + ((pars == 1) && (len == 4) && (tree_count(sc, name, orx, 0) == 1) && (is_fxable(sc, caddr(orx))))) /* the ...or|and_a_a_la case below? */ + { + const 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))) && + (((pars == 1) && (is_null(cddr(tc)))) || + ((pars == 2) && (is_pair(cddr(tc))) && (is_null(cdddr(tc))) && (is_safe_fxable(sc, caddr(tc)))) || + ((pars == 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 (pars == 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 (pars == 2) + set_safe_optimize_op(body, (car(body) == sc->and_symbol) ? OP_TC_AND_A_OR_A_L2A : OP_TC_OR_A_AND_A_L2A); + 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), (pars == 1) ? NULL : cadr(args), (pars == 3) ? caddr(args) : NULL, false); + return(true); + }}} + else + { + if ((pars == 1) && + (car(body) == sc->or_symbol) && + (is_fxable(sc, orx)) && + (is_pair(cdddr(body))) && + (is_pair(cadddr(body)))) + { + const 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)))) + { + const 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 ((pars == 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)) + { + const bool z_first = ((is_pair(cadddr(orx))) && (car(cadddr(orx)) == name)); + const 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; + const 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 ((pars == 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)))) + { + const 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)))) + { + const 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 (((pars >= 1) && (pars <= 3)) && + (car(body) == sc->if_symbol) && + (proper_list_length(body) == 4)) + { + const s7_pointer test = cadr(body); + if (is_fxable(sc, test)) + { + const s7_pointer true_p = caddr(body); + const s7_pointer false_p = cadddr(body); + const s7_int true_len = proper_list_length(true_p); + const s7_int false_len = proper_list_length(false_p); + + fx_annotate_arg(sc, cdr(body), args); + + if (pars == 1) + { + if ((false_len == 2) && + (car(false_p) == name) && + (is_fxable(sc, true_p)) && (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 */ + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cddr(body)); + rec_set_call_clause(body, cdar(cdddr(body))); + set_true_is_done(body); + 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, false_p)) && (is_fxable(sc, cadr(true_p)))) + { + set_optimize_op(body, OP_TC_IF_A_Z_LA); + fx_annotate_arg(sc, cdr(true_p), args); /* arg */ + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cdddr(body)); + rec_set_call_clause(body, cdar(cddr(body))); + fx_annotate_arg(sc, cdddr(body), args); /* result */ + fx_tree(sc, cdr(body), car(args), NULL, NULL, false); + set_optimized(body); + return(true); + }} + + if (pars == 2) + { + if ((false_len == 3) && + (car(false_p) == name) && + (is_fxable(sc, cadr(false_p))) && + (is_fxable(sc, true_p)) && (is_safe_fxable(sc, caddr(false_p)))) + { + set_optimize_op(body, OP_TC_IF_A_Z_L2A); + fx_annotate_args(sc, cdr(false_p), args); + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cddr(body)); /* body == code in op, if_true */ + rec_set_call_clause(body, cdar(cdddr(body))); /* la */ + set_true_is_done(body); + 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_fxable(sc, false_p)) && (is_safe_fxable(sc, caddr(true_p)))) + { + set_optimize_op(body, OP_TC_IF_A_Z_L2A); + fx_annotate_args(sc, cdr(true_p), args); + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cdddr(body)); + rec_set_call_clause(body, cdar(cddr(body))); + fx_annotate_arg(sc, cdddr(body), args); + fx_tree(sc, cdr(body), car(args), cadr(args), NULL, false); + set_optimized(body); + return(true); + }} + + if (pars == 3) + { + if ((false_len == 4) && + (car(false_p) == name) && + (is_fxable(sc, true_p)) && (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); + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cddr(body)); + rec_set_call_clause(body, cdar(cdddr(body))); + set_true_is_done(body); + 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, false_p)) && (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_Z_L3A); + fx_annotate_args(sc, cdr(true_p), args); + rec_set_test_clause(body, cdr(body)); + rec_set_done_clause(body, cdddr(body)); + rec_set_call_clause(body, cdar(cddr(body))); + 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)) + { + const s7_pointer in_test = cadr(false_p); + const s7_pointer in_true = caddr(false_p); + const s7_pointer in_false = cadddr(false_p); + if (is_fxable(sc, in_test)) + { + s7_pointer la = NULL, z = NULL; + 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) && ((pars == 3) || (!s7_tree_memq(sc, name, car(z))))) + { + if (((pars == 1) && (is_null(cddr(la)))) || + ((pars == 2) && (is_pair(cddr(la))) && (is_null(cdddr(la))) && (is_safe_fxable(sc, caddr(la)))) || + ((pars == 3) && + ((is_proper_list_4(sc, in_false)) || (is_proper_list_4(sc, in_true))) && + (is_safe_fxable(sc, caddr(la))) && (is_safe_fxable(sc, cadddr(la))) && + (((is_proper_list_4(sc, in_true)) && (car(in_true) == name) && + (is_fxable(sc, cadr(in_true))) && (is_safe_fxable(sc, caddr(in_true))) && (is_safe_fxable(sc, cadddr(in_true)))) || + (!s7_tree_memq(sc, name, in_true))))) + { + bool zs_fxable = true; + if (pars == 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 (pars == 2) + set_optimize_op(body, (la == in_false) ? OP_TC_IF_A_Z_IF_A_Z_L2A : OP_TC_IF_A_Z_IF_A_L2A_Z); + else + if (la == in_false) + set_optimize_op(body, ((is_pair(in_true)) && (car(in_true) == name)) ? OP_TC_IF_A_Z_IF_A_L3A_L3A : OP_TC_IF_A_Z_IF_A_Z_L3A); + else set_optimize_op(body, OP_TC_IF_A_Z_IF_A_L3A_Z); + + 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 (pars == 3) + { + if (optimize_op(body) != OP_TC_IF_A_Z_IF_A_L3A_Z) + fx_annotate_args(sc, cdr(in_false), args); + if (optimize_op(body) != OP_TC_IF_A_Z_IF_A_Z_L3A) + fx_annotate_args(sc, cdr(in_true), args); + } + if (optimize_op(body) != OP_TC_IF_A_Z_IF_A_L3A_L3A) + { + 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), (pars > 1) ? cadr(args) : NULL, (pars > 2) ? caddr(args) : NULL, false); + if (zs_fxable) set_optimized(body); + return(zs_fxable); + }}}} + + if ((pars == 2) && + (false_len == 3) && + (car(false_p) == sc->let_star_symbol)) + { + const s7_pointer letv = cadr(false_p); + s7_pointer letb; + if (!is_pair(letv)) return(false); + letb = caddr(false_p); + for (s7_pointer 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)))) + { + const s7_pointer l2a = cadddr(letb); + if ((car(l2a) == name) && + (is_proper_list_3(sc, l2a)) && + (is_fxable(sc, cadr(l2a))) && + (is_safe_fxable(sc, caddr(l2a)))) + { + bool zs_fxable; + set_safe_optimize_op(body, OP_TC_IF_A_Z_LET_IF_A_Z_L2A); + fx_annotate_args(sc, cdr(l2a), args); + zs_fxable = is_fxable(sc, caddr(letb)); + fx_annotate_args(sc, cdr(letb), args); + for (s7_pointer 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(l2a), 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, pars, args, body)); + + /* cond */ + if (car(body) == sc->cond_symbol) + return(check_tc_cond(sc, name, pars, args, body)); + + /* case */ + if (((pars >= 1) && (pars <= 3)) && + (car(body) == sc->case_symbol) && + (is_pair(cdr(body))) && + (is_fxable(sc, cadr(body)))) + return(check_tc_case(sc, name, args, body)); + + /* when */ + if ((pars >= 1) && (pars <= 3) && + ((car(body) == sc->when_symbol) || (car(body) == sc->unless_symbol)) && + (is_fxable(sc, cadr(body)))) + return(check_tc_when(sc, name, pars, args, body)); + return(false); +} + +static void mark_fx_treeable(s7_scheme *sc, s7_pointer body) +{ /* it is possible to encounter a cyclic body here -- TODO: s7test example! */ + if (is_pair(body)) /* slightly faster than the other way of writing this, checking treeable (to catch cyclic trees) slows us down by a lot! */ + { + 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 pars, s7_pointer body) +{ /* func is either sc->unused or a symbol */ + const s7_int len = s7_list_length(sc, body); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %s %s\n", __func__, __LINE__, display(func), display(pars), 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_pars; + + begin_small_symbol_set(sc); + for (p = pars; is_pair(p); p = cdr(p)) + add_symbol_to_small_symbol_set(sc, (is_symbol(car(p))) ? car(p) : caar(p)); + if (!is_null(p)) + add_symbol_to_small_symbol_set(sc, p); + sc->got_tc = false; + sc->not_tc = false; + sc->got_rec = false; + sc->rec_tc_args = -1; + /* I think cyclic code has already been caught in check_lambda et al */ + result = ((is_symbol(func)) && (symbol_is_in_small_symbol_set(sc, func))) ? unsafe_body : body_is_safe(sc, func, body, true); /* (define (f f)...) */ + end_small_symbol_set(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 (s7_pointer p1 = pars; is_pair(p1); p1 = cdr(p1)) + { + const s7_pointer par = car(p1); + if ((is_pair(par)) && /* has default value */ + (is_pair(cdr(par))) && /* is not a ridiculous improper list */ + ((is_symbol(cadr(par))) || /* if default value might involve eval in any way, it isn't simple */ + (is_unquoted_pair(cadr(par))))) /* pair as default only ok if it is (quote ...) */ + { + happy = false; + if ((result > unsafe_body) && + (tree_has_definer_or_binder(sc, cadr(par)))) /* 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_big_symbol_set(sc, func)); + sc->temp1 = lst; + } + else lst = sc->nil; + + if (optimize(sc, body, 1, cleared_pars = collect_parameters(sc, pars, lst)) == opt_oops) + clear_all_optimizations(sc, body); + else + if (result >= recur_body) + { + int32_t npars; + mark_fx_treeable(sc, body); + if ((!unstarred_lambda) && (is_pair(cleared_pars))) + { + cleared_pars = proper_list_reverse_in_place(sc, cleared_pars); + /* we need pars in decl order below, else (e.g.) fx_o out-of-date because pars does not represent lambda pars (as in its env) */ + if (car(cleared_pars) == func) cleared_pars = cdr(cleared_pars); + } + else cleared_pars = pars; + for (npars = 0, p = pars; (is_pair(p)) && (!is_symbol_and_keyword(car(p))); npars++, p = cdr(p)); /* npars should not include a dotted (rest) arg */ + if ((is_null(p)) && + (npars > 0)) + { + fx_annotate_args(sc, body, cleared_pars); /* 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! */ + car(cleared_pars), + (npars > 1) ? cadr(cleared_pars) : NULL, + (npars > 2) ? caddr(cleared_pars) : NULL, + npars > 3); + } + if (((unstarred_lambda) || ((is_null(p)) && (npars == sc->rec_tc_args))) && + (is_null(cdr(body)))) + { /* (if #t|#f...) happens only rarely */ + if (sc->got_tc) + { + if (check_tc(sc, func, npars, cleared_pars, 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, npars, cleared_pars, car(body)))) + set_safe_closure_body(body); + }} + clear_big_symbol_set(sc); + if (is_symbol(func)) sc->temp1 = sc->unused; + 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))) /* this can happen (3 examples in s7test) */ + 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); + + /* 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 + */ + clear_big_symbol_set(sc); + 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); + } + clear_big_symbol_set(sc); + 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) +{ + const 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)); + + clear_big_symbol_set(sc); + 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)); + clear_big_symbol_set(sc); + 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 exprs) +{ + for (s7_pointer p = exprs; 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; + const s7_pointer 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); + + { + s7_pointer clauses; + for (clauses = cdr(code); is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer keys, clause = car(clauses); + if (!is_pair(clause)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case clause ~S messed up in ~A", 30), + clauses, object_to_string_truncated(sc, form))); + if (!is_list(cdr(clause))) /* (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", 40), + clause, object_to_string_truncated(sc, form))); + if ((bodies_simple) && + ((is_null(cdr(clause))) || (!is_null(cddr(clause))))) + bodies_simple = false; + + use_fx = ((use_fx) && (is_pair(cdr(clause))) && (is_all_fxable(sc, cdr(clause)))); + keys = car(clause); + if (!is_pair(keys)) + { + if ((keys != sc->else_symbol) && /* (case 1 (2 1)) */ + ((!is_symbol(keys)) || + (s7_symbol_value(sc, keys) != 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), + keys, clause, object_to_string_truncated(sc, form))); + has_else = true; + if (is_not_null(cdr(clauses))) /* (case 1 (else 1) ((2) 1)) */ + syntax_error_nr(sc, "case 'else' clause is not the last clause: ~S", 45, clauses); + if (!is_null(cdr(clause))) /* else (else) so return selector */ + { + if (is_pair(cddr(clause))) + { + set_opt3_any(code, cdr(clause)); + bodies_simple = false; + } + else + { + set_opt3_any(code, ((bodies_simple) && (keys_single)) ? cadr(clause) : cdr(clause)); + set_opt1_clause(clauses, cadr(clause)); + }}} + else + { + if (!is_simple(car(keys))) keys_simple = false; + if (!is_null(cdr(keys))) keys_single = false; + if (key_type == T_FREE) + key_type = type(car(keys)); + else + if (key_type != type(car(keys))) + key_type = NUM_TYPES; + if (key_type == T_SYMBOL) set_case_key(car(keys)); + + for (keys = cdr(keys); is_pair(keys); keys = cdr(keys)) + { + if (!is_simple(car(keys))) + keys_simple = false; + if (key_type != type(car(keys))) + key_type = NUM_TYPES; + if (key_type == T_SYMBOL) set_case_key(car(keys)); + } + if (!is_null(keys)) /* (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), + clause, object_to_string_truncated(sc, form))); + } + if (!s7_is_proper_list(sc, cdr(clause))) /* (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), + clause, object_to_string_truncated(sc, form))); + if ((is_pair(cdr(clause))) && (is_undefined_feed_to(sc, cadr(clause)))) + { + has_feed_to = true; + if (!is_pair(cddr(clause))) /* (case 1 (else =>)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "case: '=>' target missing: ~S in ~A", 35), + clause, object_to_string_truncated(sc, form))); + if (is_pair(cdddr(clause))) /* (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), + clause, object_to_string_truncated(sc, form))); + }} + if (is_not_null(clauses)) /* (case x ((1 2)) . 1) */ + syntax_error_nr(sc, "case: stray dot? ~S", 19, form); + } + if ((keys_single) && + (bodies_simple)) + { + for (s7_pointer clauses = cdr(code); is_not_null(clauses); clauses = cdr(clauses)) + { + set_opt2_any(clauses, caar(clauses)); + if (is_pair(opt2_any(clauses))) + { + set_opt2_any(clauses, car(opt2_any(clauses))); + if (is_pair(cdar(clauses))) + set_opt1_clause(clauses, cadar(clauses)); + }}} + else + for (s7_pointer clauses = cdr(code); is_not_null(clauses); clauses = cdr(clauses)) + { + set_opt2_any(clauses, caar(clauses)); + if ((is_pair(opt2_any(clauses))) && + (is_pair(cdar(clauses)))) + set_opt1_clause(clauses, cadar(clauses)); + } + 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)) + { + const 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 (s7_pointer clauses = cdr(code); is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer clause = cdar(clauses); + 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(clauses))) set_opt3_any(code, clause); + }}} + { + s7_pointer selector = cadr(form); + if (!is_pair(selector)) + { + sc->value = (is_symbol(selector)) ? lookup_checked(sc, selector) : selector; + return(NULL); + } + push_stack_no_args_direct(sc, OP_CASE_G_G); + sc->code = selector; + return(selector); + } +} + +#if !WITH_GMP +static bool op_case_i_s(s7_scheme *sc) +{ + const s7_pointer selector = sc->value; + const s7_pointer else_clause = opt3_any(cdr(sc->code)); + if (else_clause != sc->unspecified) + { + if (is_t_integer(selector)) + { + const s7_int val = integer(selector); + for (s7_pointer clauses = cddr(sc->code); is_pair(cdr(clauses)); clauses = cdr(clauses)) + if (integer(opt2_any(clauses)) == val) + { + sc->code = opt1_clause(clauses); + return(false); + }} + sc->code = else_clause; + return(false); + } + if (is_t_integer(selector)) + { + const s7_int val = integer(selector); + for (s7_pointer clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses)) + if (integer(opt2_any(clauses)) == val) + { + sc->code = opt1_clause(clauses); + 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 */ +{ + const s7_pointer selector = fx_call(sc, cdr(code)); + if (is_t_integer(selector)) + { + const s7_int val = integer(selector); + for (s7_pointer clauses = cddr(sc->code); is_pair(cdr(clauses)); clauses = cdr(clauses)) /* code = (case ...) */ + if (integer(opt2_any(clauses)) == val) + return(fx_call(sc, cdar(clauses))); + } + 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 clauses; + if (ok) + { + for (clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer keys = opt2_any(clauses); + if (!is_pair(keys)) /* i.e. else? */ + goto ELSE_CASE_1; + do { + if (car(keys) == selector) + goto ELSE_CASE_1; + keys = cdr(keys); + } while (is_pair(keys)); + } + 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: + /* clauses is the entire matching clause, (case 2 ((2) 3)), clauses: (((2) 3)) */ + sc->code = T_Lst(cdar(clauses)); + 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) +{ + const s7_pointer selector = fx_call(sc, cdr(code)); + if (is_case_key(selector)) + for (s7_pointer clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer keys = opt2_any(clauses); + if (!is_pair(keys)) /* i.e. else? */ + return(fx_call_all(sc, cdar(clauses))); /* else clause */ + do { + if (car(keys) == selector) + return(fx_call_all(sc, cdar(clauses))); + keys = cdr(keys); + } while (is_pair(keys)); + } + 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 clauses; + 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 (clauses = sc->code; is_pair(clauses); clauses = cdr(clauses)) + if (!is_pair(caar(clauses))) + goto ELSE_CASE; + sc->value = sc->unspecified; + pop_stack(sc); + return(true); + }} + for (clauses = sc->code; is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer keys = caar(clauses); + if (!is_pair(keys)) + goto ELSE_CASE; + for (; is_pair(keys); keys = cdr(keys)) + if (integer(car(keys)) == selector) + goto ELSE_CASE; + } + sc->value = sc->unspecified; + pop_stack(sc); + return(true); + } + sc->code = cddr(sc->code); + if (is_simple(sc->value)) + { + for (clauses = sc->code; is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer keys = caar(clauses); + if (!is_pair(keys)) + goto ELSE_CASE; + do { + if (car(keys) == sc->value) + goto ELSE_CASE; + keys = cdr(keys); + } while (is_pair(keys)); + } + sc->value = sc->unspecified; + pop_stack(sc); + return(true); + } + for (clauses = sc->code; is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer keys = caar(clauses); + if (!is_pair(keys)) + goto ELSE_CASE; + for (; is_pair(keys); keys = cdr(keys)) + if (s7_is_eqv(sc, car(keys), 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: + /* clauses is the entire matching clause, (case 2 ((2) 3)), clauses: (((2) 3)) */ + sc->code = T_Lst(cdar(clauses)); + 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) +{ + const s7_pointer selector = sc->value; + if (is_simple(selector)) + for (s7_pointer clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses)) + if (opt2_any(clauses) == selector) + { + sc->code = opt1_clause(clauses); + return; + } + sc->code = opt3_any(cdr(sc->code)); +} + +static s7_pointer fx_case_a_e_s_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer selector = fx_call(sc, cdr(code)); + if (is_simple(selector)) + for (s7_pointer clauses = cddr(code); is_pair(clauses); clauses = cdr(clauses)) + if (opt2_any(clauses) == selector) + return(fx_call(sc, cdar(clauses))); + return(fx_call(sc, opt3_any(cdr(code)))); +} + +static void op_case_g_s(s7_scheme *sc) +{ + const s7_pointer selector = sc->value; + for (s7_pointer clauses = cddr(sc->code); is_pair(clauses); clauses = cdr(clauses)) + if (s7_is_eqv(sc, opt2_any(clauses), selector)) + { + sc->code = opt1_clause(clauses); + 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) */ +{ + const s7_pointer selector = fx_call(sc, cdr(code)); + for (s7_pointer clauses = cddr(code); is_pair(clauses); clauses = cdr(clauses)) + if (s7_is_eqv(sc, opt2_any(clauses), selector)) + return(fx_call(sc, cdar(clauses))); + return(fx_call(sc, opt3_any(cdr(code)))); +} + + +/* -------------------------------- let -------------------------------- */ +static void check_let_a_body(s7_scheme *sc, s7_pointer form) +{ + const 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) /* not a named let */ +{ + const s7_pointer binding = car(start), code = cdr(form); /* i.e. form=(let ((x '(1 2))) (list x x)), start=((x '(1 2))) */ + const s7_pointer variable = car(binding), value = cadr(binding); + if (is_pair(value)) + { + 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), variable); /* these don't collide -- cdr(code) and code */ + set_opt2_pair(code, value); + if (is_optimized(value)) + { + if ((optimize_op(value) == HOP_SAFE_C_SS) && + (fn_proc(value) == g_assq)) + { + set_opt2_sym(code, cadr(value)); + pair_set_syntax_op(form, OP_LET_opaSSq_OLD); + set_opt3_sym(cdr(code), caddr(value)); + set_opt1_sym(code, variable); + } + else + if (is_fxable(sc, value)) + { + 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); /* let_a_aa_old|new is not worth the code (30 in tgc, nothing elsewhere) */ + fx_annotate_args(sc, cdr(code), set_plist_1(sc, variable)); + fx_tree(sc, cdr(code), variable, NULL, NULL, false); + return; + } + if (is_fx_treeable(cdr(code))) fx_tree(sc, cdr(code), variable, 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, variable)); /* no effect if not syntactic -- how to fix? plist is the "env" = local varname */ + if (is_fx_treeable(cdr(code))) fx_tree(sc, cdr(code), variable, 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); /* not fxable body, goto eval on each */ +} + +static s7_pointer check_named_let(s7_scheme *sc, int32_t vars) +{ + const 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 (implicit) lambda 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)) + { + const 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_safe_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 vars, start; + const s7_pointer code = cdr(sc->code), form = sc->code; + bool named_let; + int32_t num_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); + + begin_small_symbol_set(sc); + for (num_vars = 0, vars = start; is_pair(vars); num_vars++, vars = cdr(vars)) + { + s7_pointer sym; + const s7_pointer var = car(vars); + + if ((!is_pair(var)) || (is_null(cdr(var)))) /* (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), + vars, object_to_string_truncated(sc, form))); + + if (!is_pair(cdr(var))) /* (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), + vars, object_to_string_truncated(sc, form))); + + if (is_not_null(cddr(var))) /* (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), + vars, object_to_string_truncated(sc, form))); + sym = car(var); + if (!is_symbol(sym)) + { + if (is_c_function(sym)) /* (let ((#_abs 3)) ...) */ + { + s7_pointer fsym = c_function_symbol(sym); + if (initial_value_is_defined(fsym)) + 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), fsym)); + } + error_nr(sc, sc->syntax_error_symbol, /* (let ('1) quote) -> bad variable name #_quote in let (it is syntactic, not a symbol) */ + set_elist_4(sc, wrap_string(sc, "bad variable name ~W in let (it is ~A, not a symbol) in ~A", 58), + sym, object_type_name(sc, sym), + object_to_string_truncated(sc, form))); + } + if (is_constant_symbol(sc, sym)) /* let ((pi 3)) ...) */ + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_symbol, vars)); + + /* check for name collisions -- not sure this is required by Scheme */ + if (symbol_is_in_small_symbol_set(sc, sym)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "duplicate identifier in let: ~S in ~S", 37), sym, form)); + add_symbol_to_small_symbol_set(sc, sym); + set_local(sym); + } + end_small_symbol_set(sc); + + if (is_not_null(vars)) /* (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, num_vars)); + /* set_opt2_int(code, num_vars); */ /* maybe set on vars? */ + + if (num_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 (num_vars == 1) + check_let_one_var(sc, form, start); + else + { + /* this used to check that num_vars < gc_trigger_size, but I can't see why */ + opcode_t opt = OP_UNOPT; + for (vars = start; is_pair(vars); vars = cdr(vars)) + { + s7_pointer var = car(vars); + if (is_fxable(sc, cadr(var))) + { + set_fx_direct(cdr(var), fx_choose(sc, cdr(var), 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 (num_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 (num_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 */ + if (optimize_op(form) >= OP_LET_NA_OLD) + { + if ((!in_heap(form)) && + (wrapped_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_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 void op_named_let_1(s7_scheme *sc, s7_pointer args) /* sc->code = (name vars . body), args = vals in decl order */ +{ + const s7_pointer body = cddr(sc->code); + const s7_int n = opt2_int(sc->code); /* num pars, see check_named_let called in check_let, normally 1, sometimes 2..4 */ + if (n == 1) + begin_temp(sc->y, list_1(sc, caaadr(sc->code))); + else + { + begin_temp(sc->y, sc->nil); + for (s7_pointer vars = cadr(sc->code); is_pair(vars); vars = cdr(vars)) + { + sc->y = cons(sc, caar(vars), sc->y); /* this consing is not completely wasted -- it becomes the closure arg list below (why is this needed?) */ + vars = cdr(vars); + if (!is_pair(vars)) break; + sc->y = cons_unchecked(sc, caar(vars), sc->y); + } + sc->y = proper_list_reverse_in_place(sc, sc->y); /* needed for closure_pars */ + } + set_curlet(sc, make_let(sc, sc->curlet)); + begin_temp(sc->v, make_closure_unchecked(sc, sc->y, body, T_CLOSURE, n)); /* n = num pars */ + add_slot(sc, sc->curlet, car(sc->code), sc->v); + set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */ + for (s7_pointer vars = sc->y; is_not_null(args); vars = cdr(vars), args = cdr(args)) + { + add_slot_unchecked_with_id(sc, sc->curlet, car(vars), unchecked_car(args)); + vars = cdr(vars); args = cdr(args); + if (is_null(args)) break; + add_slot_checked_with_id(sc, sc->curlet, car(vars), unchecked_car(args)); + } + closure_set_let(sc->v, sc->curlet); + let_set_slots(sc->curlet, reverse_slots(let_slots(sc->curlet))); + end_temp(sc->y); + end_temp(sc->v); + sc->code = T_Pair(body); +} + +static bool op_let_1(s7_scheme *sc) +{ /* op_let form: (let ((i 0) (j 1)) (+ i j)), code: ((i 0) (j 1)), value: (((i 0) (j 1)) (+ i j)), args: () + * op_named_let: (let loop ((i 0)) (if (< i 3) (loop (+ i 1)) i)), code: ((i 0)), value: (loop ((i 0)) (if (< i 3) (loop (+ i 1)) i)), args: () + * eval->op_let_unchecked: (let ((i (catch #t (lambda () 1) (lambda (t i) 'error))) (j 2)) (+ i j))) (in a function), + * code: ((j 2)), value: 1, args: ((((i (catch #t (lambda () 1) (lambda (t i) 'error))) (j 2)) (+ i j))) + */ + /* true -> BEGIN, false -> EVAL */ + while (true) + { + sc->args = cons(sc, sc->value, sc->args); /* sc->value can be a mutable number here */ + if (is_pair(sc->code)) + { + const s7_pointer val = cdar(sc->code); + if (has_fx(val)) + sc->value = fx_call(sc, val); + else + { + check_stack_size(sc); + push_stack(sc, OP_LET1, sc->args, cdr(sc->code)); /* come back here */ + sc->code = car(val); + return(false); /* goto EVAL */ + } + sc->code = cdr(sc->code); + } + else break; + } + sc->args = proper_list_reverse_in_place(sc, sc->args); + sc->code = car(sc->args); /* restore the original form */ + { + s7_pointer vals = cdr(sc->args); /* car=form */ + s7_int id; + sc->temp8 = vals; + set_curlet(sc, make_let(sc, T_Let(sc->curlet))); + if (is_symbol(car(sc->code))) + { + op_named_let_1(sc, vals); /* inner let here */ + sc->temp8 = sc->unused; + return(true); + } + id = let_id(sc->curlet); + if (is_pair(vals)) + { + s7_pointer vars = car(sc->code); + s7_pointer last_slot = add_slot_unchecked_with_id(sc, sc->curlet, caar(vars), unchecked_car(vals)); + for (vars = cdr(vars), vals = cdr(vals); is_not_null(vals); vars = cdr(vars), vals = cdr(vals)) + last_slot = add_slot_checked_at_end(sc, id, last_slot, caar(vars), unchecked_car(vals)); /* not unchecked -- tlimit.scm */ + }} + sc->code = T_Pair(cdr(sc->code)); + sc->temp8 = sc->unused; + return(true); /* goto BEGIN */ +} + +static bool op_let(s7_scheme *sc) /* from OP_LET */ +{ + /* 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 */ + { + const s7_pointer body = cddr(sc->code); + set_opt2_int(cdr(sc->code), 0); + begin_temp(sc->y, 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->y)); + funclet_set_function(closure_let(sc->y), car(sc->code)); + add_slot_checked(sc, sc->curlet, car(sc->code), sc->y); + set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */ + sc->code = T_Pair(body); + end_temp(sc->y); + } + else sc->code = T_Pair(cdr(sc->code)); + return(true); /* goto BEGIN */ + } + sc->args = sc->nil; + /* value: (((i 0)) (+ i 1)), code: ((i 0)) */ + return(op_let_1(sc)); /* sc->code == vars, sc->value = original sc->code */ +} + +static bool op_let_unchecked(s7_scheme *sc) /* not named, but has vars, called from eval if looping via op_let->op_let_1 + unopt'd args */ +{ + const s7_pointer code = cadr(sc->code); + const s7_pointer val = cdar(code); /* next arg */ + /* value: 0, code: ((radix (+ 2 (random 15)))) from (do ((i 0 (+ i 1))) ((= i 2)) (let ((j 0) (radix (+ 2 (random 15)))) (+ j radix))) on second iteration (i == 1) */ + sc->args = list_1(sc, cdr(sc->code)); /* as if sc->value were this, then absorbed into sc->args */ + if (has_fx(val)) + sc->value = fx_call(sc, val); + else + { + push_stack(sc, OP_LET1, sc->args, cdr(code)); + sc->code = car(val); + return(false); /* goto EVAL */ + } + sc->code = cdr(code); + return(op_let_1(sc)); /* sc->args preset with code */ +} + +static bool op_named_let(s7_scheme *sc) +{ /* from eval */ + sc->args = sc->nil; + sc->value = cdr(sc->code); + sc->code = cadr(sc->value); + return(op_let_1(sc)); /* sc->args is ()? */ +} + +static void op_named_let_no_vars(s7_scheme *sc) +{ /* sc->code is full form (let name () ...) */ + const s7_pointer name = cadr(sc->code); + sc->code = opt1_pair(sc->code); /* cdddr(sc->code) == body */ + set_curlet(sc, inline_make_let(sc, sc->curlet)); + sc->args = make_closure_unchecked(sc, sc->nil, sc->code, T_CLOSURE, 0); + add_slot_checked(sc, sc->curlet, name, sc->args); /* sc->args is a temp here */ + set_curlet(sc, make_let(sc, sc->curlet)); /* inner let */ + /* goto BEGIN */ +} + +static void op_named_let_a(s7_scheme *sc) +{ /* sc->code is the full form (let name vars...), par pointers are preset in opt1|3(cdr(sc->code)) */ + const s7_pointer data = cdr(sc->code); + const s7_pointer par1 = opt1_pair(data); /* cdaadr(args) == first par */ + sc->code = cddr(data); /* (vars ...) */ + sc->args = fx_call(sc, cdr(par1)); + set_curlet(sc, make_let(sc, sc->curlet)); /* funclet(?) */ + begin_temp(sc->y, list_1_unchecked(sc, car(par1))); /* (list sym1), subsequent calls will need a normal list of pars in closure_pars */ + begin_temp(sc->v, make_closure_unchecked(sc, sc->y, sc->code, T_CLOSURE, 1)); /* picks up curlet (this is the funclet?) */ + add_slot(sc, sc->curlet, car(data), sc->v); /* car(data) == the function name */ + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(sc->y), sc->args)); /* inner let */ + closure_set_let(sc->v, sc->curlet); + end_temp(sc->v); + end_temp(sc->y); + /* goto BEGIN */ +} + +static void op_named_let_aa(s7_scheme *sc) +{ /* sc->code is the full form (let name vars...), par pointers are preset in opt1|3(cdr(sc->code)) */ + const s7_pointer data = cdr(sc->code); + const s7_pointer par1 = opt1_pair(data); /* cdaadr(data) == first par */ + const s7_pointer par2 = opt3_pair(data); /* cdadadr == second */ + sc->code = cddr(data); /* (vars ...) */ + sc->args = fx_call(sc, cdr(par1)); + sc->value = fx_call(sc, cdr(par2)); + set_curlet(sc, make_let(sc, sc->curlet)); /* funclet below I think */ + begin_temp(sc->y, list_2_unchecked(sc, car(par1), car(par2))); /* (list sym1 sym2): subsequent calls will need a normal list of pars in closure_pars */ + begin_temp(sc->v, make_closure_unchecked(sc, sc->y, sc->code, T_CLOSURE, 2)); /* picks up curlet (this is the funclet?) */ + add_slot(sc, sc->curlet, car(data), sc->v); /* car(data) == the function name */ + set_curlet(sc, inline_make_let_with_two_slots(sc, sc->curlet, car(sc->y), sc->args, cadr(sc->y), sc->value)); /* inner let */ + closure_set_let(sc->v, sc->curlet); + end_temp(sc->v); + end_temp(sc->y); + /* goto BEGIN */ +} + +static void 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); + op_named_let_1(sc, sc->args); /* sc->code = (name vars . body), args = vals in decl order, op_named_let_1 handles inner let */ + /* goto BEGIN */ +} + +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, let; + sc->code = cdr(sc->code); + binding = opt2_pair(sc->code); + let = wrap_let_with_slot(sc, sc->curlet, car(binding), fx_call(sc, cdr(binding))); /* wrap maybe unsafe here (see snd-24.3/s7.c */ + set_curlet(sc, let); + sc->value = fx_call(sc, cdr(sc->code)); + let_set_slots(let, slot_end); +} + +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) */ +{ + inline_op_let_a_old(sc); + 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, wrap_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); +} + +/* 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 p; + inline_op_let_a_old(sc); + 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 = 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) +{ + const s7_pointer let = opt3_let(cdr(sc->code)); + s7_pointer slot = let_slots(let); + const s7_int 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 */ +{ + const s7_pointer code = cdr(sc->code); + const s7_pointer a1 = opt1_pair(code); /* caar(code) */ + const s7_pointer a2 = opt2_pair(code); /* cadar(code) */ + gc_protect_via_stack(sc, fx_call(sc, cdr(a1))); + set_gc_protected2(sc, fx_call(sc, cdr(a2))); + set_curlet(sc, inline_make_let_with_two_slots(sc, sc->curlet, car(a1), gc_protected1(sc), car(a2), gc_protected2(sc))); + unstack_gc_protect(sc); + 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 */ +{ + const s7_pointer code = cdr(sc->code); + const s7_pointer a1 = caar(code); + const s7_pointer a2 = opt1_pair(code); /* cadar */ + const 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_gc_protected2(sc, fx_call(sc, cdr(a2))); + set_curlet(sc, inline_make_let_with_two_slots(sc, sc->curlet, car(a2), gc_protected2(sc), car(a3), fx_call(sc, cdr(a3)))); + add_slot(sc, sc->curlet, car(a1), gc_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 */ +{ + const 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; + const s7_pointer 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); + + begin_small_symbol_set(sc); + for (vars = ((named_let) ? cadr(code) : car(code)); is_pair(vars); vars = cdr(vars)) + { + s7_pointer var; + const s7_pointer var_and_val = car(vars); + if (!is_pair(var_and_val)) /* (let* (3) ... */ + { + /* fprintf(stderr, "%s[%d]: got %s\n", __func__, __LINE__, display(var_and_val)); */ + /* (let* name ((i 0) :allow-other-keys) i) + * check_let_star[79760]: got :allow-other-keys + * let* variable list, :allow-other-keys, is messed up in (let* name ((i 0) :allow-other-keys) i) + * + * (let* name ((i 0) . others) i) + * 79802(9): let* variable list is not a proper list: others in (let* name ((i 0) . others) i) + * + * (let* name others others) + * 79738: let* variable list is messed up: (let* name others others) + * + * (let* name ((i 0) :rest b) b) + * check_let_star[79760]: got :rest + * let* variable list, :rest, is messed up in (let* name ((i 0) :rest b) b) + * + * what about (let* name ((i 0) :allow-other-keys) ... (name :x 2 3)) -- is i=3? (it is in define*: + * (define* (f (i 0) :allow-other-keys) i) (f :x 2 3): 3) -- so other-keys are completely ignored? + * but (define* (f (a 1) (b 2)) (list a b)), (f :b 12 3): parameter set twice, b in (:b 12 3) + * t_allow_other_keys is set on arglists and c_function_star (? clo*?) -- let* makes t_closure_star + */ + 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 (symbol_is_in_small_symbol_set(sc, var)) + { + if (named_let) /* (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 */ + shadowing = true; + } + add_symbol_to_small_symbol_set(sc, var); + set_local(var); + } + end_small_symbol_set(sc); + if (!is_null(vars)) + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "let* variable list is not a proper list: ~A in ~A", 49), + vars, object_to_string_truncated(sc, form))); + 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 () ... */ + { + const 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)) && + (wrapped_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)) + { + const s7_pointer val = cdar(sc->code); + if (has_fx(val)) + sc->value = fx_call(sc, val); + else + { + push_stack_direct(sc, OP_LET_STAR_SHADOWED); + sc->code = car(val); + 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) +{ + s7_uint 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 = add_slot_checked_at_end(sc, let_id(sc->curlet), sp, caar(sc->code), sc->value); /* was unchecked */ + } + 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 val = cdar(sc->code); + if (has_fx(val)) + sc->value = fx_call(sc, val); + else + { + push_stack_direct(sc, OP_LET_STAR1); + sc->code = car(val); + return(true); + }} + else break; + } + sc->code = sc->args; /* original sc->code set in push_stack above */ + if (is_symbol(car(sc->code))) + { + const 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 */ + begin_temp(sc->x, make_closure_unchecked(sc, args, body, T_CLOSURE_STAR, (is_null(args)) ? 0 : CLOSURE_ARITY_NOT_SET)); + if (symbol_id(name) > let_id(let_outlet(sc->curlet))) + { + const s7_int cur_id = symbol_id(name); + const 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, sc->x); + symbol_set_id_unchecked(name, cur_id); + set_local_slot(name, cur_slot); + } + else add_slot_checked(sc, let_outlet(sc->curlet), name, sc->x); + end_temp(sc->x); + 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; + s7_uint let_counter = S7_INT64_MAX; + sc->code = cdr(sc->code); + for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars)) + { + const s7_pointer binding = car(vars); + const s7_pointer val = fx_call(sc, cdr(binding)); /* eval in outer let */ + if (let_counter == sc->capture_let_counter) + { + if (!sp) + { + add_slot_checked(sc, sc->curlet, car(binding), val); + sp = let_slots(sc->curlet); + } + else sp = add_slot_at_end(sc, let_id(sc->curlet), sp, car(binding), val); + } + else + { + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(binding), 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; + s7_uint let_counter = S7_INT64_MAX; + sc->code = cdr(sc->code); + for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars)) + { + const s7_pointer binding = car(vars); + const s7_pointer val = fx_call(sc, cdr(binding)); + if (let_counter == sc->capture_let_counter) + { + if (!sp) + { + add_slot_checked(sc, sc->curlet, car(binding), val); + sp = let_slots(sc->curlet); + } + else sp = add_slot_at_end(sc, let_id(sc->curlet), sp, car(binding), val); + } + else + { + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(binding), 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); + /* check_stack_size(sc); */ /* t101-42 but commented out */ + 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) +{ + const s7_pointer code = cdr(sc->code); + const 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); + + begin_small_symbol_set(sc); + for (s7_pointer vars = car(code); is_not_null(vars); vars = cdr(vars)) + { + s7_pointer sym, var; + if (!is_pair(vars)) /* (letrec ((a 1) . 2) ...) */ + syntax_error_with_caller_nr(sc, "~A: improper list of variables? ~A", 34, caller, sc->code); + + var = car(vars); + if (!is_pair(var)) /* (letrec (1 2) #t) */ + syntax_error_with_caller_nr(sc, "~A: bad variable ~S (should be a pair (name value))", 51, caller, var); + + sym = car(var); + if (!is_symbol(sym)) + 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), + sym, caller, object_type_name(sc, sym), + object_to_string_truncated(sc, sc->code))); + if (is_constant_symbol(sc, sym)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, caller, vars)); + + if (!is_pair(cdr(var))) /* (letrec ((x . 1))...) */ + { + if (is_null(cdr(var))) /* (letrec ((x)) x) -- perhaps this is legal? */ + syntax_error_with_caller_nr(sc, "~A: variable declaration has no value?: ~A", 42, caller, var); + syntax_error_with_caller_nr(sc, "~A: variable declaration is not a proper list?: ~A", 50, caller, var); + } + if (is_not_null(cddr(var))) /* (letrec ((x 1 2 3)) ...) */ + syntax_error_with_caller_nr(sc, "~A: variable declaration has more than one value?: ~A", 53, caller, var); + + /* 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_small_symbol_set(sc, sym)) + syntax_error_with_caller_nr(sc, "~A: duplicate identifier: ~A", 28, caller, sym); + add_symbol_to_small_symbol_set(sc, sym); + set_local(sym); + } + end_small_symbol_set(sc); + + 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 (s7_pointer vars = 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_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))) + { + const 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_pars(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 # + * get parallel list of values + * eval each member of values list with let still full of #'s + * assign each value to its variable + * eval body + * which means that (letrec ((x x)) x) is not an error -- it is #. + * 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) + */ + set_curlet(sc, make_let(sc, sc->curlet)); + if (is_pair(car(code))) + { + s7_pointer slot; + for (s7_pointer vars = car(code); is_not_null(vars); vars = cdr(vars)) + { + slot = add_slot_checked(sc, sc->curlet, caar(vars), sc->undefined); + slot_set_pending_value(slot, sc->undefined); + slot_set_expression(slot, cdar(vars)); + 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) +{ + const s7_pointer code = cdr(sc->code); + /* get all local vars and set to # + * 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 vars = car(code); is_not_null(vars); vars = cdr(vars)) + { + slot = add_slot_checked(sc, sc->curlet, caar(vars), sc->undefined); + slot_set_expression(slot, cdar(vars)); + } + 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) +{ + const s7_pointer 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 (s7_pointer vars = car(code); is_not_null(vars); vars = cdr(vars)) + { + s7_pointer var, sym; + if (!is_pair(vars)) /* (let-temporarily ((a 1) . 2) ...) */ + syntax_error_nr(sc, "let-temporarily: improper list of variables? ~A", 47, form); + + var = car(vars); + if (!is_pair(var)) /* (let-temporarily (1 2) #t) */ + syntax_error_nr(sc, "let-temporarily: bad variable ~S (it should be a pair (name value))", 67, var); + + sym = car(var); + if (is_symbol(sym)) + { + if (is_constant_symbol(sc, sym)) /* (let-temporarily ((pi 3)) ...) */ + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_3(sc, cant_bind_immutable_string, sc->let_temporarily_symbol, vars)); + } + else + if (!is_pair(sym)) /* (let-temporarily ((1 2)) ...) */ + syntax_error_nr(sc, "let-temporarily: bad variable ~S (it should be a symbol or a pair)", 66, sym); + + if (!is_pair(cdr(var))) /* (let-temporarily ((x . 1))...) */ + syntax_error_nr(sc, "let-temporarily: variable declaration value is messed up: ~S", 60, var); + + if (is_not_null(cddr(var))) /* (let-temporarily ((x 1 2 3)) ...) */ + syntax_error_nr(sc, "let-temporarily: variable declaration has more than one value?: ~A", 66, var); + + if ((all_fx) && + ((!is_symbol(sym)) || (!is_fxable(sc, cadr(var))))) /* if all_fx, each var is (symbol fxable-expr) */ + all_fx = false; + if ((all_s7) && + ((!is_pair(sym)) || (car(sym) != sc->starlet_symbol) || + (!is_quoted_symbol(cadr(sym))) || (is_keyword(cadr(cadr(sym)))) || + (!is_fxable(sc, cadr(var))))) + 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 (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars)) + fx_annotate_arg(sc, cdar(vars), 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 */ + { + const 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))) && + (starlet_symbol_id(cadr(cadar(var))) == sl_openlets)) /* (cadr(cadar(var)) == make_symbol_with_strlen(sc, "openlets"))) */ + { + pair_set_syntax_op(form, OP_LET_TEMP_S7_OPENLETS); + 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); + const 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); + const s7_pointer settee = car(binding); + const 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_pair, goto_do_unchecked, goto_pop_read_list, + goto_read_tok, goto_feed_to, goto_set_unchecked} 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))) + { + const s7_pointer settee = caar(sc->args), p = cdddr(sc->args); + s7_pointer slot, 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_t_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 ( () like begin I guess */ + return(fall_through); +} + +static bool op_let_temp_done1(s7_scheme *sc) +{ + while (is_pair(car(sc->args))) + { + const 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->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); else sym = keyword_symbol(sym); + 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_t_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 *starlet_immutable_field = NULL; + +static bool op_let_temp_s7(s7_scheme *sc) /* all entries are of the form ((*s7* 'field) fx-able-value) */ +{ + const s7_pointer code = cdr(sc->code); /* don't use sc->code here -- it can be changed */ + s7_pointer *end = sc->stack_end; + for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars)) + { + s7_pointer old_value; + const s7_pointer field = cadadr(caar(vars)); /* p: (((*s7* 'expansions?) #f)) -- no keywords here (see check_let_temporarily) */ + if (starlet_immutable_field[starlet_symbol_id(field)]) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "let-temporarily: can't set! (*s7* '~S)", 38), field)); + old_value = starlet(sc, starlet_symbol_id(field)); + /* check_stack_size(sc); */ /* t101-42 but commented out (probably the #symbol stuff) */ + push_stack(sc, OP_LET_TEMP_S7_UNWIND, old_value, field); + } + for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars), end += 4) + starlet_set_1(sc, T_Sym(end[0]), fx_call(sc, cdar(vars))); + 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) +{ + 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_openlets(s7_scheme *sc) +{ + s7_pointer new_val; + push_stack_no_code(sc, OP_LET_TEMP_S7_OPENLETS_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_openlets_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 *end = sc->stack_end; + sc->code = cdr(sc->code); + + for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars)) + { + const s7_pointer var = car(vars); + const s7_pointer settee = car(var); + const 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_3(sc, immutable_error_string, sc->let_temporarily_symbol, settee)); + push_stack(sc, OP_LET_TEMP_UNWIND, slot_value(slot), slot); + } + for (s7_pointer vars = car(sc->code); is_pair(vars); vars = cdr(vars), end += 4) + { + s7_pointer var = car(vars); + s7_pointer new_val = fx_call(sc, cdr(var)); + const s7_pointer 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)) /* (define (f) (let-temporarily ((_asdf_ 32)) (+ 1 2))) (catch #t f (lambda args args)) (f) */ + 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_t_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; + const s7_pointer 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; + const s7_pointer 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 */ +{ + const 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) +{ + const s7_pointer code = cdr(form); + s7_pointer cdr_code; + 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) ==> # 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) +{ + const 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 + { + const 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) +{ + const 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) +{ + const 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; + const s7_int 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; + const s7_pointer code = cdr(sc->code); + const 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) + error_nr(sc, sc->syntax_error_symbol, + set_elist_4(sc, wrap_string(sc, "~A's first argument, ~A, is ~A but should be a list: (name ...)", 63), + caller, car(code), object_type_name(sc, car(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)) && + (is_global(caadr(code)))) + { + if ((is_defined_global(func)) && (is_immutable(global_slot(func))) && (initial_value_is_defined(func))) + immutable_object_error_nr(sc, set_elist_3(sc, wrap_string(sc, "can't ~A ~S: it is immutable", 28), caller, func)); + 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_defined_global(func)) && (is_immutable(global_slot(func))) && (initial_value_is_defined(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) +{ + const s7_pointer code = cdr(sc->code); + s7_pointer 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))) + { + const s7_pointer definee = car(code); + sc->code = cadr(code); + if (is_pair(sc->code)) + { + push_stack_no_args(sc, OP_DEFINE1, definee); + sc->cur_op = optimize_op(sc->code); + return(true); + } + sc->value = (is_symbol(sc->code)) ? lookup_global(sc, sc->code) : sc->code; + sc->code = definee; + } + else + { + const 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. + */ + const s7_pointer func = 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(func), pair_location(locp)); + set_has_location(closure_body(func)); + } + sc->value = T_Ext(func); + 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, pars; + 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); + + pars = closure_pars(new_func); + if (is_null(pars)) + { + 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(pars)) + { + last_slot = make_slot(sc, car(pars), sc->nil); + slot_set_next(last_slot, slot_end); + let_set_slots(new_let, last_slot); + symbol_set_local_slot(car(pars), let_id(new_let), last_slot); + for (pars = cdr(pars); is_pair(pars); pars = cdr(pars)) + last_slot = add_slot_at_end(sc, let_id(new_let), last_slot, car(pars), sc->nil); + } + if (is_symbol(pars)) + { + if (last_slot) + last_slot = add_slot_checked_at_end(sc, let_id(new_let), last_slot, pars, sc->nil); + else + { + last_slot = make_slot(sc, pars, sc->nil); + slot_set_next(last_slot, slot_end); + let_set_slots(new_let, last_slot); + symbol_set_local_slot(pars, 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(pars); pars = cdr(pars)) + { + s7_pointer par = car(pars); + if (is_pair(par)) + { + const 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) + { + pars = cdr(pars); + slot = add_slot_checked(sc, new_let, car(pars), 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(pars)) + { + slot = add_slot_checked(sc, new_let, pars, sc->nil); /* set up rest pars */ + 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, parameter-holding-let will be created on each call */ + return(new_let); +} + +static bool op_define_constant(s7_scheme *sc) +{ + const 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)) && + (is_global(car(code))) && /* else (let iter ... (define-constant iter iter) ...) -> segfault on later calls */ + (is_null(cddr(code)))) + { + const 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)) + { + const s7_pointer slot = s7_t_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; + const s7_pointer code = cdr(sc->code); + const s7_pointer func_name = caar(code); + + new_cell(sc, new_func, T_CLOSURE | ((!s7_is_proper_list(sc, cdar(code))) ? T_COPY_ARGS : 0)); + closure_set_pars(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, func_name, 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(func_name)) + sc->let_number++; /* dummy let, force symbol lookup */ + + /* see if func_name exists in curlet, reset its value if so */ + for (s7_pointer slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == func_name) + { + if (is_immutable_slot(slot)) + syntax_error_nr(sc, "define ~S, but it is immutable", 30, func_name); + slot_set_value(slot, new_func); + symbol_set_local_slot(func_name, sc->let_number, slot); + if (sc->curlet == sc->rootlet) set_global_value(func_name, new_func); + set_local(func_name); + sc->value = new_func; + return; + } + + /* else add a slot for func_name */ + if (sc->curlet == sc->rootlet) /* (let () (define (func) (with-let (rootlet) (define (f x) (+ x 1)))) (func) (func)) */ + s7_define(sc, sc->rootlet, func_name, new_func); + else add_slot_unchecked(sc, sc->curlet, func_name, 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; + const s7_pointer 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; + const s7_pointer 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)) */ +{ + const 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); /* the !is_pair case raised an error in check_macro */ + } + sc->value = make_macro(sc, sc->cur_op, false); +} + +static void op_define_macro(s7_scheme *sc) +{ + const 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 func, 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_pars(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 (ca. 20 cases in s7test.scm) */ + return(unknown_any(sc, sc->value, sc->code)); /* see m4 in tmac.scm, macro -> macro* could be handled in place: call apply_macro_star_1(sc) */ + sc->args = cdr(sc->code); /* used to copy here, but that appears to be unnecessary */ + 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) +{ + const 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 void check_c_macro_args(s7_scheme *sc, s7_pointer mac, s7_pointer args) +{ + const s7_int len = proper_list_length(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)); +} + +static goto_t op_expansion(s7_scheme *sc) +{ + const 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 */ + { + const s7_pointer symbol = car(sc->value); + if (!is_let(sc->curlet)) set_curlet(sc, sc->rootlet); + + if (is_symbol(symbol)) /* maybe (#_cond-expand) etc */ + { + s7_pointer slot; + if ((is_global(symbol)) || (sc->curlet == sc->nil)) + slot = global_slot(symbol); + else slot = s7_t_slot(sc, symbol); + sc->code = (is_slot(slot)) ? slot_value(slot) : sc->undefined; + } + else sc->code = symbol; + + if ((!is_any_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); + if (is_c_macro(sc->code)) + { + check_c_macro_args(sc, sc->code, sc->args); + sc->value = c_macro_call(sc->code)(sc, sc->args); + return(goto_start); + } + 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); /* apply_lambda probably handles arg number checks */ + 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) */ +{ + check_c_macro_args(sc, 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) +{ + const 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 #? I think that + * happens now without generating a multiple_value object: + * (define-macro (hi) (values)) (hi) -> # + * (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 s7_pointer fx_with_let_s(s7_scheme *sc, s7_pointer arg) +{ + const s7_pointer code = cdr(arg); + s7_pointer e = lookup_checked(sc, car(code)); + const s7_pointer sym = cadr(code); + s7_pointer val; + if (!is_let(e)) + { + e = find_let(sc, e); + if (!is_let(e)) + { + s7_pointer new_let = find_let(sc, e); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->with_let_symbol, e, new_let, 1, set_mlist_1(sc, e)); + e = new_let; + }} + /* e here if mock-hash can be (for example) (inlet 'value (hash-table 'b 2) 'mock-type mock-hash-table?) + * mock-hash has let-ref-fallback which calls (#_hash-table-ref (e 'value) sym) -> (e 'value) is a hash-table, so returns #f if not in table + * we go directly to this function in check_with_let to avoid this ambiguity + */ + 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 #: (with-let (inlet 'x #) x) */ + { + if (is_slot(global_slot(sym))) /* (let () (define (func) (with-let *s7* letrec*)) (func) (func)), .5 tlet */ + return(global_value(sym)); /* used to check also that e=*s7* */ + if (is_slot(lookup_slot_with_let(sc, sym, e))) /* check for explicit # value! */ + return(sc->undefined); + unbound_variable_error_nr(sc, sym); + } + return(val); +} + +static bool check_with_let(s7_scheme *sc) +{ + const s7_pointer form = cdr(sc->code); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: op: %s, form: %s\n", __func__, __LINE__, op_names[stack_top_op(sc)], display_truncated(form)); + if (!is_pair(form)) /* (with-let . "hi") */ + syntax_error_nr(sc, "with-let takes a let (an environment) argument: ~A", 50, 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); + if ((sc->safety > 1) && (is_symbol(car(form))) && (is_c_function(initial_value(car(form))))) + s7_warn(sc, 256, "%s is a strange first argument to with-let\n", display(car(form))); /* (with-let curlet ...) where they probably meant (with-let (curlet) ...) */ + set_current_code(sc, sc->code); + if ((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)))) + { + pair_set_syntax_op(sc->code, OP_WITH_LET_S); + sc->value = fx_with_let_s(sc, sc->code); + return(false); + } + else pair_set_syntax_op(sc->code, OP_WITH_LET_UNCHECKED); + return(true); +} + +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 void activate_starlet(s7_scheme *sc) +{ + const s7_pointer new_e = let_copy(sc, sc->starlet); /* get fallback methods */ + const s7_pointer iter = s7_make_iterator(sc, sc->starlet); + gc_protect_2_via_stack(sc, new_e, iter); + iterator_carrier(iter) = cons_unchecked(sc, sc->F, sc->F); + set_has_carrier(iter); + while (true) + { + const s7_pointer field = s7_iterate(sc, iter); /* next *s7* field as '(symbol . value) */ + if (iterator_is_at_end(iter)) break; + if (lookup_unexamined(sc, car(field))) + add_slot_checked_with_id(sc, new_e, car(field), cdr(field)); + } + set_curlet(sc, new_e); + set_immutable_let(new_e); + unstack_gc_protect(sc); +} + +static void activate_with_let(s7_scheme *sc, s7_pointer e) +{ + if (!is_let(e)) /* (with-let . "hi") */ + { + const s7_pointer new_e = find_let(sc, e); /* sc->nil/rootlet here means no let found */ + if (!is_let(new_e)) + error_nr(sc, sc->wrong_type_arg_symbol, set_elist_2(sc, wrap_string(sc, "with-let takes a let (an environment) argument: ~A", 50), e)); + e = new_e; + } + if (e == sc->rootlet) + set_curlet(sc, e); /* (with-let (rootlet) ...) */ + else + if (e == sc->starlet) + activate_starlet(sc); + 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 clauses; + const s7_pointer 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 (clauses = code; is_pair(clauses); clauses = cdr(clauses)) + if (!is_pair(car(clauses))) /* (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(clauses), object_to_string_truncated(sc, form))); + else + { + const s7_pointer clause = car(clauses); + if (!s7_is_proper_list(sc, cdr(clause))) /* (cond (xxx . 1)) */ + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "stray dot? ~S in ~A", 19), + clause, object_to_string_truncated(sc, form))); + if (is_pair(cdr(clause))) + { + if (is_pair(cddr(clause))) result_single = false; + if (is_undefined_feed_to(sc, cadr(clause))) + { + has_feed_to = true; + if (!is_pair(cddr(clause))) /* (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), + clauses, object_to_string_truncated(sc, form))); + if (is_pair(cdddr(clause))) /* (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), + clauses, object_to_string_truncated(sc, form))); + }} + else result_single = false; + } + if (is_not_null(clauses)) /* (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 (clauses = code; is_pair(clauses); clauses = cdr(clauses)) + { + s7_pointer clause = car(clauses); + /* clear_has_fx(clause); */ /* 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(clause))) + fx_annotate_arg(sc, clause, sc->curlet); + for (clause = cdr(clause); is_pair(clause); clause = cdr(clause)) + if (!has_fx(clause)) + { + s7_function func = fx_choose(sc, clause, sc->curlet, let_symbol_is_safe); + if (func) set_fx_direct(clause, func); 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))) + { + const s7_pointer arg2 = caddar(code); + if ((is_proper_list_3(sc, arg2)) && + (car(arg2) == sc->lambda_symbol)) + { + const s7_pointer arg = cadr(arg2); + if ((is_pair(arg)) && + (is_null(cdr(arg))) && + (is_symbol(car(arg)))) /* (define (hi) (cond (#t => (lambda (s) s)))) looking at (s) */ + { + set_opt2_lambda(code, arg2); /* (lambda ...) above */ + pair_set_syntax_op(form, OP_COND_FEED); + }}}} + else + { + s7_pointer clause; + bool xopt = true; + int32_t i; + pair_set_syntax_op(form, OP_COND_SIMPLE); + for (i = 0, clause = code; xopt && (is_pair(clause)); i++, clause = cdr(clause)) + xopt = ((has_fx(car(clause))) && (is_pair(cdar(clause)))); + 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) + { + s7_pointer p = caadr(code); + if ((p == sc->T) || ((p == sc->else_symbol) && (is_global(sc->else_symbol)))) + pair_set_syntax_op(form, OP_COND_NA_2E); + } + else + if (i == 3) + { + s7_pointer p = caaddr(code); + if ((p == sc->T) || ((p == sc->else_symbol) && (is_global(sc->else_symbol)))) + 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); /* goto APPLY */ + }} + 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); + /* it would be nice to see T_C_FUNCTION here and call apply_c_function_unopt, but that requires either a switch (to continue) or putting this in the eval function */ + return(true); /* goto APPLY */ + } + 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); /* goto EVAL */ +} + + +/* -------------------------------- set! -------------------------------- */ +static void check_set(s7_scheme *sc) +{ + const s7_pointer form = sc->code, code = cdr(sc->code); + s7_pointer 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)" */ + (is_c_function(settee)) ? set_elist_2(sc, wrap_string(sc, "set! can't change ~S (a c-function)", 35), settee) : + 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 */ + { + const 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->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)) && (starlet_symbol_id(sym) != sl_no_field)) + { + /* perhaps preset field -> op_print_length_set[misc?]|safety[tstar] etc */ + set_safe_optimize_op(form, OP_IMPLICIT_STARLET_SET_S); + 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 */ + { + const 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)) + { + const s7_pointer slot = s7_slot(sc, settee); + if ((is_slot(slot)) && + (!slot_has_setter(slot)) && + (!is_immutable(slot)) && + (!is_syntactic_symbol(settee)) && + (!s7_tree_memq(sc, sc->setter_symbol, value))) /* (set! x (set! (setter 'x) ...) ...)! */ + { + if (is_normal_symbol(value)) + { + const 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_opt1_con(code, (is_pair(value)) ? cadr(value) : value); /* collision if ((values set!) x 32) code: (x 32) value: 32, opt2: fx_s, opt1|3 is free */ + } + else + { + const s7_pointer cddr_value = (is_pair(cdr(value))) ? cddr(value) : NULL; + 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_SS); + /* fx_annotate_arg(sc, cddr_value, sc->curlet); */ /* this sets fx_proc(cddr_value) */ + 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))) + { /* a=symbol case does happen here */ + pair_set_syntax_op(form, (is_symbol(caddr(value))) ? OP_INCREMENT_SS : OP_INCREMENT_SA); + fx_annotate_arg(sc, cddr_value, sc->curlet); /* this sets fx_proc(arg) -- usually set much earlier in optimize_lambda? */ + + /* an experiment */ + if ((has_fx(cddr_value)) && (fx_proc(cddr_value) == fx_multiply_sa)) + set_fx_direct(cddr_value, fx_multiply_sa_wrapped); + + 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_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_t_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 = opt1_con(cdr(sc->code))); +} + +static inline void op_set_s_s(s7_scheme *sc) +{ + s7_pointer slot = T_Slt(s7_t_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_t_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, but no setter */ +{ + s7_pointer slot = s7_t_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_t_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_t_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_t_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_t_slot(sc, car(sc->code)); + arg = opt2_pair(sc->code); /* cddr(value) */ + 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 void op_increment_ss(s7_scheme *sc) +{ + s7_pointer slot, arg; + sc->code = cdr(sc->code); + slot = s7_t_slot(sc, car(sc->code)); + arg = opt2_pair(sc->code); /* cddr(value) */ + set_car(sc->t2_2, lookup(sc, car(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 no_return 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? + */ + const int32_t typ = type(obj); + if (!is_pair(car(sc->code))) sc->code = cdr(sc->code); + + if (is_any_c_function(caar(sc->code))) + 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))) ? sc->z = 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)) + sc->args = list_2(sc, arg, value); + else sc->args = with_list_t2(arg, value); + sc->value = c_function_call(setf)(sc, sc->args); + 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_COMPLEX_VECTOR: /* cfft in tcomplex hits this */ + sc->value = complex_vector_set_p_ppp(sc, 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 = vector_set_p_ppp(sc, 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_or_map_list(obj))) + return(pair3_cfunc(sc, obj, closure_setter(obj), arg, value)); + sc->code = closure_setter_or_map_list(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; + const s7_pointer code = cdr(sc->code), 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; + const s7_pointer code = cdr(sc->code), obj = lookup_checked(sc, caar(code)); + if (could_be_macro_setter(obj)) + { + const 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); /* goto APPLY */ + }} + 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_gc_protected2(sc, index); + return(set_pair3(sc, obj, index, value)); + /* set_pair3 can assume goto apply as above, and can push the setter on the stack preparing to goto apply, but that means + * we can't blithely unstack_gc_protect. + * (set! (setter for-each) map) (define (func) (set! (for-each (make-vector '(2 3 4) 1)) (vector-append))) (func) (func) + * set_pair3 -> pair3_cfunc which returns false even if it invokes map so we have no way to tell whether we can unstack. + */ +} + +static inline bool op_set_opsaq_p(s7_scheme *sc) +{ + const 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)) + */ + const 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); /* goto APPLY */ + }} + push_stack(sc, OP_SET_opSAq_P_1, obj, code); + sc->code = cadr(code); + return(false); /* goto EVAL */ +} + +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)); + break; + case T_COMPLEX_VECTOR: + sc->value = g_complex_vector_set(sc, set_plist_4(sc, obj, index1, index2, value)); + 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_or_map_list(obj))) + return(pair4_cfunc(sc, obj, closure_setter(obj), index1, index2, value)); + sc->code = closure_setter_or_map_list(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; + const s7_pointer code = cdr(sc->code), obj = lookup_checked(sc, caar(code)); + bool result; + if (could_be_macro_setter(obj)) + { + const 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_gc_protected2(sc, index1); + result = set_pair4(sc, obj, index1, fx_call(sc, cddar(code)), value); + if (!result) unstack_gc_protect(sc); /* see comment under op_set_opsaq_a above */ + return(result); +} + +static bool op_set_opsaaq_p(s7_scheme *sc) +{ + const s7_pointer code = cdr(sc->code), obj = lookup_checked(sc, caar(code)); + if (could_be_macro_setter(obj)) + { + const 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) +{ + const 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); + if (!result) unstack_gc_protect(sc); + return(result); +} + +static bool op_set1(s7_scheme *sc) +{ + const s7_pointer sym = T_Sym(sc->code); /* protect from sc->code possible change in call_c_function_setter below */ + const s7_pointer slot = s7_slot(sc, sym); /* if unbound variable hook here, we need the binding, not the current value */ + if (is_slot(slot)) + { + if (is_immutable_slot(slot)) + { + if (s7_is_eqv(sc, slot_value(slot), 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(slot)) + { + const s7_pointer setter = slot_setter(slot); + if (is_c_function(setter)) + sc->value = call_c_function_setter(sc, setter, sym, sc->value); /* perhaps better: apply_c_function -- has argnum error checks */ + else + if (is_any_procedure(setter)) + { + /* 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, slot); + if (has_let_arg(setter)) + 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 = setter; + return(false); /* goto APPLY */ + }} + slot_set_value(slot, 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)) */ + { + if (starlet_symbol_id(sym) != sl_no_field) + error_nr(sc, sc->unbound_variable_symbol, + set_elist_5(sc, wrap_string(sc, "unbound variable ~S in (set! ~S ~S), perhaps you meant (*s7* '~S)?", 66), sym, sym, sc->value, sym)); + 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, settee; + const s7_pointer val = sc->value; + /* from the T_SYNTAX branch of op_set_pair: (set! (with-let e settee) val) as in let-temporarily + * here sc->value is the new value for the settee = val, args has the (as yet unevaluated) let and settee-expression. + * 'settee 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); + settee = cadr(sc->args); + if (is_multiple_value(val)) /* (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, settee, val)); + if (is_symbol(e)) + { + if (is_symbol(settee)) + { + 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, settee, val); + pop_stack(sc); + return(true); + } + sc->value = lookup_checked(sc, e); + sc->code = set_plist_3(sc, sc->set_symbol, settee, ((is_symbol(val)) || (is_pair(val))) ? set_plist_2(sc, sc->quote_function, val) : val); + /* (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, settee, val); /* 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 settee, val; + /* here sc->value = let = 'e, args = '(settee val) where 'settee might be a pair */ + if (!is_let(sc->value)) + wrong_type_error_nr(sc, sc->let_set_symbol, 1, sc->value, a_let_string); + settee = car(sc->args); + if ((!is_symbol(settee)) && (!is_pair(settee))) + error_nr(sc, sc->syntax_error_symbol, + set_elist_3(sc, wrap_string(sc, "can't set ~S in ~$", 18), settee, set_ulist_1(sc, global_value(sc->set_symbol), sc->args))); + val = cadr(sc->args); + if (is_symbol(settee)) /* settee is a symbol -- everything else is ready so call let-set! */ + { + sc->value = let_set_1(sc, sc->value, settee, val); + return(true); /* continue */ + } + if ((is_symbol(val)) || (is_pair(val))) /* (set! (with-let (inlet :v (vector 1 2)) (v 0)) 'a) */ + sc->code = list_3(sc, sc->set_symbol, settee, + ((is_symbol(val)) || (is_pair(val))) ? list_2(sc, sc->quote_function, val) : val); + else sc->code = cons(sc, sc->set_symbol, sc->args); /* (set! (with-let (curlet) (*s7* 'print-length)) 16), val=16 b=(*s7* 'print-length) */ + return(false); /* fall into SET_WITH_LET */ +} + +static bool op_set_normal(s7_scheme *sc) +{ + s7_pointer val; + sc->code = cdr(sc->code); + val = cadr(sc->code); + if (is_pair(val)) + { + push_stack_no_args(sc, OP_SET1, car(sc->code)); + sc->code = val; + return(true); + } + sc->value = (is_symbol(val)) ? lookup_checked(sc, val) : T_Ext(val); + 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 */ +{ + const s7_pointer slot = T_Slt(s7_t_slot(sc, cadr(sc->code))); + const s7_pointer val = slot_value(slot); + 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(slot, sc->value); +} + +static void op_decrement_by_1(s7_scheme *sc) /* ([set!] ctr (- ctr 1)) */ +{ + const s7_pointer slot = T_Slt(s7_t_slot(sc, cadr(sc->code))); + const s7_pointer val = slot_value(slot); + 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_2(sc, set_plist_2(sc, val, int_one)); + break; + } + slot_set_value(slot, sc->value); +} + + +/* ---------------- implicit ref/set ---------------- */ +static Inline bool inline_op_implicit_vector_ref_a(s7_scheme *sc) /* called once in eval, Inline because tnum/tmat get ridiculous call overhead (70!) */ +{ + s7_pointer ind; + const s7_pointer vec = lookup_checked(sc, car(sc->code)); + if (!is_any_vector(vec)) {sc->last_function = vec; return(false);} + ind = fx_call(sc, cdr(sc->code)); + if ((s7_is_integer(ind)) && (vector_rank(vec) == 1)) + { + s7_int index = s7_integer_clamped_if_gmp(sc, ind); + if ((index < vector_length(vec)) && (index >= 0)) + { + sc->value = (is_float_vector(vec)) ? make_real(sc, float_vector(vec, index)) : vector_getter(vec)(sc, vec, index); + return(true); + }} + sc->value = vector_ref_1(sc, vec, set_plist_1(sc, ind)); + return(true); +} + +static s7_pointer fx_implicit_vector_ref_a(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer ind; + const s7_pointer vec = lookup_checked(sc, car(arg)); + if (!is_any_vector(vec)) + return(s7_apply_function(sc, vec, list_1(sc, fx_call(sc, cdr(arg))))); + ind = fx_call(sc, cdr(arg)); + if ((s7_is_integer(ind)) && (vector_rank(vec) == 1)) + { + s7_int index = s7_integer_clamped_if_gmp(sc, ind); + if ((index < vector_length(vec)) && (index >= 0)) + return(vector_getter(vec)(sc, vec, index)); + } + return(vector_ref_1(sc, vec, set_plist_1(sc, ind))); +} + +static bool op_implicit_vector_ref_aa(s7_scheme *sc) /* tnum/tmat, neither uses fx case if available (see tmp) */ +{ + s7_pointer ind1, ind2, code; + const s7_pointer vec = lookup_checked(sc, car(sc->code)); + if (!is_any_vector(vec)) {sc->last_function = vec; return(false);} + code = cdr(sc->code); + ind1 = fx_call(sc, code); + gc_protect_via_stack(sc, ind1); + ind2 = fx_call(sc, cdr(code)); + set_gc_protected2(sc, ind2); + if ((s7_is_integer(ind1)) && (s7_is_integer(ind2)) && (vector_rank(vec) == 2)) + { + s7_int i1 = s7_integer_clamped_if_gmp(sc, ind1); + s7_int i2 = s7_integer_clamped_if_gmp(sc, ind2); + if ((i1 >= 0) && (i2 >= 0) && + (i1 < vector_dimension(vec, 0)) && (i2 < vector_dimension(vec, 1))) + { + s7_int index = (i1 * vector_offset(vec, 0)) + i2; + sc->value = (is_float_vector(vec)) ? make_real(sc, float_vector(vec, index)) : vector_getter(vec)(sc, vec, index); /* check for normal vector saves in some cases, costs in others */ + unstack_gc_protect(sc); + return(true); + }} + sc->value = vector_ref_1(sc, vec, set_plist_2(sc, ind1, ind2)); + unstack_gc_protect(sc); + return(true); +} + +static goto_t call_set_implicit(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val, s7_pointer form); + +static void setup_eval_args_pair(s7_scheme *sc, s7_pointer obj, s7_pointer inds, s7_pointer val) +{ + push_stack(sc, OP_SET2, cdr(inds), val); + sc->code = list_2(sc, obj, car(inds)); + set_optimize_op(sc->code, OP_PAIR_ANY); /* usually an error: (#\a) etc, might be (#(0) 0) */ + sc->value = obj; + sc->code = cdr(sc->code); + push_op_stack(sc, sc->value); + if (sc->op_stack_now >= sc->op_stack_end) + resize_op_stack(sc); + sc->args = sc->nil; +} + +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; + const 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)); + }} + /* PERHAPS: do the loop here to collect the evaluated args, then call apply_vector */ + setup_eval_args_pair(sc, vect, inds, val); + return(goto_eval_args_pair); + } + if ((argnum > 1) || (vector_rank(vect) > 1)) + { + 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; + const 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_safe_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_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; + const s7_pointer s = lookup_checked(sc, car(sc->code)); + const s7_pointer val = fx_call(sc, cdr(sc->code)); + if (!is_string(s)) + { + sc->last_function = s; + return(false); + } + if (!s7_is_integer(val)) + { + sc->value = string_ref_1(sc, s, set_plist_1(sc, val)); + return(true); + } + index = s7_integer_clamped_if_gmp(sc, val); + 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, val); + 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; + const s7_pointer 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)); + } + setup_eval_args_pair(sc, lst, inds, val); /* (let ((L (list (list 1 2 3)))) (set! (L (- (length L) 1) 2) 0) L) */ + return(goto_eval_args_pair); + } + 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) + { + const s7_pointer obj = s7_hash_table_ref(sc, table, keyval); + if (obj == missing_key_value(sc)) /* (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)); + } + setup_eval_args_pair(sc, table, inds, val); /* key = car(inds) */ + return(goto_eval_args_pair); + } + if (keyval) + { + const 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) + { + const 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)); + } + setup_eval_args_pair(sc, let, inds, val); + return(goto_eval_args_pair); + /* this is unnecessary: continue at eval_last_arg+ goto apply -> apply_let -> pop_stack + goto top_no_pop */ + } + 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_or_map_list(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 (and 99% of these cases are handled elsewhere -- this is the eval fallback code) */ + 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: case T_COMPLEX_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, + set_elist_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; + const s7_pointer 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 no_return 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_scheme *sc, 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) && ((car(expr) != sc->set_symbol) || (!is_symbol(cadr(expr))))) 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))))); +} + +#if DO_PRINT +#define all_ints_here(Sc, Settee, Expr, Step_vars) all_ints_here_1(Sc, Settee, Expr, Step_vars, __func__, __LINE__) +#define do_return_false(body) do {if (DO_PRINT) fprintf(stderr, " %s[%d] from %s[%d]: %s\n", __func__, __LINE__, funcly, linely, display(body)); return(false);} while (0) +static bool all_ints_here_1(s7_scheme *sc, s7_pointer settee, s7_pointer expr, s7_pointer step_vars, const char *funcly, int linely) /* see also all_integers above */ +#else +#define do_return_false(body) return(false) +static bool all_ints_here(s7_scheme *sc, s7_pointer settee, s7_pointer expr, s7_pointer step_vars) /* see also all_integers above */ +#endif +{ + /* 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? */ + do_return_false(expr); + 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))) + do_return_false(expr); + func = lookup_unexamined(sc, car(expr)); + if (!func) do_return_false(expr); + if ((is_int_vector(func)) || (is_byte_vector(func))) return(true); + + if (is_either_macro(func)) + { + if (tree_memq_1(sc, car(step_vars), expr)) /* TODO: all step_vars? */ + do_return_false(expr); + if (tree_including_quote_memq(sc, car(step_vars), closure_body(func))) + do_return_false(expr); + return(true); + } + if (!is_any_c_function(func)) /* TODO: (case ...) */ + do_return_false(expr); + + if ((car(expr) == sc->vector_ref_symbol) && (is_pair(cdr(expr))) && (is_symbol(cadr(expr)))) + { + s7_pointer vec = lookup_unexamined(sc, cadr(expr)); + if ((vec) && ((is_int_vector(vec)) || (is_byte_vector(vec)))) return(true); + } + sig = c_function_signature(func); +#if 0 + if ((is_pair(sig)) && + ((car(sig) == sc->is_integer_symbol) || (car(sig) == sc->is_byte_symbol))) +#else + /* tvect tshoot tbig */ + 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))))))) + /* maybe make int|byte_vector_ref|set explicit, or check indices=rank? + * or just use (func == sc->int_vector_ref) etc + */ +#endif + return(true); + if (!is_all_integer(car(expr))) + do_return_false(expr); + for (s7_pointer p = cdr(expr); is_pair(p); p = cdr(p)) + if (!all_ints_here(sc, settee, car(p), step_vars)) + do_return_false(expr); + return(true); +} + +#if DO_PRINT +#define do_is_safe(Sc, Body, Stepper, Var_list, Step_vars, Has_set) do_is_safe_1(Sc, Body, Stepper, Var_list, Step_vars, Has_set, __func__, __LINE__) +static bool do_is_safe_1(s7_scheme *sc, s7_pointer body, s7_pointer stepper, s7_pointer var_list, s7_pointer step_vars, bool *has_set, const char *funcly, int linely) +#else +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) +#endif +{ + /* 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 + */ + const s7_pointer code = sc->code; /* only used once, but I worry about sc->code changing */ + for (s7_pointer exprs = body; is_pair(exprs); exprs = cdr(exprs)) + { + const s7_pointer expr = car(exprs); + if (is_pair(expr)) + { + const s7_pointer head = car(expr); + /* this used to be if (is_pair(head)) continue; */ + if ((!is_symbol(head)) && (!is_safe_c_function(head)) && (head != sc->quote_function) && (!is_pair(head))) + do_return_false(expr); + /* car(expr) ("head") 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(head)) + { + const opcode_t op = syntax_opcode(global_value(head)); + switch (op) + { + case OP_MACROEXPAND: + do_return_false(expr); + + case OP_QUOTE: + if ((!is_pair(cdr(expr))) || (!is_null(cddr(expr)))) /* (quote . 1) or (quote 1 2) etc */ + do_return_false(expr); + break; + + case OP_LET: case OP_LET_STAR: + case OP_LETREC: case OP_LETREC_STAR: + { + s7_pointer cp; + if ((!is_pair(cdr(expr))) || (!is_list(cadr(expr))) || (!is_pair(cddr(expr)))) + do_return_false(expr); + cp = var_list; + begin_temp(sc->y, sc->nil); + for (s7_pointer vars = cadr(expr); is_pair(vars); vars = cdr(vars)) + { + s7_pointer var; + if (!is_pair(car(vars))) {end_temp(sc->y); do_return_false(expr);} + var = caar(vars); + if (direct_memq(var, ((op == OP_LET) || (op == OP_LETREC)) ? cp : var_list)) {end_temp(sc->y); do_return_false(expr);} + if ((!is_symbol(var)) || (is_keyword(var))) {end_temp(sc->y); do_return_false(expr);} + cp = cons(sc, var, cp); + sc->y = cp; + } + end_temp(sc->y); + if (!do_is_safe(sc, cddr(expr), stepper, cp, step_vars, has_set)) + do_return_false(expr); + } + break; + + case OP_DO: + { + s7_pointer combined_vars, cp; + if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (do) or (do (...)) */ + do_return_false(expr); + cp = var_list; + sc->temp5 = cp; /* this can be stepped on -- t101-12..16 */ + combined_vars = (is_pair(cadr(expr))) ? pair_append(sc, cadr(expr), step_vars) : step_vars; + sc->w = combined_vars; + for (s7_pointer vars = cadr(expr); is_pair(vars); vars = cdr(vars)) + { + s7_pointer var; + if (!is_pair(car(vars))) {end_temp(sc->w); end_temp(sc->temp5); do_return_false(expr);} + var = caar(vars); + if ((direct_memq(var, cp)) || (var == stepper)) {end_temp(sc->w); end_temp(sc->temp5); do_return_false(expr);} + cp = cons(sc, var, cp); + sc->temp5 = cp; + if ((is_pair(cdar(vars))) && + (!do_is_safe(sc, cdar(vars), stepper, cp, combined_vars, has_set))) + {end_temp(sc->temp5); end_temp(sc->w); do_return_false(expr);} + } + end_temp(sc->temp5); + end_temp(sc->w); +#if 0 + if (!do_is_safe(sc, cddr(expr), stepper, cp, combined_vars, has_set)) + do_return_false(expr); +#endif + if ((is_pair(cdddr(expr))) && + (!do_is_safe(sc, cdddr(expr), stepper, cp, combined_vars, has_set))) + do_return_false(expr); + } + break; + + case OP_SET: + { + s7_pointer settee; + if ((!is_pair(cdr(expr))) || (!is_pair(cddr(expr)))) /* (set!) or (set! x) */ + do_return_false(expr); + settee = cadr(expr); + if (!is_symbol(settee)) /* (set! (...) ...) which is tricky due to setter functions/macros */ + { + if ((!is_pair(settee)) || (!is_symbol(car(settee)))) + do_return_false(expr); + if (!direct_memq(car(settee), var_list)) /* is it a local var */ + { + const s7_pointer setv = lookup_unexamined(sc, car(settee)); + if (!((setv) && + ((is_sequence(setv)) || + ((is_c_function(setv)) && (is_safe_procedure(c_function_setter(setv))))))) + do_return_false(expr); + /* 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 + { + const s7_pointer end_and_result = caddr(code); /* sc->code */ + /* I think this is trying to catch (set! end i) [do-test-20 s7test] etc and needs the end-and-result form to check that */ +#if 1 + if ((is_pair(end_and_result)) && + (is_pair(car(end_and_result))) && + (!is_syntax(caar(end_and_result)))) /* 10-Jan-24 but why? */ + { + bool result; + set_match_symbol(settee); + result = tree_match(car(end_and_result)); /* (set! end ...) in some fashion */ + clear_match_symbol(settee); + if (result) + { + if (DO_PRINT) + fprintf(stderr, "%s[%d]: %s in %s\n", __func__, __LINE__, display(settee), display_truncated(end_and_result)); + do_return_false(expr); + }} +#endif + if (!direct_memq(settee, var_list)) /* is some local variable being set? */ + { + const 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))) + { + if (DO_PRINT) + fprintf(stderr, "%s[%d]: %s (%s) not all_ints_here in %s with %s\n", __func__, __LINE__, + display(settee), display(val), display_truncated(caddr(expr)), display(step_vars)); + do_return_false(expr); + }}} + if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) + { + if (DO_PRINT) + fprintf(stderr, "%s[%d]: !do_is_safe %s %s %s %s\n", __func__, __LINE__, + display(expr), display(stepper), display(var_list), display(step_vars)); + do_return_false(expr); + } + if (!safe_stepper_expr(sc, expr, stepper)) /* is step var's value used as the stored value by set!? */ + { /* but this is safe if (set! loc i) where i is int because it checks and copies */ + if (DO_PRINT) + fprintf(stderr, " %s%s[%d]: !safe_stepper_expr %s with %s%s\n", + bold_text, __func__, __LINE__, display(expr), display(stepper), unbold_text); + do_return_false(expr); + }} + break; + + case OP_LET_TEMPORARILY: + if ((!is_pair(cdr(expr))) || + (!is_pair(cadr(expr))) || + (!is_pair(cddr(expr)))) + do_return_false(expr); + for (s7_pointer 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))) + do_return_false(expr); + if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) + do_return_false(expr); + break; + + case OP_COND: + for (s7_pointer cp = cdr(expr); is_pair(cp); cp = cdr(cp)) + if (!do_is_safe(sc, car(cp), stepper, var_list, step_vars, has_set)) + do_return_false(expr); + break; + + case OP_CASE: + if ((!is_pair(cdr(expr))) || + (!do_is_safe(sc, cadr(expr), stepper, var_list, step_vars, has_set))) + do_return_false(expr); + for (s7_pointer 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))) + do_return_false(expr); + 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)) + do_return_false(expr); + break; + + case OP_WITH_LET: + do_return_false(expr); /* 11-Jan-24, this was true!? */ + + default: + do_return_false(expr); + }} /* is_syntax(head=car(expr)) */ + else + if (head == sc->quote_function) + { + if ((!is_pair(cdr(expr))) || (!is_null(cddr(expr)))) /* (#_quote . 1) or (#_quote 1 2) etc */ + do_return_false(expr); + } + else + { + if ((is_pair(expr)) && (is_pair(cdr(expr)))) + { + if ((is_saver(head)) && (direct_translucent_member(stepper, cdr(expr)))) + do_return_false(expr); + if (is_setter(head)) /* tree_inspect_stepper in tmp? */ + { + s7_pointer arg; + for (arg = cdr(expr); is_pair(cdr(arg)); arg = cdr(arg)); + if ((car(arg) == stepper) || + ((is_pair(car(arg))) && + (((is_saver(caar(arg))) && (direct_memq(stepper, cdar(arg)))) || + ((is_translucent(caar(arg))) && (is_pair(cdar(arg))) && (cadar(arg) == stepper))))) /* is_pair for (write) etc */ + do_return_false(expr); + }} + + if ((is_pair(expr)) && (is_pair(cdr(expr))) && + (is_symbol(head)) && + (!initial_value_is_defined(head)) && + (direct_memq(stepper, cdr(expr)))) + { + const s7_pointer slot = s7_slot(sc, head); + if ((!is_slot(slot)) || (!is_applicable(slot_value(slot)))) /* expr: '(=> () ...) */ + do_return_false(expr); + if ((is_saver(slot_value(slot))) && /* || (is_translucent(slot_value(slot)))) && */ + (direct_translucent_member(stepper, cdr(expr)))) + do_return_false(expr); + } + + { /* if a macro check both expr and the macro body for the stepper */ + const s7_pointer val = (is_symbol(head)) ? lookup_unexamined(sc, head) : head; /* head is car(expr) 200 lines back (!) */ + if ((val) && (is_either_macro(val)) && (!is_setter(val))) + { + if (tree_memq_1(sc, stepper, expr)) + do_return_false(expr); + if (tree_including_quote_memq(sc, stepper, closure_body(val))) + do_return_false(expr); + return(true); + }} + + if (!is_optimized(expr)) + do_return_false(expr); + if (optimize_op(expr) == OP_UNKNOWN_NP) /* tmac, (mx 1 (3 4 5)) */ + do_return_false(expr); + if (!do_is_safe(sc, cdr(expr), stepper, var_list, step_vars, has_set)) + do_return_false(expr); + + if (is_setter(head)) + { + /* (hash-table-set! ht i 0): caddr is being saved, so this is not safe; similarly (vector-set! v 0 i) etc */ + 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))) || + ((head == 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; + /* and also set stepper unsafe? and also any other steppers */ + /* need a way to lock unsafe_stepper -- maybe set safe, clear here, do not set elsewhere */ + + if (!do_is_safe(sc, cddr(expr), stepper, var_list, step_vars, has_set)) + do_return_false(expr); + if (!safe_stepper_expr(sc, expr, stepper)) + do_return_false(expr); + }}}} + return(true); +} + +static bool preserves_type(s7_scheme *sc, uint32_t ctype) +{ + return((ctype == sc->add_class) || + (ctype == sc->subtract_class) || + (ctype == 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)))) + { + const 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) +{ + const s7_pointer vars = car(code); + s7_pointer e = NULL; + const s7_pointer pre_e = cons(sc, sc->nil, sc->nil); + gc_protect_via_stack(sc, pre_e); + + /* clear_big_symbol_set(sc); */ /* an experiment -- slightly slower than pre_e? */ + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + s7_function callee = NULL; + s7_pointer expr = cdar(p); /* init */ + /* add_symbol_to_big_symbol_set(sc, caar(p)); */ + 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 = cdr(expr); /* cddar(p): step */ + if (is_pair(expr)) + { + if ((is_pair(car(expr))) && + (!is_checked(car(expr)))) + { + if (!e) + { + begin_temp(sc->y, sc->nil); + for (e = vars; is_pair(e); e = cdr(e)) sc->y = cons(sc, caar(e), sc->y); + e = sc->y; /* only valid in step exprs, not in inits; also all vars are valid at any point in step exprs */ + end_temp(sc->y); + set_cdr(pre_e, e); /* we'll put each current var at top of this list to speed up the most likely search (arg_findable -> pair_symbol_is_safe) */ + } + set_car(pre_e, caar(p)); /* caar(p) == current var, highly likely it's in the step expr */ + optimize_expression(sc, car(expr), 0, pre_e, false); + } + callee = fx_choose(sc, expr, vars, do_symbol_is_safe); /* fx_proc can be nil! */ + if (callee) set_fx(expr, callee); + }} + unstack_gc_protect(sc); + /* clear_big_symbol_set(sc); */ + + 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_definer(s7_pointer vec) +{ + s7_int len = vector_length(vec); + s7_pointer *els = vector_elements(vec); + 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_definer(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? + */ + s7_int i = 0; + for (s7_pointer p = tree; is_pair(p); p = cdr(p), i++) + { + s7_pointer pp = car(p); + if (is_symbol(pp)) + { + if (is_definer(pp)) + { + 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_definer(sc, pp)) + return(true); + } + else + if ((is_applicable(pp)) && + (((is_t_vector(pp)) && (do_vector_has_definer(pp))) || + ((is_c_function(pp)) && (is_func_definer(pp))) || + ((is_syntax(pp)) && (is_syntax_definer(pp))))) + return(true); + if (i > 10000) return(true); + } + return(false); +} + +static void check_do_for_obvious_errors(s7_scheme *sc, s7_pointer form) +{ + const s7_pointer 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))) + { + s7_pointer vars; + begin_small_symbol_set(sc); + for (vars = car(code); is_pair(vars); vars = cdr(vars)) + { + const s7_pointer var = car(vars); + if (!is_pair(var)) /* (do (4) (= 3)) */ + syntax_error_nr(sc, "do: variable name missing? ~A", 29, form); + + if (!is_symbol(car(var))) /* (do ((3 2)) ()) */ + syntax_error_nr(sc, "do step variable: ~S is not a symbol?", 37, var); + + if (is_constant_symbol(sc, car(var))) /* (do ((pi 3 (+ pi 1))) ((= pi 4)) pi) */ + syntax_error_nr(sc, "do step variable: ~S is immutable", 33, var); + + if (!is_pair(cdr(var))) + syntax_error_nr(sc, "do: step variable has no initial value: ~A", 42, vars); + if (!is_pair(cddr(var))) + { + if (is_not_null(cddr(var))) /* (do ((i 0 . 1)) ...) */ + syntax_error_nr(sc, "do: step variable info is an improper list?: ~A", 47, vars); + } + else + if (is_not_null(cdddr(var))) /* (do ((i 0 1 (+ i 1))) ...) */ + syntax_error_nr(sc, "do: step variable info has extra stuff after the increment: ~A", 62, vars); + set_local(car(var)); + + if (symbol_is_in_small_symbol_set(sc, car(var))) /* (do ((i 0 (+ i 1)) (i 2))...) */ + syntax_error_nr(sc, "duplicate identifier in do: ~A", 30, vars); + add_symbol_to_small_symbol_set(sc, car(var)); + } + if (is_not_null(vars)) /* (do ((i 0 i) . 1) ((= i 1))) */ + syntax_error_nr(sc, "do: list of variables is improper: ~A", 37, form); + end_small_symbol_set(sc); + } + if (is_pair(cadr(code))) + { + s7_pointer p; + for (p = cadr(code); is_pair(p); p = cdr(p)); + if (is_not_null(p)) /* (do ((i 0 (+ i 1))) ((= i 2) . 3) */ + syntax_error_nr(sc, "stray dot in do end section? ~A", 31, form); + } + { + s7_pointer p; + for (p = cddr(code); is_pair(p); p = cdr(p)); /* body */ + if (is_not_null(p)) + syntax_error_nr(sc, "stray dot in do body? ~A", 24, form); + } +} + +static s7_pointer do_end_bad(s7_scheme *sc, s7_pointer form) +{ + const s7_pointer code = cdr(form); + if (is_null(cddr(code))) + { + /* no body, end not fxable (if eval car(end) might be unopt) */ + for (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars)) /* gather var names */ + { + s7_pointer var = car(vars); + 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 (s7_pointer vars = car(code); is_pair(vars); vars = cdr(vars)) /* look for stuff like (do ((i 0 j) (j 0 (+ j 1))) ((= j 3) i)) */ + { + s7_pointer var = car(vars); + s7_pointer val = cddr(var); + if (is_pair(val)) + { + clear_match_symbol(car(var)); /* ignore current var */ + if (tree_match(car(val))) + { + for (s7_pointer q = car(code); is_pair(q); q = cdr(q)) + clear_match_symbol(caar(q)); + return(code); + }} + set_match_symbol(car(var)); + } + { + s7_pointer vars; + for (vars = car(code); is_pair(vars); vars = cdr(vars)) /* clear var names */ + clear_match_symbol(caar(vars)); + if (is_null(vars)) + { + 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 (s7_pointer vars1 = car(code); is_pair(vars1); vars1 = cdr(vars1)) + { + s7_pointer var = car(vars1); + 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, code if not(?) */ + const s7_pointer form = sc->code; + s7_pointer body, end, vars, code; + + check_do_for_obvious_errors(sc, form); + pair_set_syntax_op(form, OP_DO_UNCHECKED); + code = cdr(form); /* ok here, since check_do_for_obvious_errors will call error_nr otherwise */ + 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 big_symbol_set via check_do_for_obvious_errors(???), 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 */ + { + s7_pointer slot = let_slots(sc->curlet); + v1 = slot_symbol(slot); + slot = next_slot(slot); + if (tis_slot(slot)) + { + v2 = slot_symbol(slot); + slot = next_slot(slot); + if (tis_slot(slot)) + { + v3 = slot_symbol(slot); + more_vs = tis_slot(next_slot(slot)); + }}} + if (v1) fx_tree_outer(sc, end, v1, v2, v3, more_vs); + }} + return(sc->nil); + } + + if ((sc->safety > no_safety) && (tree_is_cyclic(sc, form))) + return(form); + if (do_tree_has_definer(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 */ + const s7_pointer v = car(vars); + s7_pointer 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) + { + const 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; + const 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_class_and_fn_proc(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))) + { + const opcode_t op = optimize_op(car(body)); + 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? */ + + /* this code sets the hop bit in any outer safe function call. I tried a procedure (leaf_hopper in tmp) that + * walked the body setting all the hop bits; this worked in all tests, but cost as much as it saved. + * this was in the inner block below originally. + */ + if ((is_optimized(car(body))) && + ((is_safe_c_op(op)) || (is_safe_closure_op(op)) || (is_safe_closure_star_op(op))) && + (!op_has_hop(car(body)))) + set_optimize_op(car(body), op + 1); /* set hop bit if it's a safe_closure call in a safe do loop */ + + if ((!has_set) && + (c_function_class(opt1_cfunc(end)) == sc->num_eq_class)) + { + /* vars is of the form ((i 0 (+ i 1))) -- 1 var etc */ + pair_set_syntax_op(form, OP_SAFE_DOTIMES); /* safe_dotimes: end is = */ + if (is_fxable(sc, car(body))) + fx_annotate_arg(sc, body, set_plist_1(sc, caar(vars))); /* if _args, fxification ignored? (need safe_closure_s_na etc) */ + /* is this redundant? safe_closure_s_a must already have fx, and otherwise it is ignored */ + } + 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 (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const 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 (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + s7_pointer var = car(p); + const 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 (s7_pointer p = vars; is_pair(p); p = cdr(p)) + set_match_symbol(caar(p)); + for (s7_pointer slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) + if (is_matched_symbol(slot_symbol(slot))) + { + outer_shadowed = true; + break; + } + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + clear_match_symbol(caar(p)); + + /* end and steps look ok! */ + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const 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))) + { + const 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 + { + const s7_pointer endp = car(end); + const 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)))) + { + const 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 */ + { + s7_pointer slot = let_slots(sc->curlet); + var1 = slot_symbol(slot); + slot = next_slot(slot); + if (tis_slot(slot)) + { + var2 = slot_symbol(slot); + slot = next_slot(slot); + if (tis_slot(slot)) + { + var3 = slot_symbol(slot); + more_vars = tis_slot(next_slot(slot)); + }}} + for (s7_pointer p = vars; is_pair(p); p = cdr(p)) + { + const 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)))) + { + s7_pointer e; + begin_temp(sc->y, sc->nil); + for (s7_pointer e1 = vars; is_pair(e1); e1 = cdr(e1)) sc->y = cons(sc, caar(e1), sc->y); + e = sc->y; + end_temp(sc->y); + fx_annotate_arg(sc, body, e); + 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)) + { + const s7_pointer val = slot_value(slot); + if (slot_has_expression(slot)) + { + const 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_real(sc, real(val))); /* 2-Mar-25 was mutable? this is not a stepper, just a do local with no step expr */ + else + if (is_t_integer(val)) + slot_set_value(slot, make_integer(sc, integer(val))); /* same as above */ + 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_t_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; + const s7_pointer code = cdr(sc->code); + const 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)))) + { + const s7_pointer num = make_mutable_integer(sc, integer(slot_value(stepper))); + slot_set_value(stepper, num); + 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(num)++;} while (!fb(o)); /* do {integer(num)++;} while ((sc->value = optf(sc, endp)) == sc->F); */ + clear_mutable_integer(num); + sc->value = sc->T; + sc->code = cdr(end); + return(goto_do_end_clauses); + } + set_no_bool_opt(end); + } + do {integer(num)++;} while ((sc->value = endf(sc, endp)) == sc->F); + clear_mutable_integer(num); + } + 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; + const s7_pointer expr1 = slot_expression(step1); + const s7_pointer step2 = next_slot(step1); + const 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 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)); + } 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 + */ + s7_int id; + int32_t steppers = 0; + s7_pointer code, end, endp, stepper = NULL, slots; + const s7_pointer form = sc->code; + s7_function endf; +#if WITH_GMP + bool got_bignum = false; +#endif + const 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)) + { + const s7_pointer expr = cdar(vars); + s7_pointer slot; + const s7_pointer val = fx_call(sc, expr); + const 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)))) + { + const 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)))) + { + const s7_pointer body = car(code); + s7_pfunc bodyf = NULL; + + sc->do_body_p = body; + 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)))) + { + if ((S7_DEBUGGING) && (lookup(sc, c_function_symbol(car(body))) != car(body))) + fprintf(stderr, "%s[%d]: replacing %s with %s -> %s in %s\n", __func__, __LINE__, + display(car(body)), + display(c_function_symbol(car(body))), + display(lookup(sc, c_function_symbol(car(body)))), + display(body)); + bodyf = s7_optimize_nv(sc, set_dlist_1(sc, set_ulist_1(sc, c_function_symbol(car(body)), cdr(body)))); /* trouble! #_xyzzy need not match xyzzy */ + } + if (bodyf) + { + if (steppers == 1) /* one expr body, 1 stepper */ + { + const s7_pointer stepa = car(slot_expression(stepper)); + const 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); + sc->do_body_p = NULL; + 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); + sc->do_body_p = NULL; + return(goto_do_end_clauses); + } + + if ((steppers == 2) && + (!tis_slot(next_slot(next_slot(slots))))) + { + const s7_pointer s1 = slots, s2 = next_slot(slots); + const s7_function f1 = fx_proc(slot_expression(s1)); + const s7_function f2 = fx_proc(slot_expression(s2)); + const s7_pointer p1 = car(slot_expression(s1)); + const 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); + sc->do_body_p = NULL; + 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); + sc->do_body_p = NULL; + return(goto_do_end_clauses); + } /* if (bodyf) ... */ + + 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; + const 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 (s7_pointer p1 = code; is_pair(p1); p1 = cdr(p1)) + fx_call(sc, p1); + + 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)) + { + const s7_int incr = integer(opt2_con(sc->code)); + const 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 + { + const s7_function stepf = fx_proc(cddr(var)); + const 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; + const 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 slot = slots; + do { + if (slot_has_expression(slot)) + slot_simply_set_pending_value(slot, fx_call(sc, slot_expression(slot))); + slot = next_slot(slot); + } while (tis_slot(slot)); + slot = slots; + do { + if (slot_has_expression(slot)) + slot_set_value(slot, slot_pending_value(slot)); + slot = next_slot(slot); + } while (tis_slot(slot)); + } + sc->code = cdr(test); + let_clear_has_pending_value(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 bool op_do_no_vars(s7_scheme *sc) +{ + s7_pointer p; + const s7_pointer 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)) + { + const 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)); + return(op_do_no_vars_no_opt_1(sc)); +} + +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 void op_do_no_body_na_vars(s7_scheme *sc) /* vars fxable, end-test not */ +{ + s7_pointer stepper = NULL; + s7_int steppers = 0; + const 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 slots = sc->code; is_pair(slots); slots = cdr(slots)) /* sc->code here is the original sc->args list */ + { + const s7_pointer slot = car(slots); + 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; + const s7_pointer dest = slot_value(o->v[1].p); + const 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); + sc->do_body_p = caddr(code); + 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)))) + { + const s7_int start = integer(slot_value(ctr_slot)), 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int i = start; i < stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc); + }} + sc->value = sc->T; + sc->code = cdadr(code); + sc->do_body_p = NULL; + 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)))) + { + const s7_int 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 (s7_int 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 (s7_int i = start; i >= stop; i--) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + func(sc); + } + sc->value = sc->T; + sc->code = cdadr(code); + sc->do_body_p = NULL; + return(true); + } + if ((stepf == g_add_2) && /* this was g_add_2_xi, 27-Sep-24 */ + (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)))) + { + const s7_int 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 (s7_int i = start; i < stop; i += incr) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fp(o); + }} + else + for (s7_int 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); + sc->do_body_p = NULL; + 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)))) + { + const s7_int start = integer(slot_value(ctr_slot)), 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); + sc->do_body_p = NULL; + 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 */ + const s7_pointer code = cdr(sc->code); + const s7_pointer end = opt1_any(code); /* caddr(caadr(code)) */ + const 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_t_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) +{ + const s7_pointer ctr = let_dox_slot1(sc->curlet); + s7_pointer end = let_dox_slot2(sc->curlet); + const s7_pointer code = sc->code; + const 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) +{ + const s7_int end = integer(let_dox2_value(sc->curlet)); + const s7_pointer slot = let_dox_slot1(sc->curlet); + const 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) +{ + const 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) +{ + const 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); /* goto DO_END_CLAUSES */ + } + push_stack_direct(sc, OP_SAFE_DOTIMES_STEP_O); + sc->code = opt2_pair(sc->code); + return(false); /* goto EVAL */ +} + +static /* inline */ bool op_dotimes_step_o(s7_scheme *sc) /* called once in eval, mat(10+6), num(7+1) */ +{ + const s7_pointer ctr = let_dox_slot1(sc->curlet); + s7_pointer end = let_dox2_value(sc->curlet); + s7_pointer now = slot_value(ctr); + const s7_pointer code = sc->code; + const 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) +{ + 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(sc, code); + sc->do_body_p = car(code); + func = s7_optimize_nv(sc, code); + if (!func) + { + set_no_cell_opt(code); + return_false(sc, code); + } + if (loop_end_ok) + { + const s7_int end = loop_end(sc->args); + const 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 + { + const s7_pointer step_slot = let_dox_slot1(sc->curlet); + const s7_pointer end_slot = let_dox_slot2(sc->curlet); + s7_int step = integer(slot_value(step_slot)); + const s7_int stop = integer(slot_value(end_slot)); + const s7_pointer 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); + sc->do_body_p = NULL; + return_true(sc, code); + } + + { /* not is_null(cdr(code)) i.e. there's more than one thing to do in the body */ + const s7_int body_len = s7_list_length(sc, code); + opt_info *body[32]; + sc->pc = 0; + if (body_len >= 32) return_false(sc, code); + + if (!no_float_opt(code)) + { + s7_pointer p = code; + for (int32_t k = 0; 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*)))) */ + const 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)) */ + const s7_pointer step_slot = let_dox_slot1(sc->curlet); + const s7_pointer end_slot = let_dox_slot2(sc->curlet); + const s7_int stop = integer(slot_value(end_slot)); + s7_pointer 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(sc, code); + }} + { + /* not float opt */ + s7_pointer p = code; + sc->pc = 0; + for (int32_t k = 0; 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))) */ + const 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); + const s7_pointer end_slot = let_dox_slot2(sc->curlet); + const 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(sc, code); + }}} + return_false(sc, code); +} + +static bool do_let(s7_scheme *sc, s7_pointer step_slot, s7_pointer scc) +{ + const s7_pointer let_code = caddr(scc); + s7_pointer let_body, let_vars, ip; + bool let_star; + s7_pointer old_e, stepper; + s7_int body_len, var_len, 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; + var_len = 0; + for (s7_pointer 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 (s7_pointer p = let_vars; is_pair(p); p = cdr(p)) + add_slot_checked(sc, sc->curlet, caar(p), make_mutable_real(sc, 1.5)); + + { + s7_pointer p = let_body; + for (int32_t k = 0; 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int k = numerator(stepper); k < end; k++) + { + s7_pointer slot = let_slots(sc->curlet); + set_integer(ip, k); + for (int32_t n = 0; tis_slot(slot); n++, slot = next_slot(slot)) + set_real(slot_value(slot), 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 (s7_int 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 (s7_int k = numerator(stepper); k < end; k++) + { + int32_t i = 0; + set_integer(ip, k); + for (s7_pointer slot = let_slots(sc->curlet); tis_slot(slot); i++, slot = next_slot(slot)) + set_real(slot_value(slot), vars[i]->v[0].fd(vars[i])); + for (int32_t i1 = 0; i1 < body_len; i1++) body[i1]->v[0].fd(body[i1]); + } + 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) +{ + const 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) +{ + const s7_pointer form = sc->code; + s7_pointer init_val; + + sc->code = cdr(sc->code); + init_val = fx_call(sc, cdaar(sc->code)); + if (s7_is_integer(init_val)) + { + const s7_pointer end_expr = caadr(sc->code); + const 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, goto 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 */ + { + const s7_int end = s7_integer_clamped_if_gmp(sc, end_val); + const s7_pointer body = cddr(code); + s7_pointer 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. + */ + const s7_pointer form = sc->code; + s7_pointer end, init_val, end_val, 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_t_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 */ + { + const 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)) + { + sc->temp7 = sc->unused; + 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))) */ + { + const 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...)) */ + { + const s7_pointer step_slot = let_dox_slot1(sc->curlet); + if (slot_symbol(step_slot) != cadr(body)) /* we're not setting the stepper */ + { + const s7_int endi = integer(let_dox2_value(sc->curlet)); + const s7_pointer fx_p = cddr(body); + s7_pointer val_slot = s7_t_slot(sc, cadr(body)); + s7_int step = integer(slot_value(step_slot)); + s7_pointer step_val = slot_value(step_slot); + + clear_mutable_integer(step_val); + do { + slot_set_value(val_slot, fx_call(sc, fx_p)); + slot_set_value(step_slot, make_integer(sc, step = integer(slot_value(step_slot)) + 1)); + } while (step != endi); /* geq not needed here -- we're leq endi and stepping by +1 all ints */ + + sc->value = sc->T; + sc->code = cdadr(code); + return(goto_safe_do_end_clauses); + }}} + clear_mutable_number(slot_value(let_dox_slot1(sc->curlet))); + 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) +{ + const s7_pointer code = cdr(sc->code); + s7_pointer end_val, slot, old_e; + const s7_pointer end = opt1_any(code); /* caddr(opt2_pair(code)) */ + /* (do ... (set! args ...)) -- one line, syntactic */ + const 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_t_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)) + { + const s7_pointer old_args = sc->args; + const 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); + 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) +{ + /* initially from do_unchecked, sc->args=(), sc->value=sc->code, sc->code=vars */ + 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) */ + 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 */ + sc->args = cdr(sc->args); /* init values */ + set_curlet(sc, make_let(sc, T_Let(sc->curlet))); + + /* run through sc->code and sc->args adding '( caar(car(code)) . car(args) ) to sc->curlet */ + sc->value = sc->nil; + for (s7_pointer vars = car(sc->code), inits = sc->args; is_not_null(inits); vars = cdr(vars), inits = cdr(inits)) + { + s7_pointer slot = add_slot_unchecked_with_id(sc, sc->curlet, caar(vars), unchecked_car(inits)); + if (is_pair(cddar(vars))) /* else no incr expr, so ignore it henceforth */ + { + slot_set_expression(slot, cddar(vars)); + sc->value = cons_unchecked(sc, slot, sc->value); + }} + 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) /* looping through inits via eval */ +{ + 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) +{ + 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) */ + 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 -------- */ +{ + const 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 */ +{ + const 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 -------- */ +{ + check_c_macro_args(sc, 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) + 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))) */ + { + if (vector_length(sc->code) == 0) /* (#()) */ + error_nr(sc, make_symbol(sc, "inapplicable-vector", 19), + set_elist_2(sc, wrap_string(sc, "(~S) can't be treated as an implicit vector application", 55), sc->code)); + wrong_number_of_arguments_error_nr(sc, "implicit vector-ref needs 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)) + { + if (string_length(sc->code) == 0) /* ("") */ + error_nr(sc, make_symbol(sc, "inapplicable-string", 19), + set_elist_2(sc, wrap_string(sc, "(~S) can't be treated as an implicit string application", 55), sc->code)); + error_nr(sc, sc->wrong_number_of_args_symbol, /* (a string") */ + 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 pars, args, last_slot = slot_end; + const s7_pointer e = sc->curlet; + const s7_uint id = let_id(sc->curlet); + + for (pars = closure_pars(sc->code), args = T_Lst(sc->args); is_pair(pars); pars = cdr(pars), args = cdr(args)) /* closure_pars can be a symbol, for example */ + { + const s7_pointer sym = car(pars); + s7_pointer slot; + if (is_null(args)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_5(sc, wrap_string(sc, "~S: not enough arguments: ((~S ~S ...)~{~^ ~S~})", 48), + closure_name(sc, sc->code), + (is_closure(sc->code)) ? sc->lambda_symbol : ((is_bacro(sc->code)) ? sc->bacro_symbol : sc->macro_symbol), + closure_pars(sc->code), sc->args)); + slot = make_slot(sc, sym, T_Ext(unchecked_car(args))); + 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(pars)) + { + if (is_not_null(args)) + error_nr(sc, sc->wrong_number_of_args_symbol, + set_elist_5(sc, wrap_string(sc, "~S: too many arguments: ((~S ~S ...)~{~^ ~S~})", 46), + closure_name(sc, sc->code), + (is_closure(sc->code)) ? sc->lambda_symbol : ((is_bacro(sc->code)) ? sc->bacro_symbol : sc->macro_symbol), + closure_pars(sc->code), sc->args)); + } + else + { + s7_pointer slot = make_slot(sc, T_Sym(pars), args); + symbol_set_local_slot(pars, 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)), gc_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); + const 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))); + + last_slot = add_slot_unchecked_no_local_slot(sc, e, car(pars), sc->undefined); + 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 slot = gc_protected1(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))); + + { + const s7_pointer arg = gc_protected2(sc); + 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_gc_protected1(sc, (is_rest_slot(slot)) ? slot : next_slot(slot)); + set_gc_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); + } + { + s7_pointer 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 slot1 = let_slots(sc->curlet) /* presumably the arglist */; tis_slot(slot1); slot1 = next_slot(slot1)) + if (slot_symbol(slot1) == sym) + return(star_set(sc, slot1, 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; + const s7_pointer code = sc->code, args = sc->args; + s7_pointer slot = let_slots(sc->curlet); + s7_pointer pars = closure_pars(code); + const 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 + { + const 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 + { + const 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_pars(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 slot = sc->args; tis_slot(slot); slot = next_slot(slot)) + { + if ((slot_value(slot) == sc->undefined) && /* trouble: (lambda* ((e #))...) */ + (slot_has_expression(slot)) && /* if default val is not a pair or a symbol, this is false */ + (!is_checked_slot(slot))) + { + const s7_pointer val = slot_expression(slot); + if (is_symbol(val)) + { + slot_set_value(slot, lookup_checked(sc, val)); + if (slot_value(slot) == sc->undefined) + { + /* the current environment here contains the function parameters which defaulted to # + * (or maybe #?) 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(slot, s7_symbol_local_value(sc, val, let_outlet(sc->curlet))); + if (slot_value(slot) == sc->undefined) + syntax_error_nr(sc, "lambda* defaults: ~A is unbound", 31, slot_symbol(slot)); + }} + else + if (!is_pair(val)) + slot_set_value(slot, 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(slot, cadr(val)); + } + else + { + push_stack(sc, OP_LAMBDA_STAR_DEFAULT, slot, 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 slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) + { + clear_checked_slot(slot); + slot_set_value(slot, 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 slot = let_slots(sc->curlet); tis_slot(slot); slot = next_slot(slot)) + { + clear_checked_slot(slot); + slot_set_value(slot, (slot_defaults(slot)) ? sc->undefined : slot_expression(slot)); + } + return(set_star_args(sc, slot_pending_value(let_slots(sc->curlet)))); +} + +static bool apply_unsafe_closure_star_1(s7_scheme *sc) +{ + s7_pointer pars, top = sc->nil; + for (pars = closure_pars(sc->code); is_pair(pars); pars = cdr(pars)) + { + const s7_pointer par = car(pars); + if (is_pair(par)) /* parameter has a default value */ + { + s7_pointer slot; + const s7_pointer val = cadr(par); + if ((!is_pair(val)) && + (!is_symbol(val))) + slot = add_slot_checked(sc, sc->curlet, car(par), val); + else + { + add_slot(sc, sc->curlet, car(par), sc->undefined); + slot = let_slots(sc->curlet); + slot_set_expression(slot, val); + } + if (is_null(top)) + top = slot; + } + else + if (!is_keyword(par)) + add_slot_checked(sc, sc->curlet, par, sc->F); /* checked tlimit */ + else + if (par == sc->rest_keyword) /* else it's :allow-other-keys? */ + { + set_is_rest_slot(add_slot_checked(sc, sc->curlet, cadr(pars), sc->nil)); + pars = cdr(pars); + }} + if (is_symbol(pars)) + set_is_rest_slot(add_slot_checked(sc, sc->curlet, pars, 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 pars; + for (pars = closure_pars(sc->code); is_pair(pars); pars = cdr(pars)) + { + const s7_pointer par = car(pars); + 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(pars), sc->nil)); + pars = cdr(pars); + }} + if (is_symbol(pars)) + set_is_rest_slot(add_slot_checked(sc, sc->curlet, pars, 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 */ +{ + const s7_pointer func = opt1_lambda(code); + const 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) +{ + const s7_pointer func = op_safe_closure_star_a1(sc, code); + s7_pointer p = cdr(closure_pars(func)); + if (is_pair(p)) + for (s7_pointer slot = next_slot(let_slots(closure_let(func))); is_pair(p); p = cdr(p), slot = next_slot(slot)) + { + if (is_pair(car(p))) + { + s7_pointer defval = cadar(p); + slot_set_value(slot, (is_pair(defval)) ? cadr(defval) : defval); + } + else slot_set_value(slot, sc->F); + symbol_set_local_slot(slot_symbol(slot), let_id(sc->curlet), slot); + } +} + +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 */ +{ + const 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) */ + const s7_pointer func = opt1_lambda(code); + s7_pointer arg2, 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_pars(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_pars(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_safe_list_in_use(arglist); + return(target); +} + +static bool op_safe_closure_star_3a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code), arg1 = fx_call(sc, cdr(code)); + s7_pointer arg2, arg3; + gc_protect_via_stack(sc, arg1); + arg2 = fx_call(sc, cddr(code)); + set_gc_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 safe_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 safe_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 safe_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 safe_list_in_use */ +} + +static void op_closure_star_ka(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + const s7_pointer par = car(closure_pars(func)); + sc->value = fx_call(sc, cddr(code)); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), (is_pair(par)) ? car(par) : par, sc->value)); + sc->code = T_Pair(closure_body(func)); +} + +static void op_closure_star_a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer p; + const s7_pointer 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_pars(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); + const s7_int id = let_id(sc->curlet); + for (s7_pointer p1 = cdr(closure_pars(func)); is_pair(p1); p1 = cdr(p1)) + { + s7_pointer par = car(p1); + if (is_pair(par)) + last_slot = add_slot_checked_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_checked_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 slot; + 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) */ + { + slot = (is_slot(global_slot(sc->code))) ? global_slot(sc->code) : s7_t_slot(sc, sc->code); + /* local_slot can be free even if sc->code is immutable (local constant now defunct) */ + + if (!((is_slot(slot)) && + (type(sc->value) == unchecked_type(slot_value(slot))) && + (s7_is_equivalent(sc, sc->value, slot_value(slot))))) /* 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 slot = s7_slot(sc, sc->code); + if ((is_slot(slot)) && (slot_has_setter(slot))) + { + 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) + { + const s7_pointer body = closure_body(new_func); + const s7_pointer pars = closure_pars(new_func); + if ((is_pair(closure_pars(new_func))) && + (has_location(pars))) + { + let_set_file(new_let, pair_file_number(pars)); + let_set_line(new_let, pair_line_number(pars)); + } + else + if (has_location(body)) + { + let_set_file(new_let, pair_file_number(body)); + let_set_line(new_let, pair_line_number(body)); + } + else + { + s7_pointer p; + for (p = cdr(body); 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) +{ + const 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 */ + { + const s7_pointer new_func = sc->value; + s7_pointer 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 + { + const s7_pointer slot = symbol_to_local_slot(sc, code, sc->curlet); + if (is_slot(slot)) + { + if (is_immutable_slot(slot)) + { + s7_pointer 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, code); + } + 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) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, inline_make_let(sc, closure_let(func))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static void op_thunk_o(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, inline_make_let(sc, closure_let(func))); + sc->code = car(closure_body(func)); +} + +static void op_safe_thunk(s7_scheme *sc) /* no let needed */ +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, closure_let(func)); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} + +static s7_pointer op_safe_thunk_a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer func = opt1_lambda(code); + set_curlet(sc, closure_let(func)); + return(fx_call(sc, closure_body(func))); +} + +static void op_thunk_any(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, make_let_with_slot(sc, closure_let(func), closure_pars(func), sc->nil)); + sc->code = closure_body(func); +} + +static void op_safe_thunk_any(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, closure_let(func)); + slot_set_value(let_slots(sc->curlet), sc->nil); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} + +static void op_closure_s(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + check_stack_size(sc); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), car(closure_pars(func)), lookup(sc, opt2_sym(sc->code)))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} + +static inline void op_closure_s_o(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), car(closure_pars(func)), lookup(sc, opt2_sym(sc->code)))); + sc->code = car(closure_body(func)); +} + +static void op_safe_closure_s(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), lookup(sc, opt2_sym(sc->code)))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} + +static void op_safe_closure_s_o(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), lookup(sc, opt2_sym(sc->code)))); + sc->code = car(closure_body(func)); +} + +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) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), sc->value)); + sc->value = fx_call(sc, closure_body(func)); +} + +static Inline void inline_op_closure_a(s7_scheme *sc) /* called twice in eval */ +{ + const s7_pointer func = opt1_lambda(sc->code); + sc->value = fx_call(sc, cdr(sc->code)); + set_curlet(sc, inline_make_let_with_slot(sc, closure_let(func), car(closure_pars(func)), sc->value)); + sc->code = T_Pair(closure_body(func)); +} + +static void op_safe_closure_3s(s7_scheme *sc) +{ + const s7_pointer args = cddr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), lookup(sc, cadr(sc->code)), lookup(sc, car(args)), lookup(sc, cadr(args)))); + sc->code = T_Pair(closure_body(func)); + 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 */ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), lookup(sc, car(args)), lookup(sc, cadr(args)), fx_call(sc, cddr(args)))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} + +static void op_safe_closure_saa(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + const s7_pointer args = cddr(sc->code); + const 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(func), arg2, sc->code, fx_call(sc, cdr(args)))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin_unchecked(sc); +} + +static void op_safe_closure_agg(s7_scheme *sc) /* possibly inline tleft */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), fx_call(sc, args), fx_call(sc, cdr(args)), fx_call(sc, cddr(args)))); + sc->code = T_Pair(closure_body(func)); + 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_pars(sc->code)), sc->value)); + sc->code = T_Pair(closure_body(sc->code)); +} + +static void op_safe_closure_a(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cdr(sc->code)))); + sc->code = T_Pair(closure_body(func)); + 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) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_slot(sc, closure_let(func), fx_call(sc, cdr(sc->code)))); + sc->code = car(closure_body(func)); +} + +static void op_closure_ap(s7_scheme *sc) +{ + const s7_pointer code = sc->code; + sc->args = fx_call(sc, cdr(code)); + /* (hook-push (undo-hook ind 0) (lambda (hook) (set! u0 #t))) -> # + * 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_pars(sc->args)), sc->code, cadr(closure_pars(sc->args)), sc->value)); + sc->code = T_Pair(closure_body(sc->args)); +} + +static void op_closure_pa(s7_scheme *sc) +{ + const 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_pars(sc->code)), sc->value, cadr(closure_pars(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(sc, fx_call(sc, p), OP_ANY_CLOSURE_3P_3); /* set stack_let */ + /* (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)) + { + const s7_pointer func = opt1_lambda(sc->code); + gc_protect_2_via_stack(sc, sc->args, sc->value); /* sc->args == arg1, sc->value == arg2 */ + set_gc_protected3(sc, fx_call(sc, p)); + if (is_safe_closure(func)) + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), gc_protected1(sc), gc_protected2(sc), gc_protected3(sc))); + else make_let_with_three_slots(sc, func, gc_protected1(sc), gc_protected2(sc), gc_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(sc, sc->value, OP_ANY_CLOSURE_3P_3); /* set stack_let, arg2 == curlet stack loc */ + sc->code = car(p); + return(false); +} + +static bool op_any_closure_3p_1(s7_scheme *sc) +{ + const 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 */ + const 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_gc_protected2(sc, fx_call(sc, p)); + p = cdr(p); + if (has_fx(p)) + { + set_gc_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)) + { + const 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), gc_protected1(sc), gc_protected2(sc), gc_protected3(sc), sc->args)); + else make_let_with_four_slots(sc, func, gc_protected1(sc), gc_protected2(sc), gc_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_gc_protected2(sc, fx_call(sc, p)); + p = cdr(p); + if (has_fx(p)) + { + set_gc_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) +{ + const s7_pointer p = cdddr(sc->code); + set_gc_protected2(sc, sc->value); + if (has_fx(p)) + { + set_gc_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_gc_protected3(sc, sc->value); + return(closure_4p_end(sc, cddddr(sc->code))); +} + +static inline void op_any_closure_4p_4(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + if (is_safe_closure(func)) + set_curlet(sc, update_let_with_four_slots(sc, closure_let(func), gc_protected1(sc), gc_protected2(sc), gc_protected3(sc), sc->value)); + else make_let_with_four_slots(sc, func, gc_protected1(sc), gc_protected2(sc), gc_protected3(sc), sc->value); + sc->code = T_Pair(closure_body(func)); + unstack_gc_protect(sc); +} + +static void op_safe_closure_ss(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), lookup(sc, cadr(sc->code)), lookup(sc, opt2_sym(sc->code)))); + sc->code = T_Pair(closure_body(func)); + 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) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), lookup(sc, cadr(sc->code)), lookup(sc, opt2_sym(sc->code)))); + sc->code = car(closure_body(func)); +} + +static inline void op_closure_ss(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + check_stack_size(sc); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), + car(closure_pars(func)), lookup(sc, cadr(sc->code)), + cadr(closure_pars(func)), lookup(sc, opt2_sym(sc->code)))); + sc->code = T_Pair(closure_body(func)); + 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) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), + car(closure_pars(func)), lookup(sc, cadr(sc->code)), + cadr(closure_pars(func)), lookup(sc, opt2_sym(sc->code)))); + sc->code = car(closure_body(func)); +} + +static void op_safe_closure_sc(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), lookup(sc, cadr(sc->code)), opt2_con(sc->code))); + sc->code = T_Pair(closure_body(func)); + 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) +{ + const s7_pointer func = opt1_lambda(sc->code); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), lookup(sc, cadr(sc->code)), opt2_con(sc->code))); + sc->code = car(closure_body(func)); +} + +static void op_closure_sc(s7_scheme *sc) +{ + const s7_pointer func = opt1_lambda(sc->code); + check_stack_size(sc); + set_curlet(sc, make_let_with_two_slots(sc, closure_let(func), car(closure_pars(func)), lookup(sc, cadr(sc->code)), cadr(closure_pars(func)), opt2_con(sc->code))); + sc->code = T_Pair(closure_body(func)); + 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) +{ + const s7_pointer func = opt1_lambda(sc->code); + check_stack_size(sc); + set_curlet(sc, inline_make_let_with_two_slots(sc, closure_let(func), car(closure_pars(func)), lookup(sc, cadr(sc->code)), cadr(closure_pars(func)), opt2_con(sc->code))); + sc->code = car(closure_body(func)); +} + +static void op_closure_3s(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + const s7_pointer v1 = lookup(sc, car(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cdr(args); + make_let_with_three_slots(sc, func, v1, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static inline void op_closure_3s_o(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + const s7_pointer v1 = lookup(sc, car(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cdr(args); + make_let_with_three_slots(sc, func, v1, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ + sc->code = car(closure_body(func)); +} + +static void op_closure_4s(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + const s7_pointer v1 = lookup(sc, car(args)), v2 = lookup(sc, cadr(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cddr(args); + make_let_with_four_slots(sc, func, v1, v2, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static inline void op_closure_4s_o(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + const s7_pointer v1 = lookup(sc, car(args)), v2 = lookup(sc, cadr(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cddr(args); + make_let_with_four_slots(sc, func, v1, v2, lookup(sc, car(args)), lookup(sc, cadr(args))); /* sets sc->curlet */ + sc->code = car(closure_body(func)); +} + +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); + const s7_pointer v1 = lookup(sc, car(args)), v2 = lookup(sc, cadr(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cddr(args); + make_let_with_five_slots(sc, func, v1, v2, lookup(sc, car(args)), lookup(sc, cadr(args)), lookup(sc, caddr(args))); /* sets sc->curlet */ + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static void op_safe_closure_aa(s7_scheme *sc) +{ + s7_pointer p = cdr(sc->code); + const s7_pointer func = 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(func), fx_call(sc, p), sc->code)); + p = T_Pair(closure_body(func)); + /* 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) +{ + const s7_pointer p = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(p)); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), fx_call(sc, p), sc->code)); + sc->code = car(closure_body(func)); + /* (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); + const s7_pointer func = 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(func), car(closure_pars(func)), sc->value, cadr(closure_pars(func)), sc->code)); + p = T_Pair(closure_body(func)); + 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 */ +{ + const s7_pointer p = cdr(sc->code); + const s7_pointer func = 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(func), car(closure_pars(func)), sc->value, cadr(closure_pars(func)), sc->code)); + sc->code = car(closure_body(func)); +} + +static /* inline */ void op_closure_fa(s7_scheme *sc) /* "inline" matters perhaps in texit.scm */ +{ + s7_pointer new_clo; + const s7_pointer code = sc->code; + const s7_pointer farg = opt2_pair(code); /* cdadr(code), '((a . b) (cons a b)) for (lambda (a . b) (cons a b)) */ + const s7_pointer aarg = fx_call(sc, cddr(code)); + const s7_pointer func = opt1_lambda(code); /* outer func */ + const s7_pointer func_pars = closure_pars(func); /* outer func pars (not the arglist of the applied func) */ + sc->value = inline_make_let_with_two_slots(sc, closure_let(func), car(func_pars), sc->F, cadr(func_pars), 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); + const s7_pointer func = opt1_lambda(sc->code); + const s7_pointer let = closure_let(func); + const s7_int id = ++sc->let_number; + let_set_id(let, id); + for (s7_pointer slot = let_slots(let); tis_slot(slot); slot = next_slot(slot), args = cdr(args)) + { + slot_set_value(slot, lookup(sc, car(args))); + symbol_set_local_slot(slot_symbol(slot), id, slot); + } + set_curlet(sc, let); + sc->code = closure_body(func); + if_pair_set_up_begin_unchecked(sc); +} + +static inline void op_safe_closure_3a(s7_scheme *sc) +{ + const s7_pointer p = cdr(sc->code); + const s7_pointer func = 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(func), fx_call(sc, p), sc->code, sc->args)); + sc->code = closure_body(func); + if_pair_set_up_begin_unchecked(sc); +} + +static void op_safe_closure_na(s7_scheme *sc) +{ + s7_pointer let; + s7_int 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 slot = let_slots(let), vals = sc->args; tis_slot(slot); slot = next_slot(slot), vals = cdr(vals)) + { + slot_set_value(slot, car(vals)); + symbol_set_local_slot(slot_symbol(slot), id, slot); + } + if (!in_heap(sc->args)) clear_safe_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; + const s7_pointer func = opt1_lambda(sc->code); + const s7_pointer pars = closure_pars(func); + const s7_pointer e = inline_make_let(sc, closure_let(func)); + const s7_int id = let_id(e); + begin_temp(sc->y, e); + add_slot_unchecked(sc, e, car(pars), lookup(sc, car(args)), id); + last_slot = let_slots(e); + args = cdr(args); + for (s7_pointer p1 = cdr(pars); is_pair(p1); p1 = cdr(p1), args = cdr(args)) + last_slot = add_slot_at_end(sc, id, last_slot, car(p1), 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); + end_temp(sc->y); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static void op_closure_ass(s7_scheme *sc) /* possibly inline b */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + make_let_with_three_slots(sc, func, fx_call(sc, args), lookup(sc, cadr(args)), lookup(sc, caddr(args))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static void op_closure_aas(s7_scheme *sc) /* possibly inline b */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->z = fx_call(sc, args); + make_let_with_three_slots(sc, func, sc->z, fx_call(sc, cdr(args)), lookup(sc, caddr(args))); + sc->z = sc->unused; + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static void op_closure_saa(s7_scheme *sc) +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->z = fx_call(sc, cdr(args)); + make_let_with_three_slots(sc, func, lookup(sc, car(args)), sc->z, fx_call(sc, cddr(args))); + sc->z = sc->unused; + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static void op_closure_asa(s7_scheme *sc) +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->z = fx_call(sc, args); + make_let_with_three_slots(sc, func, sc->z, lookup(sc, cadr(args)), fx_call(sc, cddr(args))); + sc->z = sc->unused; + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static void op_closure_sas(s7_scheme *sc) +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + make_let_with_three_slots(sc, func, lookup(sc, car(args)), fx_call(sc, cdr(args)), lookup(sc, caddr(args))); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static inline void op_closure_3a(s7_scheme *sc) /* if inlined, tlist -60 */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = 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, func, gc_protected1(sc), gc_protected2(sc), fx_call(sc, cddr(args))); + unstack_gc_protect(sc); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static void op_closure_4a(s7_scheme *sc) /* sass */ +{ + s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + gc_protect_2_via_stack(sc, fx_call(sc, args), fx_call(sc, cddr(args))); + args = cdr(args); + set_gc_protected3(sc, fx_call(sc, args)); + make_let_with_four_slots(sc, func, gc_protected1(sc), gc_protected3(sc), gc_protected2(sc), fx_call(sc, cddr(args))); + unstack_gc_protect(sc); + sc->code = T_Pair(closure_body(func)); + if_pair_set_up_begin(sc); +} + +static void op_closure_na(s7_scheme *sc) +{ + const s7_pointer exprs = cdr(sc->code); /* "n" = opt3_arglen(exprs), mostly 5 in lt, 6 in tlet */ + const s7_pointer func = opt1_lambda(sc->code); + const s7_pointer pars = closure_pars(func); + const s7_pointer e = inline_make_let(sc, closure_let(func)); + s7_pointer slot, last_slot; + 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 (s7_pointer par = cdr(pars), expr = cdr(exprs); is_pair(par); par = cdr(par), expr = cdr(expr)) + { + sc->value = fx_call(sc, expr); /* 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(par), 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 (s7_pointer slot1 = let_slots(e); tis_slot(slot1); slot1 = next_slot(slot1)) + { + symbol_set_local_slot(slot_symbol(slot1), let_id(e), slot1); + set_local(slot_symbol(slot1)); + } + 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))) + { + const s7_pointer func = lookup_unexamined(sc, car(sc->code)); + if ((func != opt1_lambda_unchecked(sc->code)) && + ((!func) || + ((low_type_bits(func) & (TYPE_MASK | T_SAFE_CLOSURE)) != T_CLOSURE) || + (((args == 1) && (!is_symbol(closure_pars(func)))) || + ((args == 2) && ((!is_pair(closure_pars(func))) || (!is_symbol(cdr(closure_pars(func))))))))) + { + sc->last_function = func; + return(false); + } + set_opt1_lambda(sc->code, func); + } + return(true); +} + +static void op_any_closure_sym(s7_scheme *sc) /* for (lambda a ...) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + s7_pointer old_args = cdr(sc->code); /* args aren't evaluated yet */ + const 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_pars(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_pars(func), + ((is_safe_closure(func)) && (!sc->debug_or_profile)) ? + set_plist_2(sc, gc_protected1(sc), sc->args) : list_2(sc, gc_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_pars(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_pars(func), sc->args)); + } + sc->code = T_Pair(closure_body(func)); +} + +static void op_any_closure_a_sym(s7_scheme *sc) /* for (lambda (a . b) ...) */ +{ + const s7_pointer func = opt1_lambda(sc->code); + s7_pointer old_args = cdr(sc->code); + const s7_int num_args = opt3_arglen(old_args); + const s7_pointer func_pars = closure_pars(func); + + if (num_args == 1) + set_curlet(sc, make_let_with_two_slots(sc, closure_let(func), car(func_pars), sc->value = fx_call(sc, old_args), cdr(func_pars), 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_pars), gc_protected1(sc), cdr(func_pars), 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_pars), gc_protected1(sc), cdr(func_pars), sc->args)); + } + unstack_gc_protect(sc); + } + sc->code = T_Pair(closure_body(func)); +} + + +/* ---------------- tc/rec ---------------- */ + +#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 + +/* op_tc_case */ +static bool op_tc_case_la(s7_scheme *sc, s7_pointer code, int vars) +{ + /* opt1_any(clause) = key, has_tc(arg) = is tc call, opt2_any(clause) = result: has_tc(la arg) has_fx(val) or ((...)...) */ + #define case_clause_key(p) opt1_any(p) + #define case_clause_result(p) opt2_any(p) + const s7_pointer clauses = cddr(code), la_slot = let_slots(sc->curlet), selp = cdr(code); + s7_pointer endp; + const s7_pointer l2a_slot = (vars == 1) ? NULL : next_slot(la_slot); + const s7_pointer l3a_slot = (vars <= 2) ? NULL : next_slot(l2a_slot); + const s7_int len = opt3_arglen(cdr(code)); + tick_tc(sc, (vars == 1) ? OP_TC_CASE_LA : ((vars == 2) ? OP_TC_CASE_L2A : OP_TC_CASE_L3A)); + + if (len == 3) + { + while (true) + { + const s7_pointer selector = fx_call(sc, selp); + if (selector == case_clause_key(clauses)) + endp = case_clause_result(clauses); + else + { + s7_pointer p = cdr(clauses); + endp = (selector == case_clause_key(p)) ? case_clause_result(p) : case_clause_result(cdr(p)); /* there's always an else */ + } + if (has_tc(endp)) + { + slot_set_value(la_slot, fx_call(sc, cdr(endp))); + if (vars > 1) slot_set_value(l2a_slot, fx_call(sc, cddr(endp))); + if (vars > 2) slot_set_value(l3a_slot, fx_call(sc, cdddr(endp))); + } + else break; + }} + else + while (true) + { + const s7_pointer selector = fx_call(sc, selp); + s7_pointer p; + for (p = clauses; is_pair(cdr(p)); p = cdr(p)) + if (selector == case_clause_key(p)) {endp = case_clause_result(p); goto CASE_ALA_END;} + endp = case_clause_result(p); /* else clause */ + CASE_ALA_END: + if (has_tc(endp)) + { + slot_set_value(la_slot, fx_call(sc, cdr(endp))); + if (vars > 1) slot_set_value(l2a_slot, fx_call(sc, cddr(endp))); + if (vars > 2) slot_set_value(l3a_slot, fx_call(sc, cdddr(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) +{ + op_tc_case_la(sc, arg, 1); + return(sc->value); +} + +static s7_pointer fx_tc_case_l2a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_case_la(sc, arg, 2); + return(sc->value); +} + +static s7_pointer fx_tc_case_l3a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_case_la(sc, arg, 3); + return(sc->value); +} + + +/* op_tc_when_la|l2a|l3a */ +static s7_pointer op_tc_when_la(s7_scheme *sc, s7_pointer code) +{ + bool when_case = (!true_is_done(code)); + s7_pointer if_test = cadr(code), body = cddr(code), la_slot = let_slots(sc->curlet); + s7_function tf = fx_proc(cdr(code)); + s7_pointer la_call = opt3_pair(code); + s7_pointer la = cdar(la_call); + tick_tc(sc, OP_TC_WHEN_LA); + while ((tf(sc, if_test) != sc->F) == when_case) + { + for (s7_pointer p = body; p != la_call; p = cdr(p)) fx_call(sc, p); + slot_set_value(la_slot, fx_call(sc, la)); + } + return(sc->unspecified); +} + +static s7_pointer op_tc_when_l2a(s7_scheme *sc, s7_pointer code) +{ + bool when_case = (!true_is_done(code)); + s7_pointer if_test = cadr(code), body = cddr(code), la_slot = let_slots(sc->curlet); + s7_function tf = fx_proc(cdr(code)); + s7_pointer la_call = opt3_pair(code); + s7_pointer la = cdar(la_call); + s7_pointer l2a = cdr(la); + s7_pointer l2a_slot = next_slot(la_slot); + tick_tc(sc, OP_TC_WHEN_L2A); + while ((tf(sc, if_test) != sc->F) == when_case) + { + 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(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); + } + sc->rec_p1 = sc->unused; + return(sc->unspecified); +} + +static s7_pointer op_tc_when_l3a(s7_scheme *sc, s7_pointer code) +{ + bool when_case = (!true_is_done(code)); + s7_pointer if_test = cadr(code), body = cddr(code), la_slot = let_slots(sc->curlet); + s7_function tf = fx_proc(cdr(code)); + s7_pointer la_call = opt3_pair(code); + s7_pointer la = cdar(la_call); + s7_pointer l2a = cdr(la); + s7_pointer l3a = cdr(l2a); + s7_pointer l2a_slot = next_slot(la_slot); + s7_pointer l3a_slot = next_slot(l2a_slot); + tick_tc(sc, OP_TC_WHEN_L3A); + while ((tf(sc, if_test) != sc->F) == when_case) + { + 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, l2a); + slot_set_value(l3a_slot, fx_call(sc, l3a)); + slot_set_value(l2a_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } + sc->rec_p1 = sc->unused; + return(sc->unspecified); +} + + +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); +} + +/* tc_if_a_z_la|la2|la3 */ +static bool op_tc_if_a_z_la(s7_scheme *sc, s7_pointer code) +{ + bool true_quits = true_is_done(code); + s7_pointer la_slot = let_slots(sc->curlet); + s7_pointer if_test = rec_test_clause(code); + s7_pointer if_done = rec_done_clause(code); + s7_pointer la = rec_call_clause(code); + tick_tc(sc, OP_TC_IF_A_Z_LA); + 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) != true_quits) {set_integer(val, o1->v[0].fi(o1));} + return(op_tc_z(sc, if_done)); + }}} + if (fx_proc(la) == fx_cdr_t) + while ((fx_call(sc, if_test) != sc->F) != true_quits) + { + if (!is_pair(slot_value(la_slot))) + sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, slot_value(la_slot), sc->type_names[T_PAIR]); + slot_set_value(la_slot, cdr(slot_value(la_slot))); + } + else while ((fx_call(sc, if_test) != sc->F) != true_quits) {slot_set_value(la_slot, fx_call(sc, la));} + return(op_tc_z(sc, if_done)); +} + +static s7_pointer fx_tc_if_a_z_la(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_la(sc, arg); + return(sc->value); +} + +static bool op_tc_if_a_z_l2a(s7_scheme *sc, s7_pointer code) +{ + const bool true_quits = true_is_done(code); + const s7_pointer la_slot = let_slots(sc->curlet); + s7_function tf; + s7_pointer if_test = rec_test_clause(code); + const s7_pointer if_done = rec_done_clause(code); + const s7_pointer la = rec_call_clause(code); + const s7_pointer l2a = cdr(la); + const s7_pointer l2a_slot = next_slot(la_slot); + tick_tc(sc, OP_TC_IF_A_Z_L2A); +#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; + const int32_t start_pc = sc->pc; + if ((is_t_integer(slot_value(la_slot))) && + (is_t_integer(slot_value(l2a_slot)))) + { + if (int_optimize(sc, la)) + { + o2 = sc->opts[sc->pc]; + if (int_optimize(sc, l2a)) + { + 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; + const s7_pointer val1 = make_mutable_integer(sc, integer(slot_value(la_slot))); + s7_pointer val2; + slot_set_value(la_slot, val1); + slot_set_value(l2a_slot, val2 = make_mutable_integer(sc, integer(slot_value(l2a_slot)))); + if ((true_quits) && + ((fb == opt_b_ii_sc_lt) || (fb == opt_b_ii_sc_lt_0)) && + (fi1 == opt_i_ii_sc_sub)) + { /* trclo: (if (< i 0) sum (loop (- i 1) (+ i sum))) */ + 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 /* s7test: (let facter ((n n0) (result 1)) (if (= n 0) result (facter (- n 1) (* n result))) */ + while (fb(o) != true_quits) + { + s7_int i1 = fi1(o1); + set_integer(val2, fi2(o2)); + set_integer(val1, i1); + } + return(op_tc_z(sc, if_done)); + }}} + + if ((is_t_real(slot_value(la_slot))) && + (is_t_real(slot_value(l2a_slot)))) + { + sc->pc = start_pc; + if (float_optimize(sc, la)) + { + o2 = sc->opts[sc->pc]; + if (float_optimize(sc, l2a)) + { + 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; + const s7_pointer val1 = make_mutable_real(sc, real(slot_value(la_slot))); + const s7_pointer val2 = make_mutable_real(sc, real(slot_value(l2a_slot))); + slot_set_value(la_slot, val1); + slot_set_value(l2a_slot, val2); + if ((true_quits) && + (fb == opt_b_dd_sc_lt) && + (fd1 == opt_d_dd_sc_sub)) + { /* trclo: (if (< i 0.0) sum (loop (- i 1.0) (+ i sum))) */ + 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 /* trclo: (if (>= i 0.0) (loop (- i 1.0) (+ i sum)) sum) */ + while (fb(o) != true_quits) + { + s7_double x1 = fd1(o1); + set_real(val2, fd2(o2)); + set_real(val1, x1); + } + clear_mutable_number(val1); + clear_mutable_number(val2); + return(op_tc_z(sc, if_done)); + }}}} + set_no_bool_opt(code); + } +#endif + tf = fx_proc(if_test); + if_test = car(if_test); + if (true_quits) + { + if ((fx_proc(la) == fx_cdr_t) && (is_pair(slot_value(la_slot)))) + { + if ((fx_proc(l2a) == 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_t_integer(slot_value(l2a_slot)))) + { /* list-tail ferchrissake */ + const s7_int end = integer(caddr(if_test)); + s7_pointer lst = slot_value(la_slot); + for (s7_int start = integer(slot_value(l2a_slot)); start > end; start--) + lst = cdr(lst); + slot_set_value(la_slot, lst); + return(op_tc_z(sc, if_done)); + } + if (tf == fx_is_null_t) + { + do { + s7_pointer p; + if (is_pair(slot_value(la_slot))) /* needed if improper list passed here */ + p = cdr(slot_value(la_slot)); + else sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, slot_value(la_slot), sc->type_names[T_PAIR]); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, p); + } while (!is_null(slot_value(la_slot))); + return(op_tc_z(sc, if_done)); + }} + while (tf(sc, if_test) == sc->F) + { + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); + }} + else + { + if ((tf == fx_is_pair_t) && (fx_proc(la) == fx_cdr_t) && (is_pair(slot_value(la_slot)))) + { + /* we need to save la new value before getting the new l2a value since l2a might refer to the current la value or vice versa */ + do { + s7_pointer p = cdr(slot_value(la_slot)); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, p); + } while (is_pair(slot_value(la_slot))); + return(op_tc_z(sc, if_done)); + } + while (tf(sc, if_test) != sc->F) + { + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); + }} + return(op_tc_z(sc, if_done)); +} + +static s7_pointer fx_tc_if_a_z_l2a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_l2a(sc, arg); + sc->rec_p1 = sc->unused; + return(sc->value); +} + +static bool op_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer code) +{ + bool true_quits = true_is_done(code); + s7_pointer la_slot = let_slots(sc->curlet); + s7_pointer if_test = rec_test_clause(code); + s7_pointer if_done = rec_done_clause(code); + s7_pointer la = rec_call_clause(code); + s7_pointer l2a = cdr(la); + s7_pointer l3a = cdr(l2a); + s7_pointer l2a_slot = next_slot(la_slot); + s7_pointer l3a_slot = next_slot(l2a_slot); + s7_function tf = fx_proc(if_test); + tick_tc(sc, OP_TC_IF_A_Z_L3A); + if_test = car(if_test); + while ((tf(sc, if_test) != sc->F) != true_quits) + { + sc->rec_p1 = fx_call(sc, la); + sc->rec_p2 = fx_call(sc, l2a); + slot_set_value(l3a_slot, fx_call(sc, l3a)); + slot_set_value(l2a_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } + return(op_tc_z(sc, if_done)); +} + +static s7_pointer fx_tc_if_a_z_l3a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_l3a(sc, arg); + sc->rec_p1 = sc->unused; + sc->rec_p2 = sc->unused; + return(sc->value); +} + + +static s7_pointer 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); + tick_tc(sc, OP_TC_AND_A_OR_A_LA); /* cell_optimize here is slower! */ + while (true) + { + s7_pointer p; + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + p = fx_call(sc, fx_or); + if (p != sc->F) return(p); + slot_set_value(la_slot, fx_call(sc, fx_la)); + } + return(sc->F); +} + +static s7_pointer 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); + tick_tc(sc, OP_TC_OR_A_AND_A_LA); + while (true) + { + s7_pointer p = fx_call(sc, fx_or); + if (p != sc->F) return(p); + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + slot_set_value(la_slot, fx_call(sc, fx_la)); + } + return(sc->F); +} + +static s7_pointer 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); + tick_tc(sc, OP_TC_AND_A_OR_A_A_LA); + while (true) + { + s7_pointer p; + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + p = fx_call(sc, fx_or1); + if (p != sc->F) return(p); + p = fx_call(sc, fx_or2); + if (p != sc->F) return(p); + slot_set_value(la_slot, fx_call(sc, fx_la)); + } + return(sc->F); +} + +static s7_pointer 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); + tick_tc(sc, OP_TC_OR_A_AND_A_A_LA); + while (true) + { + s7_pointer p = fx_call(sc, fx_or); + if (p != sc->F) return(p); + if ((fx_call(sc, fx_and1) == sc->F) || + (fx_call(sc, fx_and2) == sc->F)) + return(sc->F); + slot_set_value(la_slot, fx_call(sc, fx_la)); + } + return(sc->F); +} + +static s7_pointer 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); + tick_tc(sc, OP_TC_OR_A_A_AND_A_A_LA); + while (true) + { + s7_pointer p = fx_call(sc, fx_or1); + if (p != sc->F) return(p); + p = fx_call(sc, fx_or2); + if (p != sc->F) return(p); + if (fx_call(sc, fx_and1) == sc->F) return(sc->F); + if (fx_call(sc, fx_and2) == sc->F) return(sc->F); + slot_set_value(la_slot, fx_call(sc, fx_la)); + } + return(sc->F); +} + +static s7_pointer op_tc_and_a_or_a_l2a(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_l2a = cdr(fx_la); + s7_pointer l2a_slot = next_slot(la_slot); + tick_tc(sc, OP_TC_AND_A_OR_A_L2A); + + 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_l2a) == fx_cdr_u)) + { + s7_pointer la_val = slot_value(la_slot), l2a_val = slot_value(l2a_slot); + while (true) + { + if (is_null(l2a_val)) return(sc->F); + if (is_null(la_val)) return(sc->T); + if (!is_pair(l2a_val)) sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, l2a_val, sc->type_names[T_PAIR]); + if (!is_pair(la_val)) sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, la_val, sc->type_names[T_PAIR]); + la_val = cdr(la_val); + l2a_val = cdr(l2a_val); + }} + while (true) + { + s7_pointer p; + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + p = fx_call(sc, fx_or); + if (p != sc->F) return(p); + sc->rec_p1 = fx_call(sc, fx_la); + slot_set_value(l2a_slot, fx_call(sc, fx_l2a)); + slot_set_value(la_slot, sc->rec_p1); + } + return(sc->F); +} + +static s7_pointer op_tc_or_a_and_a_l2a(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_l2a = cdr(fx_la); + s7_pointer l2a_slot = next_slot(la_slot); + tick_tc(sc, OP_TC_OR_A_AND_A_L2A); + while (true) + { + s7_pointer p = fx_call(sc, fx_or); + if (p != sc->F) return(p); + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + sc->rec_p1 = fx_call(sc, fx_la); + slot_set_value(l2a_slot, fx_call(sc, fx_l2a)); + slot_set_value(la_slot, sc->rec_p1); + } + return(sc->F); +} + +static s7_pointer 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_l2a = cdr(fx_la); + s7_pointer fx_l3a = cdr(fx_l2a); + s7_pointer l2a_slot = next_slot(la_slot); + s7_pointer l3a_slot = next_slot(l2a_slot); + tick_tc(sc, OP_TC_AND_A_OR_A_L3A); + while (true) + { + s7_pointer p; + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + p = fx_call(sc, fx_or); + if (p != sc->F) return(p); + sc->rec_p1 = fx_call(sc, fx_la); + sc->rec_p2 = fx_call(sc, fx_l2a); + slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); + slot_set_value(l2a_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } + return(sc->F); +} + +static s7_pointer 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_l2a = cdr(fx_la); + s7_pointer fx_l3a = cdr(fx_l2a); + s7_pointer l2a_slot = next_slot(la_slot); + s7_pointer l3a_slot = next_slot(l2a_slot); + tick_tc(sc, OP_TC_OR_A_AND_A_L3A); + while (true) + { + s7_pointer p = fx_call(sc, fx_or); + if (p != sc->F) return(p); + if (fx_call(sc, fx_and) == sc->F) return(sc->F); + sc->rec_p1 = fx_call(sc, fx_la); + sc->rec_p2 = fx_call(sc, fx_l2a); + slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); + slot_set_value(l2a_slot, sc->rec_p2); + slot_set_value(la_slot, sc->rec_p1); + } + return(sc->F); +} + +static s7_pointer 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_l2a = cdr(fx_la); + s7_pointer l2a_slot = next_slot(la_slot); + s7_pointer fx_l3a = cdr(fx_l2a); + s7_pointer l3a_slot = next_slot(l2a_slot); + tick_tc(sc, OP_TC_OR_A_AND_A_A_L3A); + 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) return(p); + if ((fx_call(sc, fx_and1) != sc->F) || (fx_call(sc, fx_and2) != sc->F)) return(sc->F); + sc->rec_p1 = fx_call(sc, fx_la); + sc->rec_p2 = fx_call(sc, fx_l2a); + slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); + slot_set_value(la_slot, sc->rec_p1); + slot_set_value(l2a_slot, sc->rec_p2); + }} + while (true) + { + s7_pointer p = fx_call(sc, fx_or); + if (p != sc->F) return(p); + if ((fx_call(sc, fx_and1) == sc->F) || (fx_call(sc, fx_and2) == sc->F)) return(sc->F); + sc->rec_p1 = fx_call(sc, fx_la); + sc->rec_p2 = fx_call(sc, fx_l2a); + slot_set_value(l3a_slot, fx_call(sc, fx_l3a)); + slot_set_value(la_slot, sc->rec_p1); + slot_set_value(l2a_slot, sc->rec_p2); + } + return(sc->F); +} + +static bool op_tc_if_a_z_if_a_z_la(s7_scheme *sc, s7_pointer code, bool z_first) +{ + s7_pointer if1_test, if1_true, if1_false, if2_test, if2_z, la, endp, la_slot = let_slots(sc->curlet); + bool tc_and = (car(code) == sc->and_symbol); + bool tc_cond = (car(code) == sc->cond_symbol); + tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_LA); + if (!tc_cond) /* code: (if a1 z1 (if a2 z2 la) or (and a1 (if a2 z la))? */ + { + if1_test = cdr(code); + if1_true = (!tc_and) ? cdr(if1_test) : sc->F; + if1_false = (!tc_and) ? cadr(if1_true) : cadr(if1_test); + if2_test = cdr(if1_false); + if2_z = (z_first) ? cdr(if2_test) : cddr(if2_test); + la = (z_first) ? cdaddr(if2_test) : cdadr(if2_test); + } + else + { + if1_test = cadr(code); /* code: (cond (a1 z1) (a2 z2|la) (else la|z3)) */ + if1_true = cdr(if1_test); + if1_false = caddr(code); /* (a2 z2|la) */ + if2_test = if1_false; + if2_z = (z_first) ? cdr(if2_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, if1_test)) + { + opt_info *o1 = sc->opts[sc->pc]; + if (bool_optimize_nw(sc, if2_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 = if2_z; break;} + set_integer(val, o2->v[0].fi(o2)); + } + else + while (true) + { + if (o->v[0].fb(o)) {endp = if1_true; break;} + if (o1->v[0].fb(o1) == z_first) {endp = if2_z; break;} + set_integer(val, o2->v[0].fi(o2)); + } + return(op_tc_z(sc, endp)); + }}}} +#endif + while (true) + { + if ((fx_call(sc, if1_test) == sc->F) == tc_and) {if (tc_and) {sc->value = sc->F; return(true);} else {endp = if1_true; break;}} + if ((fx_call(sc, if2_test) == sc->F) != z_first) {endp = if2_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) +{ + op_tc_if_a_z_if_a_z_la(sc, arg, true); + 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); + 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); + 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); + return(sc->value); +} + +static bool op_tc_if_a_z_if_a_z_l2a(s7_scheme *sc, s7_pointer code) +{ + const bool cond = car(code) == sc->cond_symbol; + s7_pointer if2_test, if2_true, la, l2a, l2a_slot, endp, slot1; + const s7_pointer la_slot = let_slots(sc->curlet); + const s7_pointer if1_test = (cond) ? cadr(code) : cdr(code); + const s7_pointer if1_true = cdr(if1_test); + tick_tc(sc, OP_TC_IF_A_Z_IF_A_Z_L2A); + if2_test = (cond) ? caddr(code) : cdadr(if1_true); + if2_true = cdr(if2_test); + la = (cond) ? opt3_pair(code) : cdadr(if2_true); /* cdadr(cadddr(code)) */ + l2a = cdr(la); + l2a_slot = next_slot(la_slot); + slot1 = (fx_proc(if1_test) == fx_is_null_t) ? la_slot : ((fx_proc(if1_test) == fx_is_null_u) ? l2a_slot : NULL); + if (slot1) + { + if ((slot1 == l2a_slot) && (fx_proc(if2_test) == fx_is_null_t) && (fx_proc(la) == fx_cdr_t) && (fx_proc(l2a) == fx_cdr_u) && + (is_boolean(car(if1_true))) && (is_boolean(car(if2_true)))) + { /* ugly... */ + s7_pointer la_val = slot_value(la_slot), l2a_val = slot_value(l2a_slot); + while (true) + { + if (is_null(l2a_val)) {sc->value = car(if1_true); return(true);} + if (is_null(la_val)) {sc->value = car(if2_true); return(true);} + if (!is_pair(l2a_val)) sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, l2a_val, sc->type_names[T_PAIR]); + if (!is_pair(la_val)) sole_arg_wrong_type_error_nr(sc, sc->cdr_symbol, la_val, sc->type_names[T_PAIR]); + la_val = cdr(la_val); + l2a_val = cdr(l2a_val); + }} + while (true) + { + if (is_null(slot_value(slot1))) {endp = if1_true; break;} + if (fx_call(sc, if2_test) != sc->F) {endp = if2_true; break;} + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); + }} + else + while (true) + { + if (fx_call(sc, if1_test) != sc->F) {endp = if1_true; break;} + if (fx_call(sc, if2_test) != sc->F) {endp = if2_true; break;} + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + 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_l2a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_if_a_z_l2a(sc, arg); + sc->rec_p1 = sc->unused; + return(sc->value); +} + +static bool op_tc_if_a_z_if_a_l2a_z(s7_scheme *sc, s7_pointer code) +{ + bool cond = car(code) == sc->cond_symbol; + s7_pointer if2_test, if2_true, if2_false, la, l2a, l2a_slot, endp; + s7_pointer la_slot = let_slots(sc->curlet); + s7_pointer if1_test = (cond) ? cadr(code) : cdr(code); + s7_pointer if1_true = cdr(if1_test); + if2_test = (cond) ? caddr(code) : cdadr(if1_true); + if2_true = cdr(if2_test); + if2_false = (cond) ? cdr(cadddr(code)) : cdr(if2_true); + la = (cond) ? opt3_pair(code) : cdar(if2_true); /* cdadr(caddr(code)) */ + l2a = cdr(la); + l2a_slot = next_slot(la_slot); + while (true) + { + if (fx_call(sc, if1_test) != sc->F) {endp = if1_true; break;} + if (fx_call(sc, if2_test) == sc->F) {endp = if2_false; break;} + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); + } + return(op_tc_z(sc, endp)); +} + +static s7_pointer fx_tc_if_a_z_if_a_l2a_z(s7_scheme *sc, s7_pointer arg) +{ + tick_tc(sc, OP_TC_IF_A_Z_IF_A_L2A_Z); + op_tc_if_a_z_if_a_l2a_z(sc, 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 if1_test = cdr(code); + s7_pointer endp, la_slot = let_slots(sc->curlet); + s7_pointer if1_true = cdr(if1_test); + s7_pointer if1_false = cadr(if1_true); + s7_pointer if2_test = cdr(if1_false); + s7_pointer if2_true = cdr(if2_test); + s7_pointer if2_false = cdr(if2_true); + s7_pointer la1 = cdar(if2_true); + s7_pointer la2 = cdar(if2_false); + s7_pointer l2a1 = cdr(la1); + s7_pointer l2a2 = cdr(la2); + s7_pointer l2a_slot = next_slot(la_slot); + s7_pointer l3a1 = cdr(l2a1); + s7_pointer l3a2 = cdr(l2a2); + s7_pointer l3a_slot = next_slot(l2a_slot); + tick_tc(sc, OP_TC_IF_A_Z_IF_A_L3A_L3A); + while (true) + { + if (fx_call(sc, if1_test) != sc->F) {endp = if1_true; break;} + if (fx_call(sc, if2_test) != sc->F) + { + sc->rec_p1 = fx_call(sc, la1); + sc->rec_p2 = fx_call(sc, l2a1); + slot_set_value(l3a_slot, fx_call(sc, l3a1)); + } + else + { + sc->rec_p1 = fx_call(sc, la2); + sc->rec_p2 = fx_call(sc, l2a2); + slot_set_value(l3a_slot, fx_call(sc, l3a2)); + } + slot_set_value(l2a_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) +{ + 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_if_a_z_if_a_z_l3a(s7_scheme *sc, s7_pointer code, bool zfirst) /* zfirst: z_l3a rather than l3a_z */ +{ + s7_pointer if1_test = cdr(code); + s7_pointer endp, la_slot = let_slots(sc->curlet); + s7_pointer l2a_slot = next_slot(la_slot); + s7_pointer l3a_slot = next_slot(l2a_slot); + s7_pointer if1_true = cdr(if1_test); + s7_pointer if1_false = cadr(if1_true); + s7_pointer if2_test = cdr(if1_false); + s7_pointer if2_true = cdr(if2_test); + s7_pointer if2_false = cdr(if2_true); + s7_pointer zendp = (zfirst) ? if2_true : if2_false; + s7_pointer la2 = (zfirst) ? cdar(if2_false) : cdar(if2_true); + s7_pointer l2a2 = cdr(la2); + s7_pointer l3a2 = cdr(l2a2); + tick_tc(sc, (zfirst) ? OP_TC_IF_A_Z_IF_A_Z_L3A : OP_TC_IF_A_Z_IF_A_L3A_Z); + + while (true) + { + if (fx_call(sc, if1_test) != sc->F) {endp = if1_true; break;} + if ((fx_call(sc, if2_test) != sc->F) == zfirst) {endp = zendp; break;} + sc->rec_p1 = fx_call(sc, la2); + sc->rec_p2 = fx_call(sc, l2a2); + slot_set_value(l3a_slot, fx_call(sc, l3a2)); + slot_set_value(l2a_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_z_l3a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_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_z_if_a_l3a_z(s7_scheme *sc, s7_pointer arg) +{ + op_tc_if_a_z_if_a_z_l3a(sc, arg, false); + 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); + bool wrappable = has_fx(if_true); + s7_pointer if_false = cadddr(body); + s7_pointer la = cdr(if_false); + s7_pointer let_var = caadr(code); + s7_pointer inner_let = (wrappable) ? wrap_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))) : + make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); + s7_pointer let_slot = let_slots(inner_let); + tick_tc(sc, OP_TC_LET_IF_A_Z_LA); + set_curlet(sc, inner_let); + if (!wrappable) 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); + } + if (!wrappable) unstack_gc_protect(sc); + if (!op_tc_z(sc, if_true)) return(false); + let_set_slots(inner_let, slot_end); + return(true); +} + +static s7_pointer fx_tc_let_if_a_z_la(s7_scheme *sc, s7_pointer arg) +{ + op_tc_let_if_a_z_la(sc, arg); + return(sc->value); +} + +static bool op_tc_let_if_a_z_l2a(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 l2a_slot = next_slot(la_slot); + s7_pointer if_test = cdr(body); + s7_pointer if_true = cddr(body); + bool wrappable = has_fx(if_true); + s7_pointer if_false = cadddr(body); + s7_pointer la = cdr(if_false); + s7_pointer l2a = cddr(if_false); + s7_pointer let_var = caadr(code); + s7_pointer inner_let = (wrappable) ? wrap_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))) : + make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); + s7_pointer let_slot = let_slots(inner_let); + tick_tc(sc, OP_TC_LET_IF_A_Z_L2A); + set_curlet(sc, inner_let); + if (!wrappable) 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(l2a_slot)))) + { + if (int_optimize(sc, la)) + { + o2 = sc->opts[sc->pc]; + if (int_optimize(sc, l2a)) + { + 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(l2a_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(l2a_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)); + } + if (!wrappable) unstack_gc_protect(sc); + if (!op_tc_z(sc, if_true)) return(false); + let_set_slots(inner_let, slot_end); + 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(l2a_slot, fx_call(sc, l2a)); + 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); + } + if (!wrappable) unstack_gc_protect(sc); + if (!op_tc_z(sc, if_true)) return(false); + let_set_slots(inner_let, slot_end); + return(true); +} + +static s7_pointer fx_tc_let_if_a_z_l2a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_let_if_a_z_l2a(sc, arg); + sc->rec_p1 = sc->unused; + return(sc->value); +} + +static s7_pointer op_tc_let_when_l2a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer p, la, l2a, let_var = caadr(code); + const s7_pointer body = caddr(code), outer_let = sc->curlet; + const bool when = (car(body) != sc->unless_symbol); /* can also be when or if */ + const s7_pointer if_test = cdr(body); + const s7_pointer if_true = cddr(body); + s7_pointer inner_let = wrap_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); + s7_pointer let_slot = let_slots(inner_let); + tick_tc(sc, OP_TC_LET_WHEN_L2A); + + set_curlet(sc, inner_let); + let_var = cdr(let_var); + for (p = if_true; is_pair(cdr(p)); p = cdr(p)); + la = cdar(p); + l2a = cddar(p); + if ((car(la) == slot_symbol(let_slots(outer_let))) && + (car(l2a) == 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) + { + s7_pointer p2 = fx_call(sc, if_test); + if (when) {if (p2 == sc->F) break;} else {if (p2 != sc->F) break;} + for (s7_pointer p1 = if_true; is_pair(cdr(p1)); p1 = cdr(p1)) + fx_call(sc, p1); + 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 l2a_slot = next_slot(la_slot); + while (true) + { + s7_pointer p2 = fx_call(sc, if_test); + if (when) {if (p2 == sc->F) break;} else {if (p2 != sc->F) break;} + for (s7_pointer p1 = if_true; is_pair(cdr(p1)); p1 = cdr(p1)) + fx_call(sc, p1); + sc->rec_p1 = fx_call(sc, la); + slot_set_value(l2a_slot, fx_call(sc, l2a)); + 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); + }} + return(sc->unspecified); +} + +static bool op_tc_if_a_z_let_if_a_z_l2a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer if1_test = cdr(code), endp, outer_let = sc->curlet, slot, 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 l2a = cdr(la); + s7_pointer l2a_slot = next_slot(la_slot); + s7_pointer inner_let = inline_make_let(sc, sc->curlet); + tick_tc(sc, OP_TC_IF_A_Z_LET_IF_A_Z_L2A); + + 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 (s7_pointer var = cdr(let_vars); is_pair(var); var = cdr(var)) + slot = 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 (s7_pointer var = cdr(let_vars), slot1 = next_slot(slot); is_pair(var); var = cdr(var), slot1 = next_slot(slot1)) + slot_set_value(slot1, 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(l2a_slot, fx_call(sc, l2a)); + slot_set_value(la_slot, sc->rec_p1); + set_curlet(sc, outer_let); + } + sc->rec_p1 = sc->unused; + unstack_gc_protect(sc); + return(op_tc_z(sc, endp)); /* might refer to inner_let slots */ +} + +static bool op_tc_let_cond(s7_scheme *sc, s7_pointer code) +{ + bool read_case; + const s7_int args = opt3_arglen(cdr(code)); + s7_pointer result; + const s7_pointer outer_let = sc->curlet; + const s7_pointer slots = let_slots(outer_let); + const 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)); + const s7_pointer inner_let = make_let_with_slot(sc, sc->curlet, car(let_var), fx_call(sc, cdr(let_var))); + const s7_pointer let_slot = let_slots(inner_let); + tick_tc(sc, OP_TC_LET_COND); + + 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 (args < 2) + 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; + if (args == 1) + 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); + return(true); + } + sc->code = car(result); + return(false); +} + +static s7_pointer fx_tc_let_cond(s7_scheme *sc, s7_pointer arg) +{ + op_tc_let_cond(sc, arg); + return(sc->value); +} + +static bool op_tc_cond_a_z_a_l2a_l2a(s7_scheme *sc, s7_pointer code) +{ + s7_pointer c1 = cadr(code); + const s7_pointer c2 = caddr(code), la_slot = let_slots(sc->curlet); + const s7_pointer la1 = cdadr(c2); + const s7_pointer l2a1 = cddadr(c2); + const s7_pointer c3 = opt3_pair(code); /* cadr(cadddr(code)) = cadr(else_clause) */ + const s7_pointer la2 = cdr(c3); + const s7_pointer l2a2 = cddr(c3); + const s7_pointer l2a_slot = next_slot(la_slot); + tick_tc(sc, OP_TC_COND_A_Z_A_L2A_L2A); + 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(l2a_slot, fx_call(sc, l2a1)); + } + else + { + sc->rec_p1 = fx_call(sc, la2); + slot_set_value(l2a_slot, fx_call(sc, l2a2)); + } + slot_set_value(la_slot, sc->rec_p1); + } + return(op_tc_z(sc, c1)); +} + +static s7_pointer fx_tc_cond_a_z_a_l2a_l2a(s7_scheme *sc, s7_pointer arg) +{ + op_tc_cond_a_z_a_l2a_l2a(sc, arg); + sc->rec_p1 = sc->unused; + return(sc->value); +} + +static bool op_tc_cond_n(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer let = sc->curlet; + const s7_pointer slots = let_slots(let); + const s7_int args = opt3_arglen(cdr(code)); + const s7_pointer cond_body = cdr(code); + s7_pointer result = sc->unspecified; + tick_tc(sc, OP_TC_COND_N); + + if (args < 2) + while (true) + for (s7_pointer p = cond_body; is_pair(p); p = cdr(p)) + if (fx_call(sc, car(p)) != sc->F) /* we got true car(clause) */ + { + result = cdar(p); + if (!has_tc(result)) + goto TC_COND_N_DONE; + if (args == 1) + slot_set_value(slots, fx_call(sc, cdar(result))); /* arg to recursion */ + break; /* tc call */ + } + let_set_has_pending_value(let); + 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_COND_N_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)); + break; + } + let_clear_has_pending_value(sc, let); + + TC_COND_N_DONE: + if (has_fx(result)) + { + sc->value = fx_call(sc, result); + return(true); + } + sc->code = car(result); + return(false); +} + +static s7_pointer fx_tc_cond_n(s7_scheme *sc, s7_pointer arg) +{ + op_tc_cond_n(sc, arg); + return(sc->value); +} + +/* -------- rec -------- */ + +#ifndef INITIAL_RECUR_STACK_SIZE + #define INITIAL_RECUR_STACK_SIZE 1024 /* stack max size 39 in s7test.scm, 1001 trec, 513 c, 100 b */ +#endif + +static void recur_resize(s7_scheme *sc) +{ + const s7_pointer stack = sc->rec_stack; + block_t *ob, *nb; + if ((sc->rec_len / 2) > sc->max_stack_size) /* /2 not *2 because the stack size refers to the 4-frame main stack */ +#if S7_DEBUGGING + { + fprintf(stderr, "%s%s[%d]: rec stack will be too big after resize, %" ld64 " > %u%s\n", bold_text, __func__, __LINE__, sc->rec_len / 2, sc->max_stack_size, unbold_text); + if (sc->stop_at_error) abort(); + } +#else + error_nr(sc, make_symbol(sc, "stack-too-big", 13), + set_elist_1(sc, wrap_string(sc, "rec stack has grown past (*s7* 'max-stack-size)", 47))); +#endif + 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) +{ + if ((S7_DEBUGGING) && (sc->rec_loc == sc->rec_len)) fprintf(stderr, "%s[%d]: recur stack resize skipped\n", __func__, __LINE__); + sc->rec_els[sc->rec_loc++] = value; +} + +static s7_pointer recur_pop(s7_scheme *sc) {return(sc->rec_els[--sc->rec_loc]);} /* macro is not faster */ +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 result = sc->rec_els[sc->rec_loc - 1]; + sc->rec_els[sc->rec_loc - 1] = value; + return(result); +} + +static void initialize_recur_stack(s7_scheme *sc) +{ + sc->rec_stack = make_simple_vector(sc, INITIAL_RECUR_STACK_SIZE); + sc->rec_els = vector_elements(sc->rec_stack); + sc->rec_len = INITIAL_RECUR_STACK_SIZE; + sc->rec_loc = 0; +} + +static void rec_set_test(s7_scheme *sc, s7_pointer p) +{ + sc->rec_testf = fx_proc(p); + sc->rec_testp = car(p); +} + +static void rec_set_res(s7_scheme *sc, s7_pointer p) +{ + sc->rec_resf = fx_proc(p); + sc->rec_resp = car(p); +} + +static void rec_set_f1(s7_scheme *sc, s7_pointer p) +{ + sc->rec_f1f = fx_proc(p); + sc->rec_f1p = car(p); +} + +static void rec_set_f2(s7_scheme *sc, s7_pointer p) +{ + sc->rec_f2f = fx_proc(p); + sc->rec_f2p = car(p); +} + +static void rec_set_f3(s7_scheme *sc, s7_pointer p) +{ + sc->rec_f3f = fx_proc(p); + sc->rec_f3p = car(p); +} + +static void rec_set_f4(s7_scheme *sc, s7_pointer p) +{ + sc->rec_f4f = fx_proc(p); + sc->rec_f4p = car(p); +} + +static void rec_set_f5(s7_scheme *sc, s7_pointer p) +{ + sc->rec_f5f = fx_proc(p); + sc->rec_f5p = car(p); +} + +static void rec_set_f6(s7_scheme *sc, s7_pointer p) +{ + sc->rec_f6f = fx_proc(p); + sc->rec_f6p = car(p); +} + +static void rec_set_f7(s7_scheme *sc, s7_pointer p) +{ + sc->rec_f7f = fx_proc(p); + sc->rec_f7p = car(p); +} + +static void rec_set_f8(s7_scheme *sc, s7_pointer p) +{ + sc->rec_f8f = fx_proc(p); + sc->rec_f8p = car(p); +} + +typedef enum {opt_ptr, opt_int, opt_dbl, opt_int_0} opt_pid_t; + + +/* -------- if_a_a_opla_laq and if_a_opla_laq_a -------- */ + +static opt_pid_t opinit_if_a_a_opla_laq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + const s7_pointer call1 = cadr(caller); + const s7_pointer call2 = caddr(caller); + +#if !WITH_GMP + const s7_pointer c_op = car(caller); + tick_tc(sc, OP_RECUR_IF_A_A_opLA_LAq); + if ((is_symbol(c_op)) && + ((is_slot(global_slot(c_op))) && + ((is_global(c_op)) || + (s7_t_slot(sc, c_op) == global_slot(c_op))))) + { + const s7_pointer s_func = global_value(c_op); + const 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, rec_test_clause(code))) + { + const 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, rec_done_clause(code)))) + { + sc->rec_a1_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(call1))) + { + sc->rec_a2_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(call2))) + { + sc->rec_bool = a_is_cadr(code); + 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); /* call1/call2 above are more complicated than (- n 1) or the like */ + 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, rec_done_clause(code))) + { + sc->rec_a1_o = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(call1))) + { + sc->rec_a2_o = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(call2))) + { + sc->rec_bool = a_is_cadr(code); + sc->rec_val1 = make_mutable_real(sc, real(slot_value(slot))); + slot_set_value(slot, sc->rec_val1); + return(opt_dbl); + }}}}}}}} +#endif + tick_tc(sc, OP_RECUR_IF_A_A_opLA_LAq); + sc->rec_bool = a_is_cadr(code); + sc->rec_fn = fn_proc(caller); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + rec_set_f1(sc, cdr(call1)); + rec_set_f2(sc, cdr(call2)); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_loc = 0; + 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 s7_pointer op_recur_if_a_a_opla_laq(s7_scheme *sc, s7_pointer code) +{ + const opt_pid_t choice = opinit_if_a_a_opla_laq(sc, code); + const bool a_op = true_is_done(code); + tick_tc(sc, OP_RECUR_IF_A_A_opLA_LAq); + if ((choice == opt_int) || (choice == opt_int_0)) + { + if (choice == opt_int_0) + return(make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq_0(sc) : oprec_i_if_a_opla_laq_a_0(sc))); + return(make_integer(sc, (a_op) ? oprec_i_if_a_a_opla_laq(sc) : oprec_i_if_a_opla_laq_a(sc))); + } + if (choice == opt_ptr) + return((a_op) ? oprec_if_a_a_opla_laq(sc) : oprec_if_a_opla_laq_a(sc)); + return(make_real(sc, (a_op) ? oprec_d_if_a_a_opla_laq(sc) : oprec_d_if_a_opla_laq_a(sc))); +} + + +/* -------- if_a_a_opl2a_l2aq -------- */ + +static void opinit_if_a_a_opl2a_l2aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); /* cdddr(code) */ + const s7_pointer call1 = cadr(caller); + const s7_pointer call2 = caddr(caller); + tick_tc(sc, OP_RECUR_IF_A_A_opL2A_L2Aq); + sc->rec_fn = fn_proc(caller); + rec_set_test(sc, rec_test_clause(code)); /* cdr(code) */ + rec_set_res(sc, rec_done_clause(code)); /* cddr(code) or cdddr(code) */ + sc->rec_bool = true_is_done(code); + rec_set_f1(sc, cdr(call1)); + rec_set_f2(sc, cddr(call1)); + rec_set_f3(sc, cdr(call2)); + rec_set_f4(sc, cddr(call2)); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_loc = 0; +} + +static s7_pointer oprec_if_a_a_opl2a_l2aq(s7_scheme *sc) +{ + if ((sc->rec_testf(sc, sc->rec_testp) != sc->F) == sc->rec_bool) 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_slot2, sc->rec_f4f(sc, sc->rec_f4p)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + sc->value = oprec_if_a_a_opl2a_l2aq(sc); + 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_if_a_a_opl2a_l2aq(sc)); + set_car(sc->t2_2, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_opl2a_l2aq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_opl2a_l2aq(sc, code); + return(oprec_if_a_a_opl2a_l2aq(sc)); +} + + +/* -------- if_a_a_opl3a_l3aq -------- */ + +static void opinit_if_a_a_opl3a_l3aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); /* rec call */ + const s7_pointer call1 = cadr(caller); + const s7_pointer call2 = caddr(caller); + tick_tc(sc, OP_RECUR_IF_A_A_opL3A_L3Aq); + sc->rec_fn = fn_proc(caller); + rec_set_test(sc, rec_test_clause(code)); /* cdr(code) */ + rec_set_res(sc, rec_done_clause(code)); /* cddr(code) or cdddr(code) */ + sc->rec_bool = true_is_done(code); + rec_set_f1(sc, cdr(call1)); + rec_set_f2(sc, cddr(call1)); + rec_set_f3(sc, cdddr(call1)); + rec_set_f4(sc, cdr(call2)); + rec_set_f5(sc, cddr(call2)); + rec_set_f6(sc, cdddr(call2)); + 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_loc = 0; +} + +static s7_pointer oprec_if_a_a_opl3a_l3aq(s7_scheme *sc) +{ + if ((sc->rec_testf(sc, sc->rec_testp) != sc->F) == sc->rec_bool) 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)); + slot_set_value(sc->rec_slot3, sc->rec_f6f(sc, sc->rec_f6p)); + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + sc->value = oprec_if_a_a_opl3a_l3aq(sc); + slot_set_value(sc->rec_slot3, recur_pop(sc)); + 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_if_a_a_opl3a_l3aq(sc)); + set_car(sc->t2_2, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_opl3a_l3aq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_opl3a_l3aq(sc, code); + return(oprec_if_a_a_opl3a_l3aq(sc)); +} + + +/* -------- if_a_a_if_a_a_opla_laq -------- */ +static void opinit_if_a_a_if_a_a_opla_laq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + tick_tc(sc, OP_RECUR_IF_A_A_IF_A_A_opLA_LAq); + rec_set_f1(sc, rec_done_clause(code)); + rec_set_f2(sc, cdr(rec_done_clause(code))); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, cdr(rec_test_clause(code))); + rec_set_f3(sc, cdadr(caller)); + rec_set_f4(sc, rec_call_clause(caller)); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); + sc->rec_loc = 0; +} + +static inline s7_pointer oprec_if_a_a_if_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_if_a_a_if_a_a_opla_laq(sc))); + set_car(sc->t2_1, oprec_if_a_a_if_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_if_a_a_if_a_a_opla_laq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_if_a_a_opla_laq(sc, code); + return(oprec_if_a_a_if_a_a_opla_laq(sc)); +} + + +/* -------- if_a_a_if_a_a_opl2a_l2aq -------- */ +static void opinit_if_a_a_if_a_a_opl2a_l2aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + s7_pointer p; + tick_tc(sc, OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq); + rec_set_f1(sc, rec_done_clause(code)); + rec_set_f2(sc, cdr(rec_done_clause(code))); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, cdr(rec_test_clause(code))); + p = cdadr(caller); + rec_set_f3(sc, p); + rec_set_f4(sc, cdr(p)); + p = rec_call_clause(caller); + rec_set_f5(sc, p); + rec_set_f6(sc, cdr(p)); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_fn = fn_proc(caller); + sc->rec_loc = 0; +} + +static s7_pointer oprec_if_a_a_if_a_a_opl2a_l2aq(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_if_a_a_if_a_a_opl2a_l2aq(sc); /* second l2a 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_if_a_a_if_a_a_opl2a_l2aq(sc)); /* first l2a arg */ + set_car(sc->t2_2, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_if_a_a_opl2a_l2aq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_if_a_a_opl2a_l2aq(sc, code); + return(oprec_if_a_a_if_a_a_opl2a_l2aq(sc)); +} + + +/* -------- if_a_a_if_a_a_opl3a_l3aq -------- */ +static void opinit_if_a_a_if_a_a_opl3a_l3aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + s7_pointer p; + rec_set_f1(sc, rec_done_clause(code)); + rec_set_f2(sc, cdr(rec_done_clause(code))); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, cdr(rec_test_clause(code))); + tick_tc(sc, OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq); + + p = cdadr(caller); + rec_set_f3(sc, p); + rec_set_f4(sc, cdr(p)); + rec_set_f5(sc, cddr(p)); + p = rec_call_clause(caller); + rec_set_f6(sc, p); + rec_set_f7(sc, cdr(p)); + rec_set_f8(sc, cddr(p)); + 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); + sc->rec_loc = 0; +} + +static s7_pointer oprec_if_a_a_if_a_a_opl3a_l3aq(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)); + recur_push(sc, sc->rec_f6f(sc, sc->rec_f6p)); + recur_push(sc, sc->rec_f7f(sc, sc->rec_f7p)); + slot_set_value(sc->rec_slot3, sc->rec_f8f(sc, sc->rec_f8p)); + slot_set_value(sc->rec_slot2, recur_pop(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + sc->value = oprec_if_a_a_if_a_a_opl3a_l3aq(sc); /* second l3a */ + slot_set_value(sc->rec_slot3, recur_pop(sc)); + 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_if_a_a_if_a_a_opl3a_l3aq(sc)); /* first l3a */ + set_car(sc->t2_2, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_if_a_a_opl3a_l3aq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_if_a_a_opl3a_l3aq(sc, code); + return(oprec_if_a_a_if_a_a_opl3a_l3aq(sc)); +} + + +/* -------- if_a_a_opa_laq and if_a_opa_laq_a -------- */ +static opt_pid_t opinit_if_a_a_opa_laq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + const bool la_op = a_is_cadr(caller); +#if !WITH_GMP + const s7_pointer c_op = car(caller); + if ((is_symbol(c_op)) && + ((is_slot(global_slot(c_op))) && + ((is_global(c_op)) || + (s7_t_slot(sc, c_op) == global_slot(c_op))))) + { + const 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, rec_test_clause(code))) /* (zero? x) */ + { + const 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, rec_done_clause(code)))) /* x as return */ + { + sc->rec_a1_o = sc->opts[sc->pc]; + if (int_optimize(sc, (la_op) ? cdr(caller) : cddr(caller))) /* x in (+ x ...) */ + { + sc->rec_a2_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(rec_call_clause(caller)))) /* arg of recur call: (- x 1) */ + { + sc->rec_val1 = make_mutable_integer(sc, integer(slot_value(slot))); + slot_set_value(slot, sc->rec_val1); + return(opt_int); + }}}}}}} +#endif + /* not int: a_op: (lis (cons (car lis) (copy-list-1 (cdr lis)))), + * la_op: ((car lis) (copy-list-1 (cdr lis))), + * opt3: ((cdr lis)) + * (if (not (pair? lis)) lis (cons (car lis) (copy-list (cdr lis)))) + * + * not int: a_op: (1 (lcm n (flcm (- n 1)))), + * la_op: (n (flcm (- n 1))), + * opt3: ((- n 1)) + * (if (<= n 1) 1 (lcm n (flcm (- n 1)))) 1 1 + */ + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller)); /* a arg */ + rec_set_f2(sc, cdr(rec_call_clause(caller))); /* la arg */ + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); + sc->rec_loc = 0; + 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 s7_pointer op_recur_if_a_a_opa_laq(s7_scheme *sc, s7_pointer code) +{ + const bool a_op = true_is_done(code); + const bool la_op = a_is_cadr(rec_call_clause(code)); + opt_pid_t choice = opinit_if_a_a_opa_laq(sc, code); + tick_tc(sc, OP_RECUR_IF_A_A_opA_LAq); + if (choice == opt_int) + return(make_integer(sc, (a_op) ? oprec_i_if_a_a_opa_laq(sc) : oprec_i_if_a_opa_laq_a(sc))); + if (a_op) + return((la_op) ? oprec_if_a_a_opa_laq(sc) : oprec_if_a_a_opla_aq(sc)); + return((la_op) ? oprec_if_a_opa_laq_a(sc) : oprec_if_a_opla_aq_a(sc)); +} + + +/* -------- if_a_a_opa_l2aq -------- */ +static void opinit_if_a_a_opa_l2aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + const bool la_op = a_is_cadr(caller); + tick_tc(sc, OP_RECUR_IF_A_A_opA_L2Aq); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller)); + rec_set_f2(sc, cdr(rec_call_clause(caller))); + rec_set_f3(sc, cddr(rec_call_clause(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_fn = fn_proc(caller); + sc->rec_bool = true_is_done(code); + sc->rec_loc = 0; + if (la_op) {sc->rec_p1 = sc->t2_1; sc->rec_p2 = sc->t2_2;} else {sc->rec_p1 = sc->t2_2; sc->rec_p2 = sc->t2_1;} +} + +static s7_pointer oprec_if_a_a_opa_l2aq(s7_scheme *sc) +{ + if ((sc->rec_testf(sc, sc->rec_testp) != sc->F) == sc->rec_bool) 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) == sc->rec_bool) + set_car(sc->rec_p2, sc->rec_resf(sc, sc->rec_resp)); + else + { + recur_push_unchecked(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->rec_p2, oprec_if_a_a_opa_l2aq(sc)); + set_car(sc->rec_p1, recur_pop(sc)); + set_car(sc->rec_p2, sc->rec_fn(sc, sc->t2_1)); + } + set_car(sc->rec_p1, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_opa_l2aq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_opa_l2aq(sc, code); + return(oprec_if_a_a_opa_l2aq(sc)); +} + + +/* -------- if_a_a_opa_l3aq -------- */ +static void opinit_if_a_a_opa_l3aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + const bool la_op = a_is_cadr(caller); + tick_tc(sc, OP_RECUR_IF_A_A_opA_L3Aq); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + rec_set_f1(sc, (la_op) ? cdr(caller) : cddr(caller)); + rec_set_f2(sc, cdr(rec_call_clause(caller))); + rec_set_f3(sc, cddr(rec_call_clause(caller))); + rec_set_f4(sc, cdddr(rec_call_clause(caller))); + 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); + sc->rec_bool = true_is_done(code); + sc->rec_loc = 0; + if (la_op) {sc->rec_p1 = sc->t2_1; sc->rec_p2 = sc->t2_2;} else {sc->rec_p1 = sc->t2_2; sc->rec_p2 = sc->t2_1;} +} + +static s7_pointer oprec_if_a_a_opa_l3aq(s7_scheme *sc) +{ + if ((sc->rec_testf(sc, sc->rec_testp) != sc->F) == sc->rec_bool) 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) == sc->rec_bool) + set_car(sc->rec_p2, sc->rec_resf(sc, sc->rec_resp)); + else + { + recur_push_unchecked(sc, sc->rec_f1f(sc, sc->rec_f1p)); + recur_push_unchecked(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->rec_p2, oprec_if_a_a_opa_l3aq(sc)); + set_car(sc->rec_p1, recur_pop(sc)); + set_car(sc->rec_p2, sc->rec_fn(sc, sc->t2_1)); + } + set_car(sc->rec_p1, recur_pop(sc)); + return(sc->rec_fn(sc, sc->t2_1)); +} + +static s7_pointer op_recur_if_a_a_opa_l3aq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_opa_l3aq(sc, code); + return(oprec_if_a_a_opa_l3aq(sc)); +} + + +/* -------- if_a_a_opa_la_laq -------- */ +static void opinit_if_a_a_opa_la_laq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + tick_tc(sc, OP_RECUR_IF_A_A_opA_LA_LAq); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + rec_set_f1(sc, cdr(caller)); + rec_set_f2(sc, cdaddr(caller)); + rec_set_f3(sc, cdr(rec_call_clause(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); + sc->rec_loc = 0; + sc->rec_bool = true_is_done(code); +} + +static s7_pointer oprec_if_a_a_opa_la_laq(s7_scheme *sc) +{ + if ((sc->rec_testf(sc, sc->rec_testp) != sc->F) == sc->rec_bool) 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 op_recur_if_a_a_opa_la_laq(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_opa_la_laq(sc, code); + return(oprec_if_a_a_opa_la_laq(sc)); +} + + +/* -------- if_a_a_opla_la_laq -------- */ +static void opinit_if_a_a_opla_la_laq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + tick_tc(sc, OP_RECUR_IF_A_A_opLA_LA_LAq); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + rec_set_f1(sc, cdadr(caller)); + rec_set_f2(sc, cdaddr(caller)); + rec_set_f3(sc, cdr(rec_call_clause(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_fn = fn_proc(caller); + sc->rec_loc = 0; + sc->rec_bool = true_is_done(code); +} + +static s7_pointer oprec_if_a_a_opla_la_laq(s7_scheme *sc) +{ + if ((sc->rec_testf(sc, sc->rec_testp) != sc->F) == sc->rec_bool) 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, s7_pointer code) +{ + opinit_if_a_a_opla_la_laq(sc, code); + return(oprec_if_a_a_opla_la_laq(sc)); +} + +/* -------- if_a_a_and_a_l2a_l2a -------- */ +static void opinit_if_a_a_and_a_l2a_l2a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + const s7_pointer la1 = caddr(caller); + const s7_pointer la2 = cadddr(caller); + tick_tc(sc, OP_RECUR_IF_A_A_AND_A_L2A_L2A); + 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); + sc->rec_loc = 0; +} + +static s7_pointer oprec_if_a_a_and_a_l2a_l2a(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_l2a_l2a(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_unchecked(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_l2a_l2a(sc)); +} + +static s7_pointer op_recur_if_a_a_and_a_l2a_l2a(s7_scheme *sc, s7_pointer code) +{ + opinit_if_a_a_and_a_l2a_l2a(sc, code); + return(oprec_if_a_a_and_a_l2a_l2a(sc)); +} + + +/* -------- cond_a_a_a_a_opa_l2aq -------- */ +static void opinit_cond_a_a_a_a_opa_l2aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + s7_pointer p; + tick_tc(sc, OP_RECUR_COND_A_A_A_A_opA_L2Aq); + rec_set_test(sc, cadr(code)); + rec_set_res(sc, cdadr(code)); + p = caddr(code); + rec_set_f1(sc, p); + rec_set_f2(sc, cdr(p)); + rec_set_f3(sc, cdr(caller)); + rec_set_f4(sc, rec_call_clause(caller)); + rec_set_f5(sc, cdr(rec_call_clause(caller))); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_fn = fn_proc(caller); + sc->rec_loc = 0; +} + +static s7_pointer oprec_cond_a_a_a_a_opa_l2aq(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_l2aq(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_l2aq(s7_scheme *sc, s7_pointer code) +{ + opinit_cond_a_a_a_a_opa_l2aq(sc, code); + return(oprec_cond_a_a_a_a_opa_l2aq(sc)); +} + + +/* -------- cond_a_a_a_l2a_opa_l2aq -------- */ +static void opinit_cond_a_a_a_l2a_opa_l2aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); /* opA_L2A */ + s7_pointer p; + tick_tc(sc, OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq); + rec_set_test(sc, rec_test_clause(code)); + rec_set_res(sc, rec_done_clause(code)); + p = rec_done_clause(cdr(code)); /* (cond) ? caddr(code) : cdr(cadddr(code)); */ + rec_set_f1(sc, p); + p = cdadr(p); + rec_set_f2(sc, p); + rec_set_f3(sc, cdr(p)); + rec_set_f4(sc, cdr(caller)); + p = cdr(rec_call_clause(caller)); /* (L)AA */ + rec_set_f5(sc, p); + rec_set_f6(sc, cdr(p)); + sc->rec_fn = fn_proc(caller); + sc->rec_slot1 = let_slots(sc->curlet); + sc->rec_slot2 = next_slot(sc->rec_slot1); + sc->rec_loc = 0; +} + +static s7_pointer oprec_cond_a_a_a_l2a_opa_l2aq(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_l2a_opa_l2aq(sc)); /* first l2a 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_unchecked(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_l2a_opa_l2aq(sc)); /* first l2a above */ + } + else + { + recur_push_unchecked(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_l2a_opa_l2aq(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_if_a_l2a_opa_l2aq(s7_scheme *sc, s7_pointer code) /* if version, same logic as cond above */ +{ + opinit_cond_a_a_a_l2a_opa_l2aq(sc, code); + return(oprec_cond_a_a_a_l2a_opa_l2aq(sc)); +} + +/* -------- cond_a_a_a_l2a_lopa_l2aq -------- */ + +static opt_pid_t opinit_cond_a_a_a_l2a_lopa_l2aq(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer caller = rec_call_clause(code); + tick_tc(sc, OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq); + 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(code))) + { + sc->rec_result_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdadr(code))) + { + const s7_pointer l2a1 = caddr(code); + sc->rec_a1_o = sc->opts[sc->pc]; + if (bool_optimize(sc, l2a1)) + { + sc->rec_a2_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdadr(l2a1))) + { + sc->rec_a3_o = sc->opts[sc->pc]; + if (int_optimize(sc, cddadr(l2a1))) + { + const s7_pointer l2a2 = cadr(cadddr(code)), l2a3 = caddr(l2a2); + sc->rec_a4_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(l2a2))) + { + sc->rec_a5_o = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(l2a3))) + { + sc->rec_a6_o = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(l2a3))) + { + 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(code)); + rec_set_res(sc, cdadr(code)); + { + s7_pointer p = caddr(code); + rec_set_f1(sc, p); + p = cdadr(p); /* not sc->rec_f1p = car(caddr(code)) */ + rec_set_f2(sc, p); + rec_set_f3(sc, cdr(p)); + rec_set_f4(sc, cdr(caller)); + p = rec_call_clause(caller); + rec_set_f5(sc, p); + rec_set_f6(sc, cdr(p)); + } + sc->rec_loc = 0; + return(opt_ptr); +} + +static s7_int oprec_i_cond_a_a_a_l2a_lopa_l2aq(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_l2a_lopa_l2aq(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_l2a_lopa_l2aq(sc)); + set_integer(sc->rec_val1, i1); + return(oprec_i_cond_a_a_a_l2a_lopa_l2aq(sc)); +} + +static s7_int oprec_i_cond_a_a_a_l2a_lopa_l2aq_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_l2a_lopa_l2aq_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_l2a_lopa_l2aq_0(sc)); + set_integer(sc->rec_val1, i1); + return(oprec_i_cond_a_a_a_l2a_lopa_l2aq_0(sc)); +} + +static s7_pointer oprec_cond_a_a_a_l2a_lopa_l2aq(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_l2a_lopa_l2aq(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_l2a_lopa_l2aq(sc)); + slot_set_value(sc->rec_slot1, recur_pop(sc)); + return(oprec_cond_a_a_a_l2a_lopa_l2aq(sc)); +} + +static s7_pointer op_recur_cond_a_a_a_l2a_lopa_l2aq(s7_scheme *sc, s7_pointer code) +{ + opt_pid_t choice = opinit_cond_a_a_a_l2a_lopa_l2aq(sc, code); + tick_tc(sc, OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq); + if (choice != opt_ptr) + return(make_integer(sc, (choice == opt_int) ? oprec_i_cond_a_a_a_l2a_lopa_l2aq(sc) : oprec_i_cond_a_a_a_l2a_lopa_l2aq_0(sc))); + return(oprec_cond_a_a_a_l2a_lopa_l2aq(sc)); +} + +/* -------- and_a_or_a_l2a_l2a -------- */ +static void opinit_and_a_or_a_l2a_l2a(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer orp = cdr(rec_call_clause(code)); + tick_tc(sc, OP_RECUR_AND_A_OR_A_L2A_L2A); + 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); + sc->rec_loc = 0; +} + +static s7_pointer oprec_and_a_or_a_l2a_l2a(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_l2a_l2a(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_unchecked(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_l2a_l2a(sc)); +} + +static s7_pointer op_recur_and_a_or_a_l2a_l2a(s7_scheme *sc, s7_pointer code) +{ + opinit_and_a_or_a_l2a_l2a(sc, code); + return(oprec_and_a_or_a_l2a_l2a(sc)); +} + + +/* -------------------------------- */ +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) +{ + const 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 + { + const 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 func) +{ + if ((((type(func) == T_C_FUNCTION) && (c_function_is_aritable(func, 1))) || + ((type(func) == T_C_RST_NO_REQ_FUNCTION) && (!has_even_args(func)))) && + (!needs_copied_args(func))) + { + sc->value = c_function_call(func)(sc, with_list_t1(fx_call(sc, cdr(sc->code)))); + return(true); + } + if (is_any_vector(func)) + { + sc->args = set_plist_1(sc, fx_call(sc, cdr(sc->code))); + sc->code = func; + apply_vector(sc); + return(true); + } + if (!is_applicable(func)) + apply_error_nr(sc, func, cdr(sc->code)); + if (dont_eval_args(func)) + sc->args = cdr(sc->code); /* list_1(sc, cadr(sc->code)); */ + else + if (!needs_copied_args(func)) + 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 = func; + return(false); /* goto APPLY */ +} + +static bool op_x_sc(s7_scheme *sc, s7_pointer func) +{ + const s7_pointer code = sc->code; + if (((type(func) == T_C_FUNCTION) && (c_function_is_aritable(func, 2))) || + (type(func) == T_C_RST_NO_REQ_FUNCTION)) /* ((L 'abs) x 0.0001) where 'abs is '* in timp.scm */ + { + if (!needs_copied_args(func)) + { + sc->value = c_function_call(func)(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->value = c_function_call(func)(sc, sc->args); + return(true); + } + if (!is_applicable(func)) + apply_error_nr(sc, func, cdr(code)); + if (dont_eval_args(func)) + sc->args = list_2(sc, cadr(code), caddr(code)); + else + if (!needs_copied_args(func)) + 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 = func; + return(false); /* goto APPLY */ +} + +static bool op_x_aa(s7_scheme *sc, s7_pointer func) +{ + const s7_pointer code = sc->code; + if (((type(func) == T_C_FUNCTION) && (c_function_is_aritable(func, 2))) || + (type(func) == T_C_RST_NO_REQ_FUNCTION)) + { + if (!needs_copied_args(func)) + { + set_car(sc->elist_7, fx_call(sc, cdr(code))); /* heh heh... (I'm going to regret this someday) */ + sc->value = fx_call(sc, cddr(code)); + sc->value = c_function_call(func)(sc, with_list_t2(car(sc->elist_7), sc->value)); + set_car(sc->elist_7, sc->F); + return(true); + } + sc->args = fx_call(sc, cddr(code)); + sc->args = list_2(sc, sc->value = fx_call(sc, cdr(code)), sc->args); + sc->value = c_function_call(func)(sc, sc->args); + return(true); + } + if (!is_applicable(func)) + apply_error_nr(sc, func, cdr(code)); + if (dont_eval_args(func)) + sc->args = list_2(sc, cadr(code), caddr(code)); + else + { + sc->args = fx_call(sc, cddr(code)); + if (!needs_copied_args(func)) + 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 = func; + 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_safe_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, opt1_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)), opt1_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(gc_protected1(sc))); + unstack_gc_protect(sc); + sc->value = fn_proc(sc->code)(sc, sc->t2_1); +} + +static void op_cl_fa(s7_scheme *sc) +{ + const 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) +{ + const s7_pointer code = sc->code; + sc->value = fx_call(sc, cddr(code)); + if (is_null(sc->value)) + sc->value = (fn_proc_unchecked(code)) ? sc->unspecified : sc->nil; + else + { + sc->code = opt3_pair(code); /* cdadr(code); */ + sc->temp8 = 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, sc->temp8, sc->value) : g_map_closure(sc, sc->temp8, sc->value); + sc->temp8 = sc->unused; + } +} + +static void op_map_for_each_faa(s7_scheme *sc) +{ + const s7_pointer arg2p = cddr(sc->code), code = sc->code; + sc->value = fx_call(sc, arg2p); + sc->args = fx_call(sc, cdr(arg2p)); + 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); */ + sc->temp8 = 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, sc->temp8, sc->value, sc->args) : g_map_closure_2(sc, sc->temp8, sc->value, sc->args); + sc->temp8 = sc->unused; + } +} + +static void op_cl_na(s7_scheme *sc) +{ + const 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_safe_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, gc_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; + const s7_pointer p1 = ((is_pair(sc->args)) && (car(sc->args) == sc->unused)) ? cdr(sc->args) : list_1(sc, sc->args); + const s7_pointer ps1 = gc_protected1(sc); + const s7_pointer p2 = ((is_pair(ps1)) && (car(ps1) == sc->unused)) ? cdr(ps1) : list_1(sc, ps1); + const 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); /* goto EVAL */ + } + sc->args = proper_list_reverse_in_place(sc, sc->args); + sc->value = fn_proc(sc->code)(sc, sc->args); + return(false); /* continue */ +} + +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); /* goto EVAL */ + 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); /* continue?? */ +} + +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); + /* continue */ +} + +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); /* goto EVAL */ + sc->args = proper_list_reverse_in_place(sc, sc->args); + sc->code = c_function_base(opt1_cfunc(pop_op_stack(sc))); + return(false); /* goto APPLY */ +} + +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 args, func; + s7_int id; + sc->args = proper_list_reverse_in_place(sc, sc->args); /* needed in either case -- closure_pars(func) is not reversed */ + sc->code = pop_op_stack(sc); + func = opt1_lambda(sc->code); + + if (is_safe_closure(func)) + { + s7_pointer slot; + id = ++sc->let_number; + set_curlet(sc, closure_let(func)); + let_set_id(sc->curlet, id); + for (slot = let_slots(sc->curlet), args = sc->args; tis_slot(slot); slot = next_slot(slot), args = cdr(args)) + { + slot_set_value(slot, car(args)); + symbol_set_local_slot(slot_symbol(slot), id, slot); + /* don't free sc->args -- it might be needed in the error below */ + } + if (tis_slot(slot)) + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); + } + else + { + s7_pointer pars = closure_pars(func), last_slot; + const s7_pointer e = inline_make_let(sc, closure_let(func)); + begin_temp(sc->y, e); + id = let_id(e); + last_slot = make_slot(sc, car(pars), car(sc->args)); + slot_set_next(last_slot, slot_end); + let_set_slots(e, last_slot); + symbol_set_local_slot(car(pars), id, last_slot); + for (pars = cdr(pars), args = cdr(sc->args); is_pair(pars); pars = cdr(pars), args = cdr(args)) + last_slot = add_slot_at_end(sc, id, last_slot, car(pars), car(args)); /* sets last_slot, don't free sc->args -- used below */ + set_curlet(sc, e); + end_temp(sc->y); + if ((S7_DEBUGGING) && ((is_pair(pars)) || (is_pair(args)))) + fprintf(stderr, "%s[%d]: p: %s, args: %s\n", __func__, __LINE__, display(pars), display(args)); + if (is_pair(pars)) + error_nr(sc, sc->wrong_number_of_args_symbol, set_elist_3(sc, not_enough_arguments_string, sc->code, sc->args)); + } + if (is_pair(args)) /* 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(func); + if_pair_set_up_begin(sc); +} + +static bool op_safe_c_ap(s7_scheme *sc) +{ + const s7_pointer code = cdr(sc->code); + const 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) +{ + const 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) */ + { + const 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 ()) */ +{ + const 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_sc(s7_scheme *sc) +{ + sc->args = list_2(sc, lookup(sc, cadr(sc->code)), opt3_con(cdr(sc->code))); /* 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_gc_protected2(sc, fx_call(sc, cddr(sc->code))); + sc->value = list_2(sc, gc_protected1(sc), gc_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) +{ + const 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) /* -8 so the next two push_stacks don't hit the resize_trigger before we can check for cyclic code */ + 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 head) +{ + /* save call-state before autoload/error-hook invocations */ + const s7_int loc = port_location(current_input_port(sc)); + const s7_pointer ops = op_stack_entry(sc); + const s7_pointer args = sc->args; /* maybe GC protect? */ + const s7_pointer val = check_autoload_and_error_hook(sc, head); + if (val == sc->undefined) + { + const 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, head) : proper_list_reverse_in_place(sc, cons(sc, head, 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), head, sc->w) : + set_elist_5(sc, wrap_string(sc, "'~S is unbound in ~S (~A[~D])", 29), head, 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 head) /* 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(head)) + { + s7_pointer val = lookup_unexamined(sc, head); + sc->code = (val) ? val : unbound_last_arg(sc, head); + } + else sc->code = head; + 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 head) +{ + /* save call-state before autoload/error-hook invocations */ + const s7_int loc = port_location(current_input_port(sc)); + const s7_pointer ops = op_stack_entry(sc); + const s7_pointer args = sc->args; /* maybe GC protect? */ + const s7_pointer value = sc->value; + const s7_pointer val = check_autoload_and_error_hook(sc, head); + if (val == sc->undefined) + { + const 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, head, 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), head, sc->w) : + set_elist_5(sc, wrap_string(sc, "'~S is unbound in ~S (~A[~D])", 29), head, 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) */ +{ + const s7_pointer head = 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(head)) + { + 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 = head; + return(true); + } + /* get the last arg */ + if (is_symbol(head)) + { + s7_pointer val = lookup_unexamined(sc, head); + sc->code = (val) ? val : unbound_args_last_arg(sc, head); + } + else sc->code = head; + /* 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) +{ + const 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) +{ + const s7_pointer code = sc->code, head = car(sc->code); + + /* evaluate the inner list but that list can be circular: head: #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(head))) + /* 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(head) == sc->lambda_symbol) && /* ((lambda ...) expr) */ + (is_pair(cddr(head))) && (s7_is_proper_list(sc, cddr(head)))) /* not dotted! */ + { + const s7_pointer args = cadr(head); + set_opt3_pair(code, cddr(head)); /* lambda body */ + if ((is_null(args)) && (is_null(cdr(code)))) + { + set_optimize_op(code, OP_F); /* ((lambda () ...)) */ + return(false); + } + if (is_pair(args)) + { + if ((is_normal_symbol(car(args))) && (!is_constant(sc, car(args))) && + (is_pair(cdr(code))) && (is_fxable(sc, cadr(code)))) + { + set_opt3_sym(cdr(code), car(args)); /* new curlet symbol #1 (first arg of lambda) */ + if ((is_null(cdr(args))) && (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(cdr(args))) && (is_pair(cddr(code))) && (is_fxable(sc, caddr(code))) && + (is_null(cddr(args))) && (is_null(cdddr(code))) && + (is_normal_symbol(cadr(args))) && (!is_constant(sc, cadr(args))) && (car(args) != cadr(args))) + { + fx_annotate_args(sc, cdr(code), sc->curlet); + set_optimize_op(code, OP_F_AA); /* ((lambda (x y) ...) expr expr) */ + 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 = head; + if (!no_cell_opt(head)) + { + /* if */ + if ((car(head) == 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, head); + if ((fx_function[optimize_op(head)]) && + (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(head)]); + 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(head); + } + 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(head))) + { + if ((fx_function[optimize_op(head)]) && + (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(head)]); + 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 = head; + 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, head); + sc->code = car(head); + return(false); +} + + +/* ---------------- 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) || (top_op == OP_READ_COMPLEX_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 port) +{ + /* 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(port)) + { + char last_char = ' '; + while (true) + { + int32_t c = fgetc(port_file(port)); + 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(port)++; + } + return(token(sc)); + } + orig_str = (const char *)(port_data(port) + port_position(port)); + pend = (const char *)(port_data(port) + port_data_size(port)); + str = orig_str; + while (true) + { + p = strchr(str, (int)'|'); + if ((!p) || (p >= pend)) + { + port_position(port) = port_data_size(port); + 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(port) += (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(port)++; + str = (const char *)(p + 1); + } + else break; + } + return(token(sc)); +} + +static token_t read_excl_comment(s7_scheme *sc, s7_pointer port) +{ + /* 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(port)) != 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 port) +{ + const int32_t c = inchar(port); /* 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->read_dims = int_one; /* for read_expression! */ + return(token_vector); + + case 'i': /* #i(...) */ + if (read_sharp(sc, port) == token_vector) + return(token_int_vector); + backchar('i', port); + break; + + case 'r': /* #r(...) */ + if (read_sharp(sc, port) == token_vector) + return(token_float_vector); + backchar('r', port); + break; + + case 'c': /* #c(...) */ + if (read_sharp(sc, port) == token_vector) + return(token_complex_vector); + backchar('c', port); + break; + + case 'u': /* #u(...) or #u8(...) */ + if (s7_peek_char(sc, port) == chars[(int32_t)('8')]) /* backwards compatibility: #u8(...) == #u(...) */ + { + const int32_t bc = inchar(port); + if (s7_peek_char(sc, port) == chars[(int32_t)('(')]) + { + inchar(port); + sc->read_dims = int_one; /* for read_expression! */ + return(token_byte_vector); + } + backchar(bc, port); + } + if (read_sharp(sc, port) == token_vector) + return(token_byte_vector); + backchar('u', port); + 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(port); + 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') || (d == 'c')) + { + const int32_t e = inchar(port); + 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->read_dims = make_integer(sc, dims); /* for read_expression! */ + if (d == 'd') return(token_vector); + if (d == 'r') return(token_float_vector); + if (d == 'c') return(token_complex_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], port); + } + break; + +#if !DISABLE_DEPRECATED + 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); +#endif + + case '!': /* I don't think #! is special anymore -- maybe remove this code? */ + return(read_excl_comment(sc, port)); + + case '|': + return(read_block_comment(sc, port)); + } + 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 port) +{ + /* 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). + */ + const int32_t c = inchar(port); + 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, port); + return(token_comma); +} + +static token_t read_dot(s7_scheme *sc, s7_pointer port) +{ + const int32_t c = inchar(port); + if (c != EOF) + { + backchar(c, port); + 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 */ +{ + const 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 port) +{ + /* 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(port); + 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, port); /* "\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 */ + { + read_error_nr(sc, "# 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, port); + return(i); + } + /* perhaps if c_ctr==0 error else backchar + return(i??) */ + + c = inchar(port); + if (c == '"') /* "\x4" */ + { + sc->strbuf[i++] = (unsigned char)d1; + backchar((char)c, port); + return(i); + } + if (c == ';') /* "\x4;" */ + { + sc->strbuf[i++] = (unsigned char)d1; + return(i); + } + if (c == EOF) /* "\x4 */ + { + read_error_nr(sc, "# 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, port); + 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 port) +{ + /* sc->F => error, no check needed here for bad input port and so on */ + s7_int i = 0; + + if (is_string_port(port)) + { + /* try the most common case first */ + char *s, *end, *start = (char *)(port_data(port) + port_position(port)); /* not const: C++: strpbrk(start, "\"\n\\") first arg is char* */ + if (*start == '"') + { + port_position(port)++; + return(nil_string); + } + end = (char *)(port_data(port) + port_data_size(port)); + 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(port) += (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(port) += (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") */ + const 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(port) + port_position(port)), len); + port_position(port) += len; + } + i = len; + break; + } + else + if (*s == '\n') + port_line_number(port)++; + }} + while (true) + { + /* splitting this check out and duplicating the loop was slower?!? */ + int32_t c = port_read_character(port)(sc, port); + switch (c) + { + case '\n': + port_line_number(port)++; + 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(port); + 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, port); + 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 \...... or \...... + * 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_string(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 no_return void read_expression_read_error_nr(s7_scheme *sc) +{ + const s7_pointer port = current_input_port(sc); + pop_stack(sc); + if ((is_input_port(port)) && + (!port_is_closed(port)) && + (port_data(port)) && + (port_position(port) > 0)) + { + const s7_pointer str = make_empty_string(sc, 128, '\0'); + const char *msg = string_value(str); + const s7_int pos = port_position(port); + s7_int start = pos - 40; + if (start < 0) start = 0; + memcpy((void *)msg, (const void *)"at \"...", 7); + memcpy((void *)(msg + 7), (void *)(port_data(port) + start), pos - start); + memcpy((void *)(msg + 7 + pos - start), (const void *)"...", 3); + string_length(str) = 7 + pos - start + 3; + error_nr(sc, sc->read_error_symbol, set_elist_1(sc, str)); + } + 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->read_dims); /* sc->read_dims here and below = vector dimensions (from read_sharp) -> sc->args */ + sc->tok = token_left_paren; + break; + + case token_int_vector: + push_stack_no_let_no_code(sc, OP_READ_INT_VECTOR, sc->read_dims); + sc->tok = token_left_paren; + break; + + case token_float_vector: + push_stack_no_let_no_code(sc, OP_READ_FLOAT_VECTOR, sc->read_dims); + sc->tok = token_left_paren; + break; + + case token_complex_vector: + push_stack_no_let_no_code(sc, OP_READ_COMPLEX_VECTOR, sc->read_dims); + 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->read_dims); /* sc->read_dims 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); + check_stack_size(sc); /* s7test, tlimit */ + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->nil); /* here we need to clear args, but code is ignored */ + 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 port) +{ + push_stack_no_let_no_code(sc, OP_READ_LIST, sc->args); + /* check_stack_size(sc); */ + sc->value = port_read_name(port)(sc, port); + sc->args = list_1(sc, sc->value); + pair_set_current_input_location(sc, sc->args); + return(port_read_white_space(port)(sc, port)); +} + +static /* inline */ int32_t read_start_list(s7_scheme *sc, s7_pointer port, 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(port)(sc, port); + sc->args = list_1(sc, sc->value); + pair_set_current_input_location(sc, sc->args); + return(port_read_white_space(port)(sc, port)); +} + +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) +{ + const 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[%d]: %s not loading?\n", __func__, __LINE__, display(current_input_port(sc))); + /* if *#readers* func hits error, clear_loader_port might not be undone? */ + if (SHOW_EVAL_OPS) fprintf(stderr, "%s closing %s\n", __func__, display(current_input_port(sc))); + + 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) +{ + const 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) /* ' -> (#_quote ) 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->symbol_quote) ? sc->quote_symbol : 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->read_dims 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->args = dimensions */ + 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); + /* should this be an error: #r(9223372036854775807): #r(9.223372036854776e+18)? + * also #r(pi)->error that pi is a symbol but #r(+nan.0 -inf.0): #r(+nan.0 -inf.0) -- should pi be a number in the same way? + */ + /* 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->read_dims = dims, read_expression push_op moves it to sc->args + * : 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_complex_vector(s7_scheme *sc) +{ + /* sc->value is the list of values, #c(...sc->value...), sc->args = dimensions */ + sc->value = (sc->args == int_one) ? g_complex_vector(sc, sc->value) : g_complex_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_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); + return(true); +} + +static bool unknown_unknown(s7_scheme *sc, s7_pointer code, opcode_t op) +{ + if ((is_symbol(car(code))) && + (!is_slot(s7_t_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_defined_global(func)) && (is_immutable_slot(global_slot(func)))) + return(true); + for (s7_pointer e = sc->curlet; e; e = let_outlet(e)) + if ((is_funclet(e)) && (funclet_function(e) != func)) + return(false); + return(is_immutable_slot(s7_t_slot(sc, func))); +} + +static bool op_unknown(s7_scheme *sc) +{ + const s7_pointer code = sc->code, func = sc->last_function; + if (!func) /* 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(func), s7_type_names[type(func)]); + + switch (type(func)) + { + case T_CLOSURE: + case T_CLOSURE_STAR: + if (!has_methods(func)) + { + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + if (is_null(closure_pars(func))) + { + const s7_pointer body = closure_body(func); + const bool one_form = is_null(cdr(body)); + const bool safe_case = is_safe_closure(func); + set_opt1_lambda_add(code, func); + if (one_form) + { + if ((safe_case) && (is_fxable(sc, car(body)))) + { + set_safe_closure(func); /* 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(func); + 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(func)) + { + set_safe_optimize_op(code, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA_0 : OP_CLOSURE_STAR_NA)); + set_opt1_lambda_add(code, func); + return(true); + }} + break; + + case T_GOTO: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_GOTO)); + case T_ITERATOR: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_ITERATE)); + case T_BACRO: case T_MACRO: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); + + 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, func, OP_S)); +} + +static bool fxify_closure_star_g(s7_scheme *sc, s7_pointer clo, s7_pointer code) +{ + if ((!has_methods(clo)) && + (closure_star_arity_to_int(sc, clo) != 0)) + { + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + const bool safe_case = is_safe_closure(clo); + fx_annotate_arg(sc, cdr(code), sc->curlet); + set_opt3_arglen(cdr(code), 1); + if ((safe_case) && (is_null(cdr(closure_pars(clo))))) + set_optimize_op(code, hop + OP_SAFE_CLOSURE_STAR_A1); + else + if (lambda_has_simple_defaults(clo)) + { + if (arglist_has_rest(sc, closure_pars(clo))) + fixup_unknown_op(sc, code, clo, hop + ((safe_case) ? OP_SAFE_CLOSURE_STAR_NA_1 : OP_CLOSURE_STAR_NA)); + else fixup_unknown_op(sc, code, clo, hop + ((safe_case) ? + ((is_null(cdr(closure_pars(clo)))) ? OP_SAFE_CLOSURE_STAR_A1 : OP_SAFE_CLOSURE_STAR_A) : OP_CLOSURE_STAR_A)); + return(true); + } + fixup_unknown_op(sc, code, clo, 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 clo, s7_pointer code) +{ + const s7_pointer body = closure_body(clo); + const bool one_form = is_null(cdr(body)); + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + clear_has_fn(code); + set_opt2_sym(code, cadr(code)); + + /* code here might be (clo x) where clo 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 clo which initially + * thinks it is not safe, then later is set safe correctly, now outer func is called again, + * this time clo 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(clo)) ? ((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(clo)) ? + ((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, clo); + return(true); + } + if (!is_safe_closure(clo)) + 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, clo, 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, clo); + return(true); +} + +static bool op_unknown_s(s7_scheme *sc) +{ + const s7_pointer code = sc->code, func = sc->last_function; + + if (!func) unbound_variable_error_nr(sc, car(sc->code)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(func)); + 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(func)) && /* if func 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(func))) + return(fixup_unknown_op(sc, code, func, OP_S_G)); + + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, 1)) break; + case T_C_RST_NO_REQ_FUNCTION: + set_class_and_fn_proc(code, func); + if ((is_safe_procedure(func)) || (c_function_call(func) == g_values)) + { + 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(func)) && (closure_arity_to_int(sc, func) == 1)) + return(op_unknown_closure_s(sc, func, code)); + break; + + case T_CLOSURE_STAR: + if (fxify_closure_star_g(sc, func, 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, func, OP_IMPLICIT_GOTO_A)); + + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_VECTOR_REF_A)); + + case T_STRING: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_STRING_REF_A)); + + case T_PAIR: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_PAIR_REF_A)); + + case T_C_OBJECT: + if (s7_is_aritable(sc, func, 1)) + { + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_C_OBJECT_REF_A)); + } + break; + + case T_LET: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_LET_REF_A)); + + case T_HASH_TABLE: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_HASH_TABLE_REF_A)); + + case T_CONTINUATION: + fx_annotate_arg(sc, cdr(code), sc->curlet); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_CONTINUATION_A)); + + case T_BACRO: case T_MACRO: + return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: + return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); + + default: break; + } + if ((is_symbol(car(code))) && + (!is_slot(s7_t_slot(sc, car(code))))) + unbound_variable_error_nr(sc, car(code)); + return(fixup_unknown_op(sc, code, func, OP_S_G)); +} + +static bool op_unknown_a(s7_scheme *sc) +{ + const s7_pointer code = sc->code, func = sc->last_function; + if (!func) unbound_variable_error_nr(sc, car(sc->code)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(func)); + + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, 1)) break; + case T_C_RST_NO_REQ_FUNCTION: + clear_has_fx(code); + set_class_and_fn_proc(code, func); + if (is_safe_procedure(func)) + { + 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(func)) && + (closure_arity_to_int(sc, func) == 1)) + { + const s7_pointer body = closure_body(func); + const bool safe_case = is_safe_closure(func); + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + const bool one_form = is_null(cdr(body)); + + fxify_closure_a(sc, func, one_form, safe_case, hop, code, sc->curlet); + set_opt1_lambda_add(code, func); + return(true); + } + break; + + case T_CLOSURE_STAR: + if (fxify_closure_star_g(sc, func, code)) return(true); + break; + + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_VECTOR_REF_A)); + + case T_STRING: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_STRING_REF_A)); + case T_PAIR: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_PAIR_REF_A)); + case T_C_OBJECT: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_C_OBJECT_REF_A)); + case T_HASH_TABLE: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_HASH_TABLE_REF_A)); + case T_GOTO: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_GOTO_A)); + case T_CONTINUATION: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_CONTINUATION_A)); + case T_BACRO: + case T_MACRO: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: + case T_MACRO_STAR: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); + + case T_LET: + { + const 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, func, OP_IMPLICIT_LET_REF_C)); + } + return(fixup_unknown_op(sc, code, func, 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, func, OP_S_A)); /* closure with methods etc */ +} + +static bool op_unknown_gg(s7_scheme *sc) +{ + bool s1, s2; + const s7_pointer code = sc->code, func = sc->last_function; + if (!func) unbound_variable_error_nr(sc, car(sc->code)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(func)); + + s1 = is_normal_symbol(cadr(code)); + if ((s1) && + (!is_slot(s7_slot(sc, cadr(code))))) + return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); + s2 = is_normal_symbol(caddr(code)); + if ((s2) && + (!is_slot(s7_slot(sc, caddr(code))))) + return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); + + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, 2)) break; + case T_C_RST_NO_REQ_FUNCTION: + if (is_safe_procedure(func)) + { + if (s1) + { + set_optimize_op(code, (s2) ? OP_SAFE_C_SS : OP_SAFE_C_SC); + if (s2) + set_opt1_sym(cdr(code), caddr(code)); + else set_opt1_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(func)) ? OP_CL_NA : OP_C_NA); + fx_annotate_args(sc, cdr(code), sc->curlet); + } + set_opt3_arglen(cdr(code), 2); + set_class_and_fn_proc(code, func); + return(true); + + case T_CLOSURE: + if (has_methods(func)) break; + if (closure_arity_to_int(sc, func) == 2) + { + const s7_pointer body = closure_body(func); + const bool safe_case = is_safe_closure(func); + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + const 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_pars(func)), cadr(closure_pars(func)), NULL, false); + set_safe_optimize_op(code, hop + OP_SAFE_CLOSURE_SS_A); + set_closure_one_form_fx_arg(func); + }} + 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, func); + return(true); + } + break; + + case T_CLOSURE_STAR: + if ((closure_star_arity_to_int(sc, func) != 0) && + (closure_star_arity_to_int(sc, func) != 1)) + { + fx_annotate_args(sc, cdr(code), sc->curlet); + if (!has_methods(func)) + { + fixup_closure_star_aa(sc, func, code, (is_immutable_and_stable(sc, car(code))) ? 1 : 0); + set_opt1_lambda_add(code, func); + } + 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: case T_COMPLEX_VECTOR: + set_opt3_arglen(cdr(code), 2); + fx_annotate_args(sc, cdr(code), sc->curlet); + if ((!is_pair(func)) && (vector_rank(func) != 2)) + return(fixup_unknown_op(sc, code, func, OP_S_AA)); + return(fixup_unknown_op(sc, code, func, (is_pair(func)) ? 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, func, OP_IMPLICIT_HASH_TABLE_REF_AA)); + + case T_BACRO: case T_MACRO: + return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: + return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); + + default: break; + } + if ((is_symbol(car(code))) && + (!is_slot(s7_t_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, func, OP_S_AA)); +} + +static bool op_unknown_ns(s7_scheme *sc) +{ + const s7_pointer code = sc->code, func = sc->last_function; + const int32_t num_args = opt3_arglen(cdr(code)); + + if (!func) unbound_variable_error_nr(sc, car(sc->code)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(func)); + + 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(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, num_args)) break; + case T_C_RST_NO_REQ_FUNCTION: + if (is_safe_procedure(func)) + { + 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(func)) ? OP_CL_NA : OP_C_NA); + fx_annotate_args(sc, cdr(code), sc->curlet); + } + set_class_and_fn_proc(code, func); + return(true); + + case T_CLOSURE: + if ((!has_methods(func)) && + (closure_arity_to_int(sc, func) == num_args)) + { + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + const bool one_form = is_null(cdr(closure_body(func))); + const bool safe_case = is_safe_closure(func); + fx_annotate_args(sc, cdr(code), sc->curlet); + if (num_args == 3) + return(fixup_unknown_op(sc, code, func, hop + ((safe_case) ? OP_SAFE_CLOSURE_3S : ((one_form) ? OP_CLOSURE_3S_O : OP_CLOSURE_3S)))); + if (num_args == 4) + return(fixup_unknown_op(sc, code, func, hop + ((safe_case) ? OP_SAFE_CLOSURE_NS : ((one_form) ? OP_CLOSURE_4S_O : OP_CLOSURE_4S)))); + return(fixup_unknown_op(sc, code, func, hop + ((safe_case) ? OP_SAFE_CLOSURE_NS : ((num_args == 5) ? OP_CLOSURE_5S : OP_CLOSURE_NS)))); + } + break; + + case T_CLOSURE_STAR: + if ((!has_methods(func)) && + ((closure_star_arity_to_int(sc, func) < 0) || ((closure_star_arity_to_int(sc, func) * 2) >= num_args))) + { + const int32_t hop = (is_immutable_and_stable(sc, car(code))) ? 1 : 0; + fx_annotate_args(sc, cdr(code), sc->curlet); + if ((is_safe_closure(func)) && (num_args == 3) && (closure_star_arity_to_int(sc, func) == 3)) + return(fixup_unknown_op(sc, code, func, OP_SAFE_CLOSURE_STAR_3A)); + return(fixup_unknown_op(sc, code, func, hop + ((is_safe_closure(func)) ? OP_SAFE_CLOSURE_STAR_NA : OP_CLOSURE_STAR_NA))); + } + break; + + case T_BACRO: case T_MACRO: + return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: + return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); + + /* 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) +{ + const s7_pointer code = sc->code, func = sc->last_function, head = car(sc->code); + + if (!func) unbound_variable_error_nr(sc, head); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(func)); + + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, 2)) break; + case T_C_RST_NO_REQ_FUNCTION: + if (is_safe_procedure(func)) /* 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(func)) ? OP_CL_NA : OP_C_NA); + set_class_and_fn_proc(code, func); + return(true); + + case T_CLOSURE: + if ((!has_methods(func)) && + (closure_arity_to_int(sc, func) == 2)) + { + const s7_pointer body = closure_body(func); + const bool safe_case = is_safe_closure(func); + const int32_t hop = (is_immutable_and_stable(sc, head)) ? 1 : 0; + const 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(func); + } + if ((is_fx_treeable(cdr(code))) && (tis_slot(let_slots(sc->curlet)))) fx_curlet_tree(sc, cdr(code)); + set_opt1_lambda_add(code, func); + return(true); + } + break; + + case T_CLOSURE_STAR: + if (!has_methods(func)) + { + fixup_closure_star_aa(sc, func, code, (is_immutable_and_stable(sc, head)) ? 1 : 0); + set_opt1_lambda_add(code, func); + } + 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: case T_COMPLEX_VECTOR: + if (vector_rank(func) != 2) + return(fixup_unknown_op(sc, code, func, OP_S_AA)); + return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_VECTOR_REF_AA)); + + case T_PAIR: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_PAIR_REF_AA)); + case T_HASH_TABLE: return(fixup_unknown_op(sc, code, func, OP_IMPLICIT_HASH_TABLE_REF_AA)); + case T_BACRO: case T_MACRO: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); + + default: break; + } + if ((is_symbol(head)) && + (!is_slot(s7_slot(sc, head)))) + unbound_variable_error_nr(sc, head); + return(fixup_unknown_op(sc, code, func, 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_t_slot(sc, sym))) unbound_variable_error_nr(sc, sym); + return(true); +} + +static bool op_unknown_na(s7_scheme *sc) +{ + const s7_pointer code = sc->code, func = sc->last_function; + const int32_t num_args = (is_pair(cdr(code))) ? opt3_arglen(cdr(code)) : 0; + + if (!func) unbound_variable_error_nr(sc, car(sc->code)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %s\n", __func__, __LINE__, display_truncated(func), display_truncated(sc->code)); + if (num_args == 0) return(fixup_unknown_op(sc, code, func, OP_S)); /* via op_closure*-fx where original had 0 args, safe case -> op_safe_closure*_0 */ + + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, num_args)) break; + case T_C_RST_NO_REQ_FUNCTION: + if (is_safe_procedure(func)) + { + 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)) + { + const s7_pointer arg = car(p); + if (is_normal_happy_symbol(sc, arg)) + symbols++; + else + if (is_pair(arg)) + { + pairs++; + if (is_proper_quote(sc, arg)) + quotes++; + }} + if (optimize_safe_c_func_three_args(sc, code, func, 0 /* hop */, pairs, symbols, quotes, sc->curlet) == opt_ok) + 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(func)) ? OP_CL_NA : OP_C_NA); + fx_annotate_args(sc, cdr(code), sc->curlet); + set_class_and_fn_proc(code, func); + return(true); + + case T_CLOSURE: + if ((!has_methods(func)) && + (closure_arity_to_int(sc, func) == num_args)) + { + const 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(func)) + { + 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, func); + return(true); + } + if (is_symbol(closure_pars(func))) + { + optimize_closure_sym(sc, code, func, 0, num_args, sc->curlet); + if (optimize_op(code) == OP_ANY_CLOSURE_SYM) return(true); + } + break; + + case T_CLOSURE_STAR: + if ((!has_methods(func)) && + ((closure_star_arity_to_int(sc, func) < 0) || ((closure_star_arity_to_int(sc, func) * 2) >= num_args))) + { + const 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(func)) + switch (num_args) + { + case 0: return(fixup_unknown_op(sc, code, func, hop + OP_SAFE_CLOSURE_STAR_NA_0)); + case 1: return(fixup_unknown_op(sc, code, func, hop + OP_SAFE_CLOSURE_STAR_NA_1)); + case 2: return(fixup_unknown_op(sc, code, func, hop + OP_SAFE_CLOSURE_STAR_NA_2)); + case 3: if (closure_star_arity_to_int(sc, func) == 3) return(fixup_unknown_op(sc, code, func, OP_SAFE_CLOSURE_STAR_3A)); + default: return(fixup_unknown_op(sc, code, func, hop + OP_SAFE_CLOSURE_STAR_NA)); + } + return(fixup_unknown_op(sc, code, func, hop + OP_CLOSURE_STAR_NA)); + } + break; + + case T_BACRO: case T_MACRO: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); + /* 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) +{ + const s7_pointer code = sc->code, func = sc->last_function, head = car(sc->code); + const int32_t num_args = (is_pair(cdr(code))) ? opt3_arglen(cdr(code)) : 0; + + if (!func) unbound_variable_error_nr(sc, head); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s %s %s\n", + __func__, __LINE__, display_truncated(func), type_name(sc, func, no_article), display_truncated(sc->code)); + switch (type(func)) + { + case T_C_FUNCTION: + if (!c_function_is_aritable(func, num_args)) break; + case T_C_RST_NO_REQ_FUNCTION: + if (num_args == 1) + set_any_c_np(sc, func, code, sc->curlet, num_args, (is_safe_procedure(func)) ? OP_SAFE_C_P : OP_C_P); + else + if ((num_args == 2) && (is_safe_procedure(func))) + { + set_any_c_np(sc, func, code, sc->curlet, 2, OP_SAFE_C_PP); + opt_sp_1(sc, c_function_call(func), code); + } + else + if ((num_args == 3) && + ((is_safe_procedure(func)) || + ((is_semisafe(func)) && + (((head != sc->assoc_symbol) && (head != sc->member_symbol)) || + (unsafe_is_safe(sc, cadddr(code), sc->curlet)))))) + set_any_c_np(sc, func, code, sc->curlet, 3, OP_SAFE_C_3P); + else set_any_c_np(sc, func, code, sc->curlet, num_args, OP_ANY_C_NP); + return(true); + + case T_CLOSURE: + if ((!has_methods(func)) && + (closure_arity_to_int(sc, func) == num_args)) /* if values clo as arg, we need to know how many values etc */ + { + const int32_t hop = (is_immutable_and_stable(sc, head)) ? 1 : 0; + const bool safe_case = is_safe_closure(func); + switch (num_args) + { + case 1: + if (safe_case) + { + const s7_pointer body = closure_body(func); + 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, func); /* 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 + ((safe_case) ? 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 + ((safe_case) ? OP_SAFE_CLOSURE_PA : OP_CLOSURE_PA)); + } + else set_optimize_op(code, hop + ((safe_case) ? OP_SAFE_CLOSURE_PP : OP_CLOSURE_PP)); + set_opt1_lambda_add(code, func); /* 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, func, code, sc->curlet, 3, hop + OP_ANY_CLOSURE_3P); break; + case 4: set_any_closure_np(sc, func, code, sc->curlet, 4, hop + OP_ANY_CLOSURE_4P); break; + default: set_any_closure_np(sc, func, code, sc->curlet, num_args, hop + OP_ANY_CLOSURE_NP); break; + } + return(true); + } + break; + + /* PERHAPS: T_CLOSURE_STAR? */ + case T_BACRO: case T_MACRO: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_D, func))); + case T_BACRO_STAR: case T_MACRO_STAR: return(fixup_unknown_op(sc, code, func, fixup_macro_d(sc, OP_MACRO_STAR_D, func))); + } + return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); +} + +static bool unknown_any(s7_scheme *sc, s7_pointer func, s7_pointer code) +{ + sc->last_function = func; + 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) +{ + const s7_pointer clo = lookup_unexamined(sc, car(code)); + if ((clo == opt1_lambda_unchecked(code)) || + ((clo) && /* this fixup check does save time (e.g. cb) */ + (low_type_bits(clo) == type) && + ((closure_arity(clo) == args) || (closure_arity_to_int(sc, clo) == args)) && /* 3 type bits to replace this but not hit enough to warrant them */ + (set_opt1_lambda(code, clo)))) + return(true); + sc->last_function = clo; + return(false); +} + +static /* inline */ bool closure_is_fine_1(s7_scheme *sc, s7_pointer code, uint16_t type, int32_t args) +{ + const s7_pointer clo = lookup_unexamined(sc, car(code)); + if ((clo == opt1_lambda_unchecked(code)) || + ((clo) && + ((low_type_bits(clo) & (TYPE_MASK | T_SAFE_CLOSURE)) == type) && + ((closure_arity(clo) == args) || (closure_arity_to_int(sc, clo) == args)) && + (set_opt1_lambda(code, clo)))) + return(true); + sc->last_function = clo; + return(false); +} + +static bool closure_np_is_ok_1(s7_scheme *sc, s7_pointer code) +{ + const s7_pointer clo = lookup_unexamined(sc, car(code)); + if ((clo == opt1_lambda_unchecked(code)) || + ((clo) && + (is_closure(clo)) && + (set_opt1_lambda(code, clo)))) + return(true); + sc->last_function = clo; + return(false); +} + +/* 20-Jun-24 calls=closure_is_*, misses=symbol_ctr != 1 + s7test: calls: 974814, misses: 550785 + full: calls: 11433106, misses: 6406461 + tlet: calls: 3600032, misses: 1900012 + tlamb: calls: 33000005, misses: 11999999 + tset: calls: 1329500, misses: 998 + lt: calls: 1374000, misses: 232936 + tmat: calls: 222206, misses: 0 (tobj, tsort, tform, tread, tfft, thash, etc) + so symbol_ctr==1 is valuable + */ + +#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) +{ + const 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 no_return 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_cadr(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_cadr(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_cadr(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_caddr(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_cadr(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_caddr(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: op_safe_c_ap(sc); goto EVAL; /* currently op_safe_c_ap always returns true */ + + case OP_SAFE_C_PA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_SAFE_C_PA: op_safe_c_pa(sc); goto EVAL; /* op_safe_c_pa always returns true */ + 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 + two 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_SC: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_SC: op_c_sc(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_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_3a(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; + + + /* these nine are ok */ + case OP_TC_CASE_LA: if (op_tc_case_la(sc, sc->code, 1)) continue; goto BEGIN; + case OP_TC_CASE_L2A: if (op_tc_case_la(sc, sc->code, 2)) continue; goto BEGIN; + case OP_TC_CASE_L3A: if (op_tc_case_la(sc, sc->code, 3)) continue; goto BEGIN; + case OP_TC_WHEN_LA: sc->value = op_tc_when_la(sc, sc->code); continue; + case OP_TC_WHEN_L2A: sc->value = op_tc_when_l2a(sc, sc->code); continue; + case OP_TC_WHEN_L3A: sc->value = op_tc_when_l3a(sc, sc->code); continue; + case OP_TC_IF_A_Z_LA: if (op_tc_if_a_z_la(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_L2A: if (op_tc_if_a_z_l2a(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_L3A: if (op_tc_if_a_z_l3a(sc, sc->code)) continue; goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_LA: if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_LA_Z: if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false)) continue; goto EVAL; + case OP_TC_AND_A_IF_A_LA_Z: if (op_tc_if_a_z_if_a_z_la(sc, sc->code, false)) continue; goto EVAL; + case OP_TC_AND_A_IF_A_Z_LA: if (op_tc_if_a_z_if_a_z_la(sc, sc->code, true)) continue; goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_L2A: if (op_tc_if_a_z_if_a_z_l2a(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_L2A_Z: if (op_tc_if_a_z_if_a_l2a_z(sc, sc->code)) continue; goto EVAL; + + case OP_TC_IF_A_Z_IF_A_Z_L3A: if (op_tc_if_a_z_if_a_z_l3a(sc, sc->code, true)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_L3A_Z: if (op_tc_if_a_z_if_a_z_l3a(sc, sc->code, false)) continue; goto EVAL; + + case OP_TC_AND_A_OR_A_LA: sc->value = op_tc_and_a_or_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_LA: sc->value = op_tc_or_a_and_a_la(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_L2A: sc->value = op_tc_and_a_or_a_l2a(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_L2A: sc->value = op_tc_or_a_and_a_l2a(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_L3A: sc->value = op_tc_and_a_or_a_l3a(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_L3A: sc->value = op_tc_or_a_and_a_l3a(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_A_LA: sc->value = op_tc_or_a_and_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_AND_A_A_L3A: sc->value = op_tc_or_a_and_a_a_l3a(sc, sc->code); continue; + case OP_TC_AND_A_OR_A_A_LA: sc->value = op_tc_and_a_or_a_a_la(sc, sc->code); continue; + case OP_TC_OR_A_A_AND_A_A_LA: sc->value = op_tc_or_a_a_and_a_a_la(sc, sc->code); continue; + + case OP_TC_LET_IF_A_Z_LA: if (op_tc_let_if_a_z_la(sc, sc->code)) continue; goto EVAL; + case OP_TC_LET_IF_A_Z_L2A: if (op_tc_let_if_a_z_l2a(sc, sc->code)) continue; goto EVAL; + case OP_TC_LET_WHEN_L2A: sc->value = op_tc_let_when_l2a(sc, sc->code); continue; + + case OP_TC_COND_A_Z_A_L2A_L2A: if (op_tc_cond_a_z_a_l2a_l2a(sc, sc->code)) continue; goto EVAL; + case OP_TC_IF_A_Z_IF_A_L3A_L3A: 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_L2A: if (op_tc_if_a_z_let_if_a_z_l2a(sc, sc->code)) continue; goto EVAL; + case OP_TC_LET_COND: if (op_tc_let_cond(sc, sc->code)) continue; goto EVAL; + case OP_TC_COND_N: if (op_tc_cond_n(sc, sc->code)) continue; goto EVAL; + + + /* these six are ok */ + case OP_RECUR_IF_A_A_opLA_LAq: sc->value = op_recur_if_a_a_opla_laq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_opL2A_L2Aq: sc->value = op_recur_if_a_a_opl2a_l2aq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_opL3A_L3Aq: sc->value = op_recur_if_a_a_opl3a_l3aq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_opA_LAq: sc->value = op_recur_if_a_a_opa_laq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_opA_L2Aq: sc->value = op_recur_if_a_a_opa_l2aq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_opA_L3Aq: sc->value = op_recur_if_a_a_opa_l3aq(sc, sc->code); continue; + + /* these 3 need 2 true_quit cases */ + case OP_RECUR_IF_A_A_IF_A_A_opLA_LAq: sc->value = op_recur_if_a_a_if_a_a_opla_laq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq: sc->value = op_recur_if_a_a_if_a_a_opl2a_l2aq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq: sc->value = op_recur_if_a_a_if_a_a_opl3a_l3aq(sc, sc->code); continue; + + case OP_RECUR_IF_A_A_opA_LA_LAq: sc->value = op_recur_if_a_a_opa_la_laq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_opLA_LA_LAq: sc->value = op_recur_if_a_a_opla_la_laq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq: sc->value = op_recur_if_a_a_if_a_l2a_opa_l2aq(sc, sc->code); continue; + case OP_RECUR_COND_A_A_A_A_opA_L2Aq: sc->value = op_recur_cond_a_a_a_a_opa_l2aq(sc, sc->code); continue; + case OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq: sc->value = op_recur_cond_a_a_a_l2a_lopa_l2aq(sc, sc->code); continue; + case OP_RECUR_IF_A_A_AND_A_L2A_L2A: sc->value = op_recur_if_a_a_and_a_l2a_l2a(sc, sc->code); continue; + case OP_RECUR_AND_A_OR_A_L2A_L2A: sc->value = op_recur_and_a_or_a_l2a_l2a(sc, sc->code); 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_STARLET_REF_S: sc->value = starlet(sc, opt3_int(sc->code)); continue; + case OP_IMPLICIT_STARLET_SET_S: sc->value = starlet_set_1(sc, opt3_sym(sc->code), fx_call(sc, cddr(sc->code))); continue; + + 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_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_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; /* 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: /* = 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: /* = 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; /* is a normal value */ + + case OP_EVAL_SET3_MV: /* = 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: /* = 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))) + { /* this can happen */ + 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))) + { + const s7_pointer head = car(sc->code); /* not a pair */ + sc->code = cdr(sc->code); + sc->value = (is_symbol(head)) ? lookup_checked(sc, head) : T_Ext(head); + /* 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))); + /* pulling out T_C_FUNCTION (to avoid the switch) does not gain anything in the timing tests */ + switch (type(sc->code)) + { + case T_C_FUNCTION: sc->value = apply_c_function(sc, sc->code, sc->args); continue; /* only call so it does get inlined */ + 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_COMPLEX_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 */ + /* goto EVAL_ARGS_TOP if the "macro" has changed typed in midstream -- normally we fall through */ + + 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; /* looping if need eval for init */ + + 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: + set_current_code(sc, car(sc->code)); /* better error message if unbound variable: (define (func) (let ((sig 0)) 0) (lcm sig)) (func) */ + 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_SS: op_increment_ss(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; + 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_eval_args_pair: goto EVAL_ARGS_PAIR; + 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_eval_args_pair: goto EVAL_ARGS_PAIR; + 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)); /* might need to check stack size here */ + 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: op_named_let_na(sc); goto BEGIN; + + 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_let_1(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; + /* it is slower here to check if has_fx and use fx_call */ + 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_OPENLETS: if (op_let_temp_s7_openlets(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_OPENLETS_UNWIND: op_let_temp_s7_openlets_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 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: if (!check_with_let(sc)) continue; + 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; + const s7_pointer port = current_input_port(sc); + c = port_read_white_space(port)(sc, port); + + READ_C: + switch (c) + { + case '(': + c = port_read_white_space(port)(sc, port); /* 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, port); break; + case '\'': sc->tok = token_quote; break; + case ';': sc->tok = port_read_semicolon(port)(sc, port); break; + case '"': sc->tok = token_double_quote; break; + case '`': sc->tok = token_back_quote; break; + case ',': sc->tok = read_comma(sc, port); break; + case '#': sc->tok = read_sharp(sc, port); 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, port, c); + goto READ_C; + } + if (sc->tok == token_atom) + { + c = read_atom(sc, port); + goto READ_C; + } + if (sc->tok == token_right_paren) + { + sc->value = sc->nil; + goto READ_LIST; + } + if (sc->tok == token_dot) + { + do {c = inchar(port);} 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, port); /* 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(port)(sc, port); + 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, port); /* 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, port); + break; + + case '\0': + case EOF: + missing_close_paren_error_nr(sc); + + default: + sc->strbuf[0] = (unsigned char)c; + sc->value = port_read_name(port)(sc, port); + 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; + case goto_start: + default: continue; + } + 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_COMPLEX_VECTOR: if (op_read_complex_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; + case OP_UNOPT: + goto UNOPT; + default: + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: eval unknown op: %d\n", __func__, __LINE__, (int)(sc->cur_op)); + return(sc->F); + } + + /* this code is reached from OP_CLEAR_OPTS and many others where the optimization has turned out to be incorrect, search for !c_function_is_ok -> break */ + if ((S7_DEBUGGING) && (tree_is_cyclic(sc, sc->code))) fprintf(stderr, "%s[%d]: cyclic %s\n", __func__, __LINE__, display(sc->code)); /* never hit? */ + clear_all_optimizations(sc, sc->code); + + UNOPT: + if (SHOW_EVAL_OPS) fprintf(stderr, " unopt trailers %s\n", display_truncated(sc->code)); + set_current_code(sc, sc->code); + if (is_pair(sc->code)) + { + const s7_pointer head = T_Ext(car(sc->code)); + if (is_symbol(head)) /* car is a symbol, sc->code a list */ + { + if (is_syntactic_symbol(head)) + { + sc->cur_op = (opcode_t)symbol_syntax_op_checked(sc->code); + pair_set_syntax_op(sc->code, sc->cur_op); + goto TOP_NO_POP; + } + sc->value = lookup_global(sc, head); + set_optimize_op(sc->code, OP_PAIR_SYM); /* mostly stuff outside functions (unopt) */ + goto EVAL_ARGS_TOP; + } + if (is_pair(head)) /* ((if x y z) a b) etc */ + { + if (eval_car_pair(sc)) goto TOP_NO_POP; + goto EVAL; + } + if (is_syntax(head)) /* here we can get syntax objects like quote */ + { + sc->cur_op = syntax_opcode(head); + pair_set_syntax_op(sc->code, sc->cur_op); + goto TOP_NO_POP; + } + /* car is the function/sequence to be applied, or (for example) a syntax variable like quote that has been used locally */ + set_optimize_op(sc->code, OP_PAIR_ANY); /* usually an error: (#\a) etc, might be (#(0) 0) */ + sc->value = head; + /* here head can be a c_function (#_list-values, #_curlet, etc), a vector constant (etc), a closure (etc)... */ + /* this code is rarely called, so no need to pick out these cases here */ + /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, s7_type_names[type(head)], display(sc->code)); */ + goto EVAL_ARGS_TOP; + } + if (is_normal_symbol(sc->code)) + { + sc->value = lookup_checked(sc, sc->code); + set_optimize_op(sc->code, OP_SYMBOL); + } + else + { + sc->value = sc->code; + set_optimize_op(sc->code, OP_CONSTANT); + }} /* continue */ + + return(sc->F); /* this never happens (make the compiler happy) */ +} + +static s7_pointer g_reader_cond(s7_scheme *sc, s7_pointer args) /* (reader-cond clause . clauses) */ +{ + #define H_reader_cond "(reader-cond clauses) is a read-time cond." + for (s7_pointer clauses = args; is_pair(clauses); clauses = cdr(clauses)) + { + const s7_pointer clause = car(clauses); + s7_pointer val; + if (!is_pair(clause)) + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "reader-cond: clause is not a pair, ~S", 37), clause)); + val = s7_eval(sc, car(clause), sc->rootlet); + if (val != sc->F) + { + if (is_null(cdr(clause))) + return(val); + if (cadr(clause) == sc->feed_to_symbol) + { + s7_pointer func = s7_eval(sc, caddr(clause), sc->rootlet); + return(s7_apply_function(sc, func, list_1(sc, val))); + } + if (is_null(cddr(clause))) + return(cadr(clause)); + return(g_apply_values(sc, list_1(sc, cdr(clause)))); + }} + return(sc->no_value); +} + +#if !WITH_PURE_S7 +static s7_pointer cond_expand_clause_to_tree(s7_scheme *sc, s7_pointer clause) +{ + if (is_symbol(clause)) + { + if ((clause == sc->or_symbol) || (clause == sc->and_symbol) || (clause == sc->not_symbol)) + return(clause); + return(make_boolean(sc, is_a_feature(clause, global_value(sc->features_symbol)))); + } + if (!is_pair(clause)) + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "cond-expand car(clause) entry is unexpected: ~S", 47), clause)); + return(cons(sc, cond_expand_clause_to_tree(sc, car(clause)), + (is_null(cdr(clause))) ? sc->nil : cond_expand_clause_to_tree(sc, cdr(clause)))); +} + +static s7_pointer g_cond_expand(s7_scheme *sc, s7_pointer args) /* (reader-cond clause . clauses) */ +{ + #define H_cond_expand "(cond-expand clauses) is a way to use cond with *features* without writing honest Scheme code." + if (!is_pair(args)) + error_nr(sc, sc->syntax_error_symbol, set_elist_1(sc, wrap_string(sc, "cond-expand has no clauses?", 27))); + for (s7_pointer clauses = args; is_pair(clauses); clauses = cdr(clauses)) + { + const s7_pointer clause = car(clauses); + if (!is_pair(clause)) + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "cond-expand clause is not a pair: ~S", 36), clause)); + if (((is_symbol(car(clause))) && + ((car(clause) == sc->else_symbol) || + (is_a_feature(car(clause), global_value(sc->features_symbol))))) || + ((is_pair(car(clause))) && + (s7_eval(sc, cond_expand_clause_to_tree(sc, car(clause)), sc->rootlet) == sc->T))) + { + if (is_null(cddr(clause))) + return(cadr(clause)); + return(g_apply_values(sc, list_1(sc, cdr(clause)))); + } + else + if ((!is_pair(car(clause))) && (!is_symbol(car(clause)))) + error_nr(sc, sc->syntax_error_symbol, set_elist_2(sc, wrap_string(sc, "cond-expand car(clause) is not a symbol or a pair: ~S", 53), clause)); + } + return(sc->no_value); +} +#endif + + +/* -------------------------------- 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 stack, s7_int top) +{ + if (stack_elements(stack)) + { + const s7_pointer heap0 = *(sc->heap); + const s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size); + for (s7_pointer *tp = (s7_pointer *)(stack_elements(stack)), *tend = (s7_pointer *)(tp + top); (tp < tend); tp++) + { + s7_pointer x = *tp++; + if ((x >= heap0) && (x < heap1)) mark_holdee(stack, x, "stack-code"); + x = *tp++; + if ((x >= heap0) && (x < heap1)) mark_holdee(stack, x, "stack-let"); + x = *tp++; + if ((x >= heap0) && (x < heap1)) mark_holdee(stack, x, "stack-args"); + }} +} + +static void mark_hash_table_holdees(s7_scheme *sc, s7_pointer table) +{ + mark_holdee(table, hash_table_procedures(table), NULL); + if (is_pair(hash_table_procedures(table))) + { + mark_holdee(table, hash_table_key_typer_unchecked(table), NULL); + mark_holdee(table, hash_table_value_typer_unchecked(table), NULL); + } + if (hash_table_entries(table) > 0) + { + const s7_int len = (s7_int)hash_table_size(table); + hash_entry_t **entries = hash_table_elements(table); + hash_entry_t **last = (hash_entry_t **)(entries + len); + if ((is_weak_hash_table(table)) && (weak_hash_iters(table) == 0)) + while (entries < last) + { + for (hash_entry_t *xp = *entries++; xp; xp = hash_entry_next(xp)) + mark_holdee(table, hash_entry_value(xp), NULL); + } + else + while (entries < last) + for (hash_entry_t *xp = *entries++; xp; xp = hash_entry_next(xp)) + { + mark_holdee(table, hash_entry_key(xp), NULL); + mark_holdee(table, hash_entry_value(xp), 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_OUTPUT_PORT: if (is_function_port(p)) 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_HASH_TABLE: mark_hash_table_holdees(sc, p); break; + + case T_ITERATOR: + mark_holdee(p, iterator_sequence(p), NULL); + if (has_carrier(p)) mark_holdee(p, iterator_carrier(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: case T_COMPLEX_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_pars(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_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->v, "sc->v"); + 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->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->temp_error_hook, "sc->temp_error_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++) + if (vector_element(sc->protected_objects, i) != sc->unused) + 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 p = T_Pair(gp->list[i]); + mark_holdee(NULL, opt1_any(p), "opt1_funcs"); + }} + for (int32_t i = 1; i < NUM_SAFE_LISTS; i++) + if ((is_pair(sc->safe_lists[i])) && + (safe_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 slot = sc->rootlet_slots; tis_slot(slot); slot = next_slot(slot)) mark_holdee(slot, slot_value(slot), symbol_name(slot_symbol(slot))); +#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++) + { + const 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) + const s7_pointer typ = car(args); + if (!s7_is_integer(typ)) + sole_arg_wrong_type_error_nr(sc, make_symbol(sc, "heap-scan", 9), typ, sc->type_names[T_INTEGER]); + if ((s7_integer(typ) <= 0) || (s7_integer(typ) >= NUM_TYPES)) + sole_arg_out_of_range_error_nr(sc, make_symbol(sc, "heap-scan", 9), typ, wrap_string(sc, "0 < type < 48", 13)); + s7_heap_scan(sc, (int32_t)s7_integer(typ)); /* 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 obj = car(args); + if ((obj->holders == 0) || ((!(obj->holder)) && (!(obj->root)))) return(sc->F); + return((obj->holder) ? obj->holder : s7_make_string(sc, obj->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 20)))" + #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->max_show_stack_frames; + sc->max_show_stack_frames = s7_integer(car(args)); + s7_show_stack(sc); + sc->max_show_stack_frames = 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) +{ + if (sc->op_stack < sc->op_stack_now) + { + 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)); + } + else fprintf(stderr, "op_stack is empty\n"); +} + +static s7_pointer g_show_op_stack(s7_scheme *sc, s7_pointer args) +{ + #define H_show_op_stack "(show-op-stack) displays the current op_stack" + #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 "(op-stack?) returns #t if there are entries in the op_stack" + #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 s7_int starlet_length(void) {return(sl_num_fields - 1);} + +static s7_pointer g_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]); + if (starlet_symbol_id(sym) == sl_no_field) + 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(starlet_set_1(sc, sym, caddr(args))); +} + +static s7_pointer g_starlet_ref_fallback(s7_scheme *sc, s7_pointer args); + +static s7_pointer make_starlet(s7_scheme *sc) /* *s7* is semipermanent -- 20-May-21 */ +{ + const s7_pointer slot1 = make_semipermanent_slot(sc, sc->let_set_fallback_symbol, s7_make_function(sc, "#<*s7*-set>", g_starlet_set_fallback, 3, 0, false, "*s7* writer")); + const s7_pointer slot2 = make_semipermanent_slot(sc, sc->let_ref_fallback_symbol, s7_make_function(sc, "#<*s7*-ref>", g_starlet_ref_fallback, 2, 0, false, "*s7* reader")); + const s7_pointer star = alloc_pointer(sc); + set_full_type(star, T_LET | T_SAFE_PROCEDURE | T_UNHEAP | T_HAS_METHODS | T_HAS_LET_REF_FALLBACK | T_HAS_LET_SET_FALLBACK); + let_set_id(star, ++sc->let_number); + let_set_outlet(star, 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(star, slot2); + set_immutable_slot(slot1); /* make the *s7* let-ref|set! fallbacks immutable */ + set_immutable_slot(slot2); + set_immutable_let(star); + sc->starlet_symbol = s7_define_constant(sc, "*s7*", s7_openlet(sc, star)); /* define_constant returns the symbol */ + if ((S7_DEBUGGING) && (sl_num_fields >= 256)) fprintf(stderr, "too many *s7* fields!\n"); + for (int32_t i = 1; i < (int32_t)sl_num_fields; i++) + { + s7_pointer sym = make_symbol_with_strlen(sc, starlet_names[i]); + starlet_symbol_set_id(sym, (starlet_t)i); + } + return(star); +} + +static void add_symbol_table(s7_scheme *sc, s7_pointer mu_let) +{ + /* check the symbol table, counting gensyms etc */ + s7_int num_syms = 0, gens = 0, keys = 0, mx_list = 0, mxs = 0; + s7_pointer *els = vector_elements(sc->symbol_table); + for (s7_int i = 0; i < SYMBOL_TABLE_SIZE; i++) + { + s7_int k = 0; + for (s7_pointer syms = els[i]; is_pair(syms); syms = cdr(syms), k++) + { + num_syms++; + if (is_gensym(car(syms))) gens++; + if (is_keyword(car(syms))) keys++; + } + if (k > mx_list) {mx_list = k; mxs = 1;} + else if (k == mx_list) mxs++; + } + 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), cons(sc, make_integer(sc, mx_list), make_integer(sc, mxs)), + make_symbol(sc, "symbols", 7), cons(sc, make_integer(sc, num_syms), make_integer(sc, num_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; + 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-hook et el */ + const 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; + + const 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 +#endif + +static s7_pointer memory_usage(s7_scheme *sc) +{ + s7_int 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 + + const s7_pointer mu_let = s7_inlet(sc, sc->nil); + const s7_int gc_loc = gc_protect_1(sc, mu_let); + + check_free_heap_size(sc, 2048); + +#if !_WIN32 /* (!MS_WINDOWS) */ + getrusage(RUSAGE_SELF, &info); +#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 + 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))); + 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, "elapsed-time", 12), make_real(sc, (double)(my_clock() - sc->overall_start_time) / ticks_per_second())); + 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_true_total_time) / ticks_per_second())); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "gc-calls", 8), make_integer(sc, sc->gc_true_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_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)))); + { + s7_int 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)); + } + { + s7_int 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, lines_in_use = 0, line_used = 0; + for (s7_int i = 1; i < NUM_SAFE_LISTS; i++) + if (is_pair(sc->safe_lists[i])) + { + live++; + if (safe_list_is_in_use(sc->safe_lists[i])) {lines_in_use++; line_used = i;} + } +#if S7_DEBUGGING + begin_temp(sc->y, sc->nil); + for (s7_int i = NUM_SAFE_LISTS - 1; i > 0; i--) /* omit safe_lists[0]=() since it is never used */ + sc->y = cons(sc, make_integer(sc, sc->safe_list_uses[i]), sc->y); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "safe-lists", 10), + (lines_in_use == 0) ? list_3(sc, small_int(live), int_zero, sc->y) : + list_4(sc, small_int(live), small_int(lines_in_use), small_int(line_used), sc->y)); + end_temp(sc->y); +#else + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "safe-lists", 10), + (lines_in_use == 0) ? list_2(sc, small_int(live), int_zero) : + list_3(sc, small_int(live), small_int(lines_in_use), small_int(line_used))); +#endif + } + /* show how many active cells there are of each type (this is where all the memory_usage cpu time goes) */ + if ((S7_DEBUGGING) && (sc->heap_size > sc->max_heap_size)) + fprintf(stderr, "%s[%d]: heap_size: %" ld64 ", max: %" ld64 "\n", __func__, __LINE__, sc->heap_size, sc->max_heap_size); + for (s7_int i = 0; i < NUM_TYPES; i++) ts[i] = 0; + for (s7_int k = 0; k < sc->heap_size; k++) + ts[unchecked_type(sc->heap[k])]++; + begin_temp(sc->y, sc->nil); + for (s7_int 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); + const s7_int tlen = 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, tlen); + name[tlen] = (uint8_t)'\0'; + name[0] = (uint8_t)toupper((int)name[0]); + sc->y = cons_unchecked(sc, make_integer(sc, ts[i]), cons(sc, make_symbol(sc, (const char *)name, tlen), sc->y)); + }} + if (is_pair(sc->y)) + 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->y))); + end_temp(sc->y); + /* 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 - 2 - sc->protected_objects_free_list_loc), + /* -1 to make size and loc commensurable, another -1 because we're using an element in this function (see gc_loc above) */ + 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)); + if (S7_DEBUGGING) add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "classes", 7), make_integer(sc, (s7_int)(sc->f_class))); + + 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 (s7_int 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; + len = 0; + for (s7_int 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, clen = 0, cvs = 0, ilen = 0, ivs = 0, blen = 0, bvs = 0; + gp = sc->vectors; + for (s7_int k = 0; k < 2; k++, gp = sc->multivectors) + for (s7_int i = 0; i < gp->loc; i++) + { + const s7_pointer vec = gp->list[i]; + if (is_float_vector(vec)) + {fvs++; flen += vector_length(vec);} + else + if (is_int_vector(vec)) + {ivs++; ilen += vector_length(vec);} + else + if (is_complex_vector(vec)) + {cvs++; clen += vector_length(vec);} + else + if (is_byte_vector(vec)) + {bvs++; blen += vector_length(vec);} + else {vs++; vlen += vector_length(vec);} + } + 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, 12, + 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, "complex", 7), cons(sc, make_integer(sc, cvs), make_integer(sc, clen)), + make_symbol(sc, "byte", 4), cons(sc, make_integer(sc, bvs), make_integer(sc, blen))))); + } + /* hash-tables */ + { + s7_int hlen = 0; + gp = sc->hash_tables; + for (s7_int i = 0; i < gp->loc; i++) + { + const s7_pointer table = gp->list[i]; + hlen += ((hash_table_size(table)) * sizeof(hash_entry_t *)); + hlen += (hash_table_entries(table) * sizeof(hash_entry_t)); + } + all_len += hlen; /* was adding all_len?? 11-Apr-25 */ + 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; + len = 0; + for (s7_int i = 0; i < gp->loc; i++) + { + s7_pointer port = gp->list[i]; + if (port_data(port)) len += port_data_size(port); + } + 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; + len = 0; + for (s7_int i = 0; i < gp->loc; i++) + { + s7_pointer port = gp->list[i]; + if (port_data(port)) len += port_data_size(port); + } + 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))); + + { + int32_t files = 0, strings = 0, closed_strings = 0, functions = 0, unknowns = 0; + gp = sc->output_ports; + len = 0; + for (s7_int i = 0; i < gp->loc; i++) + { + const s7_pointer port = gp->list[i]; + if (port_data(port)) len += port_data_size(port); + if (is_string_port(port)) + { + strings++; + if (port_is_closed(port)) closed_strings++; + } + else if (is_file_port(port)) files++; else if (is_function_port(port)) functions++; else unknowns++; + } + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "output-ports", 12), + list_3(sc, cons(sc, make_integer(sc, sc->output_ports->loc), make_integer(sc, len)), + make_symbol(sc, "string/file/func/?", 18), + list_4(sc, cons(sc, make_integer(sc, strings), make_integer(sc, closed_strings)), + make_integer(sc, files), make_integer(sc, functions), make_integer(sc, unknowns)))); + } + +#if S7_DEBUGGING + { + s7_int i = 0; + for (s7_pointer ports = sc->format_ports; ports; i++, ports = (s7_pointer)port_next(ports)); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "format-ports-allocated/free/inuse", 33), + list_3(sc, make_integer(sc, sc->format_ports_allocated), make_integer(sc, i), make_integer(sc, sc->format_ports_allocated - i))); + for (i = 0, len = 0; i < sc->file_names_top; i++) len += string_length(sc->file_names[i]); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "file-names", 10), + cons(sc, make_integer(sc, sc->file_names_top), make_integer(sc, len))); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "c-functions", 11), + cons(sc, make_integer(sc, sc->c_functions_allocated), make_integer(sc, sc->c_functions_allocated * (sizeof(c_proc_t) + sizeof(s7_cell))))); + } +#endif + + /* continuations (sketchy!) */ + gp = sc->continuations; + len = 0; + for (s7_int i = 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) */ + { + s7_int k; +#if S7_DEBUGGING + s7_int num_blocks = 0; + s7_pointer ff, frees = make_big_list(sc, NUM_BLOCK_LISTS, sc->nil); + s7_pointer fa, allocs = make_big_list(sc, NUM_BLOCK_LISTS, sc->nil); + s7_pointer fb, borrows = make_big_list(sc, NUM_BLOCK_LISTS, sc->nil); + ff = frees; + fa = allocs; + fb = borrows; +#endif + begin_temp(sc->y, sc->nil); + len = 0; + for (s7_int i = 0; i < TOP_BLOCK_LIST; i++) + { + k = 0; + for (block_t *b = sc->block_lists[i]; b; b = block_next(b), k++); /* these are the free blocks awaiting mallocate */ + sc->y = cons(sc, make_integer(sc, k), sc->y); + len += ((sizeof(block_t) + (1LL << i)) * k); +#if S7_DEBUGGING + num_blocks += k; + set_car(ff, make_integer(sc, sc->blocks_freed[i])); ff = cdr(ff); + set_car(fa, make_integer(sc, sc->blocks_mallocated[i])); fa = cdr(fa); + set_car(fb, make_integer(sc, sc->blocks_borrowed[i])); fb = cdr(fb); +#endif + } + k = 0; + for (block_t *b = sc->block_lists[TOP_BLOCK_LIST]; b; b = block_next(b), k++) + len += (sizeof(block_t) + block_size(b)); + sc->y = cons(sc, make_integer(sc, k), sc->y); + sc->y = proper_list_reverse_in_place(sc, sc->y); +#if S7_DEBUGGING + num_blocks += k; + set_car(ff, make_integer(sc, sc->blocks_freed[TOP_BLOCK_LIST])); + set_car(fa, make_integer(sc, sc->blocks_mallocated[TOP_BLOCK_LIST])); + set_car(fb, make_integer(sc, sc->blocks_borrowed[TOP_BLOCK_LIST])); + add_slot_unchecked_with_id(sc, mu_let, + make_symbol(sc, "blocks-allocated/available/in-use", 33), + list_3(sc, make_integer(sc, sc->blocks_allocated), make_integer(sc, num_blocks), make_integer(sc, sc->blocks_allocated - num_blocks))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "free-lists", 10), + s7_inlet(sc, cons(sc, cons(sc, make_symbol(sc, "bytes", 5), kmg(sc, len)), + list_4(sc, cons(sc, make_symbol(sc, "bins", 4), sc->y), + cons(sc, make_symbol(sc, "allocs", 6), allocs), + cons(sc, make_symbol(sc, "frees", 5), frees), + cons(sc, make_symbol(sc, "borrows", 7), borrows))))); + add_slot_unchecked_with_id(sc, mu_let, make_symbol(sc, "wrapper-uses", 12), + s7_inlet(sc, s7_list(sc, 7, + cons(sc, make_symbol(sc, "strings", 7), make_integer(sc, sc->string_wrapper_allocs)), + cons(sc, make_symbol(sc, "integers", 8), make_integer(sc, sc->integer_wrapper_allocs)), + cons(sc, make_symbol(sc, "reals", 5), make_integer(sc, sc->real_wrapper_allocs)), + cons(sc, make_symbol(sc, "complexes", 9), make_integer(sc, sc->complex_wrapper_allocs)), + cons(sc, make_symbol(sc, "lets", 4), make_integer(sc, sc->let_wrapper_allocs)), + cons(sc, make_symbol(sc, "slots", 5), make_integer(sc, sc->slot_wrapper_allocs)), + cons(sc, make_symbol(sc, "c-pointers", 10), make_integer(sc, sc->c_pointer_wrapper_allocs))))); +#else + 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), sc->y)))); +#endif + end_temp(sc->y); + 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_to_list(s7_scheme *sc) +{ + begin_temp(sc->y, sc->nil); + for (int32_t i = 0; i < sc->num_c_object_types; i++) /* c-object type (tag) is i */ + sc->y = cons(sc, sc->c_object_types[i]->scheme_name, sc->y); + sc->y = proper_list_reverse_in_place(sc, sc->y); /* so car(types) has tag 0 */ + return_with_end_temp(sc->y); +} + +static s7_pointer sl_file_names_to_list(s7_scheme *sc) +{ + begin_temp(sc->y, sc->nil); + for (int32_t i = 0; i <= sc->file_names_top; i++) + sc->y = cons(sc, sc->file_names[i], sc->y); + sc->y = proper_list_reverse_in_place(sc, sc->y); + return_with_end_temp(sc->y); +} + +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_to_list(s7_scheme *sc) +{ +#if WITH_HISTORY + return(sanitize_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_to_list(s7_scheme *sc) +{ + s7_pointer lst = sc->nil; + for (s7_int op_loc = stack_top(sc) - 1; op_loc >= 3; op_loc -= 4) + switch (stack_op(sc->stack, op_loc)) + { + 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, op_loc)), lst); + break; + } + return(reverse_in_place_unchecked(sc, sc->nil, lst)); +} + +static s7_pointer sl_stack_entries_to_list(s7_scheme *sc, s7_pointer stack, s7_int top) +{ + s7_pointer lst = sc->nil; /* the stack can contain anything (like #): this is a dangerous function */ + begin_temp(sc->y, sc->nil); + for (s7_int i = top - 1; i >= 3; i -= 4) + { + const s7_pointer func = stack_code(stack, i), args = stack_args(stack, i), e = stack_let(stack, i); + const 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->y = lst; + } + end_temp(sc->y); + return(reverse_in_place_unchecked(sc, sc->nil, lst)); +} + +static s7_pointer sl_gc_protected_objects_to_list(s7_scheme *sc) +{ + const s7_pointer nv = s7_vector_copy(sc, sc->protected_objects); + s7_pointer *vals = vector_elements(nv); + const 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 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_to_list(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_to_list(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_to_list(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_gc_protected_objects_to_list(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_hash_table_missing_key_value: return(missing_key_value(sc)); + case sl_heap_size: return(make_integer(sc, sc->heap_size)); + case sl_history: return(sl_history_to_list(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_iterator_at_end_value: return(sc->iterator_at_end_value); + 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_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_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_string_port_length: return(make_integer(sc, sc->max_string_port_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_length: return(make_integer(sc, sc->output_file_port_length)); + 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_to_list(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_symbol_quote: return(make_boolean(sc, sc->symbol_quote)); + case sl_symbol_printer: return(sc->symbol_printer); + 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 (starlet_symbol_id(sym) != sl_no_field) + return(starlet(sc, starlet_symbol_id(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_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(starlet(sc, starlet_symbol_id(sym))); +} + +static s7_pointer 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(sc, iterator)); + symbol = make_symbol_with_strlen(sc, 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 + { + const s7_pointer osw = sc->w; /* protect against starlet list making [sc->w not in use here?] */ + value = starlet(sc, starlet_symbol_id(symbol)); + if ((S7_DEBUGGING) && (osw != sc->w)) fprintf(stderr, "s7.c[%d]: osw: %s, sc->w: %s, symbol_id: %d %s\n", + __LINE__, display(osw), display(sc->w), starlet_symbol_id(symbol), display(symbol)); + sc->w = osw; + } + if (iterator_carrier(iterator)) + { + const s7_pointer p = iterator_carrier(iterator); + set_car(p, symbol); + set_cdr(p, value); + return(p); + } + return(cons(sc, symbol, value)); +} + +static s7_pointer starlet_make_iterator(s7_scheme *sc, s7_pointer iter) +{ + iterator_position(iter) = sl_no_field; + iterator_next(iter) = starlet_iterate; + iterator_carrier(iter) = NULL; + return(iter); +} + +static no_return void 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 no_return void 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_double sl_real_geq_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + s7_double fv; + if (!is_real(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_REAL]); + fv = s7_real(val); + if (is_NaN(fv)) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be nan?", 16)); + if (fv < 0.0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be negative", 25)); + return(fv); +} + +static s7_double sl_real_0_to_1(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + s7_double fv; + if (!is_real(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_REAL]); + fv = s7_real(val); + if (is_NaN(fv)) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be nan?", 16)); + if (fv <= 0.0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be greater than 0.0", 29)); + if (fv > 1.0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be greater than 1.0", 33)); + return(fv); +} + +static s7_pointer sl_integer_gt_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!s7_is_integer(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); + if (s7_integer_clamped_if_gmp(sc, val) <= 0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should be greater than 0.0", 29)); + return(val); +} + +static s7_pointer sl_integer_geq_0(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!s7_is_integer(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_INTEGER]); + if (s7_integer_clamped_if_gmp(sc, val) < 0) starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it should not be negative", 25)); + return(val); +} + +static s7_pointer sl_set_history_size(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ +#if WITH_HISTORY + s7_pointer p1, p2; + s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); /* was geq?!? */ + if (iv > MAX_HISTORY_SIZE) iv = MAX_HISTORY_SIZE; /* if 1M, tests can be slow -- assume user wants one such test */ + if (iv > sc->true_history_size) + { + /* splice in the new cells, reattach the circles */ + s7_pointer p3; + const s7_pointer next1 = cdr(sc->eval_history1); + const s7_pointer next2 = cdr(sc->eval_history2); + const s7_pointer next3 = cdr(sc->history_pairs); + unchecked_set_cdr(sc->eval_history1, semipermanent_list(sc, iv - sc->true_history_size)); + unchecked_set_cdr(sc->eval_history2, semipermanent_list(sc, iv - sc->true_history_size)); + unchecked_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)); + unchecked_set_cdr(p3, next3); + for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2)); + unchecked_set_cdr(p1, next1); + unchecked_set_cdr(p2, next2); + sc->true_history_size = iv; + } + sc->history_size = iv; + /* clear out both buffers to avoid GC confusion */ + for (s7_pointer p11 = sc->eval_history1, p22 = sc->eval_history2; ; p22 = cdr(p22)) + { + set_car(p11, sc->nil); + set_car(p22, sc->nil); + p11 = cdr(p11); + if (p11 == sc->eval_history1) break; + } +#else + sc->history_size = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); +#endif + return(val); +} + +#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 no_return void sl_stacktrace_wrong_type_error_nr(s7_scheme *sc, s7_int num, s7_pointer arg, s7_pointer typ, s7_pointer val) +{ + set_elist_6(sc, wrap_string(sc, "(set! (*s7* 'stacktrace-defaults) '~S): the ~:D list element ~S is ~A but should be ~A", 86), + val, wrap_integer(sc, num), arg, object_type_name(sc, arg), typ); + error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_6); +} + +static no_return void sl_stacktrace_out_of_range_error_nr(s7_scheme *sc, s7_pointer accessor, s7_pointer lst, s7_pointer arg, s7_pointer descr) +{ + error_nr(sc, sc->out_of_range_symbol, + set_elist_5(sc, wrap_string(sc, "(set! (*s7* 'stacktrace-defaults) '~S): ~S => ~S is out of range (~A)", 69), lst, accessor, arg, descr)); +} + +static s7_pointer sl_set_stacktrace_defaults(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + s7_int code_cols; + if (!is_pair(val)) + starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_PAIR]); + if (s7_list_length(sc, val) != 5) + starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a list with 5 entries", 21)); + + if (!s7_is_integer(car(val))) /* max_frames, default 30 */ + sl_stacktrace_wrong_type_error_nr(sc, 1, car(val), wrap_string(sc, "an integer (max stack frames)", 29), val); + { + s7_int i = s7_integer_clamped_if_gmp(sc, car(val)); + if ((i <= 0) || (i > S7_INT32_MAX)) /* keep these in sync with g_stacktrace */ + sl_stacktrace_out_of_range_error_nr(sc, sc->car_symbol, val, car(val), wrap_string(sc, "should be 0 < max-frames <= 2^32", 32)); + } + if (!s7_is_integer(cadr(val))) /* code_cols, default 45 */ + sl_stacktrace_wrong_type_error_nr(sc, 2, cadr(val), wrap_string(sc, "an integer (code columns)", 25), val); + code_cols = s7_integer_clamped_if_gmp(sc, cadr(val)); + if ((code_cols <= 8) || (code_cols > 1024)) + sl_stacktrace_out_of_range_error_nr(sc, sc->cadr_symbol, val, cadr(val), wrap_string(sc, "should be 8 < code-columns <= 1024", 34)); + + if (!s7_is_integer(caddr(val))) /* total_cols, default 80 */ + sl_stacktrace_wrong_type_error_nr(sc, 3, caddr(val), wrap_string(sc, "an integer (total columns)", 26), val); + { + s7_int i = s7_integer_clamped_if_gmp(sc, caddr(val)); + if ((i <= code_cols) || (i > S7_INT32_MAX)) + { + int bytes = snprintf(sc->strbuf, sc->strbuf_size, "should be %" ld64 " < total-columns <= 2^32", code_cols); + sl_stacktrace_out_of_range_error_nr(sc, sc->caddr_symbol, val, caddr(val), wrap_string(sc, sc->strbuf, bytes)); + }} + + if (!s7_is_integer(cadddr(val))) /* notes_start_col, default max(45, code_cols) */ + sl_stacktrace_wrong_type_error_nr(sc, 4, cadddr(val), wrap_string(sc, "an integer (comment position)", 29), val); + { + s7_int i = s7_integer_clamped_if_gmp(sc, cadddr(val)); + if ((i <= 0) || (i > S7_INT32_MAX)) + sl_stacktrace_out_of_range_error_nr(sc, sc->cadddr_symbol, val, cadddr(val), wrap_string(sc, "should be 0 < comment-position <= 2^32", 38)); + } + if (!is_boolean(s7_list_ref(sc, val, 4))) /* as_comment, default #f */ + sl_stacktrace_wrong_type_error_nr(sc, 5, s7_list_ref(sc, val, 4), wrap_string(sc, "a boolean (output-as-comment)", 29), 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)) + 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; + 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) /* for profile.scm?? seems like a bad idea! */ + { + 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 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)) + 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) +{ + sc->debug = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, 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 (!is_character(val)) + 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 */ + 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) +{ + sc->bignum_precision = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); +#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 s7_pointer sl_set_default_hash_table_length(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); /* protect against this being 9223372036854775807, then being used as a hash-table's size */ + if (iv > sc->max_vector_length) /* these range limits are from g_make_hash_table */ + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "(set! (*s7* 'default-hash-table-length) ~D), which is greater than (*s7* 'max-vector-length), ~D", 96), + val, wrap_integer(sc, sc->max_vector_length))); + if (iv >= (1LL << 32LL)) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "(set! (*s7* 'default-hash-table-length) ~D), which is >= ~D", 59), + val, wrap_integer(sc, 1LL << 32LL))); + sc->default_hash_table_length = iv; + return(val); +} + +static s7_pointer sl_set_symbol_printer(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (val != sc->F) + { + if (!is_any_closure(val)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_4(sc, wrap_string(sc, "(set! (*s7* '~A) ~S): new value is ~A but should be a function or #f", 68), + sym, val, object_type_name(sc, val))); + if (!s7_is_aritable(sc, val, 1)) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "(*s7* 'symbol-printer) function, ~A, should take one argument", 61), val)); + } + sc->symbol_printer = val; + return(val); +} + +static s7_pointer sl_set_symbol_quote(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->symbol_quote = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_heap_size(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); + if (iv < sc->heap_size) /* heap can't be made smaller currently */ + starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be less than the current heap size", 43)); + if (iv > sc->max_heap_size) + starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be greater than (*s7* 'max-heap-size)", 46)); + if (iv > sc->heap_size) + resize_heap_to(sc, iv); + return(val); +} + +static s7_pointer sl_set_max_heap_size(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); + if (iv < sc->heap_size) /* heap can't be made smaller currently */ + starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it can't be less than the current heap size", 43)); + else sc->max_heap_size = iv; /* else needed??? */ + return(val); +} + +static s7_pointer sl_set_initial_string_port_length(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); + if (iv > 1048576) /* just a guess, some joker might try setting this to (*s7* 'most-positive-fixnum)... */ + starlet_out_of_range_error_nr(sc, sym, val, wrap_string(sc, "it doesn't need to be this big", 30)); + sc->initial_string_port_length = iv; + return(val); +} + +static s7_pointer sl_set_max_string_port_length(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); + if (iv < sc->initial_string_port_length) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "(set! (*s7* 'max-string-port-length) ~S): new value should not be less than the initial string port length: ~D", 110), + val, wrap_integer(sc, sc->initial_string_port_length))); + sc->max_string_port_length = iv; + return(val); +} + +static s7_pointer sl_set_max_stack_size(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + const s7_int iv = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); + if (iv < INITIAL_STACK_SIZE) + error_nr(sc, sc->out_of_range_symbol, + set_elist_3(sc, wrap_string(sc, "(set! (*s7* 'max-stack-size) ~S): new value should not be less than the initial stack size: ~D", 94), + val, wrap_integer(sc, INITIAL_STACK_SIZE))); + sc->max_stack_size = (uint32_t)iv; + return(val); +} + +static s7_pointer sl_set_safety(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!s7_is_integer(val)) + 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)) + 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); +} + +static s7_pointer sl_set_default_random_state(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_random_state(val)) 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); +} + +static s7_pointer sl_set_float_format_precision(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + /* float-format-precision should not be huge => hangs in snprintf -- limit by bits in mantissa? */ + s7_int 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); +} + +static s7_pointer sl_set_undefined_constant_warnings(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->undefined_constant_warnings = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_undefined_identifier_warnings(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->undefined_identifier_warnings = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_accept_all_keyword_arguments(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->accept_all_keyword_arguments = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_autoloading(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->is_autoloading = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_profile_prefix(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if ((!is_symbol(val)) && (val != sc->F)) starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "a symbol or #f", 14)); + sc->profile_prefix = val; + return(val); +} + +static s7_pointer sl_set_profile_info(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (val != sc->F) starlet_wrong_type_error_nr(sc, sym, val, wrap_string(sc, "#f (to clear the table)", 23)); + return(clear_profile_info(sc)); +} + +static s7_pointer sl_set_muffle_warnings(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->muffle_warnings = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_openlets(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->has_openlets = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_gc_temps_size(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + sc->gc_temps_size = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); + if (sc->gc_temps_size > sc->heap_size) sc->gc_temps_size = sc->heap_size; + return(make_integer(sc, sc->gc_temps_size)); +} + +static s7_pointer sl_set_expansions(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_BOOLEAN]); + sc->is_expanding = s7_boolean(sc, val); + return(val); +} + +static s7_pointer sl_set_history_enabled(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (!is_boolean(val)) 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)))); +} + +static no_return 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 starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + if (S7_DEBUGGING) + { + if (!is_symbol(sym)) {fprintf(stderr, "%s[%d]: %s is not a symbol\n", __func__, __LINE__, display(sym)); if (sc->stop_at_error) abort();} + if (is_symbol_and_keyword(sym)) {fprintf(stderr, "%s[%d]: %s is a keyword\n", __func__, __LINE__, display(sym)); if (sc->stop_at_error) abort();} + if (starlet_symbol_id(sym) == sl_no_field) {fprintf(stderr, "%s[%d]: %s is not an *s7* field\n", __func__, __LINE__, display(sym)); if (sc->stop_at_error) abort();} + } + switch (starlet_symbol_id(sym)) + { + case sl_accept_all_keyword_arguments: return(sl_set_accept_all_keyword_arguments(sc, sym, val)); + case sl_autoloading: return(sl_set_autoloading(sc, sym, val)); + case sl_bignum_precision: return(sl_set_bignum_precision(sc, sym, val)); + case sl_catches: sl_unsettable_error_nr(sc, sym); + case sl_cpu_time: sl_unsettable_error_nr(sc, sym); + 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: return(sl_set_default_hash_table_length(sc, sym, val)); + case sl_default_random_state: return(sl_set_default_random_state(sc, sym, val)); + case sl_default_rationalize_error: sc->default_rationalize_error = sl_real_geq_0(sc, sym, val); return(val); + case sl_equivalent_float_epsilon: sc->equivalent_float_epsilon = sl_real_geq_0(sc, sym, val); return(val); + case sl_expansions: return(sl_set_expansions(sc, sym, val)); + case sl_file_names: case sl_filenames: sl_unsettable_error_nr(sc, sym); + case sl_float_format_precision: return(sl_set_float_format_precision(sc, sym, val)); + case sl_free_heap_size: sl_unsettable_error_nr(sc, sym); + case sl_gc_freed: sl_unsettable_error_nr(sc, sym); + case sl_gc_total_freed: sl_unsettable_error_nr(sc, sym); + case sl_gc_protected_objects: sl_unsettable_error_nr(sc, sym); + case sl_gc_temps_size: return(sl_set_gc_temps_size(sc, sym, val)); + case sl_gc_resize_heap_fraction: sc->gc_resize_heap_fraction = sl_real_0_to_1(sc, sym, val); return(val); + case sl_gc_resize_heap_by_4_fraction: sc->gc_resize_heap_by_4_fraction = sl_real_0_to_1(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 = sl_real_geq_0(sc, sym, val); return(val); + case sl_hash_table_missing_key_value: hash_entry_set_value(sc->unentry, val); return(val); + case sl_heap_size: return(sl_set_heap_size(sc, sym, val)); + case sl_history: replace_current_code(sc, val); return(val); + case sl_history_enabled: return(sl_set_history_enabled(sc, sym, val)); + case sl_history_size: return(sl_set_history_size(sc, sym, val)); + case sl_initial_string_port_length: return(sl_set_initial_string_port_length(sc, sym, val)); + case sl_iterator_at_end_value: sc->iterator_at_end_value = val; return(val); + case sl_major_version: sl_unsettable_error_nr(sc, sym); + case sl_minor_version: sl_unsettable_error_nr(sc, sym); + case sl_max_heap_size: return(sl_set_max_heap_size(sc, sym, 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_stack_size: return(sl_set_max_stack_size(sc, sym, 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_string_port_length: return(sl_set_max_string_port_length(sc, sym, 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: sl_unsettable_error_nr(sc, sym); + case sl_most_negative_fixnum: sl_unsettable_error_nr(sc, sym); + case sl_most_positive_fixnum: sl_unsettable_error_nr(sc, sym); + case sl_muffle_warnings: return(sl_set_muffle_warnings(sc, sym, val)); + case sl_number_separator: return(sl_set_number_separator(sc, sym, val)); /* I think no PL uses the separator in output */ + case sl_openlets: return(sl_set_openlets(sc, sym, val)); + case sl_output_file_port_length: sc->output_file_port_length = s7_integer_clamped_if_gmp(sc, sl_integer_gt_0(sc, sym, val)); return(val); + case sl_print_length: 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: return(sl_set_profile_info(sc, sym, val)); + case sl_profile_prefix: return(sl_set_profile_prefix(sc, sym, val)); + case sl_rootlet_size: sl_unsettable_error_nr(sc, sym); + case sl_safety: return(sl_set_safety(sc, sym, val)); + case sl_stacktrace_defaults: return(sl_set_stacktrace_defaults(sc, sym,val)); + case sl_stack: sl_unsettable_error_nr(sc, sym); + case sl_stack_size: sl_unsettable_error_nr(sc, sym); + case sl_stack_top: sl_unsettable_error_nr(sc, sym); + case sl_symbol_printer: return(sl_set_symbol_printer(sc, sym, val)); + case sl_symbol_quote: return(sl_set_symbol_quote(sc, sym, val)); + case sl_undefined_constant_warnings: return(sl_set_undefined_constant_warnings(sc, sym, val)); + case sl_undefined_identifier_warnings: return(sl_set_undefined_identifier_warnings(sc, sym, val)); + case sl_version: sl_unsettable_error_nr(sc, sym); + default: return(sc->undefined); /* can't happen */ + /* 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 (starlet_symbol_id(sym) != sl_no_field) + return(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));} +#define NUM_UNSETTABLE_FIELDS 19 + +static void init_starlet_immutable_field(void) +{ + const int32_t unsettable_fields[NUM_UNSETTABLE_FIELDS] = { + sl_catches, sl_cpu_time, sl_c_types, sl_filenames, sl_file_names, sl_free_heap_size, sl_gc_freed, sl_gc_protected_objects, + sl_gc_total_freed, sl_major_version, sl_memory_usage, sl_minor_version, sl_most_negative_fixnum, sl_most_positive_fixnum, + sl_rootlet_size, sl_stack, sl_stack_size, sl_stack_top, sl_version}; + + starlet_immutable_field = (bool *)Calloc(sl_num_fields, sizeof(bool)); + for (int32_t i = 0; i < NUM_UNSETTABLE_FIELDS; i++) starlet_immutable_field[unsettable_fields[i]] = true; +} + +/* (let-temporarily (((*s7* 'safety) 1)) (object->string (inlet *s7*) :readable)): this uses :fields reversed with immutable! on the filenames */ + + +#define NUM_INTEGER_WRAPPERS 4 +#define NUM_REAL_WRAPPERS 4 +#define NUM_COMPLEX_WRAPPERS 4 +#define NUM_LET_WRAPPERS 4 +#define NUM_SLOT_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("#"); + if (p == sc->symbol_table) return("symbol_table"); + if (p == sc->rootlet) return("rootlet"); + if (p == sc->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"); + 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->complex_wrappers; i < NUM_COMPLEX_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("complex-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"); + for (i = 0, wrapper = sc->let_wrappers; i < NUM_LET_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("let-wrapper"); + for (i = 0, wrapper = sc->slot_wrappers; i < NUM_SLOT_WRAPPERS; i++, wrapper = cdr(wrapper)) if (car(wrapper) == p) return("slot-wrapper"); + } + return((p == sc->stack) ? "stack" : NULL); +} + +static bool is_decodable(s7_scheme *sc, const s7_pointer ptr) +{ + s7_pointer *tp = sc->heap; + const s7_pointer *heap_top = (s7_pointer *)(sc->heap + sc->heap_size); + + /* check symbol-table */ + for (int32_t i = 0; i < SYMBOL_TABLE_SIZE; i++) + for (s7_pointer syms = vector_element(sc->symbol_table, i); is_pair(syms); syms = cdr(syms)) + { + const s7_pointer sym = car(syms); + if ((sym == ptr) || + ((is_defined_global(sym)) && (ptr == global_value(sym)))) + return(true); + } + for (int32_t i = 0; i < NUM_CHARS; i++) if (ptr == chars[i]) return(true); + for (int32_t i = 0; i < NUM_SMALL_INTS; i++) if (ptr == &small_ints[i]) return(true); + + /* check the heap */ + while (tp < heap_top) + if (ptr == (*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) + { + s7_int 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 (s7_int 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; + const 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 + { + const 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)) + { + const 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_STARLET_REF_S] = fx_implicit_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 */ + /* these choices make only a small difference (< 1%) in timings except in tclo */ + fx_function[OP_TC_AND_A_OR_A_LA] = op_tc_and_a_or_a_la; + fx_function[OP_TC_OR_A_AND_A_LA] = op_tc_or_a_and_a_la; + fx_function[OP_TC_OR_A_A_AND_A_A_LA] = op_tc_or_a_a_and_a_a_la; + fx_function[OP_TC_AND_A_OR_A_L2A] = op_tc_and_a_or_a_l2a; + fx_function[OP_TC_OR_A_AND_A_L2A] = op_tc_or_a_and_a_l2a; + fx_function[OP_TC_AND_A_OR_A_L3A] = op_tc_and_a_or_a_l3a; + fx_function[OP_TC_OR_A_AND_A_L3A] = op_tc_or_a_and_a_l3a; + fx_function[OP_TC_AND_A_OR_A_A_LA] = op_tc_and_a_or_a_a_la; + fx_function[OP_TC_OR_A_AND_A_A_LA] = op_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_Z_L2A] = fx_tc_if_a_z_l2a; + fx_function[OP_TC_IF_A_Z_L3A] = fx_tc_if_a_z_l3a; + 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_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_L2A_Z] = fx_tc_if_a_z_if_a_l2a_z; + fx_function[OP_TC_IF_A_Z_IF_A_Z_L2A] = fx_tc_if_a_z_if_a_z_l2a; + fx_function[OP_TC_IF_A_Z_IF_A_L3A_L3A] = fx_tc_if_a_z_if_a_l3a_l3a; + fx_function[OP_TC_IF_A_Z_IF_A_Z_L3A] = fx_tc_if_a_z_if_a_z_l3a; + fx_function[OP_TC_IF_A_Z_IF_A_L3A_Z] = fx_tc_if_a_z_if_a_l3a_z; + fx_function[OP_TC_CASE_LA] = fx_tc_case_la; + fx_function[OP_TC_CASE_L2A] = fx_tc_case_l2a; + fx_function[OP_TC_CASE_L3A] = fx_tc_case_l3a; + fx_function[OP_TC_OR_A_AND_A_A_L3A] = op_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_L2A] = fx_tc_let_if_a_z_l2a; + fx_function[OP_TC_LET_WHEN_L2A] = op_tc_let_when_l2a; + fx_function[OP_TC_LET_COND] = fx_tc_let_cond; + fx_function[OP_TC_COND_N] = fx_tc_cond_n; + fx_function[OP_TC_COND_A_Z_A_L2A_L2A] = fx_tc_cond_a_z_a_l2a_l2a; + fx_function[OP_TC_WHEN_LA] = op_tc_when_la; + fx_function[OP_TC_WHEN_L2A] = op_tc_when_l2a; + fx_function[OP_TC_WHEN_L3A] = op_tc_when_l3a; + + fx_function[OP_RECUR_IF_A_A_opLA_LAq] = op_recur_if_a_a_opla_laq; + fx_function[OP_RECUR_IF_A_A_opL2A_L2Aq] = op_recur_if_a_a_opl2a_l2aq; + fx_function[OP_RECUR_IF_A_A_opL3A_L3Aq] = op_recur_if_a_a_opl3a_l3aq; + fx_function[OP_RECUR_IF_A_A_opA_LAq] = op_recur_if_a_a_opa_laq; + fx_function[OP_RECUR_IF_A_A_opA_L2Aq] = op_recur_if_a_a_opa_l2aq; + fx_function[OP_RECUR_IF_A_A_opA_L3Aq] = op_recur_if_a_a_opa_l3aq; + fx_function[OP_RECUR_IF_A_A_AND_A_L2A_L2A] = op_recur_if_a_a_and_a_l2a_l2a; + fx_function[OP_RECUR_IF_A_A_IF_A_A_opLA_LAq] = op_recur_if_a_a_if_a_a_opla_laq; + fx_function[OP_RECUR_IF_A_A_IF_A_A_opL2A_L2Aq] = op_recur_if_a_a_if_a_a_opl2a_l2aq; + fx_function[OP_RECUR_IF_A_A_IF_A_A_opL3A_L3Aq] = op_recur_if_a_a_if_a_a_opl3a_l3aq; + fx_function[OP_RECUR_AND_A_OR_A_L2A_L2A] = op_recur_and_a_or_a_l2a_l2a; + fx_function[OP_RECUR_IF_A_A_opLA_LA_LAq] = op_recur_if_a_a_opla_la_laq; + fx_function[OP_RECUR_IF_A_A_AND_A_L2A_L2A] = op_recur_if_a_a_and_a_l2a_l2a; + fx_function[OP_RECUR_IF_A_A_opA_LA_LAq] = op_recur_if_a_a_opa_la_laq; + fx_function[OP_RECUR_IF_A_A_IF_A_L2A_opA_L2Aq] = op_recur_if_a_a_if_a_l2a_opa_l2aq; + fx_function[OP_RECUR_COND_A_A_A_A_opA_L2Aq] = op_recur_cond_a_a_a_a_opa_l2aq; + fx_function[OP_RECUR_COND_A_A_A_L2A_LopA_L2Aq] = op_recur_cond_a_a_a_l2a_lopa_l2aq; +} + +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->complex_vector_ref_symbol), complex_vector_ref_p_pp); + s7_set_p_pi_function(sc, global_value(sc->complex_vector_ref_symbol), complex_vector_ref_p_pi); + s7_set_p_pip_function(sc, global_value(sc->complex_vector_set_symbol), complex_vector_set_p_pip); + s7_set_p_ppp_function(sc, global_value(sc->complex_vector_set_symbol), complex_vector_set_p_ppp); + + 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_p_pip_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_p_pip); + s7_set_p_ppp_function(sc, global_value(sc->float_vector_set_symbol), float_vector_set_p_ppp); + 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_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_p_pip_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_p_pip); + s7_set_p_ppp_function(sc, global_value(sc->int_vector_set_symbol), int_vector_set_p_ppp); + 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); + + /* experiment, don't add byte-vector -- collides here with int-vector, this works only for these cases */ + s7_set_i_7piii_function(sc, global_value(sc->vector_ref_symbol), int_vector_ref_i_7piii); + s7_set_i_7piii_function(sc, global_value(sc->vector_set_symbol), int_vector_set_i_7piii); + s7_set_d_7piid_function(sc, global_value(sc->vector_set_symbol), float_vector_set_d_7piid); + + 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_pp_function(sc, global_value(sc->complex_symbol), complex_p_pp); + + 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_d_d_function(sc, global_value(sc->angle_symbol), angle_d_d); + 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_p_i_function(sc, global_value(sc->round_symbol), round_p_i); + s7_set_i_i_function(sc, global_value(sc->floor_symbol), floor_i_i); + s7_set_p_i_function(sc, global_value(sc->floor_symbol), floor_p_i); + s7_set_i_i_function(sc, global_value(sc->ceiling_symbol), ceiling_i_i); + s7_set_p_i_function(sc, global_value(sc->ceiling_symbol), ceiling_p_i); + s7_set_i_i_function(sc, global_value(sc->truncate_symbol), truncate_i_i); + s7_set_p_i_function(sc, global_value(sc->truncate_symbol), truncate_p_i); + + s7_set_d_d_function(sc, global_value(sc->tan_symbol), tan_d_d); + s7_set_d_d_function(sc, global_value(sc->atan_symbol), atan_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), tree_memq_b_7pp); + 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_7p_function(sc, global_value(sc->real_part_symbol), real_part_d_7p); + s7_set_d_7p_function(sc, global_value(sc->imag_part_symbol), imag_part_d_7p); /* also angle, magnitude, but angle might return int etc */ + 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->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 !DISABLE_DEPRECATED + s7_provide(sc, "deprecated"); +#endif +#if S7_ALIGNED + s7_provide(sc, "aligned"); +#endif +#if POINTER_32 + s7_provide(sc, "32-bit"); +#endif +/* maybe WITH_WARNINGS */ + +#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__ /* this defines __GNUC__ */ + s7_provide(sc, "clang"); + #if __cplusplus + s7_provide(sc, "clang++"); /* compiles and loads, but doesn't work yet */ + #endif +#else + #ifdef __GNUC__ + s7_provide(sc, "gcc"); + #if __cplusplus + s7_provide(sc, "g++"); + #endif + #endif +#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; +#if S7_DEBUGGING + sc->string_wrapper_allocs = 0; + sc->integer_wrapper_allocs = 0; + sc->real_wrapper_allocs = 0; + sc->complex_wrapper_allocs = 0; + sc->c_pointer_wrapper_allocs = 0; + sc->let_wrapper_allocs = 0; + sc->slot_wrapper_allocs = 0; +#endif + 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) */ +#if S7_DEBUGGING + p->carrier_line = __LINE__; +#endif + 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; +#if S7_DEBUGGING + p->carrier_line = __LINE__; +#endif + set_real(p, 0.0); + set_car(cp, p); + } + unchecked_set_cdr(qp, sc->real_wrappers); + + sc->complex_wrappers = semipermanent_list(sc, NUM_COMPLEX_WRAPPERS); + for (cp = sc->complex_wrappers, qp = sc->complex_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) + { + s7_pointer p = alloc_pointer(sc); + full_type(p) = T_COMPLEX | T_IMMUTABLE | T_MUTABLE | T_UNHEAP; +#if S7_DEBUGGING + p->carrier_line = __LINE__; +#endif + set_real_part(p, 0.0); + set_imag_part(p, 0.0); + set_car(cp, p); + } + unchecked_set_cdr(qp, sc->complex_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); + + sc->let_wrappers = semipermanent_list(sc, NUM_LET_WRAPPERS); + for (cp = sc->let_wrappers, qp = sc->let_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) + { + s7_pointer p = alloc_pointer(sc); + full_type(p) = T_LET | T_SAFE_PROCEDURE | T_UNHEAP; + let_set_slots(p, slot_end); + let_set_outlet(p, sc->rootlet); + set_car(cp, p); + } + unchecked_set_cdr(qp, sc->let_wrappers); + + sc->slot_wrappers = semipermanent_list(sc, NUM_SLOT_WRAPPERS); + for (cp = sc->slot_wrappers, qp = sc->slot_wrappers; is_pair(cp); qp = cp, cp = cdr(cp)) + { + s7_pointer p = alloc_pointer(sc); + full_type(p) = T_SLOT | T_UNHEAP; + set_car(cp, p); + } + unchecked_set_cdr(qp, sc->slot_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) +{ + const s7_int len = safe_strlen(name); + const s7_uint hash = raw_string_hash((const uint8_t *)name, len); + const uint32_t loc = hash % SYMBOL_TABLE_SIZE; + const s7_pointer symbol = new_symbol(sc, name, len, hash, loc); + const s7_pointer syn = alloc_pointer(sc); + + set_full_type(syn, T_SYNTAX | T_SYNTACTIC | T_DONT_EVAL_ARGS | T_UNHEAP); + syntax_opcode(syn) = op; + syntax_set_symbol(syn, symbol); + syntax_min_args(syn) = integer(min_args); + syntax_max_args(syn) = integer(max_args); + syntax_documentation(syn) = doc; + set_global_slot(symbol, make_semipermanent_slot(sc, symbol, syn)); + set_initial_value(symbol, syn); /* set_local_slot(x, global_slot(x)); */ + add_to_unlet(sc, symbol); + set_type_bit(symbol, T_SYMBOL | T_SYNTACTIC | T_UNHEAP); + symbol_set_local_slot_unchecked(symbol, 0LL, sc->undefined); + symbol_clear_ctr(symbol); + return(symbol); +} + +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 symbol = syntax(sc, name, op, min_args, max_args, doc); + set_syntax_is_definer(symbol); + return(symbol); +} + +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 symbol = syntax(sc, name, op, min_args, max_args, doc); + set_syntax_is_binder(symbol); + return(symbol); +} + +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 symbol = syntax(sc, name, op, min_args, max_args, doc); + s7_pointer p = global_value(symbol); + full_type(p) |= T_COPY_ARGS; + return(symbol); +} + +static s7_pointer make_unique(s7_scheme *sc, const char *name, s7_uint typ) +{ + const 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 ) ) */ +{ + s7_int 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); + { + s7_int i = 0; + 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_safe_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->complex_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, "#", 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, "#", 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); + c_function_set_setter(global_value(sc->current_input_port_symbol), global_value(sc->set_current_input_port_symbol)); + c_function_set_setter(global_value(sc->current_output_port_symbol), global_value(sc->set_current_output_port_symbol)); +#endif + + set_is_setter(sc->set_current_error_port_symbol); + c_function_set_setter(global_value(sc->current_error_port_symbol), global_value(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". + */ + + c_function_set_setter(global_value(sc->car_symbol), global_value(sc->set_car_symbol)); + c_function_set_setter(global_value(sc->cdr_symbol), global_value(sc->set_cdr_symbol)); + c_function_set_setter(global_value(sc->hash_table_ref_symbol), global_value(sc->hash_table_set_symbol)); + c_function_set_setter(global_value(sc->vector_ref_symbol), global_value(sc->vector_set_symbol)); + c_function_set_setter(global_value(sc->float_vector_ref_symbol), global_value(sc->float_vector_set_symbol)); + c_function_set_setter(global_value(sc->complex_vector_ref_symbol), global_value(sc->complex_vector_set_symbol)); + c_function_set_setter(global_value(sc->int_vector_ref_symbol), global_value(sc->int_vector_set_symbol)); + c_function_set_setter(global_value(sc->byte_vector_ref_symbol), global_value(sc->byte_vector_set_symbol)); + c_function_set_setter(global_value(sc->list_ref_symbol), global_value(sc->list_set_symbol)); + c_function_set_setter(global_value(sc->let_ref_symbol), global_value(sc->let_set_symbol)); + c_function_set_setter(global_value(sc->string_ref_symbol), global_value(sc->string_set_symbol)); + c_function_set_setter(global_value(sc->outlet_symbol), + s7_make_safe_function(sc, "#", g_set_outlet, 2, 0, false, "outlet setter")); + c_function_set_setter(global_value(sc->port_line_number_symbol), + s7_make_safe_function(sc, "#", 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, "#", 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, "#", 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, "#", 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, "#", 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, "#", 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, "#", g_symbol_set, 2, 0, true, "symbol setter")); + c_function_set_setter(global_value(sc->symbol_initial_value_symbol), + s7_make_safe_function(sc, "#", g_symbol_set_initial_value, 2, 0, false, "symbol-initial-value setter")); + c_function_set_setter(global_value(sc->hook_functions_symbol), + s7_make_safe_function(sc, "#", g_hook_set_functions, 2, 0, false, "hook-functions 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); + copy_initial_value(sc, sc->quote_symbol); + 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_baffle_symbol = binder_syntax(sc, "with-baffle", OP_WITH_BAFFLE, int_zero, max_arity, H_with_baffle); /* (with-baffle) is () */ + sc->with_let_symbol = binder_syntax(sc, "with-let", OP_WITH_LET, int_one, max_arity, H_with_let); + 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); + + set_is_escaper_syntax(sc->lambda_symbol); + set_is_escaper_syntax(sc->lambda_star_symbol); + set_is_escaper_syntax(sc->macro_symbol); + set_is_escaper_syntax(sc->macro_star_symbol); + set_is_escaper_syntax(sc->bacro_symbol); + set_is_escaper_syntax(sc->bacro_star_symbol); + + 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_exit_function_symbol = make_symbol(sc, "invalid-exit-function", 21); + 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); + set_initial_value(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. + */ + 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_complex_vector_symbol = bool_defun("complex-vector?", is_complex_vector, 0, T_COMPLEX_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_number_at_end_symbol = make_symbol(sc, "integer:number?", 15); + 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->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->symbol_initial_value_symbol = defun("symbol-initial-value", symbol_initial_value, 1, 0, false); + sc->immutable_symbol = semisafe_defun("immutable!",immutable, 1, 1, false); /* was unsafe 29-Mar-25 */ + 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); /* keyword->string is symbol->string */ + 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->curlet_symbol = semisafe_defun("curlet", curlet, 0, 0, false); /* was unsafe 29-Mar-25 */ + set_func_is_definer(sc->curlet_symbol); + set_is_escaper_function(sc->curlet_symbol); + set_is_saver(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)); + + sc->outlet_symbol = defun("outlet", outlet, 1, 0, false); + sc->rootlet_symbol = defun("rootlet", rootlet, 0, 0, false); + sc->is_funclet_symbol = defun("funclet?", is_funclet, 1, 0, false); + sc->sublet_symbol = defun("sublet", sublet, 1, 0, true); set_is_saver(sc->sublet_symbol); + sc->varlet_symbol = semisafe_defun("varlet", varlet, 2, 0, true); + set_func_is_definer(sc->varlet_symbol); + set_is_translucent(sc->varlet_symbol); + sc->cutlet_symbol = semisafe_defun("cutlet", cutlet, 2, 0, true); + set_func_is_definer(sc->cutlet_symbol); + set_is_translucent(sc->cutlet_symbol); + sc->inlet_symbol = defun("inlet", inlet, 0, 0, true); set_is_saver(sc->inlet_symbol); + sc->owlet_symbol = defun("owlet", owlet, 0, 0, false); + sc->coverlet_symbol = defun("coverlet", coverlet, 1, 0, false); set_is_translucent(sc->coverlet_symbol); + sc->openlet_symbol = semisafe_defun("openlet", openlet, 1, 0, false); set_is_translucent(sc->openlet_symbol); + + sc->let_ref_symbol = defun("let-ref", let_ref, 2, 0, false); set_immutable(sc->let_ref_symbol); + 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); + + 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_object_let_symbol = defun("c-object-let", c_object_let, 1, 0, false); /* added 3-Apr-25 */ + c_function_set_setter(global_value(sc->c_object_let_symbol), s7_make_safe_function(sc, "#", g_c_object_set_let, 2, 0, false, "c-object-let setter")); + + 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, "#", g_closed_input_function_port, 2, 0, false, "input-function error"), + sc->closed_output_function = s7_make_safe_function(sc, "#", 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); set_is_translucent(sc->write_symbol); + sc->display_symbol = defun("display", display, 1, 1, false); set_is_translucent(sc->display_symbol); + 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 (except gc protects), + * 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. + */ + copy_initial_value(sc, sc->read_symbol); + + 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); + set_is_translucent(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); set_is_translucent(sc->floor_symbol); + sc->ceiling_symbol = defun("ceiling", ceiling, 1, 0, false); set_is_translucent(sc->ceiling_symbol); + sc->truncate_symbol = defun("truncate", truncate, 1, 0, false); set_is_translucent(sc->truncate_symbol); + sc->round_symbol = defun("round", round, 1, 0, false); set_is_translucent(sc->round_symbol); + sc->logand_symbol = defun("logand", logand, 0, 0, true); + sc->logior_symbol = defun("logior", logior, 0, 0, true); + sc->logxor_symbol = defun("logxor", logxor, 0, 0, true); + sc->lognot_symbol = defun("lognot", lognot, 1, 0, false); + sc->logbit_symbol = defun("logbit?", logbit, 2, 0, false); + sc->integer_decode_float_symbol = defun("integer-decode-float", integer_decode_float, 1, 0, false); + sc->nan_symbol = defun("nan", nan, 0, 1, false); /* (nan) -> +nan.0, (nan 123) -> +nan.123 */ + sc->nan_payload_symbol = defun("nan-payload", nan_payload, 1, 0, false); + +#if !WITH_PURE_S7 + sc->integer_length_symbol = defun("integer-length", integer_length, 1, 0, false); + sc->inexact_to_exact_symbol = defun("inexact->exact", inexact_to_exact, 1, 0, false); + sc->exact_to_inexact_symbol = defun("exact->inexact", exact_to_inexact, 1, 0, false); + sc->is_exact_symbol = defun("exact?", is_exact, 1, 0, false); + sc->is_inexact_symbol = defun("inexact?", is_inexact, 1, 0, false); + sc->make_polar_symbol = defun("make-polar", make_polar, 2, 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("charchar_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("stringstring_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-cichar_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-cistring_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, 1, 2, false); + sc->substring_uncopied_symbol = defun("substring-uncopied",substring_uncopied, 1, 2, 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); set_is_saver(sc->cons_symbol); + 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); set_is_saver(sc->list_symbol); + 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); set_is_saver(sc->make_list_symbol); + + 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); set_is_saver(sc->make_vector_symbol); + sc->vector_symbol = defun("vector", vector, 0, 0, true); set_is_saver(sc->vector_symbol); + sc->vector_typer_symbol = defun("vector-typer", vector_typer, 1, 0, false); + + sc->subvector_symbol = defun("subvector", subvector, 1, 3, false); set_is_saver(sc->subvector_symbol); + 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->complex_vector_symbol = defun("complex-vector", complex_vector, 0, 0, true); + sc->make_complex_vector_symbol = defun("make-complex-vector", make_complex_vector, 1, 1, false); + sc->complex_vector_set_symbol = defun("complex-vector-set!", complex_vector_set, 3, 0, true); + sc->complex_vector_ref_symbol = defun("complex-vector-ref", complex_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); + set_has_even_args(global_value(sc->hash_table_symbol)); + set_is_saver(sc->hash_table_symbol); + 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); + set_has_even_args(global_value(sc->weak_hash_table_symbol)); + set_is_saver(sc->weak_hash_table_symbol); + 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); /* semisafe: see t101-6.scm, apply on stack */ + + 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, 1, false); + sc->catch_symbol = semisafe_defun("catch", catch, 3, 0, false); + sc->throw_symbol = semisafe_defun("throw", throw, 1, 0, true); /* was unsafe 29-Mar-25 (also error) */ + sc->error_symbol = semisafe_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); set_is_saver(sc->values_symbol); + /* calling values a saver rather than translucent slows down tmv.scm by about 6% */ + /* values_symbol set above for signatures, not semisafe! -- many errors in s7test */ + /* 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, "", 9); set_immutable(sc->unquote_symbol); +#else + sc->unquote_symbol = make_symbol(sc, "unquote", 7); +#endif + sc->qq_append_symbol = defun("", qq_append, 2, 0, false); set_is_saver(sc->qq_append_symbol); /* occurs via quasiquote as #_ */ + sc->apply_values_symbol = unsafe_defun("apply-values", apply_values, 0, 1, false); set_is_saver(sc->apply_values_symbol); + sc->list_values_symbol = defun("list-values", list_values, 0, 0, true); set_is_saver(sc->list_values_symbol); + copy_initial_value(sc, sc->apply_values_symbol); + copy_initial_value(sc, sc->list_values_symbol); + /* are these three names necessary? */ + + 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->procedure_arglist_symbol = defun("procedure-arglist", procedure_arglist, 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, 2, 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, "#", g_c_object_set, 1, 0, true, "c-object setter"); + /* c_function_set_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->hook_functions_symbol = defun("hook-functions", hook_functions, 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 */ + copy_initial_value(sc, sc->quasiquote_symbol); + sc->quasiquote_function = initial_value(sc->quasiquote_symbol); + + sc->reader_cond_symbol = s7_define_expansion(sc, "reader-cond", g_reader_cond, 1, 0, true, H_reader_cond); + /* set_initial_value(sc->reader_cond_symbol, sc->undefined); *//* until bug is fixed */ + + sc->profile_in_symbol = unsafe_defun("profile-in", profile_in, 2, 0, false); /* calls dynamic-unwind */ + sc->profile_out = NULL; + +#if !WITH_PURE_S7 + sc->cond_expand_symbol = s7_define_expansion(sc, "cond-expand", g_cond_expand, 1, 0, true, H_cond_expand); + /* set_initial_value(sc->cond_expand_symbol, sc->undefined); *//* until bug is fixed */ +#endif + + /* -------- *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, "#", 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, "#", 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, "#", 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, "#", 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* -- why? */ + 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, small_int(ST_MAX_FRAMES), small_int(ST_CODE_COLS), + small_int(ST_TOTAL_COLS), small_int(ST_NOTES_START_COL), (ST_AS_COMMENT) ? sc->T : sc->F); + + /* -------- *#readers* -------- */ + { + s7_pointer 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, "#", 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) +{ + 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_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! */ +#if S7_DEBUGGING || ((DISABLE_FILE_OUTPUT || POINTER_32) && (!WITH_GCC)) + if (!cur_sc) original_cur_sc = sc; + cur_sc = sc; +#endif + sc->overall_start_time = my_clock(); + 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_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->do_body_p = NULL; + sc->object_out_locked = false; + sc->has_openlets = true; + sc->is_expanding = true; + sc->accept_all_keyword_arguments = false; + sc->muffle_warnings = false; + sc->symbol_quote = 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->reset_error_hook = false; + + sc->nil = make_unique(sc, "()", T_NIL); + sc->unused = make_unique(sc, "#", T_UNUSED); + sc->T = make_unique(sc, "#t", T_BOOLEAN); + sc->F = make_unique(sc, "#f", T_BOOLEAN); + sc->undefined = make_unique(sc, "#", T_UNDEFINED); + sc->unspecified = make_unique(sc, "#", T_UNSPECIFIED); + sc->no_value = make_unique(sc, (SHOW_EVAL_OPS || S7_DEBUGGING) ? "#" : "#", 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 (int32_t i = 1; i < NUM_SAFE_PRELISTS; i++) + sc->safe_lists[i] = semipermanent_list(sc, i); + for (int32_t 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->v = sc->unused; + 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->rec_p1 = sc->unused; + sc->rec_p2 = sc->unused; + sc->read_dims = int_zero; + + 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->max_show_stack_frames = 20; + + sc->heap_size = (INITIAL_HEAP_SIZE > 0) ? INITIAL_HEAP_SIZE : 64000; + if ((sc->heap_size % 32) != 0) + sc->heap_size = 32 * (s7_int)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 + sc->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(sc->heap_size * sizeof(s7_cell)); /* was calloc 14-Apr-22 */ + add_saved_pointer(sc, (void *)cells); + for (int32_t i = 0; i < sc->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; sc->heap[i]->uses = 0; +#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; sc->heap[i]->uses = 0; +#endif + clear_type(sc->heap[i]); + } + /* memcpy((void *)(sc->free_heap), (const void *)(sc->heap), sizeof(s7_pointer) * sc->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 > 0) ? GC_TEMPS_SIZE : 256; + 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_true_calls = 0; + sc->gc_total_time = 0; + sc->gc_true_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 lenmax_string_port_length = (1LL << 45); + sc->output_file_port_length = OUTPUT_FILE_PORT_LENGTH; + + { + s7_int size = (INITIAL_PROTECTED_OBJECTS_SIZE > 0) ? INITIAL_PROTECTED_OBJECTS_SIZE : 2; + /* this has to precede s7_make_* allocations, need to protect against 0 here else segfault in g_multivector->gc_protect_2 */ + sc->protected_setters_size = size; + sc->protected_setters_loc = 0; + sc->protected_setters = make_vector_1(sc, size, FILLED, T_VECTOR); + sc->protected_setter_symbols = make_vector_1(sc, size, FILLED, T_VECTOR); + + sc->protected_objects_size = size; + sc->protected_objects_free_list = (s7_int *)Malloc(size * sizeof(s7_int)); + sc->protected_objects_free_list_loc = size - 1; + sc->protected_objects = make_vector_1(sc, size, FILLED, T_VECTOR); + for (int32_t i = 0; i < size; i++) + { + 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; + if (STACK_RESIZE_TRIGGER <= (INITIAL_STACK_SIZE / 2)) + sc->stack_size = INITIAL_STACK_SIZE; + else sc->stack_size = STACK_RESIZE_TRIGGER * 2; + 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); + initialize_recur_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 (int32_t i = 0; i < OPTS_SIZE; i++) + { + opt_info *o = &os[i]; + sc->opts[i] = o; + o->sc = sc; + }} + + for (int32_t 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->iterator_at_end_value = eof_object; + sc->gensym_counter = 0; + sc->capture_let_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->big_symbol_tag = 0; + sc->small_symbol_tag = 1; +#if S7_DEBUGGING + sc->big_symbol_set_state = set_ignore; + sc->small_symbol_set_state = set_ignore; + sc->y_line = 0; + sc->v_line = 0; + sc->c_functions_allocated = 0; +#endif + sc->symbol_printer = sc->F; + 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 **)Malloc(8 * sizeof(format_data_t *)); + sc->num_fdats = 8; + for (int32_t k = 0; k < 8; k++) sc->fdats[k] = make_fdat(sc); + 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->temp_error_hook = sc->nil; + sc->anon_symbol = make_symbol(sc, "anonymous-lambda", 16); + + 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_entries = NULL; + + init_wrappers(sc); + init_standard_ports(sc); + init_rootlet(sc); + init_open_input_function_choices(sc); + + { + s7_pointer rs; + new_cell(sc, rs, T_RANDOM_STATE); /* s7_set_default_random_state might set sc->default_random_state, so this shouldn't be permanent */ + sc->default_random_state = rs; +#if WITH_GMP + mpz_set_ui(sc->mpz_1, (uint64_t)my_clock()); + gmp_randinit_default(random_gmp_state(rs)); + gmp_randseed(random_gmp_state(rs), sc->mpz_1); +#else + random_seed(rs) = (uint64_t)my_clock(); /* used to be time(NULL), but that means separate threads can get the same random number sequence */ + random_carry(rs) = 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"); + set_initial_value(sc->pi_symbol, global_value(sc->pi_symbol)); + copy_initial_value(sc, sc->pi_symbol); /* real_pi (below) is not in the heap so pi's initial_value is real_pi if not gmp (s7_make_slot 9571) */ +#else + sc->pi_symbol = s7_define_constant(sc, "pi", real_pi); +#endif + + for (int32_t 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); +#if S7_DEBUGGING + init_tc_rec(sc); +#endif + s7_set_history_enabled(sc, false); /* see below */ + init_signatures(sc); /* depends on procedure symbols */ + sc->starlet = make_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 that hook to each function in its function list.\")) \n\ + (lambda hook-args \n\ + (let ((body ())) ; list of functions \n\ + (apply lambda* hook-args \n\ + '((let ((result #)) \n\ + (let ((hook (openlet (sublet (curlet) 'let-ref-fallback #)))) \n\ + (for-each (lambda (func) (func hook)) body) \n\ + result))))))))"); + /* (procedure-source (make-hook 'x 'y)): (lambda* (x y) (let ((result #)) ... result)), see stuff.scm for commentary + * '((when (pair? body) ...) at start might be a good idea -- depends on how often an empty hook is called + * moving make-hook to C (see tmphook) was a lot of code and did not save anything at start-up (20/1750 in callgrind, ca 1%) + */ + + /* -------- *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"); + + /* -------- *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)."); + + /* -------- *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))"); + + /* -------- *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->temp_error_hook = s7_eval_c_string(sc, "(make-hook 'type 'data)"); + /* internal; this is holding error-hook functions during an evaluation where error-hook is temporarily nil -- do we actually need a hook for this? */ + +#if !WITH_PURE_S7 + { + s7_pointer rs = s7_define_variable(sc, "make-rectangular", global_value(sc->complex_symbol)); + set_initial_value(rs, initial_value(sc->complex_symbol)); /* for #_make-rectangular */ + } + + 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) (list (cons 'lambda (cons vars body)) expression))"); + + /* call-with-values, make-hook and multiple-value-bind can't set the initial_value to the global_value + * so that #_... can be used because the global_value is not semipermanent, but could it be made so? (via remove_from_heap?) + */ +#endif +/* at this point there are about 640 symbols in the symbol table, only 3 or 4 of which are sharing a bin -- nearly perfect */ + +#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 != 913) 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 248 */ + if (!s7_type_names[0]) {fprintf(stderr, "no type_names\n"); gdb_break();} /* squelch very stupid warnings! */ +#if 0 + if (POINTER_32) fprintf(stderr, "pointer 32!?\n"); + /* sizes: c_proc_t 104, c_object_t[i.e. type, not the c_object] 160, vunion: 8, port_t 88, block_t 40, port_functions_t 80, s7_cell 120, s7 12264 */ + fprintf(stderr, "sizes: c_proc_t %d, c_object_t %d, vunion: %d, port_t %d, block_t %d, port_functions_t %d, s7_cell %d, s7 %d\n", + (int)sizeof(c_proc_t), (int)sizeof(c_object_t), (int)sizeof(vunion), (int)sizeof(port_t), + (int)sizeof(block_t), (int)sizeof(port_functions_t), (int)sizeof(s7_cell), (int)sizeof(s7_scheme)); +#endif +#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 + */ + 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 = call_c_object_frees(sc); /* do this first since they might involve gc_unprotect etc */ + gc_list_free(gp); + + gp = sc->vectors; + for (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int 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 (s7_int i = 0; i < sc->saved_pointers_loc; i++) + free(sc->saved_pointers[i]); + free(sc->saved_pointers); + + { + gc_obj_t *gnxt; + heap_block_t *hpnxt; + for (gc_obj_t *g = sc->semipermanent_lets; g; g = gnxt) {gnxt = g->nxt; free(g);} + for (gc_obj_t *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 (s7_int 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 (s7_int 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); + } +#if S7_DEBUGGING || ((DISABLE_FILE_OUTPUT || POINTER_32) && (!WITH_GCC)) + if (sc == cur_sc) cur_sc = original_cur_sc; +#endif + 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 + */ +#if WITH_SYSTEM_EXTRAS + bool repl_loaded = false; +#endif + const s7_pointer e = s7_inlet(sc, set_clist_2(sc, make_symbol(sc, "init_func", 9), make_symbol(sc, "libc_s7_init", 12))); + const s7_int gc_loc = gc_protect_1(sc, e); + const 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) */ + const s7_pointer val = s7_load_with_environment(sc, "libc_s7.so", e); + if (val) + { + s7_pointer libs = global_slot(sc->libraries_symbol); + s7_uint 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 !WITH_SYSTEM_EXTRAS + dumb_repl(sc); /* repl.scm uses file-exists? et al */ +#else + 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 /* S7_DEBUGGING */ +#endif /* WITH_NOTCURSES */ +#endif /* WITH_C_LOADER */ +} + +#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: clang s7.c -o repl -DWITH_MAIN -I. -O2 -g -lm + * 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 + * according to callgrind, clang is noticeably slower than gcc + * + * 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 49 secs on x86 Linux, 16 secs on M4 OSX) + * 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 + * addr2line -e repl 0xd7237 -> s7.c:29697 + * 6-May-25: cloc: blank 8773, comment 4007, code 88585, [gmp: ~5600, s7_debugging: ~2900 see search.scm] -> ca 80000 lines of code normally + */ +#endif +#endif + +/* ---------------------------------------------- + * 19.0 21.0 23.0 25.0 25.4 + * ---------------------------------------------- + * tpeak 148 114 105 109 110 + * tref 1081 687 459 412 407 + * tlimit 3936 5371 5371 783 774 + * index 1016 967 988 984 + * tmock 1145 1042 1031 1031 + * tvect 3408 2464 1669 1457 1481 + * thook 7651 ---- 2030 1731 1742 + * tauto 2048 1760 1792 + * texit 3094 3093 1830 + * s7test 1831 1829 1849 1892 + * lt 2222 2172 2185 1892 1896 + * dup 3788 2239 2012 2014 + * tread 2421 2408 2241 2249 + * tcopy 5546 2375 2352 2352 + * tload 2404 2506 2467 + * trclo 8248 2782 2634 2499 2490 + * fbench 2933 2583 2430 2536 2530 + * tmat 3042 2578 2522 2625 + * tsort 3683 3104 2804 2858 2857 + * titer 4550 3349 2985 2917 2929 + * tio 3752 3620 3127 3135 + * tbit 3836 3305 3261 3181 3183 + * tobj 3970 3577 3434 3429 + * teq 4045 3486 3556 3557 + * tmac 4373 4193 4024 3946 + * tcomplex 3869 3844 4215 4204 + * tcase 4793 4430 4376 4382 + * tmap 8774 4541 4380 4383 + * tlet 11.0 6974 5980 4470 4465 + * tfft 7729 4476 4538 4585 + * tshoot 5447 5055 4833 4804 + * tstar 7121 5565 5237 5243 + * tnum 6013 5396 5402 5380 + * concordance 10.0 6095 5165 5345 5395 + * tlist 9219 7546 6240 5770 5791 + * tari 14.3 12.5 6662 6292 5996 + * trec 19.6 6980 6656 6015 6074 + * tgsl 7802 6282 6208 6217 + * tset 6260 6278 6280 + * tleft 12.2 9753 7331 6393 6407 + * tmisc 7614 7130 7126 + * tclo 8025 8809 7627 7653 + * tgc 10.4 7579 7619 7634 + * tlamb 8003 7920 7917 + * tform 9992 9626 9029 + * thash 11.7 9479 9283 9203 + * cb 12.9 11.0 9564 9657 9663 + * tmap-hash 10.3 10.2 + * tgen 11.4 12.1 12.4 12.5 + * tall 15.9 15.6 15.6 15.1 15.1 + * timp 24.4 19.6 15.5 15.5 + * tmv 21.9 20.7 16.6 17.7 + * calls 37.5 37.5 37.1 37.3 + * sg 55.8 55.3 55.3 + * tbig 175.8 148.1 145.5 145.1 + * ---------------------------------------------- + * + * fx_chooser can't depend on is_defined_global because it sees args before possible local bindings, get rid of these if possible + * the fx_tree->fx_tree_in etc routes are a mess (redundant and flags get set at pessimal times) + * use optn pointers for if branches (also on existing cases -- many ops can be removed) + * the rec_p1 swap can collapse funcs in oprec_if_a_opla_aq_a and presumably elsewhere + * extend oprec_i* and also to oprec_p[air]* where base p is protected but locals need not be? + * tc_if_a_z_la et al in check_tc_cond et al need code merge + * recur_if_a_a_if_a_a_la_la needs the 3 other choices (true_quits etc) and combined + * op_recur_if_a_a_opa_la_laq op_recur_if_a_a_opla_la_laq can use existing if_and_cond blocks, need cond cases + * see s7-ffi.html 2631 -- needs rewrite! + * unsafe: apply-values values sort! apply [maybe because fx* does not protect against values, sc->code change in apply syntax etc] + * unsafe: s7_apply_function s7_values s7_call s7_eval s7_eval_c_string, only phase-vocoder is unsafe in clm2xen.c + * ffitest examples of unsafe funcs, for-each/map/member/assoc with push? + * t101-5|6|13|16 trouble fx_safe_thunk_a opt_p_pp_ff etc if unsafe->semisafe or safe (see 29-Mar) + * c-object throughout *.html needs rewrite and the rest as well + * tree_set_memq et al with #_*? also begin_set* [search is done by hand -- can c_funcs have a tag? what about big_symbol tag] + * for immutable... error, would be nice to give location of setting + * + * function|format-match + * bool ops return either #f or arg? (integer 1)->1, #t erases info unnecessarily, integer? as a filter + * (let ((y ...)) (set! x (and (integer? y) y))) -> (set! x (integer? ...))? + * (cond ((procedure? abs) => (lambda (f) (f -1))...)) + * does (let* loop ((i 0) :allow-other-keys) i) make sense? see 79760 check_let_star + * can start/end args be keyword/val? start_and_end 28297 + * affects substring|vector, string|vector->list, fill!, copy, write-string [object->list?] + */ diff --git a/s7.h b/s7.h new file mode 100644 index 0000000..6b5a08b --- /dev/null +++ b/s7.h @@ -0,0 +1,1307 @@ +#ifndef S7_H +#define S7_H + +#define S7_VERSION "11.5" +#define S7_DATE "30-June-2025" +#define S7_MAJOR_VERSION 11 +#define S7_MINOR_VERSION 5 + +#include /* for int64_t */ + +typedef int64_t s7_int; +typedef double s7_double; + +#ifndef __cplusplus +#ifndef _MSC_VER + #include +#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 + #include + #include +#endif + +#if __TINYC__ || _MSC_VER + /* _MSC_VER should also set HAVE_COMPLEX_NUMBERS to 0 */ + typedef double s7_complex; +#else + #if __cplusplus + #include + #ifdef __clang__ /* defines __GNUC__ */ + typedef _Complex double s7_complex; + #else + typedef std::complex s7_complex; + #endif + #else + #include + typedef double complex s7_complex; + #endif +#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); /* # */ +s7_pointer s7_unspecified(s7_scheme *sc); /* # */ +bool s7_is_unspecified(s7_scheme *sc, s7_pointer val); /* returns true if val is # */ +s7_pointer s7_eof_object(s7_scheme *sc); /* # */ +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_(...), s7_make_(...), and s7_is_(...): + * + * 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); +char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, s7_int radix); /* (number->string obj radix) */ + +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) */ + +bool s7_is_vector(s7_pointer p); /* (vector? p) */ +bool s7_is_float_vector(s7_pointer p); /* (float-vector? p) */ +bool s7_is_complex_vector(s7_pointer p); /* (complex-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_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_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_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); + +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_pointer s7_make_vector(s7_scheme *sc, s7_int len); /* (make-vector len) */ +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_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill); /* (make-vector len fill) */ + +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); +s7_pointer s7_make_int_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info); +s7_pointer s7_make_int_vector_wrapper(s7_scheme *sc, s7_int len, s7_int *data, s7_int dims, s7_int *dim_info, bool free_data); + +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_pointer s7_make_byte_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info); + +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_float_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *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); + +#if (!__TINYC__) && ((!defined(__clang__)) || (!__cplusplus)) + s7_complex *s7_complex_vector_elements(s7_pointer vec); + s7_complex s7_complex_vector_ref(s7_pointer vec, s7_int index); + s7_complex s7_complex_vector_set(s7_pointer vec, s7_int index, s7_complex value); + s7_pointer s7_make_complex_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info); + s7_pointer s7_make_complex_vector_wrapper(s7_scheme *sc, s7_int len, s7_complex *data, s7_int dims, s7_int *dim_info, bool free_data); +#endif + +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 port); /* (port-filename port) */ +s7_int s7_port_line_number(s7_scheme *sc, s7_pointer port); /* (port-line-number port) */ + +s7_pointer s7_current_input_port(s7_scheme *sc); /* (current-input-port) */ +s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer port); /* (set-current-input-port 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 port); /* (set-current-output-port 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 port) */ +void s7_close_input_port(s7_scheme *sc, s7_pointer port); /* (close-input-port port) */ +void s7_close_output_port(s7_scheme *sc, s7_pointer port); /* (close-output-port port) */ +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 port); /* same but returns an s7 string */ +bool s7_flush_output_port(s7_scheme *sc, s7_pointer port); /* (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); +s7_pointer s7_symbol_initial_value(s7_pointer symbol); /* #_symbol's value */ +s7_pointer s7_symbol_set_initial_value(s7_scheme *sc, s7_pointer symbol, s7_pointer value); + +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_set_immutable(s7_scheme *sc, s7_pointer p); +#if (!DISABLE_DEPRECATED) + s7_pointer s7_immutable(s7_pointer p); +#endif + +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) */ + +#if !S7_DISABLE_DEPRECATED + 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); +#endif +s7_pointer s7_lambda_body(s7_scheme *sc, s7_pointer p); +s7_pointer s7_lambda_let(s7_scheme *sc, s7_pointer p); +s7_pointer s7_lambda_parameters(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) */ +s7_pointer s7_function_let(s7_scheme *sc, s7_pointer obj); /* obj is from s7_make_c_function and friends */ + +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); +s7_pointer s7_make_typed_function_with_environment(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 let); + +/* 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_pointer s7_define_expansion(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 -- I'd like to deprecate these, but much old code depends on them */ +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 + * + * 7-June: *s7* 'hash-table-missing-key-value and 'iterator-at-end-value. + * replace s7_closure* with s7_lambda*. + * 3-Apr: c-object-let. + * 10-Mar-24: s7_make_int_vector_wrapper. + * -------- + * 31-Dec: s7_function_let as an experiment. + * 31-Aug: s7_define_expansion. + * 26-Aug: deprecate s7_immutable and add s7_set_immutable with s7_scheme* argument. + * 16-Aug: s7 complex vectors. + * 2-July: s7_make_typed_function_with_environment. + * 31-May: *s7* 'symbol-printer and 'symbol-quote?. + * 24-May: symbol-initial-value, s7_symbol_initial_value, and setters. + * 24-Apr: port-string. + * 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.. + * 19-Oct: s7_let_field* synonyms: s7_starlet_ref|set. + * 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: #_ = 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 (=-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/samply/act.c b/samply/act.c deleted file mode 100644 index 0c0bbb2..0000000 --- a/samply/act.c +++ /dev/null @@ -1,4 +0,0 @@ -#include - -#include "../dat.h" -#include "samply.h" diff --git a/samply/error.png b/samply/error.png deleted file mode 100644 index e0ab545ef576b41e70d41a186593dd4fafcdaff7..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 100211 zcmeAS@N?(olHy`uVBq!ia0y~yV15C@9Bd2>48Du6JYis9;4JWnEM{QPQwCwiilz2t z3=9eko-U3d6>)Foa_;dz`u~6X8}Dr?odOGUBAr}L?OWn8ZHlT>x2{OgwjiykZ=w|^ zE)_a8ZEgO|>l~aX=Lu*=KmBw6{rU56>o4#9UTio2{GRhOi_c}t^;gE+DZY2Q_?gUS zJLAuCO9LDjSVqxk2%v<(fnb(Nm8YU4xS13fpy(UNk_D%wg4eoy6TOeJ3vXoLXuv=&&I;OhOt_l+>mH)f0*o3QqAB(yMhes?G)BgCbs&C~yv!3@> z{i4^mnRT!#%wbt|;q7E4o>RiJBIirYmfRtYCE+%?H+-L7zGzpVbAp_G#C$QEDIX-T zC{t1oXvwQ=)>5zb&Z@7}*H7Zxl3_%0CLx&2)00h@n5Rr2-9ZRPN=MKC56OnMI$y`PrToGX6S{U?RMS1tSnY7&G$a{r^-@aL(~pd0n2u z4>oAZLxj$Qe5S1@_HLEqKl50AXW8`qv$^kK+Vx}N0R?&1XN8Vd=Ul!g`?vZd^h46} zgJ7ob6XIXjNX#jo@UPkbHcuWFLwXwI)6YKEFMMu4{Y&KRgR+>hATPLMcFj%CueTDe z_1D*5bbrehj*^GK#cGYqgR2cJ&kE(G#eS@K`+y50g*EVVOi`5&n=LbEx&QpQB)0!b zKj)lbf6Fe8#Vm&hqLZ0F7d<@{nZNhzw5waQ!#f$~riOiRls?2NfRQTsg*E)P=^L3^ z9S`Sqmw{D{KTkB^Q9F;x9gcc|ENDP zReQS21iQ13b2&ddf<1-oG#ifw<1OnA3=Q({?%MkG@Av!a5;KnfO+GzMSC#3DtXz)! z3?3$h5BW?hU#!<%(YJV4*DJGCuUFK$Y}LNHhXFN)mkD_Iw(*!78my1qz3uDO@OV|p z8OQ$?U0D$*#AtQ;OoEs5K|TQn#@j4h7pKl$p||;GUbTGVuH0=q1d!6UL&pJSmGbFl z8P|j`{E^=|(>Q(Gv0mwPZG-;Z8QPb0IS)Bw{HOQy7YS&KaR$VLn4YMrG~TeG5acD9}EVE87u zgNJFEu!bYsKF6lnbE6hAZJyQp;P$N{(ITWOR8$tLW!TZ zexEHX*U*s9@ge7@I^Uk-7Kv)839LiF!#zmd+F(VmhC|++9fgaIFLM>%xc~pZ--0i< zpL{&QquW7)qoE;|N%iHS@|FK`KF_@RRW2jrx*O5Q8uyt0J*XM|#G^R*dIpPZO@ z_|clzyG}nlJ3D!suAtw}w}+0EDljlbaeTP<=~~GCqK|h?ox9Zqm{80J=loJsSTH+b z!=D$6`=i|ZWG>3iZhsQHuO?Ela+~<%?R4bkY;J1fmG)wJ!JM2aaEF^oVS+-V`^$KH)0eSR8+2VS zl%YC7w{f8wZ&~rvQ>nglt*%ZyVB>evTYs;L;DY|{ZH@)<91REdbC@jH@4Kk#+>-K8 zp=||CRw4od$`hP?j9B0W=MK+??;ib2qK^40KYG24=WW)V9fhyjr1J`{EZI}}+3Uq= zMMV)KM+F6ziug+JRs2C`pBv6!UvVaG22y3L@W6<1aoXA7Wj>md7T$el@@G%wXO*-I zg<`u-&y{&)>$yNT^6c|YZ=1<}C!f^Fp#|hLhVx!)jWRz(uL@Z?xBC0LznAk2bPMmc z@k*<(y{kUFjZKe%Q6Pb-JV4g%Yxv}QzJa$kvHNnNL}nRBL0Dm@gGts*Ww)LQ9ovEWf`)3^K*?=SuI;cTr*&U(AEME)c zU=R>&^eXxKeHl-SaoU*-UP&Vtt#f^zdAGJ?s}94}NZbhPN2KfL>R5%1MfrdE_j zM!xWihmQ_?iEqq3+{U|hv3q|O_nf&xQ?$eNIvM7Mn=EK(i08EN>04{~^zP$DvU56w zS&<4n1{Nolwp|tmf5QV_FI9beo$cSw;^)&iF62ANvog*Xd~hWHe30q05)S5j^~|-` zjuo&Y=~eJzl9w{D*t#k0?5mw1y)R}Or%&U!aM}Ilx*fbMKFS5+l3(Pm+WS;Imq>FK zyDY{1tpTYyV&SczzVi367Dp}pO#7N28-lej9{rMXa+0f(ga7lK?G0uE7rYeMJ*#KE zViUe++IH(hW7s1B{D^P;y|1A#YE&-K0iNSZq+7sRb6C(I(J@p>vK8f3A5h3^(^h? zd@s>|n`aS|J%K2XUbs*Go)ds3pK5Skd$1yM`A0F$LVRh*=u8WU;E~8!(Y5l(%6mraP}<&y}+ses|{>QCNrql zNk9Ac+j;rFKR-W5JGb#{{PzC7{KxEP?{>eRRx$1I=_kRaDB}Y)UJaYK$X~bI(d!nr z*sXWX=JfM!HWJ@X^D?vXOpv(3{~>dJYjm1`hErNk=d()luk)(DzKY}))9LuN_0uJ9 zeNUU?A5+g6E`FKFij>kCSQ@YUNNDW;aELpQzvFLF^8bH-RoTA%Rkh+xVVid#*X4n& z@I6_poD&n3+pjM7mw$brk=bys-?qHFS|54hwKqFGsFr6y6a)?YoJ*AESEwE9WK3OT zWt4g12rIB9#jgmoi2TSZL8m0tJL&6 z(lfH9%=2^%59B{typKD4j(Wh1kaI>4=Po?l_U!EJ==(LFd%u;RTIAZTGVgA7>b}P{ zpPiMF!%(ELM5SURWt>^W*)ENoX{`^oQBs&V40X(P{*yDuWef7@3=hhNSnBB|#M_e>{u z<50c;`}WmU93|?8G6G)ga~FNe-}CWUz@zQ8zrS_vlmF3E!XEMU^5rcPkQ;vw%o@#7 z4v4a|P4MIk+MIqq@1s$`lp~xWYokJw7Q~-?%g6C|p5lSky4!aAUDpw6U;kp3N#>+& zNAf-QZa&s0tNrmzoc3q-^IsGskQ*TrR2Y@}02>g>GFP`(=!YgUtQ?To_%?lZ{ObZZTa`}mU>Qhdo*)zn3|C7qo1sZ+P7cW z!|~gG`PV*E`hHh`d-L)}!_C)SdHesCbsqe;R_^_2gZOC-`sw!T9!Hitv!y53zu)^k zrt(YVc4oVJrQ3fd@F5iz3cd>Znh~!L956h2FmqGN$u*tA>br~zzOA|>V_D?E^JBAT zxy6a^DviHVzDjMsFMRRE`8k%GukJ3-&%V7acb)C4zrVgtt_WK{^{4np%||Eiu`Wig z;GI~cf=g@7bi&ugTzho1J677JI<)ZI97|QUzmXqu8XRnxwqKtA+(lSocddUbm*^T! zVYMCqD$dWf4u53n>yf7ZB?hH`AtdqY8^f%x#ZAi|AMf97*YRx;1s^ zbkyTKn=sqmySqw_lLX#|DhDn1TU-6${LSBi4hxtSZ=@fxKD3Uvm0NsU8^3(sN6E)( zqV0VlyM5+-T6i0|daUR_5S;R9ei{4TpzBM$r=OFut=i)GIOF`yPsio!U+|rayeIj- zG&5q&L5Ep8B4iz1i2-U3+(T zcW-S<mKi_KfUFf>Z#&Tv4 z*7})2$nsMQ=Rb%?eCgF{CxBc$K zFK}SYzOo|lT73QAr=9L!4)fbjsW20sbo0X3I2L9^HfLbT5qz-uY`TSE1>f?;Wp8hZ zy`S!O(L3S!xw%4)2g;)Na*J2aWKeIg7J0YR^x=2cZn3X1>$<$B>qX{lXZ{oStw_D) zEu!)fP+_t$E<4r8m~_K2V}IS>FK$aGeB*D7-CfrDRNhtohnWYz*MXX+YxPzyejzOM zSI2W^>ZvIk)%@nXIJtbT|FVLHkN=sjl|R%&lx!7~98@<|Eo5#!yn*?`9LwUU%gcN} zKVi77?Y2I4w^@$0%SCaE2Ir6BjWJL9)P)X&u8X-j%cgQuxZJ`2H+H6+6zWVjQkxy1ewZPo=&};_+2sYoop{ZGX2VU2cyHPwn5Y*Hz~o&rYpN+t2;L3t=Jy z<8sa`Dy`FfC0q7?zgHb6pIm+FpZ@+oK}re{PfFC=?AEe)P1y2t*&g9Z8V zn7U%#=PS+A8#bn&pSRU0{hZE6n`6@}8)l?lx)rU!!y=#^1PNZ5b&uOZ?Bzv%NagIDLulD<7_NUfPW{NWN)&!BOL~ z-Shm7mZ|aU<7{6~kFWdqi)DuT+xgbzc{jdwF6yt5i7h`8t0z>^Sn^-cHQM{je3w+a zk4J>XSU1kAxi-nD>gT7Yeg!qxkN#u5ib!b;Oo<#*%o7d%T?zL8nYZDsYP*H^J_q{; zIrla0DSTj=S?RKXKjUq9P0Fo9t=xORWVoihjxE2tbZR)$+mkz40vryAvurqWSNtr8 zIwUU$DO|XetJTcL8?@N1x9E0{!)yEcxD-<>c4>_?;fh&jemB0VShdsF)YNyDN!E!8 zidmPJ`L6PtYqe~ah$ZXV8cji!AI7t%o6Efk zNqOcSqJOK_?e3m+zO&7)9c-?dQ@Md_zj*7;&yBB+sr~Z;{FmbFX|}6P(v4 zW63nXdy&^vEur%%XQpshyTtym(5FjFz0>!8I;DMWe*M3f50|T!U6%FY`M#jLR%jK% zqYNx>1QskzbzQZ1g=SyhmV=2=QeDwyqH=+H z=RD;LdAEK$b%|)|_%VEcy?(#dt@XYk-;T@IN0{HMSX_4O`j_UHMR)loAzPB9;qs&CH#=5!R)zL@qZN=HA+JZGxh+j|~4|HEEW0`~Ur#am#+9f?=$Wthl+l+X9Zi zO~%FETV|Hc?6>*kp&)!f_1lfo*VlZlA7}qMwEoNYnu;1o{)Lb{N)FA3Pld!U+;!Eh zMr_xT+TY&-d1d4)9x!I#-&b39^?}u4jt@Qa95$3+TX6iK{<0;i?)R4bn(k1Y`JQOzGHfvCxNu|Q_wQzlPPuD`PTDl9sdQ`o|2o&x z3q;=rhfR4Kz0`kxoR{pAT@DRQC7~+<6z|U3uiofd%FR1r&#fn~yF;|A4?d6Dnx%Ql zap9?Hy02M_V>fQ}n5dL>Uhd-iu=Nv?|Hc&Zc{v_nWzvkfz&RCC1pHGDXp7PEGnEd# z=U&zEifxtqn_Z_iKP}1SUbS|`vQ5?TTdt>`ofTT>`cc18Sl!RVqTI_VgCV7;X#K$u z`Oi)3mwHbRV`k$C;FUJ}(zJ8k%^%mI^F7(0-=A2_aV|DHQKPJxfvLoNg)`WTKbjrV ziWXnL%2-`^Fh=FI$Q-`Z3Zx9!HXEa6p=e;QfiW;iKC8cl3%3itVV-nooN zDSCIX>A#9yZ*Fd0ZCCqi#k;#VW2P+Okg=hMHP2?JcUXnD?)iEDe?Ff-$*taDcS49FY%Rc{ zbT6%j907xg3``}$(X3{mp^t{0EM5~bl~;!KUN|x<^U{)=7Wwz~94?99$npN@Qw0H0 z#)S^t#xEX5FIJ5`^!v=unBv9U-zT1%YrVRWnSGVdOe4wM)t<+4Z*Fqk`}f=JNos|U zEbmqKF)=kNH~61%oH7eu zklVL$6m%8OFuCk#-#2)ugBNnQ2G3c0mCnm7LP?;a?SMMV zrpfZ_gL9Q%o)?d=S-37{XH(9}NfQ*K=US;2rTo0vu=uI*%F3S`KTfv!`T04&?DT6( zy{9*r&$RpQ-Y>V-KjP4&HZSdl8Ucg34IlNxFEbtjPcnTFWVGwA*<4a^ZjWC4zBOj~ zX`vbl3hoXWY=84DyL+dd`F*B-!Kvp#(zbO^a^C#?{XM+;+Z)G%bsN2NZ)|WpJImC2 z@sa->j}}{R2dB#qOpIq1R4<&G03Mn+A*A8(h&}LW>f64li{1OJmT`AAc`B5@yCc-c zzV@-0YRBOf*Csct3|6b3@Nn~)>aVYsZc2ZC)Ir0F(`S~6=kgudsj`dfD;ku_&@xj0S;YD8~a)AGSr$ccB#%*GrkhpG1k zk4@*3wOV0U`%5G4THm7i2Ob`7zq+IF@fYrY|Apcg+q2dF?of$8@lAkn@pO&K4rL$k zV8D982PaZ3L*s&8R1}=sQ1s-)L({Yk*OOUJP1j$axAUpk+_3iwiT7WMWUN@T{KUHE zkY4_CudlCPZ&4`8-p_IFX_c_Nr+UP-$#2S8pE{dxRCF;gmH3;A_khjTW%*%KeC|Ts zda=wvF3r$YAydj9nF(z0Ul6;y?3+Gc{n8gw_dmQky8c1xoBKhsuBP2Pwn>PDtPFCk z{d7`2>tGY>s;sN43_T95eF&;#{CXvg)$XKj{PXW^MBcHzpqvDq;SOcmqgc)u8W;U8 zYi;Oiv9$&6jEw0VBAP)i?)CQ{U1h)Dc6ZO2gnhT)vs(Y+7STxXoo{z{W*@VzBGZ=T z@y9<;p3(FF=8O3|SXh``8H`^vX61oqT?7)CY>dB&Uj3zJka2g{R?f5oZ4CkvmPILR z<`orOvhyH_uNb8BA~v-4Z-nNzJwvrJ1~1b`}(tBYK@C;NV#nk%js6CkYaH|0xb z|5q1A_|QwEgW!V$PDN}gN;kL2h<*-Icwo`UZ~w<&QJvKLnGch%{^&5YpJw#risj^c z{G2y0ZBF-p{o~`~zVDJ6Th>gEtJ1vn{MfnL_+K9vHu)n0VS)&w-|p=61y4?xW?ovd z@x`Cwo@&PfqD$YfocT}mJJ2^b`%SY|DzuhhEi?46Xxp`^P<}ZadxlzV_+q>AUawH{~5T(8#RXTzs#nm5E7V0z+fU0>}{A18XMp$?nE0 zrHns^@2My>t@@I2bmsIxhXW!^?0hl-(cAMvx70+bdQbCtdTMHS|NrW>Nk_YCE;Zgi zomaG>!_)86#coiqrDmCB*Kd{|9f#!W{{)_zaNOgAiRQxzNONV&1a?g3v2+P7dZw&& zbN#+wSr^n7J=njUBggn@qS%(jdpzHBcrm2&%Guo5Rr7Px_NuP_wM&n53GRKa{Ko$_ z>u)oc=7#5-3f;S(&lcbV4YnSzXPI?jepukyWTwe(y;3XR@Bbh7_1)duEX4`T95+-0 zCOukr`)%Bti?6k2B$ZFsi@h>Y**#=`-QSQ?Q#5@IwLg?y2rQe#qvpZYo+I$Vijn0- zT)yKCeo%S+-@U-lA~uH`EH{QNw8vbulR{F+alS}{8|+{Aj-tN@`c7G!RGs&;;iTA=5jrs!@k$M>fV2;dEXT>*@JdIm7kyZ?{4}1m72lJ zRxq)0?MP+&qUP9Ozm98~Vbdl>DV7>X2G2(|7kdhrSR51%u&7OX|Mt$e|KD!shv)DA zyKPnI>S?!^IoNZ&P%2CvF45v3-4a)i2Tx8; z)~f#YM(|$h?@#kzocgnE{jpXBfdHl%j{F&i59bOnFvbf!$mF};{5gGoZCLK@ZM+9} z>hBVn)8W2gUw`JCl2hAPg|1$uzwd|B**TWN2X_WvNWSp-X8Qc21?4xQ)m!&6i8nBC zXq;KFSQr#%4c|FLR3YzOZL@%fj2KO!F`D{A$*_t+3Qi zn^P=Sc7lGq-PO(M{$I}+pZEC5u#<^JD|FS8YilBv6(VJo7tT5GrK_dj1Pi0R-~pap z^P`0KH860nG&0Q3-FM~fgFWHv*YAteBp7^>&MJf&hB08f7jl(?(C#bYooX4 zWgYL6aevz>-YcL)o*y%RNzPZfe5ZkvG?7SF3N5B^)&l#(fj@X>$cYY{S{!>#Up9- zLX5xi5X&;Zr>&7nPlY^dqg{+znn1Gy9~Sx-fZN-DJQmnmKD~8wW9FqLfuLMuQ{2bI z#HegAvFXd6Eq7`guK!iDf2SfZx8T%GnfHG_pSQnyT7SRH=IEo{;{1E1f4ndec`x+f z@zs`79+Rs5Jj{+D1}+;Ovs6uRJH0k)dtPkz`+Iv$wz)GlItWL&-P=9uyW%W!{+luL zvg}u73uW0_2^qdB=bjs%$17)JabfNu{d1RRehK`}EdAg7uAuMzqqc}LEkTLVj?c5` z!IUL${{8*^JM|Bzy@P{zqoIn%@=ks3ZJjyZzFQTqE(|HZRXEEpspE(2<(0weub_=FCCV!u-%kl$dr$GdSc??Ur#3c+Ze2A z=~Q?i)hM{cGJFaD)+1kSHv50ATqPg4SAR!&>;`6qN_f>hNOg3noE;rFC=s(CJ zSMi{6L$3VO|L(b}zid*P8s>98m|<$aU9X0jQQ(6SW8AfW%cS`}e9XMO+&{dPTfEHK zwxp?HI!BB`a(j@hfAy805}L=kj#ll-*UI!w!dEUtV7Q`T2Qi^cQu`GcHr-3xkGbXR`<_xXsdf z8r+0(WI7)!`^9?2r~e@zXFmJ<>}>GK$&V-SAAjh)@H!`tGP_!U!|%OQltre5tKU4k z(riK28>4E?|BB&l2R=PL9s2dvovmA@^Lr>6v1c9UYOGUl5S(#8S^~7#t)iD<{_Zoz zMSauzWUW`Ra*HWgl+Upd`PIU(zUrp0;}@q@G7j0AGE;(O{YtGlpZwiZvxvE=Shqy6 zg;OVbn-5n@L{x=lv!XbQk3xfFiEtF787Q+J_%Hb2asRVjjLrQ4)gO<|HUG+8)5{5qr>A{&3xBQBEOXQqG(wB?a@;d}jq1?QrXrs$>xKVPW(a_He&uU$ga7U`G9g`IakX{#S>s z%Cvba+w)zgvETk*#HnvjgPIh@S^oGjFz$i|?F_#L<2&b;%sTJsTzRZz^1-QEp{G2z zUSMTX_)yPsDOi_9Lg9f~<5KVGUNaA@b_GqbEmCMueHZ9(SQnIQ7IZS`r$67ja?hHp z8-w=MRGJn)^OBsdvxRb{G&H|*fZUzf4ASP)%_pH#s4zg zD;Sv+K!ZhnA6e9W-`(H8U&RWg}@LS&e8Pt>c z_V(v&1}_~JjnCU|ZONQ`YiDt~2FLUHG994xFAL|p_sfOW|NmP)Nh@fX&&p3vP72>j zDmbmX9aIypNIKfpTBnp4ud}wf+L3`pN%6zY^rY1n!rhbD*Re7R{Lp7SvtV&JDD^fJ zvjk0ERT?7eId`5-Wszy>DUq))7WZ2{U)XQ*_U2~y+MiFSgQ|d6tJm-2VtpdB#9K5^ zpYMwIbUj(Fd)gr@7I2B_bR3A~vUt+u(7;)+=>o5`nTJ4zv(s`9jy4|w4lYKP7mk^k zKRB5b5||o0Q(Uaoc}~tSTnt)%vnqc7KH*n3>zkS1pPg;KTGe~nie72+wz_}+e!qA7 zF;zF(3^bMzy3|WFbWcTL=+>;O0Sf)#*4RaX8{6~aU(8hs*);LaWv5MwVk}IK4BmH` zFPw54<>y7>YKgL^nCQo1f`HTho zvpxNP-rU^mXWHH&XSaXG`AyGHsaAh`^J?GkcigP6udWUc-+r%Zbw?ZrE2F>%yT-%q z{N9!uL%a;0G&xM*P;lT6%03(}z`(ej_wYv4x?cd-`QrSsWB@u;lGvfBS@2ms-^>dO9A6z3kDn5jJf+6&QqT8W{qpv9Q&MGBZ5k)3 zdaq*Rm0F=buR^KhiZmBTgTn`of_J^U-|h0={#e)ZLCIYwMShkh4+h36foNH~W(E!m z*8~~OR|;#_RDXZ>YVG!WlfsgFYV5wfIm~a*b9Tmj%i?1ayZ5Ad%(W^FS?)LY3NydW z1Jlci`Wy`oJuF2}Pc5~W-ny))@kxw-Xv*6?YSM~qEH=&$tjDYPu{F|P=6k@XkwQOfN@>lUU{8wOL3StSHobWcA zM-4{6(5r{fA>y2eZ0F@#xlrvw%J*U*?+P;c9*>kIXzAH>fZ17UWbc66z6DQ z5VWZLl=5N=JMZcV7M3xIt9~HQK0p);QB`+_uTiEp(o%*D9*WBV%b)ht+3t2^N_fRkY6*MAhjW z?~~m;ul8GHVA-U%kJ4{~dXBqFU#I>3a@oJ`P1OfZ7AD_>BOQWbtgj~StFBxsfwbUO z!uNsMONF;Dm(Tz9)Zx?I@_QSNQceiGWDva0UC-mS!hU=H{dy?~3Q$t&Ud zy4Y*U{kCb(=UPp^$6YS**WR#)nXzBkVUk6^xxyKCMgfDa10kE98ESU_xO403YRm6) z>bZU&u0B)w-neT!$CiwXPFwTtMqOPOdpo-AaFhT;qYGz2*?0YYKa{@sEerMSvWr+T z$FjKXQ{ab-J?3{yg5783%Ja7>)w}YlG z8$CEw`ky4lKzf@KG#ckk%3TpKcCOb zUg9!UU|`Y{JmFJS_-v{7hlOSmEC$VTJ!Ngv6&RQ{vAk3J_STf11`Tp*1bYWWtsI7NjNWyFLi@mk4Wo4Kd#W@q$?z;X6 z;AK*HAk7r3Vq5w9?RM3p)@rl+eI7r(z;RC2`CZqd$jxahjZ#l(ocgtnPu}iL7jFO; zlY)ZZgUVa;`&dLC%~+_=0dmrju=eu`3`|y>QOSpRUyQeqx%UXwd?MW`WzAkq4 ztLy96`^~p|JHyXhBv7sDsA>7TJ6ff$uDp7`|3BZ%!cR{;L4zRXK1HGG#xL&g-~a0J z^8VFj4wf7Z4IGW}o>{50JnyS2$vQbIEC3aqTOK|%<7j9wW18%7>G7>4M}?0x-fLuL z4*@MXIAX0AV61Le=v%BW!r&rUW^8$ZePPOVo!x#`xH%*VTQ z4H#G)9JCwns=RgNy0rhgmgpf+2UlPL`;LzftvDJS&aiMzYT0Y(?dfu0_xpXTt;*l& zsNNIYDQ%X+p_~2v)0xU|Z*GR3on;!jv*>Ba(^FHg&Mm*UGQ(iiRC)RIE$Qdwj_$F@ z`2TEnz7u239iBa5sd`+i0~fcwy17}sFRgeZ?*c2AhUSw>2@87<$W02Fd$0S(C@?*G~EO_4rEBCFNY|PaiwX zNk3_6YbF=+$lV8F8$bi%fsq2mHW5k-;ewH_I9|aM!Xzn0yXbk7XHC@#^}1X8{jOH+uP+z7g!kuves(tNeJKHkF1u8Eb*A=#4By)Q~FYAR&wB}niG)56W=-Mpb7h!3mh0&7O6Kd*jAP85C+$Q zR+D}!-Msy7=X1HOMNhrXUwZoVmZ)|Z&)e;0D?ii~#wEpW%efig5Vy#sGeF6F{WR_H zbuCR_S-Hhp&dL9OxqQCOORuF~Q?Hzus9dNsTRocJt@%Jb#~+{nmpYri>`Y*0QV@`3 zWO;G1@NldG1CzpmnYS&QcYiZVKPU6`f-`^S^w%v1?En364qYAQn|o)+Mb6U1(hoYi z^LO9dmKz(xJ*&P}l|eRU<^!n>nAAJ^~sEH~=<+rnE7m7kx1$7B5MejdrZYWVVTOVge=f4|+%@Au@(V`CIBXmZf!x^&;< zkdOo;Xb=hHkq6mK!6&S}7oD4Hef?8b<;SDqt}|Q?&HOeYddrjBt2wsb_Px!!=HA}w z=q-Ehf8Dn6cHb1{1GDUEca@0=a4;!6;9@+p=y#O`%X1Zu1h&{Ft&}DPjvq4}q>A3j zTou_h_et&T>}zW->RuD9w0V7A^88(`J^eew*T=m&$Sz-Un&t7=x-S>qvpzjJxlr{( zoW>lRydNJP#u{bf1J_qp+9P~QyHJq71HMn6kkBWcUxXFlP}%#%XB zj<1L;iJ8VRxnRxvU9a`BudRvPxJzKgZ_UH|t}gSH4!@-xQyura+UrGn?)`nX0dJYp z9Sl`N^qWOT{&VT;AS$d-f!&-Q}uF zOFVZ?RMG6;yrKNT$y{@4il%d!-OneJ>kje9J1DGR zu~R$#`%=!Yc?*~t?t_9EJm&n1L!_&O?ZUgS@Av&)r>^d6_xp{pdwLRRSw3i9X| zt!SCFd1c^Yx0P2{hfBZw_xJn#^%l;yki_`m(rWQcv%fR+_cRJCEa-G7@-0#Tw>6p^ z7R+p!+;8`5#q*}(XCKZOpSKX3W1fF62DDIzX2y5rZg+4)xvwQ`64{q?nV ztE*n!zdt{_jJ~c`cJFhkGk(XwC}7ab@ZR&jt9UeIBrKqlKc-VkFXj~Y$Y`RWlkZ%0GnAFqL&T8yV;NfU+ zxWaO8>C7+d0`K=qgIb&5ObK_8w+Nfero-{(iq7?|J^e z!>Ztw=ayMb%<^A#u7;QI&IUF;^Z|)!Fw|}#DxG-OUL@< z_2s6NzPfU9#l}|$o7vZvy}gzB{r2nQZF8;5&%L_6eSMkUMV7Z`XPFwWI)6YyfT3{- z=bD(EmmVb>FRr}zQqC?-X|Z{`@CGSRV;7X(9oQRn1NoFD$<%xZDqKJH&(F{9)(bY3 z%F8ZJa942=?;B03QP->n8OLrF-hC+2Cu3=}<;p$%r8ze@Wqp2jcA+kd-!#zDi1@mnM?I&4#^WZi zG)`9c_xiBY(MbbTQ$qSyGdv%d%v}1l`~TPL@%iUU+I+n?rJi0k)lueh%E?KQH7?UH zr+$BTH*BU+s!PqKoADLVjBl5gN%gPTSNQl?MLm13pPwb3%frFW*v=_qQxWj$ z=KgbM6j|0VHNN0TV6(N#+riD^aNs}7J4Nx$FUlsL`*}?_DCFK8%VLqY{Nfi6o;;Gb z`>mPa%}&nPO(~s=7N2!8-nC48+t+#3?*czRJ8OJ5gAKY8<-sjP= zUteE)cZg25to>CYc+6XJEA2 z#SBV!Dn1Klu}JU<>E!;`B7Pql&P1jRf$IozeocEM~nJ_%`cda?)>k= z($nrCuwxnnQ^^-j(D>#L{l+U_{P!G*&Ca~Apb^v-TWh4+TKnaqdlF;r@jh8q-~ZF! zl)k>U^4i*H>t+64g8J9%zTHe;dStg!`Kv1{S9wlWd$dd4?}(?*qX`QcSaJjwB%9{O zh<;Q(sC7yJ1)5KBr@O%Q?|-(AJB~S*~Bt&a;iax;orHguOn;iIGvDV17eDL!a%7 zcjme}7d#jkce%|FUYH>>E+8l`23xy>^>*( z*@S5ulaEVP+QjI*J3q%V_+sSCjU67J?%7sOW78;#zM4&sa~FLrr2fr_j792xyfG8qc@cuZ89mw3c;&%b}a^WT0G(+=~wx+2hd z_nj7&q5{3G?e_%PCj}TK9AG%Q`DLBv9`(7*FMMVib?*G~@Av!elWhqC42;z*Drpzi z$LySRbzWHvE7LuN35TT94uO{o7xXwJUMks~m;3Yc^ZQOluU}2mR_zzA@Dy2|cHaKS z17_2@KNXzfJrhs@=jZ3Ejm+#Kw%y0JDDrgn9oU$B zTtt1NP3^Ce7tfb^Pj|96PCK(=lDfa#ugb%`<}G#iDjxS<)I1og#PaFs>E*F{wLWf> zEZ&AFUhrk&xNvs~|6K(JCN-fIs)<+LZoj|pv^S&G{7~J%IUH&~GmO+HU+^s0q&@lj z=k>9>!$2eW?{wYbkGr4Zm9YqT!(nF^yw7{Oo||z);s5yu!sBa~{`=R?}Fik_TE4Ch&Q*@eOQ#ViM>p7op+ zT8R_aM>CxRjjcL0@c+wOczcF?{hy8IXYcG?7QL=zk8bp~6-KG2GQ?xoMs2CYayjik;iuJo4&bha@`R=xUdU|^JoU8IjeVA@<&*%U8 zl$BddgYTTBcw5TD^fuY);UEl4_YEHQ~pWhm&=>3Ia`5pEvPJP zkY@QdDagC{Zbsy_fK~G}O7gbk{dfN4)+3?#&R#cBY@=;V{eqj8-P5i{H?#2;xz>Mu zb@k{?tCbDYc6Art*;~DR@;Zlb2_{en-qlhRR9ba!t=#e4{NH;`hwZaWv&E{WWvWj6 z`h0%y{2v`t9;t@_xJbijn*YE zCWIUOIOcb6Tfz0%^3JU*zZB1(Q4=@o|EtyOqwd59z7c$&%fj?_scpGW!*QpAyQxeT z?028CHB<>OFfQhJBEI3->eWX1LKD`;s<6JemAdIb8}C+m-T4dVrk|T5xY6EER!Yz0N!GLq*Hj`=iueek(*L3YU=rkopYML zfNLhG3B|yq@W80?y~qA{`oHxz`zwViy!x2= zFD@>2zf!j)>#En8b=kjlQcL@9`CZPNV_Ce6WBaeKuV+77_5RJme%EOig3>11E&P4= z{3;N21yjt@m8cbVINuV;I)yM(V`NeXC7!uJ1S zXPdlc{+8dFd3o8@Jp1pR?sAnXY4R^>@&#`Tz1j>K8aVT9mcoNeOTEK>eR;XH*n6(k zR@d~**$)=I&smVXWzF;X^>Nj+Irq$#-8gaj0qer1*6CJ3ppAt$_{AiI9aK1WI5BwN zi9N`-RDpqsO=!o|954NZ>+e<@_1542^mEIUFCNxSzu)cl-+kr?OHh-wU@U0HS~q%I zkLNdU{k=<`ot?eBWm@^a)7vgCc0Zo7TGM>F*HkaltScV7Ek%B4|LRy6n|Fa#FKUZM z$+{mG7CJZgJ(B-l$yxLK++5MxKOxQR{9^XE?{Yu*xl>GIC2NWk$UO&sFfP^(Ss=pV zpwPkciPNHXTFSqI&~+cHFPP`uS@Ggb{96gFur(`U(~_9F#r5@;bvKv%yRjkr`nnaR zck2KD?P4yq+NGH#S(f+2_L`7<^qUvgYI#%7T+=mDIp6<#p{v795wFe9R^{E@1sV!8 zd(Uw#wd737i<{@?+wTYURThcL9ApwWAH9%&<&9>!8*)$WkEgnG{CmvW@4&$F$NPa8 za0sk zJOf`o{GF-4dsop@uaNKVMZ$B9Wlugm78kvkZGPQ~{RK|8Q*Ln1v8gng!t&|s_4xkS z2nLlue?Fh@+O%)=p;qqI*W;>n8RY(7cU>s?#iX%?b9t>N1LH3J*`j`+)|cahXBzJ~ z%TG717O!{|Tm9$9$AW(@f2vPPzHRBLe6#Vm(l*0O(sh5ohF{%RTmALJVSa6^b*I0* z71xX5xcl6t;GEmro12es%TMA3?5#XE$8uG|!KSPW3mo@&DZR;kduwZONm$X1 z*CnwZZs+fRDfD#LoUE&>I&W;KE|2Nr5d64L?9|_VWp8ioyXo~XEcxx7ox!$0pG*d= z16(L0>ZmbgN#LQgB|=V$!Yp?b8W`^KzPbRK5>;aCw0%+7{!nWF|2fi6rpMP^yr)<4 zWO~`mhb-GNFRR^Ay;XO<`kSWm##6J+*H?YNTMlXt{8Rn?=xBG>^dR%xTOns>7&_06 zvu@J(y>sqqn?l~tlQn9V*?Oh0Sj<$Jn$e6;8{vSp*jBZj$wKWMJV@nGkzm*^ZZ&e3&+E?Vd8j@wx2_zv;*2>+f8w zeg8&&^Xpq%S8D|!sdwmg~M>doA|Ulaq_1m*`gRNx8E2P~^Sq>tdx(rRAo- z+&yKk5aZe@Ys;Q|ic7!ywBP>U1>H;AKUJLna<}~c+CP(OE<9eEj__PZwJ|64U}m>2~*<}@6!db9WA8H2hD1^@n3 zmi{Wa)Ai>BqgvVVUh{h^{3BW>Rp|fFUcX1^VeGyAbJ#!6IdVE*H9PFDcEnGgtSLu0 zYySOw{_0-!`_P(emR-A9ew_ItWtyeYxz;1ELhZ}Pkm@V%*`!~vF#fyM0-lt2R9Bdo z^(Vw;#j$#xsTPyE(>>PherFZ_8#JCH@}6_PN#>;0Wfm(zE6)5@75iNOdOd!9?DeOo zr*A#|rQ0Dc?5up1MfUDY)yhv#wCex;(MmqnqZPc&XW@L!pd|tIf4@$Dw1?@BW8?S2 z-@2R+K$Wd*`JIJo{_|vh6+C)+X!U9qy9pn|_srjOhILyrgRnzGUmbYF(`%_ngFrpo z-#raAYn4>L&EIWVEhm5ONT;wf=k2hyQA?-J>^wBfG<#d8P^GW>?RU$g&bml1-s+je z_V>rf#}{Wke*N1*@J=(o-HLTFJCj=G%QSpGCEyoyyfJg4l55V*qw)#ca&IsD_V)I2 zv)o%tK>PB&9=v#(e8wW*X|7f2l{Jx@osMs++{*FR`TG7d$5uBannRm86>|=Fr|e(4 zbD!Mt7Ng4T3$jWUJ_z0ZUrg29=vX?}ku{*U@Atss`JE^2yn4jve`ox4T4L4rKw1B< z9frMvOBG9wg!|M8WodH>E!uKy|Ms;pJ1;GI%(!)P-?PYtM@p{Eu`J$lc$s8b_Q57r zvE0Uu@Am(%(=LB^$L)u-rt+^JE9UkFGfA6fsT};1*x&D(U-4>oAF;x_lDeG zcq;G@)2eV61#a%A4N>a(USX;^8@C@>AHDtDqQ!z+jrx}DwaEDQ>-BosR`=C8Yd~WM zZ*Onk4qB~!UGm1$Zx7q$txkDP-}LP4Y;S{iErGloKN=aP?fAV=^dU1xgToq@pyOH! zjlXTTvd1Q!RDaKFy7Gd~%wLbX^__laX$lyg+%hAl^2ft==hLy1HRf%Tynnt zH_@waL$ZU`3QiW}yK`na&x?D;>!Rl|OB@OLP?!7b!eW(eyKk88%Dug<>$97PcG#JB zy0_M8M{HQ|=+;8#_6a`s#14CYnx+@KN=!E@N>FAAzf!AG1E6{o=gxig$(|*D4gI?L4xtO!#K&=Fa*5ca^^0 zB{s)A^O8zQ&+Y2>d!Kt1%oCXJ)XKGTUF>eHD6aLO3AAOtvzPs-6uxCGyRLK6AKUtn z8=F$SeT?Spi|kk&8Q(g$jjMK_Vgtinb6-w(2L_fT1%-*6FP&_vFC9ymt-Rgq%&ezp zwF~#uys(mrYE8Pc?-_C__$BX{b{(EOdu%phV zvNtybPrv27cY5ZMz$saGca^@_!n~Y&eb&RP@|)Aohk+KhTz-}N`Z3Q(o8YtOrPJH% z|Ns3Sx;AQS&VBt_#q_oL7ZGn zc=uoXIZd;@AL_#G>Q;uV3|cl@YEyr+)I85;lIItQcB<~ldsAw*5_DkGGP@rSn2-Cu zy1hL=1|`2|PS{iV`Ps^Ow$)Y(U&+hvS(@-@bL_d7lB zY`<__S=2&Yf@y{$zfbVtKmmqE6^uosUm_dS<4vz>Z3`zfY&fhyDKcHrU_hW6NW^&(?RpsLYt*SiUFPVPQL{ zkrI%6Fa$hN_wl^W^`$Cx*Ay1t-}?Og{OeCY+ZXMz6L^1T=Vq ~)j>Uhe;*Cvp3! z?Dcz}P0L#R<&(Sc-PY-${h_E%JG>w@c^UL=&cUrqdcOHoGOSJZK=mz_?#U-PQ><(EG;JDr6@l)Sf zCZ4_0=I0EpEBk-n*qAJPIepb4&>Ho#v(4M@Df>-3*vxLdQco$?>G=Zby-~VK4m&I^ zfL1;1`uWg?15`^~GJc`%qgMO0>z^U-dB0yv3zogS9$#-eW#vrcIP<(a5umLQcWmcX zx&$t~=^m%GX7?10K&R~NMp+pXDCzAyN__QNC}yYv~xDxbGC zJUu;K``%`~K#L0SSt>5oe$SrIuh&a5ULU{_^e|W2PxM^IInk&4S)|NzR+PQHwRDzg z_A?GSySYiv&&}<7(dE*4L9WElrk#mto_Yhr-Os)p><$bpCIS;?IGz_dulMuiH3@}) zW%niC`TYpvoO!Fa$5CPa!|L~Yzpwi8^73&7)sNB9+j2COu6H{vJ@>M#%74S`HG1)_1M%^U2Dwm^)!86EAnn>WjRr@%Fz<>gj2|yM2UNi_)?>FRhEU=G-`M^2ybrparpa z-xWPQB{^|v{O)8mh&9qF&p&>8p^Z`8q21a#Gk24GI%bahVKet3JC{}3mU7_E%l)rla z`Xy^!w&L`3{p|3|dn${c9@k~M*zo9p(;~=R&P1cRUOvZeKD1n^Pj{*;h_%P|afExUkr*9W>Qhpop;CTZrYc> zoAYhinJJq8xa!|N>J|8LT7Q4Xjf3fKi#4{UpPzT3uD&y9xt}cO#$zXIzFrN#dTnj= z(YIAkCc0mlVVHd6>yJ>!>+51e`{it1?%v*z*bJ&9R`hwaaGzZe--X?$&lTApy|*Lkq8k?EG>ee}8@L z{*?E7J81dHtHb>ETk4tD`Aj%4JAdCwDbp+!ujgyG-wOimOIpFV`%wMwx8}R2Ke7_w z0QCf*yEG>-G;aQqFV1qJV1itD&)xQOH&2#M_n!X8exl;WJ$q|@e%dwr(Bw}${`bh) zMjiR~>+9?86Q;fz`sUN`WffiaHP>93%dzZZ$)R~CC#$cH&fgpABU-=3P_H9~Z^9nfyK@Dy2?@N9Cw$PW?$3rvlD+(^y^FJ#xvJixy8fg9K8GfXy@MtG9GNHrcIOoF3r2Ut4sK} zrc#AZX)}KnRmMt4zQB)|5Bw7hkX2?YH~&vNy$7-bL6n z3K_r9nRj02nen9NsJQC4rlqf@9BC3;dTV?B`|34wczULLc~1i^{nv}#<*{mm?(Fcn zAJ`9q4n3(m_IEC8f&HVaHihT4>U*9-K07OCF{WKmjS@40j*}gTXJMOYT_d;a+%5$^L0+NhL8hB@;`T%= zKd%@msvTx>DSWP5pu&Q=(J}uQZ(dzG>y>1rw0WLL@~NEq9}n5jZ|JyoL4AHr&=keB z4jVwLpfk>P|Fpa1o_mptvD3cmRWVyM4@fBcs`cjDQqt*yTiXaY;9IsGhcM!{o3!HA5xa-Mr|p$A^rU7M|O_J z?>Fp?Cae4BUHq4NT=w?1+}WlD4;(;Sx)%LAy7Beh-P<4AsV(_1ulk+f*YcM^-}gyh z4wK`&zmNNy0oy&;0P}v15D}>x%TjzyepFrU5R7MX`}5_pzYw!(a@r!5o#n5u`L@WG zOGdrY%iLACNi%!5g!ePg^i|T&H|I5LIB(Z*jt zebCY_SMO)CpUo9rXPe~;eVtpxvE$kN3&)q7{UXAV&N31FtUT$v%=sIaGnx8+%$*_RC82(*X}+yF z*HfSf7r_a*k8}&r|zz1d)hXckeKP0v&GhLguQ!Dt{84X{y;!P@dkG3qX zDfwNpb`QH;g#%}*GT+Lq+uPPIV%)Mtdfn;zcRQbpyv-Kdyg2prw4_bGf;uxpbiAkO zbWQ&5Ddraywy&o0>Xyu4)AVyPo}t@PFY|1B-O2j<+uPs%ldNyIxfeV=*(mDn$LZ^7?<^S-Q|6OZ;gC~Jx(sY zqTFwzlqQzG@L4}Y_4jw8mmh9Ru$x}_?#|Anv?u51$Ctjn73#B3v*~!Btacigu4(wr zqNhR=>z|wuyt=2dICQZa?@`GYzS_oVX9V8PfB0wb%Vo2j)U7>4Z~anKwesAVes0dh z3)QYpNHfwq+#B3??3#Y}Y;t)9XJV=OG{IX}e?IEgfA#J5qR7hKuWV~&^`DBrF#kWv zv$>>uddsi1I+2@P=E$Z$`&PY>-y%r{v=Ym(M&wW1J>g5|{nvbY`M6Pnd3O`Hn2yG= z%x7n2mYuy&c6V3lYn4Bd&+dI-oaN{s4_Z2%%n4eqa8Lb1a|8GG_^BtG1(UsBURt{K zcG;gFg`gwMvZiOxI>5#&)iUjwm)N}2B@Uh+e;%#VjNX>Rd3KJM*u2^|S65G8!lj(z zKikar44-Bim zk|fwFHc-ZG=w`{9kk`5X*UgMu3!ApBWM^~~@$mkU3+i_ti2CeOWMsZ@-)H%qb1eT| zTI&7GvEzV}pU+fvf4Rc6{5>DtSi&m5Uz()q-L+xL4BP*&*YDT4C8m_L{)w?g$_at% z)*fePnY!*+>NWM$$CL`~ur(7tq&9XxW?#X^2+b}63I}HEsIu{vW~NNP|Mg<51ar}o z6ASN_%LTA4y;J-B?yaAy*W|m!bh8434Ez^8eZ2Y8v$NXgKjz2 zXYAq@*NdpBnR%f)EasgvzirCLj|q9AcH3jRWb@4nHr0GOsV=myM$JI4!2@bB1LJf~ z88HcluZi9)`u*PUBVmo@WsAzv&dj)Y z>F+}&p$ojyW+I6*=YfN56-}pPsmRe(^tsd#CqSeok9#*e_-3 zb+PgZXl?JKvLJ!QvrMzq)*WYIoRZR^K)~9O(w6i z`+a8a$y>|k*F_!4U0F9}#zv>=3s28wi7ez>2v#wf|oR}MKm4BZjJ>F!$eZhl< zZD#!H8Q0cC3fcK=`#j%f9V6pq&IGo*U&NYf6&RTOgl}jp_>eZ~AC%A7id#>0ck&o)!8B+UxaD zEu`ja_44!{;q1+zRW4gXZZ3L!Q|4jyzdx0)&zj%gqM;%F(*5BtwOr$ZBmTitK<(WY zW7*wHj~@MguiF2}zJk98PTv3A$>KL1G~ZZ|dw<{F$TU` zMn}und}us+b4#h1-;Xaxg#9D-m{>{OF1ahb#I6inBb6d`f%$ivyw?dG1*)xovOv>%vN-oErvjzX|t0?CTR*z{AqQk+D6;~>2`BwWE9}f2MSnWM{F7?*>m0@dVmCbDDmk;}sV;%S+d0xvb zZ}21uEbwZXYIJ6OTmSp>v$NR`uDo&4sai5^r*W{|adQt)(Ru6lM3?(1Gi{`!7dS9> zZ#opcHS6l8S!TIeTQe^od&CmoD{a25;-`gvEa>3ILOaup2c7QT+1Hovy{q(gL(a`j zGv3zxd^+7VXY#Ax8&BwltOz)>XOWznq*KW_Fe;*jdK*ce5 z8?J}I3QdE84P4@SZ|<<|mvDk*9%`Tqa!_xnoG9KXK5m!E1o@tzCgFUv-= zTF)d0hM5WvOc-?v%V$}90rd?V4-|1KYt9r{zu#6tF?#u#u(eSuLA$3#e)g}?jozkl zZj=m7q;493L)O zcRs%MPIagB9*4c2lhu;a_IfaOQB|KT>?!?DkH z-`9`aiVP-YV5yUlFLRw)4-&vnMC1dW&7%nCyO3o=q=q z&kL_f2fU_gS-$+VzhtU*xZmz~^Xvab?mpAP!Zo+K?xx`5h47={4u~?@w63X@SJjoD zFZwdhcKf>Z5gQkk{eNr>T5^21=xpd-lh@j(LKoeir8c?0gu7_x`+dK+d|zn&evh%* zlA4pQ;tAqjq!O_m|7(U(2)px?ep; zQrAHfHWc5W%yP+t$E^7IIoay2l-te=Zs}%TRU4`Keqq( zBiZLp(q7BjUtez3+Eso^S(DbfcfS3mmSpLp@8yeAN*Gk(b?fwBxmy^HDlC}D@NGeM3uho`7*hGe&b7~$xV=@LoqQ+% zzT5qtY4*c8c6A!(viyw?E$aEJH0QgN{|tkJ`tMxcvfCRAsZRTQ=JWIO(+ytA&or@K z4;s(EwB%u{ujlltudiBnyWD=C=@vhGO$O`5|C$%?&3aKQ#L2NfRBa3UUE}}Tv+_+i zzKAliyx5oJXTi**uwdo^sk5J)9@+i-@z_|XNHwL%?0eSLRh}LH+@CeEa*NFE)LwNs z@ka<^WorFMTl96lf`D&{$R&yPplpdFPH?>xGleSOWv|51w~)2G_k|64Kh>u!A8x-l+diO0kU*CRFd>c=m~W-OhaH}U_(@;^Tc zIb}~g(sLAr_dX4n(of2*_5P?KdAaW6*Jdfv3umT={TF_0S@|iYH>}!Ug~59@4a>GFHJJfj|-gr z=#8{ZMZuC~nR`J8P~ZAnl6A9go=xSJ+kS6@4s7_ye1@@c1!$3{R?ZGi76%0fmVFoB zzV4H?-t>B!re=SCT-Nn= z8R7GdQoY_92@6%cxnam@yWg9m)d${q+|2PsrFcvI%jJ&SuFVw5Omy#)+4$m2;#(P^ zB=6>;%yJvW`P2SIm*215u6#!I*N^|n?{yAr(b{Kkr@*TeJISl#(%s&YTZ~E?y{)aR zOj;UUixiUn3QQ1iSt^~$vc#Ej>2Bv)zwMv@-Mnkv?%(%j6hE%r|JmmAo>S-M{J8V` z-M!-UXEM8uEO*zwzqgmUu=kGHr2Xw>JJrncFD`Q37F+pt>vfl$tb2QQ=FUz#J4-bw zIHv7O(V=aa|OF=iAlpI#K@N z%uM5LzRO)EDVbT;c6vTP?E0qb@Aro7GpeuF{r_7o_#f0deJAu*Xwrt*Cjq-}OlD8_}3w*EHYIgSY*PE zMd#0Zy=aWQ_;*p-`FU$+nPfgn56-d)l_(LBrdfoW4uMOF(-Z`<{5o3!j{(JKJln)mCNcxju46DIJqva-KUo zReO5Jof}TAMmydMnagm2?snn05X;01+Ns#6w!vfjSNs2eiXSkQq9yGE$=_iWm#jJ?h zmXlc(w}tP{w%ple*DafOPj)-K)^FKy>+s{=QZIAfZ4r&xeLsygNN#e#KCaHNZ8?#g z8~;z*nLXV@r}y*oN8x;2ca$0!?&@B;0NS^e!gRVs+Ml!N(wp1c{kKOHR{r_$?c44A z?$@1b6P}!yxKJo%Z`IeJGw|MxUh0ni}LhM>F3{N)YVMh`E2LqWB0pDUS6^k zo&2CC&hh)Iz;6|XSM%OnI>@!_#?$5p9EuGLwoZB~cNiE21XMq4ZuufFkA6K8YLIY%A#{NQ0r~rWE?X6~ zb=Cbde{Rn^HC1~xs1g40@XrH{%u}apPuSNga?GG}u8QBQ`I~pXyuAE+-{;-$_XW>6 zcsH|nm#>}S-?+Q`gO~Yi3=zM_q_o@cqZw9@s@+wa#EKY6r#ew|j5_E(SJ$)wd z`Q_d6`&+Z8Ev?MGy>04;h3+D@{RcwfrHayl(|4ofwKB3-ENz$C&kLH$-uh|7>FL|< zN^g04Z$W73e#K9B<`q9bC;9*P{r^0xlJlROoP2!hYgg^3Y)`ce!q&&V-T8lF3TXY6 z%ewnZy{F40Ms3TP*%ABa_kw_hPRHKe-JN^;`x)c&9XGcXK6blZc5|-BPW2;yJSVAi z9(;QKPKJ{{zx=Vu@XgE)C4w*V%^Q4j?%mp&eYZkR=(1uc^G&_%b=-e0y30$t_sIx; zwmi{P`J9>k&0MQeBaPEr19z2VHlJ&eUKzA>)1L?P)qJIzH_Tu8=UazTIoi|<6Z|mM% zoNQ2^e>m1(-9G>7s;PX&z9)BlK4-03vr;CuU*&_@Bua+P@mF=Pg;t)OZ602ucPW2u($TJkEGcvT&I!x;lQ!@Dn}L;jMC0X{K|i~MQXjqitlszC*}y`+K1`y{W2*`{AKI3OB1=9!*)4W z3M`SjpYPnx7aCJ!u+XgjUyZB2q0|2EJ~>;hR41JVmL3t?SMoCG>H|wD`d@wz}Zsk3sGz>$$tu2?MyWwDoXus5E9ck!@|3kM z^U*DsVnxyW(E?RW`iOmEW_leNWkA_9Jw_MZmrt$*lq z@!MzTc0SJ^%{=e^)s;1sigAAE5|9F0-(bnaof%PE?0mL=QOvwFmp7%HTm;&6IMup5Z>m-4s|)E}BAQO~Pfk(| z-hQttJL9Rkd!Nigf2(HMU!WGsi|2n%{y)Fz=l)99{_SnY*Sz^St?*uz_w&c1wiWH$ zCVZ~Ax9@ax+RqgX|IMX1j<`2`V$WbdoXTCg1+fzV*?cjpQ6stVUO&r=qZ7W}w~d+PA3ob4v8n9$pC5al=RBXTAAhY?H_lR6-Oohh zd9${Sd#{x0EAN=KW8(jvS0pZ-M-&{*Xbrv&xh^sHTd{2S$8GQL?XA|f z%3rr)&aAwToTnDc$gF$W6{s@h%=@O-eGZBo96}BadK}`592r=YCLJi@T%S?Bq9sB< zrEK5AFU7xd{9>zhW%cKLa(aH*-+t{ffAO7n_Y|;O$qFpUy~>w%+};#4%#r%35;U0` zw>!q3b4}FNRc6I6T9;KlpIhz}`SSO-x2t{ENjjdl`Rt>iyzjQ}3!Yz$+y6G$2~1FF zV2GWhm(t9@;iA+iDdbnkd!Hk-|AKS6Ph*Z=U);oBmpDG2Ej3rNy-_He;UMa@W`Vk| z)@P0%_p0B6>(wbG6`Q@MXb9E?%n$?}?q^&5Ekx2NB>=R)(W>xKOY+PxmM5pCdVhU+ z`S>Z3++<77We$hAb}@u>eCcaAlb`J;Y{ zbW3~MBi%3eudb+n*lOr_{UrY<&{F9OcN_llaW3%^{e159!UYkRcXBm`{C?2PFEZ6= ziqQL+G2dRU+x>3S+WD`y-miYY7kqri8IMOtyComD@yV|GThT1J*XG%m%!yqY)n{KF zw-Df90-e6I!)t>ei^G9@7ME|b=VzOr&#$|+b-DW5McbF&>#RzDmAk@!!6ld2%&UA) z3v_~HjnjILN=nFOvZyfaTphl?EAdfLYu>!2V#O+b4<@O4M+KEWJtYci$X#9R&Og<* zy3F;d#?>XBlXXsBu-%b+d)uni)6;exoi)w9^n!2yRs#X;7h(yC8sIVk92IMxO!?-s zWy{+OZ(DY)d%f7<@QZtUcbAn3T|ew^lzH{!*KF3-e~KTD%hzZ8KQ~1;I_%Ct@wf`d z-FM^a^+5x^k6&C|ypZR|^>wk_hEFzSOPlAJq@9_Oxaa@B-)v9&4PISan_b{(w*GDJ z+WAE+64%$qi|>EesktJ4|2~$M99+21;^W2w&mPh^mljA5)Z*}o26Hi-){T;&{{J2u&?=D z5sCj|x=~L~nfm*1$_h?+5PJF6{QMp^#(LocV&(Pm@)7Jz3J>C$j8%PRTNEy8iMW3< z=fZ-0Y;N;!4Ucjyw)Y*6dsT;ex3YWMf_^YgCi87nr{y!$oLU9Qkq zUgYm=hxKuLuQ>DDKCu+j)81bHzmC(o06Y;<<;K9cEB(bn2^I&12Q1qr|DCfiCi`(p zz{O2na?*FY_4lnPdvjx<-M=5nN4HM7_|I1%eqW7)&`}l@qjm8+9_0BLSAEI2y3BXB z#=fq5JI?KozF+q{H-F0Ui>FpUmsygXx7_2N;aMX^J{B9*2}gq82JnG;IS17)%s*2f zx}Cf9)s;ZODHrdG&HMQH`0BvLZmwQ0Eu(po)SjN187ym2a9|>j@#OTgvzESCv-{WQ z^Y)_b`Jl}dk8=p6&AIlFt1c; zX1hmD>5bW0WVtI{J7h(|1{ss@99y!lpSx(<{oZbE^!9btd@UEhoYvnju}9b1xs504 zuTIpK6%#Fs)7Ba--S^q=Y0yot`!VN#@I0JayWH-W@&8zxNuU-ID0Vp-9AcPOv&vcZ z+}T*Z_K#qZDKk+-{(ac9TIiKf|Mr|mwko7E+%EtS9LW1FL@ zjPt)bQ-DmkXi$>Ac!m{QokMVqVMfq`X@ z!iC9G_$CFMk*u&3)}Lj|G=;_c>>SJB!fy|bc8j+gP5HeyFv!LbSb>>XeR)*CT)R%iFKJacpn(_qMEz_qVtE$L_5P{rmNL{K7TgrZ@xz9

j zxJN5+kxSFQl9!iU10SrPJO4UU^_LfdziKBcxpJ-d}HVabbt#a>gj64wjo_b(HQW82#^ z@yLtLoO62mto45-g-rT7HAcypwqa^ z#3`xtz>dG)Zu8zc_3~Sj@E2DJ#+9NsX8fLa{*QI!&Sko z{pi>+3v~R(iT4tApJjD(zr47p#IyF!xau!c zAcyc65TEjPNk zk6}kra8K>gZgKOlwNXz$PTjD6-s|h$fBSxZx$OT|TI|3~&~8o%Z`tcBLRJPHdvLIs z*~6@E@=lp$e0qf`I()ywB@s6@Et++}_sQSH#`XypntA8W?U~VTYVpX9(N1lmil-3I zN%5<&wE&&%PbyMBovL`_HuJi3bjkZ2kNK|Wc)ZyCRzgDKSV zLQ1N^kq>$N`&IiM8+FV%VRT9AJ(KW{+ZLLu=36|lfi|uh8Z?>qvdTIAtJ|<}Q})Df zci8G^)lNW@S=H8o7uqk!Q=w|gMM}YjtKj^9A%cBbH%^GcCc-Lw5Pt=Qws=I?e(b0Cjx*SGVfkp2{|tZ8dSK?=LKD{`m9xeCd!? z7w-$OtPx(-c<;)W_*5R2Mg~C#*)I&SIy1PK6a*xgTu)reopdcoNU!w$-tS(k8s2cI zI?Ox}`u<*x5VLNZ!^1qOa?}?2=Ku4VXR~ux-QOxmzE3|lM=Sr{p04+r|CSuE z`Qn-Wr*x*6ho$-5lHiWX&%(N%ti7%y{K(-zG3a2){Vbp(z7(7|c@+0odHf7p<|DZ^ zjW@j1nVIo5%ZfEKXIYi5`r0XIqYS#{=va^BDz{##ecwMlI@%4|Hq&LVdK)xuUiI~r z>Pn_fiyJ@%Sja-BRuvmxcc=5-pp!X2OmYa)pXv$tg;rZcd=VCvOgreGn?z&-Jv@Byw}->)-(=1yJo8uvY!^}_B->gj1KPfgW! z*K@2;^JelK%KR@qIQl45CTv8Twb!G5z(b@o^NR}1zc2~XI`Mkt>>lBu-%eo?; zpd}pxi_&a|tfGAR(v4>hl%$0z%;k4+6K0H36y0sF`o7llrmEKz1JJ-wowUy^lam>D zb`&=Kc^Olzk$7`e=;}vXpPp2oU-I?V-Y=KDANed$_{706b)&TC&3^t5@XPcZx*ViW zIy9wTHoJ17dQr3cI-vz`FRf#%x^$mY_S0;WOr;`Tjhiz*zFNIr>gMM3?MMDRogV+M z-*!t^-V*QW=O)Q4&(ZkbYFPiTM$k+^Y9>q8)m5s6{reQZx=R;97Z)0*@Zr>RGFLE0y=i1 zR{ZtV)#}FzpPZQZe^dI~TU(QMo%!_U!op@y%J%bpfZx&T zFzLYhH2Jc(J*Q`xYKLuF^mu0Y9dA43+~;yVS1jkO>1FP1xwS5KcaLK;o8*+IcSQ4C zyF`BWYySQ9wb-?MNA{W9AL{@8O#fId!qw#X0CWf64*hbke+%1kV1d;5LNP%5&f&F} z=YzW52P?9gr|wgKaP?-|^81V{f6lp*dv{mq!q;x97kk$4|99)bn=7i`)247Z96Gfm z>f8UF?Q->hK5qEDB*oL^{`^2NsdU@+7&0d<3r z2Z>MP`5kV&())ct()W`6?>EMs?b*6U!Am?Ay7ogvf7gr60fVkGzn~ zgreL$_WM&EKr=q!P31?IcuuZ)8@w&&X3x2~)}Tq`4?oVCE&q3Brtz^;Q?+{|H>b6p zyZ-*>=HqvcXviORcWT);JvH{HH!or`JJ9uk`$G2VH~3v*>i@oXJKtrx=uf5KJ8K1l zoEru!+uv3^4O<;{_5n+9TGPVK>F1^9)E{hpKPA89$(fnP7gt->{i(QrW7dsQ&5#un z4lccwc79%N%+8{t2W3~4zxwm@bMN)I>a#0?mU``x$>06fY;pSedB^%>t-omXDP+dv zIy|thG+Z@L5M&Lsmge48 zDouKNYUK zTofxS{r~s-Y@_b=;miHzUICqBmbGU-dtg|FtK--Ew%OO#fKK6jct88qrKR2r&reqO z*E$uxfKSdw;?vIy3!S^pP3+!%bysP&>+}Cdzp^+o#Hi%^3O5(r_xbd{uj$3ZmC;Mq-8!KEoddME$nEZ~Qs29~W5jyHohyGEvHCo6 zbNe*&3+N{2XWR4d+bwqMm0GrL>WBA>I<`GryZzp#np~yALx)0%lgpK#& z>i?Er-Ctk-TG;Tg2;;uv-{0L`tr5I;<;RIu9pxK7_=z=6>r0s@K7o58JozYm&}Z87 zHzw<-;0E98fsf-RU!wlLSD{w5_FEy; zY>SDv#N%ro?uxt1wY&WNI?%34Umf*l($-};FId^+-5oBwCwzT%b)ib>#alm~@~b}+ z&iKrd;-tdyqmO~91Phabz)=>9fVihk|7Ut0zkj-5%cOJqY-+m~h-*0<5N49K zDha6hX4TQV`Of+I_VJ*ZUZrQBBfo+6*=)gIScd(>-5*1*=Xo?q49XgmFaB%9w^H&G`euue7zE!SF>K`wMOWw zDUO|YdX(M!c2wCe_n+VA^L|#{_q=<1ZeGoPuAch!_4V>UvK`O!AIz`Fff^1fs@HSa zybEeL#~;|7%=&WX3&s42^X0xIaC5v+`*0(<-;;$uDrH;#{d)^OpWYR_O{f3#^N-$4 z;`RKlbM(x;IHUG$(DPZa_OIKjkd-Ry)Wa1WLC5Taj1^#DJkPP`;iJQaZ_d0kzi51i zQ+(dz1xze9$`@7yDt9s*ns#RQyIrRxOfn`E{`paOzCvY5#f=S#Y*SZlemcE-|Nffv z_&yoSnsVK{Mj5B3Xa-$hJUhL<7c?pf9?f-NV967h@!*m3JMJ};TYu$WqT6O1vE$=2OyC=Qg-MaRDzs;wP%xx3RHUuyCOMG8H zyZ-vAhbLiXf`(w!4s_a>->8|f@y~>ieKkMDmEI-_{%de>V)2_}k$7cg@bORIkDUBI z@ziX|`E|cm7Jhqk(;;rg%HZWvyiz6wQ)dd_i#z*t^Ph{iKqn$~{!X5Ly}oCmJgB&X z6d_3*QE zSINqS*{7}N->iGL^LY>GX0}I}aux*#Bn%Q70#^hmt~{UWBKZV0$0u$6GxI{5NfeedgC|;PqWX~$sAPL3o_v?1gGR>a$$lpYuLyc*& znr~3@@xD-QF`a-dtagFdi=UlY`RV!j^;+TU)^LgGNc?*8{>)kP`!c>K{(UQbc4p?Q z+4=i8KXzX`_TB&WwY7_{*18^Fa^=<4)vAB=9h}NN!Ce()MwSop&$iUw zEjRmpP(e$7*|8qU#Tn82e|^0k|2JXM4&KVo&q9^mdIGlWjg6TeFDheQ<^#Ie@X(%k zj|^ANgA+KJ>QoyT?ye7KD+67`a-g2`$%6VQPuum<1@HF#es{sk3Owa`LvcgVQ?H|| zPYJ8}1ne$XDl4)!}V{mn>X4-LAHBizIGw|BLzZ#oT;X z^TOs@mzP1U5oC-Djo+Fzb(VE`p2o=;;*8eMZ=aZ|J^j%i=|7$~e}tZ#q#8QYD0R^b zuN%dsr>1DGs{H)yo0_^^_xAkKi2^(`6&|EBaa{OYQ<@+RO7ALu2~vM|Y>b`&TCtOL zZOzMRRxdzz4+JsY-j*8-x^M9HwYA);v#cvVEV#8bd-`M1TRt<5TAT9D9f${4iWe8T zI?tc;g7>UkW7*qVD<>+u-E~pAotdcY zuJPKgUQ92>;>-PvUz{nYr}@g-R)uVT;H@&j_d*Gg zhWE?oYfrsba2L`Stno{@wIy?*@h_%ayOV3Q6~vVs4}52t^y{9J1P5sPL}7wNqwJT% z?JMV(FkjwL`1no$vn4H!~zuJpX%9QW^UMX%mdcIba~n*TXyF1UvweRplxt>u@O`+Ki$ zfZjtrU--wj+xbg%o_v0up&+o8MPPyZ+okP~LF2_<51c=}mi4?pfin^^r`yo*pR-`^ zFV}7{Pf4pd@Ld@Kpt~{-g*JiK3o9h_9?&+aS+P~~nVY)zG#}9U;dc^xAX@@DJecYp38Wl*Ho=tu1=8U6b=m>bF50e zdgW}RPCeQPzW=7liGi^yV4cVt7Etx}nniAb=A0b&=uz(Cx5U^pAul+I+ zbOz0ohrvr&ob@Ij7fmK|H7=GjzUS?JuZvL@ccDH}Y1!y&}DW&!)lEbxIj0vr4i#Cq^L}fD^2Y znM@oPmU23SPb~Q{*}>T8^+M@Jt9>{ zhk=ow1GJpRcea_Y*Jnndn$=SZPOvsA2supJp%7I7YMP`_%dj}*tgHd06gUM$Fm{q%6rw*R>A9E`*SBk{VB`@ zTB;zb6%z3L+}vU%wT(MiWvhO$Pt}FO;7D zJNw!i&1ty?2PFQR$ud@{#DMSLV_=dKT;T9mF6i#mDp`b|7@2%$nFL;5?k_&!&-N4B zU+j;Y9Kvw3iX(twUYm;OlDJ7$@}3%ww$@**SAO=MHd`lam&;?z=V#|%`5qYWTPyuF zl;hr1r-rO@?DwjHv9d?KTk!!>T3qX3#71dTxhQOnqUp`Da#ZF)>nIue$;#wvyPP)w0lfb5oIC^*4>L>?@1Em2Ua3ZqWNHU1Wtnr;-563&%ZK z8zezmm0B2BU*%8IepIcc%pwk2&&t5Kmc>F+M!mIoq2!Wgb_^Ux6dfFYz5U`}W4G7%0c7%OhjT;o zXVA@=-QuyH%g(7@-LXY#7BiE`jKxz{+Sa`fn(%MZ-j(mpJ2kwsD+XO-!@wxe(aym7 zYEJC8$XDwb1VBD+Xpm`K8N7TIX#3%=Yn46B#V_pNP5Z3&Ni{g(Ui+RmPIHA1EWD|_ zp>vt7d!yC;{(X5I7iw!O6J$V|UE~?Lu6&+&-9I?r|L?RH$_)LWMu0=#fiEvFU$y;y z=kc{umexUyzqBm-mBNi!pZz&B>+{x>{uuq(?{Ap7E>-VZceTlh1+fgLp_)Y_;5qxG zeOIh^Ef<{ysst2@IM2+r4!^oS{=P4}rNFNPzO54%bTbvNi#->;N!zW--tNo8^i3~4 zxvp&geZlOC#u$gve&SvS{e zez5=BiIM@}oZP7V0d!_^pKNUZ&n}@AxsANW=Vrd#s(XPSlMl-DsnDDP}yV{@qWh^i1 zc5rQA1f^St1A>jxTd%xVRXiVX{-KA28n|FNz{w+F;PCa;(WS>@^G|ywi(cQ#=A+2^ zO!H*Qy|A-ay)OK5evrv^sl6hXkEvw+dWJ6`T?`x<$_|ZI|6^Z!%{~7q^pctcxMo*i zVEOju=HgvtZ&xkzo&BtJYrBW0ytUPX)=vvwEO{^|`w;(PlPU^&7OupzFe#oqmIp`oe(xTdmG{P3_{Udt}O?&&E}eVttnUbBPdzlWM8 zJh$j)fJwb@hMVKBko7(;4evxNUqD8F3tA8KR=wh%Xk@p#Znm};WM@^3(ue2s>sQIy zR#j}xl6#z5{HtG6Z>NlfsmP4todNf(&Q=C1ZTuL$@b8uL!O!Q4Twf8t|KrRayZlA- zdadLgPkY^cZ>aG*xVh1|BkM_z9{bCmz3{p>s0rj+Ohndyf4Rvy$kr}LXzw}p#=_e!;N~q;;XP$vOpOkhKV7+}O)%V^bGAklaJ=VS=8vHw8$N06{N^@i z$2aT$j5#iQ#l9Z8HT8zDMORH;cK)irksR>06+>f#@B)Xq+wXjQ<*)rJRP}D;<}}|G zVjq8ed@LL?Svy=0w1VM6SHz_y6F1yY@)X(Rs9?pp2h<&WyZwF`=$yUl3_o;A^Vj!& zSX{?tk*~hnZsENP{ojrzUzYr3eolVF#9u+Lq%{nlGTfc)_9tuNqw2gbbLL5W?7!6B zc{IX2*P-E^TJ8%-Q~QH1BiFUcZrS|C`WaPObKCa)d^Q_2zqrg*Oe@3#bhFOY)#2yA z$ndZ*3UuT!U0&`VzPI{&Sj_!9>}&0B9^gEG;gP_OiA(=V|9bw$t}S^&F87M_%k27@ z0^;w4eEg_1um8gS&wblZ$$fkh%Y3x+qUZK6$`0k-CZHZI=p5xH2G&<6PX_o^9EpBw zWnsE2c)4HJkq*IaM?QSJ`upAP^Ved0K<6a#Fo7;p)ZhPS)2~;n*Z+AGU~lwq>-K2;Sah@-OvO+@76sZhL;HHfr-S?$VwC zN!p-eVKpMo`;^%`>@_T{v+zhg%71Uwz5Vw3CO5P9oUQ%&>FFvbR{LqZrxjpp0iK=T z_*^&*bQHF_LB<7zukUuh*W$ZWd#U2;oqzhK^DPt;*;pscSvq%h>yNd$3e6T8|EDzh z_;2QX#o#<=^+cIE!An8yHrz(51ol4_J9b;Hi{Y-Bl@GXE0veMMSyL<|eU71CzqHQ5 zV~cLwo`|a}0+sJ<*kHdtXlYl}t||R2i$DjpayJ?#A6rrP_t(n%b-&O0>wSLp)WKfz ziFmX|#uMGQbIu>}?-ia`k8KRGGKM0M zYSTrkQTpUli(hp;RhNJK$-cE^<+fc%l->J6a&PaN=V5k9Px=od<9%TX+o~;(LO*|f zZCSZ(z0{_y$BQjBJbb+W+sxhddHcpHJ@fgKpG{|N)|hc;x%-m(r2_TqR{mrB>K?mk zlVssst+m{YyG#-xr|k)JWH5=WNmpWjzwF%7lB`XeK^s)&yzmWQ9ld?sEbH=hdW91} zr??q2&B<>v-u&CZAU$aAird~x9vYw9b#@^`q14He)KJr&x65BXe_y!4i}4BT-MU|~ za5B z0o@v7HCIUybmu`b6R1F_{rxS}dz#M28ze(HM`S0cxE;n(j~N);TYFX6rkDQ_-%HOSA{kurPRvF8_l z+JFY196oTKnQiXRD{mL$JICVU`g1wzhbwM>(62MS;JsTzqNe@J=b1J7x2=Ny>9BTl z?=?B(zbl{R<$dnkTbgEcPpk3Pdc$y}8M+qEL}WHDy8_rjI z*8bfS-}~i~9@m+u3ID#^Zb>wLxz4dsW50?+cRRyIN$>xEmKey`eb&3S;b<(6F6fkh z(AbqGqo2t3fbH*Bhp!JyJw5HJt{7x-&CI*Rh^AFHl#QUf)>8XQc7 zHJ07}IYl#A$>KV%=qCq<2?sttK7JLnYTawPo@~p5KfX=}XPyw8qh9A<@Y6`YsrcT_ z3rq)hZq?WMSk;!6v(fDIr5Ed_xkXF#Fx+L*;ek|)42;4ot7b_gXL_s*TB_4~JVAhg z@jb_%_x1mSUAx6Xo!fXmp5rKQgdX4}LWcRdJg&VU5^3YCKCdFxM4)m|R0@}!Z0BSURN`TID~K;G9M zkNa0IcJI%cwl4Ngw#vlUmiZU-EDx~+2^`Zmj4Qgi_VtqYl3Zuxm((3dy(_r*-LY=o zlhdV@((ei`a6hBV0XjX>fq|vQK|%TEg1^00A0Hh(|Kou937f|6vAg#oPOW->%=}sz1y26eFS*pUHzPAbMf~(}ypuVW7^DONXTcX2ZS&%tS{TS zvq|{@lS`9Biok=Sc7B@=4OurfBnmVY+i{%#y6NXp#iru!?Fwt>l`q!(sq44d*hbCU zx~bUui_e*b;_|CAZe3}nVOmjJL4|DSrb@64NnDuw=5OfyWVY^$6|I7 zH2TWGaz^+8OF_vMm#O;kalSJQ4*qd@@7AYsHRe;{hH^EQaAVdO8RfmNn%Jd1-Ahw4 z%Nw@@$#ZAzj9#9@^1>?9Neq_GJ^ar-zs&pK-|zSTyHoBhjMjV7=#ay7eO)Z`1Qw1x zpU+t@+>|-L_FJTY#9CG5*+Kd4e?0_vzOC$yJ+W@ip>1cCf6n2_o4rA zap$)cehWE}!$vK@`_NB0+o~rMCveZa==$D;F-qhVW94G z{{Fw)Zf(zxFJV@CukJTzh1YbwwQ-eCML`?2_J2-b-ubLp^3~-(c{vPksv~c>)lDqo zXYCbl{p#>%KWB{s%My{dyB@?CMnwtf1}VTd^gnQQG6*nkYo4O;&f?^gwW~4|9?UrK z;o;%X|Ns78{rC6x;Zv_}ZeA{Ba^fvlaN=1Z`3-4jr9d?@TdKD8=LbbGdsogEYZqqa z(zuZ2p68YNH?1kgY%>?@^VzjM#+Emyb^c0yrCyt}JoWO6UqveqUYe%fHvfZ6Y_P7o z*M=rJIWsp%{n*eT$#lzj$8z7<-}r-i9^B!n?cwx(u<^KDaO|!UL(w^#H+;We9}ha4 zAou=0+cj@IBsP@2y%oS@@y$}<`5AllciRK&+pL<3Yt0{S{^fF1`=#A{*5^M@diklH zu+}dNwD+FN{Mq@6f53C0`PD1+m!8wU&>x_$amFL)4~OEzt)(YjXPU;UD6+GFyMMPh zMXvEKh}&EBXF>}bQy*u+gG}`oPp&>W)+@c5m0N7Zot?$j+Ya|LrJb9z613H1ncv)3 z?w=oR?qn{$w|29!1{?cPzo^)~({pqcGxGhp&ZTpoGS{AU{<^)--nE?d`3nv2{1kVX z8o@Q~a{c*5cAdY}Hh0w;^ktvr-|=v=Uvbt8p*GPHgllGTK2d+Zb-jj3?k$sW6X(|V zRUBX5-Mt-FAh)>oc%SSl=XSoTo{tl!yx;$Sp0GQ3w~ngC|7jlz51r_{A~@&t9dFyz zBW+9S{J+n>BAKx{t=MwI#w+{*&p&JX#kqwn`&ql9SglGgQLH0nSqbltquY<%-VyzR z)jxEzxYEW#jtiv$Ej+M%tgwl9E>pYGMLw~A*2)`lZ<}4+o*$p?l=1D&&CSh|j@qnQ z|M*yMFz62F?{|v(qqbxO-uP%IabWe7tt&oXdvw1h!QW+;!@*G1qMqF$)xlmHICsi) z_%GSl_^Vm%ShVaRYyNFP@@{|AR!_E-&<_>1{l>?9J5SMJdoQ0bq#Ne&AfM@K>1L0) zR$o^}=U<&B61Kf^g17*aeEpjBU)K9Y#y$A`Y<7M~uaxN(XMWoy({v&qwQ`1)ehSN2 zxBkwAU+2TrllP=D`A5%7tUII-we#tN8*h(oyk~vodhq_^tWRU+<;i|kkGb&F<*2_& zq*8wKwA^$G+NgNwQ<__o#fm{MJ(C zuR%|j+b?LCV7z$u%{YbB(<`#;D{~HV`Z*n6`Xnl1#^YxfUNW8fbn&#@an5AH1>7-` z9ndzj7So=n34z;>e{nconsL$LfElCTyJfro{&?KK%Qb8IaqYiTwL*hH8%}R+&!1oR zlZk2j1fRIQPuITr%=*MRrGiQ5`KHL%rmtd_-#dG3>yG=S!HG({HeEhnx8U7TzNP|> zAFORI#dCD{8Fw8?Z3GX9Gc;x>El}0;iAgxxoqbbN-1j=;zGI37@9tQ>^#LvG*Nb@| zyZc{GjMzHRy%0}NP5o!`VSiZRgCg;-oQ{STm)S!u@#v7K3XqFBGaYY+m_$YvI{ayIl{L7r*poO|aD4*~Jk1V3mUkq>c#@ys)n+ zZcW6-kU&>~b6o-&5f?rdC+#WIjn(?-^IFF7{5;#M`TKwFF z|5Y9FM{k5P^6Rs1%shO!?}G7zTA|BP{Tks*LR58QoD90PZwZAf1zuCs-}}S!;SqC| z7k)1i^&lSGBCO%aVDz%B;Q8EJ$#r+toZ=ifO!DqT>|Xl&`}=Tdvx>k=mWkn@`PsYv zy-fSnBLD1OWc=0M^i-<`JBvn#m-l7)Vg;p*E4eei)@+^d=0;Nd;{TQBSZ#NOPEl#R z|3WOw`JS0{@fn|okF~c+GnL$aVIT-Dy%|_SGCA2I9H%dknro!#Ay5dq3RJ1+E!SM@ z@^yDtPWrrT(ub-ml~bn)2QB>Bec*43pONBZJHbiP(K^$gynfy!rzzU&VW7VC^O}qA zk2^1^>2F|+xqGw>dGM>DVbzk^jt>vDhOP>+Xj(Trd&{Zpo12z)yzUnFe#5gh|J5?z z*>C)>*-sAld%yTz&o7(5j}!xi8{JJ$c4|N4=lZixe3Gp4x3FLQ@%hq*FYVR0R^NLP zu`+Q#H%HkPUOvWM2Sgho=e{+rP+VZ!T>bUc9A|c3mM;Px^X>MoikbO&;>+C4X=j5# z`_{CtEHlyjtri$`uFZ0JhM)VZrz`!p7|I97C^_7|{qs+;tYT^26N!rcoa^%woH#rr zHoox=&JStdk|%f}_CTi(YK*N|A?$!zJtV zxH9_nbFt@%JIq<+#DcOX+%a_8lzimV%+KvDr8{)zHJ7ZP29gwQu^?&G|j~<-W5%QPCWk za+)gUZaV7oy_MG-*8ZqJ`BDDL-E#v1lUQxpr$;TGZaV$#fg|w_)>jN5?Fa^zDgSuh zfu^4_FS(rCEI$45t-aOTtqLAEXc+jf0i6N`syJkADgsP1FS#uBJuN!nLWv+~bEcHB z+xv63-`?K7x>wqK)uW?ZmnUs_Q}+4U*}Gg9(kB(h2h2~o>EZK%yD`eCO=odK&ddop zVz(Qt)I+8`YDjT!s=xJu>!J_{|0KDa;6Ii{J@Re=HAV18i8=*O~j ztE!UnyI7Ljx0qkeyT z8#>RXQpNXSQGkp>VWtMl^GQpdriP0KeOx->j>N`%?$iIL{{Ss=TdC(3uKufENKRwg ziuOF~PI;yh{&x&3SU@ww0vtAs>zbGSRa_LcHLH>Ju=Z2Xc)((}-k|JjYYL}?&Q6uJ z)2Zw+-Y_Fq`rZP@6@9Md$kY=G?OQm6-V|#`w1VIW7w+SEX!@ zpT8zgh!MNpSS9KBv%dS;9MQ+edbyvn?X3B^X_iUmq+PGq?YRZ8J6rB*CXZTTD` zVjEJla;N(Jk?A*Hy54HGTwU2Tok%DBh@Do4nfYx5W*yk+2)g|WbXi7R)yt(HoWArt z;Q9SW=+4=+Z0#xuX5(9>4Cxo%PC9G@ZG)*Tuyu@ib!BDf(XLyow`J~kn{y@i^|iHG z$NOX#t-do|FZNPi^%m|YMcFlf9MT{EZj^s9+cbMwaE{Za9dU;9>u)&DHP-(>OT}|i zZ6TYz=l}VWs-$PL6;4{;ctthraqg^^%v~H8A|Ibpd7T#fDe2@-M~AeY6YsvrZwpU8 zdn0sHiYMrPzR)Ee6It5%B@7%w*T==${{3<}D*o89#S@sL?-@RDv;8UYb@`csO%`hV zkAAG@KhCu)wrB=BIN1rDW!aK%`o($C+9P@|Zf;I@Uj6ib&1c^i!ByP9&YFAMIJEyDH zw->BmS-fp`*%iS#vsuIsB(}EX%u`aCe$-A|Bf7BQoc>KA?sLgsikZ$I?H1QwscgLQ zPma#ZVw+9>MJ}ZO?w1I=z`BkNT6DPBFy4E#ZfoeO5YN>%v4?)hDCOth*_7IC#N#~u z#)hI#&(F)3@vucGJ46?Ro||LoJo8iOwx6G$TML%AsueG@yyv!W-Y+4pJ^Yq}70K@y zem&XpbOAv2?xt?b^pcV*ha%Y0m>&MuxE zpY&^o+OBu)ukP3V*8L)MJcW;yFXdT4ykjl%*QFv8X2-tV)>WkM`=ELAoyzV4$5%1? z-|Lj#Q`&!gl|v7|O=B^WoQ~iGN##x53*H25?cG!P`Bu=!yXE&+?tZ_|dWuZQ3R9Jx zyNbM8i~}E)H@+?Y!g1kntll3PXtn&$x8b}&R({>d2X()`ybKWgcEA3A?C$#r22Yzyw zn4jxaxVU4<{BL)o4BNiFzU~hiJD+$r`FJ01?R$RNOB-K4wO_VnQGKDd!}qI_C2u7& zWMfl(*uX^)1LJ?;iiti?RDy0r?J9XGGXLYZO`!64ZOl%iEkdu-yl0uLJT=2`G3Y)a zt&kNHN_4Z$V?Qrl2f9+T=I5u(?Y-xheA*VCmA&Hp;&V4&m<2n$`zOZp_MT&cir@m5 z!at|Oo`-!G+H$mZF~ee3mCe%{VvZh<1ue>QHA%0_zdh};T}FP*pVsh&>$9iJxGUTh zo-^ZJOPZ~EXR(^Kk>G;c3){d8M;Mqc`ZVz0y}MZ0VQth_C+!JwTS4`~)z#tJ=0?ju z&paNpv#6En6KD;W)vVnt72Da=e_g)$!u9mh?Ca}Nmo(hDJS*F(wrR}?6^Da2!k^rH zJZsPI)+U3_Pts3M*zHvnPqI97(31V-E-88MsNH32^$IsW{h+lgrR~rD(u=hR-E&LS z1NL`XMAsc`(0wPgT?l$Vu8UFQq+N5hL%Sx2?7m-NI+gjevip)x(tr2+Z@*WSt>J8- zUgtegsr7fC)8qXdA?soys~hV6{`xvaWX^SUS9?ZtjvsRv!r3o~F4(NodF=LW*ISeQ z?N*vvq$@|JU0)Zg`sS(ak990BmONMbYBFo?gGv3<;-g;Gc`vxB-T@t|VvH9&;d!lK zk>=X7-M^l{zP>&jwETkm++=nCbzNe*tD?5&$*!6hyQ3hH<$2V5so#e{hga1XJu+VH z&Dj zLZO*=a&_C39j5P^s~`?e$qGW8QzjIwD#@IfzLCZEDNDiW>H5{F-2TS?-;c)& zLucjO+|>D^G2l0g#pK-qbAP6NTYJbyprD`OZ(h~REtZippK`IhWz{{WsJOfO`@4m* zzPqAdU0E6W_?Xht)2k=0-S)aO`b%(9wfOo4(Rmyfbd?XYKni~iwE)-c?_=txZLi;b z(?W92xnp((vgL8EnO9a!-1WH6T136x`LjOby{ifrez>))QdXDa76C||yIu++K>-iTxJYdFvH z$$8GTXJrlVN?!le-F`=CRp_~;mo7AUH=Mo;I-RVr)AsCI){~D}6;3a0HMz}LsF2Xf zz{M|J&znuJ`Z+r-!Ney1;jChq-o1Pg%$ePEiajCPD%y17a6C zvG%I9iBC1nzV@M6NV4$PmrU2MNms9|48HpCaJ%fuLn-;3ANV*LkMZx^%KF4fg~P?F z(J_dx=#roLtN>S`xBAC~6B4tnt0dNK+qNdLd$)ACb_ry7&4sBkY1iBbQ#0P>nO$4{ zSmx2b+TWnFPOlzn6q9h%TCSLFe^{MYGA zeTtYyfP<6&gzyWKZ!k77+~qSp16keB;l^}pa~9{^>)h43t3p;T(mnlaTkh>EH#R0; zy|mQ(>dnpRhhH6I_%D!gW5dFbou+T^i~bL2R#i}NYM6XAGk=bL%83bzx1Or01gxle ztU6uh!aU3QZ;o;8@)qaMf>vsi8@{=iK0Q7CdyC3^`R6M6HS=P^A8$UBe5@z%^YioJ zpj-S@#fn-uudLJEBt18rDPP=7_K~AP5XT3xce_ii4}U$U?lWUS>hUR&xAo%p<&>?M zT9~D>kuGT(#wxa&Y;lFZ*9eOk8`l{%+fjBQXCt90+Any18Xflw-f*be%|}(CvA5 z11jf;YKMWY#Lj5mRsB8h=v;Xb&^?Y^;(BX*%~)P42Q2rKtv&QlcctOq_Z*rJCvYugICEQU6Wfbjpt@$w_w$H@*$3+{Ih?+pYn;D4Bs#prHAH z_pYf=&d;|O+4F0msAiDL7lZ9NH;uNIz7AWfCTm%wvgK{<EI-XDG(O<(JGOlVu# z+o;k92N+A=-ZDM9^o+%MhgBg$*6Lp?4(R*6+x1#+Yvt!OTc-aLANhr8-3@b=dnJrT)S8dqMx6iX|!!e`~K?&OyFFgu#0n#=R51wzGD3L z3yVy)tq=M1sxhiI7QCGRj6wuiX zxwk^LW?XavHQtu`&9&N6{ot~{{nyn$SHBK z!K*!abv4J9yG%xpyUr*rIQ-4Yf~ll&H6wIOkDznIf4^@NJ{()k^X_5ILzW_$n4$~Q zEQ_BN9M=8&=h9N|te>BrPJ8yF^25Pqc4tP*`H$l^r}<`Fwb{3=_IKIUt=Zv6`Ooe- z^ltmL1&+*`lV5>rpAH75Ie*q{ZIKt%3Yj1v9i|rkRUl*Axx(lz&W~&u!Y=5>vG70^ zeKIf_v%FjEsAL-PcUzO3xZA-dR%g#AKOFTlgKFP@{{HT+v|#Dw@bz)BUK`R?AEe#4 z%)FdFzc%gJz2e+6p!*&#E%Vi0=wF?d#i^_)%wnT-q4P`Eocf1z1L921Su0&A<2=!$ zy=hSc-))00e~*fO;8KE&e>ogTX1coc%jZ+s0#dhso>1=3IQvcROYXbsZ*Kxkv#ta@ zKRyYTUkuk>&2TlV+?Y%Rcl z;Rk2F`x)Qco_qURxP`P?jz%i~ww>M+Tkj|c@96FkuhhP_DpcElhm2K;ht}~9>91C* zVHdXF*eej>h}0}@Y&cG9j!pswbgxxXK|)^?VZ&d)8M{Pg$x{p-u#+;|xA zbZ7DNkk{9gj{E1{4BNjiLPodjz};z!XRt8+Q&9Ny^!fd@{kGp`sLOG!o%dOO-rPxi zft_2YsKh_&|HQVt?Djdm^l-&zkX2O;4h|dzZ6=*()~)iIs0Vq@o6$>6=aJWjRxq}Vi-gs)SW z!qVd4y=ikp%Uav24iQsbJTIRZr^s}J=5lTCO(_9c#j;%1=a&j(9z2h z;T^Gu{)%V@{m5gT8-5CO^3aZX-ya@sSG^OKd1*=Do?feDw~0%BD487>wJLiP@wRH2 z-`rKP%VHa2_Q$TcDmICGqk@17Q?5$SGnfAIdzH&uGJ=ij|9%Y*eyqdy>+qur>%*0- zvE{{Ik{F}!l*aQxXDd5In3P&mDzytYrTqK(d3W94s;ya9wMxIf3Z3}+nCdOiemKzF zSOu%?iQLD>dT*V*zvt$~;yGc}7C&Prsd$Q{&$@m`YT};jrl(sh1UQr$txsf3{QNv_ zu5JHL4kzswN`durq}`Pq?{KM`FRz~`FsGt%C$xH4F#kaAFITP5ty!U*8>gkpS(o|f z#_x-HJ?-rcw>veT&#v;AsI>5bO{&+qgTjBd6)*o6+Wju<9xJ3B&Ce8pl?#8f`j-D zB?0hqd<6kPmQ$V;51)!1k*K#2yfI1DTjfsh&reUmQ{+ECKNp|)e(43{^m7^E=bzrX zwkC4%scBCouKhlyKY@j*q^u{~zV_kX_6-ayHp&O`wdPN{a4uD7vbw*X;;kt@3+Fma z_x!09%yvWm$nI*DTQTZRsz%o=H?kMQ3I=`_i^l#Fm-_;g^e&&tIOW ze!sU`$}~%4;z3L1XIA@#ddrP|ECm(Dr$i?5lms1f(&OL|c;RDone)WgHCv*3^qur; zzUD{%(*L8zbp5fwQ|22_UG%~(%)M|J*78$T2x4Cwv$F_v?(IB-$Hvc$)6QJjwbV9x zTTa*cE58%N8>9m)yLY?Hwy)p!>fYYnEg7ecxW)C>aEWLv`1dEcx>R{1Psy~oM_2?t zv^j`#ZUr^-_B6dq71r9Q_UqZCxUlCcX+r7e#4PuUA+29&^iUB9R4o7vP-@LR_WWGw zmN}NiZRe)lFPnYBuvS(rYx=>HUzP~HTpRIFWB!D)_)5{ghxzTV=uSVq_M_cDQ}AJv zEDa3TZS|EB(|><^t9m4A($12XLEevj`R*ka&AFSX^poL)#BtV#8;{<7r+O4RrsJWu zz;<=^Je$gp+uL$u(~qUkS?)i7ovMXDXtXzW_qIn2db65}_hneUo_~BVC!d_nifij) zU;o-Wae~u9mo}xFt81D0+8P`VvCNy&^fchE3wVr4;rJkPV`BHqfqv!40 zuP0w@W#zGVdwxFLdTO_5$#ND$c}VqsiQ|qF-`%CRHP>${$-lqv?nLdHw0YtG7F$}R zH%!ugp;P}Z#@(}CHumw3$veeB8G6g9J&J40YM)I2?{rFLl3kkfx$5hjzmH_3n0jB& zpD!>$S~*B%wjJmEm50+j}sX(GC@+Tj%E&ZEp}aUu3hb|P3M+) zPF|%Ix~fI)kA=7Ot^dLn1rHiDxawvq{S`XU#cY~&WrNY3QxO|a-0u>U;AYYj6tKR1 zWm#`XpYi7u(1h~2IhM(FO+P30881{{!E1svj@Rn>ELHUiC%L zy^h{lmI}{9i|z9JzVSDL25)0`mvt&f?!EQ#qHC_%r-?iZT^f{BdA3^eIVvpZXHcJ7 z;V^$ky-J~Kubgd_N5?jm$>)lqrScOucw};K`p&n>Q7iiO_mY2iA`eZMZrG51_R!p> zg^&_3&~ZUio_@EO?yBe|nw2jvEj2dPOA}Z>r+VY1{F5I1Y~J(j`wKh67h9D~@Y2bV zjaeJD6};iRHtCV^r_248iPJKAlkd7Y%W>yIxfZr6M04$@GhC)pVVe=hn``!D5@we((pMSJGwtMof(%0aNQ>SVMtKHuB`R3>7{JmGd)x-)f_np1W zJ0!-EyM<-D`p%f8u8V4y2Wv2u%ryZmxMN^(Ph0BOrC;Z5?##cj z;h=VL?aJxrChbZSpYQxVcy;*tc~dNV!Mndagcm&6BldEG?39n)mqDjRY?@hqzxF%p zzuAvUfB*e{e`-MHiM3B=e>);xvUi@^&OOe4i+mTpeH)eQ)}U87QvrN#tAoM{mMzyE z^uyN7SgsSa%xC4h9nHemXXT%srdzC} z?(0%!PET4gPjUa> zZ?hjg@vh5EJvAk;^7FH)2Fn{;0#2|nW-^I<_*hx2Td!?Z`fACir^eeic&~mJtsVZ1 ziR0e(_xmnaJ+a#6T+F(sdV0z&Ykz@zGgP-!*{T0A$W|6W+8;2{*P)uX#QNaIyd!fa zoOq@6>+0%o(fsXYtB=gcn_qgexcIBhv1e1Y!(SQ2ch9-CH9LEvuscWkPAz>!2_r{` z83&wqJppY9oM{{U@73z{ML!MC-|mq#zVhwuZPhmxu1;Ii<}IGC=|Azz2F^b+7REOY z-eFm;i64|Cr)*4=i^OZeRqEL-FtoqD~*kwDDOTtW5)KGVdwXo8=m_l!17|+#6%`Y zvEL%Jp)BAwON&Y7B@KI(FNwjIm;0|jHGTWOgp-cHzP!9#yY=lYma1ImJrR!ao6~yD zewT7AIuc@at3$=Jh-#&hU-*)}lW2)+` zr&sr0EiJ!T`p8Q#>Gy~H8NRB=xIq9d)u6QZ=i2_>N!@6sH9*f&2vUAK(P$-=id68@9 zBjcAJO-|k3`DPdA?IZ0qACHO$S?NuBAZgVSTyQRb(ehybmCkWYMitio!h=2uF7TcR z8!=lTcp;AYZdRwUc|+*hsHdpjOy$dW zc4cl{An?E;XpQZk4~IX__543cv6w5Xc0eXbVPCn_v<48=GhC5 zZ!7-y=cnJ9Yj)c`C#&5`y(geCsnPFL#EIT2rrk?8L7M_W7e6ocogEe^w3D|j@r}yd zdDB(@{QLd>>akwwrFZ7P3Nc`PzSHv<%d1Q2Un|WIb1eU+W@bNgNx=!|fPQ0xz=J0R z&$8}D6r9lKeDr7*=)jitu!EJicg-#P_vdH8CyRTE2edz#-z}LeYq)Rz;pnsH=U6`O zoC`YnUcE{<=+sZ{O{u4s^~qQ+x~;d7r(_pztBt^d>9f-{1Y-PEyu2>0h}*mC)J)^$ zi?XEV>?v8eL~rw^c7FN1vK3bgZ)Y6x4^uxX=YPGWxyWw0epPJV3mJ#+2N~7BwaxAp z{Zi2Kp%_w6Whewh9rCnax8V4XlLt$uYRz#!UiY{PG-(lPUH*y5|H;<7yUVMeiR_p8 zAbmaUtV`MA&)pjr&1-B+64>DPfcphgjV={V}UN+{Qa^R!Vt$^OTEMSA|X%x*G)APu#%J=hIM4O*`}cXx zx^gp_as7hNtJaHeJ*@hGL(Rn~_1&kZr+s^ivjdLxNQ%yP70>APcy<;%uHnKFu)wT= z>6x?AAz^`2`aF9z_FJT!5b!j&bl$tvt+6tA)(7pcX4BNHT-zl!DGp!Gg6z*}FrRdCd{Cd{WF40$4H1&j~-)yV@U*|9Tp!h}HyypJ% zKf~5Wc^asVnO~l8Gv$LYjPRFN6wit#&-MXP7de?0NOG3)cacdm3Z-1WV6 z0kTf_fjiT!)0+xzZd|Z-!SR?GS5^jVuR9#QX^FAU@jltlkGGoTP7Z%=`&ep6%1NQi zX1fh1$c2Qii`l6XVyUgEkSLhauq!*CJu!H-?tO&9+&!Xe)~dApNKtkupAEh^tbu{!N3Vn7UADr?IZsYb zel7NT)gI7Q9c;W(D@tDOaM|;%1!-SAGFZ7p0{HF!Y|x6jQZ@6H z&rBm$se|icch@A^=WqW0OQ$AA;OuPk=}E!P;0&q8Bs1rEw|4e}1C6habPCT3i4Z<~ z^0CFjr}6cFQ*)DMT%2F?sWYsyu%)-_?|+e=z=9^m7dJHBGA3~s8W4!U!nkqir)gBzdx@2Xe%%}K0U6=^W&;*;%}dv zoV>93B|E>|l|}P}YtPNIjqYAk(egom3#&-a^riolO6`;nIR5l__1!~rtHyWVU%QWg zeP^4=al!T=-%>~`!%it6X1gwUE5oJY%AcQ~hkw6czh5g%=T9et-Trf&&ztV-S=T5x zd+r0X;OOZZ{_|{BB^~YB_N;AY$jrLB$>3u@cvo!Qr|oY&a&>9R_#Y3VxcI`dNdxt!822P@@k z??q3aa^#oD8AuP1p|L~p!0p@DUw>=cuIheCt18Cs_qVsfdkzW3H!U(sJ+*>MRO^M? zt6h86L~ia+HNUjXH#=>|35j!!ll0^5qB&*xWv!MJJv)mZEdp1@3*(c{^PTHP7zo-TqX%ZQ;7u-D0=8&iy~1e3Sj(ykdoO zpMOqn{`T_4VN1;gPjJo{250*Kzu5ez!@HpCv~iBTd~R-4?WqZmxAXAM4Ae zPEp^TpbO}Z+AdS|o~9!*;W*2)jjc6bF1jyEal5c!qR5=>pC{XU2t8lEnlT#Em%5{N zVC(d)+ZLqjZ|7{D{MW_j^P**i78ReLpXWC}@^$|8wb9{T>B^c1CvY=~aV%N1v01mL zzx>7P_50Ty>z98Y(sS+SoPfUY)0Q6npUkf0AGD0;XL%7=7k;P~RO)mjF}*zb{m-ty z&voAg-l&K!I%2Z_ibFr|6k}uV9QE>&vr^`HZ$Rzy*B+o5^9>FQ?0fg#J@kX6y(sL9 zpt9Qw0anRh93_h%?AdKs_)A66;rel*Nf388xh~k!vUB2`y|#jJtSS*zs>P?L>Bg<} z3waM}fv1MQyR%a?{jGQgFZhtK2*m@@x2vOO3go?+VVLaH`S{#?d-*(#Iz8_M{?2^I zgFEj<6-ni~HLMdWoU zF#9gz5}#9fuRdH%>}St`wJGPth0JtgcZHO`y%k!hX>8)pp`)_)s;0&NlfrM+rYbp@ zb8;PqI9{ob;kv{1Tc87)LgN}*Sod$c#e1Xr`@64q!#>UUo$&3=&3(I7rA!2(->iFY zot_x5Mc{!>W|ArIPY&Msf1jOsm9b7p!lAJ;_tn1|W@&C#rjqdY+!~No3m*gj>UoKbrHWj>0v_!Lgui@W^>o|1U9Yq*?<`Ia-d*-K z;H8mCDbwo{hpvju_#V7nC53@;mw?9!NQLmD&p|h{UpqwLq`J!6Y1{6V0Apa>bzeqhrW^km_We}^n$9nZh{ljHv2!LHIhHy-7IhIWh3 zfhPM;tMkpc;BbJgaZ<_?(_H5{D(@C`>sg)Vnf|Qj@~1hoc1)k}W2(rE`);-Smnrh* zvb>NASqL@Ts&VsvMb66Tl|ibCs_`d9K26>J(&F_mu3tAcCeJ;5cVBI_?)<0>PG@nJ zbBYE{b@6eNy?Uig&lI1xoxX@O&UJm{=4B`6+3sG({c+J>9@eK@SN?x-ol)80`|C3Y z^FjHDp)rCZr1$BwDeu;Xub+2vl4|!Boi94VH#Q_Tr*==A8NI7yW%2V1mX=9hUp>;4 zmGGH;;>Ck3fsU>Nt4pR=1sz)GZ23Lrm2UmNKhK)D^$b|K#d@*?cAVVf%yTLz;op|~ zkqQpqfAbuwhgg-t5hHNcH}h`rG9SrI&li;r2fm7yxIIcT`_3mDQntAG+szDku)H&hoEYoLaW*VO>2JIIuwu>t|sTyThdPS%$?~d>a zHx|1~%MMuk+^hTjw&Tncok*jSFx&8T2SPUVWc*2tIrID!d*FIM$DguS?s}gSJf;w| zTP2w1`=cW);&BxR=ak1i$zBw*Z$sYQU1^t>`7Z1eQ#xS( z$1O*cGCDitQ~&Hm!elOG=+`!4sJYx1Wz>hrAZbr(4<+?>CRL1A2>9wI>b9%JGyz|`B|o?cQSx3t$oXrJ(evCiE;w$nmda}F_OFRrdE2g1Am_^I8 z`r-md=1k8Qk!l5BUR=CzEwFW)-N)_~84ddq4mMq=46&R2DhRak+N~jO#<3F@&#l+% z72Wrvi{ZcX&z4Dku_+_n9%HG|{1l{M7XUxQW`{k|H zE0v~m$^}23KloFmr}&c3mJ$vHhvUl7^ELcgxGp9fBa({4xV7e`0;A7Su4-GfAvqMc&#bST_SuXlxw>Ge7n0l8TLkQPE!kB=JV`| z=0`4%82-Kc|Iat+Il#=MKk@80vp0OwW@kh+0uHpTtiN$$j^$>}s4W>Q=G)a;ZP`@! z6HQ#ea@b@S=d}pxoffPFxZVom2Rh>erKHuKlw3Qa% zIV}(n<>((Z?Y?K+IaaTJ7T8*V<$AOJCtO}D6{#sbbS3%TXFzCVgsCv8!%VCSnjFq zKj-cLPucWy*A#)09!q`!NJ-(K(8tk{U%2OmlHTQ>XXQ*@jK6NB#8?E*$@u+t`~5Qq zo8P@vS^9SEqQ^dJ-}ZAjpJpm)c3Ggy>-Kcd(VY|W_Wexz{Nr)I_36A97Z#@fJf{7; z>EO@XD*MjfJox*9ASBbFD9Gu(KfYifL$9^JeXz-;UDsV{z8S?;H!d4}neyUz&)`>L5# zeoEoJIm1LdbXCd@Z4>S19io5Qmc%msJb6d_O80Gp-v`;{XUwrIzGWafwfA6i=;?jM zPu5RLR$g_G?TH%83&xoqJdovU3b9Nwh9W-SS8?bEaJeXbVVZv2sbR9h+nbx!#X7IN zdm6Rhv-dQg?ld!_+*>A@o`QSLa&L9Kn4>&tdfojHXNg&jiW8=~8MW=2y4H97{(rl6 z{z$sW)wM|Ypybo399i+tx6{Qmzja${2KF@+uX z-tRp9$#@Cx*;%IAQz~z6y|yXUTX*`cOipKW0hWrVF*cGJUMWBB{Ivak=dsBa$7Z(7 zU*Bar|1Zi^h}$Z-;P~q^$#+0~O@VqADKGw=MNdy%nsniFL&K$S-%2%kQYRhzu;b3G z?6;@1*PBQhrCcaj-P)#M!t9tJ()-9uS~>ILqSl`;l((<$;+40%qp`Qf$LY^J-fJH- zm>H{V&RHD;NBBoiP~Dn$ch^TxqlCp_s~YEpBGqaE^MA6~6qpY`a$6Y)Jweajpe7acSZ|Tu@9jWK`DlTQ1>n*6;ANfi4p?n6m8V2&o>R!|1AkK<2<9q# z{>tC`bz0`VJv()a18-VZeOdAH{{H%q?`@TrU3R^@Y_R@lYM_8agB+{L9Y`7az?$jn z$;UdE;&$)rQnJ0b;Fadu1<~9WD&s67=VY%fdwXkH&dp6yd9lkBxqR;n?&!6VOFI1; zbTKq&OYF3rE8g0CK4aXb9jvjR7iU(U)uw1aQ@5eEjwDxMDo+K`TIK1WA-!SPo+^Pk!I zx=%fqS#;OfE`MIoZLj(rUbF7Kxw(0%s_Pev+gpRO*Dv9Y{LWcmH}T@OJ2@8?H2!?h z%%3x}`{cRD{q}N~|0dq~<0WzZ!6XSz1&4k?g*qfhH+=@>3I--e1%-XGV%jep zD|C7u>MrEc-TURFu}IFWoyE_yP8?fuveEbPvEJlM9#5Yw`|`Ziv}NH-9Y(%$^_wi; z&)N9*5VwAbm`Bm^UteD@fBRe^m-)i~ZU&|j8&0U%>J!@8B7CYQ)cw4qX8Ufz%e4_3 zosvCXu3b`g?WFXut+^?QPx)Kq()MIE|O+UFqp=>_+z)ZEH%cZ$!?8#K z_&H><*5+EpY`buOdAaYAjQZbiw|BhXSlFBtsa5adZ>GS0+s#!EQo>U}c4r%>>dQ1*ROy!r>3#(X9?elW@Y~L8X+)p*- z#01ALH$7_39kLAixb2DY$tas?kB|3TTN;M03c2`T52yW0CjW-!VmqTnAO9>_adWXd zzxsdPrB6hjUhvR}*s#ECb~y9@DVAmqYZh3WDHcF>mpRN~xb7gHYnl}ieM0c7bW*zT zgR8~AF0F1<-71uQGPiSi?DLH~c6Hs`u&_drH7#;hm2xj<%Q9gWt%>6I1NGBS&(>bI z;}GZwgKcMy<}6P?KQHb5y}gF7mnd$S|L+~AFY|?e>WnNeDzqTgVw0c4o`}k|QCpkN z>F6EXUh*=iw=hpV@L$mExM0l~yRX1o|FmCSJ0}!d zbW*j=c;WA*ypl#o&dgXiDc{JlN%4#H_fyV4QYS6?BFtDd4sK<4amfpOwzh7QnPP?`yQtpD!{glhgw02)K zp71pL()K>>8i$6-)qfoB-rDx<&d%c5>-YUSHAN@#5_`qJqK|90-!r;jciQu9=xviA z`Gr}Gk5&pfH1xGY>*NzGTHgG9r&kAV%gKytMql+<&-nqn6TfC79uODn3YmMVcb(L-F{Ui(g({J-zJYjNHPupVQ;2G}Go9 zu*faQ4&h$i{?PeOd=rE1J9$P1P<7OJKq$b|N?XYxDU z$HzY}T2k%1QEpe1toe5hwnNJIqR+V=-??Pg*0Sew%jeboc-X%7=468{d3UWoA7GX- zU%j3G#G&+8VF?PcOdJ<3yS8vc@@$RQ1EEkQ?CmTu>k-R3Ro8PV8Cz}c`I_I|^8Bp%{WBVN zQmF^;?X8~u_V#w|Xv5Pd4&>f)TOcpT$nxT0;h|7SGXJL>5PIvWR_H1ZZ>RIhOkSoJ zetPGb^a`hRZsQbI>v-ka67=5QTSK_kW?M=x-!(V$&b9E&+uQT^XFfSGF)aMG zD(Di3eb27P*H4|`<=tGI9^uKm-gd%*7s?L&r+kuRAQn9rTA|&$#BZ(@sF~JrV4Ciu z?rS!aJhB$3%kQkP{Q@dmtNHe(o}L!9dEKN&ztcA@t~{Ok*?(npuf4|mgR|u8ek|;{ zU(qjRdTP(7Q`%;Cp8fqCoFmcH`++0kFT2n@?;Tt$kRWv72oVbOR14a>>#ES+OYfZZ zCmuLA*P6GyRqQR-FA3K8Ge0QsTs4Q;Ea_f$BNVimkZ3!ndC3{SeICR zCinKXSkuf)Dj)xIZ#llP=&9G`#qRvM#%s>+E^oVKz#{!n*r7qrPCEuVWF^n!dLs1W z;YSgU-_J8on6}(&_4DN?o*mQR{8$^kc#rwj+iB}k_-dZbbUA9L5yz1TB?{}Y_xBt&mzG7ocy6W#39lm3a_i|i#TzJh8d=oE+ zUE?e%=QWYRu3?8mGnP3ztYrIjNn&BQe);87i9LER@2(SBu=(&D9lo=&Ow1>yUeDQm zd71C*xAuR(1iRiYQ+@OG_4V@+s}6n8`6>N&oqXp)CuLD4jtd_%K$Rc^2g}5UABi8m zrfSW!sr}_)+S`RPFGx`YRs{beOuubh%#d;?VCZWu1H4uXDR*@SQV%L$+iD2Jf${{rGWG z0{5%1)8&~whn~+8pZNdtiu;MxGS_3v?{Y?2p3l6!uEo}FQqghQunBY3>VJFw;Ng{J z;%*A^GQ zIOi9$G3ltuv*e`*VjPren9MIOl{TGsx4`86&gXLJ^WPW9{C=^x-{c?fk|jI)D$+RX zqY9UXvutR3Ct7&}G75G>T_Q)2eM?cJc2+!Xxql(3`Q_lid1abh_*AV>KCf)2^U_RS&(Ck??oG3N>5=*O?WHFtC%4|2JbmY< zQ`%2m{|Du)Q{}lU(0F>q`Gx-`gxkE^|G&<-=10N$Gu=1dUR>O6S@@`>Bg{&v|Kk1C zdl^MAq5ZpqEm_qUm0U%`Wgpjv_vbSU@7wQGB&&E0M;Yp_why}esMz*zF+p;wPG zuYZ4kKR@m4tfx7r(#S2|f8-?N@7pWcp4hFQW&il8!LRS{^XFB+v(%66xM_CX zy8dVCx#i36S;!xbeHE7AFol7sByf%Zbar9}1N$W@$vZnsgrgWh=9K&z+zsqVk z*B`Rjt=D9p&cDbDfzB3wroS)mNDuy=b9K&6ekqd^Hh;fd-ZziwT(e{6+nnBqW=16k zrWxLtsMx>|+ol`>DMarmDD0~`cNlbFp7i2oaYNx789}+2i+a8A<9@CKB|7&ttH1pEcu8_!00vM+op%ea*1T};y386Q@talW2uTm5Z@W$}+68)mO{ zZs(Kg`&cOMf2ux{=h&n)y-lBOzNTKu-=1RZYaHXYHhg`Y-VUM3{QP!57W{l)|6h8t z+YEF4g|BzDRO;##PhemwVOM9>gUooj_&V%itJ;`!^qcEj-n^2oh9I`@u3XJ?mMwT$ z(y(rdMxSBa;)6yDW|?2!5f=RZ`KceE8z5&t-+Hy}?@9IfH%?id*XRD3%eH>i;-8>6 zpYJDg2eN3&Vx=g>$kxbDGiKVPA9zVrX5)8lQD=g)iSH`i)u zx#yPp^^+R)qS9sd_D_EK@$g5%uZ#44%rMOkGfq1rQG8l=`;G^GK6W}WJ1*R*+r9NH z$DCTe=jW1V8NSbVYk2op<^VIKxRGQ!>bY!2&z1inudc7JkBJhlx+m~J{}h*RGV9#C zbF|;S&fj0SPTxFwqLM4mUY^SZ@3e%De!n~AWZ5$NXT|*YgYuU$+Do1N^z`)X!pFyE zp4Q)QGwb%;UC(c9OkVi*XZ^pQ%X#;=O%^;S-SDiK=||(!&zvp4A?c%Dc*U{S^7%iBUvO1(JwSJ;2|Icts>zDu{a=dU-kkM!8m+P0zJboa#f+AHe4 z?q1%M`P^vFi$&dM*6;t9HOrLSjp^UJySr!aEIxXF>(VbT&MvXvbNl#tl^B0F21YA6 zcCb$y7YM9aZ7{)iO6;u3Y72kPInc<=e&*Izt)Krwrak2}uYV|(AJcsEYT3)B)3bIi z1GP~iU1R-ZwoUo<`^svqTb*9J{O8*(wBdYuYHIhZy6bsWFBZ0+d2w-Z?#{0Zbe%UW z_Ge(+WtSWQDJ3>IJ0!Et-Cm!z>9O6K451r)A~%KnjGUJj_-Xd^yGPD%|GYCUTsl89 ztV;gcm8*u)pSoWsem-y1Cw5dj_J~!RP30#Et;K0={PKC{to0=pp0s|yCpoU}=hKLb zE!Fk@y9Az}JG}I1^XsOM>kqImc&G#!-LPu3;u5oPl*ymy`q{G4wL7G*t5{R(?BS){ zOEzk!ZW1rv?8-g$?hEmW&7w!i5deH&d2x+oZ0z=gB1RGixF@GX=Wo zX8M4(ky*<5z4^Y*Ue2>ZQV-OsoOGxZ5_Ri@FWlH z&l}{`Z3SnWtwm2Npaq~iR~rc6ZHE7pWhX~yz;)M?Rw{bbDy3P_P0s2 zn6Wm>)WSaL`kKh(b$h=>MW6V&E(fWVjcC4?bmCiafbKF)fib z)+0)7!ImbyeTQoK#O_Vgxo43XdUuzUrgT#I*G;GOx?@#RTeV;G|6i>7ZegDArn5J{ zR=jp}=KsrayJTzDRj24%&67CvG9R?_$r{D(E;FtE{*HIHE01{5-r{?=`otWVA{_Z2 zEJ^YJc~zjD#bjE-KZQQ;70KPz400=SZ*R-&ar)Eq!_x25&Y+K>zvkEfi)?P~NPBu} zs&B89*6}6!f`u2NC)%X!(=GMmI3{_cKVZJwUis2^mgk@g*}bRfaK;pz>t_x9WAORe z+09>DzNk7|l;?GCOSO)0+|DEO3{pUcaKx-waO(N_oexvDF~!`T)Ge-m%^*`*)hfMH zU+v|d)6sV-=d6v|YIJ(q$B%Uvr}Zyg`Cn_5mh!Rt$2SM+d)sP%4Z6}D{Ji9utI+>B z|NFLY_`OL~JM0XPjKzgJb-&;4`(kgq{QaKKexJ{p-(ONb^UD4G9!_)O8FUx02rOVP zNiqZ<6WL+R6e@CT_LjXf_8TnzIpY9m^BHKXiy_ln(UNbKI;9tzZ%Uix82mZ3sO;@6 zDW9ZkdtR+tedfYK=j3aijtflxMy_GBdcWeKxSC9W_@a4ps~V5o|Lo21uh{PU+4(Vx zCfXOP)qOIQ`Dgpz$Mc`$i&(4c@%4Kvzg`XZ?G)NqyMMy7%|CuT?w`H=eqHqAN?*^< z?!OMZ=Snuq=5r`Gd~dT}1FH8KI8F#%un5?#sHphx&k_9xo9;QC)nZ(Fwb+hnVNk?h z84IoIwDfaxUgk8M`+A{r_3u|#S1+AE*-Yh!hfyHky5ivHJnv;}ru+Z-9%uG(bIK!i z_9r#E>(kPwlxeM~s{H)S6m-SI!>dmhnCbBzPu_B6+T^*}Iyajn!37F<%&%h>!~Pt< zfEUw)8ser}%{tFn^Wh-7)cN)wa&JujvA&sDw{QLKcUH^OOK)sQlqx

+#Cs1&1^L zZp}HeH?N&fR>&;>-kUGRVylZ6yZ3LiJs+bdpv%YcASPDE$EXc_Qx2ng!NyBJu1(f6 z+M#`LtLACXl_IlFE&LYpMP9cjoW4qF{lk zL47ioPLj9w|9)p3yh=oVDSz5*gG46{%{fQQ%x?<)w@kQLKclOGf$0lJ!owhlkJLFs zfzj^_$=V_L0IS*Hg3bC2&do z!eV#+!=(qRzrI?Uf5w^n&--Q3+w-0s=@j0!r=pjKcY7*N*&g)8qC5Uy!#GNLeOv+n!Uw;dn5#?@`VqrTxN_ zQBb|t>9Zx{QmGevP9F-J?bXKTAwAooaM6|}Gvb!{%=CG8XD2WFtBgFM2jUu2?jP)t zHb1u|_w>`7&3DV*-bw{cK8CH0O3hv{NA;sx^s$8FpgzalncNkSk#PZ8#$Krxo;P>y z>=ByP&$%Xcci8G9x0p^xJoCCe+qQb!mL)UfR6iJ{o}Om9+<(5<<(3IDjf~7}Eli=O zpKo}|Cb00*Oyl%3y4&w0P1Aq=rzuS8{rvs&tirn;x{aAQEtDG zai1qnRG(LIsL8b4C*W%H1wY2_wbnPIQZCB*Sh_GU?sA^Y7!E0Jl+-S0JhDEtJ5hJ- zgOB%a-Fg_?w>n03!4!_%mF$m0Bj3%lsoccw?0G+>jYrbw;h|RMxtun&T<>BIGQOIk z8GPpV`~C9eCx2Icf0w)O->>Z1lRs)mN~c~{$l2-IkbQhnV}nZL8I@z}_Y?=~Pxx{2 z*Pq{uPulsb{hPP_gUrHn=|6wG|9Ks}%1c16k?Ucc#KBVS7q^_RXuB2g>y=J9aI9C_ z)F#-Idw$hd(1V~c<=Y;j?4TSxf03Jf0uf|*Qa>0NNFsHn7pD>>IGLpuD90O1*=8E z_?yrA>{=EoalN(nWRIlrp?%lBwaP3AUmtgOTjUL8rt-U`(|7*=_uKbq*T>)UKAlvb zZ?b;xG0}5tw!S}csrlNPgA+Eh2rRI+HubYOcCfsmbzFeOj^n9w)KONV(%tilB#$0i< ziAk9J`{|YUo?r6SYu7EY)BRX1RGU|Pp?n7mlY)Z3!(uk8{XZUudEblGxTR9?=m_WL zs?tj(T~Xg&9o=xM=z9yN@Eo2CmVq&#vB*XyR)GcGcKg!1KXy;3ez)`ZowD1x%iMVX zaY@{NyYuhtZDy-d4*{uj8ddTrAABPG9ly-%*3X*KnK zcgg0bCng>aSr>Ej$=TW0Wh@E~_^Q`F2?fo?AMcZO?qt;8(Xd}`k*Z+D=d^f>DI{-|x7#dZn}40qWli!AG&exY>lit;6WwO*Od-dxx2FFw6*(LdX-{D+_P zoOWPfxubZ%Q)g-Pr`)y`je5S6J8L30J26_>{%&hdnjUp=k?Z4Kcfu`-Ct8>1 zUEY-HeR+{9_vKZg+QDn3#P2zJw;x#lWlizPBl^0Nt7g8jO}?pi=4VI43;uHX-rMij zeVQJ0uf16R>*v3A67GM_yVVu2`M#SInql$Pf5qZ;-O9o&<_-^JnC2umYx{ecuj4rA zn_L=qEBwV$XNOGIyQ`&McrNx`5dWb&piIcsXaOW>?~9J#kX_VpU>fbx$wl@qp}}C^~3(O z+2Lo{1D}f)o7ggmdRBQP$-B*$51zj?o$r(a15=>DgZkxCx+~dsxiMMs)-RmN)!59= zKPz^3S>}hED-@*`s;N&E;=Qm_>{q}2zl?uh*Vntg==%3`kL~Q{OHo_1W~zGcsk2wI z2hF?A?vXTZ6MFd3;`5V}$y}mZBEM|&-#-^u`!iENe&3Gu{(7$e|NVYnUwm^@>U!^& ztt$`fvs66Smf~3A$-ua)UT%W=iK}&2Hvc~U)S;rvytm0(eai0!tNdnnW=4Sz^9~&4 z(tD$F*0yt()auV%dd^0sOrRm$lk={pU#L8>r|I94FK^OMJ$ZKB>05X6)hR7(mt=H*b*~?2yogY76Qu62bqodvJc01*)>lelCI3*Gx zENff!#r^x8V*YgJEju3^wT`ojmR8~UIgf#`zKqe zPy4N)rvV_6)`hB9 z9o(BNSa)nw{pqvS>Gp~Rl53y5$;kJ4YiGB;{*{P&NBR1X(+buy%yqXedlT`UjkkXZ z$C?FazLf_SoO{0iXZ5zV$2<*g1^dVCyF4xT#z#X&mKS-xa`RWt@!z{WI`80Y6OMv{ zbB@1mFJNI(Na%Ht+!W$uF*ZL=Y-XBz$n946~UA;11@SyDu5f%ppE2gO1=bcS2to+E$U@{-PUiBD9 zh|A)VDaDIA%8Lhvduw(kMl~fgt2^t z-NY5$O{cjUa=qT&*mxLpL+#-u-r6sYXErQa{ldEZT}fHDwSQXBw4Y+SQ61;sg7!(= z*;#zFRPlvuW8U3eZ{;kDmSk8SGH@@pjBS5l;}fyt&3qPt1=asU3Y2y%-&4*k$01ZP zb&H+Am1Yr+h66WQOjbpy@b5A4+L6eoD->|+UfqsIgjOkw&lM2wY9Ap8jUp=&b&V=6vs>(E{BW24ZvlK^#dz=|-7U-w0m~wFL_U+Gm%MaAa|9^G0=8?yq zl^w@kEPb)>jdMHS%){;c$6rkP_cr&|izjJE&C37oyu8gJ{p{IR@wkk-UoX{jgEe2? zcc}ldRlF_HI0EE7^ZB+Xzj)u9*`CVHvTFkGMSXv56p~brCyw1e$=k6AS-`; zP2^(3uCG#y46};fNo_p#^+5UCTd78AXEc_rRGea8Uw3&=WpUw4&&g^t7rR$3W|<|= z2^zj_+q6}BDHq>M#ho+tekkqj{_tHvfRFKtBY*p(Kc>ANpX@(vx~E+vG+oBBXvU#d z?%8i{Zl3Mb%GGN3^NvKlTJG$}Z{6qUe(SgYXRy2cz1g4Nd#k@!*)vq~M@@dR`%3i* zZ)ZW4N0S_KrM9}woO6N8%2fZH_OYifS$t8Mtg%ZsRQ1U8UHDtW7yD$VZPAmCo7?l} zKlDF0<6Y72FPFS|*{@uB`}_TV^SRdL)26k~Q)<+W-ZtZQ-tMy>UhQ;$>$l1Jl=5u@ zX$K~b3vd0i3XNX=UVA?E)D+ICR+{1K=B$j~p7&xi=s=e98Pe)s9wyA)ACY@+&&>~9 z9RFw8Utbq1y><=v_fmCrzM%RGtmzM!IeyG>2xa|Wc~WPkS~xRnEokWHOMP3n_6whB ztNA-vUg#YA&;MJ|;kog#^EQVq%TjM2=@b@Ra9Sxe^!KaP>(4Or+ay?cd|&ZZaks|S z*Mff*%yMnWt54f`rFp&Ak1Ok9Zx=Y+Tj0nXyf(`8@`gm`;6*N+g+<_{rmI6%e&WxK z%Z%Tc)H>5FcUI({ij6Z3liR|hXDpI6PcMsi`ujJ7wLqSu!J*?oE0>Iz`sFq27VvwX zW|^{WhyHe(o`SQzOSyN3toC^PKmY%q&;EkCzJhTo5AIg|adO<$D|_1F;va_x`+mPO z22G?)Uw6;_*!@qJ7;o^YF|xcUd%o3t=I&eTPJUQZ=o=WvsUNy(%F2k1NiQ~st&Ljf zZ#Vf_>FLSp{x6O)d|z_x_9M%H=XTlGbUvTf-(T@It?HZm1=c-Y=E{4yKYmwWU|K13 zVMXJ_Mh0aJfGc0+LC9rutUSTz90F_M_+{N z-!`7UO||axnMgfL;jFz?UwPPH)MeM$^?9#VnHv32x6=OKkHrr^C(GCWF|5B?R_O7E z$K+we0oUgbggJgRG(6+lRa2NM&%isY+w1miOV6%1L2G4x+}K07Yf+%k_$pp4rtD_wybXToeatfzEu1uR zk58Voa0&}$6nduaQ~qQArD?G}_X9DG28R}wbv+;C_ut@OkaV<5^}_9AEla(pAG>`1 zD*Z-QS*n zKj0^?UHG>Thxywl-K)IQHmSBZC{T`{`oq|s84mBdTsi(-OpxaFHv=_0^O5#u{Gld%e}haZv!4ZxE@!n z`)Br-buvDe{9m1PmSp+o&cL|q-{k_)nHh`opXqbQl+QW;OecEVnG0G?x|{cH4Bna* z`uS0}{;XbU^R{zq3uQz5rJk$2cs?4ch3wi<{tBtrLRMZ zcB)Q&Sj_rd_{j<0sB<|tHaKcuoVVk2ue76<_oce4*FF)@9c3_ZWYv zJ=^$AV=ur5|*z zh*q6bU}pO0kg({``O6nB@%&AwjQG>e&9YY5qUy_vYv+r4pR`>3H+${c5APr7XSyhKfU9cD zlS8}LTf|<|+vB}>|Elck>)P&@1t-aXhQnU8KKkMp=lcKCY5lXOrfQ$f-QKBw*tdVx z^OYW#iv{ZWnfL@(EPmh}G*`}VTkEr8P%GC*HKgnO#BbZS$wzO`r)!TWK}yGy<0 zN_ug7BBI2qo(tUAUB15Z+s$;}rCw8g-rw8nZ0#VMwSAJl-<$R29h@;6LF-!ep3Ix| zsq*tPUe;-#Ev%Z++tw^wx#PmKVn1cK9*)1yFYK)@k4}DO`>p?m5u3HbgJh-{Zln24 z|4(ObRF{5PWaMu$UpQi4&CX*SW|LnS@;=lsdB3dsO0nvP|IKHDKDN4xIQ##d)+cM- z^-8tVcczi6tNA@w%l(X@qDKF}*Z&u{nssx3ef{DPIm4(cF+mgW|JpG_#^{#eLpymv zhlX|5ky-ISHl>}-vitib*g1N0sk=b?tD1K&@0Q=^-TP;O&JQz=f|Gq!W;_SkIDX7v z$bUUGZ@K4$@C!d(CDl8fKU;z>?8xqMcp6YG(kHgGddI&_RgXi@&NNP+Rr&eZO#6R7 zobSf1Vbk0BWKx7`(4POh-|q{)*c*P)F!@-^zU@Iv8H$g~me0uF_w$&mNKDYg=He92 zlESh_N7PwfR0+pUSaP*Vk5A$Dw%pavZKpW@@BAPx(z~`;^MNee69opQOraGk540N> z&tLTJ($A#U#AE#`@}WT)t3^!~Ppp}ecS`nb@5MWx5A)m4D13ZOa+Q7VxjB}?y)9d- zy{2lV>h1fHR9O8-_Q99Ty8d=C-Nv28&u1N%tJVpzecq+LjzjhS;!BwqPi5Z!E-IPf zTHCu#@kO&k6pO%u*S7NE8J_k(pGKToio&@UZRs-`{YFYZtfbwTkH9wPw#}_0`P?T)&6doV_CfFjI&Cy*u$;SFMqAR{8zk# z+u?u`}jB%UGB|)JiO{~JOBNX?{~|m2bRq;zNFw0-o{fIF9dQ= zs@A$i`rGzgFIuDDdEn({4jG$@3r|i?c5n6y75ch~&q{v7yfua!3QRK#4}1tqy&nDV z&(E{}{{D8o`{d1|)#1B~PC1rj2zIZH*r+t+?)=FdM#6q77S-Q!?B$t%^eEUk)Vd!r zC}8H$5OQc($82tWvMayySsYiy@)X8$7a_gm`vV;s8` z9w;#Ct=|@KaJ`nug8%X_`GUaX?8a$l418yG%n!5hJZy3QQ@}aXY+hOuX>?Sg$m%I@g^|soghs z7B7$7RkHHoPy4z*6%z!$EIwE;Db7TopwB_=xeZsFv(`(O{2dS55-xoFsF8MdR;Y3C zGN0EPnLeyX6K(u%%@4T0E`#}!!UJ_CDb7dVgc#z)vfro+d@wC#@+#eJUUg;<ac)~=m-;r(R0mn&jl zoPSyE@#6f??=lvjpYN;v?KFQ+v%<^C>#YkOIJ~GjckF!qIY!I>^WHyhut{(%w>W>1 zZCA%>(SIW6j_zP%*`v_F5ZnHXRccf2tt}TPw5Fx7d7Ke-z{kk^QOm0`N+;> zP@XLvBOAlCRitfO<353OwYz0pw;;icaR6J)cIVZI4 zqQzv}xvu`-Y=KDeb>e8T#~v_oVD@a-{0G7-tByTY>rK3(C2R3 z{OJ;2wSFRckHkRhQ+h>9>;g_75B=~z!C{`*y=kj2gmA5Hf0>@S>)kek^`ZNF$|kJ5 z-Er07fZI;XsMOX^qMd@1uQ?w8Pkqk&5& zhpDFju=(5ex^PjW!ye%k3mFn*Gas?9W{Oy^V%a#=>2ne5-u6Qki>5tcn7ZBj`PtL6 z_uR?db2iq>VY&FHWr51;O4^?}Grga9-aqj8Mn`$SxIMditX^0d>+fs2x5Kc{^Oa9% z$*R)V*Y?h2`jU9@uI#s1-Irc0FA^UgYGqWNF#A|&SYpnern-eqdMdU`3$`@9OXd9% zZR<31RphxFZ>wHkTH5_u?~uJUOP#v$_JHT&u^i{#8nlZlGI3mJb(p8Dyia^@QR+w6 z%DEGdPkgnf@-x@vg5w(eGdK4vYILv>Ua{Jw!cU-l=OnWfUEv#hDvL8p!xvU=ZMrx0 z*rDhn%Ptf6APPy6?WezFvOM-(rPV!|CN8xo=Ed6{f()6)iHBThTf)xrBWHt? zwb!g@(UQXx_h`@Q&WSfp@B5t@cx`QTx<$VKG@Zzt$Bnk{IX_%fJ@@eNZ4I;P_k1=C zjW0k$`hC$=<*G}{9hcOs&tt|mF^`=M9G)nb(eQmApWHmpf63MyuYo$GyS9sKJ zxzEn@-;u%d(UbX%X*;Ks zzn0v3u<(BI-*XXC*PlO8G5PuVxj8GB2uJBX$AWv6e*65hob^@iotvP@oX)n_Zd&2; z!uO?L%Ac+%e(Pr<&|%JWRfO#fd!~Nah1MnREEV0m!NW;?OD3;=?%DVM+wJ^kn@(30 zPoLep-x<`}Uj}M^onE|0DKlSASw^SS?c7#`T6*uW55x9Vv4`K8Rkac7_1nseu; zuf_U;;(&8=n~T;*2iabDV(Ms|b|xe1>Z(-GxmsJRHE%u_eRq51_NDXOPad4@QQiO= zn>dilBxQPGXUVn2di+xRT-_30URpZwuE4#krw{M;`Lar8$+MDan+=nXS;#KF>w1UPFZ3@MuphO!awYG1 z)DDgdQy(~8i)31Q!uX=Br%lkWOXqe6YFS!mS%?`jE)^}&FVp?VegBOh^M(p$RgbM1 zx>mt^HU#b}$-KNR_x6RrU6RIWF6u42W0Vg(&8h zzw6ibzFz5f4Gn6I-6luc`DAAWJB!b{C-7kUxzp2E>y)kTSmyjPDqo{5zx2_O&V@CG zmc_gNp6~d(c+!f6bIUm{9G)NVzW$D5-Cp0nrLVM}O3BEY-{}elIY)io=6(M>V|8jZ z*l*9N(5+l>?)gE>Y+dz;$1T}=qU7{*k9LXbvAyuk?6bNkW9$5RL1=s1>q;eu{^{(p zk5iaJMGekq2QA?cI-=R|)oW6?$JDa6oA<0v>sN%vd3l~cduL~{Z?~B4lGLMLSB0)l zlQPXpIW=8B|JwTJlXWxfls{&*xcz(ig*jUm{)>MVu6@Qoo7LB&so^w>N!Eh=C5(^nPddF>Zef1S zAJ2uk>Syd7%nw6T9 z+t2;YK_Q2UR=Wb?f*|unV&rN5Jh6a0%g0eHW zF0BiyToJrPGWMBoX8HnkCx?}6yWVn4(Jo!F#VofXd3w%cE`z>(8vlLf+qH!9F4#DX=nD9{Tv@6joNSfeo6Ps>f%c+T!n4VdXRudeM3$48t0e?Chp?_r&84cfkRx2!Eg@2ciKQ1krq zzS`=-yP!4Ki`^}s_Wc#h+{bwCe(*A%nE@-qUT)g@&Ha6Kw|53h%*3{S$FnZgv#(GqFfc$?}w8U;#hzE1xe7o8ZugPLM5dqqU@v|f>ZuF&@ zCvHqS>I0gAT^SU!Q}C=(V{S@!|I@qfdsRyBi5}H{I_D2BFN=eMD3e9=y3ZLMsRjP; zIFWVbq&qS+!D+*iz}VZ zeKnl;OUl$+fUS{1*r7qserHVil8JlP7;1;F+ak1}_*!t>%5&3nqgSZ^ooByue*M3n z_219TG?soh(F+x*J+x3|T$uhsfIHnfJmc z?X$V#r7!PxG4#)}h+VNtx*WCw1rrXmUb4G*-qi2U)tD&ps(XSn?CbZn6`nh`E5zA? z)wk~4`U@Mb?k<17KlP`~u9Sv->F4JKEI7@1BWHU?_{Go9&SvZFdZBc<^v=a3r31T} zfBvzk|1_=i-%cy@kCTgQ7Bn(&9Pwaatm50|3?wWHP??9bC zEzid*gO~G7JGW$E)tcp7s?Oam@{f{=;@7o~-Cg!KdKPo=$!%$8r4Bn*Ez!OiWT*0W zU$;yD{`XUKqs>a>WLLjPpJ?r{|M7uY^Q-^8J5^dU*{)pe-@M84#SVF|kA|uQcV{~) z6tD;^IPIso-)o;yV33JL`q|jsWiw^1%Ovc)Me`p2pYUU?VLtzJ^Sd>9XCCsrc*u8} z|N7PC`g*=EyjjwVr}JH?{NuY)+2Q-)$qe#~6%W{ZAKmO2SO51b>*7MT?>oF5RG z=em_~^yG=TQf(F%>jRrVPyKgw-43U+iFN1ZSf>5{_V(F_hllGd%EXc;D7*6ouZ!7v zp{(AWxuj0>NTVV9;Xfx$4@|CCW4%5A0PjoY}c>) z@81v0?;rny7NhWirqZn?WlUCXySh4jxzvKs*FGI|QYxmD* zv(I08`kt-kU)A3#J#*RW$Df~{p0021-Y4_Xx8dC4XT>k}1T4JsW8ss8nf8_z&;0rN zettfG#GmijRG4~QfuBj?0Xq}Nh17J<8t-R2-+ioKH%CKv<;PbQpvl1K zZC+C}6s@IJ9QA7GK3}xS!p}!_uH`PzHRm4I2^7p|a8ug8c1!h&uEWV~*?|HPTRc*g zC-#b#_^rC6-le#_+8cBt#O|`U{|aMIPt!fhR3i5LF86Hnd_G;CA4@;-IXzRpVZrd; zV{Z6f%Lo5r1Ehl#7?=vZ7(PtBaRRm$fN|HGBhRNy{k>dj{_jV}@*8&+e=;#i=e)8c z_ubo!*}qdh1z0)gJIz|UvbadhM1Vu8k&BD@QBIP_h7}Cgygl!wt-X-*C#Kfv;QI+F z+w<-QO?f7?^!=XCeKR80*`L?<*s;$-eacto$4fS=dQam~-S+gAA(O6k=7&{3k{ES8 z8W=!h@(iyQoVMfGv($6z+xz?P$5g-Fy3Dm(jN@FWXLsj)7q9rPm2-8kM0kpCQg~nr z+Nkoys92v@YyEZR=2}ap-R1AEX>D94oAa@Ik@QoKIcrM}^O`TwxVtSkI&kuygbg`2 zHwDzm?B4>Kc=_}5b9>ez?rn}sj{d)HzWAK}`HP@MRSIfM92b%geea)rHT=TOMd4fB zQv;9o-U>AdTE~9sWbBe?%S^`?jSb2yM}&`T&A&fSSbZUDN5iF`pN(5G78@;V-}=SU zQf9rt@+)3bwM0)P>D^rBH#ZA(_J!a4XUbRJnd`Bh{`zocYr^9{&dMwO7oLkeZ`ppZ z;??05_nrS1z54M#O2A@?gTf0?raZUd7njxU)AbBmw1y+R zM+GIOIj5cX>@d38cus1f_>LQup!w&m;pcZ=@~+n1vHfmY^sGyJe*10uC{wU$$71)N z8r$rp_AhxbX;WA4{Rtob|BlJ~TKXz^MRD1_saN(dJLg!P>iT;E8>7GnOGcI#n}k>V z5}qIXG$?b91mD?k7K=un`OeexDwOqoMXK}!1mbO%JI-CQ*s)^s%R_Itek~~Z7xOfr zdQ+mkYR3bemB)IeL3?yi2X_C1%NbzucDbC!IPdL^@Ez1N%n z3(vn^nJ%z}SyO<4aXzRnux@;%{la&aLgn^1Qz8RjdxcHYjtHt(T=KwJ#ZkeQsrS-u zg|7YazTZ#i$+|sc$(yLUA>klXI4V3D7#zW3+JetcAIJ80MEWNa3{P^4|eqT+@KPFXuoB2_Z>}79mC~E(hek+VO z@Y0j0l&sS8tHamlf#!8fV)et<#jMa-oif|Hd|l-3vbB~K9~LZGGfPZf_{>D*c5TP1 zOBUys$A9?PuD_!A+^p*>#KW2y5(O9-mvbsOOrI-vRkY+E|Bq#}Edn)W-RCHIdCB$h z9?5f8e!X>U*#A%?+jU>rL5n4$v|soOUA2iyk*|2rxM8XOPM3YR z9;}JneCGZB--}r)uC0mmJ=nw=%Y9+;`S`qFXKSxm+Wy;p<#mhg&K&|Q4hjOGMCZ5o z71yr=jm)WgTW6Uvxps@abvWk7C4EL|4ZEd4L8C)trh3%2oSpHY4F^IGF2x=1lf7Kv z^w_{uz4i6thdSBURs6okY74hD{kszEKQnvX!#heDcB%oU&TTxG{@<(co}<4n z@khzI2it0yYV5*m(mmSwWVvq0bLnIWMeLZ6EcWr3_O#hYLwh9`Ecm(oiLk$o;KV&8 zYUO785)ZQ-mb^Pv=)0@Qz5=~_+wmJj3*$`erMkxL+BM9%ym6I6GJ+bR26} zxVv~$)4l!m^`FlepJ(X|j_GR^y6hp|^;EPn^X!f}(mb~$nWUC7f4{muKK^k>r}2eH z7bmWb4(;nI=FNV2Z9dCuuWq%MAInOuoJ1$qJUun_==p`4ndfZje}0tT^y2wBmdV?4 zZ;J_XO<7u)Yut*-p_a(U|BmRag7FTB0e5)ZFw z7cEI#G2!!+14p^8g-=kMZtlb_0P4`a-0~rYJNm2r2Y2~elU0#VC*@qq{qy7F!jwWU zcYc?%`*!6bzTx{M!1zuelIt?W2wd-1BISk30$Pq=_`Cj>;|W@=sF9(*0&6LER5SZ3piILUDCT(aG3X! zb@-ClmN*fXDOn4=WxbwBU0b_IBJ9TYJB7z()ovAK-rZep9(7;WVzxE=%en~H{2Ln* zZ|tcpco_WT@$V~^l{!)!4GrhPxz*ughLrY;O~Oy6O0A!#uA<^G`}oh|%taSIPim<6 zTP$}bG(2|d;nR)>x7jp4Jw1K)V)y=2+`;pV885bbG-pSwHvJc8kl;|#`LO!ytJG!w z^VdC-=Jua$cJ|G^y|)XL%%%ep*k%5~ESNB%RyO^pJLpSVP( zO?uYKwQItc2@OHKUn0)Uw|B5;yY2AlR(8!E+fUz4X|JD=diqE0)Vk9X6q_?IFYDC| zTGFv^qlB(W?ky8H*5-FvFfWb!|h;b?H^0u_OF5>US_-L)Z4-=8Jzn}L8g%aQO4 zr>E=hpIM`yak75KMi+-n*4o4=@A#Mgj_dt&uOn~w-*2~lKR-LGysKURnKI+wUtha_ z?90eMF~@TA&S$f-7wx_Ksy1eo-h;Q6Qt>66+)R9IhnX3tgAf%4;&iahA z^LOJERi>LuHDk)}mTH}pU-GvlE`?=VZg=WN>(JnoP-Y>;UTHE4&NHw2z zELp!dSH#ewD;hLg?%1IBTO@%sc3OJE6|=lMD-6ZfEXWRMT_(<=r7aOVQ8Rd%7C15w zwDC%BS<}9|>0I=!{Y&G5PERZ@UBCZd)#c6U=U1HJm9@I^p=+CXZ}_{v7qr6GWZbL$ zes@O9+3EW6KHsBv{jA*dxPLSIw1xvb96P)i7*P2-W>uZ+hrFvIi;sA9mK^sl4Ht@^a$rL}3 zoci#{?0r8Tac{2QZ+}m@{N<&iJyNEpE_m)utV< z{iLtF6}+&b@to%B?3>a|IyV&-gfQ1;OYJLPwEuBY=)5bBt6s0&&cpul;uiD!HJ3j# z{CqyY-c07tuZ4Fj9``N_TO0N4qPx6l^06Mz>rX)?B_lK2jMMu2ZAx_6zkhvwo&W2T zx7XwAO^wsfncT1czjvl}dETyFr^Hhf{+h4cJULH%RX7`Cr9i<FnAsHrX&Q z-j?3)wQf~!BV$YB5#vT3lOMOZ7@RQL>_UN!f_?w($l>cT&HePd@TrC@stta7v=bT#Y?qU zdy?cT-OL=%?<#vM72I(4_BwvKFZ+a^zu*7cc>2qw)8n#ssGIuv&9JThwz=tR#mEZ2ifgTylOFlCU6s1;1ynpzss6Y7oKV82y$_M`{2!QsXO`jVA&RQ)} z^A84FHJ^K~cG2O$dzM#PJPq5|6!4bJaSU&Gy>!W?uAE9K;pH;%4u9k0*q_Tt6g?2j zy}dEHz4BqJ_@ceBU-o@IZyz6WUVCHA&Z46-bLPLU-kx{&%#V+c&!*3>Oj~4~J9LExiAq znySq!pZQ_IUN^I!9_&&a4GqqqqSB8o>_TcKn-gfrRqAno;MD?=Sqc;Q7<)y(xTXj{ zKhON_h349M)~=oB&5m!Hb;_OLUd3bH^kY{RI5MZ#6y6m)C;8!S`Td!no>n@yZw;HP zQ~1&W6r=6ndW{F>6RuzT91a{*a5yl-i%VeIOl5^O|wyS;dulbqlj^14pxp_uS z<;SDq$-Ck|J=>Iede$=Ez>C^K%Ve!e41$;YnTE$zrmAc|T9xZB^g~|JW;8=boQa{{EirGRfOpv!_ei z)l~RMO)|ePIj=DwdVAj7 zV-}ZI-Cmu@KTBbO65&E+U${;Bx#y8W#`*%x0AjlzQ4Ek+1u^+`y$<) z8eX^U|9UN2D5!A##ns{ZpPx>TpLJ%Y@$H0OvdePxf+Lew|?WexnY*uy+bn+m{@8+ z3!2_cNo0+kw*387HJ=#^4BJ$t7F}RrOcFd zpFvg0dAr|dK1k-S1hr#Y!XEF<>XkAz`uzO7Ilt|f3E_H2rryoFyX&UMzV8Z-S68eP z3@>gy*yNxCYBM>#pZ`4xoKpE**RPTNp&8VqoXuk5wWifeEnt&Q+~0>S z?iq}V53Y-r=*{1jbye%~#$@-4GiO+ruY36RQ`{CIRj(NvlaJ3j*vwv?C}-Arp!)sZ z^ez$2MJJoQ*QH)HVaOF=XuJYyE!BdqzC3;TdY1kFKbzbB&-N@?*k)kjc)*CUm%;Ys z0;6;Dqv!eL7SB;R=fAe(<)yaxOMNnymr_nm@x1c&>}>Pdda=7^TwY#zxa01%z18KL zD?TP2e!lSH9_4^N6@_nu%4%FZmK|v*pOGNRQUhuwy}1HT8~Il&N)yk{T9W0z=x~J2 zDmFub4}A@84RTSA%hmpEx?=6K;Y{O;S65^1-IIR{T67t+`R}akb%BLHzTM6@e|>#@ z_(ebOFL%rDo8I~S{CxghGoF8w8SLX@)MGc^U9^HXQ-GlnbXL>!TAL&LMda*s4T`8)ce! zE7;#Q71Rpyz4HIUzE`VOI~}aNyv%p)t=5enI6hdGJmvW%d+0Mucq8bj2Zshd&)~#p z)vybx>L=Qy(xsoh?d9ry&9m^xET#yLD0PK!mS6Sj-Y<@S=krJR+=A%&LAK3$*BtaC zHY|8~d3pcC>FhC9Zy$B*Ut@MSHNWoHN=bu+hE=`AN8j&w%=h{J|9|1uk~6OwvR;&6 ze=$|N_^Q{`vbkMaE{+T=msCKxj`1L0u)*AXrrI_+ zO@?n?lQu8deaS*V-l}B9&5gS4~w6h-9FIBeD-$!{@lwd zIY%8HJZzWmd-%>If317{YL?R*IRYf*b_|+ zxlCI{c+}3%YSo{@)v$NcmtAaCpq*K(pT^8=-oEL6_4~b#X5PG&K`RwH5eUXR% zKWvwubzHvw&MaGruDJ})*&oC(daa#2NiW5bfh7nunf>h|xHO4h1zLP}IRD-~J5Ohc zSqcvr8((pmO|4pi&M#+jdwc$LaX-h8e?Ff# zpCi(nT~j<^mSu68c3H6Tp_4b`s$QyQ+kN0;)Q@wDkWM(j`}N)3+h1N^_fOvL`m8(lsnzEMZrtQCS5#~)Z+m%V$Duco z>KoF|N`=l2T^(jRJ+^G-&PQF^KC8pl`b^V_40-FS^lyFrU+qb!lXq>)zrT;;T(Z)O zzi0ovDSLJ0WRH}o*R7eGE;U_XW)$$44XT0Eq1GO|ttcubZ}%tCQGAlZ1J*`v(Vje| zv%;Ob_Bi#634m5W6+Jzb8dv#L6tpGaZ1HZxvkcdR=3ATpT-iJ0$)!CzJtwQBeRy!N zifutouR}YZ>=veyK5@TDX%3!7hdJQn!T{=;EMI@+Sf6aR$vz(;mbgndy=}Ei>yDlK zduH0H`O8cHD(+Ih^n1yh<;xylnr|$xSzqxlXx8>8zy1ideZM?!$-Ks@ruB0FPRv;= zb@ORrtZbC6e~v}HoS0F4%#y-?bC@s9v#qw`PWb%nY}@7)x3fS4^18tr7W*`OR!ccC zp|M=ZGg`~L>14m4=WAzv76%1MP`jlc+%Wp(<-1XZH~*&Y1P*2QN9jS+UM;cLf1@2y z@GXXEkI_N<{{CQpt~-Zo8xLJ~{d7q6((B9Bfr2aVP35}0-*Bedx%t`*-@Jm7yQ^Ed zME6MfMU>62{T2yYkG5f5@7G1sq+K1Z%gyt1sYjQQjAvft;@F-p8fp&UiJB|>ODvAKeH^?Zf+6`Ug{;<%P=?o$f8CD zjtHd&qwGx!KqCy7&9nUNelE$cX~U<|HInuBiQVQa$b2nVI`Oi25}-FmTE&G1T=m z(<@)Rp5f4SnM?2P?gp(UJnFk+*V5{PO{~wl_4f(L=X*8Pu+86mZ82-V!^R}3P#tH> z>r7DM#gWXR!Q`49{>EH33~3Fo6pk)8IC|)%vn$XCyy^ zj&6OgF2mBuApB#um}sirvtQ3Gn&l>(ymsT>yR4=ipo27~9QXR@`QX7E@3RY8Cm-0D z93$egXQj*EM{!O9EKK0&asf9yK4*DP*E3!2x6ow8XJJ#0T)$Wy=!s8@%D6U?XTFV#GgZXOUTm5*3_9K4(>bFRCm8brASD zRn9+nSN2zjU-9R~FS|-#AGup*=_%IE$0=CA8 zBj50#6^8}58T$olVob3JFN?#0V5XCcE#}yNFVRZrT_3kMDr~})814(~d@>n3-tFu) zOE|y~yd@)0dRf9@XC^Mw3za4jj^7LX60QD$J1WJXj!H?~+7L~d^3u9V4-zJD<}5y# z>uGj?$x$w6PjBwuU&WvQAN6aPP3!^2D z3@qos#ri~W0(yS+)Ku+suPGW2_slO4U}5rla7XDTC@wmmu@p)*x;;HLb*{pf1I+vq z_ip7aPCYTY%f06V*G+}W=ikX&ow_k%~W#TW6QcR|GwSjZMo5(Z)LBKoUN&MKWu%RZT7c> z6VXh^`{l0}B=kcPyTF3m6>J-t@|rg#n^k>%^>l`N0Xxg1wgWr0U)*zxFKmvjUvPT5 zzPS0LudjZBHrzIT+EMuU$nj~j9+X~>O@Fule;ve7(19-P{N3wC=Pn79{aBW=fsg5< zD}(lnO`moD1skUOK}KFV1W^xR>tS$qKSYM-0pCs zzz6L{^ZPZEU%UD)+-LIfGxPpF*1G?b8;*GuAMFxdyGYKuEN8`<+wJmo8CUhBA1^8J zon^8yPn>P9>W1p?dA#g=SshNoEGT{aFH@z|$F_|VRo-3pw>OQc`@Hx2z3!wZ8}A>g%y#ROk=!jHQsdbmEU0Dj zb9*Y6pOX+vlMBPe<~KRuLgM|E7cy%e3aPhpiE^dBe(Dd32T3N-87`o1)}KzX7$)!O zpH{No4BJ(bIaxbgFY;na)}F09yr=7dmieW;Zy&*#>Hf-(*NzFR`_0I?xk)naq(^*e^z8h6eN}eZcFvqTI|A?Q-jsT}D_f28 zQ)T`=)1^}!t(Eq_zP?`m;@2G(7A)W1-OVJNNJWjj1D)iBK5H3qNCagv_?7+yt81I=jSk@)DJ!B`U`? zpNX`r5tw0|-q$vlMd&EkF1E;wCI=}{+Ov}b zyG~r~*U--&kIP$Iy4R?z3RxNC_ls@$7fzoU29Ae0y60UHXj9{8aCikaM;2-h=xDD- z3#9|@)@5&RsoFh?$XcKuwdKT~f4^R*9qAB!ROiW+w7pZsw?4Bl$yM+3staOT8BRhh z4hpiM2B^FssB~|U0w31pAS3u7A!1kIq_Y`e7nb|Z7K<|c|7>>tlGvb&-d1c&mG}ae zbJqO(`8?`h?{!e04dj%7G+$`9e+A@JtRsSrXJ?yt_fOMKD0y?^;v5^vdw#L^wC-%n zjRvi+yU+5RhgbW>qyD~p7W+RRoOR=$X3J$&a>WX82!QJA$(^9KPypn(!4736?`b-L zl5hF#|0L+`|5LQN_V>4tulxV~$_8zW1RZB!oOj1U)ZWB(XBS7*A3+J*sx22QHoB@* zR{x&%L%B<^x#2q~w9YYtqS}cUd@QFzABP63lw#8!qkFqbUvECO=;Nzj7Zy7E&b2Ca zTKXsL{Jgi(x7hh)KCFFTU{l4UzyD9s7xU${>Zev`PHffVSmMl(ejyb-+8mNbbZ4_|%e$L(Sth5_M?q2X z;FtIJ<4<@0Rk4YJbj&h^4~UiDgf!|Gf=`A~5O8OySiQ4XY|Dc=Ge6FFc6N3;vwV() z!-I+La-PP^oqF{8dOz0P;bT$|U}j`_VR*p%VHj#ccyVE&vrKPT-HOZ0{iln!E-GeO z<})*ijbCof%j@j39$jEV?Moo6T@|u2sY_H_%w2h!tQIKLcdY_#;mh8&ZQ_x?;l~^% zb8G?izgb>vIshs>H*WFBQ5i@Sks2XqL3|VV|V2n;(ytpU{INZKtlX-77A7P{76V z2r}P#jBA&UKP;(9GV(ciP1BJ~Up!4xPyN7b!{oLeiI6$U8%kaVeZEtCKJ)k2h1(ck zG@}mh!4j7<)BT#yzBWC-WP2U^WV`>wNyWro*zO!g}*#G&^yhY`UjKYQW@%F}< zmsE27=Up^os1;yn{KA>QYFq0zF{V-Ui$})8D6mP40v@dg&YIuPvHShTxcJ}C=j^Q) z%cMNwU#(r??;$g#!e|}nc- zjM1P>J_$K(G&poPe0+42cRf$}n;REXm5PO$Kb?MId?)qId=s`Wpzihwr^`a1=C~wx z^zBNMW*uJ6GzXB28W?PS0utleM86m~J~V>HRL2yDJ{ik1+wa$9=k0jd=8=DOU!9rc zj?Q04uT(}?tN5xqJZGuS_@`R%xYvA^to4=hxy6yDethkqt-p|R4cy0rCOwA6dI8We za%cB`|Fkjh{B4O(4b#6!2mQD3%HN@PYoW$_->=)YW?!EL+8!DuRwc%9r~d!nv_BQ= zjxE2{H{n~D+Rs!d5=%xZ1G$fO{k$jI_SkjeXb5vqA!4;Hq| z8RhReD0;>wv-HHPlvh((*Q{oFQ6qD}iLIdVp>q@G2kxotauo;Ic9>Twg!JGI~M9y`42zWAhK`=IBWpKsiv|MFS$Mvf(A?;jj&HceTm>C;fm zcBks~+C!^Wp8C2um7~mofdz+gC7cCLYdMA0X586Xyu5ntAy!e($^1O#{eiz{OT730 z_-&%H`>e>#X_+3*!5s%SBp&vet`{@$yw_vZU!q|;2RS$z970$G7Pz_(`}hCbJ7%9%O3@E~FbbYjl4KEdX;NVnY!nTgq~Xb<(a{yj z`8&+9cGHR(H%-?vhRbV7FbFSbTEX!s*fDU50+*7d`bo<(tBddVbXy$0^KM`1>$30r z_pRTTmiB7is$X~6mhE~K);f=Cw$#@*pXYI2k$JCHyfduw{oe0+=e7#4&f&26aDe&J z_Wb)BUR{f2p3k+~=#?Ww;|~^z1;?LHyBvCE0sCuD6BYpn21b?|?m2b8UVi#`T;BWg zGT+*G;evzVzI!UT6#o2dcK)>LcbvJ(UwhfU z9ouqn>0%C*jSS3R67uDYUmUCw;$;LG+&F_}RoL29%t4uVca{2FXN~y5DV!ZJ=i{2W zo_`-S^S|rf>>DGt;lQu2ua|mH*ZXvcTc1Vd=Zc5#OziK9q_tjYWnlWqY2eU*UU&KG z8IJtdCTDOcG%zr69MK6_;vqQGBy&>9>ub8tvYB^1s1ttv(jsZEO0rfD;C;C$h>Z-Zrpk7*5()6@0QIzGt*f8U|wP69;WhpmCLu}-;Wd1xo}%1>Jsn6 zU#(%%qKXX;hnRRS2&?^ZW=Olx{8dGY3G8A{PMdExl8rI~_Gq6IUKORk@63~apT5-U z%53J6+<*@EO4Xj}T8zi~<@I;jAF}`VkzYLalK+ZryI0Jx5_C|oV`O{rap%(#QDm34 zu!1^^m47}S7w!{IZzy}Vi{E$MqtCxOm(9tONLM{O%k=cqOZD2dU0D}?etzz~+;8rZ zzb_v#zb`FmCWe~teydVOom6aNQ&*6$`nZOuB#E?@KDebWQ)UNc2`E;}7TL5Bm| zKw;ZD6DiVI)C!J@hF2WlAgV2Py6f|SRrWVsW~CKH%L|sy{4H*G>S*kf`2WAA^T^p) zynDUVpqlaS_XTNZXMH+f|L?Nu#p%mFz0;F+xXYm+u%ChX%a6C4c2AQ0l3?4}#sCUp zhXqWzx3`Jj_1qn`HLLO1SIIXO!FhX5+SW|D{`l6KWxwC;_J6ncd)(^MCEf*_z4y(j z|Mzo|JX7l)&N~y2R86^cRxN!=x9wjSg{v$Q3)rjOQQWO}VM}Ik{)D*wb$<^e|K_Mz zqxre&nZm1#qsM2;N7;9K&p-eF{r`XY@@JQMlrcqb%b8gB_m}5lx86NhB?UcVeWahc zE|4{0WMp|HlF%Th9>X`?uvu=6`bBWQ6WE|sa7uIeiRyjd}(#KzPxW=*u>o1+fLrvn*DV7{JKf;^?yU_em)hC+?F%*&F$^ytDLvz z-`4}peubDpKBgO1^Z3kK3Tv)p_BEKYT@n0H%ihjEUpO85C#Pq1Jg|o z5sd(cWj-^NY^%RbxgLMr^X-Mp&C8AzslA^0@}_ES+TX~@zi;H-{P6JbUPn+rR+m@G zWJB!S_dm45*NNP%{C8Zweu}F1v=e(OKR?-izwYy`UG@L}$vg(_7S;-1r=#jU?MvKj zlgvkJXI!`{-1*M&!v&6R^@8-S?2kAPfxu}S8?}m z=ac=^_p18c&gXj~e|4ztjr4b0<7>i>6is*Y_t|Tln9$6|D^zRO(*jOs3`}LL?{>Y` zyU2e`cIn1t_q2WQP4)e|_w4r)HQOy$R)uQkPcN4}aLb3CPi8`=uzHpIgO|p4W}D}4 zi;Ug2@$1izo6p-tTa~}l(T&>{oL z9%A6EsfnC57jnJ$^mPB@ychvpSRrIuzKAtFE&0IjjOA} z`M10ZTr6eDV3kub5qn zmz=(-Z&>+F@ayYopMUvOX?Wl5f3w?;so?L|>(#rb9-qDM@3-jphD@?kZb$5r%imqJ z%P;*>X=XLcWv$E0vVH!UH03V# zx1Z{f+~v?PWx;{+XH|b0)Qk8Jso&7ob7yGuVeE_K{$~J+fKSTGcd9Ua5y>4UwSopUfTJ2y57_Ec$HKPWw>4#rN=hK?%VV3qFB|cgseFk zMc0+H>Q2_Y{oHhtskcQ3EU6!SKJPPpf!>^nn^=Unqa z6)vVg(S!!MH*-1v$dp{(b3b{O<1cTu?I!oFZ>Gqud0l@`1ypS^x-(UOd-JiZ>{{=Z zKHF~*D+3p|f$Ha=rCy?-g?cY?7B7ChTc&eK*w(7}QuU9wwr1~sal>%grE=r{`|bDq zt9!=%+x6Kb3i%J; z8|vBL{I_24-01bX%e%``x4--*|G)TR@?5#vFM*l2x8-j5|5`v-q>)$J?8MaYIL-Mr zpFB0brUsw1eOApc^X;$Ev-9#ZWjdKpe~tMFS`lD9{m;U7IU!rEUXd9G*o0rEO+L;d zHqn7Yp}|3l^F{F^$rPRn{tt2wY!6f`?EZdWvcFyCHc>^@#SN7$ii@+auhaYAU;n4$ z{_uoalz(}5ZSCxGv2SZ4H|t!PkbPp=G8fCq>M7G=^5ga! z{WO~V`FYjWr%YDWeq25d<(bzv|NEC$^v=74Y4tP*4g~>LaK>#trWP|h!5PvJQkcq8 zqMluw7S8^Xl}p59>AIz^@mA&UbgI9r@ZOzP@9}n9nX7KlR_&(TnJ8!ahT!rGc?k4TE zr|*^?-&HkJ@&ENbuZo4O7W;YWHOBiEuQ&Z!GkL$~x@DK6SOhjG9^k3kuu6PZK{~ti zBuL|JrPhM;Z$XO>tQ(!#UoUwglyPOn#4D@A{g3rXD!22s*8Q5QxA(;)%N5aianon6 zQQ!X}kWqD#w^45N>hxRjDWA$SwH=NNIy~@aIhpW= z#auOAX9h-bQ22(fmxUYHec-}E=ckXl^{3sh`>h+hYmU+1oI5)<`ph(PeRX~P`$hh{ zq(0S7&OfuJW^U!xrNWex6~9!og@Gwk^+4bJgZJL)s@?f`unp22 zbg<$C9o7~7ZJqaW&y%Vfs=j9J{PXGb({BBJ1y?`p_Brazw>pOX?K!zA<*gG^zP>tE zkgpOsJ5!H|BLdWd(0S)5+!xAua27aec~~>r*5zJV5qN27w_TEtmsum9tksDY&dB3a z+wc84xa`<(zSW`jFE2XoKDTP}BFzieOAU;orr*cpQi6$68nGh-otlymrs9sdiv=#k(*;mmM&enWzxxAZ(=9w zRbH38RjW2X^HZUoldh+U{6MW<<}V5NnRnfEUkJ|yv8uf| zC@19PrPg?EuJ!48w$)Eouisa6@lD&ZOKfVdi_b;A^#0sl?z1kV=u}Qt^fDhw%a=FrfQ+Pu52mWcJlM&RaZ^K7+ILa6SkR01l=_a?Kf8h zCkq9E84Y@+@@6?RKzB%Qn8Cv3{@@_H{1nG#w$|XA^Rq7|U$2_6X7h{o&h*?scf ztV-N?t@_hRb?;_2UKjHxtHajL`kpR3910UAF>Rj}mpZ`^R9-cFXL#SZ;6Afy)|C@8jMM$tG=H+3 z;rpvsZ+@Zl+wx~0qOYqy`@OoUZatgm`8me(Kla!EQGR?}zTW4@ve}mfjgIxn&c3+Z ze?HIV+xt%co)~?%s>gZjls~#N{S+G-^cmAG)EfTO3%M{QCcjAVet3WYxZlM%pJ`Xk z_p9OYQ%~#dKJ#2uq`T_?yL^qpT&vQet8=z4OIrKqwz5>g?w`L5!+TGyySMqAmA6&d z8x7m4FB48p)sD`-)x^r3^6AORB(}GU`X{;Q)TZ4kjyrP8rC7j0L4|RiBfr?M2F~UD zwp%&Pbf7I+gZ~F-JkPpc`CK+X^8L;9`MjP&oHIlPE-iB92KCh5+}No6X4>l`je4cm zeNTv`gxOu#V<%PST(s)_uGi}(i^talzT5d+?)~1_Jr#wkeYHbZP1zo^FX!f_pzV3F z??b=y7#P0|d;L{%PnTx+xs-Hw#veKAM+F=XG%*;z5DV}c-gY6Md$ZLeCe!KCq|!{k?m}PZQN^?f%}*|G#5J z!rfh^Mzz06e*SvBKK1prwTb30PyG6F@#OPZ^QK>d4hk`hY%j|8l&<{kuC{%H@VphE zB+kUq5mRuG)hOu*$HkitL7zC*#O}Tp{jToG1B1${2^HS@`~MWZyuW|{jOS;B`Nh&( zuE$mTmc6?(^YPWH`jVf!T7&vV2{=`ScJ|Y= z=J&sR-3Pk1_RI{!!&f)Ix^?1ot?3je4uuIqOqIcl#4o-*(z`6P>dmbqFU%%R17{JH z%?H-+|EHBcuX0(BjHS`c-4n}l?Z4efPW|)aW6|5KyB^utUV3n_dGF(MG5qI3qwN(w z&i*1 z@3H@}eQ>|=%Fl9#_WHp>=pid|d!cGr=+{+BKbSABi;wfbVae4WLc{prQNPrv@zGS!Gf zVZt9Ko(q%z%UxmywV)bbaFm$%RvvvaY2BQ!<6zPLuffy~AHvQ|&tO1(F~TXNZVlKT1jy4-o@`Sb1+ z9Ok{(R;0L;-N*KOONjVYg@y)a#=gkn4*#p*w4kZ}q5I{<-DO_UqN^ z^?P`qfX)D}`WqrK-{JH$-K9xKyB0lPy4-11(9*6uMW=P^Z%HS9e|L9N?e8+nr&EIG zlm)ZjE`EOQYoFei$t9u9Znsi!r3$aY+L$cXWP}e%fIgYGJ%b6=eBmHe=O_v|EmHmb(Jah zDLOy@MLTc#ox=9-jm~A67ZSx#A7jIj4%X4qN$c4wpOFr+I zq&nADb>anG(3+z?&(9Wn?=s%?TI4iC?fZLsEzQEix%T||bULwQ`SO)d?9X$z1S*#* zG&sCqI{8;H_eD%d2gs5J2Op;Svo7sY*;?xp&KeRi{e7RTb=a542V%My5JloW&y|2kvJYc-I^ljawbwU^FcKKLMUVr-SUzNAvA0Hhp*15I7 zk=gR!kH>qf(=4Z&e~jNA!~Rgv;lM%$=92awA-y0=Cx|iqYFPE`vv1j_fFJ4eYt^L9 zawc%=?=jFl5WH~m(^FF?d+Y6V+4tv@cjVrx(j~jEEOchizqUVOW74Lqt6K57S0yvq z-KYIsnCm@V@9SU26Q1gGr@UU(w#;{S)o;5O%4%Yh?e_fNdh(YBFDD~QP(Xv~JI#vV zmqMUUxx*6{wOL}OCY8%pPkULs2{a_IeWj?TCCeAdJlp!+$?mo?3bR)F&$qjGtZb>* zR3X_TzkGK^-Z|DQ{a0*zklr-acc2-lt8BI3>{>Rz&HsE=f=jW%A&ASs!T;24x5eNT zGASToXXfU2NB*>}-sV5oDpble>&e?seqMZxv1Wh&{eJ(uYMu2PIop3f9@ks!k7a+^ z$}RrwZcpj!Yd`g}7e9D-eA!d6`2N(-vq6j1Kyyv^AAOvXovpV@{(NgpGXv8_@q`As zztt|>V9SEs6ZXG6HC4^}woTs6O{tewg=&MAiN9L0%+cSiU+%4Jv{>ts^Zoua3>@=z zzdbL!bC=2ee6MAUyYAbiPW^p-|3A^!svD=h7k|w<#hsz?iNFKNFHd&(ZxI4ja|&Bo zz9@#q-mh-#&U^W+@crKJaeBOTgwYAad(izv+ z#Xc%;FN-yc+n#s#h_pyL%ij%N-_t%!)(Tyvl6rdD*WfGK!3&*O1G_UXFZ;Pq?N}49 z&(DWy`Mn>lx|ACnjx87V#aZ?Axk0gsf4$Co#`L7zByWGn)l zX3RY+wxs0crJ~<&w|Bpbm=~-SysRhx%-ZPfr=FdiT|1qB*Mon5cP%&?e`>b*xA>W* z;lCr;zW$5))E>0`SRwCp1(01y|F5e(l7(8vp)#@I+>-g3pUl_YT66yNtIC&k=|Ztv zCs+MfzOX)i{{{KL6;WGPeR*-w`JDB8n~RO5e&X4O>c+ZtC z+gJ7V)gt$OFRPWeKR#KqZS8~A#jv#iKab1Tf4MmMzkbk~2*cawv;MEt{S`OgFuCo$ znOXKVo$GbaMSSG>XPD>D`}5_p|GwAV3lmI(%X&_}PTtYBh(kdjkumLpa!qjtc#zm3 zifd0oRc+tNb9|lue&7GEx2t8Ah;QTW_xqwjBYmrTwd42gDS2_>V038UVmIFWf_eJ! zcJZZR`f)KykM8A zPn$6J!2enK^HM)eUsnNIIsnSVJ0xs&zA84l^82E@{7GSdo5ZavUAsg+nl)Sh|MPjN z-(0JEJlp5h%6YGf*}3WcqwH&IKE|4@XtFMU_eEA~;?uX0Q&*%)_WRJR;>aIksp>@7Jr zgFuJOXy;kpagRNvJF3ow_gUF|>Lu5NYD);V=jhjgme zWKD5bSj5D0LAfe9LkyH|8JOH2OgMRcM$XqY%NBdSepZ-!Ym1<5U+zp23W%BW_)r~MKRrP#`+Qx{o3 ziuMYR>hg|Y5#Wea*!I;+(Y)^!WaQT2fba#)H&fNxi`Rvjz1USb$FBLzv%f3G!NQ1|y&(cRMPCwD%dr~UNQ)X!!u-YPHo-tPbVZT5PBUp?FNT*SjJ z6`u`X7o%A>&-HrprKF!56t~;?%&{=suJrNGo@F~<Im`dxx}1#)Ddh1;6=T zJh=0|t-yV?yZNlov#+h?uJ=E3tXKN^EgRb?y=iq%#5Sa#pLfr&blRn-(;f+lF|s&; zI-5#nq2MN>!h{74>+khY%t`aw*2=Jnqzj<3ABI{bX~JDZEjM>kb1XRfv7^D}S!Jh>!! zXT&_-@5090jnwB9G^H=_zW4e0`S))l*1x^LzcB0iy1BQX7XFQSUGaA7^+&tRrgwME zn19}|a$oO*BQ6Y$1uTDLGbH_@SFnPr9tK91Kin@adhObL&Efxamhd7_-L@{)TGA|M z#`il$C;J-adD<60J9D7<^`c3VV zWfMy*_kXirvt+j3t9FK8Dif z&*{~(LeL<#nV2%G_5$Y5tJm$)y0Kv9#Z77FN*mT~J{r0zWaFotE$8O_mh5W=cbd^IV|dGOdL1FA4rz`K6V9MI5af)GRD5Ucjn1cGi}SL z9NT~1{m+zGwJ+?iuRnR>1c%v*&Smbkp{v8rR@*qTzp%2{Zd$$eqxTeziP`dp<{Uh? z)lgC7#l^+#XQS3_mz;BhLm?r&fpJ%C{31xvBhYrBB>3b_wR#b^)SFj7e!HDtot~~A zv*SXjaL}rIg34|uuB;4Zejj{tlIqf|tE=L!%`CRPudLZ-s_xKJ}+9jv|yb)%L~7^ zRquW@GPCdT23>KTKButlhvhq+?N*aMKHsHz7j$2u$zK=YFQt>sZ*%zhK;j5eI&}CZ zY|vbny?E}^>2XyjdyG9la@c%2p&a%ux|K`RXjjS0Ngr<{_ou$OxmkVQGS;HA@9yq4 zK9gWOA>yRmlDxaS!rpEDx%>b18~;u&Fk#|wacz+Nvf>WstwvDuw85c(DcE-ft6IEJ z%!wOHFP{~r3A{LaY0@9=oLgHw&nW!*9+~z({8?O3xY>)MBHL|iYkq#(8K1DS<=rf~ zFL@uQ&C0S}Gw*L+=H?x|%Rat&miL!0h>__a_XnP;56fI!K%?Id3S3OP%EGoEjeD}n z(7BCgVz>Uj8=+r4Bj0!H@6$+Yv;45__2%cGhHx9Nbd>dd>kn?r9S`iQ{eA1z(s!PY zP7IAIA_)!iTFiUZAkqFHIANCN^-E9uYo_turPJf2?jLpE|0?D4<4tBv!orL!Z@3H`w!ii+fdq97 z_Zk!4jPy?h;k-Ye&CcJm^qsJ}U&+;$B`dy94UhY17Pxt$*HkUlx3{)V_L{17lf(ZE z3ya>)Bey1NhzezhO@|~Ba7t-tNNsdf+qc$tWzEsrpHHVxu8r5verxWY|I?`FtK7VT zL!6S=V~Tx`ottaDcI(^&otz?CAt#RQeV_XCzVIRCh6Yx~v;e5$^^(M%J_P^}YblCyg9MpxG3 z``0xU+$Zn)HHcX`d$3$`RfykJGNlgc%m#IXV<~qXvSysz8Z!g5Y;jY@MWxEmXU$#D zH>u5>ZRnHVKKIJj>~PEXdp^HmDVMmqhGW9}{r}^p>BVaOO1C|~H|OT2q`t|MgZ(UB z`|ST!w6E=6`|8)%*QZ-Jg_Cw`e804{Sl@}0MWADr!@L!y9pAt+?FtPJ8cbHZ%?>>= zTX3>+!K(*Xh69O+ht-+vQU? zIJ|sV1U6_N;6W5k6L^@)XS&%v+O!aKPvV`L&u8^!KUnh)G{61l=V#{i@#k%?AI!Tl z+3wwf(^taRMyc*Dd%NkRGwzw@bB{)Aswg8fyS!xM7nSe34tdT^&% z!GQ+G#;wLL99D;~7n7Z$7rDvh+uPgXB|q$sUY7i^e%~*zYwP3Ruf26)>Hk2lY11Bx z_XNpjax-!K5KdsbJ70JyBosZ^8<#Dce13M!{m^vl@^?D_=*8R!6?R&?J^%i` zPj5D#XNyZeIZ1Wz&EmTjx?Y**=2+f45Ho$lZm(UN7L>le7PQ1eFx>aVwz$}){k6Zp zEx5hJ_=VMEKTsYQ?6`Kk-LuKf7~Inn@Ca;txh#HH<{g#rzt!*eeqZ7{+iVf@&JvHu z$NRTm@{OG+u=L6|J4pF4VesBE@0qM ztRyy~wN$P4)02~lq0d*z$)%U7`tRj9qIrP9*3Uu@+~Rdm;AN3BuibMc#X36sH^ZOT z@&C1c%_-ATi#?aG3>sQ8J9JDW*gm21|KIO>lg}-hQ}_34_{GQn7ERE}jXD1QSKyAF zTNoQ9Sblg*GmE)GgV?#T+-LrIQFAmHm$g%?^)KS$98~{|8{d&Egxx2Jt0ce=oE5_cDU)D+mbSi(&?QLiMKOQ)( zvgzUMbKiEyy_)CooB6nk0uzUYaL50}Zt1?uk|1?}K!MJM<5&LooHhe3u>tkBcjq`c zmA;m|V|8051vJQ}6Sv3W#00~mm-zjr=|l=$HVxFSdAW3Y*F44dN>5Ku_ve$dkx04P z?z17eiN`~SMPP&e0iIp8$ywl$WCw+-Eb~ldFP(k7ZO5yK|Ns6jEq{M+-75bT_ulXS zZ};KgPO}x+*Vl1w)t=b>wdQk*{G9CnrBmCww`5&iwSfKkEne9Lp!F9gStJ&y-{f7q z6CCawE-nt{{n^QzHXCnggj1l+1GUBmo5%; zDd*+4dO7Lmx3{<1WzDWvu=B|j{CiWjuD54nLw7I7biG)qWbIl}{{NHN;?FJ;VB(PR zZD6!|&kqe=4;KgdCD$e{+?;;t`MJ5;zO&7~p1bSUW>Wg<%7NK8m-XtUaoE31D_>{U zy7_9f?e5yYzrJoelrCNVHcET)-LR%MF6UH^B?}ptznJWKSt1Ee7L43Xe|^sE6MOWF zYiIg-xtDi#Zsw6RIuc$P-umTFvGnui`Niif7nXanPqqK|Bl*SGw!nqG#;^LX<<6`J$JR;{nG2PMW7qQSJ_>!TJAG*QufRW zt}WTu_2!)x+VyPr`!AgBSA0%S)8*cp%q^y~AyD4AdI z^U+HO)ZgXR{(if?Fn;#s)?J=)H#9@1Z4iKKS>@mFFGjZ9e-{K9{u>)RQ`SjHjxZjo0bz96q&J z8CS6^b>Gy)wFiDY>ekOG)&239DQD}H9UKZDb~7-S+~a{HO@)Nu1^YSINuRLv{Qd3i zWN-bwA#!y;64k%T$E}oOT|WCJ>)b>46!hNkUTOOFNjm>{pKM*XT1eidC7ztI^A8{0 z<#?w|y0Nnpv`$81!R@cAR#0dD`7f9g>&y53&8ovs*!g5$)O@zE<GuGG*F%*gh_@8?Px za6)R_A}EnvRWLS9T!UiHQ1a45*p-~j6$L9od$J-^C@%R)t;Yv{Kv<~OCvX@ zB|VP(aOYP_a>Kn96W<*bkGoWS=dx<6p@Y0}T959zncJ9z#lbZ^Qo~f>$KnRR{bhzf z1;Y)jPS`x|F;2O%B5b=m3RLA{k^pM`@2sM zn)%xHX~a|BpV2T(_j;^NzB&w@&{0`psSYPiMQg)oZF2tDN!j zhSlNg`PQym5t8!xF#lbH3zyoeFZae**>(#|HRpNjprF9W_JYw-hz)9}kdQ^fx_wuk zvvH+y!qp|tUf(%09{?tRqY)l#Td;o!@wa>i4Au87B+H%%|4Uss)fbb86RKNl7{e~g`TIP~YIr;`o( zBR1EnRV=XJWCKm|W^9{!tXDc+`%6l6BgoK)oCXg3=V#4=I#;2L@vhCf-6#8x)MXlk z>qKw!IcND?M$)dPB8E|TZsYlNmrhO9K7Mstg}zqQmW(~qt@i8r&$BVy>e#=2^VEA) zuXQ80WK8V+pzU+P6Vih`1X_Q!&U`CmSgXOIhN*n^>85H8n`366>jJC3z7oCutkC}d zpW>daPviD@P1V{d&b7hi&*5{)=N+^2c4;o-m~Eclw{p+?Ly6}X zWX~>1|D58z@!Y)d)nUF}BAQ7{XYVq+v&8e7+Rpo1E@glc#tTrwP+#r@O&A^y4}^-*mO&(6=EA5eQUR_2*tcI4Oa6#Td8!yna(T*Q#`l z>B~;_c^gElXLH)z3oCe})Znm#iRZ%MuglC}=EgY8-=3THsRPtnd)TeNZ$cZd^r`3b zpYPjLaeA8W$IzlFt8?BN%?sX|_)bdRVn%;MR@Ax}OL^5~eb5rK6Vmy61b?^wTPN{y zy~I)h2L(w`tLJd+qF!j#Qn2KJ9((j==eEi;x*5A657f8Mlmt~T>s8^7{Od!yX@`(m%H zkC(65oWrYDoSkuYmT9r}q!Rn<%1>sQ=jW}xTYk56`qmq2AEM2gg{2u;4uPDx&(aj; z%nwY#z9)=*=ZV#1)C+!{QzH9fZRF->-??+n%$u$i>eVHx{cL?8<8-TsEy72R@_k|~ zf6V{z%RJfQGlpTSD&FmUp7QL>%&??%w%Vg<1xd;c4nIKgX1?4F8gCnvH{5Bly`7TY zJT3F`GSA6szM!QWar~h1*$V$|aecXpGZ9R;?!2^_R>l&zEpV~hwP|l(vzs!r@o+4f zX?av4w{C&7+9Ux7g;r2dTsXT#8xj->3hg}yx2jp+wOJRtyG-(M8}H<`(c9VTyjO*+ z6aty~N-%%rhQ+(B%<}G7Oj~z6B#iy}?(+A2FK0<`^LKBwIV$L&z{&DS)loWA30g=h z2&`_%liPmd$^Xu;hZIi9+f*2w=QY2h@O)13xqP*_PKBhjqZiVb#j4-^So5)JrfjlOIc<(`men0nGVfv4-6RRCSJL_KWul9 z;qxWzRutdgDc{A~8~>km>-PxHLLuU0r~aew#x z?}2Sf910U!n9Ba8dO2~->VZ~~nwkq{A2T(r%v$wjUBSac6JL03PCNVLh_HW;OY|SJ zMJ}B}m-f|GZ_KRtdNuqsXd>23b6!#W?CyI#&z;seGBm#6HgM?wXS=8s8m1FwG^{&% zE%`>9x|o_&xcf_;Pho4LJVmD6`MuLP_0*J!eX`b3cNzD)_sb=P`TofCQ%arZ`6Owb zD??)j$fR$77nVXz5}4B<7xFKl;Ncw?&|KT>uFWgA1}t_mo>xWc%cJmp2#B ze!J(@s?{k^PE6eP{_OE(Os}Wjc*pWl&_N-ck?qAEYiP(R%w_qPXSJI7>k{9<+m3rv zPENYC(7FA@xh3<h-dhxYZC#h-Mewrmix)_#$@ z{jM75+=#1IM$NB}70ho76a*XCX!CB>vNUMwb~v!|fakI@+qSi9FNYn8_}RuQy(DC1 zkYSu?+{gF(e*2m1_IU+5W+Z=m*MV!pUu4REqnLbFV8%8+bUTxakw}(Fjk4YW6Fhe6d4$=Gd24%zbm}kap#qO z*qRwRcXyd?Pn!7i=cA+Dso&n*+?03M>UHiV<@-|Rc{)!|P2C)Kz4rTE^=9_h(P~q^ z^saQ3KdGSD;2_0e;Nagp+eaMIXK*+$-GM*&RcXActf*G>wl$y?MuBfXhVRa~X*AQm zexFX{CY65*mN6@5KfAgr6p}OFykWBYaDch!yzRoeX_qf;IsEHp?!pIwoJ<@~v<@)X zhAVMF8@r&zwLVMbl10yD=)2vpDt&e0&d%cGJz7>rLHh}~#r3|hz51n7yXWPP$Nk^g zo?KlWK3z!F>xi`4v)4{F&umub`p>riWBRPEh>?jyWi12qmnC~kO(1P^Miw2;7hz9! z>6TY}e|*fh+IvU(nHhrLzXt9KnEq;g%+8>&^>Mnh&GV<}MsGW@(7An6Zqmg?u6uhw zo|>YmT(zunMsrc_1<=Nz^z-vRom8LS;`w9p$~9#(M1#bkaR~8)Kq%u~8$D&On{%Ge zop>tq`MJ50v(0i(MQl#HZ4=wk<)+2@wsoRdGV@Y6~4-4*g%`d-EJ+-hZD z`o{9TuW%?=Ye?{I$Y*^Php1T1t~WXbjNKqIqJ!U2ZL zS1Xstm^?2F)=Zzbd%|)*78&j*r7`wbp-o{1ra-YB_f6gzO)h1-T6t;dJ(b@~pgYJw z3%J*@Jzqad&MtBPbkJl=AZUi|=x(Rk0+1A>;Kh_b`U#bA zz2Ch~Pt#4kx2IBXm(|sfs;%8!D}|vAS%^*#wMMRG8|7!dc~qIQ{@k9*&v}N=yYkC_ z1(bD#?Mpb=)DyNg%5wMiXaCNb?W{5S+qz&av;={UeP=gLkKwz-EuyiZ^v{ovnpQq# zm)9yfx9yObk$soj_Zoi#X!-FoCYjCCp5-&_g7lCXmR=L(?p8Xz|UvG{(oA>(Ob?dS>AL{bTlK=k=-M>Em_3L%9yZ2nbySu#F{{H6l z{_k7&W!>6czW)2J{QLXt_h#)}^Zxz){r7+G-1q8xf6Z0idnPYe|Fc;hp8J1S>Fc`n z_jhajS{04Z?fPs-E$az6`pQ>+}?QgHYC#(6xW_|Z>zVhR>gFYl& zA<@FXxSc6|=Bwuh9?zY-EbcL9pEWJLv#)lgY?8LfP6h_HYEKu(5Y+h4Z8TbD?PuQK zom_BY&F*KKXIMNh>ObEFX;@+dxuIjif&T^pX=-fdSkMI zBS;!-KZnZ$X5rN7Cv%xP-6n*HT)6vM&+O;tkT){5PH;6Kg^ScKm=-TMXH>NP^ohmK z_TSv2f3Ek|?5VJEd}wX9Qm;JaWP25S=I^R`R{4%q zO~~HlP?(^4;lQ6nv*s@+_%HF#s$Q~M&I4jDq>yT0VA9knnDg>>1>4JsvP;$*eP8Cq zwg3MM@X8N_Ne2X(szSoqEREQHpWQ2Qa<>SICma-PS*vE}y-%1R_e-I6zTx#fN1s@# z*-x35Z(r5Rz_gC#(~ea$st}Iv(+aru=S#j?eBvk1n^W#&?=!!eV*4z+^x1juRK8c< zX?3wmpSM;#%igFQ_tmFt?ppmxKWl5RuIEm#i`DoXI{kk3t!Y0$znvNXdiAvXl{Z%Z z%LspV{nx6@@@Lnp`KqtJ&zApEReSbVRD9`#HTSRIe0?~cU*_A^X{Uch#c$qsExa}? zX1(48Du6JYis9;4JWnEM{QPQwCwiilz2t z3=9eko-U3d6>)Fwa_;dB{e9r0YH-LiO=C%=7^BGnZ7w1~K}IH;nHLsJxf1>IzRk+; z<_X({&T1~4l%eG0WhAN?qM@1e|N5@{?cbMG&#gTdd0wvm_h-xbY}xkNw)eN**?s+H z_4=hE>`WXA4Gg2iXc&y91NvrzhB*#$J1@AnF)*?SI504>*odFFU@EuNzWwF-^S?fC z{ipMNk7!5-*i8;xOgf^4=uaw);t_8LQPMl}?^^eXg{}M;S;E^I{Pu>*b|w*D?4>i${Yc) z#^4g?@W>fFGdV9t{nZqob|f=BfmLs#iQL&4ChwPj=gC=S!UGK{h>Ly%KPc-KUbx1+ zd-=j{2PvlGFN(`Kdrm*h+|n70;u1!~#w@E(vzaC@SmXI?W|FRY!4+1O<4=VHk1N}Q z0u*K{$MlBEC3kcBr)9K$EBRN`+!t>UqqD_~f$2I&zqj!+bruExS*XRt3PU-chD~bU z_#gK=2r;EK9<-I~^)H@omoJpNSOdj>3BCt(?wH+OeA54$_50(|ryCps#eZCQ{4w*J zx4v{~$R}r5DiCmBXiVTVxqLSA;m0TH*^~ZxZqUf^bzt37vq|~4xX0%$$0stHE{sIZ ztOACO_pIjI*UXxe?%Sf*J45s34bhC3pMU)ExgLKe&&vhbY(|!UdIfvW3(sG}`AdJ7 ztmq3FmLkCleTK&+ZF$aeRUELe07v`;0SU*l>)=0=^ySHI%xxNk)4ZGY#82aFqk?OJx1asG#t z{oX(I&!?===wNb;K47rj`lmjdV859nQuI0$uzI~%rptfviA}aq%D#{X9rGPx=YHBJ z(0hIMDOpeP?`j(lt(mz#T%I3%C~| zCvAlzOzkhWwO4MMTsx^QvEz5+vfbhm!jDc?UaQ!9wRYDO7o^~C+`(~2vhk$fwI%7j z=Tzfktn`*u%1JN$c*|^At;a1$XhK>76Pg<$H)w6oUAX4||IO#DPD>i4bbQ^x{=}eb zUf-4juO}sMbL|%MJ3r5M>G6!PKdBSnX-+~;VvS2!>?X~5lhSWn^(EuD%>A0ry_4t1qRF!a<6u+U+8?$v*t-~Nw5@tm?ZHv+4A(vJQwkNA+OjvP`aIAgSJZyJ95{N&{0 z9%*yE;!BfD?^L~Bduj4~&!QZcZ=MS4*L}}EX_!6l-3hC@UoX|wm6e^V=A<2c|8TPA zRVCzjWMJWXZ8qcWyd&xg#%X7M+lDqeb-}G_PoJ!{+3}6Pt_1sg_FrD}W4!?za#B>NV+viWZmst3$;rvZ zbLXW0bzJT@cZs_F-pAMXPCQew?#YbY>+9}19)I=qdc3}^-{wd0q9^YuYa%C+6QK|6 zCry?W{(X>L-p9hyoHgy-98KGgGmlzu>^*Sw(&N&DO{|>9v$yBnU2;4t?9XK9`^hRu z;ljYQj^&kyf0_*>T9ITHe%*-&gZY?)gd?^SdRJzZ`iU zBEM&)k!|CnUtjJ{O8$0IeZEiCj(eroV=pC}YX9?n`LWOpInl60KHxlg^4t>7$&=>2 zNtyfMcK&|Lsam0v=KRp%Dms2)n+&Vm1ex`*yGlGO_k4SC(Ya_%TL0aijVJ}rMPUs! z%bPFn@2@{KdF~ovb-y_pwl80b@6GGYal5K|e0AsEl#`RD9DlPd_x2niRWFbJaN+vQ zlPovG?~_$kx7AL*^FPu1ujR^*S&#VS?QGsYe05OV zE3#hvSlimq8T!Z`k%>vzd!^<1IqUa6)te@ZCcL||bCPh0@NXwJuLrDWlJ6!xUXXTn z*0p1+*{uaqEawRRh+Eu3?@u=~~~iO-yqOk4Yv?Hh!D1ZNnpuZ3m=- z9$!5&*QRpQR>R%-_wAO~{rxrRv8ndAu)E(*9eigN)s7r5c`RvOz7_N8|5avBp1a0j ze$A)OFD=h)%rmBZbY0MYCBn4u_m`K+wR`q`JSKhVv8ndI+55h5OhwLs4W^B3LBjK< z=|)G*f0M%c=IZL{PnM)lHH~GuDfYuBYmb;-%#FycSyNBUkTp*0c~Ws!?zi0S2S<>L z6vp=~d6Q>-@R@Dqo3bgnNiSl9L)D?;W#zFBzIv=|9=)N$Zakr>hJG#EgwcoY^Ymg=~b&|80LFsQ|jri{_xF{ z8&|q(wKG4O70zgZ6sHafE=;mZ)VLoX?-!r{VMgt$rMLd4$Alf@JC|VQZ_@GgJ2StH zf?b?1>-xRlW<~I^|H!%iKUUr1uDdsiArlV>3r(K)>gwuhqnn0PdE{&&iVl5tRC4%t z$GEXy<=Cpu$kk!G=Z~#k`6B-Rujx-_oRz!1XZ`%^o8=ZMA?JM$?+5Okp67G7-+gwo zCH?WS-b<6`ZoVw^EJd2>t?IGNurulNDvxdcI4d*|oc(jd{+u+kYLGxqBMRCVVzVwK z-`o22(~dWrPOGR}-*KHT+n%?`f3no-wb9$Z6|MLedi~ee*K>_hPkHp+ezS3Xd9#ls zvMWCLKk)4IJioxP*=GKSoZH*Zo}6#L|4GX8lK;CjznO+#Vfw9lY*nXa^|ze!$Fsv) z)8?|R+*8z1?e)f8hylqdED;IKN1i17`tow0Pla2bjHczynZgh1da5q}Q#JJS_4zzw z=l$bH#p87>^EMxkTVAXu@b#cm9g+bpfeYpyS@L|v;=WJ0`#zsFzwhB+azp&?{E7dz z9*HnDwEzF7`2Ml%u%p%A-<28}87(=U7gn=bLj|Sl%i{AOtkd&+>Gjy>uUpbjOi-L8 zJoh`(wf4e{zMIedmiV8Y`+9*){{Fw)JouOnmOpZ@{9o_Fa*RzAQsaV)WdY8{ zBB9Cio}Hb|o^;4K;Q+(Q&U1e}dKwB;E;=X8nKh$MC*{R6efRhG_NpGw`*!2;VMCS- zRiskmqPT>H;YY*nEvyeCb`&i9qO!dFOS^}H(Hw05cJ$YO0 zx@6Fak(`^{ytv^<|R z| zPIc(LI!Eg9!$pPjGoK$?Wb0XgoS;sGE|_-Y$niDvIR5gW)YXm2?k^4Jh}KIi7DP5> zkLZtU-&j2S6~3{SUfW#rv*_i?-kbjO4$nK_bo;Tf_B~ed7=bH^RTs)~Z)`ZYGG^zd zFBa#z?jMT_7vcmNqoBdm&azZ-3p0rGAfL(o)&Er~x0i&j4r~0oGk$ws?A7J|^0zh9 z`>zN5Kb~=tD@mk!!nv&*L-sYZ^H1Z_mD=vq%Jr&|T~1)Fa&*CGyDH1|T8rh7g8Gq8 zL7(5fUvqc#+yAq;P_A}%Tc}WFdiT%vf8S3P%0)~o`tP)A{;%)v{H@_@VnaLTGP@R+3Z(jee=Kk>o zy=+%j2D?|uq#u=^7?xjTgp}quR74^Ys)epB^%j@@%=b}Zb@=*kNlC>;hvXJG_%X45 z`TytMw;N}=uCI@`|M>A~DC_!tzgCGqzHwz^e0`L047fSGNKxQMx!~f1-eMdI4GyQ6 zN`vi;rwh+E$xO0d;<4w|)z#X2!*_eU$#FdH5iW4?$M%&J2r)e z7S-?0^6ELgW`=F`H=pV|EQSu0njN$G7WynZ5YkyVQ?&Trp2~$%^Yf&4CmrQlo^Y_~QnID?zQ~wK z;Isfs>pEO}lB<=bOq}?z%uaAc5wDcVgn2h+xNox*;+Dy;_DSnszWqA)l^vV!&hVV9 z=Gp&v&5!+A*B1+wtE)mC12*VDZ$st&>%WfvVHJ-_s6O}5bB}mj#lc;!eEUT2miU}G zy+_+nZ*!7f)Rq&IKR!uU{q?s>|JbILkGIa~5543LHUUf=nB}0~*?D1czul|ncU0Ey zV&|9BvEBGk@7KZheDhAjnWCTnd_M1=UDNXN$z^~0*ead$qx(gL(s-Xpv8$Sw7 zUU;-yyggIy^Y(3dcXwUYjNiBC$&s}6X8NL!4X0~-Jt~xZ>ByPM>iwVJZol7FmZNt2 zgM9s;iysT>zijKYnr4sWB!}z+=)}FCnzu&d0WReV0GH+sH zR#kIOGZJV`J~zh_)SRnclyJYz@Jp%CV?*s{z2^5MS`%j$@hx`iog{ZY@*{g|;fIT9 zNO|p#n1Qg%Yw@?wWZ$ijNi(hDT%2S0`ll@iQ&4^4-M+U$*Phwt@EsSd(^7f;{*?bN z`D~Vyn2S6}1~@4v{QdjcEccd6mfV)q(_+hAI)x@p{-U{1Qg;(?tw&Z--XpuOSAr)> zO<$>&EOx@U|Ce{vf63prHy=8cfQ^Y}YQMqdA_HPKZeh`SxjB28sABu%e*1qFw-sx9 z!*`WrmOh;t?zL@UKi@siO-%wv)-AYg5wdEo`kaC$DT9QDkRJg@*M_W|wCn%B-+MDQ z|8z9C)!nrMDP1>eaD2Ju8L@xzw{zC-msAz&Uw9t6HtOoGP_zHr7aJ_NbmE|nj@q-| z?{>dutIGL#aYrLFdsn6Wh3RiENr=zsLbO{Qa#-GNv(?lJSutUA{(U?9XVQ;K|NXxI zf7-kYGu|G3R54@s^Q3KitG)`!ODC>LI6u$U@A5L=qjxrceW~^Lef#mkgvrK8QFoH# z%vM{&Oa0s13)el`byie6Y|5MqHB)__yRLXsyX|=5w~F|hkFBr&^+q48{QS(b@A;dJ z^8FVoR7F_?92AO}_B6}w)KgVt5#U(qpnUsn-t~2J-%e=kTE6||q#S=;*_tgWtc*Ri zEAlS42ECQCsn~F7^>*)8{@Od&)<&;3Og>gI@p$E~N!@!_bXXx}U5>>KGv`F_um1LG z^?J8|YAIW@uCCdg`kH&Q?bV5iG69;~B6IG4{`2#*b>OXc{-5;2w&&edIbQPZhHS8m z`kXeTkXpjJZrY3m|NneGKk0La!;yJ5m7Bh#Je%mzzh}St_pL`PObp%oWF$L23bnbd ziQRo|_1f!p*K31q+#b&kK`Pq{R1FS)JF=qe?XAQa-4U6K*}Jn%i?4P+)GKLwYdAx6 zJ*aQJe*eF$rRyIHrJS0gc`4o|^=Q53ox{_vDK{`MT@-#G`{l(~O-aQDhaD_ux=zi_ zHMh+AJzxGz`jHO7Z9n;X%GZ{#GIrFj3z5#-@sMq4xyS@A`I9?pe|-rQkJH#D<50Fa z_-lQPn5WAmCs?)>a8O`nEN;yCn|Jf?_xtkGXZOym+?Id;-mZs?e=ixg?&CeJdEBGN zQP|kezsTcH>**6GCdgfn{Ahg0C;~hfAyCTrZh`yW_LKaKEKPa^lU$gsOI|1lnr$%5 z-}O@M<+fPG*v9^kzdf(6y>C06OSXGQzs;wPQ`7b5i|@Sm)K&EgQoqvS0_(I_Y*Bl? z)9(H3eSC3!y#4Av%P*%lEZ|=za(nx^ZxSXS&)kjg`@;He-|xJag>yyk>x7*|)}OAxgXaD!hmvmOeo(*YdrCxTPDZ3jVc)M)v>LU^+hVnHZ4hr-wN-*15{{G&jWNYoZ z$v6I)s1<^8E4VOgyulr#YG^sjAkoPnT~cm~m;Ea}+liG*NsGUgb{a4zOx@07h5V^j@?~mnR;r<#Ca#abe+gp zt7rJn=gjN%`|Y+R2WWlFyu8e_|Mi+5hn0=?c_L+T#_LS(9zK12w%;OF{&dWE)F*B3 zSEcm1_1$g_olRL{Y{DC(_Se;B9P^$bwQ9SF$jkN2#}4}c+V8#VpQoE6+%t?UN(u^_ z_RhLjY~}NrcjLCI4YpTjaP%D9DkS`6U+wR%uiA~W%U!$0;(RWtyCl?1W@6${5b$c$ zxWmYyYSZh+(0GHpWRgI}-CbK>Hw7QgiB=ts&v0WABj@NTS9UsLh%(Vc`dY8Tc`G zqoj}KmdClbAD=(6I(oZa@&)F`=ku!ls&Z!kc)!G8odqi>Rup_0-z`|qdEzCg;ljlf z`qk2XdBHtLf6I?Ygmc?@O7~1ucK6!;zasXa@1?06NAlMs&r=Wx|N7=;u#%1;zktQ# z9^)&e*JIV+UWyAZSXiQZ1gQ!?{!}1$Lo8mzbo+X*WFck_G`NP1nHSMx2New zKa(lDk$CCx?@0o^`LjTUbW2=AzN_>7R?u*iqR5Wu?KfYUxuq5EIIX|mrbT3vuU^oS z4y!*O4quJVpQ-!&Xx}WWO_ixReG$ChnBtc?mu?k*S3gm%?nh$i-d#7NY$qH~+!ea4 z@b;JGMGDa~oED#&qPh6f^YiP|&d!>8=;k_q!}wP=Z+DrnB9&Gg6CEP&hP^J|)5b49 z@6Flm5mUb>+%~gV-DsG6 zEajf3xK-bULT~P)YT&7l1B^^Q7bJx^6dD?~Gxg?#PgnPsySge=`*xzT==#{*WmzXC zC|dR5d$G1gP+<9UzAcbex_owI!I(W-A9^wu41G6)CLm657O>kE#dD&vD@q2_?6z*Nq3(ZojvROJu{ZQ$LL5OlCu- z#{P*UG@T287`9>Gr0AtyQ|q)NFTI-f>R#rLkjZAjPW?>sGcNA^RX^ps=Giw_%dY z-V2tkb%-pqDtjaGBzJGl@@(CE7Zy5SJ*hrFM>kHd@r=3p|4HkPxc-sTJEamk=inY; z*jj)k_5c5A<;P94_mDc*ES$IVsn}BS9`EhT=9f0CzRY{*C)lQwoCc2m=ejR}lB^Ze zwRkb}^3xVU!Up|J)df74N`L%aQGLsJ>zp}NUtc|Cln-5^_2J89|J7MnS1qmDWqJOM z+Xkb#40F0cMcjlv48mWYoV5Uz-X5+8Y?5kRwAAI^$cVl0iro^p*zMIscR5enhTq2j z{l&k&4*bp&``z%}>{shjZf;7QdNX>S@(w1`>}w&L)6a*UTo;%a$GG$Dw%c--X3ji* z8zsFiX^6DC^Goiib@@ASq z#9gJY-^K2$sjQoA$eQ%_x*_x5E!Vc?-k!28Bzk+EsK@_&#j}s!`Fn;JIsCc#Yrp@N z*yne47KhF@%gt$5owwmYxBk8r_p0C9e!UtVuW2h7-pVB!bai!j_}ZwgLC>bPE^S+MNlKsi77PadC{AV$8YgT-mZA|ZeiV? zaI61ZyPDdUYM&I_Klg|@lWkRp4%d4{?$Dhg84owf90lhO9WDdM?H!&PATz`pYkvJV z-@5iN*Sj)T`HBaOQzs@~3lX;c_438@j%y$GKe$%TYp~GY>ZMBmEPqow?kk^n)~y0n zCrO$ISZt@=^}EEO@L*%Z*ONOl>kqf_+WIN~x_Y<%|KB*3%I)ixbg+v?&i94r^uZ*nUYK#3J)eT2$#%%uu_bX zB}p~mZ{Wp8N4saU9=Bj&dAIAe-qVA>|JIgVX6G=m*G@^_%MclN`=fQ~s}yUMk4!oX zjtA^!Fz;Um>T^yMNobNgnWw7BBET`D;j8-{e)~TK+w6tjJTXi@#^Lr~`%Ck$`)3Xn z3b~7SE;u{ed^(5snFm~RMDHxSXaow&Sxi0`7T;W-(#pVeP-sQwZp)vapU+RVR{Qu* zJ>i{5eBn{iODgU!xYRsC79DT@%31aH*4C-_l6)8KJi@ci;r#=%-f19LTm-q|Y@Mn$ zivUMo!%gnB8{R&PDY@wSGxxa4z5A^1_I{7My2MjBa~j{Srf8k;qC5BYR%=J~y=-lL zt0t^p+xY00;rGv%`JGw7&7$p0J{RtK1@bYn2zdA|2+LajwCyUeHA_cs4FyIt7% z-Jh{vu5^Fk^*dJ=?LXm_7rQHBzh=H+suL$yjE2PQ3*a=z&SBt~?xE1Yz_f{}H@AI# z{QiBMkq63R9{mko;M~rab)-Wu?!ujw+L|dVl_qlTihMXvc^Xsi*Vr%9HlCTY1XRV! zv&>lVyTNZNhk}51JLeu(iF?QNOs}e$jdw}st5;k(IfwF&xkcaZ&Aqy6 z>Z$<8EL-c_YgOkpIFvWeXaP@Ko^Wj7v^vbh$RaR7)ZqPsXxo2#n)6K64)WWH+ zV28u?iSHK0C<$x6n^%3|_rZ0KY&vs)H_bI#3z|6iBbdndWvYOY^rcZe4xG^jS0QSf-;u#(MeU^|CE(7uY}v z@DwNk-r4=6je)6-+ho(-hMpdt+lrmjTO4Ma;>@oJn^LA4FHJ~0xFflL>%MRI8*^7q zb$Z_xt)azS(5%afNH{kj}l-_|c{{Y}aIxk~Ud&&g`5GA=GUImhW{2Di+z%iiV78#A~k z$}({%OjyPs{KbUPQkIcL;DqafeJwtppPf}bBxLN#_<6-|+44IRpG10!{{MR5Qk76$ z$GF4L^c?GJZF{KGQL*~{M8N&+2 zn^bj}IF7_UDAFyM@5>r?dE3fN^|1Ty%`sbJbuio%)M!4#$ zSN=;~M5k(p`_=y6J9G1G%V%e2FOS-um#Z!jSR;O8Q)+kBx0~r#=U5hB=@Qkx^6l;I z(1lK|AzQPqhMbWvG(?$f;M)7X)4zqu|LXSLiR)^9aux(8{LeMx?~C01{r6Uf zub)z>zxT_fDd%lJxXj+T#!>;eF zVmrTB)bl%=I;dCxml7O5R5v(=zj@U+^>&f4x}Q%;c(?s`&j*`M>utVty~@$d-M(y2 znAl?Xe!tzivQ{M?t9j?h@G#n1mU~UnnE0vULjP{-&1q*(>CRkP_qSka9Ju&`5R(Ko zUYA{(>$5ZU^fcDTtLBIOaegp8zOHap*xFg2Tr{#}Y`$D@4l6lt@wjKo?V>Az?w0rK zey^QcCUC^Q@$c{N)?Z&;^{$jj`G2$I?bhp7)!*Np)tsqz@=wANaGM*{sA*tes^i$= zllJKCwm0wh|9^M?s-3C2$PC-+vZ%=mx%GA^B+8x?vG{(ccyeBU<^NcHxoJM8Q+QV# zFufi#x#Yk6oAki5vrJ`;kMUdF`|_AwrxaEn;Q>BGy)EU?%(}aa!Tkq z9hZs&7j0+C_e}wn5uj?5MZn=ecH`|ydtdm5?2F!>cQ5{FaIzOu_O&&IU!3ySskx`I z{!pJ^W3;qtlI6)Og|AjFx2k%*ZU3#*d%k(Mx2-LHy>|O2k7}bCiW=5=cPzpm>t8%S z_s+jPuH9ni)aTbsQvEpXx_!b*eo&7TGJ4XO!V>5C^^p1Y&tJMuDb5hPaO4fs=jZ3k z_4fTpdj4W@|G(QQD^pHRI(Jfi{+k(|Q{vtA-V6V}D)VZqPQkUv^iIDEXV0$$jXq6Q z^F5WdbM@KFlYc6DMS@DMbxc1W&9bNjbt{{g+;8=*eP45n&(kKcF>Gy==4Zp>^7Vff zf);cvmA4M7T3YsSmT>#|>HYElJEtCsPI`K3>Z9K4@t;=w`}=$KQt#=jcE8(|J!Rd7 z_KKw;pgeWNp`rFd@`aO2IvAMdabMXSySR@1ZkflUN{s}yBTK!f^Bs9|=kS)5r_>q$ z^6g4DyXs&k_hr)yI0}ppybJ~{ujBi(N z;3GwW*v3Px+|{%0xXafr`7-bIdqiNnds`G*;M{u~rD`dZAo^P}_;`;Ah|3W^ktXl<26i&JaSZuG{b$=}Aps;|6 zJ7?SK%*)Hn4hwQKvMA{-*#7gg_2G5980BC1bMKdS`U~>a4VD=T+SeWjEi`Cxd|*1e z_szY%yU!LJabjrf;0{?G<~z6g-Ojr7%x&{#EVqCDBdkau_2s<5?Dudas2hyMQl{`*SN`q1n;v9c@k#lIfcSq2$Xo6yW4T++tM z#G#;|{$UeeY;^rA_2{EV#pBn=RXk`+@m~yDwDrNf@z>YatL1E~R&33_zUu1g@ZW2b z!^-S^>+fBk|Nd_t&sR_qb_6xyj>IkWmxTWdv$ra|1;&cpfsIWWg^MQ za!6rA?rk$r$@BHi=JUVq#(dUooVjB5?w61eym~GJ$8-%)gvfDO^j$7|dTOfi*~QCt zm%R;g?Gg!0E6UsE`Un)#dxQ*xzhtl5>6Uxr!EfI;mrKuG-g9bp6=+ys0k?r8e--~l zI~IYCDGl=$^k3$T62JNpnN`dAZVmKcBDmoUHcq?!SGz7|;K_%K=VAO$r4b z0#c6BATuO5OZo!WE$L!lVieN|SkN%bqHs~wmy7OGf0oPhf8O)g((ao7RZwb6V41Oi zeVKL!2NQ=&tiyd<`@rWBs;??1$un`Zct2Rwtrzt9+1cQ-Y9Qb>$gB{51Jf=I2={cZecZliNqVL(U zuDvO%B<<_={M!Hj_x>}-Z%(#lD9HDgI_nqRz7ZZ@Yg#;e@y6uitK{o`9DJKuul@aI z`ux;5hxtXPG&Sd*_XN4ak7=rQc-Zp!b-R8&>ej#V>gwvfZdpsU|M=EFtBy7N3hIr; zaTT!N_0E0e#L#$y^9ARxkhxoCE|LFI@%?VO@qOd^pHHU?idg&)c<0lt zoyE(g43kubJyzu&7?a!dP^ulDk|T=g1{nkJIkD36_O{&M^f`rX zukP>PZ}fYXx7@S2WuR8GgV%#T>vsX$@7L`P`O$pT^gZ*|FHlFRfE*Px{RY@kwcqzl z^ZU1&nNiJW#sarKnU!XFcV2Y%-W0#PTy(na$$l>Z2L%Zxe%mh-q|DBIetXLP`pxo7 z^6}HA^0(QnbpVA>0lRIMt(P5#f`CZlxtr3PDnF-PT_10sy3OHpR#Dz7^RNH@{eJIg zxKNfuK_IZvTYqne?WYsUap~dy;TAVvdx2Xo6GRf4^j3Q3un2T)K42MnvR~TV&ouLr zi|yw##``MX+}wP8deur1MwUma1}P^5ObZ{mte7;bS7reElRV7X@GBc%q19M&(7 z-=^)q_cQzYy0bNN{@zTV|Ml#n3(owZyUX8yTl=ped{4~w_cI!{Pkg2*VAXg%zCO0} z{k_{W|2ePXQRlwxjcf`H4u4o~ZOvZ3%zys6Gfq?GXq=9|}s_ z*H|l#+_lnV6m(EH#uWSc+1cMW_SODA#eOv5<)x*o>i+(6%;bCPz|c5@6Ev2+D*gPt zQ#txCFD8C-%U@-0ZL_LB3se@YX1e3J{gkHxi$KT5hRA(CzAE^hW9N}L@WkdA^Q0?+ z98I9k=an}%H;3Nbl)5*|&o}mBaa^dIEhrRn8Q(3qEv72R#Bs!TL9gGBy1$lY9-ZMU zgIsl^ws=g{2vqVoyGWNqK_IwM)qC2CZMnBs$y(d&-dH<#**@iEcb4=rFe!>X;H&De z?q8C&3g58`q}=#kB9gCi2Hbc{>?{I0~wh(6cU^pICt^7 zCMh&H#IQ)ca*4k%Kg`k7B7R@Zt52u(!}a%kXnJ*LXK}zRS8GrfjbW8C%UJ=M*tl2m zm{)&_QHg5&%k$6ULfm9Qh1)JBp9_~opVY7jbaXpZ&wUa7D_B*7lV8pz!gr>T>)gs` zGhbbB=I8a=oB>*^H6dU@=H+Es|Ns5XdKa^~r~OCby`P5GxqlSnghfFGbtadAqrdQk z%YqIHVob~>)AV2ZA5=)GzLmLrrTV-ICtg{rDXkBhE+}qcWMl~v%DBI8Z`97BrN90Z zf1G{W{RP{s>yzWWS1z0bTBl#3alkBFE-6@)iK8VbVME?mVaJThySqxS-Yvhsc2~(u zp_XUh;fw=a4UtzqHS^nT5Yl#>;P>l%I&2lrO0ErE)vJo;v@Bc4tXa0}o$InPyc?{AwE);sg#6D^Q4Bd>q3f(6Q;jQmdWqfBiPZ?XAi> zH^(yTjKt<>0Z>2)*fzepx*F780d-Zp)x+b%3)VuX&@KrkG|lUid#=>r5W>p#;>a1h z=lkTY$Jg(T+Lkjj>-M&_>)$RYVi9m~h+2?(dRo?_Bb}G7&iIkm6bD<-;NjZf`Y0&y zu?)xw4KwH1KTU4}jTQUb{aj-8|Ig>YIc%k%2IM@hE9>LqpPrno{&}V1!Nn8$a@W8O1uiXZ8sTIw&+TJ%2Gr?dQzvCnhRiUAz6>t90QN(u^zuA3_(TpP%GU(lBp12I%Kr7fD8BS8B!C+2-oSQJYfFzLT+8Hf4>}Q$YuZn1=ETM>|(CFtRu)7@RnN z^5@m?__fc@&p-dfhK0FRO{t+_kHgDLOO4|{3)-E#{P8yTb;k;jt1}tzIr`7)5f*Sz zNMd3xv3vaY#K|==Hg$h0N?$HbJ6Hj#Ru~#}8fTeiuX=lX`|5uCe-T1U=kVD@ZemIT zg~>^-4;|H;lBT#bG-`0pSunZsc7F>SkHmz^_7@YJD<+)euYcvj(D;DcqHl55^>u6a z{ri=D^4Pb_2j@>*({KZnA&i(}B-IwXMzRQWOma}3d**bUddZK6?W;M3)mAK@SJicL z=k*^~+8LM@3K?kcvj4N;$0dcuPOVPKf({Cwm~0-&{nS%)WDz*wsIdQEz5XlzQhm^} z(JQal?_XzC{_aicR&bfn682!l;=Z8!wcqDPZONDz!nd^KLHw8J&MUb(K(i+*$_JF+ zoy-UnV`N#R^kI+RlM?;OFE20e2erqhhX#p*8mpX*^7VfLudWDm{`=*!f6&jIU!S>e z-(RAopa*J4hBa{Riq<@(*x(St;`Z7l?~~EY)$4Y7-7UQydu?^ho{GX}u}ghto2{H{ zU7q%@_;{b}%>O3u^WNRtYyElt(^FG}RlTR3`IEjjYOB%z$}@(?Q~qss=@hzl+ZEi< z*mj`y``zX1_I&cXow)h9^veH_%T982^fEAU><~<7dgs<@#GxP{+W5|DV)!1PV|(l? zPpYPMmsTGK4Z-a^aA#HM>Pvi48g+V1|}+w|{EjZnryP?OahG+3<>$i~RBNFg9v{o}-cBA>Npb_%Pn`uF#D z^y<84XJ%&I*pT>Y_4<9A#Eh3a{QUg<{G1i$`S)T>b8m%g&A%TvRX;v%i(eBcy>zmi zc{Hn;jn^wgXRiH!``S+(B}@gNAe^v{K^WRhKcr;fY<^|))thR*vzDB*d@hr1=5POZ z%hi*0n|N1;t(}#1eO>IcC4ZMp_6rJK72;{e@>I})p>YeVRoR;rY3Jw7Et}KKVi5mq z-4sX?gHLHF@G(7GcfvGIHS67{8MWtfWuGNoiJ8Loaz)hEtY=wYKv~|l`ddiaZwo#a zfeqRpKA*QwU#Gt@@9wTM^?5fpseYc{$}N7bX4TUThxvl1YKNcu^WG@+)Qz<^3oe4n z`m0;B!%tr8y?&70JIo=6MZlqf(<+&Pk>!z2LRhx>>TT6UGs+L=+BZc)$D*q){R`1H zEWcL$_0`fo`+q;q?0zG|p)g_20rmMci^A4KEPQr$_Vk}pr*Cb|zWVFy>sWTpur)KZ zLRU>Ox;<&;QH8Usp0ADGey%1~HLJbSD)ZBmlan${uO1Zlf>^F#&iHPDv6+B_!YQV- z`e@_LrvF9kkM+y1XXBH}*g9|b`+d=|wO_A>C3~?OYaf|?{Ne9!Z)aONK5$@Y+|QkJ zZ%^dj&*!XPeLim={(j%@b)c5G(fb~6nY53`z4iBA`6b>ilv^rY{PNOLEoJ4yxgSGL z?Op5tYQm|`InAIt95leAFk$zB)4%#<^zEv+74|Nk`Pccr?e`^rgWN>5LJB}t@$msoJst(*RiU=iEmjSZn~B8Zq>})7XvNNbbYwHyZn63DF^>MizkUy zDtzE?l(jBfA!(eZ@%QMIs@H3`ugU4mXx>@&_Ey%fFE3~IA8h}7V_)rVqn|Ure`@Vp zYPIe~Zq>pvVKLYs8^;_6<-1BRcWcl5sO~dk!jCZjF4ZsA)8;*SFg5gBRn?al5BGe# zm92TIK#J+0@Q*i}&(ASTK4y`7YfIs$Cntq(?BD&Xd((r5OK&U+Th$@$(#7*@ zO8(m@D<7`>eAayFiM7XSpH2;5^84(X{6mfK{Pe&np=6i%qRw;g@9y4ywfkgB)6A*o zgtzMJ)!$p_%%1-6Q0vJLfntr#Tse1lT{V0yH)FZ!qfg&8ZrYp`W=*uH`u0ZiX1n#) zXh-q={TfX$Q;$R~2-+k*`{XopZh_qU`|fUkeR=!6D(_E=jHhhO-}zMR{;%e)#fqS^ z&^m2yvooKi%9MKcNq;S;<^2SWz<-e4U-B~O<-Qcx?-B8N6JY6OhoHp#cdhA*KBu3V z@$hx)%k}&Jy$V?$7yIjwammNCcfX{bp7!&Wd5D}}W8h*p%Xay?iWkRf7R?X6RDW-& zw|M&HWxkE?zI;A!AHOMnd*)-CygEZr{R7D~9g7`=Uvghk&_xUDcNT&!h(jil)D_-#+%TS9jT zR#;y=nqpO-_fG6*?Vj)Vs(sX^cx4!5Tu|7*yXzOTPJ);~_MIJthYF{hJKt?FH+rEH z>+@!QJC2U zP0fP?jT3k7&e)bb+rEC^`&xJAKjH@5oMJi=0Z-mfcyfN8!BM@)O-nw%Tt5HT{hO9s z9z1N9pZ4bW*In~JssB-{W>Zo{p z$o=~NwU-R{*gbr+`Fz;pI`t0oNtN!+Xmzd?8sJy#L$+atG+UG|vuCJdz%cgRZ zc<9b`$>-HI<0NCpCiM@0KA*Qf)NfR6wePI* z<6o!Qo-b^dI~CLN_WS*M|BiL)56?BRa?b&6H8Wga{-Sf!=ZEd`Y4gIDdWoLDRezY* zTqS4qb=G4&lFBpxAL97er>Y7or4MX9u<@neHNLWc%KbKvzHWVN|7x~f?XD+BQ=aYK zDb#+mDD%Vw#lFZTzMJ}kdUN;H7*3Y$%iz3IeBQQECO_}^%A2~6jtKjgtlRz0D*afG zWZypNyuHn5lqTfePF{ScncptMw!MVum3qC*=0|&a?-X?w&U$@6K?F3C0?toLY9FRt zaSiJh)4jBlZA)3+>aevc`YN)UH*Ng#@y+J*R(E%oi=S1VT9~jcw&?f2y;}r7UKY1_ zzvnZP`LR1aryuv*-`n}?)oR(l7W-E3e*Dtw>>SI>#mg7`wUxH5+Op(ePsiVRs-#=Y=&uV?Roxl9lRBiQH;YNSg z-hWtnX7Nv%hoV0o_uJ30tNq22=A$ZAztn4L(K*ZKbIu$;_qXcmqa~C5K3zF&6ZZcw zzdcLZgtxc0p4JRr*0ZGX&LYKib+$q9o%|o-9^7&fKeX~+rNFjO+_wN z?wFR|#l*^0@hWZK6pl-UZ?|6edRE{4eZSC3_|~Tn;R!Qub4F}>3R?I1yYz|n`aMdO zA76ZVb@lXj8DC~K-&rCZomD3%ss4|0(H1Z;QCiqgIsL|-^>g3c&tHFPx<=rkoi7%3 z&xzcerh4XRKhraAtMxjYUKwVyuspr7F}Xc?UYdZ>iAu@Z`ug-BYtY&vP?e*gmar{M zc;^PI?{|us3;*6&7i&H7&!#(J>*HiQY&J_J-fR6{{WRBjVbqq4zy&cGKJS=fcbAF& zwVw3q{0uqUs+78qB5lt3lV42Hi@jxh{4k&O8N>4T%|$&jmO)0}Cm*e27LtIKFdQ=u z2(OH@QMc0P(5^l|+uZ-tqKlG-NiG5F`u|_#`+OsFo=v68XZsrx8COQP5e+@tH z@AVCpF;*Avr|SRTlW}p;%-7mF@%wB_Vz*>n)mmQo_}IM4S^DzLMKgB4`1$$y^izL- zHvGM}#1d96H*`4I$(HUua(#2&hmMK9 z{5DH}eV2&lqtg*5q}0>0*SX78s$4pEsC>%*SN5A5;sW{@nb|ygSC>xwm+Mmm^_D<& zqf?Ya%KOip!fGs!qAuDPX@6vG>HPWexIDYk@erxPhppmWJ7v!N?z4X9v2^DgWrYiS ztIOk$Ib8d(bMM#xk5$-?jBj| zYt#3cKTf)^z_D*m#YaqSRLkYy9$=D?dFsd2V65oK~sg+~k;G`P=JnzSw&uspk9L@=3o#pIc2kll54> z?nh!)Z{LB)+2;9WXLf%RvM=6z+$7$I?ct86)1p<1bESUYzsCTs9~2rKp0J#G_14}y zMn^AV!-4Ow59>y6>xh+MOD(O6J~6-MQ)lqrs#3%CbB@hedH#!F`*$X0cD^rL)_YIU zcxdzELGwLzsRL4H`?%5^%{%Asjx=oElznJ=e4XaZ=RZ#TbyEW^U<55H=-BJv-`RZx zw7>PyrW-ySDxZuE@7MqT>+mFFv*7J*xy4rH?{w0p1;>ARdHHx6*O4Mc&@Ko6-#@Md z`PO8_m%Q~mzaKO{ZzIfcA@A-k&!@lI|II8)c~jrb4DM4jFfdIN`my~8 z%eQsA-*FvjO`NRe>!QbVdwafo$Dbuq55GPtydGD*Hbm>lS;vGE6BL!|^^1N*3Qhfc zMwRW-iHXXtzaRd1+&?{|?2=*Y_K(t{EAO9Bf%QH&ir-K$bd29!mU~IOaGU>+2hIFP z^y=d4ex}|&%Nt{}xvk;IjT5?QGr|w^$2^x^;%NWx$KuKA{&FApt&Q5c$~gI0kHN(s zm%=`4?0Ry4vv_>X#p!$a)`WccI#YGye_cLMNe1$Qi`#;UM_Lm>+ieRSD^99T?}+&^ ztJ6J(Z!_z(BN8Vy(>AA_eRSwm_Pj~!Yg4{vcZ=!HnW`QBYgT%MR{Xx2oiFZhTo=2W zt?5ylbl!wBo4r%&v?qh6B|%0XiAq><4`XXk>h7+t0R|GC*Dm?f)RJn~` zUhmP2%QtpEpI5!dOMBZ_lZ*=vTkNe%UOaenXQ%PDeJfS!-tYb1_03b@+G&H`Y)?*4 z_t!eVapONSKMY z^Ug}2XU~Kk=Atl->1XM+-#PIDvs`aB6?o|Kl|SlKXH&F|zXe)-;u#zBU-#XGh0e7n z_4%gGtN-^isWxJ<8}IQus!u(9A6yNO7kw@Lx!8^)evV$ujsTyUq*u-%E z)l#41og4}ZDi?wt^)=t~b6>IZ-Qic=4ykrR?f0yslyWqZ{yn$<9~k%L{b7FlHDBy5 zE;QhbR{pvuH_5l|&&T7TKR-P^`pDh(187%i)%SP0)0X}G{rdaG9fiqPH!b~nRk>)6 zuFzC?+1udGwEbn(n)_!B`Y-&d<&iQuQ5ARW)Sk=x($CB7zx;XYzqQfZt-ijxD*W-R zo!oi5-#PK0dy<}}xt4bB|E%`R*Zi)CtI_%5Ur#3cANh4+%_6y$Kvp<(jxpD{M`KhHcZm7k0J3I=)Q*xm&a)R)ghx-Tk%2XT%rW-)h3j$ik#^K=unm zIiIhyLL1Yy_w%F=>&5Q+;RQOxU~9%jrHN(*-~Y^C^X%Nq4nbv?J)4_e=`*@KKCb#> zie|7&(A)d__j}yg!M^v)CGVpgYCba*#BS$4*j4&kYjeV!1BEO4ZiXr7DT2m7!Og?K z#!jnUSFKG#SBHK5yX;DxWVlUA)Du>Ojh&FY4_2ZxATFCuwduoMcsOnIHYIJ z0F6+W->Y06VfW1Nd+hGA&ZGTR4=jtHY5ZmB_-eAd>}{5<8smTUf^(M7HTK@x$#K&7 zyp6Ju`OF1RPfrh*weH%JTk2!ZI!Q6>Yp{Z#94GpKD#dYWcjXQ*{q!xLn~r(wTB=Ww83h9V~z6 zAGn!5U-yt-S`W!vRbJ?U!mWZto?+xIK0oHbbE>$BPU%L>GnOECVOx1*Hf z^Ocqhcl}@I@)kQ3i^smI_;xdWsnhPh+Y6o9ucuDdxuJ0KlZZP*qXd_MV}IiE$wo|! zq8sYc55BiP^UNtY>HX(Tsi(D8T1PO-N@tp$-eY`wUF_~HNl(f)-8>wvFQzVJ{mOCw zuUFcyH9?cZ*OG-k%x8LL`~Tcr>+TCS|NneeDxAz2wK_~UwMfLGPq@R=gGHcY27~aI zj#7=63Ia)tufv_s&Nlx(_3_>E`=TrN=ilF_RJd5Cvkwjy(}~@d0)rPJ(b0WibQ_Q zKd{Vq_L^c5-Kdb4d$+7TuA1Dg6=&v`442)4AYRrxfj zYiH3@uh$Eg{<>D>tSs`OiCa(LWZJbgk*|Kg-!I|9 zE9Za$uZB_W#liQ=Q5_C4ENkvNe*gS#=Szdna!Zd~+*@7VxnX0cW~q4Xw>LL88g7}m z;^v}r-vakqnXBc_R_h91=)|hJb?x2g{Jm3GRDHA;uhMO6)Vfz3(%`Uzb;g4B-TyOe znF0k@q+3svGR?ZdH#1}p=rD+tpYph7yLPV%S@~$0Mrx6ugh|E(t$+m$rSh9+{XW(! zz4mx-)`8H~VUhl4eZ(yHh);;x@@Z;#+()~a%voz$l-C*^=*Jj`}xu zm*-D(KWP8wgY*4h@hYum>lgdJ>+m`#++gy#(0tc^3tyuJ$COK+a+%f_v#zeX$@kJ~ z-jTb-!Ii7S*2ZjaY}(2F<;6wkmh@LwRw@-PmIz6jxFhLkm+M5W50E^yciG!D$9t0BmW`-Z9flqc7~KKbPpf zpyJ~ruSa^n`ed!IwDC&6F)?}+*faI*;hN5)5BnXSpPTEdHP5bgmq*NY$JTcXX1m); ztjV)(EaEs4(7;*6V?B3@Ajb>`-`j6jhM)g6t9ae)9r^d|R12>kKVSYTR$YEk)AG4x zvplk&pPj8PWS-@yde6~3TD$0na=;=N&eBVs>XGYf9v*7VdVg>4wa2@7BUS_`hVCdx z+u)q5k{6xoDuN`$In~8$iB8Fu89`mP`d3^Y6@hjss zf91>)zOTmWuiO|K6Sxf=`OE%auwr?nknmUb%dXPbzn-aWb(k~%{gvNsnh}K;7rDC1 z6~}MOnVGP9vGA>L)-TfTc3xTe`*Co4N0s)>LJI98eB= zCm+=g%0cVjsBGELzk1(<8*yu0yTwkenQ|sE+#%_r?Yjl)?-s}IE{m)`0YA-InaNp#hu!bqE+w`@5 zAD8Z%$EPZec8RV#r5b$VygJjQ%=83V$3prfk7A$(p({J&JBXnO)1tY4Vds2Mg9U_WY4Mi&EoNRpbi4eePt4H*D25 zPj-ED?)9^?vs(mw8}@--mh-IBmy4gZNCuf zCqMO2Wa(0`sUe5kc-NZOottBMEqNEOhRL>wqjz)J1Ne}uK%otG)>fZRDA#)DUtJY? z?X_7y^Y5K6=6-Eq659}_`+7FViun4!rU{X3t1a8*vg-2=$$ok8rEsxZ?;7*8mzS1; z4K87~-GBQRXg%Ra;e;l+{dVffEKMp2fBAMDkqz9Q@cP=?;^-@-miG6Tm)|`hAg&X* zsO9Um^^u#8Rh`jbJu};U{U%#a^K#4YZ*PmMF1zsT(n4qU*SY_{-OisHU%!4wbKYKS z&JG49PSAEY7XgO@{*6W3w5L}rzmY4gdT*_1w0PkO&Kd4Sx$<`${dKacoAR=r=v5_^ z>wC#mzuBmCRVR9zk4oO61<$xu8y}~GH$pXba2PoDd$>Qg8``qvE=3k5Z?V?iDd-?7ET$s+%dTi?7 z?>03T7Y4BiOb|$D(p%`|!y-_iolx5(x7GT^Qt#;v}@_TpT<73x^WA@eT{5m6#>D}Gk*L^ppoX+w8#&Sxz!J&p_#)9L^*Pj$=RN#u3 zzhHLlg}+uR_d<2z_Uwp%d1O&sr|nKvwfTXsc{;6M)EElQ3B0r=Gx&9HuM34)pYT;FDT0RXbGQv0x9fV@un2g# zEhsQ*y*tIUdgAX=51(Z_oAqwb77})~->)+1>L&5I)-S&4G)s79E!?qw->*}jOH}t& zT=nc&WAogSPgJR)p@TuVL@=yLsiDD}@pbuyzjv}cA36EGc-MRSU1yzPr|9*a&GRbm zc+?mklKpbzUEEZS=xuAPUaeTXCj9yF>KAF<=8cclG2`+^{_eYV_Z+832-^71v)R_! zG2PeUkzd|Ir&a?$1%-$2jz2zMQu2;zYu43G=N`MubJsrHcGQXw)Y&p(^0}aVd8$g2 zg9hsw`~G*&Wxw37|9`hi-Q&*G?e|Uyuus|1tS4xEQeITwEGBt6Z!mnSf3yS@Ldy_a6OynU|MM zD9g2&rTdY~@!}%a!xQ)Pubr}^`QO*;@xNyXhRSOM>?}%stpOV5_&TGL>D{fZ+JO^8 z{{7h<;`a!&?x~$Y_)EnX<47fe5XRT<7reipUwiKTEx)8BwZiawrA~$#8YLfPnRk8( zno?n3dAv{drD@mZwOk=lL!s{{8h89E1sPZ*9G1tFmv!#(N&~nZ>lj&Qx*lXwI8!vbF)V zs^j&aIe!0Ms^`z=xxcS=_g9$`hj;V5R|p9=a&Q_r_6MX-;$l)1+3=6=7r*_V2hz?f zgO;wjp8M`W!3j=}9`R21>ZdG!I&})!@4h}c+rH@G%Fsve8(${t&({*F`X7^WO@7`) zM{hv~g^3KpUtFC2STb>Va7ENF40urJa{Z_G9moIAX6MIT_docAbw~5OJu`cay{748 zDxbNZv?g-1o97zMguM$5IWx+PHNw};`I@u$kJ7W?&RT^}*Kc>)Ygvvlz8QS1nNy>-wBL z_5F&ky=QB<#B?%@W72f=zwZ|Rb@TPx;$PRQ8yYwi6m$=;K$aF47%;v*pa1(WU)8-m zm21EMcyzRT?QxX{_4;47=WN_BYxsV_Zs}Md|2b=-ww{W8I^~ngf|8e)uD$;FiSO5? zrQU0|$Fs*MLaIhtP}TU-+sIL&hw0jV$LTwiXYs5#68pv9?x)I3wSa3&547=0$4o1U zKjY(}a!sk=e$$63Ya%x<`+DqC`BAIPC`Q$H3%rk<(e+$t{o-2uTd&oVEhHIPnA8uj z*cQY(H4Ai1ZTNb7dfh!obKCMS7u}=ZANcwCd33+0!%~%d_R}Ng+N`P#T^*+Tdga=< zy|=1-n3m}koKXCxZ`>Ld_TPQd?{9B|y{GAT+Wx$A{!fsShM}N?f)&%Z`XaaEZ9W1H z4soE+y}d1Wa{gDxtQFDQ*M0pZt`m`9tHwC>*SFjGYmGf>9FzA>WaQK+WdFOk-;T?p z%;YeK$DOy+I%Wpv&va#%J^ssY!Ln6Tdq6AQ9wdOyd64H&c(AZtXsSEQ zHqDQ*HEz1W{?BHWlNhEd%oB@)tp!kMaL52P>9@Vkuwa@fu%V8<_W8NFS?A~3?t3Ux ze8y0zR6k}%fJ)w+W-pt4S{vCMLw;k^6~Sy7ou7r0g{rE*LFXAyZ!z)IpcSXs$qZh zf|vQ+iHv<-4_XbDb#>KFz4zN5q|dK?woT({3#-aK@#z)oZPnQphIj81P*b;I;&5?j z;H+Y?nkXW`v9sap?ibJQI@etyP zEj{a$y^VkUy9M=MuZC}%o%cw0ItQp4>zKwM{3YY7`b`A^H^$f1u|NOvWgYL6UHkp; z_xtthpPieVZJQUv>}5Mq;cJ(3$nTY*tHZ7ZM}uo179U@Sr1PJYT)UQBo1t><)~3|% z6XF#<7bd@8=~5C%W>kA&_^u|%T|t4#I(NJCqjMQXxl<~R+`aPu*X#A_mw8Ufxi};- zuJD?wwQ`Yb_oI0&4M&98XPe~)X@_qLC=Ic%SUPSu;4RrfP+**`E09%*<=a$4no5d3ky5@_Rc9 zlV2MymfMhfdz+Hxx!LCaDteB0xo2#3$hq%m{(gS=nuv?F%0W6mUoM}&tm2uY|8Kwl zE5FY5R*?b)&xh~^&RzTeUFld?KpBMtx&opzV7GJsO@=k zzixSbZEdz~+7;$mu3t}0*Uz^-+i(BxMwJhfntH;&c{lC$RQ->6#3`M7@Kx(Jc9xF< z9Vi+rJ*~dpRbi+H<`NP&kEL6EyzinCx57SJ$4YeLQ zr^^$h&(8hdD{X!&Z&&B>WLcqAM_d$|KsD!$l}lP2POz+5|4ilMkD^V>c%@7Nwq{-R z`nILz>Dk>|?f>W0rtfO`>bA6@Qa|ib?7zqT_Hm$&V_@PZ6aJOz{1G7+FX#PnPZi=` z8@e_s)JF4QEW@-e^LbnX4hljb3oiDmG&-zct=n+-*IesztUT4l`KJd@~N~-9pS zy?%$T*G_xZGvd;Hk0ZVt#2+bGqJCkabNd&jCq>_8=kL=Ln!bQtd_sgPXmnI5z9Q}X zku@I`OFHgM6VK946m&R{&ZzdnuAJeja)ZONhOcX{H5IVmRk^m}!9|82SY3Q)%@*vK*YMT)h0}XMHQoAGE0?dT`T0q;Hg1vdncrK5-dCutGG9}lx9wi_>$Tfm zX5C-vEe=YwRYwHfH9G%ZxL^A{w#@cJqC)M5gY4I`&z?B3LGJT`2BGqQrLs!1S9K=` zFfwuc0F9iOS82I1H0Cf}(@!`fcjET;{O__ieQcK8^Pgu?xaj@Q)}@R=tG90lt%cPN z*VEx?%v*jXwxrDV!?xRJU;W(w=TrArujs8=skUj~8lLT~?6m&Bt1og9uet>jhl^hW zXVsHkQ(6Q#mLA}`oAp|so&BM0$z^HV>Te=1ryQ5Bk5S1JX}0@#L|7>kw8cmzPo~*x z?`iw$Z*MG$eofnaA^8z#+sGozz29zS2Ys}k%H;!EY!BMKpYcsQQc=LH(Y~a4t^Koq zPp8MT9dgWS%9FeO>|MemJu`989(2DLgI1yRIfZUq>4jc?OlkT*la6*p9-nDdy6V?M z_Se>yQTgd1O#6O3>b@47d1uE)BY$O2x%YcM_qqJ2wR%wk-WSvO0yI9FcYl&3Q=;$& zyV+*_QEU$l`W?J=RgT4eIb!?gef@vy!i6GUGWCBxu5xPS(wuWrb0_DVnolQ{EYc>O zQ`Aq`#{sSfy0WgUNCXEH_Z&&%G>-C=KCl{B$~lXfIOwcDI9J!VJ2!m7u;<}OkD<^>xPY;`6rR>0#%K zrr-K^(I!^0lEe3$@8qNNW>5d3V8+DpL;C>B-T3+}cZSCQoDuUE)c<<998_gD8oax_ zyg$PF-Hyk68*e1?|9LXmziVki*o)^Iv_WSe?PmPn^X*>s`<1Dur*$4td-0!Tna@n6 zLyB7)62g*~icP%o(O!sAQG~GfCBZRiCUimrGdItu2{Kg`B_Q88<)QbL7yR zXX)vO+jx)8D1Ucn=FPIkj$hYFUkm&@L5x*OBUeJtd* z#!rtgD*_h><%Xr4-~E2y?;}O8@9y3n@n#46yL)?ga~#}J_}Jx<(3ky8pi{LMPWZR` z+aYfK6?>~)@9bDsh2D-SA?vbwDk^O$*y<1UN=oy zwLUj;d*0j`#Z$FHYtHJvnwo!elk1xIU)He)KL4z0|98oxi1{zoVtaHov#^YioJx3}kSmoK(nR)uF~7=m_< zbaowmbUuI2N4JeOH=}%e%!~_OURruot~mWV^UQsqH5aZ-;<`~GpyLNrwsG#N`&(sN z{ViwZ596gw!s3i9i*ygL*xvf+q!3cHwvK;7zh-IT2pZciO&uwR(M7w8^HY zXLd1z)}%+&O^+>`8Ii;EKiuI}slevzTYp~aJ3Ox;Qo=85QuQHD^&8n4d=urW-x#j^ zk^k~Q^pYlYD;^Ygvax42#cj)pEWH+)?zv>9+?D*SLlRe02rjfxyqmwnAUw{D8xUzfDe_d$4kZK&41nG1?RSpgg!69s;F zr6+!!d%!65RL8!{j%0!SFY{JKK-!Q;s3wCM}Gz7 z?|kMfB)I&FYfuM2UUr4-~^_1^UsH`6C2*(E2Gnwk`vcm+2! zl)RJ`WaYl$An3>#$e4L)smJ%OUwQBk8SmtX*4hOvFqXKI+04(roX+l^|O-D>YRVyZs#BU z)qa2fu9BBZukzdZWS6}8FE{^*0s|8i33#zo{NMhqQ#iL;Z0?(%T6d0USrsqQZmBUn zyZLSOmW+k9cU154DAXNnt{ul7oKGl8zfG=i?7fimq5Jq2@VBMW^Wt zXq|1=CRxqt%&sDzS=x9cm9DLy;(uU|v*MzO?^cPw7O&fTb$xvNlq)|zK308uzM;Pm z9y|gZrcBzZO<(5M|BEcS^nCRPW_CUc83*qlRm;!t+yA)`{@Ld8zt`*ci=|tXzl%Bl zfkV~Vf3B74t?lz`K6z?9GFr^Oe+>*AFeEIY zA-Lt+ySvdPm!9{3sQdfN(^usEB=4K6{~BI=l@2-yBjxlo-zkX)n^@PT3A{RXacXwb z-{?&#Cj*Wzzq;T2eogQi{YCdauMSK4hMy<1BsmqpqZCNlkMwU z{AZbXW*w4P9J4F=mSxeC4*O+MpU?dK{CsZI)~wEA?buygOzqk?D^Ar87km5qe%)`~ zIUkR`{{7%!v+Gayz1Pk2?pVY{Gi4UMxnbyO-}d;iG}J2&3@lDF52$o9?2Xx3)OhCo zk$F?^9FrDyzbE$YYW59_W|REpsS@(#r=F}{642!Tpj&^Rz}xq;OtabUdwS~{Ogv-s zs#Lw!e(wiyURLLy%#!;W;Su4$ypo}3`Oz3ejm}XO1)Gpj}Gvd~k%;cP)8ujQn-QO=3_vajW1X_Hh zG2OA5E%Kz|o!&`t7ky`$to$JwZ}wd=-*A2K^1h4LrS|jt&ans-Iem7v`P@4@i@krA z_SSgx_Gcqy5_YDms!S!*ER&9KT;yE1|4{zjT~9sopZ4}^sy_kk4&1MoQJZ&qn(n#! zf1l-7c9!-OfretPvU6N^e{foVzlc2d&Z4J971iYyQ?swHvs}ODQF@#7yJ9*(`)>2^^0z~g}Q`N!3?^Y86B_v-5E z=I1LmJd-p|v#9A^z&UN>%ZLpLjT@%-U0&)f?kPY0VXzb;sUPZfFe>`7>4?fEkBLf; zCLeYX>5;RIDoT1eJ;#pu%)wu6ywXgCZ`Y+C@0WjX^XY_g-OVN0IagK$I(8xY#`TV+DiEZkBa|+&Hc{{EC@7L+ZIX5;e z$X(xSC-!dVbGhdyCMw(gZeVY6esE`JvEMSEnSbPV@7p)O;M1|Ux3{w&kK~Oie|t;x z=h0hxzu(L5iHzy_nO7>jG;VLzqr$WGOH@5}##RtDGp{${!V->=oi)!%ZSUk#5hT@|)=mGAo7 z`}$VT?OeNUTfg!8o8RwMzn7GE*5CJIQSrk=to{pr{eHiH?#|-pR$pIVH$SJj?z+_a zd$SXE6g+gw+|S%X{M%letW|L?Z1fBBh{ z)jr%v?w6F0UKzBs$l~*l=={B+m8!FSt@SN_+uTn)*ZDV@X}gtlyXAgr*ZDBEueL9 zU7Mz?o?}_O>dMMs?OT)9YwYO%GrMn7`gu9mgXNKXP+gFVB;mpWZ(|KfnJ=XZ<{zN~2HePjds(&(G`SIg@{9$3w~aHv>+E zF3dRIyyNWtzu#t8eYxna`gM-NL;e6;^_470MePA@7Pg5Km2Qh!YHtZYr9QtV>8S0? zpxQ*Iyk<7uJ(uooxXjuprW@6^q?>*Bw{=)|7=;uZiv4o?f9_pp!P+t~YgG zZ@N;QG38E|sJ2_&#*9rR@9sqIdjC^RPy|t`Gc-zY)aaNVlrc)_IBB`mEH=LO>(t;K z1&J>?SEWC-|9+?VR)q6}yDV{4FICU?1+V;WI=N_f`TM+@2A#-FM_lHcA6RaP$jS{4 zXINHw`dYl)rSf>PcP!WXn4OOCTQ%>JVb&Fm*bc?x$}AQhQ>ywK?#vJ_UFI?I z&`gWMqyRUL{N>{BrnCMqK+1*!9kUN`t>nDfA*kGBbn?p5DdCg3M730G6Sv0M-8FxE zX1;yAc-V=L5{%5z^VZh$dhB(-r@1|7sn@wSUg;(yr(a)QCNGkAd7pc@-4@}*7N$nG zpvmWTA~(hGobn0Yd}*O`yIWe|v_~nML7RK6et&;|-ACln9=8RhudgLq{`1{u7GMAO z>jGZxeMOfV*5|h!VppqyHLL{~7=>BFynWB9`OmA-%-HPL+r=+$CsTI&9y`C>nu!W7 zm2(-M%TK79&yl{f=KhasYonXZY(QrcFY%urw=4f=)Yd6#c4rnaBdP+Y#)cbORc$~W-C5rUs>^RP5l122053ixd$2;nVYQ4oHZw$pKHC{xcJ$b z1^k`2wr0AJswtnJ zPLI!0V=Y|hmT+%RrK0IO-~HDnsdzpDEy~54`>}5QeHn}Ne{K^%PC1P7oLj`_ zthje)TW++6-pNm1#lOG3_4O$_S~5i=@KEHQioy%ctP&4onLzVo!MjQ_HyUdGh!Y8! zZK-XSuep8Un#j$^M7opg>ckdWBI2jvKrYkoC2GfhetP=*Mw{o#DZJI+-<7uUNE|1cFT7IS=UZf5`szu}y*)Qq2?nl$%;NeF`@WqH@ei<-U9(Y0 zP%v@P{%t@02ezmqaw-GM3F1AKd2RmE zzB=%&^cuyDB`<@5WmZ2-7DXf<2ZaKrd=CE&zb_mq$=aZ{{NR<-+P!~&eJ$=1)lN%k znxhe@wA`_oEi9#rPp$lgnRmjA3k%ON^V=k(^lhAH<8y#Ql7Z-+atl zP;LLAU&#ZM-Wv~asBpX~wBZF6Y}W*KOxLmWFr7KY6;#z8KHe`s-~Cg!_sb2j?_OSB z4mxp4WUhB8=-e*Q+=5m4yO;xM_sj3sf~uOXbJJHX^PR1=>%K+8OaTU_e*zM=Ra<5m zr}r&#>H25$t}|ULY|V;WTQV1e`ua!L+ur7moxEHlyluGxNFnB)xpdCR{s6{ zU7PROWL58Fd3Sa!oTTQvN=V&L=BKsllHi-0)BFEKF7Xg_)lTl(CQ*GVUAkxK=O0;L zUtI+aPrZ6{w7cuvOKqw76XWx2zFcqyopRE3PWX1hD)rn4A8qRY)qDjF_NLYT_>k!T z>!90m&&g^=66*sOw`E;hGxO90#pd)H(0y;KVs>ugtiC;QQly%QBRj|+3J%957#IaO z#F_XfF23D5w{}*Of}heC%c~`ab}7iQyi+>h_;`k4vPi7CsQz59sal#|Ez9QBeDZX? zz5Q`+el_#0S290cFD&(*9-GkfeBT}Kq{$ia zWZN?}-&rnf`Ei=l_2a`HAL|X4um7_#YIoV&{b!!ZO3Ku1%efg;`r?A3hFM z|G(ewzxwX(?yEmPKfk&zcDGXfr&ZSfmmJBSXup&Hr#G8yYx&Xwg>&&iPfku&|HM6m zUB1TPQ~JqCs--J9cJb0Xy$`t(h`NqcNiT0K^p3l+>)jAsQ^Wl68r?A_!4gdt&zVe((0Y z$SoNY7qOJ7$vj!}_WtYu7Fk4jC9sZV*Tlz{BOd%t_7&AWa*akH5F zwM?Tj!J%&d_j}cOAq#t#vQ+52lDPcwL`23fXU<Up?!@80U~W`YZjtZo)sZ#iXSOn3Z8&V@^|{8oppeYExD^y|fU zca=U4?%p5m(J)CeOO}0OkL1bM79SOPK&2rh>=XpJ8*{$=7q6Ll<@e1pzbSRI-tWtL zI7eLVs8hnLD=Tj`G45J@b7A$#ziGDB-*Vc|xBRwbJ38;NLu`@j-?!WEmuU#j>i8Ss z`n}qM?dd`BxC+M$~R8U)NpSC9W?w!T00dZNI<2f4@uqg24`! zuyrw-R$_VmQ~!Q3E)=luUx3sfb!gzIk-zT}cldt(gq}|qn@WtUo13kdf7|lSbFx|| zD@%#$?8DlRK8nWK`b|)1oFOZ9>}%|{uWxQ%UYLFUQL*l|{rb_{&a4byKTmM}>ae4# z+;!zs99aPz7R=@mz>EfPk%@23#UisNQ2+y1wZmB+}n0+w{gx5gXfo)dYAVukKUeV zxhJ>s$A^c0GmTQ49u;rPxp}B=&TYO2hxzSI49)m1ynZNGBh$pd(a<2yq4J?=;s!xb z1#KeuW8RaHiz?b-hRtleL7>Biw@97fZ(vCE4u5%RDYrw@`~FL>HvW3Ke7*?l=6&`# zKZU=jwt!CDJ2gqwdr5!E{9RF-(|UJRPR>{2iCft7AnWzDwFiwEW<6FZ`1U5!^|<4e zkB^Tp_1vn+`d{VqlrXlR&}0c7q^XNE-j1;Ovx zGvBXt-#EQt;ggQ{yMI?WXoCvR4b2Wt)@K?-L53u>9LQg?bTg;#mfpzPuUEs>LLA%W zSt^c-tA61OSskYPW$u?1?Z#nu&gLG{)h{k6Ufq=HooPDZ zy?UdRY1WUQDsrEh8trO-DOhaZvRET~cjto|rlw+Vc7`)du%rO${)jC6zuPJFk519; zZMko4S)`6lyZDan<34l4eG4AHyI%0|(b2;dDYxJL`h4C#|5538^}Tv$(i)E(*8$bs z8A=m8Cd+g%g3Mbl_+ZPy<15UjnAKcf=G(Pd^!nQ9aF7oj8v5l5+TQ2h-uCl@$gEp_ z3f14foB4iyfB$~V{qvJ2nZjBH&`jSD$F$gEPN%4B`?k_s zd$)+TU3+_b`+37s`CTgu#m-fEP1SmOVY*(T#iY08Gxx11xwOPH`O)68efRn~JeWbw z0!1bRqkw^L!qk-umif*$`*wcG;WLNy_x(8JIm2LK=K)45mi;{49UUB-C%)D#*A7{c zkn|^h!S_!w%j_K%@Pm>rw9t0YZwyj-w``@tUcb3k=Ng&W_n7YHE6fJ1LR8Pcw?~bM zBT&}4ov(D?pHJTH@2C4s(U`bGFL?d*A74~_XI+_TobK1rACSNM`uceL;N*?H_xjmT zT*x8TsQ!qXrR1Nj|2!MMxs$(sTVs7>&Hj>?lbmPn_hl7|`U*NL`scIR`TwpemmHm8 zoOFbv{r|G!H@8$)SABg2>h(G0sI*P9)(&51V)}0x`|HEZRiH!&D{N9YcuZw$3fz)K zc5@Us1a8d=4R&-rP<3l-_VYQ`<$8V{dk&p>zS*}w-?Mga)z?kg4-U+d;I#Sk;jr4V zyJa)`Sv-&i&jdKk8vRw8yJn+9y1 zC!U#OdHLbTw5p!hSHd?Yxu)OURXVL#Y=*FK+5HvK)w_!pGTz!_D6fys#F z(u5oFrEDU3sl1X#ESqaibAa|CezMtq+s@?by8Qe57$-(;NN5aR8)f?XPgi&Rtu2{z zHG`M2JTaFubANER{JyE_zP6J!A`V)hGzv>cx-6$ADPH$sjlTHx!^~TY-TP-JtAG{&KF__VPO_f&YswX*jc3hl#HczT>!MoPA@6X%)UQ_(%N1?gi!d_Mui@=2o zzn_=S`FWuMsinfew24JZdRD?c(}}uqdv+8*J0r=x?54p(KPDLsw&a)(e=mYod_}aM znP+?ZR7#O<)Ruy<^>Mn-%vnwgXoRhqvGTg7<;{LZ4|b#kyP?zJe*#PLn$3lej~N-K zd+^RUuqpNQoJp$Qv$!1QfKL3FGx4qqXySabcDP>hzN6oM{W@R&?{UrFuh-RL+W5}0 zSe$QM`28%$Y&)F>-WmBD_b!Xtn)UR<+%FpUR6%2ZGbPNq&+Pf@jACpr%QSXnkLPRO zX_N`y*j>K<@`gm`wTztiqyOEje$RThaG&@*Vew_&)BRT0m+zbQ!@F;uZMD_@f4{OX z)V47;3VX~nTKb}5;m6G9R!KvEebMEb}w&oO8<2kYa#d`T~TQe^&JNM(`S*{5bi}K1~&B(cJa><`k@M7#!t>9%o6Yb?|J~)Q%tNG~>pE-L^B=bUD4VJPuHx|lOy-?J= zD?jOh`jQrBJ&-GII59Bp(zRu@2G>suI3$0WUd>VCS(d#_18#7FQs6Y9A5-4!^4z*B@As!?XIH!R z$*hdlf!HF!c<R<`&*Yn`K3%WKG~>)XL%|*9ZpVCy}B{^_!a&Ae}p=2`d>P1&#uI99@2E;RB-s7 zwEke400W~m=NqNPYQcNwXC3&S7P=z9(RbdNM*(2RRy)xQB1pS!w^Li^XjDE~X5S*A!wn6+B~he6s<~7feu_ zFj=JF+rw%5G#*uNdVY5Ha<3^G4^Jm&aD&3mOen&~?W_L;g@b;-Zq9vGzv9!*xh5BT zp6Z+IUu-r1m67z^247IIpD>Amsbun&h1@I-3NoBF-hTXxW*OQ&*A8Fz=QQY60PeMO z)E92szT#7@>qk5B`7wWFL2=I`{A1de-bDv$JawwxFa7WD_m$@=cUx|=6{x=7FpGhy zWc6ZRhs2`M?FT?~b5D!@EA=C~yk%W7@OV*f2ECwkT91 z;<>_prmIOImM5OueyCjeDa#rh^fOd8G*4N(=ofpa--MsitWVp0q!>U6QbAx9i@<{R ztn-KT1sEDPC^$4)$G<(M{dwxjX`I~4AF6OPGcXht%54j#}aL&CD zoJ<&4cmy39@;FScfb(P~lgNhW3Uf_YPFs4b;Z^Oj+y*-V21b8@8E#?wybt~e^N-+G z21j-ar-B3j!*i|Kpm-9P%fR~P>WlBMLcD{YPAvlug}(4?{27tJ04_u~G&3-jSpQ-S z1KSbEB(mmnmeu^&^3*WR8->5B}6j^EC2;jAUT?uiU^OtIP-rVF!o6 z1NS-%Y}~eTU2Sh*VR2A+!ue&{gPM>N)tu}g=Nw1|WvexZ6Tn56hwy@gzk!!7&e6KR z_uTbemFp((XPus=`|8Qb$y%P1R9@}-{VsTC@$+wUB~#5qWW<*S9bILYjntAsax=1PWh&1RqSee?uOF0x3<38`Fvim{ogN>wTqRMl&;J$Ope*=sw}{v$dr9z`Y(|M^Enmg zKLDqn77<347m8Qs7O;WB=8VvS23zCICvQIZuDG_~l=eHf)1X_*USC^Vdo6NbP36{# zk4aN4jdwRNF)8{dh*m~SZ~E-5_+C>6JiWs&?9lM;;ko9QpfFF6X5_l@^G=oasyQWk zbGOvaum86*>q3B;LVfztDn&y{uRBS9FPZF+5K>Kku%h4dd0kySqAXurE}2pxrpz zJl`t$cwcGOl@$+{cujp3|JcgCPloTUNZ~ZS*jKA>-2LL9*uSs$Kn|M0b6GSjPB?F6 zznZ(xO{{S1`qcoG(ml|w{P|K{L~9S zC$;H7%yMM9@kozDe37F<3x|qYe8uihdqXY@8@y9cDBE|De#CT{E?!=L8scRLy`}pgM8oVZu#^2;{0CXAKmw?B|`@cUGbiIA`>YB*Sk52EuFy~h7lgSAtkeMA0Ek>3X zjz{^QDkR7<@~!g@e0t{2&y{vArs7xGS#@naH(5qJ-}Ug@`Kw<(uUO#M!DqzCb>*k` zymui#_0rDqyx#@7v1e<>#Y3gl=DfyfXIA*lwR*Zt^HxJc7!zm>*(`&^ru#;qO|)0{ zRDPZ@FW>v%&z$|Nj~yXF0U;N&SUeU;zbohURd^Nqimcm4YaFk|t0XgCWem{{@=ck- zH$_s};b4{ZD(Sm#uHW5Nx_Yu+tkuNAU6r5H%+(g~a%3nQ6h1oAaJ=Z%m6dbf@B97E zZ?=?FHKVg2s7V3I3k?nTS+p)rULX8a^i_j;TU+XfZ9he~?+;kvY(M#zFC%}HXM{fOZlgF$qeBhLy12csE{N7g9V@=JCUWlG-In4pDIfoybJV^s zm>`0%qD77I-ZHzMS86K{sC5+WSH7zs{8Y4Tih!a6t?h5L@I@l?!e#Q3t9pzQbha4L?FYE~OoTL)ylsv1r{DCopGcU-cHeL`L3Q{p%ihwEh0`Jb>Th#s7qeiTEWYB znu;?|O!&{=xVQSd7whvik2zP>2ft;4u3@{U+>je^@3nCR57R}?FH7Rf0-st}3CuZe zXSV9%{AEG5h1LP}GKWtXv#3p6>bi7o?WdFKOG6#(IQ}?4`1JJjC6jqdtaAiJSV69H zIFJl#eKAcC$(ehzy_8bRc zs4JO4u4JCeA`Eh+_)GQq$6X87)q9vIPqe?c?*B!7IiXsW1L@~}c58ezN;<;9^8C@1 zg$im+p{v78S<|dEAJxccfQnNFCOL%$hPxnx4$nJK>(a3K(>_Pjz#Eq*um;RKqQC4^ z`7vegO**f4EGc#fjEJh;oOU+k{=V9!ApaimSdi+SoNwrPqM)!NN= zj_sWD%hxZ9Qe82vrTx<^wWeY>%j9D`EYBYrE?e`h=*EUbwYR6;PgR(Q6;1X6HPIMY z91fT>-Ozh2t-pnhF_@)7v~Y)J>IGr_#+WOMY_B$j)Gy0Y*&MtltTl|;ui=O3)hn0s z_Wu2L`_zMPNtxve_YbptdUA5{yS?Azz8)2ipYf^b{^^R<*6gpKfhi{B(2$q7{J@e8 z>K{Y}A6VxEzEM8#e9`Wpr+3}$Z=}y#uKUP%lj;&%(DCz9b~5*CJ&W6FzOz)!u3qHQ zd8JEK`;NUxg!jKihWuCknS`5{gW3%YEGird4$~KK%~W_G&$#b-rs&nAf3|(gc?2J{ zc-OE>T({2;cV6Wj#;fk|M&)hn%}uFSA06!uJ=9`xSM{var&{HJrCy??FE6Qnz3hK1 zuS&;Htca;CbzfxHHAn)u#3Hc3Tez)8pul~Byy@(+>O)W7acp4G}m%{ay+09+U*%+UG^p*dRxxN*Om5is~pbH zS#;`n8MN^RNf&v-Go0*YL;Q_zc>ZnweYv*YQ+$DY-)xEBo72t~1vnhwW&y2c|Mhu6 z^LzbR8~FMQ2BwAX3er2jEbV;2V%5X?KiMgNMpxC5n;(xhPweR6&_9y8L6Aj>bB=ZS zInY6ZKVCoTyB?=}G2E&JGKsK5t)cot>|!TpfeT&@!e0t*-D}_CB`W6D*~6#qH|K}T zsVSOszr4I0?=j2dWvSKq*C}Ua7-n{fXif^;>#7#Be9e)SD}0OgCC}O>7VkaRs&rSk zxc)M`sxKLv_W%2(eQ;mx?;shw8VkX{^EVuI6g>Ys*mB~Wjfa;wel#jr`q<;h<;L#L zXs4f_o?h*@|EIB*?USQ}b|YwD^w!qw)qj6~&z>sXzTxwi?W;oSjh6~kK|(4?4b-S) zW;r9Q;jJYewDF4V#LzbV~Eaevzv(59vL=Nn(x%Db7{N%2EAsZLT6`OBe_iB!~FU*X;?E&kZaGoiD8ux#`HO$@AO!WQ&&h&3$F_^-A!$+V6MMS*_)N ze<;p6AHI2^#?&8W1$y`T|Nj2Iy(;Fgg+PIK!lfmikJeAOzIXYDEjOeP1&=H`&2p&v zl()FQaqfvFYXTR$ookn`dr_8`5o>*m?LCjI)s>ZTdv|fjFSPsB_av%%$-xKO=TG#q z_DY*?%e!+(L4c#>z=p)bKKt*VHU6=WArz9OKxD$41KXV%=dbpZRxK-@SNkn8{rkJS zjb{YcR)4#)GMI0@o@wT#BckmI-xy!slY8d)t61$v`q^1mEh|1OC`}e+YjjuuUbS=i zeevR+`XDDoM9V=!!QhNbg3xR}zBA|NSPH+mbK%!>%ZT}AxwGDCzm8rxU(UebSx#`^ z(JR>rH#enT>kpOSVEQMNaeLd^mkP3$COOsSt+pT+f(I-a1uO1^Bor;5XI1*jLOXoj zmvXrmFQ32YQUb5dD|&t|x60_X+kLfHtG6)rYUSI`={fV%r#|ln%avzeug8D?vZM8* z!h<%4y;WbCs^?c;IMT#@R`NJ@P?henlq#SzBV4oM``oK#d5{;{y*I_;QxFIh^A@tNyt?2?v|bwQ`Hs z$O%_4ut51zxMk4*Ar)ZA6WpN-T^sT!G-gRso)Hk>l4j#qtcId ziN?*%m)cx?dt0vG^>wknemRdX9sSAawAIAmtJIHgxAS{@5ew2DJS3pBS;2lfaxjC7? z{=Qx<@b6C>q$ga$)Y+8B$ivWhL1{wMoteI-y_(yP^~tWjwKY54EB3_8latl^L7Psz z=G*Q4^>ljtm8Yj`u3W09oMGZ;x-Qi1A&1cIIJYnVy>-LZ%ve;zt(ADF<{r-Qqrp*2687R0)epV0%IJF7*fd&qO^ACp$vs8TDvyjs@a&ua!aoQP& zf_0o_pju1V-)147yxp2@c~4)T>J_^uG_O}{y-oE_8^>e)Q_32ei*~(_`IybX%Hq(l zY5P>|iO0fU-`}qn(~DVA z@s!0?o-xif|K6URi`G2Iy1dNy)t8r-f3+OfU#Vgm>Gw6^kMG)?iL=-Inxu8VS}zLJ zUVe4$sZ9^4h7V-X3STGlll5`_{=aElT>H~w7w@_?#pwlT>a$;St;U*?|N zD6hIZ>*}g`^8N)3EItA&;`Z)3`CaGQ)l<#yqYWfM?WZ*=2d+CVY+&GE@p~XAR5)kV ziR`X*%)y_ZpXa~hX9^F6}mcXWxM>d#p^*qQ7C9p^rT}|?Cx!#6+)T;+dTq#SKXfti|kb_6aJZnREyQk zRJ#zQWdT~{Hp{MdS7!YJeW}JpuH9O@@*_;MuAE>I|F>y*Kc}ly$rLroWYZI!;YWUa zd@MNUxHl)S!-IO3O{u4siRnZvFiJg@!o_)BT|7`X#Y^!Es8VuRA>_~?x5}1#zmM<= zrKJUrj&y2OetHu0Nb$OAW5~)N*SObTpG@}ORim^ZP5;8>naqW!d--|UJMVuB{r+!oe9t0ZmNy*cAy?ymLweyv);$HCqh zpc=3-$@S>_NVe0?OS3(HsE0#U=QumVHOIn6(i8bdf=Pxwf;TwKS z^#pt40s#r@vNf-6ZeH$rcmBjp$J9if#6fjN3m4;>1?^t`hx!wQPUtV(6TLl;H(a{lbxQ*AC zvsJjv$8@E@E>O9q5W=D0z&~|fi~K>A1JB=W5kDu@m!!|Qt4h~sbKRztMeZBoRhVw- zE}Aee=i%Gck6O2Hy}mv^K89bU!C{90=)75ri%-Lv|COo4u9vvN4hoR+c4bl6S^xzB zAy5`}F+bF)Abeq8Q{4JE+o`JF(-d~Ie*Gw@5xQ#1EStzbZHDun+zPTt-u>-k-SXl& z0)4`VK}r0DszayV?}z>N?y7v!`Ic$OC{{Sw}M+RIV!;L*$b{{zUXMf9{%FnB8tG~Sv;f!oz z;ghpjVX-Pp(~ZjvJ(${b7bJCm~r5K zO0_!IrJq_R`xNFje{tvi75sghU$fRi@ObVXcLwbjpdN3Id}H%2-&?!O*Js_`wKZ?! z1a%jM^mB7o)&KwJbV>Or+vjz*cG(A`Zy!Ak&R5;RZA}Jh6QPim`pO+Txl-@bqKn^jF&Gt=yJzaZ%Qn7Z>N<__sUzx?bs@AB9^}Pm7hlx}v!? z_x83E^FiI0<^J=*!xf-&qqSmpZOOW`W8 zD{bcdYw!QS)%(;G&8z(Oe-_BqUU?E25jb5zhGmaSg3;O~<%-Qa_vK&su-+rww)xir zaJ1Qg*0iPX;%bZXdtkh2{lYE1cXyQr$5b9QjClIu;^J3FI)%H=pZr{w$9Dv@68Y!k z|NjrQa@)-eTjnGA_0ws6?R`;tBBxdaE)IErZ?9_1!{2u*gmM>&sHnbPk+px}1HZ?h zQ~R$j?bh7xv!Izz;DbyfzlO*2&o63ZrP5=}L!V7pWVURIBR{BIsAy$iDp~(U*}R_pH67s4b*<{XL9}X1G6`u`usj<=Bc0eUWdomUKMc) zwB1?!JPfqddhKI%p$NzA7b2eMF8;q>bM5Nz^>JPMFE}tV3UF98u27iETr&ClwBmo$ z7#+XMv4KkM23Hn=1<_X|4US%BsaQI3`_9>3TR!uz`TcIU|J5~-!J_(cF{x)~g{GdK zrn@Qay=k@M??f*Y1JE*0<=R=c} znUBi-d4bb!^b0DxdAxX1JbStdi~D5DwtupUYn(&ZMuo18*yt3+`=l9E>Kk;0U8?-e zzdpzQ<-d&$(M1jK{+j=5Fm!;oG#m1m<^-JHxN@1-)Kd?$Ci{N8`RSDQ`ha&z`O}wr zPxmr>-gA0V>-SmSH~;nDxw10Yy8h3{_U+b^*P0zNggSNweJmD!&w8<>WNJ-vGk8q+ zgAn5y@TA)6w=A0`H`d?GTO$4jbSFjD%}K?JDmUNRQK)PrInSYTTFO3kh3T%J{vN4$ zXR~s`pZX(uQCmDrGY?t50QIMJR6fY9UBa)l`$yN&BDS~LKD#XDb3=yQO&Mc0i(R|R z|J+pA!spYyYdXd{N58(mfB$lwy5AfNBk#Qql^zahQ#|&y#MoH8zrJ3+sraB@ONPJ& zhXvxfd^3EDEDGm*OOYzPv3RjMnk-ZJ>+W^Oa)QfW*&P<) zLO-~j_T38n)a?=8wg5cV$}*XO=}W?;_IClQ1}Y)4#xJk4%hx0X%`J;)#ovmxWsM> zs<;zC6NlGIIeEAkndUH-Cvp4`3=zM!HhTHFxz^$#(oBJII|?2;$o0Ry`DIpXm~!P~ z)6+eHGVeQ1Ol*FB57fGeQ*ziIw59s(*6Y`#w(Qh-`Rl|2yA|Nc_SGB;4%=5*C-`s( zJ_z;P=Pjkmz*NJ&JKTGslBl-OTS6)4N*6vs!ss$S0QFy^3uz-CpcY*_l@C%21mF9=GEJ)t7r)i!^X3)O= zxTNS6>lkW{N;jU^&T+B*9H^Dd#`7S%57f=t&SiwAsSz%lDq)*#;W)Xs~Ay zSn%7K_k2TxHPfD30sXJ^%FkYW<;SEMwB&<{$gZrnvl^JgO;5=97|qI@AiTVz=I5uC zo|Dx)!4b#k%u-?Q)6Vzj?&gh`W}AGRnhy#P1pzZqmFydS_@aW~4fiVf<-629e%Y=y z%fGj0-nRc*qKxcJv5xD#&Gu>~T#r>sKR<8nrDeX^PNF3Z3>*?lpat=l!&UdWt@~>7 zL=HTS=WqcuJ69!spus?4!^|2T|I%cMAFHmqu4gYd&%bB0Ui8HO7FMAz=}VudbKEGI zexm$dr90@Nu@J`MRdS43@H<+*mT=gc4Lnjuj)Y~yHC`H2~$E1V2vILP&_qTm9%L$UVc)+yz22G(FXmx^mB7=PJb4* zZEFte-0fS7{a7vrZOe%?t+k3z?qOn55IDu6!MQAIQ%dKlDVmc#&42oRTLf#H%}{G# zxNB1Qf|+rt5{HxYsy(avgt!^k&$n0Ko)@#D;Nd0*_TQVE?sdI+aHL?7YTzQ5S9`zT z3+5DlwAfX|q@}q*l|`=RgX7WLcX`#m?3o_(e6B-H3_Eyi!)X#jTA`M=Hw}Xp$8YQc-N*u}^Eg96Tb~j*!M7Z0 z1}~ej{n12FArKLef{+QWY4OE^^8&h_`sjn_pc&IVaSm_*AF*`|FHZ2r+91a@3PWQPduk8I5JJOtu6~) zAdUw>oTn+}n_qK}Q!pP`h_Mc%qW44A-NzpBdR&%^DB4 z^IHoF3i7GObeHz1`OUeJd1J%E;ujYb{SQ?9d^-Jc?cU5feC9KAXN4s%3omc@61%J9q_FTMi=LW!zxsul*^Vf-J%3+lxyg#-#lF+iOI}{G z{Qd3i=4I=@y}9|=B=^=8{b!(=Fw?pN6E3JZbc)P;7K)BKLLI>F+Kkh(&^p4ICe2ljq#&7Jl@hEc5c@c{{$ys#e!6{v~;J>aN_yYv<0J z(QzzQW$l9^BZp2q?}tetqT-ior`wlYon%_;diw@w7?l0U9^ct!*M2ZNJ54_D;o;%G za*K7Nw|!xmqCT(UP`>=%n)g-bj{a7f1*#VyRb@jMQ>w?U?2zdJdmlVkIretROOBKA zj-`56r?0eg-70mJedWDMg-^TkqUTk;()9OndTjJ*|Np=51MbFn+>6(96Zy_xU-@X; z`oDRgb%oi#GH-55t@~Z5uDyOuNEEYt+YU8@^mB6>j%S{qXB+#PJMFMl=_{5utNY(4 z`|ql#cM%2+ifowY!1P+TrBQ)_X``TqQ~e3IuY#*;p88C?z5lb=ixt`#i?%ttvwqq0 z>1_0KO9p$FsrB|Xzsvub|NlQfB!AbDbDdRn1vjsiZjRiXrWtjz(gU6=u(Gjt`F?pvS zA1U4_YS;8YIJ^G#<*5N56%D?9|M~fO_m4ShzEa6{4uKT{9<$BXUfUS8KF-#^A$n)g z(#5yGSKQlecKQB$^AA7SML{`2!AW6ZM+gTic#BMpUR<_j?5-_gl?MgP5)ZL-{yu+m zs(sQ&b;-Z~U4-}X$y%9w%1e{xsuf)H>)TUbnP1%ZU;a7Ff6G7rg}I23t>c5`^Xr1@ z|Nq?{7X90MGp_PX12`vVJNoq^UMF1jq@`yFD>bmGDv7x!580BT;TWJ`S+&| z|6I@@U2wGtTjLFmoI5)LS3d?e>4;g&AxA3;lf1%&&FJ zPjBt9tu=8IXImC8d;RU7$(6m2UiR}=sF`qh)ZP62s9Rs_6kopWiauFut$U5h8?GqF z2J^gX)&j-c1<>L*u^s^?rbN$%%}=v*K?gXTIrjGHr-$wGUNhw{zq0gq=+&9;JI5kW z)%%$B%jS5{=o%ZpoKBucmq^~aIpXHbTuu!K&d$!$Klb7LO~1KTE5E+J{`>oegUc(} z`C^6B0~Wt>In_2ZgafklM}v{&MWfJ>&k6#|ScKGkR{ZUg_Y!zsIV*TshwcrXoy>lI zzhZqNOJYH{WUdP9ExvFwu%hX_N(0l^$L?M>%RGNwpWM^iMsM{N zyZ48!joxmS`GkAPnR%Nn)oj5PjlYmX!@HAt%@-8}N|=7;-Q9Kc`}%C%sahYmzPhLT z`PtcE(3bWo%&XrC*tFG6zv1;?-!yi2S?J#C@6$e=Oy3E*udG|_X!-3q=aZ6a6jD!3 zsbX>Tx*_Z_U2m>M^WWd!SBI^Q>U@21VZygJH&+ENcC&KXIrU)mYwKOPJ!POYE8xS# zaiQ5$ewX8c-7KrTX2h)sP~_ZrEalt`Luaq+;wnEpOdcM7dB1n*6xWlrPbRuwxv?>M z>D3+6&T~He_4W1hU9}5%H#W&>INHd&KKSwRv0K8Lh>cFA@9x~}Sm!YH!_J>Vs$MKw z$EH8GoLZ9`FXs>qick(VMwS-`7x2whcu>pK@3|vju^TVvMz@r8k(=Fgqqq5ZU0;5Y z<^S}5x^hd^JSI4RmYu8m>69kVdB0*;$;(AcwsW~}=VILTzP3d@NzK8%sb}FsmM&&? zK9gnV<6Sc^EeZ6Vt{1wq=;^2M7W?zHPW)59KXZJv%r<*Ol~08oPbm zdtQwjv<%KUdiqMyFB)BQbZb97IeE?b>@3sOkB-cmX_RV|s-0dp$MGv8td_1(ZD6dg30D?(RKOF#MPrvJGjy^xBd&;R7!EPlECN8+`2cXzMmleOa5`FMB4 zzD29T*T?O%mv|s-(JZInVDpckakBP{K(ETpQR*p|ch?LfEG+&vWEC}A zK?Y1>K#Pc^M5US-IPRzgcs04)-Bqf3L~5dC(h&|%TbU`vlCGgO*=p*q9=qh2P3`F5 zcxusCIC(=;o=oKlEt9=Xa;%>|9+wZ_UG{dalPjh=ly-Wmte;f1@z0;n z=PwDL%sEos%ktSel~2y*#xA`DYyMrTc|4{5-=E6YGY%-^3!Rv2T^?}UX#c(WwcjGo zA9#IZ8n`l%1+z4B8_ zKL5Y=vHt1QaFv_8Ce=PZ#`}5)$lwRbHfnLFKfVO*F->PM%fENWWb?a+e?RiQ2X&pm zgXDWW9z6e{*0ArNZS=OBc{2^%%uAl0ntEySal?I^zAUeurV}}5v3q~iRd)M7ADT^W zS3Fhsn(|^-Xh1^Ga?T5L?|(uFl)CH7thT@Q0>L*xCVH+m;0se%r44gC4}xp}6B zy5ricAjJ~U0?h++Sp*g&`+$b0RS!HrzjgYruY0#Ad_2f5zv8^zUy= z=w!p0MyWyE;(8&Go6}5Fwa<6|%m_p*v;YU_AJq?Lwkv9PKfJa!+IHhzqg@k^c8gy> zrzjQuHu6*QtLb{rTzXq?p=CbIo#ZO}@t1ZKNiy}W#TtHqVo;rd%sPm5)&u6n=otUV+ zZ&zmM?~jjq>wb7M&*ox%VbPoy++J}*EIRzc;tAj0-VWD|c+hLH z#l2rH>p%men!7W1&@uBY=&DRmPHzZhsra_+FVBM9>(xg~6+YkEn(fyoW4Xn6!UL(< zXTH6?9bNwH%dfAm{r1)TT=Tf<|KIQVoB70eKB+V+%$fh~=U10_56jhIYd`VC--!R~svGryM(Hw{A{_Z&zH2R3SkUVrnmZ|vdyz}_wb=Kf)BE@Eep$c&-=*Gz zGxmUHZ1x46-FE2tx$kdoCeMxp&G}7VYs|$~IjP~T_6we=`x-*#T9zmUiP;SeSEBU^XV10uPyPJdC6;c!j$hEGWK(YkiSMo59aFBFLB<0P^*5B;nI2l7|G<#rhLc0e(FHX>KW+OVzFzil8*lga z-nG0+N=hNq^)X!r`4m@`$km&h(^oHaZm(i0 zy0s+}ymg}J*_q5sargR`{0$SH%;x}V%HCxWSaAEU{RTdkCf|nd{LilCy6mm`8nUb8 z(e>JF!`aQn>*v|7kKDZM(beMHr{-7|UuoeK&M|%+|1F@Q?qU{m;+%AjicD5pu2%;d znXgXK47NEqBmBZo4u1Kkh9R3K&8rOAD*x9g#U3;=6XD0exa+Ab%V!6L6D(4mFV;tF zT+|Zr*693P>*Z}cl8a*3aW-aNTC(xoE2D3}Z){BN3O}E#e}sR2|F-f;?r%Qd;;It4 zwtQZdSMA@g*XJ!b6YgI3;UK$OuCBu=yQQ;EED3tS#3;bQ&orZ<#ohj}x4?(#4(avs zJ+F5@J3HIExqi|bbvD^3lc!ZZJD$&OOzAXI3he2Fy35J zD_;fbtbvY8Sh)MY*~{zk^_WpkS$CRtv4o!Yu`MDx}#oyMZRo>sCIl1>b zIApN?l@{J7Z&wrXQGC_*yt_sV^%7)jLhop=-y^g^MxMoF**4+YjQ(ZdHlscx%Zran zPRs%v(M+-`HrovgdQSTD74414y1s7hy_(OyuYH~u|B1VCOO919aFNUNwapyOHl7X{ zthI^LXt+eSJNy?q}-N&FTKa8H-9vme%h{h13cyW{fN^7T(?efschrF~EF6 zdvf)(^IW&$Kx?t4>Br~oo>_kL_{^T%J@4o6zP-4(-Kz4_lJpsACnhLvOz&x37$z(b zfdndms@L9`YMIVcS_&$m-2sov|2z5^)G-94J!F9Hm}h^ zf#rwNohgkR9WQS(v2tnXv%F|#=fC!LmtbX0eD$?8a}sW>Gs?ST@%82MIsPZDRZCx8 zG2fG{tFv`x!v(HiXK&kmuKrpl{O|L*If0AaW(F*EWlvwYK6Ldou}HmEp5`K^}u`XJ*7d_nRj<>Et|QEb>GKh(z{%{PFH_AsV;gy zIw$$z>RIdJ_G;zcQoPG0r0(};d)~|m;`3Nq!Y@c_srMLvdvGe2$_l4$2Bt3;UinurGg)z%C@bFDzWuY7+s#d>r8m^on$PQ2 zJ>=T(g5lHi^Xn_JclWlwH7e-;WcKN={@s7+=jK>;LM-%~W1;xaV!mU4+_Ovi&MG2z zH9x=K|3A!kwpr-&b90SBDN|<7`B|pk7dK9ANZlziq48E>{ga}ba%VwJ(+BaOMukHI z1IHcD2m6IQDy|;=23i?<+jr0DeV{Vv%gf8r>EEB7o$Z?%^lUBjE&J0No-tP><6qx6 zq>wLYu%StgHRZzF0|7D@zP-I2dV5>VpS#jaom#oF{?**8&0F(C(YHoSq1CWAfQ3mx zz=&mwf0k1lj|^ku2bBYpIVXO8&MS4JR;T}b!ROF~I4x!OzAa_pPV?<*eHJ|F3AN$$ zTOBQ#+j~^3{BFSEka-^@zgVyQ6!tyecfqsIcLfCn)j~2a9-QyEXHwn<8>d}jl8{Mb zP_AQOQuJ70`}4_*byKy&%X0M0^Y4`yrJY%EH~+58;?voem-TM-Xy=#DYkKPTNbsxb zXT7^?GzG)bvl$N?_zRwxXS@5zYsF-l`SzAC^Q}wwt0hf#kI$=GW#7gpt94Pn@Z=n+ zref9|@cn!V9S72dCR^RI%KOUFw=UG!Hj&#S{^TUpwNH1Zot@QC^EvU))xK}DES?=M zUiT(?e_btqwj#))1uf0%j?L*$w%FIt;um!6xQR;1ebwT7dn)I>65bVgh+}%jpZneG z4}T~JE{*F7&~n$^*>(E8Z3>~fxa z!Ml#X`}g+A}97t4E*yymWe;(ZNsK zCF0g!zx%29_Pa|-{J@*cKv1|9S+w4O8m(xLq?%FeLg(kp*=hwpCF!FkKV)p?HBa%I7@j>hv)G8(gAVDOF9+w%d8_Nz*+osvY*@ zZEN#i6WCgS>HUw_`S7ft5p8#>m?Re*w@P&hIv!{Pgd`W8<#P zo!&Q!ru*!wJ1bl(ocd&;bNd`7RxXLe;@$jum(FX|eNmJHHLQf0cBJY0SV`qIIoPmB zc?zrwSvl#{GS`0UwtQX93QIOsPZp8S zELIa6Vmf$?nK*@1CVZGNdH>HStIN#MHMJ+^f2)~#^FSl>-%1mW^G{ApbUr)JHahjx zl#^5bOba!{`=&)=R#;&*0CPRM^z=73v%Ce8C`rW^xW-S?Uf9}t0j3-i+MR394Z7I8sy^s z^5#1#s4+#pwAc1tQ2D4+UFAsD#FtY~Cg0yz8+v-0&H8Pdzr4A5xh1jL^JH6ui07IG z#RYW-Taqs@GSvxuNN1gUHD_too3l%t+xfbRf`2@WE09|myL%gG3$^FdRu4&eThMef zLu0+5Lqi`UBa^~~04B#~Hr|kFI*}?a*%N^|?ys?UJwy8#g^&RD3}tkI6~)b=>i%Xq7 zyTx>`+|J*>)_F>_91>>t{@=ZcwFVfjXitk{=K^;b8^e= zTPe@Z%nbIOVc^LJYQBoaZ**nm6i>)Y-dXc=)2mxsS94xwn>gvmKF^6!j>jcS zgl%OWS?R<$_AC9f`J23s^Uvz=_1k{U@blsM!LxVaW9z_IyD!>5x}}-2Xf^0~vjaj* z92az7a?D_4a#RZF{*rcK?e4U*v$QfVE!lN6Yx4Ks@AqdpXXwZ8b57!VCw8Xc&DnKX0xTho4i>@=4RYu9^51uK zSb0lGz(RW6*;LTx=vmY4>+3Fu|NU{~;gyxaUFXxKH1=Hi*6wX9lzyR-RrdRW-ESC7 zy5}}L)qaul!*P{=P^r(C>%RCYybI-Cq6hbuqj4i4-P_-=CQGy?uqW z{slG`hXeUc92fq&wX-`O_{>uAbmNjd{a064FTb>GYQ&W*$uB|Ya;=Nq{e|PQPU@*C znp%;YQf4iECHx(9^f)s+-wR=h%}ZLp+!wA5P%^wx!77`6q4oufN$<>tqv;nGOYfOe z_t5x)8&~}PZ@2UJOI}>+eA4#&ox|~3DIW9f_OATSVzJ1bH4n=>0nL&JB_a__kL z2a^OYxHg=hpRHf|`r1{!;N=d{;pgvHK9>z$+V!ob_SS`udp`y*_q(d5FXs6C<$ue{ zsrs(3c&u(WF)=X;emKBYHKl&?3;FddPu84n|LJ|HPu6G5@u({~r1d>CpIKmEm0P+q$0(%-&=uYb(~_pgUmf9ZdzwyS0R z&YXLDc5;T^DhXK|6$+ZUS!WU^r{KHh!o8l=#{wJ#IaK#@+`*|=p2^8hOFA7#X z$z$Ra?(*53$F=F%nRlyMp8i+<^?LpOu)Dj<%@=yj?mN~iz1lGOSjOb%P64c0hi~5n z&E6mCXgHznF7dH>wZel?rv6C}ca}=WZ_A0itF-lW^!B{DWi$VAJ$bucSlutgbCSms z%g@(W)!QGBoGz~SB>CZ@r!1b|%a`eGY^t03=Aq9g4Fv%K#)YCKFIVrMHQ{nKbJ3lr zhyVOLe)I0$5YS%D2M3#dXPt?>d-S~c%n}aJBECmzplt>$EQcmLm~w8HHpx&>44Zw% zd%E6A+v;x_lf_pom}#88%3c2Hd#^V-?fmj#b0p3=ymYlX_iLql7VF&;SA*+*^&Gcx zI^YZ{x@=wdZ&_M(kR@%OeC@kCJJmumFMoWsdi^ZBX-BN3+p>!pnj9Ed)_~@_U%hKA zR8VkRu&m|DrKR599aq(gzrVYCD}`0-#mnXM!*XwJ;SA|{@fkFn|NPus;j4~^Dt|xw z!!X5T&4OaF@B5iIaP~JjsDQjG99~zri7$EP-Jg5YzP`FTPs()8jm@d2r>W(>b3auz z3o>nSP_co**5b}WQI;lOhw5Dg=N#slW?xJAExP<)?(J=niSeymqE~hlK3=my)lB)u zK2`5&9=CV&i8B^2 z!mqZxoMB(TZ&jFYigQ$sS>H1I8-LHPGutJ=!t~IafwAhxH(MM2cqW_K9_w!Z?Gn{~ zCAKp5-p1tPTTXuoO?Y-@rf*F6v(=IRv(6u9sQUUS_W7gM@8>^fl`6PqvEIEh_ju!v zzI0vn2MTC9<<{E(_ZN4rBRr_-Ff*S>A4{rzph>=T?5bIzBXzx_V{-V`4Z*_*t=D_@Z7-C7!~SZFc4F?x>xe z=XvUlZ$c8NDstce4ed0|<(lrGAjkByL>RQpK`V6Cl)R0%o_?&ocTk6!oiAi<)K;!# zoF8AwS(mN(^=x+jqg?TX=KC)zW4*s9X}{QF`cvxWkMM@NM;{H;6}B|#%{^+nEH2ya z|H<{yAB}2%l^pfFu_r{X>czqn3bvU+$>Gz|RqW)0&%RUj+aL-WSOj%&6w;XH%)EXv z5_GKlaqg!F+2yai+OE&@`uh5O+eP>5exDVY-zF75$Nu*ve!bgn@4}bzS?AO)Kj^TU z^TPD$LhDzCNX6Ul>v(jXHN9f`hnIRYOO7tSS}Q%d5VROU(Cp%`hWr16eqZVYoeq#- z&$wp6?fdQ<1XxOh9_SX{QZJwLhjRhDBN8sd-RV&i~5q@9tjRlzO`9;qv=d zudl6L{i2(7|NQTd9q;Wr1}QO|IvAL~2)y#y!NjD;(UDTLI(GLq?yCoLi=Lbi>^!+i zdwJUVd22VNZ?9H=B%Qx!;WYjDccoN3(93e_h1sf{o11pIcAelp#?rr@ z2XwMuhrLxRpM-(K@*Ou)K2EyC#po)e{UR{BG=FhX)`EK{#=4~i=boMzfWR6vliQ_`+0Vf@f2rq^8dAqejS1pNN z(y_-l{anY1Uf+y|hgwC`mACCJC^#1`%{e{ZbKeznQK9q;i$PUUY(+xLrXQ2l{k?Xi zALgo>67PS(KFr&qa`~Cc&(BsqpZ`7X4QQ)k=yE?<;f_TmdtCn;OjAFwB>4g>(?b^q z#wv@iW;ML!OqQGnY2be6&k6>&Aw} zUo6M;R(4OA#G+z8G3{o!rgd@PsyQe8PUW3dbB>V^AXlWv8ZG+*hfqC%ycV{LdIGE{=u@%c{7&yDHUduiRM9|2{}mzhK!w zhyRhz5ax1B^i*g$zrg+ddD$=C*}<}B-bc=_U-wyvqw@66;z{KUA{qe>aX0^G&v5*& zlMfl~dI5@Pd2bIU#@n1J*K!r^YOjl4GGh;?uv*8-KD`~m%l$ydYrB=OE?QFl{$AGO zW4()@G`k zeg1oO{=Gdn-#@==7qKNH(Em>Pzqi}(uL@jzMEKu5rMye`Lo&`ksH&56EXNTq z1)s1Bi~r1b{4bG}WD&EYz;SEN&7iqXL0y zwtv4|-emAkeeUE#xdLHRT(3jI%P)OTm$8?Q;D^8n;T={+^pB>+wJFiQPNh z=xr-N*T@$uua4T9)g^pfQs=10bsxwYWd~-)-RYC0WLh``7#iz2GU6Tmr|ZqVS^?UZ zU{z)^`NFj3;&XTMswMEpI_P8kQ%uD_m zGxuz3bMZYs&B#wrPmAwV`gBCN=JABPsV^@r&3bcV<0ZGET{Xeq6*J=<{ikY8HIYBT z-sr$_V^5RZQ*r&=_uNN3x1Znl|KIPd7XiZeS$Azc5xaX|?eA5N%}es;^;~58*C6%& zoYfX4Mgb1cfa<|_j4#+3i&?hJzrMAS_3zH-^Mv=`pS^xY^~a;)qU$?u#GRXOzg|g6 z$!EsR`BP5F|M)*&J;Kra;^GSr#TyNFu-lsHwZGs$yRt}*>!VS@1Bb5{-RJP1jeffI zdYtiI-~HBtkCHh+CFe9@hladL_JcM87d#YN-6AJ0%DKyDlX*$y>$~0WUzL52|Kv4A zW1*B;j>OD0C%9Ypd;Iu(-hQcXtOwVT&F5W6qlT?e$K?h)TAY_p^<^9M7oO6tf4`Y>DK#l&-roH_jWdT zf)1emD4H}$)q9%G#OPZ)s}xt>`1A9#Z%*!hpEJJe&t=>fO?o}uZ_;DQO{p9$AGxYT z0_?v3nZ$Fq-g|H9>uFh+m-Sjzd|1F)8dX}5_T6i$R_0X6euI6*SETRj%wED2tB@eb z$nrw0l+A~cF_Gz3_=U-8SL=974{+=%d%H?6c9+P8IX77Dl;5xII?r#Gb;aZ9xw+9k z{dx!ItXNfFf3H+8?uXab*hf+S)-q_nXlrziy}((K%4*AXMfwZBa{7E7w&F$@)r1D)tJ3Y)?;qe??p8ZYTI&ehvnW-DBm2u z(5Y4A^@`x-eWxa?_j^rpsjiWj@ZZq(O!`ND8H)w6?_`-Ovww$Vsv4d+F8M{lq1~&T zr6ugb`5l+@LRZVB^iJeHFkL@>UDWox+^L`QdQMJMZl7gaz3tSDi#Mh|ontcX{&x9- zWcgbS3>-5+6Hq$&8O)6dLKpTm)%`SjpS5jqkEF3$QIm40Me^U|e%ocQuCHJJ>G}Em zw?BWs_~$>@Ds;-p+}P(Y()BgpeLUg2CR%^fj@N2Z`#!b2bKL(ja8d5bcW>2lo@?v# zrh8m}6t*$x=#}U5>({wX^H%&GVEylr%IeeKGT4|D5;_=|N}LxgWMk1$D2Ut6+bNvg z-~Y#`@awCqUGKk7)3Uj^E^6zlRY6O;wBq*c@R}F%ySMa~uYJ*zj;fcc%E#?1OW$;q zvESi5!nMoVFGG}t$?5xo>O$7JFF%V{`mV_OFVnR$yPZdJkww7wD9!kNdmg=g2in+_ zEq2v~t<*`Bqrt%jRBCoKIQ$T}AQu|9vq<&DmveJ07h9FSQpsZXpY`KR<<6p~HWNkq z5)~uiw_c-4$+lIl-#(X>gT}cK^E?s?2ec)kPQSdoeCw&t?h)tb*ZcoT9<{WdQUT{w7W1hccUrjtdXcK8G#N)F*avbKihP_=SV)wrX9!6bLcj? zFlfIpZ2I5wFZ|oA-i$2J>bkNw58kux39b72YUz)8CC#nn=01ii_(9u>9w{_1$R1{9 zIn>_pjrs9%zqwpmw(|~n~PE0 zoj+SX*iNcNv_!sf;Z94Y2*>`ZruzK+#utU>C~S`1U8WY2dHvw?7nSN$4jzi%A@w)x zz=He$R;GENK63C~)?`No1*UZ7Dyz2k|9?LF-&Kk|{W!%+fB&CNpp|5xi)ld>^sfK^ ze%nsmIJdUu)ym~A>u2shJ8}IB!>RzIY5y+oYkJrEhv{EWs!j4dhD|$;pR8f{d-cS& zSEaA7tz70idzL(dlu6O2%b|3 zIXFyaP1vtEQOgw*xSzUaJvJ7$42W{vZrN3xHg{uV-4FKdRhbtS zIJSjf&eaB`bkM%NrQW-zZJKj=U9Hd7w%j!d`W!5c3~DbNU%38YU^>Uqv3`Mm#D)Vh zwpCXmUo(Z*embfC?Bj8H@qklNP20DXzrS}kWM$CNC+FwKZ`IZO2)YWix5UZ&#J%bz zIbxR%a_tiEIB`MMHN?xRZ0Ox6er9S$OEn@B9_h%2zvXVP;bJpv~xW!BEIS!GQvZg zI~?$1dbIk*<>mh2>K~8W|GT*3qr!sV<$i73cii68_3MOk|Bj7YYXwUUmf!oBe2{CG zd^M|CrXa^Bt}3?8*)QaSw=m3GWnJ{d<1l|+uFf9c|0mUBJyqv7s`vggJmVI&0lX>L zfq~_Z-vdh{1EtvV_xEHkYJoPb?$|r?r+?!^CFAsSJu-GR5vN51@1C5jzWY#X#MVzA z7u?gcowhyqw%RR!0dDoioyE_y_SirF^<%F_W|X8*wC3M?=e+vWc3tBOvbwj#@Z6@$ zHC~$*FJxs>m|)4cWX&H3ot%XeK2Xv$4swRJ4m;X9q-><<$uj>BA5#kaktGWT`JpFFiD_}%{hb)P}! zA$^&?OKo|dv_-*!D(mGY2kI+gIIA8l3kHR#8-sAk{;wQw7#U-k9-BU~|LtS<`P#|J z>b%dbpF5P?TAF%#+A_bnR&C8kZU$5o`K|tYYuUMlY=3rbwLM(^(fGyBPfssDd?fL)j_p;*j@Zf3xXUkmdy|K!PYmq_% zKcmluw=cCLxR``kEX03_aV`ut-S_WT_U5|3Re_QJ4sEIUm=t*S%#l~u)@I+@nw_3? zZB1s;(??g<|I>SXyx$zO13=pC-ZM94&n*+1--*ULK0mp$TeD|Uf$a9SDGm`~7mRmJ zXP$ibwOhQrRmq8%x}Q(oULNe)#SJ>B{~`NXy=m81tevN~t$mq;LI{h2BY$Z5;YfiF zA&J!oAFkbgPiS)O$D`tBrStbFE}K4AV6LsX?<^BT*KV=WrF&DPcYZ!+J$Y(D(SPNV zi#F=wRTaGzd|&odey)1KH;Ye*acO7VjIayFZHJA&@XzB}HN98beAd6ezgKTxe9__I zq1Lmv^Y`bTnqF?2`m_CscPwxH0#2qx^#;zW8}1B$_>~(CrTo0-K71^iv|Z`-vL#Dq znC0G@u_^U*mV)5*J+Ig8=9zywTyL`H|Nm2NPnaM+-}koA-gqWClM>DcJi9dRM|+%| zYSIrHT-koFYW0ebd7ZH}ACI<`Zx+>f5OwO)pC`AshiLD9s(g#Faf84C7F!)#UVFy} z;8_=l|e_(>YH$We#kEV|L6I7p?&us z_PW2=wOc0c_1Dx0$M3t?FVszAnG$y4dz-{h(I?i&j|S*Zu{>h)Wy1Z#`6+#k{W%}Y z%Ei4cvtG-tD$8*!7UY@5)R@B2G4H!ioR)-Aj3| z+J=NL-@ogr{4MYb2>}MiaE^jiB2)jY)DBzYp|SkU;(ohTN#|$QT{1gxqLG<>ky%j7 zkCvR$-^*_2@4w4yX0`Lvm$qW%mxeL>>uR^}7JJJ&`Q*C$ z>C4R%53yvszc4;;v)GVr^W`UBDkiTe`Xl7`a@WLHW~+X$EIMW5SLA@tgbXi;IhozCCejyJqmRBf0aZo7a3i zDxSB&(q~Ur)VI7$J=?nItyxb~!xz705Db{L;C}wi>X6fSZZEz6JM!gJok*iiWpAUh z-IramD0!S8q?G$XaKic(pUn0dMK$y9g3cQ+@Ogw$E5iIPetq(u?F68Ep+mk=WyfGf^_!}@4lR8tUQ&jac-9B>4F-O z=+hS#I{Ws^{n;qF>(XqSy7{lfR{dWTWn04XzyQ1;xM3*!hWTv_IU8p< z+}~GgdTixf&s|^b5-c9v2swMcC3vgm*`-^RCzUfSS+*>z$Md#Hd(ixC7o;ZzKu#KD zXnewHv*K%fcc&I?Ex^-f2ifJ%d^^pvG^O|{fAzUJmdcyc&u@FxE&5iYAUpf_)sy^+ zp{>~-wN2L~Y=ftlMMjwVC9J9E{POy`|KrcS;VglE>H)3)PDgJrshGd?=bz8#f0ti4 zx*_NCGG9S2?N?mt+kYu{mbqQnyYNm}1HS+y(ft>GAhRs1ena@$sHrc*+oo!VyIK6` zOS>(3YmZQFH0a(R=^P8)K6&p{qpt1B>xz?W=G;1_yZuhm?SRI;cB&Va`AYYGFNn6^ zmspz+>}_tZ?ba*x^m3s1?KP>Vr@3~C>8>&~%f0$!fAbz^ZdR5WSBCTpwO3^g*jQrJ zH_VLsxW%eDkEdOJwqxH{x%3N<-x=STz}hHdS(LHipyZb`EBzMB-(SLLW9)lN zHc?D3=0#ZXqPJI81Rk#WbW&X{T+h$E&xu8Esny(9mqRSYAqTTIFmU{6V#uEzQvJ)e z^3#*cay_GB!xtgH z8`By@;X7ldL-g$3IzrMQK{pQxz)7KtK7HS^rJXY-x zT+H0dEu&ocJGT29Xk?#(Ws}N>+D-8hn|AH5{{C)%ZD-+YZ$|&3@bz)Icc(9(XIq_B z_w&Ssy6ca>A8ftyFE^y}>LK2G+3g>1B=<*}rzLE#=hX1Mu)6Bcy{!v>n&0^qey!!XNmuKBy~-nzKThF1=HF`HQ_H8>W zquly`+ue0{1->{w2w~DnbZeAgad4Q+;9qwuFxSPjRm=a(=at)EJ!Z=|dg{zfTpTLy4P{4WBp>fnRWJH=ch6zZ+D)378~C?aNG#JfG=K5qnkQGstj(dT!|V#I z>x4778(v;pJ6qDSDCLiN`{TatC(ph<^iXTh7iPva3w|#YPhjRaqIO{Q1KAZtaxrmB zx6~Pl+P zS-4Rv!jV6uyz1GRdA8L{)StgO9d}-4)AmHWLq}K7|9_>d(e85bxA*t!kMF7c>=j$k zSUS6%XF02kRmqCX`}_7TjCpx$N6wY~(|YvWwodOob~x=fM?zCx{QQHDJ_xLESr_NL zRru<&hlSR4{{KJr*U#vatqk8PoBICV-eos!kleuU%Yx2eVmm37*7OwW& zsuw!1=ep@4Z(Y2DF7DV5z-DfyY{(z>)69<1Dt@)LY9#oa9mhJw$dt3hfxK*XE zuf1OJ;eOt0E><%W(1h7Sk)>(R&&|Dd^L^7n+m*cwL)I5B)HQ*e>i58yDfZ+%{}oCF z-OOyYzrJkLayb9+aJ#aJW&f3RvA28w#riz%U}l*YS<%_Ped&FluYs%X2RwCX%)9aA zwpm8^s?cQ4W4|UJSQWb3T-ayb?4Yn&KhN<4w_QU+FUzb67v~2*)fbX^z^2O9`0DEF+2!{tk4yQf z`^_=<^3*o#^CVU8I~!&%{&&agYvn5W;HR9{?(1*)l$u=)U-{|Vcav3nqU2r$ZAds6 z@SFd6Dn|lqY}?`urx-3pE3TQj^3M1B_4nJt7XJMFZG!Y$&+U%88F-dzO`XO&N$$8= zg^dT_L2*babB6QJ^g5X-%TKTSX_$9s$BomBcDs^JPt%=vu$kSxOGNXLlyZ;u^Y_|T z)h`!cWD3qv1#P77{ci5A;_lh!kh`mPdi4BGS*wzYo?{=RqK_N0o;~7K_3i#?ft$8F zzbn5x*TxWb!O+IxKs3|cm6d%P{<`O%-LU@a^Lf?hmMmKqm2BajJKrd^Yoc5(UFNx0xUAZJEpIzx%Khtjt}Nc+wT;0 z?|iNIb%uS?5&wBMnb+3EO7rrVm%ocKjO92fa8MZm%)MfpX?H-YX^+g$VWQ_GX$XJ;}kzAD(W zoSm%RuNksp!ouQr7q7?cEOL$iIjbjpU!U^n&;NgBNZ4!K*qH48<-Nx9obQ2^%{dR} zO4|QEp*BN^foaA9_65QZn@U+Mg3Q<(op<%I>{^$1cNb_4HRqj|cXj`?HiZSB0i6#x zS1`j;jnSpBzmr3}0(2Bl(VNPrlP|k`dbO?Wp-H~{g_O;PzL(4|?4N%rFTnZ#tJUkx zV(NcBo&Lga!`0Q{vul5UbLA4(o71d*dHFRaRxX$S^X=>Zy;kvM@Q5C z{P>u5W`^Oj-R~_@`j;=2*?MkcjNa!fTqb;=9eWBBL>jwFzO$^7N*7^X?-^gDBocFW zm2&MAH{DNH!{c48N?(cm__wh(26V^hs*S2SZ^9DyUO4slef|H-73=rUyb>>WXO1Kz z-=dWl!)IpJonpH%dlB!q8jYL1qW7jYGBG8w6tKnesJ1vL zs5NGl9IaTTX}JCf>rA1Fw_C6Ktc{v8?{?pz^uYQb58Ge7`ne`@^BV)JC1Ibm`15!2 z6y6j|y6+krZq?jp^J39n5z*J~SJxW5-?{eq%Y;guy=4n_`Q4lQL35f;g837I0Ro@T-?4;=G{eyHMPIK2nLnv9Ikf|2tHw` z7bDTlp!Q-T$HVUm6Koo}J(`#=hj_(l&EeA2)O@yddfcW{m3%zg3m>}~7d`RVUNkTI zsJdjb{w|MymeZd|o=mCv{NWz+m2VmRxA}c8M>uX@r5!$b>-HTPAM01FwKMU&?>RO6 zs^w9wE`>%=Z}`0Zf14=F6LY&;m3I~Qm52y<%wkY`;i=rhz>(s;z~|TWxbXj8EGzxH z#P##y>i?F$j(K#T;BY&CzgwQW=R5}Ye|z6-I(=qG;p0W2yAoLMeqfPp4oyhVbS*s2 zwaejtilSjxUESV!e{8ixdln*oQ}%ObL!qM~laPSp-i>yueob*pY4ec0v` zkjW}rdEx8vi^^AyRR22b61~Fj>*Ahm8I#U2rc`!+;hKJnKh*f{uF~#*zUzXIPqoOa zSKndj#42&FOZWgwtc)g$qk>mMaNY;;xG6_CWtK(XUoK@?_~^*vFH*6&ABrvO{_Kd{ zUAFe;m&^W(Eu-rHN$w7s`%T>c)K71b^^@M;-FUFTc0UG@&`+vwfpJPejW*H7PRYRsdXZwqf{-5~jc=Wa$%^BL^>#~I=7kyv1HhR0% zsmeUi{ZE^-u4f{6qak zs$NqJ<~aZQ@bGZk_OhZcpNgKIl8l@9q*G+Q(q$IwU9K~k_kDb&zP4lYxp!Y*U+6o$Jz3qRvuiA!e54!94Rb#Gn^`YiEpA{#$_4iz;`SbC3+F7Y{5v`LX8RevN zZ*McTG0eZdZmwp`j)FT2HZ;kZ8{J8;XMEyVzMkJaIM_UJu8Zk(?z5lx4E?@}-Hr2) zWbnG=9V~u}H&ytLc}IB`Xiu7qO+`SrBeT#ukJ6qn<_o-Lj6N5d@9zI_u9itA?~l;; z*}Zp_{5N!qYNzS#`;k=q@8@&(c*_hff33<c-*)OEjmS0@t`qSfp=fAw7Q`+@`52yAp zo?G+r-ztB*pGVHjx4&QQT$951-M(J%)upA~;NkPDt3oebd&pCDi9>OLhr>%At8=F{ zzD25Cl5uGH|82+A)ioMhw@&)^tZ$tsD zGu`EDul)J@J}cgsZIX0(;M2Pe8VUm9j6N40A8PG(RETDpqjmJ_r9G9!m$zhIe&N!g z?$((jInBtbvoj)kQzDP=mCGK@+kbt0^)vTNP~<7I+_{d;Y%|Z!u1rta;nm6|>N8o* z*XQxE-o=k6s6V^q`k2RR(T?ozQ59b{Hp#8nS2t#ZYum{@;i8j4g#C zsF_wPKoee!`zcs-D_x{4bR6=s7{T@AJ2B3&c;k=UWKnEq3eW$rpU$X~}-K zaCZXh-P}hR`f^O3HY?7olU%dl_+`#b*NYD5pZk2nIqX}G={${3Du2(K-@lT__3I^z zg@08uTTM#L(ticx@hIQA5+!u{5iGy zfy}}A>Q7p^M1!_Q2g_)`m{qcHE)Qef`?og_&s1{d_CI&^lVfL;RL;huPvYuVDc>ph zd`vpuM5bfv=J*9KgfxPdbUd^$I&b@Zj+^saQ;KYd(#f7C^Y+>hH8`Tue zC%xM{d(|nQcRss+eSe?7%x9+1+!c#o2t8;OSjt%?yJ?T))tS5G9Be&Uir7v{{$OI# z6Mpa_Vtd9m%Yp|EKIcps)ffI*I*Xt|#(=rCv9QfoY|xBHBU?y1PQquflK9m>4h6x3cE zd>3D_+`U2l`SgsF`#+u1zGxDz@lW}~0cQRc(xw0ZexJQ%i^*AkiI7~Y_za8hx0w{GGKwtfb+ z7YAPlS1j>gAY!`kQ^!`9PN8QH+vTr)XV5+33p!Zk*}`_YuHXAA@*l*k(YPsmA;QsJ zq`b$9lgTUn!p0`OiGsu0(;_)5rh*{+_(ce)H@?wpf`= z4c4iPcKjFeno(x?S8C>OesiC=tyxnazI~@r#WH2l&Sciu^{1JZ_i$D{*d@ZZ)8TT>Aer%O%D6- zSGMO}o9^K@-r~hGFKjy)St8=4dg;vK1>7eYKu&I$%QZcO^TW5Yss8UAo7q-M@qIkP zab}k3X`4?clsoUr9FJYU?^l*gc>C|5Igb40|9{`Cp5yqv`2CKg+h?zwN_jg?OeZ42 zEdSn`yFM9TZ*R?B{tb$B(F}Gw{J-18Wuc@EsOVVl|8SySqn^~K>+$t_+jLBXRW_8rkNbSa`237jp{r-P zc8jU5c=Tr5G~H;adrtk2<}jRFV4dEoeOI+Xw4}W9_m-`(Dc5B~lxKa@JZgQx`f3lU_L3~oA#bd ziU%ft=3ctgy5xnx-$&h#_?g`M zqRzJeTECx}^0Y47&SK#BeVTpL_HGAZ-eOSf^G0T0aqP{_&Bs5aU;Oa!aPp_Qmc`2+{`&cR{%rI6 zHJ3&7Vl1B7Chla=ev$a{WzOF>9{Y7yc`CX0$t){Op2}N0D=m6y?B1$U-fHcv4kzOZ zQ1u!&|B$jR(;xTnEg$4>-rHNhZDOv^O_4c6M9rm>iz-|LgjC%N<60 zrhoAI*}^G&W{KzIMUx%Rnv_?5YO(%&cA9RqPq&!vnPtASA4wH}&VKo#aiaWwZMxTV zJ=yDf9rs3Lvi^O(;1k!1_*c(+s=vHQ{E@-eCC9i_^vk3a!{h(0R;F7{X?9=`{-W?j zsivU2;m5(#esir7zn)xsulNEV``wvFsa;hG7W3v5->aT-nX^aU{$9aTPs{oBWvk~@ zzuTE-`t)?!tu2|t-=EkV7WDgWQt;rwi^C!!U0iO4IwGeGS$#cT3BFjO{&)2!U-P?5 z?z+7AdfxiI&1CIxz2ZklI6cK|EZ2LK&RwFhrOBN^_{)Q@nl_gd1DaFxr%iizZSCwW zDqnxRoX1aBS7_A?%!Wujmz&N{pIcL>r0j{jchyO zSG+o8WfJH@@7x;3Ove|j@PgIZA@y|BF5Yg)5nSblI?=D&Z+`RmEa$&YuL&+GpD z{CxhrnolPy@;I+-tywp}pI;|t$Aung^K&)-|9;>1p})-U!=~j~M^fW0s@eo=<}{z5 z=sg9r?)OgV_1I+@fmauA7h1L|>&?Br(a!SKGfh{#%GjoO^O4o1V0tajY&sMW`rnQTq}TiZO5feJulD!1BUT#m~LZo^kW?zO7dA_Xp~91t#8?I_pd(A{6P1>=Vxb)=S1~y*I?7_ zf7>T(eI`7DWRl?ktqxk|#CorCS$KuCZT-ndr*g~Q+_?C`;=z>cZO@#ae?DGg@}OIPUjYBQ z<=2gm>BR4g3BFf;>yJQd_+C}+_ft5kA2u}G|JRW#*&BIdXVjzrmMQ7pnbAMR z?<#v({9f6;ujd-Oe2u}ayx-s6E*Ab;_V(7yHeTsj#pga=zyGnBoqyI+@9A#Jchf_b z8gIY#?udP#oMcz?k)G9|KhNA>m_dC64q6l zCOvY0c*91fee&BS6<3y&OD^61cD?%hj|>O5t`j`Ka@X`q#)%}Rt4ng9UoF1(sOOP9 z(;azLuPFvwv#xfzN!V9@TC)7u$H=g_r#8h)Cl_y?rXO$j%b+n{f7gpeFRuM*V&$Gy z^z@W#_}$afbgQrZ{FZ#YPcrW9zmLb|&(5>0KC>T()m%|?mnZ84n)|>idEEgp*gk3OQ!RBL}e&A1|wZZ~NhdnF+JVFDQxnzcKzKwm7g;l z+*_6Ejzu0kw!v%L)Ur9}?LSY{7J1L1v37y@=X1(ia=00NF66${yzx@Bk?j(1@da^_ z|3VKmo_S4-{`=ZQ=XZxdjXWFA=jZ49*|@IgB%aosFX_EhN7i(uuFc)6GJ86+yWI<( zv)gLi6AJJu?ZR-c@UNuPv)cE*T<~&!-7ih47G6~omO3SWOHB*+i`H@_>zDh^UiR+M zlarIL-u_U{oSB&!rKU7%x7f`mB}ad=@_(NETA*|H)UXSJ3!)blGp%dntU6#V@lMsZ zAza6W``?SMMiMFAB5$n|(~a`*cGCA_nlmqCVFGI`W7Y)~Lr4Co{zLMfOmkMm)YyX>5~{f^ z(-ay*SBJSW$LL0H^9c|QvQwWRxc4vH{M(vI_tr#ib}88;{7`>uo()Gpxk@M7scE{a zMIWrr6iRy-Cd>3__4Ayxv$Gz(X12P=9%1S~&qnH=>?MKLv<(~yO>%4gwU}>W(VH~& zcPOv+3#pJ)lb_sy`)Ym`u*I@1=hfOjVPbsHz8_{^RtdG<^cN7*k6Tms&*pIa9B1=o zvAfHp?w;Ry;p(^Z*%C5Lz8}x?ol|Mb(ZAO(^ThG{KK?^ljA}0u-&X#3+tTo3+E#A8 z9S5dpg`V=fz2g`&lT0FL7Tv_l|E%o?4&P%622<XG5|CB8hZ^DdP)9$whMu0C0*fwL;;M?vuc zPLZkK)_aM5oKbv9&8eTmBF%zF zzt=m5aSe6Qi`LZGW03Ow6=|m z*Pk#HhAyqmxw2v+s4b*0!94#S%e$^h?sE%{yR>i{I3AZ^Xk5c7GNr9qv?OzpRh5@z zPiYVDx>p57Z{t?UG{Ao%Z{B)i>}bM$k?=5+ABaqusTsQH> zF;|D0uXCc0-(Rrfm&4nnH49cRY%Snnnz10cqru@C%aQO4+~RsX_rwG|JUtC%S|yK~ zG6`m7GF?qyQMMqeL5uy+qyN{#HYIuO%1c+RjX&8ZZ-1|}dYR8jhc{K1_hoJUi}kNdFY__v&Spu?P8sv{zmF)@~wMy!kpdjr(85J zi}W?$zCHa$S4r!!kTnq(L8r>ye0TcIKR>BO7kXwpEZykww?G0?Oar$pqa%TCs1V zOvs&Q>&gz;PV@iqH=pH5^H;^Av+CWhuL@oL!*N~7#g3IqxyoN`)EYQ<9hYr*R_nW9 z%a+mz$LVUTmWOZ22)w+vx_m9$J;jILSG>EBb%6Qq+$+zfhp-2)^_#kX$Gw^VHb3UP zwOG_|{`uY6xpVz5gzmi!IzdBS&bji|mdtru-%f9{E`60U<=m#WG@jo}^^G?+FW%8T zE$iy4&R32)g-nyxe50oSxEpz|Q?!J2h2!KSEVdc8T=h#h3MOb>{O;b!#LClj#Iv;D z+Nw)Ce&G`18 znNxnfH_x84+1BgR{D8e-C*1CzJ~Qj+a*jQk-C`dn@RgsOX}mn}*2K#*PIUPT9KIV} zSb2VT^^xM`MR%A);ss{xD0z8lzKD+H8qhe0-~;_m&^EDj;S=h-tgD}2a{2o8*VotS z?{+-q>us|zh;qB>^1tG5kK3&a|FZ*i=l?sk+cGOiRDOD-#rFQXbE|(#ulOV`;^)4t zOKZK_8jt^T*`^1ZN?)iyvb}%OGmBgI&P{yiym9Z`M!y*cq}ldp#<48_eC+a@=-kW8 zdVjuJz23yUXzh^f5`1$$H&W~lEi`&!Fq?bo|`}&%4X|Aexbn@V(O;NYz`0RgNmG+@)7-~RJR!Z7AX&;RId-O2Rh=a#*D^>+2XDfrYTZJWHQ zdG4(gv;2E+c4l@w`IjxuBV#dPaeb%!d?jB#tR{AZD6U;Zwp_zA}&rKe|SUl-Ad2vB}6vp?PH%Ip?c$3*06!gk4}wyrp+_L!$Fx!Mmbex6Z^L4BM_! z`E}0X^W9=rNk;QnoG1UD^YH9^`}iq|MoF8~A6ILBUi{eTzWQOq+11fnFP+S?nI7F2 z)|tKFbMSV_kV@Ad{frVC*%@E|^p@CH6zRz&H<(n4i*s=tQEA|;@^RUrumt3|?{9^t z^JHGHcw9DJFV;lrS%*WYX^ZYPpNkv*{`>v@yz4GjlP!N&S!P|)xId$f^Vj;=!n3B= z3r;!rUUGL9nRQc0Al}iw@KKBJiSvrdKj(atHItm%yVifsr`^_5YowMh;l9}bs*@6A zxyp}l$SA8`w4DiBkM7=|C1Wr0S<>mIz>6Cj7mLk57jqifrKJ+Pi4tSBHaV96bLiz4bje=SP&@*((e0m2au~m-cI` z%z@C?{QsQVzdhJALHK~W;|X?#JLji0{Fr3Up6j%6@`0t(jZ1e2ecx_$m?j@=Vp9?X@-F$H; zGF5QfN^iXz7kuh@l{Kr(o^R$2{dl|U>nzjkGkvnwPFL9@EuwdNPF9Oz|Ku#na*@3` zbNv?HiVl6>D--X%-cq&C=svjpq0VBUS^A@?I+(W++Dn7@81uu;;|~aue0~^N}Ea8HNV?#lzmNS|I88F%ddX+Ur|cutL)CoTY61=^1Bk% z+!JgQ80=0k-&k4T+0*dj+t$+8*E%KH6~A*{Ssi{Jv}J7Z!&_2|re${dpS$`0wEq5> zKXX>x-`OW?eQmnhFU_~Jk2gpK{+=w7^T5-MpEcGa&CkImRc@d14y!8_*}t=2>ejie zpXFcVzT=go)aH2%YA>#pE6N0@Z19Sz{+jjCwK7w9p?I@HGaIjoL}F83kJp!PQ>KXY z{`<6bS$z1ajYt1(Pn;aJz=3hC{u{051vR!0_8RB)mt400|HnA#s)zI0nEqs*yL11o zp8j&{>Y~kitooUl`ZyDs-bsk+@hCFh`=%20p(I9Rxq1?>wAqymap98WBkE$JS|J9B za~AYVKR+L`8#GvaZ0O3R{HyHJKan>QSHMZT+(mNaQ64Ch9B%&^BwJrTuk=vTF=OKamTLG z&`pb4wOAw69yh6r&XJGWvL)|sRLFTY!+8wrFK=n&C71C5R{h})t`Dq^sUgF6^ZW}7@18{YS&sO9%6~Vy*=R|Q~d4ciwfVa)Lomv zc;IlGWy@kS zcdf0n7cJqwxtTL(QroAq=J!3ko!*Bt$^7_Uwd#9->?@%u(_^yO&$7T9v3?EbXLO3K zSw{4eQ<4h^vnx9XnOKn$4@EQY*JUjg8w=v2o9exm~^|-voLsTYaQ7VAIvK$T&xPwYLY-=hr^_-JW~NF8d|u zpqANE=6N-|FL(dE(A9kY?4?hfyAFc(YJK=EA*bf4dTblIbj^5#4 zlXT;NUH9^E(7`h+BQ`E#eRq0RhIhfr%*)G8TIH>e;+knU>s2DF_?uWr|w;qtynUJ6>E{yVpeO(dXxhI$pwG-d@t# z*z`~OV%y9AmpH_Zzf=opO7-Y(XLzylP1Ay@@rRFx1w2y!@aOaS*;!Xt&E&WHq400^ zG}5i-I^179^La~PC4H9 z@b=x)@lW>u|5wdB=h5$rmVCz#HnW@NZ1vr&z}oeA&(o-M;X^-{ocbGR;I{bWWOe^p z;&By@&Q=>{$*4>YUU;we``x(OV>~K5ikZ13`gVf0C0-9$tk})DX41CWGZItxKfjdb zq|ePHb24^eOCf8lO?>gmNvghCS*x7B|A;Pnb!BA~8{c(-xJ@aYZEJdG*>r{_`s{kx zJ>|t&jtIB2epfPn-Atcvx;lLQwF!Jv)bi8iO)@4te6T={ZQ&nw$G+imnrp89q+tF{&x- zYdW_^Wcw1f9ol~$-dY#C+l1%la>ZB4z8`B}{CTh>+I;GkS9ZrTc{@^VzIy zp7+x}9n3qjHsw-pNdJOj2Zu=vYA+_4EEEl4+S9cq`qs|(`+oa@$_l|7n^L>oyc44w z*Sj+u{k-q<&%;WtT^V0`*PDu#KTcuMpRLTB0P64julx98_NBC4OON|c-M6gDW1-_m zlQu3hHrG$Sy6$Ef)otTshWf}L4SS7@U!g{>hc|55V!|7FKf6zQ`J}d)=jW%dd9{k= ztb~2tp7%F*r6go$J-4_zlk4qP)w4oeyC&GoW?<(KzMnhk;+Yc@mCrt%9xrG0j$2&M zBs{is>dL^yZIz#Wx27v}7VMpt_lQ+SL_k2jfpeEd5C_|o0}+|~>wZ2JKb*cI;EnQv zlDe>(>23Wdzg^y-yN2;m+PNz;uDhytvtRn%`TczN{MQde4X0={{(331FXYideujWM ziXT>`8OzsxnFv~yWLc#0!+MoHXbbm`FJO6R?2zif+BwQ4`dcsE4p@5DTP^EnREflPD0CM;F!K5zg3PRW}a z7eUi)v(8p5`g@q)enz`|oyD#wyMzM_#z{vw{NHq3e6jY+@9lpwByzYAlV=S1(Zcf` z5?N!nUpBe&{G6!$+XHDu98ps>;-z>dU3oMA$={jx=1rQkNbz;`*~ralnKvuaE*O1m z`;jPqDxbx|UZH-+n$UzxPL9HpB84Ru@ur`eqPZ;h_O@q-`R%XddBx6G-mw4UG3kp} zKYe<7dNycj+>eU#v!N_5rPEui3QQ7M8GSCSeW51tQkdycdhfHdv(tAhy5a1QdDZ{V z!~XuxRV-^?-QB&tKlYk2=wME%M>YRy9!Va0#V^)DU+>0MzqXQRvsP;0+@k)o@JIB^6c-WWnHh&&Qz95n46n&vFG!1Nwd{5CGopTR$2&qv%X$-`|s3Ae|4vp zD9*NQe13=N^ZELJmrXJ*9N>{(H|?qK5z)H!_TTRmUwr!$bfmz}Pp7ocg60JIWG{Kd zDI^uOojCO6(Hqa`2Mb!hV1@>%GiOZa=CF|(&(VEffv--X7FCV{boUmv4 zt;{|3|30+a|EPVj;)eV4^IMNSo*db8{OqN_<(8t3{Ljhz3^w?qPhLQ9TX&) zc23?Y`Mt^E1jmQCGe<*Sd;C7@7+534<9aJ}_1ArWg0xR;;ylf@>y%xIUAN@1MHMz_ zZelh+pD!|Gsj0bkrCagpOsS^|$ubN4tGqpeFFko*Gv^%dQCTMcK;t?0?`<_IdlPYZ zYOr6?xdQXPe{XJYKYwPP?d>(u+s_rab(&^hlj!ReZ1DK}J>dAxZNi7PIySXAFt9i% zG_Y7$besx~zP0RG_wsuNO4&?zcb8v(@q4n#vLesr38%d;X^z z_I|wD3t(PSyE|j18Y|gst>MHY%>xw?xd)2;t zvA6!?QE~TqRj*c_SQWZ@Qq}yqHkC$BAC;8i>;INM`T2Z)|AmU;BH zk|R^@XTkXec3;0^JK>FMdoRhN2amvZn(oB1p~pQ-a#_v6Bht8<%8@0o)xyY*}T9a9QA zn)LC<&K$Q;!(Ka31G3idcIamdKj!JOTx-H3zjg}BB>#NTbnUn3E~A{vt8@Ar7c?~J zb0~D}*5AeG7UA|FTDQ9X-_P{opHHW^KlR)y<|cYqf8P%$*Xb_HvpIkJnEM`{w_%=r zc!cHo7xUgsd-C(4io1!J?w+Q;PtuHjPmj3PEN99rS`fTWQ&DJgfV-=nBVbF;ViU*vesO)@ z`f?|5{(ywU^VfYxPRD zPV2eb_StVG|C=(!f@}P${XZJ7PB>7>*1iT*-+YbbV7E~)XuUOO$xXfbpYJX%Zch`w z(ARt*d;Ln=$q!9z5;g9c%vqw~DzzyrLoZ^3!(l(ZN9Ae%J{#W_l;2#k=D3V?na^Q) zY18P7ZNI8gew2G1Tdwia$;_-#d&_?7BW8@@0*rB*&qF7?UYW-%DDXj<(dWY78`>LA zvN7prOaFYk{l3(_eY?~7-)p&koOEDz{=Su0|ENbDvb!7_x%KsB^*N3!%ir8cOgnQz zOE@aX*8bALyK}OFwtRR}^XtooIbRA|)``b{RSxC5p&q--gWE}8kLmA=ES_&WCUnNu z%$V|S!L6QG1%{yW{hnP+p;B>S3=a?s{gcO8Z5UoM@_ z{(i>dQspFPMFQmg2vrf}wNP9nFiOg$2TjSRUKgedtNYD}&fj}Aru1s)vjdG0?k;~j zPWjEgSNUAlIDg(Ty~`T?oMl0sx3i|6bXe}EwW-kh`BC2D=jX0wOk2F!`ftHZom>X? z<1UuH2cCYhuM;W`X!NdVHrF`d6EKOnGFYO`di_w>G+4+q)TsXgP(PM)e2dg;w=Zl_Omk;^{HExf_AP-dF_-!GG| z&8X4p`&iNJHb3wFKHDj^vsy1_U;h2rnD^Qe$!X{3TeNLWpZ+g=W&c(??LTWyKmWb{ z^BVPw2B4#9z$fjrOk-GYRrpKf`l)TXx6d4CWIns~dR#W2+?9x!!n30B<|Y*%5;o`E zwbGTYtloX=V43b>;R}0byjwZ(K<&+YlO|0{`oU8rar(;2M~+vF4UTQrSubSmn3>+N z_V5xR-#b6o{BTiaKUD4J!kHnoX-@m^^PYG5qw8(;4ro8qUBSmHAh2OBgW8L2-xc0` zXKp-xl4I@WrpRCBIX4V~7rXI({`dR+??%T3IWtT$CslsCnQmHJ<{g%weh&?4Q zmE?;3?zrh5-@CW;Z%!-xraUE><4@ziw-zuM zPi_Z4{Vvv3%=G@k(wcjntF_(v=FV=@hTQqJN9}<2w|iZmVQT?eqgPgK`r3WT*EMWi zOy}E$PApO;84GUqC;nnOHkrF{T1i~wisf%7XWrVf(!&3h^0|7s{GVaF@}FA6j=QZ|~l`CTOYG0r!M!?>_FV z=3Tbrrw`NPCz+Yi=j{Lgx$rI5tnag)$UFJoea~wyX#7(tFrInz_yUt(cf-!=cd)b9 zIx{vN5I!LG{Xn^)OvywBcdoyayWh^eDw2PCUBJSopSSP-ODlVKgvoPH?Lo`)JGG`A zUUF7=wt>i0m8Y4RnTZM0SN7L@aawuC&mp{Ky)A2}arX7JBW~UY7A4#}B)nDAYhCO2 zvrAY)0=}7EdZe%=pDXK@hUvVXeUq~kSIx1X_jvmPh+i8V?y%GdPW*bO_eC`kcje<}{ti zpat9CP7ScCpXb9=)VEyW*6}|AOiy)~YVJ)dUevwG@4EH<=kt{f-j_4!zMMbDJT_UT zV&zZapI;0^`MOTHFAi`3Uwr1^(8|DGHS^ha`z3#WfA9C1X~cTJ-e1w6_}Li_S?+?z zr%y_2DW9FcNb94-udlDgZ*AP2f8TDc;jj5BZ5OUznqLSyyE<1s{qYZ@M`w;NH#z3; zU*(tl_A2KEhNiz~UaGhtk({1Y#Kv(h{GUeX)Wre!O1Ps~83h;^LFYBjpZV#o%H01e z%3oYi{PgX1e*3>}gZym!_j^9y`QcR5vt#<^#0y+EfAII}_rKrs*)QYxoACJBrKW!R z{)^7PpZe~36DxPyw*JkNgnqp1)s*~}CG+gkQ;%~5 z)Sleqlh^{;N%}#X@t)m@leJs-#i%ch-dFSUMD6#x;*lGZTwm-HssHtIx#!02&Hloj zlX5>-cZB~r@-y%DHr92~NzSQlw@p4A@^Id*(tyt?~ z(w;BiKR^HTgmdEl@>YAlO%0FZER9cpYV%g_#{td57V97DUe-9Mc;NOi%RI*C!T$}< zZ4`K&ue|=+=WkyYhFGR**h@T6Xsc{)=AYNl@SUZoI-g00q49w51Kqf}EB5(*mD*or zop;CL@KmM!v(L@7p1rU3x0GLI=(e25{j+4Y$F}pycK!Ok|Nme8ch!@3JT%<(-9za6 z?Xv8A-sb4-d21E3Tc3dzH?E1?Bj~Jr7*#v{fP0Z|j-$zgK=bY*zPle&Ml( zo^U>vlav2k4KZI5|F|Q1a*i&bshuLHK7N(iN~kz%jm2Nw7Yz)OH|vOI zK{LYSl=oJB4SG7sHNI%cEd$oJ$L1>RZX)TiD}z)|Dkjdo#>{V{aL#1!d@t^ru6s)_ zK0n?szkS{OI|e&qb{0u}l;sPQFM1{jOB@W00vx)HZcl!u^y+WR%ldTW<*U`}`}X|# zbb8`a@9Dcf{=HHtEnoA&v1QwfY~P$YFXBWGT|CP_f6j)^*Ru{bvs=IWt`K))P2}bs z6_#(BQ$Ed~Z?#3*Do0;WUd?BQz>#%6x74fj-&}a$JIiCc*dhL$9Xv3f7ML|YpSmyS z=-1SUQ*Db}yWOh3y^(wz9|``TN~&<>&M3_o@Gzf2c6S zgWY=hCBgLnXU*>)G3H?^eY-LF_>szG-!E!AB~MAd+3}vE>fO%gOjrAZ&YhWS9iDCT z;l2{ov+@Eb9x_WOFmbfZbzo;QXvw;&(6m5z=CZ16R@joQjHH{Tqz3LbQ1-^t0(zdW9x?mw?5D`0_vbNcwFNUuFP^ky_VM-Ql|Fv?&s^K;ZPWhO9C2Hvqo8<^)9R_y^i8@2RwX6s z?{~l7r~OuZx%-p$BXdqmfp5Ksmf{L?9n!0w?ztItTVm~nvvaM>mz2D`G;xxux0}~g zEm6?Xt)gYY`&TZJ*!<+~$0f&h)c$_EeQ6nc^vcV7DvNtJ>X-hrNzN$xE1K7 zc3JKh>HIy4=dAYrf4A+)X125@295@Y1)K%*oI$bnUqHfj*_B1Vw$%F+-52V5kW=yd z*SWdYyi3K5zO-JiReqHJF~8*W^pE$&W?1jasJOI{c|HSY{!C+cRoks4L8Wny;`-g< z-uCVS<`;zzzPr0Sd+Y5mZwctxQ|CZaQgcMtu`q7ukXhXJZtwC7$%&NLy`+e@i_E0WYtM^}pHU-)Q9GIdR zEE2Oleo|AytYf{>*%pWRZwk!zXx1?SHLDc(m}V?E&d5Ezso^xskK38*tF8ydzAL(& zan7^^ccU)JoCw%;X1dstE4`N{HD1iVzi)4w zzRXVJJNZ_;t1hsB`n49E2~Be91~Gh0asm&ogqp7W^z(qP+?IZ|&1wf4|K_nOOkQ@d zA?RD?iKxXVXL5>gtuM>2>FaoZbiQ5fuBP7yC%n0_aq%=|8Fp5b80KTDUzTkiaFt7h zB{n^0e%IpjO*NT%MSeE?X0G3__icSz{kP`lr_4R#_d}$5{+ilN)~IfN|NEpiGq;$| z3PZb)N1PhHmM6dwslb`QYCGXB*K#Jm2Ido?OMa=Zy21R)H~qf<*?&i8FRQ)&ieXcS z`pZSCZ*Jdq?~}>oleg13WfJS7z3!+FZ?d}IoE3`F9B1`nLmnAjQ?_`@%*f#f$}tT~ zSqvPvZ+VqQ(a)#rMyL7C-?Yi3&zf<$ zCiAa&Ylf-l}I<9!W^`UAF1GZySVE~VSpV8%Fa&S#aqrdPwaNORBpm-ESd>ML`_ z&(_m+^S*5QoE$6i{{7`kAxY5UDpEEcVoazpeNSj~79)t&Qw@yb1O_iA3fT4!=DdG?P# zJ1YWv0(A3Mw>@}qaq-!GwZBc4gdRFHKWRlp+>X1u%V$@9ewMj`qh;BpzzL67mZvH( z9OMKwAT~^3P`D z`S_|MHBU0Kv!^(|QT;phQm(?J>T51PEj%6`YF#>U^SoPU;txk;fK%TD&{X1*doB73 z0<#Zz?s{UnO6JCDovZc%vYu1x`;vI_8K0f_@tw)dhp9#_e$SV8ccWu2n;rc5`DpT5 zLnhISJ~z77FIpd?Y4?14u188{exHn`&*fz`OzwNOC>%9IrZ*AuzF6izKaWrD$jdovs@y($bes~Lw!~cm+yGH{0Ghz7 zU_WdtP~h=EBKEu8)z>ROovKP+#UCi^{}az` zp-a}iM{>^&O%7c8C~S%8RGZh`;>B$iQ_gT~$vfL=9pc3=8rlI0F3<@W48kQm0s;(; zXE+K>o*iFNw&2wBYnJDKEe=r+uuZTuI(PfX#kbl)PuYbY>wZ7Z{kc-U%JF4e^wum@ z-ORc7etgtA{IQzppd4*52OU$@M`ng$)3Mhz|cQczUu$K zzpg!-BU8@FOntagX%_2q;V;Ga*c5ghW}0|sv;0-vs4WIumXEaqR-aw5>P^>%pS4`K zLD>(|^*HdJ#p1cu{M6^6-}+bNEjhJ1BQDG?{GY*9x4QQ9g|%}I`ESYp{Oqi>W!0Aq zl{2Y_S~wT^_`h779V3^l@7>>D^z@W0=jR(8Pk)==uUTwb_O7t<%>qkMGUl*lT(h9P zj)Q@LqeI|^lU9sBuS;mdzw@j0MOPNhNQ~=U>A!V~NB8n>nMMEomhI}$a$h>%_v*K` zKe%SNsOrtE;DV{4A)uEd8SdNp&N-aOFIqzq~>CNMJkT+n@?GJ}I@n$Uv{rzP35?%Nz?pSPn} zU>EnwYrgfm?(1WI8o&JW<+|}*J1_eiKBekcRhRE6`l4~}W6vYLMw8yOpr9a=l(m=U zm}E|B+neoq<*iLBx2eobtI}03FESUNHcCFtuV=x`l+Gxi_s8L#%qmAdF|8h+B9QeH zWEg!eOn%(H+mV6gk@^AQ?>#d)=5wB3C9*L7L%K-4;gjq0ALnzGYY04OXnd4tx ztZkg<=BzBb67Fik7G2k{ZLXGmj<9yOnC>AKTj^Q3x3*lIvEcKzX>lR;Vy`_oK^UesIZ@#vpFgbWrif4Vri;1Fp_WnJFyfoFw}hbmYpVrQX>k<^H^Z;G%_rBgKzFxTJ>%ln59Y zm$O(|?=_hB8g$>u`KOJ0rkxMh7CE;}Vc(>;7tSr^TVGsrli&VN!nHM#kAM6!h`X_K z^Qq`9N*nj6^w>N!1|0-h;m9CdqQ7FXFUY(N{SJ0Uk$-O2w{nU4e13NJ?PA58jhDXV z>VI!34rBdjRR6E0@T>x-7F%=(C!eIsw-4ajdkJVZ)>X&~6fFWdOfoWh>$h~zwJM!7 zZHr(2u^!2&=jTHY9kOQG)4T5X#fMw_^pnFhB85G?gJ-*MXMN02~;U= z6Mo=v?vZPulVaZLX$zdP*6;*}emi^opyMA#M)xB3ld~K;g;aeet34`|*?BN8q`1)* zkR&zHQs7vgP zlXE_M8OmB*Ro%AxM49LnP~0d4gBGYKfNFXMjw4DJn)Fskyk1mMe_ptAPvz0_v&XaB zo?rK$rLynB8M{vRK!1iSM_AsS{5H+Goo{9EUa$i+acq#a zT9FGJGYp`kwAnyTWMFxue8GC(>AA7JoVyGcyZ4u|Y5!XtGVSSOlVtPQ{R-!*lj7|1 z@9mj!z2z^{(g)q8ov&RJ)4BhHoZ>K>A?(6dPG@;gx&B5iVA7di_e%{5ck1B6Woxz%=v25A0te?vBvI0*ByZ{x|4QoN|pRLam%t1lE!}&o_ zZ<>g@fYh^9nSJv1an99?+A^AEJ<|RubMo(phle?53HRL=Y1UsQTfpyr{(v_qW;%Qs zgumSADPRSe&@!{Z>)+$Jy&;>nMPBund6V=1-(M*+|LX$20mYF`-%~52RfG&{%H&nE znMAe2OiZ({U2#~l&18KdqYQ}A7MzA_m}F15 z&Rfzw&93%W$E%xKX65f3+ZP0T$WCjG)MIP|#+26dlPerjzmOo9KPh{8;{?1)FPsf6Kh_ z_PEMJ?oj)f`i4VzUprYu`h+1R9~0*Yq_mJZMv^lTvCFfh#&%y6<_ zqt?4Dbaj|o__~-&o36dooM$ip+F9b!#5*^SXI?%c{;ak`&vJ6rmlqS~I9w}V{dWF! zBS>c@ft%6i0%#KyC&-2GgaSO5U)f(@U%vN4W;VB&&V>y*>Ycyd{;~YMv+Y$}X8TkL zuh}nG#=X9#@XDB-n^r9AO{)1<^FHn)YpR>!{o^)bp10dXOVV9to9DlKbLhu9E%)i$ zJKl@M@PhoK@Suf3?S-GlLn%*d7gjInZ(sSN@gwL6B|fqC zNw$nfx3uXVlmkbQ18DK$C!dAjnA;}&V$DN_bMyaum7bepDOFKE@kJ4DqT<rBZqsg0ZpMQSlsXyv`J(>0H&48e;XXoxK zZtQxuhPyx%q|*YlnIk!5hXBZbPL2+#)z$5MvQCWp(!3{!xvAX^X*YarX=xLLUJH)4!^gIf40=qy*seyBs>s;1gP>Ob# z=^%S)y~rR+h%NjtM*%TmagQq&}s97Zfxs^AE5-S@c8v z?XJ?-v$R52vCN;x%)i_}{N}^I#-_QKg+9fwuXwa8<>sc;!dUrh-Js*8W|?L$duW$G z@#Jbn9&kqBP-gVGaQMdS50aqxI;VEQkC|)R_WypRmzH=+b*N`_Xk~S|7unbS*)h}L zpczkB%jSviZfsoacKAdTgIIlI>^GT73vyFeTi!k}zm;CQ?OQoaX7K6`g_v-*i;!ZWN& zSFv$Vjojb1Fg>Hoy$H0*DH z@ytHY&&@SWS$p}(=jYMe^R8~Fp4GO3d)A}IM>o>uEm?d-ZNZOyA)OB5x0PeSt-FIt z4V+aQehJ?LRR|7ySh6nhiXW{GUh^6>NyR0qCGvVxz@IqHy;7Suo0j}6+Vofa<+U(3sgb6QoKOjEO672!<=#I%#!>2 zv_98qS7#mTk(4U)zb;T37;H0XchZs?@r^q!Pf22MpE`5Db;t!SkmeuF3~Dd_ybPCAj zWxi5tAlWl`&5VjiY|mOmzZ~clvtVITcmO(7?XFrM_*m!z_ADWbc6@z({k*+gRnEyX zGap&+G`5-bWMlS8v-OkY{50prZrb;vd=$@KZ<7XI&Z#s$76rA_Fc925e|iJ3c9*yZ?=An zpDOfUcLy^lLZ20p25!;@1$PJ)p|O6 zy4hv%s;)+v-M_3jIQT}?keTa_eLys;|<=P7yI1YV!u#y#+=QErh>E=h=JOD8lbGHFoz{% zk*;#p@Au7_=jK>ODSOu>txnD0xqI}|+jsZ&-aa#bebJuSTOsi;OtY`~9PTqxx#i_7 zF$-jh04QU%FP#2R85B-)d>vAo=FOVLb?qgKTd&m8gH7k>-bpryg9YHOdYwN<9I z$aS6geRtMGZgx9-y-;eATvpe6wun6uHP837SCq`wi`cN><*m?EW8UWl+6%I6uYhU= zg&ClciM0KPv_bXgiM|G}DNp0}Ry9^xF)qDY92V}q=3U_PPWPhcoBy}-%YQo|`+HVs zjO+VkdEN-{bih5~11xuc+cmI)-J;fb=*o%hSB2(+JP&Vd3;PzXo(Etuc-H+EOa z#R*%(iVrriN^M)+ktHG3uJ+!&|48B9#op=Xcy75dyXUEw2riG-4qq4J^!?Zl&gd+Y z6;8q|4hkPY-l`El>=zzK(&Df3cFm$-i3t?l76zkAPq)phU9&COeH z1$wVpm%70@_TzHN&1q+gZkXsLGihpSMk!QfaXO2GV!FwTLHNspZ#sXNKx4j}IScY0 zDP2m~Rr*>@H*@Q~7Z|Z2Tu>R{Czuq^-V(L&8m-pP#?}qMyL|`RN5w3mJV1)tlRP z&dU-zc(X*40eUWgUd)Xx85f-nvz?Qe7!OO;A)q$p*7S$q@_vr*g0&`7WGstjY%%#5 z`}tDZu4UV+zGiJsYCTmGtg5poJ7H6P2lLUl6SlQpUc1mj{ldy%_2=Tp%T>?qKXRNq zyqSTcWe(`D0(pi4c@_r+6P8yKmX|Kw3))Pn8MS4_mNi?ejML6s*c6)@8F%^yOG)Ub zh3X0J8To-d%8kYb3uQwKWLO*&1es#{Y+ zPFOfB(mEt{Ol^gw>cQWe_V7-;^H}-Ts!;9VMJ}B`@`}nzrPHTB1l<@Zz`&>mYSS@- z5>!ib!>OO2`(&-#n&&y|Pu&)JzWBzTv(r1*FUY^U>*|{L{rA$;*4xiz3&*fA3V47vDs&bejs<0r1mVVgDLHzX&C%PRt;yApWLf4Tcz@|! zMcKBD^f|)0-Cr_hnd|e+=6|w6Gc6^c+d=)g?G#WFJRr|v;P~C${s0#!{x7Ip@N?c1 zzrRju)3q$WITnG3zbUJ%niLUx_=bwmZ`AYi$6Gr-g=EHm ze}6yUz_Y(UD=RCj#@u56uFapl3&FK$%X9{{7Z2Z7SMV_@2=Fo4n%p_^>gUT4b>CS_ z8fTiOXL9}yD4*Eo>#9ncI8m-5G|?e=>G&>D+fY`{JV3Hs7zFTbkMo zz>Ova4^UYVlz&JZ6tos|52${*Z*?iaqN=))iFHZp+H14Ta%Z*uwb|U0!SOpHxJI=0 zqEex!{Nu@ny1Kf)ZZC2~r#4KDI_3nQUUPg@=z$-~IgD+-yEMn;AP?758k;y}d0euKco4n;s~!vViJg$CsWzz_nqz z@QYQ9u7({`+IGI0_4wGzqlL5A>HUJvgU%ysx#y z=lt|<(%LUR3WwU9x@1+CT>$P&wX}m``ek+n7n6d39+Ot!JkVURUYFsXyZdT)U;A17 zan1v=(mOJl(W2#+96aH5FU>Ii67p$Vrlj^7YyXJzpq09BZg2OGGP_Xq^Ye3auZwpo-`5;;INV$e%7GJD zK*OF5?a`p>@4#}FA8#z@e-+W4YgH;TV1qTm;M~*!}_w4;Up>2ce zEbSBLY%guoi{9oFW%Qw{_ScHDi=$cO-|Dcnvoz!P)g+mx*H1r{KBa9T zIBzm;2Th8a6>eb%b`%*0^D9EQ%NEMWjr45r>ru`M(+M;`Du6FM0Pft%T zRdrr?eQS0&ul?ys8M)B@Uc+0^2-RNpM0;>-`#lKaRp8(&H@j+Ce5AQI-K1%0T=J2J zdAGKlTobj`>+xH`jI-NvuU?v#ENXi}nf+WN1BVKz)^j=e&<>QNKBzNJ&A)u(UR_yw zzofBSGRudbpZ`i7nwEL)+6M8}FFpppy}CO5kGbXU#Y;DzhV-LbKqvY=e3f6p&7>fZ z!{mCx_M^;U&JtYU76ZqAW-&eRz{`AL z0sG65t3os{@BRIMd-*%ZF!6A?{3mN)EYf(O&0`={P@8g;eF2ZgCk_swLywGSNKB5} zsxq~=QERhia9*Tp>Yu|?HkLik;|NVCkr%t^%F4o0X?%d;ur-IqgWrrCpMq`_zvJV0 zeBe&?^7HTi?W&)@?$xiedoSA^6cyD=C=Co)p5Dl!oZ>+V8qDuWr92ZZAAt~jvC(u z{eL2!NuS^~ujv0-JA1~Cd*|j_-+gs;weGLjG)1Wm%f2tZHih;1LhSw7;l#isutCM4A7<~6CHKjK_nAd0Hs80D ztUP&SUDQik%~|Q!y%odX?ha17(5-xHfBpYQd29abZRRQYTJFmY()Uu?p<&)W!-Gm7 zPOH!h9rKvL7rtM&UVreXiCb^Q`p9Q>_O-iCx@>=E|KFt8;B|S0<6mE{?2UdWp#3b-pI^;=g!VwwH!+Wn3&o5biPchxiw$0H{#hm ze$87B3`{c>92(|zCLZ(Ta8M{>Qu}|WPsY-yD5rI|dGfKIL;0uP_g(*#J#A;0Rr9~r z{Pp2$KkeIkcYEi`E5>&|C2gy-o2p>Q#U#*hK$AmY!RHDG1||WH*$&=@_kTwolC>@? ziQPRZX6LuX8!I;6G%MWP`!>=3p5^Q7zrH2j+f%tu)p+6ZnRm|Hevjdf&)+EED$FF% z;LyRsalu)}G^dS$Md5>KW3+ApkF3=dC$oyPGmX=uek^!iTc4vS)4A+>#w?$AN9`ru z-1Xx$#Y(mAX}tp{B7R1uFBQjx{1q4)bA*1ZYrWm(9jSZ9*CqJ-{PhtJYrVJJI``)1 zO7{!D7kEP_wJvcpVzu=x#VRbbhr1>@x1%{Kt~CJ(xTqZ zCqmcPMw@fTpH-^oP6kD~LV{}p!`&{3p>H^6KV4x+g$l~?U}pv z+SkdooBye`ZjIPkl$vOM;g>|Cob8w0j_;TDYHT`l*E)S|Zx%?ALw2`Cu z4t7u!`LJ+YNS5-gX=Gs8+351Gs}*eBsqRxXUi|&<``Je?+8Q$px`PtT6~_jKxyPA6VO7E6)^+l1 z?d;mmXU%_4>v77zx2H0!Zieidywrlu(!KAU<2O2q8wPYKUf5Zj9v&7Jc4qC@yUCl% z_U-fgX$$hw76AnZ|I;1`>>$n`&M)WoXa3Xe{Wj%UzJpivzK?B@GPz|Ns=NZtuB_S0 zE4rfg|MU6v?=14xR;+4fA#xE7Q3RVs?UG7a9d}7`H;QPQBnWU%{!&1E_B;<0u(hKwv0?)uJ8-8 zfjAb84RUMC_T{T>zgsr@>PF9fzP=&(-{0Lm_hL`Z=F-odOkUeIH($ETc0X1xcGs2d zDQREYc#ThnuKaVOecsIF9PWw?jkj1hE>x;1FfekoxE@e34xVpUduY*w30t|v^|rh^ z`MWMl+c|jI>%ZN+Mmxpr4^`cnby4S+!^T%@9_c=YM3qp6(7Klqe4s*qGD}rt#oxW} zE8|V`6Vo2eGEO_Q;nn3g38mW2!HZu1wfXY&^z_}%?R-0z`OaQ;T$NTH)gxnU0E^JHJ~D3f;}VCmp_pgg+S4`lCwmFIqysE5!352kI&iP z|Gld6e%dsb^BI-9*<{~OJF@VDwW;NVx`R!u>&o*d-|2oRy#9Fe?7UBPj~-u?%eQyE zF0~~4YD4YjkiU=8g3q46Xnfp}!$BbrR8jTo-*aSON)*aaO^a9h>a((H&aI29Jx`?^ z{@inTNqq9wv>#?xNxe_s9<`U874v>W$ol9nC1P_K_U>?ed2es^JMMko?|GX%Pn;RC zdaJ+g>he>s%a^<=-W2mnYh~K$gf8V{v7mVO^KD?5tIh)Q$|n|+7yq_h>CRdwe&TD; zO851h@Aj$~to+Rwu_>kV>g2>pV)stnnDSCis9MbP>nxWZpLe{{PxsaS-qk6rZsv33 z{N1&#Zm*{XyA$Hh`P929P|eEA&uy}NuR=N?mq z>z`}Ceyz-O433L?2b#qaD-KFMz9sYWnm2~vLUhW@S8G;WXV|-Hl~$@=TdLpxe}69v zEx6A5F8|5di>9Tqz6<`j?_9^0|V`TDw8>-n2zUVL?Z zeZ0oLGEwKP|AJl_tur=%!lv0M74ENj2GVAS6f~F zcI)-FXW8b4KQdQFXW8wxZhyw`&541jP)Na{zc}V27n8sTe+TAI^4D3OfZvdbrk zxybj0SWM=nC7qA|eBRZ5_Crq2U3=e52}WOrW$yWvx}Tpmnb_ zpMFa%!QMcYNuZ;Ffw79Exr1Avp+S<-_R^d0L8Wc3=_mgCu3~#K_e_;fz>Y7@XJ?M!{fIal`WfEaI9pnfBE{DOe4ejGZQ;gcAxocl<+Hub#t1%F~3BglY%n~ z#|2}P8#}ldIi9#Wq@Vil`RaDibFbQftjM@>wreX2A0KOsoHJ)<)thOKKUZhGGq`Ye z(UYY6e$sO*-`_rS<(2D}`gs5AGxWZmymIK60f&P^78A>hKz{vmjtoq!0v9BOV>hic ze)?bMYc%T}>6FX;cE2<{cCYQdw>^J;_21ITmuFb?-@N~z(tr2Ahwbva-roLtetr;7 z<6P^n9G_O4iumZZf63L!<{F@6E(B_HNn}|yF|Y)AJxJW>Z9e~1Pp4Y#X`h>0Jh#UL zWeFSD{J--i;VVzyqLXbOEsLL}2rQMK9=$E+rMpI~)~>UeD?{$ya%p5>QJBEN*ca)| zVm#M@fk{)jVCId*-q+txyJeNSO*QS@JlpC!2baHydTrd&$8+BPx_+ZZ9mk8n z(%Vbo-nhT}AG&I_>3^A}5=?WgTqn+2tattV1oN+3`ixdut@Z<%pWxLXSrWXb!x?0} zLC~9-TBW^L+Lxr6SzIs7ys|>@V5Kboii`h>&;B|8^Ld@UKuOx=?1^i6tM_oFd93lB zZT9ZdY5o42j}0H)Su#WRh&hLYf-DQih0BI~5sZu+H-vVCKQVQ@?j6K_qfE4~s+~{v zkfE8Pcd6^aFE7=E?_L%vQuMy7^ZD(XIjwaOCSSR2yaZX=_~qk{#5&$BnjY~xDL^b) zhebg^hLP#ZgEpRKMTSNuju*4M=YIS#`N}7zcc)!0zh1xJPPk6&(UT@t?mH8e-MMzE z-ruH{`S9~wn@eT)zJHOotNF1;(YftUP(`J`llV)CIS;Ni^V_|cWu7m$d-eA2=Kf>v zRQ@?KFfCPfXo$1=_Js%J?hBEhLxW0>H3zXbCLV4(xKylB()f(f+Wl-f?^(3=YIlJK z63$KTuB&^q`9gnWaDP+9b2S-)%W)n%GGRn73e*vq!R&;QLgv%Q`@w?6WEw8{EOQmIiz z%yH@-eUiq$HsQ0>2Me8`={e9qG)wvLcW-fa6hE zt=~UW4sSytCIOBv2F9v@!>trm~)lDXeq3Qv`MeRXxgSBHczFD~Z&{`U6W%jNUSL`6k6s!jMU?pV5zJ;no6JgdE&I{nulMxBge&Y|Fj93v^7y-TME3JHJT>rT_i?y}XETTmIzjT?y{@ z7rl^GULefdzNBhyfrNS9oXdN!i2P?MdvoLA7mLH7z0H+>|9n0_cTG}3)zz}9*xhAo zZ*R+;eS1S$i&EzGS^}98s-D_91aQ|OjR|v>b?K^O}M6>@ul>7 z>~pssiHCA^KN7DmYJJDDU{240H#axyKA4e{wcWrZz}I$r&BiNoc5mbN*X{MU+|s99 z@UZo$zuEh{yUoQ{=tpnUDPOy4)v2==PXGMsw@r1*q|NIdT-yKj<5H8ReToc?790W# zjvMw>FgEH4N~oOs=ebI*RV3H)agTA#^K)}!e}8*h+_-h$wd~blYy0-*-Q4ul{GR=< z>b=vZPk&zLzjA&9+w*q5mo96*Cv9T6y?bgR_d1c!d)ZzTKRd%Y+hfVK*UuxT>%|sr zEnB&6UD@N~{pG>S{Yqb7i&Xi(Ui?)A)0ZmAi=f77GlTb?&kZiZ91aSmENoq>fpgUF zF7Xt;zA{+7{Nqva=j&vxN>0R{K6R?7ai^Z=aus)n^Lce|HXhfp(hZR)U)$xB%fi|mq?)bQ;WYNsKnxI0wOHJU8 z{Vvz)Q@sKW4kuXhgdfLGTGjb5DE`-%myg%&{T5}OaDZWX^?~y?pU+&mJ*SkpboYUO ze}C5|Ux>Ub|4Ynuy&seOiQRG2=Vk;Qb(gOdxg#j>B#`o4| zn?u`kciq3CU~zq(7+afCO7Zm{d>5Xdn=5U^pJU(WFxxEm4!8cE3BMneyt%P4?5En6 zkSr6=ip8x674#cXl55^YgRr9mCnvwi}o+`A&Ac@_DP~ zM?neGtSP(y|NFgG=JFpu<+VpZ9qUKx4h?euB_1oXIH?#!_5AbHkZ@hHV&u_Q$%P%kYFSjcGc7U1RVy@%zBi;!Q zoi^L#qXn@ zZzWco>u?<8AeD>1cIy0$Gj;p@}Lz`~^D&>(jqAyJD(Nqxa)-sDMN zK6YuZD=M|>L?Y~Ou6YR%E&@<4vFN!gbd7kAFwxUcrN+D+Zsr5y(*sd}$j^KqZ}ty33H zl-P^bPy6|8<*HSuwyRWWDqUFU%nr(c+}-cYAcRMD zUdzU(PoKW~dOg1UyiM>Xn-b3*p7NCf7oHzj@Z#TRQ?^|m&)g6EzE{6ESKw!*^J*84 z9*M+hC4X1B$SeSrW?G=;A+P#52Zacxsx`AJD_<;Zzq70K^&QY1-}l62m&|uaOA^itu2v*F>Ixj!fS+r6Au`z`YN63@vc6}_UWstY_B?f-^^yHx9|Wj@>+ExCTd zcb|9d{PJaI79Ib6U`6`!`E|RlmMuRrdEPPGpbGZJ903J~^T#Y6tFm13d9eK2G24GX z9_PKevGLm71@Z!oOTDK@MeaV}C2@BT$C>G2@lUR9YH({i@68x?;mV|jym}*zRJK_j zP7F*Fg%uq7YZ?mqnKacuFmF6>a`~;WzsDv^-Z|7B~vW+)xYA&K99tX zxvhCwD|XjlVZxEa0@Jc%ca>~3_))|iXrjo_xPwz*!ExJt73_^$gnvw2+Bj?F-;3_@ zTi-CfW#D{K_b76+PuQaB^9phb_e^HIvF)~-dFQghnr&t=RWFx{$(C#YkHB@zW?-zk z^SHZQz{9w)`{<6@Yj{965zf4|_5s_v-?y^YN2>lc^5mAcco#I|y>0iuW4+RMkIUD` zaK*ncR%CKBe(}8HC(BFDUd6i(3SvwwFE;k5)Hx{FFny1jd1qH?wt3y33hl}gW_5$g zPbu2`V$qz7qXimovTi-M`Qswj?oTMpCqd_lw{knB!`uqPBt&^Ivc2Q*Ng6@=uEcYfwmx*Joc}C#F_=+)2cj!$BdAX^y$b`x}oWK~ZOA_^yhZ*}X^NpJFv$J`J+j#R%Pt)D`+WP&TD2Ht&=pVOzpl7w$Ff+JzIrlEKmOhA75P8KT=M>mZ?j5mg+J^jH|I`|@?lV@Urluxe+!MP>j@z;99mjmD#gbp1 z2`)OM%HeQe0t4eN#h4|E42_e8c3f^cTl@X)^Qy0}K+ZqJvMu-av#|AXbGZ*(UlaNG z%htH^H#Z)BdwYBO2Gh#Y?_P0hGp2|%R$jWOZ(DwCU*KXltG!i6Cn~$YoBY~;N!j;1 z>_w_72_<4y#xGQ5f_Jqc#$+9Cu&fjLtiP$?;Y4@2jT2licO1C3)-&+jHUnGmY716wN{TG&7TQZXqU5p{Ax&oA{t+!RMHEt0yIC-e}yzO_3 z#ZNmkpGvgE&ae5@8NIV8HSbyU`uBUk$G!XY@ArG_zp*M$uX_CHIN7`QQO`A_^M1X; zwrgiyN$6&IRkh@{*h+uzyE=@&pBG)NeUo~dfi=fzv&(l4Iw*>gGdbd>)Oo5>Ba-{W(p?TUM) zwlaHZR#D5y)V^}t+0-9M_g&< zt~gVT^92_b&Q#xe&hz=p%U@1{(yxLI_;u$h{=YpdYWL6IpN_e${B5E@3yjipZn?R>7?Do=PZvO%1yhV zyJ8V%V+W_e0(YAoJJ=eh2<VjAU6G$X~y-{VZ4v*Pfc%Q`4;aH{q^UPI&XpXzZdqi zeW+Krm*;&Dee%3j@cQ*v-6pSmQd6rLy8E)<Y9&yOqt3T zTzNk2YWcW#bl-v57p*SU6!#bg)W*i%{jZpWstudhGfv^02+;0;AD<2@@CpUiGh zbGVRjO~r6&ezO0f<(!X8t_H?x_nQ=4XDQv~^UrvtRq$%YistpEjWxNlv1RLTTlVdZ z4-32I)pTof^!B{FPwo_--}_?E=X2S*n=hoFdcAp;S?;ZEk(<-rJvi8`*Ron=Q%&}z zC7#Ad?e8;M8NcBCyYT`qOOoP*ld3)&dF1LG6daiRJI~H(6?5 zeFR>+ExqN`(>=FgT}emQQpY#UZS?{gri_!%nk_Bs`lrayctz+!&k+%hBTf&VM#yyD z;1~MgYO|wp$FkL-KkKb096aR1v80hfULsS1HK)O$j3a|diHjvkp}=L%45?=2iN6=j zyrT&+(AKP<2{gK^&&2YgGI5b0i^7A>hBU5a4hn2c|26$y%)CCOL^wk2nXK3L&WP!Z zOmCdeA5eI##8M-u;PBm5NS4DvL7r*WhYqGj363*;2RnIwe3<%U#mt?W0vf7}X&1ab z=kHS#kYHr`a)6DeSW&=&G3^4gyu%rLw+HqKf;^2&4@Pt?+$fa5W_xYoQGE^x0R;#1 zhAtHrg#dNNxsD&|*sRtl1~4&kFY&jXKTC+M@sz=tBd0nzKU4~SeDFw$rAAo6;k&Ph zEr-K{6qXsb&u@0L9;iS1$iwZAg2VX}4$H5c&vNeb zf<_jWOAZNXQauOS_HeG5IBoZ*JYQ#yAF2nQx5m#~;iyo>#PZ@IzagKKf+@=kNB^?{ z2_DQGXQoz%n?9(^)8%bcUHWoboZ - -#include "../dat.h" -#include "samply.h" - -struct Image samply_sprites[] = { -}; diff --git a/samply/readme b/samply/readme deleted file mode 100644 index 955a251..0000000 --- a/samply/readme +++ /dev/null @@ -1,3 +0,0 @@ -theyre very hasty - -h/t zyre for drawing these diff --git a/samply/samply.h b/samply/samply.h deleted file mode 100644 index c11d761..0000000 --- a/samply/samply.h +++ /dev/null @@ -1,6 +0,0 @@ -typedef struct Samply Samply; - -struct Samply { -}; - -extern Image samply_sprites[]; diff --git a/samply/walk1.png b/samply/walk1.png deleted file mode 100644 index 41b0f9bba2caafe5bbbf83bb977310ee5b1408d6..0000000000000000000000000000000000000000 GIT binary patch literal 0 HcmV?d00001 literal 72585 zcmeAS@N?(olHy`uVBq!ia0y~yV15C@9Bd2>48Du6JYis9;4JWnEM{QPQwCwiilz2t z3=9eko-U3d6>)Fwa{dqvy=(Eo(czBx5#AU9)}yfwF$Z){+in;69usu=(xde=mhD^m zblQwr-jNxR%a*N-+&P_l<%$JQCUyO8tyaTf(5`aHE)Tgh@~OkBS5Fs{*sqA%_HJCp z9TVqXXji-OpHD`8%4K&&wD1o|YMfub!D9ZtfO@+lR!VQyt(g9!Wr7uoDwDW`h$D|` zemVW^75H9%$S(bH`x1B5)_s6o-`<6rOk z_vD4^_jqMyuS3lW4w)?TvJ)EZ)<*2t`(nAk#7RgM)wi9j-!hyE?f!~>oh;PvUx8*l zS7Y_8m<7*|{z^`~zg#40k_xJ3P8K%N1s3!FWmVPP{(Xz{n5GJf2L&{?99Yj4w!mNe znm>PKsrHsRPtaWF(zu-~YJvamw|BGN3#vzJpjfZ5>;NOH-nr%b-~OF7;kngOl_{dA z#=qF%5ck6`ooTFL(C9mGNmcvY^1qJ{Rx7^$vo)t!ygf(_wF9-F zuCduWYJtD@mHT`@<%Pffe5HP25^B0JiGR>GN&LlSuCL{XEc$Znmh+(b<1N$YZ61Yo ze~mxuw-~++w{8_fv!jw}_f~K;$jcwwR{1&Os}E{VZk70tQf{yf_AQ3rR?a&z5zT;) zOy{>cHrlNXuwVLdPZe4`Y!;We;db=r7Nx)M44&zqop($SO?M&Fe|^`+eGi(r{q`qB z2mb%;f9S^Z9GR{2ApU6V<0^TV!SEKGwj3H+_lXz1mbTuXKCdz@>%{JNyR^$*%=mbX z^I#d*@70O*DrpHDA^Ko}?XZ?0-r-K%=NNc`1$*4eSQf4wn4byCKR18X;Oe|fw8eqGtupY{L#P4d=T`Q_#1l#xTj{V)qxD{flpX;xWuXNzER57nI8i z=N*?e&x<+BT6OQi#^Z9Ub2gtfbJf4{o-;Yd{O6e$sA=MsSAs_uQ|+fGCrd?NT$YM0 zzgs%>YIywK7p=egZ@uy{j6gMC>%-O?tiQBYuer4FQO&Po;xPq|7voQx>HWx^Rno?y zjv6ci7B*##^VXk{EB^gtvcFdPoIqUn)yt)) z>VCfszoPW_S;9uANs_`-P_#q^Jy>{y_1BG!$NT-(^U zK8Z{YK*ee?TT3OUrpk?WbHE+l+4vQP3Xk>Pj0$d zpVN=b-s(HYV&kUg^Qzrs{Z;0(JI^^A_3DhF1WG(~s2PMWdGy(ywQyfSwBR;xy`4)g zt&iWYB=+jL%WT_5)bx|eGOZ(af&RW9k6c%rU;fM>_0*J82ifIgjwt<|`Cy;>={c@! zPAD-UD;8l>)_8As`TIj6FD?u1d^RgvYxSBVXA#`Vc}AZ3!hcq@BM!7)Uw%mQAeEq&N9%~-uiWB<_Bb#XBao?AJMyD zek)_~C6GsDO|wE$*X?|!6}9kR=jxZa-!e^NK*7GkGof!*Uzq{eE{%N$j&BT}Q~hpd za=VXQ{{O$<&#U>&n7}J-rc)VjT5>^CX7+yLzg-)?uUR+v-_F7x#N{?kjRMQQE+@u++A{J(F~Be&<> zO%g6uxz}*vN8g6|lHWc#m%BJcgM6P+&G_H_#<%4R3`{H>Tjn%qzt}wEQZt{G2DkR! z^ys{usTbA$-Bw(fet2K>MWM<3;6Tcl(!jJg@X{|(tEbV8b4Qb%^vlrjSkv9_cD>#d z>~CxO`qtL$#m|<`s+-2g9xL?i_2GSCro1xFAUCo^c{()S^V*!L1M_n3rc(+CQP`pIZ;0F$de~7U|W;8H7+D~ce#T& zXT^RPlra^bH4T3=p|!jGT4Z|a^!U2UZ6}nvMRd20%mEEg+{$`@P+{thE>;GFRtK@Er>iBnh!+p_jvXj55Sb$xd zF{y!Rujhwd;8;#!l0VXSXVv)y=TBsAJSukDtygMlY}w7!$p8QTCI=tu*q+BxlzJnd zMg}vzF`umk$oQOk7{0w#ayce4Hv!v7g6tn&NT2*j*{h=axm49p*Jp zdA)XfTww4$6_sztH^fVS>+OQ;HD%)Zk~IYqVW~nL`#kPM=kE<&_R;-(>F2ZN^M6@w zTikDFRrRKWaXZ(>Jnr916XQ*jVirOyKFlKWf_L#XL6ECWJV0^u{eHjPCP$IN-IgDZ z2yec)*j@Z*R+Zg@*u(zMS=*F1BHWVev#+nac~X7;oV(TU_uk~QeiLv)#(we@@k90dmEYKNR&O^_(E;~K zGGrN9t6ra3IuVqs4*cibBPacM<8ire*-dL7@yb{j?0&Us^`?T`)nfOwKBnH;Jp`Ze9Iy?XTX%7^IY0S6-k+^V&m3P3|Rf0R7&#Tt5e!C@DlItt` z;h!4Bf^Kt}AxQ{leq2SFg5iPmgM@HJbBK}CUAV* z=88~Rm%IGl0Zsvh3!j+IAD4S5>~AAzy`;ie;6}k=-p$(U_ZaQ|`|bATn!ue*`Sv_J zV}-v><(jkj3Ml<7aAD&5BIG+Q1mxHSYK_aYtaf!Z&#!*BQ>(AYL#J_}bGu)y?(MJF zBxa1V9WdlroDfk-RS_?ugCOL_g$cQ_=UwqVX`^h zy4z0V?R+}z&7y9-Q&r#IM3(Mmle36_@%nkHpOrY?cw!i=1lF5FjtjhJCWS{)bXT#t6m)kexk}1e`Pyzyl8JGHo$`cx| zoRaVEDt-OnQ~IpqLNhE1lb-Ir|2OZ-&)%ASGQm6iTUtO~h9!XuDveK-#bbiI9kq8J z*V_2_2KJ@Nh_4{0p!j+RPnELJiRiw7dmT3e{tV_4hXP@$rSp|}@*EB@mk$%0_ z9OTrDH3uGR?%Mr&-R__kQR9gY_xIIqUcGLY*6uHtyf=%6MJNX9o3_T<%ghyj`BPTT z45UTjgFGYauE~v{D2<9tD3Z8ycq4no>$TgD@oB~}vy|N}y`J;t#>SiTs>PD_Zrgci zLcQ3x_?FszY&`MekdS3$t>RSk>;iEvC^jCqx>Ci~`+n#1c{db~W=}Y9h+BV7Y{^B} zn@7dt=X`y2b+zN(bDL%}AG&`}{F`t0gdQ1C0$H$=iR;U=U$5taTycr}j@a&Q@%S3U z>PMX~@(a4>F00rqaHID7-OcIqD%Ec1@BiENV2Zx^|LYt6`wLE*$P7xACjJhM_iUfy!*)*r#hT9v%_s~aelpA|eY|6}j2UTJf^ESrO~v^V^C)SZ4kzP`5Xm}I(%`NaQk zZR;)mb#18M&vEhuILxKg7dYh4f%N1TR5EQp^6uBe_Qm>q^46{&UkOOq)l^K=XWH@a z*U#A(X6=&|H~LX~dGiENFmagpI5gff$dUzTXkk{lj=SHZ^Y>2Gyp+6JO!?k}gUy?* z-|sQD{`F#U_k;_6ik;qF6FR`5t+2O&$#(BXIdI7TWV*P1!E@)J1?Kfh!D$7LI@Qy{ z<0@0P9TDb5WD-F}~*UwocfCiDx`hi%-##Pwy%zD3}8Dr8xt zzx&^nV1Lo{5+hHw4R?x8r(Tb%&i(c_zur1hK9nU+L#8-E^tfdU$irSb3mo)6KJf%6 zk}RQ$70VW{wzwhsMQcLTiwVZ(ZH%q||M|T6++1t(?2y}LtCRnN3+rSSE7N7td%>kv z<1+3XDWf0RXLNRzyqr|~;UN22of}D|PMg9NZ_h;K_aGLl(=rKNb z;+*aGJ394u7CPR3&HKvT9BdVGs`eGGuqr#RzyD9sn+cDm`aF=n|HG~9|KIQF+3WX~ zy*eY$D_b*Tm+(h$tX6_@;?37HK_M=s|H0vno_v+YuSXv?28*m`WCHb7&C1@~$T`v> zs9D{;>qO!ym!sfz%`X;_7hiW~x`J}SQ;`bAvRmu-2>spo?S^L8b%(}@%I<05v8AEl zWcA|fcFm?PaDF=~7_dM*T`vXPOMc1vuK%vIT8+9&pD?e*C5 zUdt|T=M5VTnY+MN92E{&AfE4+0uIWTET7nqX>UAS&1btUUH~`5yi^xB=wB`IoCXRhB@UPPvb)7E z1k;wbI_GS?8g}z;`Te=Md%s>Y?Je4RHS9E~QU;9{MeCUCS+eXHq%9c4rE$UAGItU< z0Qopi$&dO$7Rc7z#Wig zcK&%~Z^RyI{qod3mSh2n_YabdelDQA+TbvoQ%3yQ@4qvW?^VCwyO~>mk3pKp#;BMF zpsLTUUv94Lw;Rbft>5pN-1_{?X1m&7Db8&?CqcDaWN+PJzqwX-?>(|UC`+$|O2*l~0(%VZT- zkd6+m2a;b_%xN->NSIu(`ga-cyWnz=OD`xevQ{-OCkw_)zOtx%9Q!;8DE=iA-Ey z+5%sLwQ?za$UE`)?Twv#emv^l=-lO=5XR)*u2ie&0y67D6cg8%YqR_pgI)WIWl_BA ze3Q(eQd{dT2bsp7PBWYzw+OX@;*^PG)5<682bXN0I5aMtHV!uecR4FS#p?cFuU3EDB;4sx%5=Kz@TcqRz^$7Ft}G%i zbd4sqfyWI@Irqd}z8ETFb6n=1{#Guv_9NmFg6kIP3)`>h0K1ikalhKEh3mlG?u=~* zyf+HJxVbs~&4fpSE8G?oTfBIa#aF@usscsg9U9~QSWW`ZWgHRTpkFt}O~#MP3}8D?Jm;v1)wn{9=1jtGrQ)$1|=f9pA!NA}8W^o8`~V zH3gSHO&l5*xQzraf%eXWUA%}d^>7&>GOq!&YN%N@87GexJ6YUIAOcrT&ur&X%66V=mmvL>lT=wi}D9~ zH$bP++}WzVOl4{1^SS2MzjIy}mmUeY{etO!w_KnDC_QD&Xkgl#c*P3T(`#hnijgb& zm1bLc*7&^5P0{d}iEDR0oAuS?dYgk*vzA~H8pUtTPybz zGp3`09Iln1rrV5%mcL(C{_*_rdD8~|moM5~szKiI&`y}R16Cngvi|CqFnn|(by{TF zd&_4tl3!_GVdImT(fU8`+{F{SQd#+|UMzU?-2Q*1?&H(>_40Av%*VmC++!Az7rmRW z34@$7#YG`TI#zYbul`9(w9lG}{CLpJziI8ZTUxunUW45B5 zBE}JZ{yTSV&iq~SA33jR7o5^uo^m~=*mv*QJ8o$Ppyy$%1>-8zh7JaY8J=;U)T31^?u4$yr7@VDh!_Xvr>D&RdxK& z7I5KsO~}Hv@LrVgt*pgApX%33ZnijIsmJkKZSAuZ8_*!a>ISC0YmC+NK_S|qC9rN@ zz9`c>3DXq`EK1xl<#$UbD*N%4`*kfy0*BUHCay2H&Tavx=W8Msi%i>7L)NN%_`d(Y z?a_j;uqDeAL?<&aGHvCqVB1?}tP3hm7aV0dboF!cp$Tj5+)Mg=E9>yj@B9DHEq!~- z^y!9AyFJ$V-)y`A3Pgi!M%G=%;P%R`C994@|ro7t~o=LJ$4( zd}s)&eHz6;fz$1`CJ~%_t}^{x`?l-zs+}@7bQ(dUMYdI6JZ}E=Qruzf8N}7?+rZFx zlSAXeTqTf27q&4yeDzZ(@dNu--G;{LehFtyulvmXT<*;Ndf7Xd8c;yY*x0~ycP6-$ zd8;#Ff7n`YYi5b+oh;jKBz3!~)Z{2zT?7wr)x;ezesPWqq$R_hQyDzxt0~p zdTS57UcZ0d*Ectfe}6d4AKah#{K7%emDYmuL22h-v_s>&9&jLT6X9U}_5SdI@~qPb zw_jMG?mKIW?awEZZ$3FWd9%OW&y-j5KcBa+zqUR9e$LLP)3O&%{C7W~&-&etH$NWt z``d0ST-baNW~#`GbD#t!kWt(iFz5Ny=zT@I*Savt*L-mNwtfHK+*ftK-)>L$xB2Mu z?bB)f^Cc|B=WWZct&iWIbC}os%(gp4r*jtfnw@$!Gku;=Z^g5fdAnXNyQ#bV&ZH_G z_7=W#{&zcnfI<)44q)NfGTmXl!JV3|-~Py+KVSO#+S|jfVv$RX5)L$ghw*oQJSOdY zHcxxefhn57THEu6xuJl7T+ zk14t6x^nKPbdG2Fli%|k295E616{#Eq47YL;$zz6+p-l88mE4Ie0+Le)&1Ji# zt7d;6)05((XE&YJi=M@__Dtu!!sD`2H(aVZ^=Q+&8*{BnSIsFprMYxr?t!)Mj=TKn z;R3e{Aue%{=FpKk_M@tY$+o}nT4egvWe(cOi+(EQf(D*rSxeSf&WoLMu$evlkoH}# zgS*d~-CnY#W)tr|d!C7)lnu)84GfJPO!jkQ4~Cw;&o67WMWi)Sa`Kt*jPD)4zx}@-S6Wjh{n-6xllQ}w z{8ld(s3iaYvbofqyS`pR3L5Z`w&*&azy zey6xqwf@h?b$|R#^nipC*sCrgJ5)m*i~j%pK7B2pUdq1kxXRR1i#9&o2%1Pb zWqjTy*yDBiy~^dAPAGLRF?lKaaWksLDjWP)J+kTly}thM>Itq9GbdF&ndq+7t-CGa zRMSSyjqH3f5kFrn?&q=;1&w`sO@65RR_5}Mg}2r6DyG+n z&3l}G^W(jm&u4Gi{eBaC;^W)h@As|z^h%tmUNy9!5Y)v1g*2$nSnd$_Q+21;jm7T$ zr=Fag%w1i&MW=J^jz?Xd&(yE(xi0;Ef-|4yoheVwFDid|NpyDmt%YC2r!ey~m`oQ{w-9 znjZXgbLy%CkAxH)7R0iOym)K%`534wDdMg%4*fMde_!Rczu#^z=ei$Oc)$Mt-?rZJ zR?)B%+ivIW&bhF_k@t16o2>6FlgzA%aZ7Ta&n@?x>i5s?%iSPW@#*0718xO1KH`4j z9jv}PxBSbCi>O-A;mU+vv;MdFL;q&T#z5Jh4_2=VpZP2Vq>OodJa0iN1JP8riC~>eRe5`gI?>LtG!$ zKLYipj8jjAKeYe-X0tYElJk>|UA5n{)ywO@$@9&!od454Lgm*TAI`$vOMh+X2G7Gl zjVxqsQ`ItBCZ-P>bvMplG3~YW{z-F-_Is@7!i$N;zx->ULo?5-}=j#*X@ullgnUUR$lXeG2>i((AD+kNwFq+;5bE zT<~c%dIyWXi2wU4JouVxu6XtTzu)~sInEipo1z)~%IMs4+pCtQwRbk3vs%6GPmsx} z{|6N=&M5c#dJrWxlQ?xIuUIi7YR#X=^8Y;oxwodC+57F5b||C8;T?Z}eSJOQv!C_b zDK_^*!y=bDTOP})dDN-COzQp3qrXl~-~|T^B!{kK@$(E_AYbvI(eU;BZGBf?Xg~jH zInn<4y^Fccyk;JuTmGr%?VD92xUDAjr_21M(}Qb&90m2Bphhf+V45r>DmwM~{Q7+y zrNJ+Yf1E4dH+j{E*{OH-|9zV;yRG{9+;XkeYqv#R`g1*|_$=RZNo|Kix9?onzjnPX z2Pv95bU%CzIl6Q8^FptE@9Y2n_Uyhr^X&g`xAW!G85F(#b?v>kw_08HIIDP!fbRW1 z7OR&_CI|I?-f}~}?jw>Z8q*HQuH^c%d|uTm<?Y1Y_bLk4yy|Fq(5^z=pZK-GXAXDjxTGK2JI^LGk3Vt)I_XtDoI_ z>j7tevHb>%czGjaXH9eH7kDvQg!Px%?VR9T*~dF(a^&oOyX|DxjhSbE9+S?GnQ4+4 z^vP1vJTK+{&G%5ne0!|m$Q$^Y~|Ddm9j?kYpQm^teOXM&3oNZboJKlmrY z`m0NOT|~>R6ui&92Wj&-&}WEOrucPxW~;(Oquk8RPRdE4y|{9^3oj5ch1i z(iaQc)udnNZohkNOQG-UAG5O8d7AEv7kixTA_gfqz=hor0g0)L9Nu4A>iu+X`Mu1l z#E@$&X7_78hp^s#{;2Hzy}gsNmVV3n8(;JBXv*WW_hs+D$^G=?t(QwY);8S7 zas-kwz(y|k$yD4ba?c}hLH%Rt`x#}vA-Ddy_ee}!G+}n)nR|Py!;kgJMsuwG`~ANC z$sM5D*r_M~_uK9MM*BYejNSM%UeyTMu*FRGeFEn^H+;Y2ai5cjYpVC7U9Z=9haRcb z%iCY~R|{MxbjVe|*_e`C|NHIs*>>kPpSQEV`lGG$w_+LSn zyB8X%efW4>KK$3Wx3gDu{9eC9d(8%?r>){~8ZwvlcE6dF@&{C2UOql+|9QKk&vlRd zDgC_PD+M%V_=)pO;JzuT;B|7kIvcViZa>pJW}b6ngGgeu-7~x2Zzi{XFH@IK*EqL% zLq_DbD?#3>?^j>rE4!7sJZg4GY0Zw_{i_}a$!+;?h&x?6cS~TG-o6=1D`tR04pM`g z_$9c!(E261x8|T>^joIhs-?FsdF#hY+Sk>*yzv((AboIMVK2<*)y7 z_(k&XE348U@3Z>i(!kJoO`w2vuj#Xk8lc%iEvD*a5+~N}em6@g$NPBA=d=6sV1hICP|iB9&c@e&*iVc8dkv^LaWwe%;zYS@(V^Q?1(-k9%Kd z+`OSSJ7<&U7rw)v|3=0wF|U?3$p`?YuB9HyUqu{`syH+_Xme{^h^{Q_?PXwOdMf1c zX+i#uUW@4Jw_8uEUVM_{-Y++IZt1nilbbER-ALZN_xnBTN_#^q(41s)%g>me>i2ui zJ?}&{*FEHpU$NEG^!WPdvyOeBVxaNAaKHjjeeEoRV&R|XQ1YS8Ciz+E$HJ=W-&GQb)QRtX?hwEgD&~y)yLeuP-kr&#nLW zGgLNuNpo1NY5hruJ8Lz3+xc9N)A94=GxII&|9-hVSzYMf|G7`sf7iOb?ccB0?*2cIipTeWUCGY3W_hG( zu1$Mf?!&^N8uPW^r2XDHoe*g`7aQY&dW^F(>f; z(LE2ExWyjHUQYE?x^qqLYQ5X%ou~D7PiakVt88bwYQWphmbu&r6-arKtg{o8p! z(R-0K#h_s$A6!-ko!@qUliY-=gWFW6#~7WCUm5mnt@m`j zn_Sv!1Zp|>ZNCJ3nemn7O#Jp~3DKHIV(c7a6hSk^lbE=^Oq&zdtmM$(u##ocp8Z+3 zbGPe?IvG#?dpiE#q`L)&c|C(Ie!tng`RDWV*Lk$RgT@J5w@3b ztIOwta!Vf**O#(6rODuyDa)joZMU;ltMqRb_tpzCTRx}AYl(+3U-65D?P>8pPlZqV zc5%gn)$8Tz&u;$s__(>&-^g#1_q*lYt94&>4cqjimk%_$>;C@J(&=$sa+~ip zyk4`}Z?A9q)pMd>L{=pUDO^DIawf~CtmW}|KB20OWD28M{57Y zgV!UHdtb!*%`i}`I#b1*w<_g&^!XWgwqOS5J-FzvmYcBg_mh#xl`>1>0Yrkv3;!V(C&8 z*gMHDB0W6&XqOuE?RFXZhh402zYs!yL_#Qr`}KdNj0yd?|TXD=5Q2` zOquv1Gem3Z3&YpEJMI*nzIwYP?CqpG*7KDD4MB;{hmp0)`0H0thvS=Agc^_iFV$-; z?~C$Q-rV)+l=kFa^{?5tC#lAzK4=y1`)~0T)NW3F|C0YSDDighlSpZjX$6&gmsv$# z_|9hnb>9}`vM!3ZJ+CUf*6D80K9$sYtB)Ba%uOxnk|YB4Gz|v8W(P7ZtI=Oz{qq|sN>&)*IBFAhOH44 zGnuWuZikX5c;;_YulYR-&o^QGQA^S~!Wf(aHGE5m+t5%;~@ewozF2m&AV)DFq zZr1v^y-DpkJ1f55EsvjM2wK1Cc}Iz@ly&dB$d{4j-n^iMp~l4Z#cXBM4b828{{KWC4Z*JD2CZ)1jzP;vke}1U^eZTMb zJI_aArZ1xN_lnwXT@*X@{cZD;cVArmpQ!iCg~OwPp;3)n(9uD7PeS$XR2Es$8;`l!p~ zVv(Z5f&wNk*evk{F{X?08@GKp^fSNy_8OLV`~UxY;o#iPcXnD-*2))!-BKSGw##+R zi>j-xUi7{1`rPa~_ft;Xx*_GiBTamYGVNR!fd;J?NHTGKNn7z6G%n4uNMGRk?(+Oq zn*}P~ZoR(gkK~sdx6@|lidm;De7yI|CGU%$wO>7!>|D2~n$Px^q>2I~(^{1U4*5%O znusy6a7=LrtqXj2ckzAGc)7D$Mzs$b*;iSt`sVye`^DQWOLuTDT+yGdQpI<7v&P#m zjfP=NELma!3$FVtV+2)2E&?ya6pz)nMiiY?O>WOwSpjNUe);%hds_aclWG?qi&;J} zK5rvzyLZvN-JS2eBJHdeG_Y_8WGFJSR&o0-TL?-hE=(82yFT&!T9a;nRP@W%Yf-CR zmdDHq3661$FFtGfSVi2@Yk%EeCHFZ}d0U|kpVb^17otTI5s+^ItOOxx%(`nJ`Ha2Gz<%6a)zVJMoQ+zJxX6oYgGbL2d z&$F#g>(<+qF(qO?=Oe8uu24fxfecPY)+%qG#g3rPN<;LW^jf|>f4|+n=s#)EJ~^FV z4)(mDi5oY5+k^uRFAS5}d`d)ZPab}2cwASEk%?uN>H>%SX?yBGS?M0r#r(qm9}e^1 zjxG^feEz-OkLULPCGV>5KXl9Q_KS;)7xSA3GRo+lcj3OV_4-=zi)qdZOf0t?9UAZP zZO-WdMGkW#s1M8Q7I|MFIK~#V7H#vo*w4p1ZzorOzgxb!Y){j?jD;hku#j%J&1*BVHY%bun1R zq9EbR3`1tMD)FlKGb}-~_>Eyg0SmTY%8}w`WMVm`{2}d4h`Rqg8S9kOM_%9AS^Q<= z8Pn@A7n8*-ALMSoJ56QpBJmg6Yqtb-6`r39=?P@8GO|`_pIKxGijW$nxk=04NPd~w zy{y7CV!B>zl7HgD$9IcP>t6gUZBtP&&0Z_u31}6M_r!Zako58-_l9D$+C7=#BmejR772ga&GqksGk@w&IdFUY&4i1Ob$2{yifr1g`bpU6 zSF+wkc70GAZI*(-|Nk3j8*s#eraKL z-|foSxQzeHQT;kY&pS69#iKG7-cbBpaW|L+JnfV!9R}b&?+6!!WG-~do1)%d;R!) z#@PSM$My#KWsppBN^gOK{%@XBpy{5cA{}-0UtX`@ALrM}mU4Gx@bWd$+kf=`SyoXS z&1{kN>d~Wa{dF&YWbwzP&n;bLyXEEa+7AcWHH!*ZZCh8(VBwe&=g=7UOVfk_R00Jl z{PI5iS$o&EncQFA+%&d2pS^ysm~GlbrhR|E-M(4*eC~9WrEj<2xAVLs;`n@S`8|Z@u=<`E%|6 ze!ls2AInzBSs~zRL8T9ef z^SS^3ec$gcd)ZrmuZU^f#HOd)-_Ni8cGENHR^f5k$wz!eO)iR-oL_L=F45L$a$Vy2 zc)$DBZz>>OjLeLy`Jx}$&p5x5Cq8B6^&BQ%^I_4Kg9R@FC zh~%&lj9xx<{j*~myf!BNILvP^qrCOd(I1!R|C{pniMqY#r10SDa7ZMr6FIf9TL^p(n$8O!m7AkYMEBu0d^_z`vK#P<_7q5RmA-3%1(tT~d zIZq|OX#DVQ(THxZ4Y*;>^ZQibA~Q9Qf2SI2{yW|{&+}XV@W1uPO4f=qy;V;T{r+us zu`;N4BFHk2%hRQn&9q+q`{wg@(JdQAjoL-F?|8m?PQRS(t_hFVs;@M^Ut@ebd;Q)` z;_)>b=RFJEdb9L;>}soZ9_%}t;=bqPh(yg3`*!@$y!%FVbvHh*zLctUZn=ETdw=dP zH3$3mL~IvSnBd^hIFBLJ1Jrd{;id4a`*eK8!`4++dB>YU^Y>3;Uzp#oDL!5BY`q<5 z1KFmJIXfP(ht`~-{9x3-nSuIJNIYqkDn6qT-87S9bGv! z?NCHikVE6WNtd%gJE1gM547BfwEO7t#r<~j@*7(!=314W`t{|cd|~fyP~`+-zi;#Fy>I=Nt9~=lq;A!N$?E=og1fH9z22JZuuJF7&qF*vuRg6=xIOItr{`&U zyuVj$cz%A(Z4QABg#`}%4H_(<>i&xA1FovroUi6l)o-`H&bOI7t^8hP`nOM~f8O2w z^v=E7?{`+AZ~9}X}Fmrc|uTcrKsXZ4Qg#M`z!kG^equ04-GyOr^( zVcTEl*?+RCcHWbZIPPGoc!7hFwMu!)SMVr-u~5f8mLH4zpRND2^{h|A;@(g0Nssfl z-z|&&vw*h)oM)Tacu(c+{d(=m-nVX~?ZZ3ff) zO|3C1DmAG${B@%reNqiDVPvhknC4;!s_5h!uP5=BK04C5(Ro|Qo`cQo>XPT5PLH3b zl6Pu>`JDpiZ%_5>El-E%`tQ}6bIZ@_cRQbZIooGlS)syaY(3rI{_mGdH)_l-atf<0*-&MC@Vn=$2|pj@n;-eJ zFY9B(fr81&_f`?hzAcLq$cSfTt@?d#??jN-IG8T3Uj!P- zag_*9EcVzM5L5Tu>EEhNi}t>HH#2?S$xroDZWN!l-7FrL@uv0m-SYdkx65w-c^m!o zuF%@o0d3zE^MuoM<5}`He>xYZXcVuQ@^STsa!nVrNeTf>h{ehoiH-F~dYvYle^!MladOyK^%VzvMl;$p9`{hdc{{J8Qe@btV+WqzI zZS&m^nz*HIXExnCbc=~|k=Q@3Uk?*6{PeVm?>e|W@r-_p;s1TS$8%4xyb=mnaQ)~q z@Qxf8p^mzpyH9M7bT@ikFe4=V;^!lvKHAFg-tYJ8|G&8!9{;vr-Bvb^?m4N6f!lIs zrcOKQXZQ0-)NFU_e_Jm5oqjfJ^&jp?^QyB7j=GljPKA(&J`S1Jwcuv>qPYYY4Uu)n0 zb#1%W-QDH+CvK#b-kVqXZ05=1w^#7}`u=|YA>*@79J2q{oesD1F^n_(f4H@9YA_lmIHD{$gK?bO z-bIfaXLQ~8a8x|r=jmV0sc7{vpAWb1|0@&AGwzezq?){T<1wk5&HQ#ZwrtehaDeINgM-bRuZG9l zo)!;1ExrM?5oL2hc8yu(rzb1lZ{c@M`gSGQKlNu)>d*P0mA2n5y33pDKA&0oXQ_Uz z=I)ovW^+vscNaQ!eDlv|7vul_O*)aevhRuL&bKE7&gWjA7`U3_dyz%j*$w7(3%j%? z6>~JEaaBBZgbbZ9GVMITypj9M@Av!X=ZG>@zuD*>%>AYOUZwi)*YW?YO7%aRfwthy z%3i1WSs-o3@6YG$=O_704q{nr{LFA|#GLbn$7OEXd_FT7v@-VfwY9ge*zYcRIZ1cZ z38mowf1ca_pSkz2n0{+8wPCGkgY`w)zR$sMjBJNm)o&r6P!NUwN7Sqn{?a%m4U_Nat*D zOr2l*ZRMQOYmrkw@HkKZ=&ZqKRrb>DY`*5b^niu?Qf{{M9{MJE(Xdlxe=6P{J$_X6C$1dYT$ zFlOQ}e{lRRPrc8x@c%hiIq%ebKHK}xG49nrKI=CdUL|eJb>XJReb&pY_|rtnx2nyP-UV8^2exB|-vjBbe=e;3 zc4LE8MeTl{+gq+OvddgJA^&*ktJTHN&rMyue&4R#b3M-dwqI6d*{7Szm~ZU7U$y+& zg!C)LpI68K&3gK!1Vx9=*TJ`Ni|&%AfDrubNvw7JP$-jL3^N)WPs!_|&xU~IV9_KNm+n>LK8k(t( zj&z=#vHwLaXl21>*?g79v9n70UVztjL!)B7%df`o^W`UHui5DKMSj&=fr9OK%d)TZ ze?0Vk^Z$Rpw;!HTU)Cetdj8Rj8}p9~yg#E>^IBK_*PJ;CI>xr;+i#}L_Ns7=^`2`E zT3VX=_v`iiBhSCiQ=6l_3%>elM&p6}pg$dT-)^QyziKa9%vO9Q(B1UW@ruOX5rs!Z zZ@-%M?fjf@@AmVLrm)OE{&)6=v*p=Mg=fC(IU65+W7Tctew(1knvX}NKhDfOR(Yu< zICwfVd>WIuWoA8U|Dw5k&ZSlRr%&#GeMHzl=Scs@LtiKUe|*GUzIMu;?F(dmxaJ?O zS^8Dvv(bu!@s2;OuLt)$E;ba8DL5FU%Mkv4XZiEFbtYVS={>NVqf0fU9Ma=#e8qS?zS6?ijK>cZ~49FdG}$}$SsCP-d;P9zi<7r zA9gbX&n%r5waTdM&5doA`FeZ5Tym=kE6;tfa}ju}1GtWv$ze0~k^5I+f18VD_Va>y zOzQ7m+V}h2?GE{;zAqQY@2>-`vt7DCJNe8X%a0=Km3OaiykB*?bzhv<$JkFdXMlEI zJ$<+Pz20M+a*gN0ein*f)4$GQo2S1^37l?NI0R;N9(bu)7Xs>Y$o?{1_3=MfO!eEX zQ%$eO7=Pve+;$Yykk4ce`=QhN`{(RA&sQ?RKI@Z9 z)A@(%rGBiPzFutpADgIzMpmuI$9i8gl}h$HP@m zr-ti&*MHcQTK{h6^DwdKoQ+rP&rLpho_n=&zs;sk58LI{CfB}PI$g_MzP3blzm@&s z;;OAz!&d+K&~Crx$?9bBOlixaC-*e%nibO)i~aN3H0@}*@3Xn(_fF|cIUI!U!duGwFD1$cooDDx($G3~zkDS79#!K z+`7d1WPO6wj|a`#Ked-<&73ZB9F+2=KJK^Q_vwuB`6bdH(v{>34lv5fmH+$q6?FbX zqGkQE#eZ&ou2-AUzu)A+?RAQ)w>|H7yYVkN;m?ncvUcy&3(x&s!}z>U4`ds-?UJTw zkp5#gzpx1B)IYD5tu`<=~`#7}8HD{?dZ{QMEW<&z1gLc?RP&T#a*e){M0 z`SPW6K!>gzj=w8N1y8*xuf#Y{9a+_ zr+?>n&boi|!>`xtuY2GA^mbnDx0@RCU(Y=AxT^EK{6kI=uLZ#iH%$cZK@j*6-CF*SnYm1XnwQr_q)^cYCfIRS;J!c^?X1}8feV*iv3}(o5BC* zfCgv^cGrl7#hwSPHPGGpWK!_|n7o}&H*MgEp1OCbz0MzI$8G=ry%f_tfBf&<_ciL$ zb~P274z`59NIl%f%N_jTp3Ow-lj5~+1TCL^c__yD|LMjJ&+FB0=k5RdE$79Bg(n|v zcY088+^6j0(VzR*y50YD_0E1_+f@zFB9f8Gl+#AKudgmN?V_vr+7_iHPuFKiCOl^O z#L5voXZ8HvoxfhK4tML75=~9e-}B+nmCzrbZ*Th?-llrSzFxiZ)Y~sDJN-+4-aKC? zc686xX3)Z$mFE`kUux5M1YQfS@O#j{vaVu&(J9Tf|DtdHkkSxXSFl{mCrzUK=hNxy zK^xRf`wjFL?EC-seK;GB#Dx6O61`Wal;<}raLCRa5rd9~x`q3Y-Js`H+{Tt0tY zOxexUsfYRP_ZSsCII!yW@?SlzJN~cuR2+9cvAD(UC)fRx$1Ky%%=l)r(%Rq^XnOZ* z&7URnCc8*8rHX9uh>=Y9JqPKquRR>F-qZBXhrTy!%HQ8xd8qrg8WU)s^4q`P@3)`K z$d-C$`S68vc2?lugFjc__FMh$!>vA>hb_XJlKU)|ZFB3JrzH@!=e%6~pN}`B%3B*= zALrAOYgFQT^8Z%`WH*Sb=ngZLvg%b&4oy84vhZlGawBM6Td!O6<$(VYmoILW-4mVL z9$x=tf}*p?^Q*-GMkad*rFe>@W3e?v`qZRU*it&9Ih1$V#V|L0^;lJK?tdRa=u-F@5G`u^!Ry3B7s zw{WuK3eGLf4NQAw({4&|3Md5RHQsOeGT+0r1$5{`Xhz{}7lr!&o8J~Qg{zuKPSg5U zzW?{#9MIB#(S5p)+FUt(q5mE82UYD zZs|2o!MHPK0uebIk8bJ|R!;-%D7>ApC6xc;iGnA_q4KeR8-M0szu&eu`m66M>!ME8 zX(vAI&e~O0s$N=}WNer9Zs+rJ>-Ky)^#;^w^_U^K^{hCn&(9k!Z)%Pz2TX6!eo?wH z6TCN%SIk2B%lE2PcA#a@I%|&2)!MToSE1lm=JM3qUtcntCx)3GS$-&Rdq`=@TlQL2 zlgI_%(l+N8KAGsAR#}+&ddGod()o8jD$MV{pzj)B$SLCM&=|Kxaw7OJlrugGH=7sc z@A>Ek+A%uYrg0amSX9QsH;=mY=T(`v>F!op=s0QWp75y5r8z%7JmkEbxBdcXxnLLL z?xUbl=~m%@1>$*LDqx2i3tA}td7r=R5@>_T%)c-F>%Bm+ClFD7w{-LD{C$?v1`FQ4 z?l>*vSH907=F8g#X1)%&&2yR8ZNFEg**5?Fy$jl|35J{^o(HNgbel*QDS}o(-Q@h^ zZ}EVAv-OI5`_Hdm1X>jM)$DrTfqIrt-!q=CZuFlu#op|8*zNg;Gq(GhJZg2mW1e(8 zE}@Zi(;vNA=jQ636}eotZs)U8%Y0@E8K=l;+i(9=e8z1-Dr<~m{>_!92A~oCB?tHq zulV#ldUB4in$L-SpXa_;>D0}r=9H;^voUfX!$Z*V5W4$*JbG*Lqg$A-?5oH|(0sY} zIpG7({y&(R@Oq}gvI#6)pxumDN<6@o<|+Y;rCrId>{6bbm`9 z&CX}DZa$qJZ&&*M`g+y-5?@cRQg~&bG56Q(b32}1Sm>PGF7iIO(Ix!CZ)UX%ub8;L zgw0QUtnAR>kj?c+m*;iU6zARle!bqD+-IqlDxS1`r9+*l?f$oae?0C#|LOYXttZMd zC60S{9^d5i=7)0|Pp53q9)H$paaAux#JoW>j*Uv35l8oWY*qvxC$Pd*A-*!(>Bi(R zi=V5n@B8yq|N5lq$($j&A6~6q@3;5w-yY+0D|Y!h^54;TGWGxA$Ww0@3+(Ye!}srF ze|^g8HJiN7Oh~HL`tYz_KJD(VQtyWo^+moHbsb0&(r9X6+RL$7fgRL0T@n7^#s!1; zo3=Nn?QeQ{uloI2P))jqzme1C-;c*PUoM|N@9(Sd{ii-1T9$JA#f10AI*a2Jj?`PH z$^X2|oxksA8psy61@8TFH(#&cFLygNfy2VCEZ`%Di0c8}cdj!zD?u}r4z^6{EpFeh zT;6cY?ERk4eq|>V+e4~%Jm$EfI>CN&9cWQc?0<#$kG21PK3}ixH(6@#&4#+?J$K!& zuZsl*x-nDjuP>g7m#o3L8Tpi*E7}D?dwEyqmV>rHgI0-eZMW`oxXZM+>g%kk)4#d( z_e`jLUw!}dvl)v&*k3)?dN3~bd&BDdA8udU!^)qy%RenYb32GjXQRs`_hXY;d|xV< zHAb;;{a+h@IstMLPp;;NbP%bABon39I{^0d=X}N+R>+ zmtVQP;aJ&4`82(Ui&;!3ng0KfI<0fxx_G-4uCwfoBn3Rw7dZH*Ya4;OKPG+;su!-l zqV17>xSjv}yFH)J9qaY-&(+`XWRiE9{lAa>o1f3Gx3dOSM}I(%e~PT%|WTC|~a*H_8LKYx5TJmqe=#j#~ggX^QHvMk;n21ce_^$pNT}4V-E9x1FMadCcw;>0f7`6WY0}@`zrT8G<+BgV?f+(eJDXo;T=t{b*@3(H zNSNq)1E#?E(7+jio{(*9fe#iLyvRLdr}Ol|=d0U3e~);6e(7xv6X%2%7ZyhDJD+#E z{C;hExrh5dyZAX9CmyYwm;Fzs>I#$Xer31DdlN4wT+0=Y&e3?z^mUM51qBS)FG(6DLn3^eD_vCjlKiS{5BK*e%rp^cjkrj z!EEzg-?#^Tnf=4BSwwTXTG}G*7fU7gyKr7nUf{6a-B%i9tj4Yb{7y|L=l9pXTDg2v zGr!%A7h<2XjT>h4NQAAj1~DoMtdk0gmY9?bRC%AJ5&GE)EyRCM-09M zCN*ZS-)r{!u>2=giAlMh;qz7-z3yIZv+mhpKAR5*a!yUrG~IqV;ThBV{c^Rj`}Y`! zUzl5>tGmD<|K&?l3y`rKOv~H{0=*bDUlBN7i^MyVBys50K{^`$kpe}ip zj9lH1hdH-%xBH6j(|znW%S7|&j(9)Nbh0bx^np~hC*b)fP1b!3_*DGtg348m_ew7N-rSIQIH)y$_l}>l zI5@Ydd_SvxBG`kelvCrv>!i!zhPjv8hrko&@h8_ReqaAgd$;x_@3OWj7I#5|x1c_C za9=_WM_uMAzO0_w)ZXLQOMZYhDCF$_`)&2g-sW_j2`{*QdGF!evZ;Y-@6`0`;1j44 zsv4^g*Js{X|89?mylvGMNree94{jv)pPg6#@8^`ib0!#7$Zq_s{lfqH#dWXL_W!!N zeiJjF#e!FlWi65$|7>hziJr88^OFeZ%sg=KX8~8E@L|KBO3o+0mtKopo}@e>=z)Lz zui#goE#fmacHG|B`-7)l$@b}&ttD@^->cHTx^rippudNuV2A1ht|}eRLQv;pfezD8 z?*8=|E}OpJDfXXsUoTsEg42V?{q}iBe((18npoX3V?T%Cr|auf@4EF$J@u-Zdni0^ z<{QtJ`YSUhrLlM^E^yF4YT^lYloEH1?vZN6qBD|hzwf@6+SE{^+_tE{iBqQT$3yU` zd`7FSoj%wvf3tvjV?1we|9gkut7d~dfAhn`!>jG?HU8HwxLbOC>4FM%mb2y3jnhP5 zT-l^-3~DV2C>Ufn>K=-ZpD(qt`un@cMdggk{bK(xaX-=C#xHASQrZ^JCmS<)*JQpU z?`3X1*>XiE6mQ;4pC9}6#wadlMXSk&}njw-w7q~dd#|5p7h z`zd}SHUGuCmotBVvn*vROV_foEiQjmR&J`fc7c;&NmGL+i$PPKm;V8N0R~0^2FANA z|5Tdy$i-$_7eDKx-yc9fHa&kM=&> zdSv0@jzjuJX0JZTn>jGBz|kCKgGQg#T4^b-?{3STy}a8|(PA&libFdt{Wg76S#fBm z`=$KTmqYCj2Y&6BGb-!i+Kf@xl42_xk;+i?m~1zRG_3I!CYm_O@K@W&Y3Kvs_rD zd}00kOP!wko2@u1<}wJCtp9HCh#BNnfsWn-rB)ABC%xS`SK`6@{HG@;w~KS@^L?m_ zVPh)iEZDf|@9*!cRSqqle`{HSZ_bkCi;&NdO_HVrReD?)o<_at~PowcZtn@ zFJ`F{er^`d68uA1T8X1=Dn0yM^JpzK7p!hY8Oo*8lHL{B)l5#eC^rRp*K6oH4u0d`lPo)W5q}lexmpXP=6? z5p9=ny`Ux}nCn^U z7F~}2`hL>x^x~p>cH6Qucl~}|a*kWYOI+;uGxoZCv&OmBm6!?)zz3~K-S(5mME8`xk-P&8O`Oi?qhtd@^=>*~8u zx%Mw_x7#wI$!9oLE;MI(ZQQ8pJ?%%)d)BIR=l|VXuV+2q{SyDLAAi_ReVF$;Y<=9@ z;`_V49`T!N<(c@@dB0Bi&A)8rj!2o$L~w;;*$yWY^@oA+e(Nv%e?GB9g)=KnYVR8U z;@8~Pf5O}wxF)RhYI}FVcDDQF&ySZ#-gBDx-7Ea)N4dRMSA_v#Fxv)I7PFF3C@H*LOBvUZ77 zi>`n{qeDROM;{IbJ7{KYxXuyqafh+WRgHE2d&Hz4arQXe-E}Gb*EjAn!r}2-TlYL) zs%5h^KJ)gj($ztKcTM>$&bxl^w^=W4Y+U^A$sGIN6Xv{rm2ra+;#4sCp_idI!q&Oy z!o#J@4c;3x7C%21sTs6n!q#u)GxE#lr=NfH>fNRYx7Fz{FD>P}Z+LL_|L61T*EF$m zYdsZlwtus5es%h<#&mgQmStTG%XX|*;@+#kzyv}HoeX=k(p5trduVwEahmF>7}WeI zsOBx0(7Rp!@ydJQ%~u|OI~^X#u*bQ1(zf#VaTAr@`BZmBzU&lMKe8qB@{ul4?IZhY ze;?VJef^CU>(9^6#h;#@F0Q}#OHjbJ{eQnjfBf}&efR2c*`2;xlRpX+xtTIJJm&8d)&m%q1Ob-4q(znV1fC&yIb8LVR|J>vUN?34eScfWzfYfk z{+VN0thIAy#*sT-)Ai<_uPf*|Z~J{t>5B`B^Z(4WDqS^IJ6v!77w=~~ILy_NG9d%U zj!uSr!LK!&QchNdu8XM*pQz-z#-&rp^|zC6v~8qr^tLT4K5h5ce{P{!!8F@Ef7^Zq zNt=ody7%kc>4kRb85I%2%*~6A!o^7GP*> z;80nznrp%brAzBn9(zuk^noM8LI2|2U8R%f88|%rFDzk@&@fd$exJneHtt+jqq`P| z4slw2Q}h%%eD_LQ-MQb@_v`C(7SHEZfB5oF#()0=_XX!C>R@pg0`JWcqoc(Mm;r;vc6? zr;ksM+#kPcWyX{%OBhe-WPf{eGi;tsWzDB!g5y8q`2`)C6MZdsp31Terg^Q8PH*C(z9nZx?Lb2?7q*l+DnBs#v)9>c zp87*c(TrCdHg2n~uM9f>yMMlIb=a<7+~Rs1t8VFK`0g&b%cuQBUv|f_V?6DD8!Dj| zfYVXGpoZtiJ>HvIo=A0SyX`*KC%Zaji@wN|Z!a&qm&w0h_`7X+{Nk0$2VB3Te7_xA ztL)wvQuO+BRoT=!>m}9pH*5W3!<~(h@{7X?!HQ{2|9VFK2(`X9=zdT}xR_{$C3R@bDZpPlvefA5pSqNk_n23M}P zTsV9AX7z$!X$`dk1C5=G&8te_}kDL49QV8?hXI>K7A?mJF|L%&7++hi#cCR zbaztnc^T_@b4JPB@0vOO|Nl=;S(fFjxZuBVS77AFz31jybKg?)=XBG0q@fr4=+3pP zxuTW-wNCPdyE8s_JirL5FdO(LgDMFIramDL-)pZYeYg`cZ{NHlf%!59en*$fY_HgCU0tBv9&mJ_C-i)Nr7v?F+tgkdu~|c$2_fGpPM8?;*6C37l-CjY zFS(=(A0OM=CvU$lu3V_>Ke=V= zoE_7@?%!R&%F%G(FN;A_Uo{h?>FUk$D9C`4^<|R4N=TEGS1fQqaxcA9?d#~hv)>83#eQ~$2df$Sr z&)Hlb`-Pi?7VeinC-Cc_%%rpLmMlB^Iw@u8bT9AxJs;ZwcK$xtZ~srDPtJCg5liH* zdPUbitrxu_xfZgsI6R1B^0-jw4r+2RaO`Mg@c*1EI&sSJ!sf#Vf1Fr+uix(1iU+2T zR|YTNCR}V+ z9cn#4&*AtHkB04EgRcGH-r#Q^YTcQ5YKrEmKhu{~n7x$r`?Or8Hh`H)L4cW2<;4zD zNMF`R^}yn!ugXH7zbv!Tyu4mW)vF`vXxGifkLN7-JW;q@}q_S z0+F2;I-iI>k1agbtQETI2B%g3yw6g_CdHfcoR};CfJ?pou}e z_VM3hZR^B4nX~uIFIpM2ltsQ0?S?h1PfVkL8PF;WYfA=+4JRsEj!*M>HRyV{3LXB*w*W_+}G)rM@lHZU&pBY zVq)!q>VVH>;pR?Tg0D;qQC}fn_haFwCx52L*9Fd;^M0YhKedN}pJY|Coxa35-cWd8 z#pH1z_Ihf81jvdQcLlr3KVqEyzeEe?erL2eb9;%a+T-&!pLug!RtKRcaG=E!Ebvu*ZdZQO&x=}Yy`-N=J-~TskX=m4xI}>+))@p9b1DEvR=x1m= zz`10B_wR`^N*nj+wQ`GZvnqR&p&Pxehb`*j9*>4)wzJFR%{l&jEO|QBHMG9(LLb+) zh0g6$?(g%St`}OVU&vZ!BEY~nUFZPEE^lkTJWyw%;UP=ar20L_{s-E%cqwI?yvis@m=%!6SgxJJ_i<~pC#U)U$K!t8TUnl`S4j2D@NZaV zXI-TK>qCv~;^ITS|F>|QIT%!OGgMxJ<*Ipn&BxYh(jOiiYNWd61=<9A3a#wvp8xyY+?^?Hzsyoj2uyX`q4OtlD%%2S76%90 zMuV?v3DEH%XO>HWIx#C=mg*mwq7kSRxX_99;*P@Pz@=WI6ZK@<+u4{d3VTde>$NC; z)^oC=g4^h6bxStW0e)ri1KNu(#ogIac=X-f-LBu>+zg$yvGo3)%HSnlQ@vt#E?Top z{{8a`he`zl1}23CQyAPXOnuZ^1PZ$kB8++r$4~Bjt-blP+;JPPdkY+yCmJL=`Iicv zy)0V(?v7wh%Ff!~+iHF0SZrMWs6-oL`{+|B!r&1{*T z=WdGmE)JhLr}$}^%JWJ2PAeeefZzf`m~)E4@{0J_soCmNUoXqOpi?Ee{oFj;)v0S& z3cG0-)*r|zu`fPku76{Rr1+`#!JOwM{R^M1e3+LP^Tp3HdzR_quiJD&R!lfGV_sQt z`{8ns+rj1vFfiWd*t7hxYvfekS)1}o-`~3%wXBjOzxW0-koJzy=~jq#Re=)>V9)3l>N8*FlTG&yX2<}r`>*; zc5!XA`CIeiXJ=-H-nGu=eH*@m6%?e<0!4tOaY>2p`oAGxg*09BkM&5dy|=eI+PzQa z;=d-|W`%-3KMFO!7hZX;lX+>$rBb^mmg{7Xq_=c=+h6`W^YfR>{@ME{y7$Sf+|+Nq z@`c0;7Dzb?CJXu;xQzA&eed36|4l1oMM7Ys>RbJ51{_R*oS+tG)uO4^<$2om|NdP1 zYWL*lqhCUP+l`(ugwMP#xqYf;u$ue6JK8ZjHmtJnx4b)X13!|J6{b6=1#Nfx-o0u4 zw^^pyX=mr#%SS44NH`|k-&cD{cx}wiqR9RK|Lrc>%U^j+@ACUOcV<4+jh|nC^ZDP8 z$K`LmUz~WjZRMNjz1%OK{(IYK21*3bwA=WbqhMmd+r<(4_LOYTy?yQ0p32SNre{j9 zG`0)g*p@r{OUmkui;K3Ml(Vh!xc+xS`dgmA>sp@qA4xxP@BTiU|61pMembo$yL0Ex z`p_f73pdYrX4hhgWISUl%QMZI!Y{v-&vYb_i-{Pmp^iCt5=zKXMSjXu{eHXGe)H}2Ufo|`ud06{fQ!k9b4~2-YtMh*y8e8%&rGB8 z*d=>6t-Z1`*n9g&f%v{l@8yDj%)H!CBL8J-YuD!rv%cWBptFi@PUjWXMh2zW*>tKF0IXEXlKG z`{noCUjP0)bSm)H=^d2>;Ch4 z4~9~U(?NOS5$ZSknOBpTavE@xNCOQpMEI_F>PcT{;fXNLdhr^XJ)EmggzZPAP0 z_vVJKS^7DdskP;u63a?|g>bYs zwWja35}au_drEG{h7B8bv*q90qxtU6PUS~OI+Y(C@7K?}yGu3i&JM-A`}=a|AGd!D z8ruE6C*|a%&Wev8)a_@;?XLQoWiZ{nI(L$a=c2zqFD!IEx-ND%OYT9nyJdVn57uv${L7#Za=3$P<9Uxt*QsoaF30XDNHi>X;NW=Kw{&({>)!hRf5YG0*%|!i z?(XY;8Wx>(UoN`49_x{Gt*F>Bx2E`#Z0Nd}ok|%c7y9}q7x`V$kKL7`{%B4^anU*Z z$De=fV&N3JQI&OdmFlHsM-N1QzkPNlY%PF+Ia|G_(r#Oy=W8N2ADQfLrx~^`M)P)# z&#z4v_4oDscp7E(&-KvpZk3guU6V!BG`%LpP7mI9OEY4_f*D4sT?-CP-WR9zcaMDC z563g}?c;ad<7h2^abo_{3>Cf zi>RLCpdYcpA?MDHK%JN!7yQnAe|x+9dc5B`?^BCuQN{p#iZ^Y=MEf4;ZuZPcX}PT^Z8ZPj0=pPM7t&M&`h@^2B%pc^ND z9qkrpovS~u;t{9H3&(r1T5cC6tNH#4Sa0!gP0-S=8~f&F@660ydP1sOTPoB?y#CL} z_62XHWWR2Y-(RQowqN1t?@-WG6*$R4a`;!4vPqm%vz6Xo^gY?)8eA+J{XerS(QD1x z`1-$BU)|ce`e=4i=Bb_MYaO27^O|Gvu~JIV-q-V+spMbx#b1{#C|oOlXTH%drB!{q zN?#v4m3*{IR7~~LrQFkfM>T6hSBGtVae8Hh}kNfSzZo0?Vt4#i7FTMdX9tj~A zOmc{ytAF-SlhmnRw-dVetopW}yL9rdc(lnTxl^&qs^8x4{~uSi-z@vu8TI=zH|l(= z*6h2p{NKFb^>McIf2_3YOy7QCjri0v`+|P9Gwp&55rNVk1IrcR2QOD@#Y?<@wM_Ho zwfy~mm;I8xVe!|b^vmmzM zg%`H{n^zIM+)uZSUtX`GoJ08563@v;S~!J6c75X2v|n(Ep`@9CV}>gO=dQ@VjQJpM zIj}YUTC!vvk1PM>z`a$a)`3s89>(Rx)V#f&zhCt7a)0q|as9H?6)`@1XKk4Ng|*c` zpIgon|M}hS_p`)%*!ow@YnCw2o1+mohx?TE{U6@5`R)G%Y*khcm2RjLU|`(Lq2Oq~ z+WrAAsQ5gguwYM?b^h(6oU5lxi?VKZKUT3@+uYpm9BAXjGl8BDu}3+o6n>X}=J<7U zbNW&B`87!_;<0{PvaX);JLj7fyQ^g5_toJyemIxSb^05?%cPK?z^L+qt&A&%i4ojc z-m*MwlHD9~Wt+isg(8~L}D!)x&``7%Zj7PkIfn&!!2BDJc<%&$8 zgx*-qv1i>R_kA@#-(69S{we_h{G;UnqT-_trd?4En=iwg^l z4jBiz_ez-_S>V|0^6$^j-p}i!&7Y>)EepD!-NP-z*T}%3q29m}YndbgGMzD(<(`6f zYiQKti%*}NoV?m(VW_$I>_uL0k`A}=M!kJy;`V#hYm?`Z(OPa7ny>zRxqLp?zef*F z>+k;}^4+CV=w|kA-`MQ?tHbp-*8VQLdggv`F2gTJ29`4_4J>!h)HQ~K(w6{7qL zdd@9Nxu^8b`#jBU&)LbhZ$F=3ujke$qgnQzZ*F;f&w|rCvzuk#_MPL7v{Lt*lOfI& zvght}nF)p&57$bu^ULXEU0=8Mir3vT?F3_ITi;8Sw@u? zuWmSjhs9s0T!@*vkw?;KM;({0|JmnTcV%B+7utF0=So(Olb?|6?}tu3%>rFqp$2RC3sw;~lu8%g-|F zM}eQi@+)g1gRiWQw_lJwci)T0{q|z=H6I!;=UL>*E59h(_2Aal>>?4@i;EWJSFHbV zW~T9N*K0nxUte7nw#oW;CHU07@F`MO;w{;?x4qR3TJ>x1&gCJ;7xJ(;9GJ=y;(xhN zRm1{3im9g*Fr{Yg>QnLNYCF8A=?J!Ri@O!c6$U5p?wYgQ`CGZ@vpzUIBqre9ZiE|YS3neR@4`LCYL;XeHLrFlpU1Czo7OD2yC zw%3<(aIiQi9O2lrQY&s=Rn)2w&CpjE&2+$H+>Yw7E2qHFe-W-py>{o{%K`}BXm-|z3qfUp}24 zFZTNS=QG7id+j&e3(R6XgK!iiR{d&Hz@#-xy{Dghq(7s?WY)6WkDr~CZ;6Rco-D^-&*<>_^jgp?pLzbhD}s}Z zq(fwat>#P2`zZKhHu9j#174=%p(>?Y=5H!}bc8cif1i=){_ppycf~D=&2D%1yV#_@ zK+ExY`iyT3+xg_}WcEz1%Xq-@>w0|s)>~ULlP?BMYk2ow#lR42b>UG;RI`W^k9LK)-R?m;3G^4w={2 z&0P>^E4pgwD^UA*fq3RhE7_p3mN$CpH+>GB7K@wylKt9((+gK7@m4KK-(CJ*On={x zMGu(TJtwP8eO#auRbjo&s`S;3L%sVH1ZJD%3RQo5BRJbUUrgP9p2(Nfxfa#m*3>>Z z^`TQ(eOrIb>_rI&o0O7|^+eTN%}jZAW@gj0))z)Mr}NCcn#xn=z`%0Hk%4oU^)Jpi z(B#m8zbvy>J6+mYoF2Mr>5ILEkJ}zB3NC(jX5ymrjH=Qno@q@|RnhkR=Js*n_MG|+ z{JUfpty;Y!|HcMK&{B{KUkWVwey>ywUgp!JI^}kJ{a@7|-S)n@Y&U;;P1c>k$S6=C z$f)u{@0HFDE>MsNvdArdyjd&b!->FsH9tdEOj|U0*}dB*f4;i9dg+VHOH!n7Mmicz zZjrVBC9pejQ|%#+T{4Tb+%G8G&M`{u@|b6{^TFOT7rzKa?5WteB6jz-fQ|QSO(w=H zp09bk(OKUzf|*fZf-eK-uAD^|*g@94;?$6SbkU;fiTP6F^m82dKAliK`Ll-W1HaI{ z>o?}_-4gVRS8W=%L6ctlidTYPJoNYf`<4BBzQ?7fUuNq^iRnZrtO{MNwl04EyVEa? z&b@T;`gS^iMOJ}<>7H@}%iZeQt_}wVmOcIp=5-02p02MSSMiWlbXD`U%8!p+Z*LD> zU6Hn9;#;Fi)9FvrC++v}V}GIQc7d5?`7a}1<<(^pbC!Je_?14tcA3?h3D@m&Z<#nw zeSUPVb$Q9gAJcdeyIS;aZD3~71JyjObJ?alGO#$!a^UTjb}e_Ls01Fa5>*XLYc8-0DtlR4dc zK6?DD5W4ruFRfcSSn~BDsS-<<(lw6z?_XXQySuA}Q@G1-ZiSo4EFUJDBDu(eam(&S zl%{WMFClT!>sBSQ#EM2vfAut0R4;y?&aTqe&n|JCDXu=$!nw$`TWptXwlmvK zGgc{3;|SKbbm#ccc63?}CpY)zjP=R04rco;esZVk*URNgk4rJ^<}Nuau5#1#uJdK) z4<8rKNjp0$)$jPO8^X8l9=Q0s@WX?Hddt%LUN^Jx7A=zBf91{NZ|`#C+SIfRoSUpDtXSg&k8tt zS3XMWd}$KzufGqs=G~1_@t)>ml5xQy`N=!;qqmnA_V&)Ne|AYQN?N?tc>Rv{Fct%( zlJTBOK<}YRcBY#H7CId}V{2RUW5ZPQ{J58fzYgY_&5geE@OHcRRqs@X-^ZjcAI~dO z@t&p=^jmdC-8_rJMY995zSiE}mK%0+Q|jCoyFXt!?kfAwrV%tnXkoDFy`T>HvvnvUi)-RNbfjvW57&t?CeCoPFLkVm5e{1en?PO#%T zve?^i`|a)d(OaIyROQ%x`Ze*K_qu(*Yqo7T?!LeF+1K~`|6AQXI&Z^#HD9UuGf%%e z{NjtM*OU`cn^HQ}Z=B*wy1T11Y-iEaId9gN+1Y=z5Cn}xgE9sKi^G9ZmZB9E59?p8 zT%NLDoPEjqsI6IkdpzzdEmITAyQRH*edSArs1Ga|YE8o5UpnV5^PYY#YGab?hl7bNjzsPWSM+^NS<&&fi_lU*^6k5&ix`>8ULLtE;P@f9YfYW%W>T+A`nSYAcqt zy|})9{^WmOlpfEwe94f5Je;#a{e$ex33ggril6(rA3t05<%OcHn!JVXg5sdn?>9B* z&iSUuwtq+L&Z46i>%Mh;+_1r5|Bln|j<>($=I7rorW5f%^h(`PM{BzXP?f}4`}l=9 zGh_Xu2TmZzgWKE!42=6Z=S=;(DSm+i z`qtLf$@-sGhpjDov~UB)YHp;Kdss{XI;R$*3~DyQzzS0 z7PkREjE-RmzeFI!)`9%oeZ>Wb#w@3|MgotmawUHb3O z&v`G}=GXl?`6$(L)BJvguchS|)45|Iea{Yy8r)vpTF|tqWC&h-&rN`_xII` z2b9k<+~~bM_jcOW%*)5t&q%R1-uPnm`$OkNckqDfa#%ceI_TcipWi90e(hhJUD=z6 zx%zkVR$i04s~Z$kRzF=YHmbV5`r?B=S?iK}hplpQv+nKrnSLd_*!RWyz182N*6;l` zt8WMM*20!~XID+KyS|VOIg>ACxpmU-hFtxh!nf}qt9no4`LguJ{nz`-Gwt1X{ay3s z-!iAfTfc92vu)46|L*I`^|TEm)E=e{bqjBb?#qKJ3spCtE+?K zdt~C;*;?ODhe=NQwJvV&Dy4VKOH5XC9j$wz*=|ea>9C&xwc6q9t|Y!UH@Xzju6Wce=)^VuqX$z~^LW;ptXiY=?(vc@ z)|2LGO<`Z~Id#{wr=SBc^yfMoy*nx%A7fnn?2Pr7{C^KlxCV8p*n6r8&3|nJTCnUh z)9C25`}O5#pK;9(?8#?6AUGXVM>_sr*;nk8TaQ z{WzaNYK7S%&-$2~Wh*ph3@;qmuS<^I+lRoNncLMP&$DeBm_Wrv^pysrlrznQaPdC!k}wp(&*53CAZz3KdHbA9373(J?xH2G6) zzIEM`Hv;CCJn@bUEPI?8ICqu*5}Me+z){ifz;;v7wWsf7nDpX((&kgn@z^@I-B;VW zOjluR+oaQB{emTyE~32)+FdJ-ds?Y)mwj5H9qVn8`6Tn6PPw$|yFIK=6ou+e{5SgmM{!&AmIrraA z-Fjt7r4eWU0{!qb*ZD~=m0v_O>n;B*(zn3f>V~G$!P?-y<562aSf_mB@V@jqHKX&v z|K1N$Y;vamLpI0G08RfjvU7OodoUk^ zf$i_5>kHI9CO94h(-QKP8vH&vnJf?^P;-U#q>cs1)u#m7gScR8zGU0LaRZ_ll? z{e6q&4A*rM(YZ7p>IS%(!>^&*}gkIYZD; z9H^~-^Dpyz&;ao4hAVsLu2?Zy*<^M2b*tZhlDQ^rUw3KujX1u@m-UkkoAj0^n}EX7 zX4b#J=}(r;;aH&BbYOmoj`O8?Pi$6zBc+pN$$p+05-K&|p%-zX2TVRe-EEek7k7th zzcoHTTWI%Im6+a}zP_(|IQe9neM`PL`ha zW&cSD$LW{ff)@B#?Q8fKI3=ZPj)#-q>A0>L?x%N3uw7pXT7k#F_?Xk9UedrW$pSoq z`c7d&z_!_by$gzE?Eidl-o_(o^k$muWd2`Kmn>&{RH$6~(q{Ui?c0P!f+g|S=fo)J z?3wx?S|y#=HDy-x^pgwyJ&GoNs451nZV)KoWmI{w?xmIm7n6cO63deQ1=d^HY&YE( z(~CJ#T^C!jK;C$gZ(Oz20mj?^W=#2KE~)(D--G_2pqQHD^6RqQ;>ndJf79#rxDFP( z2b{5KUgpkmtZxEn6v)Bh*Xag$E4uMOXi<}Ely&*LIXh~9Z!@X=r*&$&e*87ZW;Wf= z->o{I?|0u-@i$Yp(<*hv!1>FRLWwTrPBVw{;TJXPfF)`9Dmm{*T4?ko3FQ8UzJloynm99a^)>e z^`s5jfAfvpEN}u5w854so<-J)a0Ddi-8xwD|f9x z!G7VTO%8a(={Tp%RN4C*laHsY{t|sZfB)ZWTRbKzJ^s5d;2rB$&$~jC&U?yDTy2$* zE8)m55ql!;#P@tLp?Ux0vU0gu?@VjqKJamR9%vdv;Q=RT)aPO^2NR3KfyFF-C;GBq zhbgno5X!r?<>gA3PNCk3vhfVR?k&hJo3w@FLDbFZEJja%F0@neofWdJA5=n0eMxY; zu=pGE_0k7SMU|cv|4Y_yHx*G3uh(%pWNo?t?A+y`)sG?NN)iGLjQxTW?3(t~|E~)c zc)EOvdib3kg}xF$yk4%s^MdrWY_dA%R(G}6fxqPm5;ybmULg= zUbHl4uJ137swS2_n`NUmu*4WO)z!~nf5BesacN>fleKvSpVa#2=k31PntSR_S}Bza zS;}hxN;`{xB+7u=19DyodvokS11u(4y3x5Ce%)Kh@Uy{AOiChFX6g*2sy7ysK{(sfV-byFq$ z6y`nrchDA826Ch_{a?vZ_wv%xMKwP^X@#&a-psE0GWPJHLlx^kH6GNMRP*-qlK!XO zlNPG%X1+3i(mHL)i4{kdCbJ3sn>0sQ&F<57wSKl0*2hj8H0jM=5mI|;|AdbRt@Ugy zRh)jvJ&9C$>al9#lCKY|ZZ7{2HtDp-5AK#umF20@4R#>Q3#1uUUgW(t{K3tnAmGKq z7r24lvqD-mGxyh*muhM+WbP+;UAn(SW$t&Ae>0DCvZ$$@+p}zXtNTxT#hqf_?KY14 zpC^TddU{R#V3PcnH~Yd<1@i*=63NDo^Sa~RIbJ_r^`d6Kn7XF_q`S->6+C{m(dz`&T!`Qh~2$wsj^ zHl=po*jKw-BVa*;&sL*S-i0cEW4$hEPrAgZQe(0*RV{s=a;DcOJI??AO($uoS)Sad z;x{J(v}`bBO+?@ntxzw}-5N@9Hh*4z-#%Ytt>g5q{JZu){843>|M`TGdK>qo%jYYj zY{bo_HOtk3w}^)TO@EGKJyMAC}0xI7+Cfd`>om6#Xw!_udlD0_b%V~ zPh-`iyqrCDR>zbdO7MOc6!QbM4H)A&7j*4jzobA8lnyPN8{97}-ELW&BqcIAPfMcp z?8`^JQ)E6qdmD4)Rehvd)BzUIkW1Z_jrJ5ho{NHC0$wE@ z;Q}?vj|n(5<@tmk5CjEi$25lb$7M@nSBUs@i|I~U~^)jJN5k054&$i@{cJ05LT4ZgJ0+r6@V_3fA6-rhd1q&7XZh_f^{ z#{Yg^LcKbo30xj_G+_uVgJW%HQ>^nfk~l&ALOz&kU5Oy0yA`PpPj7k&*gO_ zW%bpS`d?2>R9-D_Q}N-Bu)od6<$j0bwjI5E=k}IN<$Lw_j~x0Lr`CT16ei%l6@+oe z>49!h$S;k!nMSE8{AO0m^8fw$x%>0;^ZTP%mj_(+bbTW8+J7>S{kI#*m*(50$Od&|oiYjYk6m#~tql3s$KV-rG~D_SDJow^8Du7GBNZWp|c$g|B$IHhg{Dh1y4D ztXs_FIj!s_g1Rk84tS?n5aC+%fq&m<{=-rRp&0;!5R(PyXsSTUgGuTK4FlXkpiJd?LuIv(T}g!1kBTnLu@>&g5a&447;3A4`aSgGWBeum-V z(%;{57YnP-JXibqthtzP`@jYr+$;$}~j{myY0(C=*0LSEoELIK* zEu00LMEoZ8wzxZQa*;81k-6+D6MSi6tNYs@6}FF_hrg_7Z@GT#)3$))%6-`{cT9gG zKS^8hjQB!#|Ay|PrD2TE_kO=8%*@6Uu<%yI+~i|D54T=TKR?Iv@cB*KrkP|0P1KDx zn`o9BHBlo_sqpPB(}US_A0O>j4_fMVH2c}nxz^=Jb{0QBve3Ex$ho=JTYo<5R*ce9 zXycWBc6#MHd-cjsPaa)T{io-i(E{VZX>^mWcroP#VS2&j_GE{nUP5hu?Az%4rcE2W1>tW@0-X6~;=qNpWBCGp_ zZy z{M&^;pE%}O84+>guFBkczu>h;r)q~E>6JFmd01Z@RQKwNW_8J2;jgyU-#VJv`EPOl zxwp6a=+Dp3LwEddIOo*L)u|i3Eo0-;C4&DRwfuHVdOWdM&e0uQ^a;q#qNPNO~@t@aFCXo?RGJ-hZHowJ56KgZzxxgbUyTYN9C2sZ`{*X{#q8iCf8G_ zHRpZ1+k=l9XS%iCzYbj;Hgksd%P%iab?fi5XqEVEGD^D(6sP%qx&{D5T)90VG^|a)^>#p_RzM>%7p);ymO!v%PY{6WZO~fZRtE9x z>h>q;LhFjwJz_oOZ51xCcv@5yn_G#{iIu7D~U?{O5M;zF>iY8PlIV z8ns~=)dn}2Ctp}TlOgwH+S8Mh-Cx#T+L9T3HgKi6`|ay16OM6OA%&KN?*rFQ@A$8F zvVC!%eIi#u?`!Wq>jyD8EKBk@#qJhgS{bbV^`?N1hU$UV$09kBW&TXN3m>~JHGC1a zulTv2DCe(hH{>$@$bnO|f(hpl&a)c?w>q*2P10XK@x!j7dDW3u74AEoocc)Q&65s& zk5er{59GQ^7rctdkk1DV%Uw-d5UcYojB8=KSnvy3mSpTH2hP+Za|B_Qb`sC{{Ail$eIGvxdL2H1fU8zMiN zDwp$3sBxQgO6U3mUmliOE-J4cznCFCrAPfhtLW|3--`bK`@5*}^RrcF9rimhWnNk$ z2wH++#0}bzxh#5n(z=HA3p4{)9q?ZP$*LE87&v#OJy6VA$8z+qIj6qQlzrj89Y$AW z%e0M7oRnW*d@L?{*UR7O@3XCHr`1pYQU7gI>S>p~ReP9~W<_&;@afo;dRnV+KG#vs zSyJm<%%?!xIStb}6&$}8y`Lp0?Y}eD_t5W|i+9dHuv>)beAA03{{n1e8O7s5?3}*8 zUcbNV-QC^QQcJEkSHIu;eM+lE*_(*eU8P!KCQWsr={y@COR68pF?n3LdpSJs^A-Wi zKkAspy0F z?v;nOphVE3$EfmR;qC9Ml%7w#%Bdn@8t!_-X0PiB)pO@|oICLO*-r6Ga(n$Q&cEWg zAocXLq<43ATKODoOJTaYDpWZ2)Rc*9zSh4=I~x?o=h%5a0Nm79U|{kSbZB}fQu+So z(^YRKdu}kh*}tz>{Cx2JWGdn?q>mzx#E+eP^EEC6de%E1n6Rlt^GoJix#t#PJ~{Juc_O>vPWQQqRl?1Z}8D zIX^E}#ed!%J2mfVXYACxrg)^BofWF$H|NH^;u-ykiHYCN|CCVolPUc6CURr)alV70 z{gyi))_*R%zppkg{ih(SLC2F#x0ydS{Abo+E4_MP5yPp8%EzZ}&AzVYIoE0{`-avq zjy+#*%`{G5!oIiQp;O?x7|WMcrJ8?UE}!qR*sV8Z_V0-zX4BS+{DPEAcl-|oA1;6Q zo-f=jpm)!|#uo1O%5{Z{=ITao+kNPy*?;@sWj@~~PJY+IDa+|FCy z-rQ6c(~VM@rWdRA@7HVngRd=PuT@RlpX*UIsphfK{k_lf%(*(!O|OK>O4M$gvLxf; zqV{chcW0@ko|@7bdb_!AS5Q_g95_9xPqsIK6JUBY1eB zqM5<%!rqJhey)KtdCseKzMjIo>5Z6Hh)2rFNv=~g0uRZ3)C*eDQTt^6%uCzy@9Tl) z4nbASvC_HS9m@R=))}>?bNmvVpA_d8Lni_^JIp3SaDCx9l3 zqD_KQ*2e9^s`mIV(QvM2UQ7&@^E>#gWQn#T^}u&rFiYv38qfD1Rv8x*M16J?C?i!@EUpTYv3s39ch|1b zciUO~eA~V1_qN&R=2)()Wt{TTLj9FZ>-{ZtT?ggwO@94!!8@-Q8I8t5zB|e>CKvKb z&YP=6>V3Y~u4l>e>DgKBzn`1CvQ8DAW7O>u`qJ2Fw_^t%xEcfZWt2F5${)1a-4b`L zyIKAF?e@2(PckkFFIeQ0=XGUg!X))_CWAkZAM3Nvd#M;W^TOTVW+ydmjz1FsZN2=$ zGWWgl_I1whFE8)slH1GsKc}G@QmpX_c08UCJEK&daov%a)0x{}Us5UWs*#cyHf4u#LLX(H|(GN?N5`xr&e7* z>4x;u_SV)~uXZ1mKa#}`oAnLEc^k#!DjYedSAKq`iBz1bGI?Csdu8^kq?Hb<*jEPs zFF30iv_v3ehsT?{yTkwddcA&8&{8kIosYbBw{nY%8K<8U`BPN$KkjuK>y+j{GhK`> z8SLNl=A0zgI@!*5wlh~xILoW@ZC8ocrS+3PoT!Quikn@1`SbqWrZ4#5@2=?+3pVvFo5yh8_E{>M zpNZZy)8-c8vfY7;>bjoD{(3H~vfuJy$co!Kp4(@_QDnUcfaM z6yFa(JN9iabaFXASoPLc^i{os>3YNExphYx7@1x6RD3L%#b+74HS4NSNQ!@tynWo0 z^YiZ?`5`=~@R7F=5$}JHuk=#ns-5b~)gC*(v8ul+mieTsayD#D zL}1mO>H6_v+F>8u6y9Zp?DKCuoTxR$NgWc}zd02g%j@M=^(+w8^j~+$A>{7iHr~zG zXNYSCxlH%Gp~$2gwMF3e_I&Z$-`_+tFE2Blcyjg=k^T>21{W>+e||AMYJ6qkjG#$( z6IHl9z1+VlDg{2byuN;dO!v4htEZ091?1{PU!Hy@U)3;H`2ZMqb;zpi#;(NnL<*PXO`@0&c`bMOCUfBUV% zU;AXOXFZD(D(YCi=f7jq->+A``3VQT|8gsT-oefNPlP9(nfNehQr(Ota)0;tMzLI2 zmn2eqyiax=bGO#Jb+3&qz%%aa)EZdsUcI~g%Fk0?TPJ@4t@AoLS-ty6r|@bs*1vT^ z9`o(?O4!xx01cmJTw619ez>;%UaiOnryl>E63vy%yyx5Pmnw6s7f7G1n{-j7yjwM3 z(mCZfF$aRa+r3jP4j0jni>X>8ZT^Xk7dBAFz+@=s(9~D0ti}}M8XYNZk})B{(RjAQ zLZ{XvM>>U%#@GK%ef00MZO1(;A@yw>#=9Rssk}ZRM0eV9y#(LFmtObQ&lNZLJe}?Q zCN-~1(<9k51J4g3gY5eN%w}+#P2W z2yk`y7atco&uM)glh-$k>bG03yL^9lxAZtu^&}2Zb^7Mk*3;{L~cXs`~&@XGPcF?+3YXe)X ze0BtQ22()5$y11J!#srrDf`!EUHxHu-}dd1PT?}As*jIctE1H9H3c{HpPZyBJY6q# z*Ygus&+ohtRZ+2{)@QO>Z>`UCy}7ktPE}Q}`|if2N zPR#zGTKw$HH$7=1X}1fhms<27A+jFSs@y6!Rs6he<*I-2!E2+ox;#HO_o#IK9>t<( zXI36^aj@c-v(ebG>jP*g<=kBBqrbksetYE4p;m6jm)$QHJvlk~HfQa-J3Cqb&+b3d z*bmw;?lG~c*r$9;&CgGr@^wEP_k6kJ{q0)LnF|xbrv3TR{ls_@zsH9A8}{^N`mWl+ z^F5(bYiXvJ$1JJM0gLuc?u*xr-Bl8Eb5rV1Z`LggoGX3=eY~ctS|7*MWAN?t1~%I= zHw$K14eDUasJHKEaP(A8-}3Ec@9+6G$5u(H-nq8OwR_FQ#qQB2OgUHAMqjV`^YOT@ z*OaM8U+C`#9U;{#WxC1k&j;u1hlg6P?JR!&=)1uK4E z+1LOnoNAN=o?VW#&=lePFwHHd#Iy48-V2qxN-i#Pb)BXY`DY$m-Io`Eh0o4N7Ctz@ z`1?fg#h*LM-^cy-h-bQSJp1}O&3@Nb#&t_#7P)YOwnkS^v2||a(K_RC(K7iM&&O}K z^Sf=Uzj<6#59C}QTGyYl-DU2=bzR>V&38Bye5N-aG#laE&L_IF=&8}Ya7n%(wjBNA zoZCL;EKfY##=831yw~bJGZbc-=j(+o_e$NvSAW;)-?^x)$9LH`xGo4;5&*8z?kNcT ziOnV#w-1@VfRZT3MZt!~oIY z-wT3;!nJJDFG>}3f79Cjf}4BsvffJ>yF&L=6bk>IwR*4l*XNE0c5W1U@am`9x3A20 z7pK==>k`%OsR|3RaE_1h3cS57H~QsYtGYiGn)_Y`1#L)he97~o@}%_Z;8y4muhS%k zZIRq3^S)bVT;3M?>E_1(%a5O)o=&>8CG*kL@VJfIN3XAojqZ`P4*T$8=H=eyBI{#! zhn2j#axydg-S+droAxWu^bI;^@;v6%d4*5A^-cy}{`-8Xo{iRBn ze#9N`{{g949263mJT5T1i3^E;vMMnV7kps)z~oVCcys=xC7lZvRrFQKo9D$;|9y2m zzW!}_E+cQ>=Xv$qo^F#;t|y#-tyVGj|7I0#AO4cd%X~qNon^Z-Tk7|S?|L&$#Z%~} z*3?&r?Ou3&bg~2$xD5wtS)TlV%9^Av_@F7u#;EO?5z`)f>-AfoZhd898~kCG|G$~R zYg128YudI)DCWbt1J~x&+;Y8i(c%7`XF~O9Htv^hmmJSDXTKb4a>!m(`NhXaiS6Oa zR^oo3t_NgjY?6c8r(af`U8WTmR!+=5)WW%TUF`0tkh^i$FP&w7^I=zn)J^l9_rovk zjk`3}e^sTQy{De8@z2f4@9ymEv*pe+i~;on&#%6{W4ZtQI4kBVy+dcKQyvO}UEjdT zV$hW5q(9^B;l!f#?KkxfS;uq4?5~UEk+X>aono@*->=t?=GT9D|KafKr2YT@RewAx z9{=OfCgJB(6c=ZEvQ1JcJH*I;Gsbb_6xElWMW>JK2wV5$eewl4H;1DfRTUOR!AX6w zB_CdZX4k>qVR3EXKDJWAwZV^lr&;c;D^VK~8kL(XSBI_Ll)<&{2dVQXb}e!rVyQvB@9rQbQXx8>$JB?S8NzvOul>7nubVv`u8^aV}Y zt4^59WS@A8+w9N8$sbJe?%V*ah*j1!@K8yZbcfyqS!+Pc7JhnZvHCMz6Zv3gNAv(5JTK9Pqj--DJ%UK4-)^Yim)Rqtsb zAB%K?pYxZ*KRe>yWWuCBVVR`WysuoMS{Zxi-_2MPvNFhMzG(FI?Dcz}X^D7TSZaGa zfCV%=3o?B{ql4|HLYL#GO>!)z&v8%nzr8tfx!>GNzncF3d_F%Kw83PahR43;zb5W0 zk(#$Nz%a0n>2Fw({M};yvvVwiU)R2IOI{hYbke^&zH=-thH8Kg1f9!x_xf??r;cuO zKsJC&#$TK&%9CxnRy9`m<3X@obFD&O@Ba4X<>j@Ya}qseQVcpTY@FYBcdA|P!o@btN9s1dm!8+#C}!OV8f*Gh zJWa)O(hXkevSSYqw=XST@Oy&2GHjGtA&P0mqdsY8vBvoxg8gNC{WgV83wmKV{lKfM zt6k?>m4b$Vj`Yb|Z?TA49j3c6{k+`8wbJ|{(ziEFO#kcYH|dM2;WnMU8(IF}-`KJV z+-%C3I`4{m^cv58?ecebE|ofg$7Mjv3ws@ATxW8!IVSL+wlC64>T%$MzL-VcmD(E9 zYE`CtR)n+9>q z^Y?z87O^E`qSDM+PS^Oun#j#uS``|>OVvxKYKQyj#O;a5 z$^mtO9v|YU7h#_0{#ynVH66*Vn}^{kgvJzu_js2}ih%eM0Q4JX5~A z{`&HA>%G}|CT7*&a#YV>dcXhwJ1ZG!^SqFQNpnxNv+aU3n?QBpfq14rmtwn@sGsx@ znzwjQ>yxMk{l_(T^@QR~Ea$dtPk*#^fBvLBE}uj^)#~S#{HRGgqWpu|V;k!U*Q4D_ z&s(hyTbuRv_ICf*+?M-&%(JhZNtfq+xNFv*9}P<;9R5D1^I7Gw&MW_T`1!9_`R}?Y zp({J_l+7moN|Rf;yqvo_<+(p_f|{0ld>OJY?7h1`ucz;N{^wo6aqG`so%5qY`O*Cv z8{v=tn@jdM9diG-^SX5ZhH&+jjzJf74_>-bY?yF>;o_=L?X`NBJ?4V81Vn61Y7N^h z)bnw=&z=wEawm&~R=!@Z`eV8G(c}~jdrwWFe~Wx?-CuR2Q@C3@{KsNuT{WgX&t_eZ zJDs!TcT?FI`P5O{g zTyywc{=KUW+vjMzA3CaZU-6~;p|A24Wd{T$zlSPV@yS{(`E6FxyBD+%`(&-})!VU$ z6;>_&{OoM-!RBt)MbH}AVGGL=Uul+j0S3n7oFxkUamt!+cBu0gCVY8uaZ&8+plL^fWe||1Xa(%hF>zPpNsdq|@`G~a4z`~>&FkkPDFWm9?uYjN;M~h6Orbyw-4#8PJ)!h8E4<7~XY%P2H=+W=0==pZFEWTUC_4ohT z6nA(-8V{pLXZJqsx?eBVRck{wtF1o-S-%Q0@k1+vP)WSTLm7brb;fyaCyR}LzO7i8 zsd(X*-^Vk?=R0;5-}K$P)}>P@>C_a>Z6Eeubm~6P$jt7foglyX@4w&gYi%y?zx?C0 z#db5-_-6^yjN9)Ce2@lZ9TU*F45N`xL&IT~v`K%tRL*)-yxMID>iI4L_3D3oc-Z&j z$l@0^v(9B-zP#N3eFwk6s`&?&ddFzU>1r|F^UJxqD)iDqn_n*$f6I}CEm~k;yboGH z*(-dGiBVtR!NZM4D!!gQx1KF8etz!J)$sVzo{zuZ@6Y$&UjO^;cG=I2ZC?csaQtds zbG+}VFXNN#UQ@MBhOY`-yh!lNYANRiO;89hFir<`eK+wn?^aM~WXLc6%H!!Qbg%qY z$G5lJ?{@_)_3HGUZD#q%ze_~($OJ{_H=5riJ{B+G-XgiTpppCLVppLZpxv6Wd?8!1 zuC7`czzrUa18pOY1T84Ny_JK9B}vs_=DCVFOIS}{i#UI+;Lxtp*KeN8xZY-c^@g4L z%RRC&|NiXRYccCOM*_>=dvda7IWu;Yy`42FZ(Y#RE}^}TeNKMR~0Ff3?T0ZRqT-0QK6ITvPSZ#Buh1Udqf$q-&k&S#mh;5R4F z@@9t)fd`6Pi&WlEh$%NpoA)Vhu^TVwR3`Pi8*vM@}J=x)3 zpkTnn&M(LF#)&`n==p2?_WxF>EZSB2y6eZs$J!Uy2EV+z+KX$QcHpYX+~8%#3>+(z z8(3mxqchkT^#y)RY0_}rbmCifV`bC~ssx|L@uC{3)(im-$Mk?pi1T$|azh4qSvfICRWoIan06Ddl96 z?_8^^Mr+qbZ9SEBb=B0zHFMs{Z@-a$W5dGC?GwW4GrrteB&q22?z;NC3a4xxt=@}g zWJP=K9hQfkVc*fo;C7)fzkz|{ht~r6xhHOK%Kh?{N%Z;0D^ILSUv>1`|BGn-)lfQ3 zFE*-2+T2gZy6nulKlAkC_cfG0bo$ByDkeaKnP1y@wthIwZ{N`^uCMj+-Ph~!;fut* zkP9^j29`zY22FKql2T6U&;9!P`u1~kt(O-u=xW^M7T4PnSNk%&I%2dB&7zyk~^S7 zz8VEyc!--S?i4+7bkn+rTJKf8r-^t^*PFUDXw|%;r>8jMo>zZ)5qNOlw!FJhOMGSq zt>V?-o^wEd{~x6a727LP@4G;!i>W4-zqt{3q*pq;GfxAuwgS8m5L5zGSTrvB@_MU^ zmfOrfmn;(wFkJ7sr5mx~z^f}OCx`ARNZg-f(zyA0&4XEN)AeGD&h8anvsm44&W3sQ z|0+|z-@Udry1De?iq|V|%;gGOi|_y>YC{A)9J-FroUkKwO~l1pd#kqx>i^hi>70FS zEoj#~sB3p>x_*A@nHhnuP7kc+hG^c`3S883l=G5!d`;s2=&QD%A*>s_P8#q3|LL^; z+LD)-G!r9tm*t)>=;CQf+q)v6l_mCSyz&dMm-q!bo;OMefDU8X%#t_Z=QWkx9&A=G zPwlDv{N_=Pa~qFf{=T2fCa?REV-31f;o7D9#s5G9dHetW%N93WtS@uqSg-V3<+X3W zMy`+c`1E zW$R^?id@kCYqfcm&m@<}PE4!+{OoMf`FXZY%LKdkR)4?s|Cw_5HuH^v2MrERvM$g2 zJwrQOPf$)SPyKPtlOr~u9q*IB+>i=CUjOByd$P6eiu?cn{eJ(bRXmQvt9_;Te5=w^ z>l#7FWU1;+(~Z7%BTC>P%bhKm!3Ra(t8PEGG^Aujxikh#tB5Nz>JB^Q^RT*WA>i+yF+?apg?%?9Om>GTje~j%e zO^N+2VP9AC8+4gS^*{NapHC>OUx|6s-Cv_8zWwq4&xU?;EWS+?etklD{_)L>KYpB0 z?!RLjpLSrXcDPva^K(;Iev*sbqQ7H?ZS}T_UoV$Wy;CF@+5vJ;QJD-QB`0&4Yb93`@^#VS5yBN#$A0HpDZVD}N z1f3ely5DQvFOl}m@Ls6`1JgXEfYwDfR~vo&7H*!OZ&vjs6Ch~`LdLi& zs8{Y$x!~e?wbZpsWaEma?fc)qvAFNZ6!PXw)vJ}ur>M;hd~dGhlMd=PAMB_#KHK?o zXYq5LRgMX=RwXB1U0T}x>B$_+%E~WuPTK!|vsvq%>3dPjg1hroAhR#egd8SX6#r(M z*VrJ=`DMX^Uo*ud)-DviyQ@@q%e^Zm*PU+7-R`lw%k(-aL3pxM)dDauZEn#b; zIu|;(cZp~QStQ!I&7Lx&JNx>&o34!F`f)k(^}k-K9~Au`y8YAB)7`AxVk^uZulQH= z^wiB5Rr7mMNh?$427u2^PRe2e$AE|x?lCmmV z7=%jtOH>YlT1p)1_3e{Q3@^UlQ~8|5 zf$BxuRerCp`le>AiJ#N(`Ng|Usi%*CR{omh-bz`szR}{^p335n|9-#kzO%EKy=dp$ zlFuTgd4JwZo9EqdpSMZQ((2sFANBwLrk~e%pl@uExqR!hZ#~Ta<_hcT==i+3vC;X1 zcw}6DNI+1|-Cdz&Ggv(y^4;`W2;MW`a6p=6!h-6>@`9`!J7zkR7R__NTs%X@rIkz6 zXetnb~^3|DBj;``dZr2M(Lij&jjm zU834u`~UyD9cst^IA>kVPL|xQ;yqn2)}8gTx6z1(l|dEF3_>OOUz8UyFs>JnaA@4~ z{8)m8UjY+kEQa;O7@VIZ1W1_QB7E zUtU~HdU|T=Kh4q)Z%i^T-6&=L^yK8@1>#k{%8u7hOJ9Q&6D$4cw?_0IqdiDC{esgzy3ax!+@h*I8LfHM)>otRx z?ASD+@9!*|%1_$&?-v~A4X=}vm92eR{dMQV8?*awzGZ*T9{gZ&zg<^Q|7`9{%kqR) zu5&&cofdho@N8<33=@Y!0|SKU<6Pms;p~LnyXKl&vmJ40NnTL>{oSYc)(3Atk>59` z!}k8)j~6%IXA$XPVB%m2P_SyKU3Qv7;Xxha*M;ZVir#CM--~|x@8hCYJFyi}TeGe_ zIM`f!=kSl+%k1twyzp1_%AI3vV2d2~FzH<2!Wywa zSe8TKfofxXYV!OkyLVmw&8KfVXPeRkQO2zn^9_^TLKZr;?zxoWerx5tbq_v-#ZLRb z@o;H?4Jcq6jfbNVP-tk7Yi#3{j;p-3v#PrK!uCb3 z-Ln)byuvP>c5%JZ2o5VS(ZJcbX49nYPv0GRJV8VF`hg=3%l+myeV5s)QZ>h_G%NUV z{PiO#p0ePGd?&u+;9uV*tsDvs4vU!5pZfpT{@z*SulRjag{3Z0`J7XMNR? zm|tIBE`D})cKRazo2ja=?n!06OLAsl1VsplI53?ltI;m%-Lg2=#q&-?{Z~6)wfD}| z+pYH}|Mo7*SNkrp^ZAtBza)-)oxSVkgLucziD_qNb^iVR{qw3y4yIS1f3iJx-pky< z3o;67Xgs&b{EMt?p(E2J9PJo?(TG{n3k8D zHpHC!`~ANDG~H;iLz|{JKjyl!BJl90t!)-nW_KK(*}xnLO0+5yoXx(u?p!_FaHh|W zmD)D>rNRf^Kl!)s&iu*Mo;#0!*V?g8q9#CW%QgRvfxAjFKVA)w-*{`AX2G{Nk%0>w z7$;vZ42^a4wFJj5gs5;_ur%k1l)dgTn>*rPZK}5#%+o3VI_RqT$15?{*4i!4 zD{_415xdlDst`NB+?Jg-PfJu4<_qdyTIT!ugvC+e?ER1oCMbR9`R~7)&bYp{SG&FF-qHnPk6#sU zeHF(LcT4Nkv2|q=({FSiPCDAvDXi|75wR$!We;=RjmH9RIxFqvHYvi&CJqIGjK(#a zzUw}*3wy_Y*khHi+K0RquTNZU{c-$Lw*1c3=ZnNYRj`zPyuBlQb(n9=u98mCZETIx zbfahOdB;}qCu-48u*1YyCq>%y9R}s<1>7l<8NQ#2-ODuR>8tB!KE0mH*ch1aeZTr^ zzv!#%H~WJB{Z8Mx`uOahsloMg0?Ys8znRW=^sW11x86m|{N}zozE1M}z1bTKA~>5U|S{%CN#=PmS?##F#hLQVcoU5^;c}sd6n;XiuSv{t6X0<|Mjcy zuikz>seC2(YlP9)Iq&VCt`obJzOGLGcj(;(zJLFpT>XE)e_d#~e|Y@WL)Gi=^t-Ki zyKMDZUG0$fOab*1KEA!SulDzfiOTN3w$(4QDg$NWPft&~gW9DbQ$1WWK^{@Wx z$Nl|x=<51c5?fc#U%CGI`Z`V$)}Fuzj_yCo1H7TJI|9xHpLaX2S1$Hy;fg{X zP$3Ko2vAzu5vH&==cam*`Oj17O{Jnb5dl8)?P5WLPa^tpcQR%NE%VWQc5d$J(+{Lr zI$|9-1XZ@#)Z+Nh&3bG{YT`W0;f?GwsGZg_C8ggs!q`Pnxwa?a}TCEwrO&Cb3XwZE=*a`#^CQdRG1K0UJ5*TQx; z*L`BNzL`FzrmqU+$K~C>=i+w6V2YT>siWv9)1qXPrEH z&%RVtGss0JdYeymeN(^#^ZPZ*S3W=EJ^HLJ(*K=9?9UQ0gT-vCzm=@Y-ltdo<;6v{<2mbAuk(`vXHihf1chXypv1c? zNhVi{f|vX09_y8U{==#G^|iH1)!*KziPv1e61pkH)BT?81B;jzZP4t{NyFb32F47s zuFxtBRPQu)a8H?{8zKKn>DJ1}$w^5^-re2ZtIIfDKR&N$qj-L7?(J=+x6+e$@P%F3 zQ&~Lu@ip^D;hMaVpnw{4pSz?uYoV;)PG)w#k^;}^1s7j!%zd~e{JG^TzxSa2t9!p( zZ%5;Gt-U2LCuzj)+H$h6`pEaqjIu6J10e3;NSU^E*E6?*@_UubXBemZxm@pfzxVsR zlSkv4N>|Qaur>dFT+Yo+s*B{}R@8u662;HXEIamAzw+#g^4S}}MFA*Gz|nk*MQ)nv z+bO$Ow)!sm3cBFk>F$QJytgMPI>#gmS)1`nnFwTGTT{r~n|<3L`O!e?Zyu{hrT#uf^(We|<6B`CxNM_}^b&TdR&pME_v|&CRO1`)>U2 zx*%P^svnl;L2lW`+I2!`T2|D88*w~$i_hC8eSUU!U2OioZ@03y{eIE1HEKou*Q?>{ zO1o1I$5lLJot*rw@2&PECY01Rfyw`LTzpB=K?%Q^uiP@?ZrrQ=9y^(P--K6H9}cn~ z?U6Lzb0A|&?6v`3EP^{FQ+ps0bRSdJ+Uyf>q- z-{Dy2Ia%$|_4xX)PYwmxPTpJb@sXN%t>X2ix4vI=m#@4OUcUJH+GzDlOFV@)CC;cf zu~a*+EwN%|>p3M@!UZ)qJ($+F?7UHs5@=lVBH(Ve!Q-cMEsNbu^6uOal%Jct^xmVl zSM6I~$XxNa|9j<0gzog@3TKaS4R&QDGaBBra-EQ?TUvZDefgTAr>8nawZmS-l)LU( zvo3b`te79Iq0_6D{W)*{U#4)ihk3$*2FApnt&*Q#EmlD-jt+=69)DVAbmnO5w^pCs zWp9=C+7++)cX6?M_lp-9Z_})fuXAeU>ic@%n{|8U+ z&`F0{IOC!Yw_d%b8@;XL)6>(lWB#MNSd0|GP0AB|%SxxMYn^?!s7p*&OH4mb=1S>(`@eQoUshCnx#;ez$K=Qv0&qy+xli=yiwvBuh?Sh|NTr)5U=@I z8e`l2=h^K1Yp>Q6?|FS?rSOZ7uWoK$esW{w{o}=gu}IBzg$qp1rFvK1Oqpt!?Dp{> zyF5$P!s!vu>wmvB2hDd+<~}&#)vK$k!xtQ17r59>vGV55uqQiTE!IGZ*9XFkrOG>= znu&AX5>xqpzkdIZhwbuAdk<{B^>h9He^DXpVj^enJty%4G~8WwxcvBB>vBI4?XWXX zcGx_byt5+@l!d{?3Ai^K3noj-i0YF(ZA_xJbN zFZOA_1|2JLvR`S=#OrYv9nPne$iXs?0|O&J_mYXZ|IfT@in{)D`~AAzpm8y6@u;}0 zD;E|zx9(awZ(ZTWXuo|mKett%^e>OL|Np0Wa`HyUzVImi^PVQM2$LEexNJ14_nv?E z$ou-wv$ITv)&1vP*=xpCQn}czS4dPV#9*g|&xUpFa#b1^>MKEaex59xA#*~q*AFSR zJP2%b+$DC+>Qv?Xz2BMkPAJ>;d2{-CF+)Q`HSvy**S>x_t$)6B*ZMrY{lUxq)Q&&! z?LX&hB8}vT0~{;PFW0-YamBSjx2am8M{aG+zPo4Hr_kG=>6nRDrCF1^kGy{UEBEWG ztHm|#x0u$z)&jIjC8e(lU!Qkre{4dUnN=5}$ZR;yGH>Er+qKDwYZv!`+95}l^0v2Y z7reZrn)u`D?IU6fy;JS?ac|d;vw#2M;^Ier*6$2^zDyuRe>Ydq;abYx@laTEP=4L!xib+Nl|$r&$C zdfur%PeSg=L}}x+o|79R-%R}3m4@u7=*D|~y6X;UmYbiubrERS}Ji{G#N zz4r7pw|}{Q@9*tB9DBg^(VoyEm9QV>CX?RX4EDE8z4TXA{CuCX@Bk?5&VTJ-S(}BqMAh<1ALpj@vj>P{K58 zN=IMcHXF0NuE{@cP11|qC4ctB&h68-->W+Pq@wQOqRO6SNICpLX5*PnUoYR;^y1WX z{rM3)3Kmv}+u3E!tg_xx6*D*bSX{dGs<5?EKU{Y`bbq|}@yo~w$B;7nPxc=$)`}N|Wn*&d}M!UR@+Fh2r!2QpYlam(( zEOb&kzF?Yqy0cU-A{RNduy~!QiY->&F=K|r#>&sn9P}6Yl*auP1fA)sCY~+09&}Sr z`uVxm>0LLbeqABWu*_@fsVfn4CVck($8k0{q#I#Y!*Uj@Q`hEQ{P}A8T+n&gFHf=d z-j@RHX9G*wp;I*M|Mi?K7Qi- z;`YAhn~mctpNeWHFMd7aBinQHRY=wE0b?f96z}qzu@7EY{h#PAC#dc>=fllQ$7}EY ze7%0Z%ke(hQr&GO(>_n@St|V~#`bCH(XgPWI&ph$)H0{;aD97g>t)Mno>RZhN>B5Y zLN1CJ8|yrEqkR6=+}M!VHeLDPn!Iy!EEjo9RPxlF=kvd2cF$He&LcI_!i6jHrX34r zYFQDqwCm)?`dbHV+(n_a1}I{8L_H|Gx$CH!m~GfAjnGvh=1s<5wl~G?t(qBA6S+3K zr$_i}*|#HR%JK&T$~W-;D*N!j5maTbPG0_aN71@@x+py#KCUg3Qg=UdE4aI>l>1lJ z36KBbYok=(?fac4+pRe_Rc6Y@8#*l!@%c~r?aKNkjZ!)$8Wt9--mm%Gd#=!L)tcI( zGn?84*kzEt`J8o8D*qMjsh+B*-RjoKJvU7~C1Solu;%hMyV_q8l9vUNUmI7}>=IbN z>e8nl_D*Zm*X+}e+H%7Dv3#DpTd$PpwAdMsjrEU2JSaelX&dc;&}}u&GdeeaQ`zg- z%$D^2-rk4nq%F=bI`Hf3YuBHjo^I`*f7ZfE_k4chW3R02&2`>#m7ksny7$R!)OdUU zFle~(r1#|+J(~o@=ODXQouw+nYu;9sSIlfYAKqsjbG0@8b3$kJM#I=+NqoHFXA6W4 z?=JBa7Vph?GV9Zi$NkZ=@v_IiUJ{TOK`ts@vs~$YaHYw^{Zh{Eo<*+RT}!>EyX8$4 zoG{Bg_m)ahQc_O;^k+MMMo(M*JMXTx>2|}o&Hw)XW>+Z^diM;}-}aiKk!Z9`uJCS- zS2I#+wm~rZ6ZZIE7>Oe)!=0xa`dhMJcnK70HQ9cK3+O?2DNFs_W{JQ#;>oyM5&2vwIm)c)|WUA}8} z-ma5R4xRLhh6hbKKF2UN}!Z*C^3%!@Aw?c6pzfXB+)EsA16~;ehk~ zptE$ekJ#m7B)870CVW(@d}23U>SI zc&)i|aZRLg;jb^5*YxNz=drur zly+U6e&qSt+1ImbURbPKRlLyoBvMwtA^al0eBr{^prW~3P}!{_IrQPfFu&PmzAI)= zeJN$``!r|r(>v+=5z|HTgfoq)7a-f-)>j3&c;t}yDh$D zNWr7sfq^CHgk4=$(!s=~eQ$1V?vC7?R+;?t!Nah!cXw_+S#&%r_Hb&?l8*;WzfYJN zv8~$Y*O!+^@9nL&l}Y_I>)xtR?bU`$9`E=k*Woy;1780;aBiHn$>07~tj7zh{gt1e zJ^JwQ@UKl(Aip=Ua=Yv-dRn5BR5I=3=AMOWa=Z7%T^9Y`IW>4?km{lct`+@BcdFm- zwMy1oxoO^q2%AeWh!U!wdqsHXB(I>}zcnW&DC)S#h`qSKfB(jhJc`@wCLT}w^kVCm zQjWhoxA$dVU&rU(X5Mvwb9(=YIhMsY`V{-F-v9Jtl3cI%EJU6AK(Uc&)7tp98EdSj ziGU6zUK6qLkhC^S|F)vDvrL`t7M#~juG=d6YTZr$>KD5@*RQmEQvc5Ap;h7`mVUSS z_tI9EH_Z63FREQCdi}qTCmv51JL?V`h-gy05K{Je%Rv_Niz&Necb8RdF8BI9{lM$> z`}2w%leeyuG-BKQ`^lu$>5rzvWKlRq-vZ+h+IUR)K~S-tys$jYFj z2RlB7U5wpTa#3=+=hUTnaVL<5HygwnKW&<#TPDuF>)iU--P982aJse)x_AtUU^K{n_Kb!@ApU- z3k`#^HxUz6y~QSX3u~9^PWxE6o_(FD`fQ7%r%aQ+&oIlqWg!uJPwUs!@c6Alvv>9V zJaY2E!W=|;f6qN-N^C@``NQj_`*v0T`1bbp-l-3(S8R3fmlItZz5UwO8y6zaW#8LB zWy=?ZxjLzf*S*%GLYx(sk5B#Wt>c8njRVX6Aug)~MyrW&B_qbEqqhj_}l}_Gx z|5#W{ff2myXjsp3<+(!do~hSPF)4+wi%Gh;$dzyDU6J3{F4&KmH&SJ|ZfSVm|YFXw`F=BLnkIn@zvwv&)SmN9z=USB(S#0Gi`*?SEx%tiw8=|he8Llz!%H79TmRpIITC`~( z23ihmaERZ{x$E5Lc3$acHDa%J9e=M_-$M{=E21?qAm~9ho7f7ZU+m>bmg7*SL+Z^uDXzS%1y&E^DEi zFd~8GaI850^Iw)hqmM~sX#e+J6(1LU-&DZArQ-X$yNlA!&QcTS4tuprA$k4m-XBk| zTwu8pyMJv@_uAxF*Vn&q)IJm=e0zI-{%PYQhSEY&9tDU2--c)wx0V?{ET^TUou1|k zng@wFCbMA{=mxQ%B_0oN{AiVQ_kL2@dZ);cWrb|^A({0P9xbo`|BrF^DWUgy&1}3* zpEg^%&1DifUm^;tGd}ET*d;h;qRL&bNs)W2N_hs413aki7WnOB#7 z{q!gF$z8q`_FWQ{HIM%M{4Cp%l`mHL+uXViR4#v4cqx- zKOMN5w5$`fC+gzGi_6xXy#GYv{1d!(a^o&ENI7B#;)8J}+bxt8nbUX6&T zMT_L7akTrYJPv!6adXpBi}H6emb;mmgw=cmDnC6j+{v&Z=z5f-IDdiSuAqcz zACLJzzS(^KmDh{XX@_N(-nIQGGVQGO($`Y{Yv!yBUcT!Gm(l$#V!BZ;_MDrfwR->V z!xOH-=RE$22h9H*o2T?~TTpw|p6kneXP-$w$he~L+L}nG+LQyQEF^5wHm_N|?!Ufq z{Fe`c!i5u!)BQG zpSQ7SNowQi>H6JzvAbsYd{}$!>%N}u4E{KC$GlGp+SfPTO-@Qm(m7r(z;|bF_4X69 zOjlohed=9d{mGBo@=p|&zlX(7LuTWbO@}U)P0omY{`}nBXrK9Zwj7n)KHBNU?~4)9 zi@A|^Xx;BWwMJ!frm|nIEcZ>AxGvj%W6`eC*J*#M3X5A$Pt(0zE2|cEFVE8KRog^{pZ>Qmm)@X_T(t7+!l5G!^6Y2yML4x9}Zs^ zqvn}^78(*tP`hxPEVYB#o!}X{{$2&=T%iGLM z+fSOwUD+YvW3bKc-;d^aC8vJH^(A^OZ|Z=o_X1_w{ah=~bE{3wko^6#fsuL7?7zEq zJOz!3pPa02Zq_H3oHfs8-HdpBonKQ|ILLP!CTXXgp05A?(P|?jU(mrEIWyZV^5z%H z!b6uMLO3AbbgpF5rl%1}<5U&%JAhrYx?} zNl5vZd3)R1d)=qlmu}6wd+W)Z53Bl9YiA(2j6c;YF-57jQX?7iGHB9&H zyj`BZD{l784*m4!Qq-auPJ8qw_?0DWKU=X$Iugxz5a^6u`M_Qs^w-+Dc}_FH)0 zV2)5lc<`ZA>z%>oI%f!D_#m#aSW?T3YcI`bT^tW#gtIOwuJdK15KeO}j& zy1!Lt!)I;pwk~+ku;X!`wa-~$@uwEyUvs8hf{)-FU~DYfbmqN}%HgnAD`IzVyRol! z_jcnL@oja7S~!)wr|B%4l(+h8&J@GIYmGCOdDL@!*$$x^<) zSobY9cy*MI8%{&Lk*{+f9fbWu;n#YL@s zDpBQ<>u+<%p5yB{5E1*?JL&0`%*)4?8$0{}AG-W5+iv5hX{;*qUaG5(vN8yc%co4&zMc^%mfQqd?E}dS@tig))tk@f8LfT|I*p^tIQ`rNiENP_ z1rM8E+}OBy-IB<3%fl&mmVCH+)g|4B_&&3R2!R#x|3?f2OFlnr{Xj^5c>?E3N1(OAP{g-LJS zf98K}VK8GkBwBIr$eqwF8G+)lXWwO608W+7o>0c59xg;CcB=!m>!k_)IBNx0o*1 z$qUacR+itrGvx$p!R9|VCl}3ED~~m|x~qKpmF{<@m^uJV(o%2J__g=+->uz# zujr2Lxf^w&{##au?{Yu!x9PBa z`QCZI*elJxv&}fa1~P8%`FOQ##r9=(YjwLcIU0YkTFvVCt>oI(FEzr}JB9Sqe5@V7an-MPEGo*;%HaFP>SrUi<6o>*aUs&i#02WO&W< z%0jVMuZ|VNE69e_#y_7<+|=_(S*Mcs%J`zqCXaZhHD0%Nm9FmS>@=Jy5xvrT@7*7g zrvpzla=Z`>FlUR-Pudq;FOa-D?7@qRi=Fl!KG3rN^s5;AkyilJ3p6 zuiy7f`_}KHwcqcSD^-4ak~e#@&z9%rlEt!jY7#G)LHn2;YYwoh3595vF7clq=QGpj z=GP8}YL|?=ntp z$-L~e&BQRS?Nxwz;@;NR0+4*oBG94zVdp{@m6IxK{N`FE-QQRH?u1nBr7qAm;5#*+ z&wAdH?rUt_v~N>P8^;ch11ID)uRdRQ^Pev02ITE$1J!PCj*nySjVaN+AOdsif&(#! zxi_;+p6A%iHgS8FNI?0X`ad6!`>M?hdtIg4^wIAshl<*UOGj!>#EAcQ`Tk_Gf7D#( zKUH_yjs9KPeDfx#@?sHiP-tLEO_{%ahKJkaRf|Jb1|=PAVwIY{Ol0Xjqgk54YTH#e z-ai?!L%-p=RP49DhF>q^1xJ*m5F*;8shdYHXGBe_Kc z;$>Z?S7`;}B`Pz^PJ`RA_5W--SE)5_PCwrzrW-ZGPh;(s@5`p0SSr9WM?533JZ^JQ z-MW~aNB;f&Z5sRYpJv+kcXuCcyPdb$X!(!7GrrH|FU^8A70o%0M0m>0wNvw*W%8(* z-|mBd*vqDQXJ!~WKRGk=a<1p=exqq}1rZ`I4$95o@6cI{lsS>J!gU`SR}W?fpR~ zPL#XW_H8YAcqq?1rG8prn03W;aocY*9prA#zpVD`jQ+kKN}ncoaz|g-njOCVZ0^LI z^E{H>HhpK)C-dBO1P{kOn9!MGywB>&=lbVoXFoqAa$&dct4mA0RVE*8c~uwQS0ANk z%2K2BVMeEA@ZAd^KRi5qZ*GrF&QIljn@7hg^@4J5X+NGQo%<`LXrVNuP;q&)`T5$Y ztwP89<;x9Pxx+4Yi|K+U@H;}9W(4egWx3CH#~FbS3l9VccYm2NV@85+idc2^von%` z+j1hepDmx5=PxfGmtMjNj^xGzoL@{PrW{+V?Aj%g^y9-rvC9U0o0UFX^452?GVEFZ z&;QAebj~}XuIY%5KW5|ySE=4O}y|}V+ z@^WFv?WT1nCMf24u&mENJiTa5an2xL4y|Mlv;k}p4>&)=;y@w2mX*}FTMt3p-^y?pZi z*RS)ZHR|*hP4s!n;o`Sod#7vF)m5Q?4O%TPwWrUkJoaPG40V6Gi`#Oe4U>*=T-;fl zUika%cIkX)p~B_&&K{X;tYoeqU<|2I6FE)Ftv0TS-MvkjGg5#Xw3qs}ki*q^Ka0-G zhJ7g%V)`fe*y)*<3wSs1+Z*0vD-;+Dbu69?(jSUMQ zzvb9CKlV@Y%!|U1BIS?%1k)q&UlLX2YJY#*Iwhen;184i|38}zCf2kGa;wz+o3H$0 zp=slpPa6&=#yBgUU-|fWfBLE(_XnVbr4Efuiq%n)#$O}Mzb@ffeS25w>m$kiw$D7G z*K9GLmwe@K+6`!lb3mEt@}WPi@y=9S`RQq5v_5Fys{DR!)a?}I zV`3+ZugXt?+w+v^Y3`px+vilIoS!%M`MhY4&!Bx53-76c_Q4i@zgr&t&D5|h{Pl~6 zpDLDBa<~L7*x#9LSp4jaji7Sl&yq(+I=4MP3!1Fs6jqCvv2m^JqebqC|8yRIp63y# za0NCLe~l&1aAL@{wb9q3%!CgtKGr9z{ci8~xZ9men;-A+nHGC8%A!z&sZs35p@XkK z%(ql>?~{47e109*gPfTq)1RN2shqd_?Y0fiF2B3GyW4xZo@%UThdbyrArb8`oi%2e zear1rDt(!1TQ5~YV#!8nf!xHW6`u?$K0FY(ELAVRFZZ^Y`Ms%se^~^S|4w&iV9aLP ze(G@9j2Zsi;(9t)cIVyrr(5vvPvyr)-TGZ7nU^Ad?G0NSWx6rxD3`mYe*8Y2d9~jn zz26!N*z2xoHFj47%^@o^I4of)I??rA!h@@&O106qL)Cj)M~|fOF4f5H^|I2bHdi`A z9D?+jdudELDe{y#A_fvCbo8?9=v{MUM=)}4(&MmCw6}cV@ToNFMRG|108V^>}Wun*Y2U zqnBPQ)^%R84(BjDu#iI`AzopsPSW0!uD`0^?|nY^Dg5V>7yEV-|O_Ed%WgReGThb*=EEnS?)JC zYE8_}OVf*2&9~ZG^)>5qd7=LM*QWp-dy!^Y=} zSF5Pj|NHak`~CXw-v7S(+XpT6O4Z_gT>LytdG=$0j-CVRY~m@PbwrP*$Jc$lJLlC` zzTEr!VxOFtc=*cu)*Ds7T-Bbegf<3PO1LFz?W*qXD&0G;`tRz$=WV~wS?Q9q=H0>N zHY@@c^cKj~W@PyZl;5x2Zc+Mb%KK-b>&r53Z_8D)|0N=wUY&Yo=>@ryBCyF_L1BY$ zH6>Gbl)b)ocJ1+IS@A_+9AxZNc_Zim6WMgqrndP#yu*t*b4s zYR|PSc`;$f>vg;5%=`UV`+uZ;ticynaN~@T<)3cCm!B^pH>ZheZTxt7Tl#r9P%Cb^ zu<5;XC$4rkn6q@9NRz59zjWE({_S$jt6yt>e!U)l)b{(G$6w~i$NxNE@mOfVRA?(F zA^gCL&lj~rRy_E{qBDohEaSp~lP$SzcO9SAum~8a1w>sdx%5Q)rET>$p7dLf<_NI* z&9~FN^4?%_a`o1AdB+w_?}DZhg-1+o^ZVCL;@!XRQSgp}#N|TUKVN#=*5S?tTI0W( zY3h^4`q?ojzP`V2f8?oJd%IG>yE{8Qbk9{s@>+pH|2LCL^fz8jMo{rRXR_-bjqlIC zb#DqgbgWl;anKSELDlyzId56|Wu{sdKU<-{@5iCeYiiS5-%bAQrp~q82b5|)bn6tZ zz9XHjZ`sH+T`yK@s+#Yt67r@+@p-$>+orTO`-XefLIdFe zUnAQl$@C}huB<-rU#tAlkNs+@QvB)p9wD!lt_IWe3 z_g*^TJzbA;r-k{qYD2$0U$_;|SwMS8EHzpI5#O@+t!y!h-BprwxQ#dNf_iODqkT1l3l|C&43_liH;A_0x-IU)i5 zMTV26tayH6o_)RDOP!O>?iN3O%zfm?XO*hl(2&gZYV9evXIE}irJbAea$)4dp6DQ}kk^?#?*oQ53X3&bB-)J#pJBP~-R1*&DS?d!%=6kzu^f zwI?mhFZ3&DkW?pflggRMp3Ae$a$jAsIj8-6-CmbW2}oI|C$15^?9B6JLZ|F%fBjHX z1`X5)cgDs~Z|6Dd%+Pp*wQbg{;85F{MyW#fe?BzlKMM<%&AhW?V{mar($jsXkHYt! zsAvYP2v``pOz2eLVz-&6_RFkao^^GVpGrmWBpCxf2L{IN+%*{>7d<&QHyX6r{-fo2 zeNmIlOGi3)TCX&^UtWFTk{zVx6)5O;kou{0#xI!j>7SpUYbQPj?Q2@uqBCc{evyB~ z1tAuJ4T=lq9hW#KBXG^~ld?Bx)Mej{=(%rPR)?)U^l7W*v^_<6kDVTcK+J2>3ed5# z`sF{{vt#KI_3(8u`#e;h8h7e`HFvpuze%d$i!`G=*BRcAzqXq$4_OuB`RDKV`+n>4 zZDY%Jm%YvT*=9K{xmMyjv_r+n!oz7Jk;WucbgB4$?e|Kni^09+FN$A?^Y)rvRcL7V z%(OC9l-u|0>Q(cyuCA)A%PU>PoO^2v=g;p`+6rgCsp$v=ZKDIV;C{p|Sl+heNRZN( zGsfpFCbmoJ8oPFhO#3C(^wM%ayTo5-g#@O^)Oz!F1NIy9f~8EeQcC1Xs#9gH%eLf7 z9sA+S6*1>>EX0Qb1px^@5+^+(I4As)**<;ymdwj-SKq7DT(+>-Ceq8m^o%uca_GOD zthmsxE5du4_vPN$;25$Z;9#ev)k>qCH<$m+?va9)aC;Bf1fP7eCG)b)Z1=P?GYnU{ z=+2qH{6lTYMMst<^#G@`pA9Q3L$6+5=*)ip+}bi}yRK+5d zg7!5j^E*?FvahX4y1dM{?DNKsIr{l)mMbspjy{$u-0UsOp&%gGsI}?ZX0>NmZ&+1* zeI+_^r{Scj+cGXXeczL_)uuGq0XFL6aKMmps!x=!PmXN(B9~5&XT^zE*Uqzk({Mh% zuUCy#xuHRtCCkzvU&Ts%@7HV5iDwJrtTS(JN(C*=^gDAp?9?31<6qg#StN2H^&kUd zJ-1D+*36t68x}7AbnyHA`ukp kTh{v+%6g^!VC$$`boo?X3B<<=+ja^+9cE64cc zY%H$q41503dug$j5`4wGfvUlo5Tl#h^X~_I-qax*ztl@~E@xa$q_z*Q)>nlF2N%{` zGiQY-zm~Kv%Q^DQd%2cf*_#;|x3;VlF5Y<6DBLstowU$J@6J<@u;*BIVEVF2p86^i zqqpU3oVBO5O6L4o-e+H3*EefkID2J}RP^~Zk(=j4X-n&uzq_+jss7)eh37U}^~dYQ zUS>Bgd1(sC(i|>P57KTny!TO^>^)7#aNe8Npu~PT+Y+_P!qcyWUN$bPV-YaWx^VZ( zo>i|rr|Ha$*j19Lae1zGf9>C|*XPb^UOR1fSk{<@dK9tz4of`U<++tnoFg)GRNR;wL8_o>KWVH9YR(+&4#c->W(C zF|sgeewes&XXw?*`tf!jANSjHN)+yF@wiDlWmcz!Ypguv|^pbGyy)@&^YRcM0#?@znO| zGsfk)910084u2P(J6ZW`)~3@_G?o44T0Onx`fFS6Z5JP(9>ac@H}%u(wR2RMR=^i7 zas(&LJn6D2et(^yuaf^f8%?9sQ%^z`RRl(*aTLo~@G`ReQJ&ya=6YB5&dQz7;-9WM zUlPBoM03&S?3$_l(&pz*{;q9#RPE5`Zuh@M!WJ_6#K5?pYsL0oZ_Q_VnC0KIN%DO1 z`MkZnmy`IbjgS9IseIvPWN{Mn&^{lLUX%x_@08899}6#>t{3Yx*Lkj0-Flh!Ns9dn z>Y(O2xCRvzT9Inh8B%Kd;Q;e7d-Ij=D&7>>zjn*`16nM3M{|O^nfG1YJ1=)WpZ{sL zX|~u$*I(0gqg`HJTH5>7lJmaur{~{y7~5osLQ|r`gbfbalRcNLTJ6#)l=S#m@3BcI zgO++(&NNu{{4_XyUFQ~={J-$VlRvi>I;o30+`=@OU(b`@xX zB%Jl0;Y^oRyRJMgdveJU5Ujl;mm%v9{FHgRKV?WdFKeX5hS!`5)9uH=4x zqjr=0t7QS8A#w*NCex?<=Vs4|kFWcgdi>ed9jy9sdm=#H{y94@cNXh;Kc3d22=nR# z@y4D_%5L_?lCw8hP4ro{TWa-l7V9}8-@l)JaG9S)pdjRdVf*t%^=C`-_y66txciIw zy^6yxf0|DD6z*|0b^?phy% zJn#Sf{5)5E3TWZaM4NqCy^}$ESR3nEtY*xMU+y+Fn}^{r;LGoI;kY_0cRr^WMP z_Ce)E>q!-(yjb(QC6i|urFK1S`7}F!pWw=%rJE+*xoMkLtf1WJr`*tx$N2ST=I+lE zpMKt)a#Cqq?(MWnzfks7=QpIEo_4lKmhb!X@W{H{yUh-j@U(ZGMRr&Vz_WY)wPx@r7eeP}XP`wOFbPaxuGu6ajUc7iQ8+7Wa zli#XW>*ue2Qm6BdWq0Z8u)wuZrrOGX|+J20MQp6N`NxcKX!`(xL;{`&X# zx9h(@KYdj@>ra@aem|XX36uh-9*{Zw`Sqq9d#6u+-CK12>WaX{*YkHgZ0oSeGM@J@ zf8zh}%b|;1lHploI_H&%Zv(kQgS#JPzgii$cb7%opC40OcU6hy&ooN)*|vD=>0?dL z6dD@pSuUMkx5mt7dtI&UeT~Ck)y?Wx&z`dE>-i6tpd*(84hJk77j1emccRymCwDux z@BQ=XwEojGGmEDmG+VKK0eG&x?_a4HrNR?) zok&3b*Ll(hTi!Jt+{J%lSKjBx3YXNuyWp#~eUEGYJUdDw-Yh2Gsk`{=w6d?qnc!^* zhDHNcwcRQki$AS>*WaFbI1{wv)Pm{hQ_uaZ336h_z|^WGr#c3rTgRzt=buw^27tm z4az^=b)2YIz41*v=XQRkxA6Giqjlki`}!X_Q)^E?y4twlE{DPc=|=V1T^{o9W(zJ- zh8U>O(9q4Alydu9mCeGC{)xf!8B;+9+)=o2@o{n1o$y!wC-#|?Gi&9-nlvm;N&x|7 zSA6^5aDL65v$e@6;EOOLi;eOEIa{$;G0(O=7C&kC!G-61iwrNc`en4|RGB_^=Hr7c zpEB)vnQ9#w7~?tjJUVD;`mLX3)mu<jWUGa} z!gnjr(ysaN*x{HV{Nd1QyFI&-_2gD?GP1nk?D=>?-p+pV+cSCVSI>cs$Z{w=XmMZ{ zSD*4q6x4@uIN;4B9BZ?DRrtB;YR<{q;Pb_fA_4iue=etbK2>*=;rP|Vz_d?b#`{e_ zLv+uSpV&J~zvLwgv}{rkU}&7Qsoy$wQivaCgL$kAsEN0x=w!_*vFDSYuFDfR1sjRu zPAdoL`<*xX$j_5hTTljhTX8TItm{dX|B_ zd7WEi!vBrdPM=@0MdnMk!7F!%1M*DoCH%C0p4n;ts4Y&R;lNg=@{{@f()0YU{*gWF z0Iy*=et0j~yl}~+^K*V{=e^)%;)u}>@T{vocA%!p>)J)B8fXjJfr0TqmyO=;vXcjo zeA54a>7p@8^EAzaLgB;J|xS-Sd z^NSA(4=%dHO>F$nDKh2%o%aq!H|0`5Gm8#Px+doq??1gsj(37=EG$*92y`eR^Lr7 zpsprMllFwDvb`(roIbTTpg{5ke1%~{gKT5krzep`_N8}|Vr`vcZRc48Du6JYis9;4JWnEM{QPQwCwiilz2t z3=9eko-U3d6>)Fwa{dqvy=(Eo(czBx5#AU9)}yfwF$Z){+in;69usu=(xde=mhD^m zblQwr-jNxR%a*N-+&P_l<%$JQCUyO8tyaTf(5`aHE)Tgh@~OkBS5Fs{*sqA%_HJCp z9TVqXXji-OpHD`8%4K&&wD1o|YMfub!D9ZtfO@+lR!VQyt(g9!Wr7uoDwDW`h$D|` zemVW^75H9%$S(bH`x1B5)_s6o-`<6rOk z_vD4^_jqMyuS3lW4w)?TvJ)EZ)<*2t`(nAk#7RgM)wi9j-!hyE?f!~>oh;PvUx8*l zS7Y_8m<7*|{z^`~zg#40k_xJ3P8K%N1s3!FWmVPP{(Xz{n5GJf2L&{?99Yj4w!mNe znm>PKsrHsRPtaWF(zu-~YJvamw|BGN3#vzJpjfZ5>;NOH-nr%b-~OF7;kngOl_{dA z#=qF%5ck6`ooTFL(C9mGNmcvY^1qJ{Rx7^$vo)t!ygf(_wF9-F zuCduWYJtD@mHT`@<%Pffe5HP25^B0JiGR>GN&LlSuCL{XEc$Znmh+(b<1N$YZ61Yo ze~mxuw-~++w{8_fv!jw}_f~K;$jcwwR{1&Os}E{VZk70tQf{yf_AQ3rR?a&z5zT;) zOy{>cHrlNXuwVLdPZe4`Y!;We;db=r7Nx)M44&zqop($SO?M&Fe|^`+eGi(r{q`qB z2mb%;f9S^Z9GR{2ApU6V<0^TV!SEKGwj3H+_lXz1mbTuXKCdz@>%{JNyR^$*%=mbX z^I#d*@70O*DrpHDA^Ko}?XZ?0-r-K%=NNc`1$*4eSQf4wn4byCKR18X;Oe|fw8eqGtupY{L#P4d=T`Q_#1l#xTj{V)qxD{flpX;xWuXNzER57nI8i z=N*?e&x<+BT6OQi#^Z9Ub2gtfbJf4{o-;Yd{O6e$sA=MsSAs_uQ|+fGCrd?NT$YM0 zzgs%>YIywK7p=egZ@uy{j6gMC>%-O?tiQBYuer4FQO&Po;xPq|7voQx>HWx^Rno?y zjv6ci7B*##^VXk{EB^gtvcFdPoIqUn)yt)) z>VCfszoPW_S;9uANs_`-P_#q^Jy>{y_1BG!$NT-(^U zK8Z{YK*ee?TT3OUrpk?WbHE+l+4vQP3Xk>Pj0$d zpVN=b-s(HYV&kUg^Qzrs{Z;0(JI^^A_3DhF1WG(~s2PMWdGy(ywQyfSwBR;xy`4)g zt&iWYB=+jL%WT_5)bx|eGOZ(af&RW9k6c%rU;fM>_0*J82ifIgjwt<|`Cy;>={c@! zPAD-UD;8l>)_8As`TIj6FD?u1d^RgvYxSBVXA#`Vc}AZ3!hcq@BM!7)Uw%mQAeEq&N9%~-uiWB<_Bb#XBao?AJMyD zek)_~C6GsDO|wE$*X?|!6}9kR=jxZa-!e^NK*7GkGof!*Uzq{eE{%N$j&BT}Q~hpd za=VXQ{{O$<&#U>&n7}J-rc)VjT5>^CX7+yLzg-)?uUR+v-_F7x#N{?kjRMQQE+@u++A{J(F~Be&<> zO%g6uxz}*vN8g6|lHWc#m%BJcgM6P+&G_H_#<%4R3`{H>Tjn%qzt}wEQZt{G2DkR! z^ys{usTbA$-Bw(fet2K>MWM<3;6Tcl(!jJg@X{|(tEbV8b4Qb%^vlrjSkv9_cD>#d z>~CxO`qtL$#m|<`s+-2g9xL?i_2GSCro1xFAUCo^c{()S^V*!L1M_n3rc(+CQP`pIZ;0F$de~7U|W;8H7+D~ce#T& zXT^RPlra^bH4T3=p|!jGT4Z|a^!U2UZ6}nvMRd20%mEEg+{$`@P+{thE>;GFRtK@Er>iBnh!+p_jvXj55Sb$xd zF{y!Rujhwd;8;#!l0VXSXVv)y=TBsAJSukDtygMlY}w7!$p8QTCI=tu*q+BxlzJnd zMg}vzF`umk$oQOk7{0w#ayce4Hv!v7g6tn&NT2*j*{h=axm49p*Jp zdA)XfTww4$6_sztH^fVS>+OQ;HD%)Zk~IYqVW~nL`#kPM=kE<&_R;-(>F2ZN^M6@w zTikDFRrRKWaXZ(>Jnr916XQ*jVirOyKFlKWf_L#XL6ECWJV0^u{eHjPCP$IN-IgDZ z2yec)*j@Z*R+Zg@*u(zMS=*F1BHWVev#+nac~X7;oV(TU_uk~QeiLv)#(we@@k90dmEYKNR&O^_(E;~K zGGrN9t6ra3IuVqs4*cibBPacM<8ire*-dL7@yb{j?0&Us^`?T`)nfOwKBnH;Jp`Ze9Iy?XTX%7^IY0S6-k+^V&m3P3|Rf0R7&#Tt5e!C@DlItt` z;h!4Bf^Kt}AxQ{leq2SFg5iPmgM@HJbBK}CUAV* z=88~Rm%IGl0Zsvh3!j+IAD4S5>~AAzy`;ie;6}k=-p$(U_ZaQ|`|bATn!ue*`Sv_J zV}-v><(jkj3Ml<7aAD&5BIG+Q1mxHSYK_aYtaf!Z&#!*BQ>(AYL#J_}bGu)y?(MJF zBxa1V9WdlroDfk-RS_?ugCOL_g$cQ_=UwqVX`^h zy4z0V?R+}z&7y9-Q&r#IM3(Mmle36_@%nkHpOrY?cw!i=1lF5FjtjhJCWS{)bXT#t6m)kexk}1e`Pyzyl8JGHo$`cx| zoRaVEDt-OnQ~IpqLNhE1lb-Ir|2OZ-&)%ASGQm6iTUtO~h9!XuDveK-#bbiI9kq8J z*V_2_2KJ@Nh_4{0p!j+RPnELJiRiw7dmT3e{tV_4hXP@$rSp|}@*EB@mk$%0_ z9OTrDH3uGR?%Mr&-R__kQR9gY_xIIqUcGLY*6uHtyf=%6MJNX9o3_T<%ghyj`BPTT z45UTjgFGYauE~v{D2<9tD3Z8ycq4no>$TgD@oB~}vy|N}y`J;t#>SiTs>PD_Zrgci zLcQ3x_?FszY&`MekdS3$t>RSk>;iEvC^jCqx>Ci~`+n#1c{db~W=}Y9h+BV7Y{^B} zn@7dt=X`y2b+zN(bDL%}AG&`}{F`t0gdQ1C0$H$=iR;U=U$5taTycr}j@a&Q@%S3U z>PMX~@(a4>F00rqaHID7-OcIqD%Ec1@BiENV2Zx^|LYt6`wLE*$P7xACjJhM_iUfy!*)*r#hT9v%_s~aelpA|eY|6}j2UTJf^ESrO~v^V^C)SZ4kzP`5Xm}I(%`NaQk zZR;)mb#18M&vEhuILxKg7dYh4f%N1TR5EQp^6uBe_Qm>q^46{&UkOOq)l^K=XWH@a z*U#A(X6=&|H~LX~dGiENFmagpI5gff$dUzTXkk{lj=SHZ^Y>2Gyp+6JO!?k}gUy?* z-|sQD{`F#U_k;_6ik;qF6FR`5t+2O&$#(BXIdI7TWV*P1!E@)J1?Kfh!D$7LI@Qy{ z<0@0P9TDb5WD-F}~*UwocfCiDx`hi%-##Pwy%zD3}8Dr8xt zzx&^nV1Lo{5+hHw4R?x8r(Tb%&i(c_zur1hK9nU+L#8-E^tfdU$irSb3mo)6KJf%6 zk}RQ$70VW{wzwhsMQcLTiwVZ(ZH%q||M|T6++1t(?2y}LtCRnN3+rSSE7N7td%>kv z<1+3XDWf0RXLNRzyqr|~;UN22of}D|PMg9NZ_h;K_aGLl(=rKNb z;+*aGJ394u7CPR3&HKvT9BdVGs`eGGuqr#RzyD9sn+cDm`aF=n|HG~9|KIQF+3WX~ zy*eY$D_b*Tm+(h$tX6_@;?37HK_M=s|H0vno_v+YuSXv?28*m`WCHb7&C1@~$T`v> zs9D{;>qO!ym!sfz%`X;_7hiW~x`J}SQ;`bAvRmu-2>spo?S^L8b%(}@%I<05v8AEl zWcA|fcFm?PaDF=~7_dM*T`vXPOMc1vuK%vIT8+9&pD?e*C5 zUdt|T=M5VTnY+MN92E{&AfE4+0uIWTET7nqX>UAS&1btUUH~`5yi^xB=wB`IoCXRhB@UPPvb)7E z1k;wbI_GS?8g}z;`Te=Md%s>Y?Je4RHS9E~QU;9{MeCUCS+eXHq%9c4rE$UAGItU< z0Qopi$&dO$7Rc7z#Wig zcK&%~Z^RyI{qod3mSh2n_YabdelDQA+TbvoQ%3yQ@4qvW?^VCwyO~>mk3pKp#;BMF zpsLTUUv94Lw;Rbft>5pN-1_{?X1m&7Db8&?CqcDaWN+PJzqwX-?>(|UC`+$|O2*l~0(%VZT- zkd6+m2a;b_%xN->NSIu(`ga-cyWnz=OD`xevQ{-OCkw_)zOtx%9Q!;8DE=iA-Ey z+5%sLwQ?za$UE`)?Twv#emv^l=-lO=5XR)*u2ie&0y67D6cg8%YqR_pgI)WIWl_BA ze3Q(eQd{dT2bsp7PBWYzw+OX@;*^PG)5<682bXN0I5aMtHV!uecR4FS#p?cFuU3EDB;4sx%5=Kz@TcqRz^$7Ft}G%i zbd4sqfyWI@Irqd}z8ETFb6n=1{#Guv_9NmFg6kIP3)`>h0K1ikalhKEh3mlG?u=~* zyf+HJxVbs~&4fpSE8G?oTfBIa#aF@usscsg9U9~QSWW`ZWgHRTpkFt}O~#MP3}8D?Jm;v1)wn{9=1jtGrQ)$1|=f9pA!NA}8W^o8`~V zH3gSHO&l5*xQzraf%eXWUA%}d^>7&>GOq!&YN%N@87GexJ6YUIAOcrT&ur&X%66V=mmvL>lT=wi}D9~ zH$bP++}WzVOl4{1^SS2MzjIy}mmUeY{etO!w_KnDC_QD&Xkgl#c*P3T(`#hnijgb& zm1bLc*7&^5P0{d}iEDR0oAuS?dYgk*vzA~H8pUtTPybz zGp3`09Iln1rrV5%mcL(C{_*_rdD8~|moM5~szKiI&`y}R16Cngvi|CqFnn|(by{TF zd&_4tl3!_GVdImT(fU8`+{F{SQd#+|UMzU?-2Q*1?&H(>_40Av%*VmC++!Az7rmRW z34@$7#YG`TI#zYbul`9(w9lG}{CLpJziI8ZTUxunUW45B5 zBE}JZ{yTSV&iq~SA33jR7o5^uo^m~=*mv*QJ8o$Ppyy$%1>-8zh7JaY8J=;U)T31^?u4$yr7@VDh!_Xvr>D&RdxK& z7I5KsO~}Hv@LrVgt*pgApX%33ZnijIsmJkKZSAuZ8_*!a>ISC0YmC+NK_S|qC9rN@ zz9`c>3DXq`EK1xl<#$UbD*N%4`*kfy0*BUHCay2H&Tavx=W8Msi%i>7L)NN%_`d(Y z?a_j;uqDeAL?<&aGHvCqVB1?}tP3hm7aV0dboF!cp$Tj5+)Mg=E9>yj@B9DHEq!~- z^y!9AyFJ$V-)y`A3Pgi!M%G=%;P%R`C994@|ro7t~o=LJ$4( zd}s)&eHz6;fz$1`CJ~%_t}^{x`?l-zs+}@7bQ(dUMYdI6JZ}E=Qruzf8N}7?+rZFx zlSAXeTqTf27q&4yeDzZ(@dNu--G;{LehFtyulvmXT<*;Ndf7Xd8c;yY*x0~ycP6-$ zd8;#Ff7n`YYi5b+oh;jKBz3!~)Z{2zT?7wr)x;ezesPWqq$R_hQyDzxt0~p zdTS57UcZ0d*Ectfe}6d4AKah#{K7%emDYmuL22h-v_s>&9&jLT6X9U}_5SdI@~qPb zw_jMG?mKIW?awEZZ$3FWd9%OW&y-j5KcBa+zqUR9e$LLP)3O&%{C7W~&-&etH$NWt z``d0ST-baNW~#`GbD#t!kWt(iFz5Ny=zT@I*Savt*L-mNwtfHK+*ftK-)>L$xB2Mu z?bB)f^Cc|B=WWZct&iWIbC}os%(gp4r*jtfnw@$!Gku;=Z^g5fdAnXNyQ#bV&ZH_G z_7=W#{&zcnfI<)44q)NfGTmXl!JV3|-~Py+KVSO#+S|jfVv$RX5)L$ghw*oQJSOdY zHcxxefhn57THEu6xuJl7T+ zk14t6x^nKPbdG2Fli%|k295E616{#Eq47YL;$zz6+p-l88mE4Ie0+Le)&1Ji# zt7d;6)05((XE&YJi=M@__Dtu!!sD`2H(aVZ^=Q+&8*{BnSIsFprMYxr?t!)Mj=TKn z;R3e{Aue%{=FpKk_M@tY$+o}nT4egvWe(cOi+(EQf(D*rSxeSf&WoLMu$evlkoH}# zgS*d~-CnY#W)tr|d!C7)lnu)84GfJPO!jkQ4~Cw;&o67WMWi)Sa`Kt*jPD)4zx}@-S6Wjh{n-6xllQ}w z{8ld(s3iaYvbofqyS`pR3L5Z`w&*&azy zey6xqwf@h?b$|R#^nipC*sCrgJ5)m*i~j%pK7B2pUdq1kxXRR1i#9&o2%1Pb zWqjTy*yDBiy~^dAPAGLRF?lKaaWksLDjWP)J+kTly}thM>Itq9GbdF&ndq+7t-CGa zRMSSyjqH3f5kFrn?&q=;1&w`sO@65RR_5}Mg}2r6DyG+n z&3l}G^W(jm&u4Gi{eBaC;^W)h@As|z^h%tmUNy9!5Y)v1g*2$nSnd$_Q+21;jm7T$ zr=Fag%w1i&MW=J^jz?Xd&(yE(xi0;Ef-|4yoheVwFDid|NpyDmt%YC2r!ey~m`oQ{w-9 znjZXgbLy%CkAxH)7R0iOym)K%`534wDdMg%4*fMde_!Rczu#^z=ei$Oc)$Mt-?rZJ zR?)B%+ivIW&bhF_k@t16o2>6FlgzA%aZ7Ta&n@?x>i5s?%iSPW@#*0718xO1KH`4j z9jv}PxBSbCi>O-A;mU+vv;MdFL;q&T#z5Jh4_2=VpZP2Vq>OodJa0iN1JP8riC~>eRe5`gI?>LtG!$ zKLYipj8jjAKeYe-X0tYElJk>|UA5n{)ywO@$@9&!od454Lgm*TAI`$vOMh+X2G7Gl zjVxqsQ`ItBCZ-P>bvMplG3~YW{z-F-_Is@7!i$N;zx->ULo?5-}=j#*X@ullgnUUR$lXeG2>i((AD+kNwFq+;5bE zT<~c%dIyWXi2wU4JouVxu6XtTzu)~sInEipo1z)~%IMs4+pCtQwRbk3vs%6GPmsx} z{|6N=&M5c#dJrWxlQ?xIuUIi7YR#X=^8Y;oxwodC+57F5b||C8;T?Z}eSJOQv!C_b zDK_^*!y=bDTOP})dDN-COzQp3qrXl~-~|T^B!{kK@$(E_AYbvI(eU;BZGBf?Xg~jH zInn<4y^Fccyk;JuTmGr%?VD92xUDAjr_21M(}Qb&90m2Bphhf+V45r>DmwM~{Q7+y zrNJ+Yf1E4dH+j{E*{OH-|9zV;yRG{9+;XkeYqv#R`g1*|_$=RZNo|Kix9?onzjnPX z2Pv95bU%CzIl6Q8^FptE@9Y2n_Uyhr^X&g`xAW!G85F(#b?v>kw_08HIIDP!fbRW1 z7OR&_CI|I?-f}~}?jw>Z8q*HQuH^c%d|uTm<?Y1Y_bLk4yy|Fq(5^z=pZK-GXAXDjxTGK2JI^LGk3Vt)I_XtDoI_ z>j7tevHb>%czGjaXH9eH7kDvQg!Px%?VR9T*~dF(a^&oOyX|DxjhSbE9+S?GnQ4+4 z^vP1vJTK+{&G%5ne0!|m$Q$^Y~|Ddm9j?kYpQm^teOXM&3oNZboJKlmrY z`m0NOT|~>R6ui&92Wj&-&}WEOrucPxW~;(Oquk8RPRdE4y|{9^3oj5ch1i z(iaQc)udnNZohkNOQG-UAG5O8d7AEv7kixTA_gfqz=hor0g0)L9Nu4A>iu+X`Mu1l z#E@$&X7_78hp^s#{;2Hzy}gsNmVV3n8(;JBXv*WW_hs+D$^G=?t(QwY);8S7 zas-kwz(y|k$yD4ba?c}hLH%Rt`x#}vA-Ddy_ee}!G+}n)nR|Py!;kgJMsuwG`~ANC z$sM5D*r_M~_uK9MM*BYejNSM%UeyTMu*FRGeFEn^H+;Y2ai5cjYpVC7U9Z=9haRcb z%iCY~R|{MxbjVe|*_e`C|NHIs*>>kPpSQEV`lGG$w_+LSn zyB8X%efW4>KK$3Wx3gDu{9eC9d(8%?r>){~8ZwvlcE6dF@&{C2UOql+|9QKk&vlRd zDgC_PD+M%V_=)pO;JzuT;B|7kIvcViZa>pJW}b6ngGgeu-7~x2Zzi{XFH@IK*EqL% zLq_DbD?#3>?^j>rE4!7sJZg4GY0Zw_{i_}a$!+;?h&x?6cS~TG-o6=1D`tR04pM`g z_$9c!(E261x8|T>^joIhs-?FsdF#hY+Sk>*yzv((AboIMVK2<*)y7 z_(k&XE348U@3Z>i(!kJoO`w2vuj#Xk8lc%iEvD*a5+~N}em6@g$NPBA=d=6sV1hICP|iB9&c@e&*iVc8dkv^LaWwe%;zYS@(V^Q?1(-k9%Kd z+`OSSJ7<&U7rw)v|3=0wF|U?3$p`?YuB9HyUqu{`syH+_Xme{^h^{Q_?PXwOdMf1c zX+i#uUW@4Jw_8uEUVM_{-Y++IZt1nilbbER-ALZN_xnBTN_#^q(41s)%g>me>i2ui zJ?}&{*FEHpU$NEG^!WPdvyOeBVxaNAaKHjjeeEoRV&R|XQ1YS8Ciz+E$HJ=W-&GQb)QRtX?hwEgD&~y)yLeuP-kr&#nLW zGgLNuNpo1NY5hruJ8Lz3+xc9N)A94=GxII&|9-hVSzYMf|G7`sf7iOb?ccB0?*2cIipTeWUCGY3W_hG( zu1$Mf?!&^N8uPW^r2XDHoe*g`7aQY&dW^F(>f; z(LE2ExWyjHUQYE?x^qqLYQ5X%ou~D7PiakVt88bwYQWphmbu&r6-arKtg{o8p! z(R-0K#h_s$A6!-ko!@qUliY-=gWFW6#~7WCUm5mnt@m`j zn_Sv!1Zp|>ZNCJ3nemn7O#Jp~3DKHIV(c7a6hSk^lbE=^Oq&zdtmM$(u##ocp8Z+3 zbGPe?IvG#?dpiE#q`L)&c|C(Ie!tng`RDWV*Lk$RgT@J5w@3b ztIOwta!Vf**O#(6rODuyDa)joZMU;ltMqRb_tpzCTRx}AYl(+3U-65D?P>8pPlZqV zc5%gn)$8Tz&u;$s__(>&-^g#1_q*lYt94&>4cqjimk%_$>;C@J(&=$sa+~ip zyk4`}Z?A9q)pMd>L{=pUDO^DIawf~CtmW}|KB20OWD28M{57Y zgV!UHdtb!*%`i}`I#b1*w<_g&^!XWgwqOS5J-FzvmYcBg_mh#xl`>1>0Yrkv3;!V(C&8 z*gMHDB0W6&XqOuE?RFXZhh402zYs!yL_#Qr`}KdNj0yd?|TXD=5Q2` zOquv1Gem3Z3&YpEJMI*nzIwYP?CqpG*7KDD4MB;{hmp0)`0H0thvS=Agc^_iFV$-; z?~C$Q-rV)+l=kFa^{?5tC#lAzK4=y1`)~0T)NW3F|C0YSDDighlSpZjX$6&gmsv$# z_|9hnb>9}`vM!3ZJ+CUf*6D80K9$sYtB)Ba%uOxnk|YB4Gz|v8W(P7ZtI=Oz{qq|sN>&)*IBFAhOH44 zGnuWuZikX5c;;_YulYR-&o^QGQA^S~!Wf(aHGE5m+t5%;~@ewozF2m&AV)DFq zZr1v^y-DpkJ1f55EsvjM2wK1Cc}Iz@ly&dB$d{4j-n^iMp~l4Z#cXBM4b828{{KWC4Z*JD2CZ)1jzP;vke}1U^eZTMb zJI_aArZ1xN_lnwXT@*X@{cZD;cVArmpQ!iCg~OwPp;3)n(9uD7PeS$XR2Es$8;`l!p~ zVv(Z5f&wNk*evk{F{X?08@GKp^fSNy_8OLV`~UxY;o#iPcXnD-*2))!-BKSGw##+R zi>j-xUi7{1`rPa~_ft;Xx*_GiBTamYGVNR!fd;J?NHTGKNn7z6G%n4uNMGRk?(+Oq zn*}P~ZoR(gkK~sdx6@|lidm;De7yI|CGU%$wO>7!>|D2~n$Px^q>2I~(^{1U4*5%O znusy6a7=LrtqXj2ckzAGc)7D$Mzs$b*;iSt`sVye`^DQWOLuTDT+yGdQpI<7v&P#m zjfP=NELma!3$FVtV+2)2E&?ya6pz)nMiiY?O>WOwSpjNUe);%hds_aclWG?qi&;J} zK5rvzyLZvN-JS2eBJHdeG_Y_8WGFJSR&o0-TL?-hE=(82yFT&!T9a;nRP@W%Yf-CR zmdDHq3661$FFtGfSVi2@Yk%EeCHFZ}d0U|kpVb^17otTI5s+^ItOOxx%(`nJ`Ha2Gz<%6a)zVJMoQ+zJxX6oYgGbL2d z&$F#g>(<+qF(qO?=Oe8uu24fxfecPY)+%qG#g3rPN<;LW^jf|>f4|+n=s#)EJ~^FV z4)(mDi5oY5+k^uRFAS5}d`d)ZPab}2cwASEk%?uN>H>%SX?yBGS?M0r#r(qm9}e^1 zjxG^feEz-OkLULPCGV>5KXl9Q_KS;)7xSA3GRo+lcj3OV_4-=zi)qdZOf0t?9UAZP zZO-WdMGkW#s1M8Q7I|MFIK~#V7H#vo*w4p1ZzorOzgxb!Y){j?jD;hku#j%J&1*BVHY%bun1R zq9EbR3`1tMD)FlKGb}-~_>Eyg0SmTY%8}w`WMVm`{2}d4h`Rqg8S9kOM_%9AS^Q<= z8Pn@A7n8*-ALMSoJ56QpBJmg6Yqtb-6`r39=?P@8GO|`_pIKxGijW$nxk=04NPd~w zy{y7CV!B>zl7HgD$9IcP>t6gUZBtP&&0Z_u31}6M_r!Zako58-_l9D$+C7=#BmejR772ga&GqksGk@w&IdFUY&4i1Ob$2{yifr1g`bpU6 zSF+wkc70GAZI*(-|Nk3j8*s#eraKL z-|foSxQzeHQT;kY&pS69#iKG7-cbBpaW|L+JnfV!9R}b&?+6!!WG-~do1)%d;R!) z#@PSM$My#KWsppBN^gOK{%@XBpy{5cA{}-0UtX`@ALrM}mU4Gx@bWd$+kf=`SyoXS z&1{kN>d~Wa{dF&YWbwzP&n;bLyXEEa+7AcWHH!*ZZCh8(VBwe&=g=7UOVfk_R00Jl z{PI5iS$o&EncQFA+%&d2pS^ysm~GlbrhR|E-M(4*eC~9WrEj<2xAVLs;`n@S`8|Z@u=<`E%|6 ze!ls2AInzBSs~zRL8T9ef z^SS^3ec$gcd)ZrmuZU^f#HOd)-_Ni8cGENHR^f5k$wz!eO)iR-oL_L=F45L$a$Vy2 zc)$DBZz>>OjLeLy`Jx}$&p5x5Cq8B6^&BQ%^I_4Kg9R@FC zh~%&lj9xx<{j*~myf!BNILvP^qrCOd(I1!R|C{pniMqY#r10SDa7ZMr6FIf9TL^p(n$8O!m7AkYMEBu0d^_z`vK#P<_7q5RmA-3%1(tT~d zIZq|OX#DVQ(THxZ4Y*;>^ZQibA~Q9Qf2SI2{yW|{&+}XV@W1uPO4f=qy;V;T{r+us zu`;N4BFHk2%hRQn&9q+q`{wg@(JdQAjoL-F?|8m?PQRS(t_hFVs;@M^Ut@ebd;Q)` z;_)>b=RFJEdb9L;>}soZ9_%}t;=bqPh(yg3`*!@$y!%FVbvHh*zLctUZn=ETdw=dP zH3$3mL~IvSnBd^hIFBLJ1Jrd{;id4a`*eK8!`4++dB>YU^Y>3;Uzp#oDL!5BY`q<5 z1KFmJIXfP(ht`~-{9x3-nSuIJNIYqkDn6qT-87S9bGv! z?NCHikVE6WNtd%gJE1gM547BfwEO7t#r<~j@*7(!=314W`t{|cd|~fyP~`+-zi;#Fy>I=Nt9~=lq;A!N$?E=og1fH9z22JZuuJF7&qF*vuRg6=xIOItr{`&U zyuVj$cz%A(Z4QABg#`}%4H_(<>i&xA1FovroUi6l)o-`H&bOI7t^8hP`nOM~f8O2w z^v=E7?{`+AZ~9}X}Fmrc|uTcrKsXZ4Qg#M`z!kG^equ04-GyOr^( zVcTEl*?+RCcHWbZIPPGoc!7hFwMu!)SMVr-u~5f8mLH4zpRND2^{h|A;@(g0Nssfl z-z|&&vw*h)oM)Tacu(c+{d(=m-nVX~?ZZ3ff) zO|3C1DmAG${B@%reNqiDVPvhknC4;!s_5h!uP5=BK04C5(Ro|Qo`cQo>XPT5PLH3b zl6Pu>`JDpiZ%_5>El-E%`tQ}6bIZ@_cRQbZIooGlS)syaY(3rI{_mGdH)_l-atf<0*-&MC@Vn=$2|pj@n;-eJ zFY9B(fr81&_f`?hzAcLq$cSfTt@?d#??jN-IG8T3Uj!P- zag_*9EcVzM5L5Tu>EEhNi}t>HH#2?S$xroDZWN!l-7FrL@uv0m-SYdkx65w-c^m!o zuF%@o0d3zE^MuoM<5}`He>xYZXcVuQ@^STsa!nVrNeTf>h{ehoiH-F~dYvYle^!MladOyK^%VzvMl;$p9`{hdc{{J8Qe@btV+WqzI zZS&m^nz*HIXExnCbc=~|k=Q@3Uk?*6{PeVm?>e|W@r-_p;s1TS$8%4xyb=mnaQ)~q z@Qxf8p^mzpyH9M7bT@ikFe4=V;^!lvKHAFg-tYJ8|G&8!9{;vr-Bvb^?m4N6f!lIs zrcOKQXZQ0-)NFU_e_Jm5oqjfJ^&jp?^QyB7j=GljPKA(&J`S1Jwcuv>qPYYY4Uu)n0 zb#1%W-QDH+CvK#b-kVqXZ05=1w^#7}`u=|YA>*@79J2q{oesD1F^n_(f4H@9YA_lmIHD{$gK?bO z-bIfaXLQ~8a8x|r=jmV0sc7{vpAWb1|0@&AGwzezq?){T<1wk5&HQ#ZwrtehaDeINgM-bRuZG9l zo)!;1ExrM?5oL2hc8yu(rzb1lZ{c@M`gSGQKlNu)>d*P0mA2n5y33pDKA&0oXQ_Uz z=I)ovW^+vscNaQ!eDlv|7vul_O*)aevhRuL&bKE7&gWjA7`U3_dyz%j*$w7(3%j%? z6>~JEaaBBZgbbZ9GVMITypj9M@Av!X=ZG>@zuD*>%>AYOUZwi)*YW?YO7%aRfwthy z%3i1WSs-o3@6YG$=O_704q{nr{LFA|#GLbn$7OEXd_FT7v@-VfwY9ge*zYcRIZ1cZ z38mowf1ca_pSkz2n0{+8wPCGkgY`w)zR$sMjBJNm)o&r6P!NUwN7Sqn{?a%m4U_Nat*D zOr2l*ZRMQOYmrkw@HkKZ=&ZqKRrb>DY`*5b^niu?Qf{{M9{MJE(Xdlxe=6P{J$_X6C$1dYT$ zFlOQ}e{lRRPrc8x@c%hiIq%ebKHK}xG49nrKI=CdUL|eJb>XJReb&pY_|rtnx2nyP-UV8^2exB|-vjBbe=e;3 zc4LE8MeTl{+gq+OvddgJA^&*ktJTHN&rMyue&4R#b3M-dwqI6d*{7Szm~ZU7U$y+& zg!C)LpI68K&3gK!1Vx9=*TJ`Ni|&%AfDrubNvw7JP$-jL3^N)WPs!_|&xU~IV9_KNm+n>LK8k(t( zj&z=#vHwLaXl21>*?g79v9n70UVztjL!)B7%df`o^W`UHui5DKMSj&=fr9OK%d)TZ ze?0Vk^Z$Rpw;!HTU)Cetdj8Rj8}p9~yg#E>^IBK_*PJ;CI>xr;+i#}L_Ns7=^`2`E zT3VX=_v`iiBhSCiQ=6l_3%>elM&p6}pg$dT-)^QyziKa9%vO9Q(B1UW@ruOX5rs!Z zZ@-%M?fjf@@AmVLrm)OE{&)6=v*p=Mg=fC(IU65+W7Tctew(1knvX}NKhDfOR(Yu< zICwfVd>WIuWoA8U|Dw5k&ZSlRr%&#GeMHzl=Scs@LtiKUe|*GUzIMu;?F(dmxaJ?O zS^8Dvv(bu!@s2;OuLt)$E;ba8DL5FU%Mkv4XZiEFbtYVS={>NVqf0fU9Ma=#e8qS?zS6?ijK>cZ~49FdG}$}$SsCP-d;P9zi<7r zA9gbX&n%r5waTdM&5doA`FeZ5Tym=kE6;tfa}ju}1GtWv$ze0~k^5I+f18VD_Va>y zOzQ7m+V}h2?GE{;zAqQY@2>-`vt7DCJNe8X%a0=Km3OaiykB*?bzhv<$JkFdXMlEI zJ$<+Pz20M+a*gN0ein*f)4$GQo2S1^37l?NI0R;N9(bu)7Xs>Y$o?{1_3=MfO!eEX zQ%$eO7=Pve+;$Yykk4ce`=QhN`{(RA&sQ?RKI@Z9 z)A@(%rGBiPzFutpADgIzMpmuI$9i8gl}h$HP@m zr-ti&*MHcQTK{h6^DwdKoQ+rP&rLpho_n=&zs;sk58LI{CfB}PI$g_MzP3blzm@&s z;;OAz!&d+K&~Crx$?9bBOlixaC-*e%nibO)i~aN3H0@}*@3Xn(_fF|cIUI!U!duGwFD1$cooDDx($G3~zkDS79#!K z+`7d1WPO6wj|a`#Ked-<&73ZB9F+2=KJK^Q_vwuB`6bdH(v{>34lv5fmH+$q6?FbX zqGkQE#eZ&ou2-AUzu)A+?RAQ)w>|H7yYVkN;m?ncvUcy&3(x&s!}z>U4`ds-?UJTw zkp5#gzpx1B)IYD5tu`<=~`#7}8HD{?dZ{QMEW<&z1gLc?RP&T#a*e){M0 z`SPW6K!>gzj=w8N1y8*xuf#Y{9a+_ zr+?>n&boi|!>`xtuY2GA^mbnDx0@RCU(Y=AxT^EK{6kI=uLZ#iH%$cZK@j*6-CF*SnYm1XnwQr_q)^cYCfIRS;J!c^?X1}8feV*iv3}(o5BC* zfCgv^cGrl7#hwSPHPGGpWK!_|n7o}&H*MgEp1OCbz0MzI$8G=ry%f_tfBf&<_ciL$ zb~P274z`59NIl%f%N_jTp3Ow-lj5~+1TCL^c__yD|LMjJ&+FB0=k5RdE$79Bg(n|v zcY088+^6j0(VzR*y50YD_0E1_+f@zFB9f8Gl+#AKudgmN?V_vr+7_iHPuFKiCOl^O z#L5voXZ8HvoxfhK4tML75=~9e-}B+nmCzrbZ*Th?-llrSzFxiZ)Y~sDJN-+4-aKC? zc686xX3)Z$mFE`kUux5M1YQfS@O#j{vaVu&(J9Tf|DtdHkkSxXSFl{mCrzUK=hNxy zK^xRf`wjFL?EC-seK;GB#Dx6O61`Wal;<}raLCRa5rd9~x`q3Y-Js`H+{Tt0tY zOxexUsfYRP_ZSsCII!yW@?SlzJN~cuR2+9cvAD(UC)fRx$1Ky%%=l)r(%Rq^XnOZ* z&7URnCc8*8rHX9uh>=Y9JqPKquRR>F-qZBXhrTy!%HQ8xd8qrg8WU)s^4q`P@3)`K z$d-C$`S68vc2?lugFjc__FMh$!>vA>hb_XJlKU)|ZFB3JrzH@!=e%6~pN}`B%3B*= zALrAOYgFQT^8Z%`WH*Sb=ngZLvg%b&4oy84vhZlGawBM6Td!O6<$(VYmoILW-4mVL z9$x=tf}*p?^Q*-GMkad*rFe>@W3e?v`qZRU*it&9Ih1$V#V|L0^;lJK?tdRa=u-F@5G`u^!Ry3B7s zw{WuK3eGLf4NQAw({4&|3Md5RHQsOeGT+0r1$5{`Xhz{}7lr!&o8J~Qg{zuKPSg5U zzW?{#9MIB#(S5p)+FUt(q5mE82UYD zZs|2o!MHPK0uebIk8bJ|R!;-%D7>ApC6xc;iGnA_q4KeR8-M0szu&eu`m66M>!ME8 zX(vAI&e~O0s$N=}WNer9Zs+rJ>-Ky)^#;^w^_U^K^{hCn&(9k!Z)%Pz2TX6!eo?wH z6TCN%SIk2B%lE2PcA#a@I%|&2)!MToSE1lm=JM3qUtcntCx)3GS$-&Rdq`=@TlQL2 zlgI_%(l+N8KAGsAR#}+&ddGod()o8jD$MV{pzj)B$SLCM&=|Kxaw7OJlrugGH=7sc z@A>Ek+A%uYrg0amSX9QsH;=mY=T(`v>F!op=s0QWp75y5r8z%7JmkEbxBdcXxnLLL z?xUbl=~m%@1>$*LDqx2i3tA}td7r=R5@>_T%)c-F>%Bm+ClFD7w{-LD{C$?v1`FQ4 z?l>*vSH907=F8g#X1)%&&2yR8ZNFEg**5?Fy$jl|35J{^o(HNgbel*QDS}o(-Q@h^ zZ}EVAv-OI5`_Hdm1X>jM)$DrTfqIrt-!q=CZuFlu#op|8*zNg;Gq(GhJZg2mW1e(8 zE}@Zi(;vNA=jQ636}eotZs)U8%Y0@E8K=l;+i(9=e8z1-Dr<~m{>_!92A~oCB?tHq zulV#ldUB4in$L-SpXa_;>D0}r=9H;^voUfX!$Z*V5W4$*JbG*Lqg$A-?5oH|(0sY} zIpG7({y&(R@Oq}gvI#6)pxumDN<6@o<|+Y;rCrId>{6bbm`9 z&CX}DZa$qJZ&&*M`g+y-5?@cRQg~&bG56Q(b32}1Sm>PGF7iIO(Ix!CZ)UX%ub8;L zgw0QUtnAR>kj?c+m*;iU6zARle!bqD+-IqlDxS1`r9+*l?f$oae?0C#|LOYXttZMd zC60S{9^d5i=7)0|Pp53q9)H$paaAux#JoW>j*Uv35l8oWY*qvxC$Pd*A-*!(>Bi(R zi=V5n@B8yq|N5lq$($j&A6~6q@3;5w-yY+0D|Y!h^54;TGWGxA$Ww0@3+(Ye!}srF ze|^g8HJiN7Oh~HL`tYz_KJD(VQtyWo^+moHbsb0&(r9X6+RL$7fgRL0T@n7^#s!1; zo3=Nn?QeQ{uloI2P))jqzme1C-;c*PUoM|N@9(Sd{ii-1T9$JA#f10AI*a2Jj?`PH z$^X2|oxksA8psy61@8TFH(#&cFLygNfy2VCEZ`%Di0c8}cdj!zD?u}r4z^6{EpFeh zT;6cY?ERk4eq|>V+e4~%Jm$EfI>CN&9cWQc?0<#$kG21PK3}ixH(6@#&4#+?J$K!& zuZsl*x-nDjuP>g7m#o3L8Tpi*E7}D?dwEyqmV>rHgI0-eZMW`oxXZM+>g%kk)4#d( z_e`jLUw!}dvl)v&*k3)?dN3~bd&BDdA8udU!^)qy%RenYb32GjXQRs`_hXY;d|xV< zHAb;;{a+h@IstMLPp;;NbP%bABon39I{^0d=X}N+R>+ zmtVQP;aJ&4`82(Ui&;!3ng0KfI<0fxx_G-4uCwfoBn3Rw7dZH*Ya4;OKPG+;su!-l zqV17>xSjv}yFH)J9qaY-&(+`XWRiE9{lAa>o1f3Gx3dOSM}I(%e~PT%|WTC|~a*H_8LKYx5TJmqe=#j#~ggX^QHvMk;n21ce_^$pNT}4V-E9x1FMadCcw;>0f7`6WY0}@`zrT8G<+BgV?f+(eJDXo;T=t{b*@3(H zNSNq)1E#?E(7+jio{(*9fe#iLyvRLdr}Ol|=d0U3e~);6e(7xv6X%2%7ZyhDJD+#E z{C;hExrh5dyZAX9CmyYwm;Fzs>I#$Xer31DdlN4wT+0=Y&e3?z^mUM51qBS)FG(6DLn3^eD_vCjlKiS{5BK*e%rp^cjkrj z!EEzg-?#^Tnf=4BSwwTXTG}G*7fU7gyKr7nUf{6a-B%i9tj4Yb{7y|L=l9pXTDg2v zGr!%A7h<2XjT>h4NQAAj1~DoMtdk0gmY9?bRC%AJ5&GE)EyRCM-09M zCN*ZS-)r{!u>2=giAlMh;qz7-z3yIZv+mhpKAR5*a!yUrG~IqV;ThBV{c^Rj`}Y`! zUzl5>tGmD<|K&?l3y`rKOv~H{0=*bDUlBN7i^MyVBys50K{^`$kpe}ip zj9lH1hdH-%xBH6j(|znW%S7|&j(9)Nbh0bx^np~hC*b)fP1b!3_*DGtg348m_ew7N-rSIQIH)y$_l}>l zI5@Ydd_SvxBG`kelvCrv>!i!zhPjv8hrko&@h8_ReqaAgd$;x_@3OWj7I#5|x1c_C za9=_WM_uMAzO0_w)ZXLQOMZYhDCF$_`)&2g-sW_j2`{*QdGF!evZ;Y-@6`0`;1j44 zsv4^g*Js{X|89?mylvGMNree94{jv)pPg6#@8^`ib0!#7$Zq_s{lfqH#dWXL_W!!N zeiJjF#e!FlWi65$|7>hziJr88^OFeZ%sg=KX8~8E@L|KBO3o+0mtKopo}@e>=z)Lz zui#goE#fmacHG|B`-7)l$@b}&ttD@^->cHTx^rippudNuV2A1ht|}eRLQv;pfezD8 z?*8=|E}OpJDfXXsUoTsEg42V?{q}iBe((18npoX3V?T%Cr|auf@4EF$J@u-Zdni0^ z<{QtJ`YSUhrLlM^E^yF4YT^lYloEH1?vZN6qBD|hzwf@6+SE{^+_tE{iBqQT$3yU` zd`7FSoj%wvf3tvjV?1we|9gkut7d~dfAhn`!>jG?HU8HwxLbOC>4FM%mb2y3jnhP5 zT-l^-3~DV2C>Ufn>K=-ZpD(qt`un@cMdggk{bK(xaX-=C#xHASQrZ^JCmS<)*JQpU z?`3X1*>XiE6mQ;4pC9}6*RjJ^CTb zmYkn*df$50Y}J&X-Y2Fl5t^zixM678*PpxX zqiFnD@B5wf%KGo0E$1Jf@!azHo%egsTYum4{a&$WW-8~=3!F@TiVcz_%eS!nVPF(s zU=%R$eNb(5;`c?@(;punzuL&`VWq=m$uqV5{W)t>m(%@A?w&ko8U9a-^S!HiP#cfr zqL%Zs%!Bxa-B|XYh)6zEe*X{SE%MZ8l&hukyJvCF+LGqaE@9Z?PdP9x-E040^H=hQNi8?o%4eFM+N*feUYh-m^#=xy9X$+b7hP9%U*75NGI%K+z|Oc{*rDOwS24H0AoCblgp>+8^D25$lAX-ie*Rwl^YioP zXAjx4|Fn@~Zmj1h*t98jcbTWq!<+uer;nM2rbxehsDGN4NitF~rem)iVX%z3i9 ze^|+v`BQdtdw%59e0qVKNr3@|9_TQso}7DFW!Lm{y+>J>w60!JIUTbtO7xvo$AKlD zlS{szz5TNKbmaO}hkG?DAO0OXIcHzRW(~$A%~c(H*BNxnSQdGFyV%G0mF*4>lb&jW z&O5zaiygdR(-oW=(s$J>J$!Rv7uWprM;e*gUzT5JG&b18kkN}$F)NsCboqJK}WM>;?d!4Xw7ndWRlm1^kuWb6VeU^cuLCK4Nmk;K6 zmVIS7_k0DPx6jq&$H#iLf|vPp^^0;pKNNYpwfXZ-j&p~1wl91K51EI43lteIYz+C_ zy2Ig8&adcidLFH%=7K8%7B=<$lbGLUC|C6|I4IWQ<6@J|^0R4VP}JU*|InGi`_AFzYXgHp zS%IPP07s4Mc6<37%Kz`2JyaVYs&N9tTJM=3-*e!t>oRk^BN2erJL{vWK2tO-IDf^O`z&=opNiN2iretrhjYvRU2p2LSSW+5UjhZ2|L`fuMXOps=IqtK9i?aczd*^ubWQ!h{tZRq#e?Xf97JvHOc-HtC` zRZlJp)-TyP{lLoLFm=X1VVIO3ZieY-l-uSxk4jUTl!(WHr&Pi9wd~pWRR260J3xY4Te^ zGCJ*&LQZ3YFh|Q4k@K9Q4g3&4C_FG_nqu?L!jpH^_3F6Q(yxSN8js6g-*;(ydBMCL zzgB*IVw)fOaOvMgPtV)`7rC16Wm$jm!=rBfRoilJ&*D4xb2ILB9e1S%7gBp{`m2-}(+$P$r@l?IC zW5R(42b*iF8=Q4&{z&M5-6ya}ZoB=yCanYNCLL2`t;<&2*;(BEB5kRApG=@}+L?gU z({zKa%io2F>&Jb0s;LpOV#2DBm6NL8Y&`C?>F>|y^H*P68@-xaJm;m_)e}GEomMf( zu|a(V@m(g9$cl2cokG9vNSN%H>Tr6RuJg=`d)#WbY$~xYZTz?CNwS8_%#Xnk(;Cb{{GH?qyP2w_0hUfTRZ~xE7<3}EQ-etNQJmeK`x zj-L*)%l}CE^W&qKDmQoR$NN%zllK%jr{}u;zxO!3!KC%w>8H#3^j>JoCu>Nxe0zI4 zJbd>5#p#cZbUOa_Iel-fZS}V!FE97o|I4_#HrhPn@2rY>%C_IRwpoWj(>f%@I|Q&y zx)|K*Ss|RMKFLs}+p~hrWQAkNbiLRu>^uQK^c%n5ufMMqu_0kj?%~dDO_6yr$qzYV zt0yh#SZuy^$^Yk{_vXKqmwxe|ZSseryeajZIb7dtKRvhnm-Ob-)6-G${h_PFB0GiE z`Ci@a|GG2jXxIObnU|J$ioFfz_gru9^JmZVz>*+n5J4;R*$$3H3+zr>s|0&)`(ZhQ zw<5sTbMY27-hi~o`*pw9PPMPE+kaarc2|j*YSm}vbXho#4w+G z`t6_G`ulHdQl`z5&kmidC}ikVdg`|kYmnQvFS#}2xr{>x27MpAJM@csK z@KWYQ^PqVYT&2aw$Me$^yZ*%m1_FKJDrd%2Z2hJ7>OPFR&xql}=_xbPl z`|sb{njOBT$j+(1`Qtm836rN3_)Y&hMg8PTGspE#AD_oA-TZ3nexuFl=lOQczx%3q zkxS>6m!I0(=YQYxWMy32DR|Y=z`$WK%^~d58cR;~FQ3ZSZ}`Dbbz*|zt>%t`;1$Xl zi&RgiXGZ=J?t8oUUUAR)I`QiLUQ@MHKS|mA{c<_U&im7cVDq$dd%w?H=qAPSK&FIO zU?CH@=x1Q*a8MGu=l+wy(|6J%za^6_i_=O!JaAOs^^9x&y12coG9q^`k}Qz@7pJZo z>RI8++9lICX-U=8DOGm$e~xqt-?}>At~M(0TA6G0t*x)OMJm?6JYZ>-cJmE8ti%MT zqKX~|%~j`LtL&c;qf&S@=lY3>%C2d@4>@L@pJ!XT{bSiH^F4p0T>BW*FJ8Wz_y2{o zRmlpE>(BqbnN)XsNwxURwMy5oT;Kt>IKaWLAdtr*w}^{h<)O~abutduSBLwnEZ|^Y zYFYGTLdNHR55EaXu6b`f>HW$pm&)p4Z=bn4eBV^II)O&i?LwR@kU-RAX%kEyiHSp8ixyI>!4`fgFt54I3RJwWn z&4sh4Z%)2-S297K<&J~GC0@Tn?$Bhqp^@P|Z{4gXiId)#-4Hk4S^vMz@NQh#o~o}| zCtvZZKAm&$Z_|>A2AA(neiiMp>Rd_5!m2NUGav76=a<)ex=ps~zWUv(K@dUxuCS(Rqp&_Ewj_{Ps{m)|J0;&XQ+)o>cG2ysS2{{K=o6 zpTky#tX%SY7U$pePW$;OjZ91m0t}327O*pLZ-*4&6@3i=be zMrl0VSy}mBUB|Y(-s74m{p)A-q??!84mtd<4sqZ3r26gc?cpUp^ElkR9<4Yx@9B+e zS5sLl|J$5Y3%|~EuDOAiMPR{g23a*oL7JmFp>K`7-=XZ_%AZwS(R()@v{0SD>ENp0 zzHxg_bpASedUpyVV^zkC*%uz~v2|Ut#BXlY-rsuWlYJzO(|UT6ilgk6f@ROlY*rQc zAjZh@;$D{j6*h31eejKC)1~_B$}63NbnhtIe&WynZvuD3aw#wC2 zefN|pU(bdSDSbXjW$Ij6By*!i-O{6c^E;c$PaSL$abb4(_iR=dJw0XBJnKh^?1H*u z+V%l|)DNiZcWgT!9$%|^?P&SCJDRU{D@gmT>11M3SkUR9;%x?&H!1-Wdp@7J z893>q%GI|e$4+k34q5Ra<-5$==!r_MAy-$0hCV#h>ieToTv9Ue(1iA!4~20_OWk^< zUY%5*FLK#F<%EFYU8k;}d)&@Fzv$&*e+7~dAcf414hH$fS7xR#cSfhr>-l|mWw822 zNr&~?`>MXK`uco+eN^qQFNQbs*6(^Tcgy9g+n3t2XXNk55a0iL-EN<6s{?YsD&9++ zo^bgbAKz_Ak_C|uT$oOt(6kFLU-l*8&gx&8)BH?MeAxAgTU;+*buH*Y~R5Z(X!#(H8z=>1SuDN@cV(e=<%#7xDS|`R()S|5a+Io|N->zv4eUZhv zmk$<#a`gur#(ARI9*2yd&9sS+UX{=(q$6Md{)vtC6tBcgWRLtt1a^L?_|C7>8XT2-u-B%Uzac%tcYPtCir zVWDZl0fy{%cXnR8wl-Q6Xgo5egA{@ z|C{FDyCY>^w`XhN<74$rjlQ$Zep=7?_Iux%na17h(hpM}{QCO(+Ct~{HJZW8B0^V% zeB3ST^rCt9%bPq8e+m}fj`}ad`;h`t%8Z96p(zjCw40K!Ky-KrW|(gZpu41EZNiy*ArF=q%skvfEES zPw}3vxAsTWo{GY$HkF_L?>O>1sC4?BoyD)iB)|Q#&^SNOcK3Q+{n%YgGH&jU+MYL8 zWqP`YWj^Cfjm#qtcX>~$Uz9#iTszF?>-+ohGKXJWTzoY5h=he-xZR{8#*_Ife|#@h z1|LggXK^@C&%|-zZ+fdWr1*4FKk)nX?MZjUcWHgkcFIEO~Wj=jL5yz3LiAPgO6e)H<1J$bByC&%!O$`TPHF z^O~YDamCD)!OK_Oum2x=>R4IOA7#$-lRg*CiC@a&sL#>R5XZ!E;p?XsGf;|WX#6ka z;q?D27w7putw$@*?RjHqCb2$XVbdbpWsKjub8l~B{o~`rpTK6T=ydS^yv;Sn_p`39 zTA6&jZ>3@Ku@#5g`PtVS{8O)7`CDD3=8)r#sn=H=nyR9GcS~mQ{cXZ8KmB|@-+R^% zdCl#qZ}+4uT_6pLcSup}pise-`QqX|mERt7Ca`#3Y2W>R-|ej1+tzMPIVq&;x%AVM zlZ)@(?-W+g`pE0`NUh-A9n06#OI}BTKe86JzL2?uV0>0@Aj;p_Mww& zioe62ZvD7D5u5VQ6sEpDlnM4Bv@|hfy6b7|FYm?YlzTmPM?qruIgf4A^kP?)I@JI9 zQ8;mzZuB;v)$;?&s+pGi&Ha>G_I&Z@mivvyOYB>3M8B~)YTQy8b-111{L*N9-#mn@bNXd7 z3yu2kcgxpaT^%khx#fPwlG4}LZn1w@md4(DxM;({)#2--Zg0=u{_D%j|Kc5pDkLxrMndV{;U6T(cP`;(!IUas=pcYD?7d=$U96$4ksan1J9@HPm(j4 zeJy@-ns4@n1&-I=-QC^GbM3KF&~iW7x6MDM$JgDwX4Sg-qjvbZh&`!_&TTxmZhtX* z&%S?hoEGa!qv|F0>_7IJhyJh?S#w@M-_-6E6H=)*!Jv_+zh}YTT;Ym(i`Cz48~6U&cF)%L`*X*bU%$S;mrv1V`yTQ5Sg-2se}U1_ zyvHC#C?t8ga9&Y+`)KCmQvM^BH>Kyx`~BYDEbVChM6+||Hm%TA7E8(=zGYKaIx|Ic za>{}->$}=7V!ic#bqenK^kvB->$~$g3tz5|+PdmupT( zSDHTH1`Pn-@L!<3)8Igz`Jc}X-%3_3pI7B&`}vHqR{6U-|7@Rp*zGshYUy2PtLEt4 zei}S;7;;Sml->J6N_yfR@U#CvQu{?iy|-GcLUfV;zy2+sKPI%gti7{fj_~1`I>PFH zQ%sI8&sqS~JGIJtx?a>R0|C{Wn^G@FwM)iBJY`t;DuXU(Z1*NfLiZ~taw6n-uD#)iaO zw{P~>9o9~n6U6rG;rcMQr>Ccz-wSW!lU=oyZ@WSE^C`z#C|Y&6($}RCljnLxEQKx;3**vzKX{4BDU-^YzZn&FNczgHFB5y3X0UP;i01Z%9bU zl=b=2I(uqUnK{)Pwyge;e)hP^o-g+zPR=r2JilwEP2C;!!qeJIzBqFp<$Nh)nl)wD>vg+@cKN=3&(1Hm=GyxB z^`XysPaX5nY>NZg0%=4rFn(tF!5ww(ozBibMjCf(M6T{Cechw)TH57!Pk-I+*ot`T zu42vrh2?wC3cqm9m-u&LrNg(nD|grbz3RUC#x|3>jY&sUZhwtCoXb&+94k#M&wg9) zFfEkVJ-BUG`TM-Lx3{04*0^PIkJp^(Hkp@H)I$aL-Dz`J8?{xXd1rKK{DSYhHavLl zz2?=GFZ}Zi%_FzZ&e{9(+3am!%uij@k9?lbvqjbilBgi0gwg?bJx@Nlzt_&DJAHq7 z`S>)(Ey2ClR)?R@ulu*{@f6MAIZ?4cM4c1<|N9$OQnKaSw*KY)GE44H75Q_fa#G3r zuiN{*?i^oT_(m)B)Rc)i-pl1?s^6HqKnhX6@9{iv?dBS3_J{d+`yB_=X7yVqk&g|uHSEUDhF3*k6+ayO{ z|MjR_U*-11$$u6$FmP1Na8TmE&Kt@MDt85T%w#yft6-8^wD;|8xmUlvy&bwfZg0q| zD|?v4p1Ls!Mcz?Xo+x~cckdd%xmK^*s5{Yab!54wuhyEGWpN9*tVvFKZ!fdBqmQce@j zHU8weTWc0kyVPsyrgL+x)1&QYndi?-+5J(n=jGWyCmTeO)0HRFw$y;UD=Q{$&AO^} zo9#@Vam=2I!ne$SrfP@p;&s09yZXTa#?`LfVz+)f*)+b_`*pWl#q#eDg;U<&_jqkG zy5SJ@Xy+tV@2GY@*-cyDhpY^8-E`LO)8gC$Zcq)DZ(?B#TMNLMaCY`-X@Pg3@xTUo z7Pd>a|35#rTe}^!A8A$o{e4~2XD|9Q{lK-g(N~|Hoqe@W);gq1L{nsb=(*=6^DT?r ztk=E1zCQapXX_@G9r`>{CLV$F*i0)wr9>vzXFosiXR?Iz{)?r0obfxImnm!d6`6Y) zPKr^J;X2|rQOUJtj>g9nh5pRF<%e20vko?~MwQ-M&=a5ZPsg2+QQ(6GBg+f9{DcsG z76*kloHkA@Rx_4e*qrWvb+J4DXPzc=Yy`-D%ilh{yNtPb-Iq!}sheDX={?vy*HZf#2KUhC~MH{s8f zmBH7xWL^fPv&cQ_(}e1N-enUM6s)`dI{)^+Z@2UP4lv0#sW`;Hh>$c+yK+ze&s%%H zee0{fzPk4D@$qJr)$cc!->(hdRBKW15%$wwd;_dE2r3X1JQqwq*=WiiaCqkho}EYC zkKZl7UptBU>w=Q^x3+4}nSD&SRNgqP2h?X-aO?h)=MA3Gyiz6wF1O`uDlT}wOX$vr8V`*qD4ReSU44?awEZ#dO!2 z9NEJ>WUb7k8 zPb}x@E=x&gde~tcdgx`2UC+$TpK&BocVWHr^VBv>`i{=WoUoN_@&Az_QGHrp*Q;zdf z_$3SuRJ~Z(zJ&cz(y#S#d$n5CbH02sdRF`UTV(qAd0W@T>`aQ@yZ_H8?~QdykBXH= zr01MZ{QBzZwvGF*e)#$M`C2AcE|2Z*nm_F&(Ski8Q=>Vde%{*X?dy`+P6qY)%(c3@ zDs=UQryHNj5^XDHidtP5E=>CKAkZg1=Vd~CnE zvp8MbxsB%%bAIx#;N^a~%7O1^JX_2AC-0)=ZLxaCt9z@5-1o4y{Gs1H>B8|nS)^r`ZqYUp>LnMOxf1uyUGWZYgTEfcV)#qYu1@Ar1Ed|RPk^77Kswb#~0N6$%|yZOiE z%BR;_xy7B#pDk|-kE=XdQ9tQV&CbyBx3{+H-Yb89BxpxLV&=EYD*po?>%Vw)Xco(?)#_>HK{^mvKJ(`Q(4f0Vd?4 zT7~iA&Cd@Hx3inhD1GE?BR$KyJWsee=XP#^koJ@doIix8EcKarY1j9A)obN!tA2c2 zm49>7(MK*xmzH`?R@?U7IM%V|@2{`5Cx6U|nx-3_*7VhVQoROxk-)u+?Zo!WmsbQT zFYlYq{3-jvfyS_XH9viLHpnI~&bYXU(eTjO?dl(nN$0a%S(bWw+SXg!^YhQnHa~xB zfBpU+a;41ah3p~!9qjvm?44tn-1d04d~Ws*v5dP+d;VM8ogeehpG^l^^?*~1hfsvj z1BDCk50*VUGjnb5azD$u2Qu@Uh1LDOycM68^dx0(>ZvJ(rME4Q{tS<=HGS~!u=iH& zur(RH(q?C(b`~uy{qiF4;w#YM%Z$HYwCuaRG1)y(Z`Tx1O~!Jc4~zejCpEwEoUHaz z>b}(V!^aa%GcFuBvf$Q6vr|*G)936K=WUxbp;!3SN3AJ}&TSFhV!E67WUW-%I{K9- z|FOBSa(CwCW&4z0-wF8PZ8x{H-}$;0MhWMeu>cZ~ZXyYEaCbCEp*m%a>&f zTb;_6-Msuys^{%(xoi9Few~ep|);tt#T?FQ2`6q_I%=!c<+`z(p=% z@)tw5W`%+V+7?=iwYRMdULIvr{C>&4Q>F9l>-R;>T`DqNC-M@DyGq;SztNm;L1i^GWTRJv9+s?X$mD zsWR6W*gD@24&uC#c5cqf^CvA#3KyL7{xVs`GwF@2=VZ0ss|%gkvtM3X`snLqqYEp8 z)r0rQiT~DSJc@8K1Jf~%FB7?BDihvL`*bxtUXs^l$qet8PbEX9T;Mdxxe=feae9Jc z^G26UP#OB8_Mzn46DK_0etoFVP;qRguy@?fBGr-?W?2tx7=zwF(XDEi_}$IujBNfQ z7Cvtt1z~l+99hevBgYnQ{J+e){9R6#z}qNmo8m4ZE5?-!bMGhGG0!>gWgcnK@XV!D zH+mb-FOEZZb{0p^Y1vTy{oOVF{eK?)T3|D6|H7WPe`ap#SBd(vo@Gii1ILa&hb6CV z+73f(^jRS3>BcFtHfn2-$!hh5QLE3T&#QF1=n%EqZ}t>fh27qs*Cu}0)_TqAug65C zR=?83)vph=awnDE-^%|Br|l0hu~CIZ!zV4vrLStzvZ~zcJi6| z#_zcUeZ|jumrvOi4dGD|BN^ z@xnE~y7vDt4oRCh*Pr)hlcWFxqqv|$!@EVtnpT5?M!0l zGPI}`DR?YnUl(Kh@rZC9=Q;5J*8R#q=e6_)eA>R`>vy;M_lJ3Q?O*a}zkd~*?X_Po zE-tS9?=oTC^1FX7ZYp@_6uQ`rxAf&D)%v{ah5pt-o4nhVUNA5Ue2@dp4rK>l;b3t% z@S8=-BV=RHQm<8MXJ-kma=upi?2P36eC@CgrwZJs6+gMkuM+I>Y?2K3CGRr}*g5@v z89E!U-j`J{;hgbHW_G?Q>%wllo^P1kw&={~SHHf#UKUZ~*S5jskVx(gMn-WVhlY2D z+?r1-Ffb+hE-<@l*UrLt@BgbKhfc1lD9gUOD%7u}fBIT~^@lm7(@iaAxHb394oP5( zh%@Q7nNvGDIJ(bS zEfd{yPE%w~^wZPRuScC%*g1FEb33JzsVn%;@?1J^5qWl|@o`Ju*Gc{_N|>X6KW3M& zd5~0fu5fSs{<^X)kJa1k>=W2n91bwEY|&r(nL#*&5!9ueW2S^fFh*{ibUcOK5L z`aG}LFJgPe$0Y08Mt|+ueJX^7Ja|L^S<#{-|zow z7Zy6RfBp4({p@20)h)M}<%)cBU|_l9&ES3K?(MPg%Wt|&U(#;baTZE5lE zZ*O0{Ts}W+|G!_^0q3);G8kU|obaSUt+sK6qu6(c49Pv$`)prq4_oirEv6N^Dg-p* zXA)8TefFcrmo1JTo1!_#>QKhRB?afa-zADL_8`Vv8_YScEXc}?pB1?!Bk=ed+q?Vg z_lGWUV0>H3({OuxNq*t%-Tcc}T|brZ^wiY8%w%)xNw(ExYu^faS@%nupF6A3`)gm~ zVYbyVJB!M;+||r_oMcu%?|=zZ;__;|7y-} zn7WEXJ~Vt)h$d(_UQ_tv%i5m0o!9sdZ{P$C>VQ%)1CxS+e}eJM3wGQ`HhY&%&%VAc za?A6W>brlQd{w%7CaUv_tOZ2~Pg z^WShawiC2CL{vL$%jUgNKmQ(k?1tP>y)Jk{*YH98hlA{;{oT!%!WX;oTC-gW?_4P? zZ2tDb-D`VF8B|M{wg?^UtCL!PmPgVk;`B6K?!85Fmq63zyKk>t{QBRa1Bn6*jP8OL z_Dwk#xV70By?yS#J+8;tZ@py5L1}pi z|7h~bm@j&3Pvz#dpVRK{D!m-1Zf~Kxr25iH^T-QgeLn-+8+OdKufKP#>|58zj*gCo z9k26_|M=qS?jFr8uJ?uORl_Ssb-ReISyzjkZr}KI*5Sf@iwXfyet>kg9263m)Jyok zaf|E8Tu_MkepcD7XG5}st$M>79U!c z`|ZumWZVCLK9|+>-8q-W|5;vi0|!#HCa^au?P4~&c70{A`favP+F@%pBnO;zU$JxH zhkF&dH5L;kyk4+Wh&G)on|S4Dd|l&Tr4QL1%_sizWWBz&Hv9B~z4ib9En~lNKO>7dIBV1Eyw^E5H{HB+Eza2M z<|W_nvAN$sw?QPk_sJBdPA*{DacZh|cJjiHf2+=3X=i!^bu8H77TpckY){%a{C&{O z-@|{+GTBCb<0T6RKac4jH{UiXnH{t1r-(+tfr{wriwf#0m+zXXeO2|G^d#hXpX^)P zZHf(j8&gk&Gj`{0THoZe9KL)z%5KKJO5oT>@%CpPr`6ylV2hay7^8=<(xE6P4X($rS8XjsE?1mq+2r36)k~#ULUCyCvw?O-56}DdG_sdu>Yh4xr8VKvGV$Xieuy^)V)7o{;yvS+9n{&%0 z*$q=QgOB~F*b}lc=pbJgb8X%p@7tEw-nN%)H&^8{zIQLqWJlrSV-CL;MZb%W-;i*y z@%Fad>h@c2-6t8V-OfKXMKi3Kjd#wuEZe=)zwi39nH4miwWGsfNq0>vq&1Ys!u4WZ z!N*57p4saH5*CN8jY>WAV0y}ujhxO+Wh_wSMZ(|qsVVpR zNC<74=(fGii*H$UYQ(F>k*S?k@@h-tCzMPNkZU=o{$i&3yIrsK>PqBJu87*2_1CKU z+nd*4^8Y3T$&%TUDk^W>;~akj`scr_d6J0 zO;NDjR=fJ5{i?Gwjon>cT;?pO|L^q4nloQH(tT6^zAZak!sEUk-26sn!}8vrmd3LE zVHHQaM0Y+rKY#wzv=^5zc}e}-JKIaWXxskTGHvS>7?|!UHZa_^&h4B98qn=`NV^-_ zHBH6L4cx?UJ;#GHMtZ~}Z7W6u-AJisoO}n6+wCAzH+~(Wcs`gx6r#j2z zlTrS(dM?&?H7rl;gz8TIJY|31GiZX!)H3}u8Zl03Q4?~ElKH|w+2g@}7J&te!$H}w zp_tRV4MR8n7q~EQ0$UFxuWS*#u#f%j z7oMt#O0HWDb~p>Z@15)VX~h;r=3iUiJNnNuS;@G4Z@yCo+uyJP*_ZbBKHB*nzgnPG zSz_K)e0(dn3{&F<)dmLJoY``s?2G~&?o1_oyDnx;*Nwi`viD0$3ZG}O@G+L$jQ_KH zBui}9rY5l2Ub`swrGNX^3SM1Kfd?#-`jZNZY>qFV?4I4kz|q3b__n$6gJb(FQ0dlS z!ML`1lCrY$)RzplvAarEIWQ)#j&~32w$Qy9rZAVq_(kIdql)zxc&gsWeTmM#H2L4+ ztp{JVE?()s;!@4FpUWRcR9=x}aX4_3MPPyT?%D^k91RW?!WXKx39FWFYJIl2Un;it zpI+#s{&hyXZ^rRQzOA2Z*t~9eBG0)6$E|GU{QGEeQqONnH8VG zW~=yo*=64T2_5r8XG~C*`(Z18JYx0|wv%4`SJ*>A-30^C&~aW&2rrAnfvYTA&ds~+ zxhUh}qE&&5-Ig`?$b>wfsIu7e#|w3H5vW6N=FV{JFRfAhyIA66imfT9wXXGwV>Z#} zP8wMFvvProD~ovz-wrlB&gNkU#r6SNmPs$mF0Yd;S$DjJQ@AMY+?>kU@2q|VTAT$f&#oeDYB{q6rc`^w5-(X8p^vWp8io(Z91UsEx;8d8T8~Jw5eD8&?0#H%hzkbqi<&_N&IONN)|V z{i>lgJ`wJd3eLNo<9r}B!9?k2@S=qagh469N9cl`guzRj98fd5;W($vmDv5x?R+o8 zBsc6^zyIH^kG9|M7^^*C|7sV|f90=}QHRRnxT}uYm+hM6WMyTy7*|{nW!dpRP5t51 z_YcFa1-Hg4JY*^Ovs4-!^c77EOeOv%%36#}3J(IA+)J*%K5s8;cyLP2+gn@t-CSLJ zFU0Ow__EjMe2!YC)RE1*@&8*=nz^i}iC1>1dj_r&CzH z?9iF}vMjCXU!G4A*&;aMn&cOo%1Wt(=%zCQSmb$b+#8V`}s9I-a9y2 z&Cj%HJ<`XZrgv`7^69PVKkqB=oZ--Hbk{3U{wAB06r>Cdga;vV+ zU_S47y>Zt07#UgRHT|0x71!(f1$C-)^C@q?xN+LQ{_}e2GaZY9PVj-3i#BL;Dmav< zZa$bPz|d%*bii@fHHO-Me}4KMGw*2na$Uni-`}rjS(=^IDbJ_6MQ!~Rue^-@i5<7l zc>ek7PwuuoW!7^wF5cgLqvF5G$1S&IZdo$gy7-261qLQFA&(b_uex1NfJ`bYq!mPmsds*TeSLMW zwE3z-t=z9eRtJaIb7{pdU+}4ZNr?_;{M?XD6OH31n5b1Yx7627d?KiBS^4&sDa-R& zQZ5<%yVez7FunT8KI_K}_i2@d5+1()&!2u|xl=K|ayHxZNe{H^H+DRI6{O3&SAl_P zo>~LL-OFdYPc<@dR5Ubvb16KN^6*frAK!(WN9#nE6c=q*>Knh`5!UVW0_kAjXc1;)dGYYdtrglF4GqzpI#=FWu;+VE*SoqlEJ$8oHQv?n z*VmYxMYg{G?`dV8;ojvx-|lVnqjv|2-^aF#8^2hWZDavnr@v0Mf#L2}U-sjU3@nE_ z4(N35s{6?L+_E_K<+kGI=N?XZ^3M2FkloGFd(tH{n!Q+_S2ZN_?~?1g09mj#0aQnG z8XuAcRU!%IjjT@&u-^6anQi8~-7EOlB{8j#75u51>u)Xdot=MT#pTV3vmX^ro*S|< z=;t}d{vH>*8v)V`#xE8M9r+A0fPv{BXyi^`^A0=8~D3o&zWhu(bG~-PYVTgKgwoB{=fQF^ioJ;@$+*lmv~Orvg4OkHDQ|J$lohJ z53-Bt!+Zv&lK+tp{Xhd68zwiL;Q81ksx890t?Zij?6;?;YCm7P_hss_KH1;yx3*-K zX9m9sa&70A|CU;KJTQBqxx%*v?dJrfK&@B?mOsi340rAQc7O|sH)-D(XxwD1&3~HX8k&G8BXPLgxoGtBwb2||e#PaHQ zSV4j0r(h6zXx5G+a~K#D7(87ZLplo|A6xnOc)$0GZK2QEUO;_przGyKdB{eW`>}Y0SDkb#?XT z9w}3=z_8EVoOTZuN>5VvUsoYE_xr-dEpDLL`*`>=)M22_vi90{zynNW!V#W)Yo-+( zTFqFcv-;WD+1gh2wyR=ymxZhRunbf`KkxIWvNw+WdrLR?DwMQcfXu`^0FA5uD?Ahn zGVp;2Q?iOov3U%viN;Uw2?v6WJ$Srv8x_GNEofL4U;DtQ?c zu;;^t{VaNMB9S$Pa?tj?!vj#$=At?%3J%1ws7=}(t{PMK`K)=Z=g~cJa#b%BzrNjm zU+w3c&F4jQ8||N8{Uv8vbi}+_jxSg1ZrcpU>1sTGL5^Wy+Q_2Rz{KL9pu+U>#mkII zb5zPFr1bAh>)V;uv2)o{?bAz27HiGB+27R_ zWaI7qd}ns_q@Iv$kc4bF&>Nfqt-J zWO)&npLj)Igh}(|LnW1$o?Md)4B{rVuz##fUMExHJ^gP=0w<^Z=B+cHs87ni?)YQeIdmlz#TNj%> zRVT7&u1NH)-+31=RdpMkj{g1q{q}S7?f>(?*#GaB_v>^%))&_fG&1YX`pJ9#*p-NE zt5ts4w-pTdZ=cT%kpWf2pg31(V^}Y?vww-@Nrg%Bp5Hup5AnXXb@{eWCDUn=sIHtD zi# zIY%QG3aUoP+4ho3E$5@iK1Wny3yNMLgHj8l?yJoI}<<^1jM7^ek)J-cMrJ_n)J zbq_L`CWh=bp7gisXqPA-_vD`4#rwk6MosQC%s1wIS-YI2hSO?)!NWrna_*cv&dAIb z(atC9b-^sJV>ZK6whQ<4u7vIJ;s*D%92i*sIWt7wxv06vsUiJ%^`tXhoKe>gc{bbG5*6uOogn7_`fhERw zfmY>z#*<==2PYk2IMZoWuUh6CdzbscpS3LeCe+DmthRo%O`4|P%nC7H#u(Hf?QxLa2Qhi){(v#v@#d06pzd!9) z%yd7rTIh=#t6bxgNm(Bp=KHHXNdE3}YJUB{l~QIoEB5{U7A^QUFYHwMjLk1JgsLz6 ztSJ?77dpVwsXUw258TiC%Q8Xb+&{Ah_WwdFT>t;+YhmW&GZUC|`g@;HN|MsaETMl+ zEJx?E?3#Rg&sXO)AAE9te|vlMi?gAr!r3FQ^*Am#t9zwiZD03fzm&@qFAJ`@pr~hH zO5;>;Fh4DQ?Vq=T`KyIX1jNZ#mu=bhvFyP$?xahAf?o}Ptk7vgU2O( z+okMkDw@7OYSN?-ml1ryMum^3QzQo?sYVWFrzQT=eOWLRJ?RQ_Wu5*Q?sqKj~shPpK zx3&b{-kv|*OgQY<_cu2e@7-5^w^aO`!*xGVF3>mu1B-*hGzO-U$bA>;j2qRyDEB+D zPrAcsu}wx0Pe2t3_Zu!m83h}H01CzP1LqngOqHn|WJL^;) zem)a;$Nxd;DyH>K4<6qPnB(0btlxG1g70iI-_p0YuI?0xc{20Jv_>V@t{oi>#j&EZ z9FNPDJU6qnVFpD@G^c{YcG3OId&QUDs`bA#S>@7YQ{Mfj3Zq{1dv2T9p}(BZeos`^ zp7~q$EOHHI^14_5zt*(mMS$=!n_TB4He2^TnR#h#pk_Cyfzcq&so?NEY4xpm^?P%E zv7c1_wwsBch4YE(U749{RUhtsrEyN_gXYf72U@&yZ*L2Ie7xAsaY_QG$DGDf@0&)h8z8 z7cpE=R<`|W%l2II0Y~ro$9fVBY8YvOuWqK#51nnEFSh-uDf1lB z|5sK9-&#G@INk59)!{(JvF3_;c5`w0@o)b6P9fDGb-y_Qv(0jY zvahZA$ZGy4f8V=1J1?)*nLX*T&ie^plr5iM>#8{Neq%_#lgiwsuZv$?Pz>E)SNrv} z{{9suFE4q{{@nBL?(XvJ_1?>TX4cF%*XUCfco=d1fdnKJ*MdT^>%Q=@>;PT02?dV~ z&WrMGsT9)+v$*lBKK<;htL0A@SVwM3QM_txWfe75H~N~ox!Ac^donI6ZLRp2WLo|% zru4yq#tCn3eE1NZvRT!$eA4-x4g8b;3%zjq|0I<6>ym{zH#RuhembF?_3zJ5E#Fxt zm!8=ytbcs0_txu!@dArpC>A_y@;Frb#_{@P8%TFz9;ks_?3=a4>FSAFIg^gKt>u!? zj@q)~k#V#46pe?oKkj=zuev7O`n=$|+2-q$9`4;6Qz2lVe2iyn&P^lJ^u8a4*LP_Y zPt%I~bgq-RlC8W|@8|_#gT}TmM}j6@Vzifhz`XzOx7qn>bAM~D7jx{K4_XkrRr%1T zvRV(_)0dX>%mQUi1{MbeMkbC67hRiF4;U93H`U%)_q<};?uw6(R)wq#di8Gi`>>_n z)5BP~#Y&F)#6LXLD#|_GIQ`s;jmgJNTUcJO;kCVI04TqMk}LzG zyTA$OxHsmO2l$VK-P)45mW@{`!e+sv1EzDh&K`=?jovmz!o%yOjAyR&Ew(!MJwoeB z7S$@e4_)#7Qc?En+xh!>mtVj5e%Cyk%AhBIqqb&Ey>Iv6*bmMxudn+r>b+O~RGobe zq)WxXC{Q5M81m%orU3TWyXK#tu0J2NTC#guRq`B97K?!V%gcI?Gz2-R&p-LKWpP#I z4+~?j@4IJA*e9s$_CR)T>jC-tKZ+mYB1_g;MPw@}h%ETdJHKD*iU_R5=g@WFObgqC zWp(F`i`MV^wQ6h8Q!igJCf~jzvZ8<4zQ-pgGc1X7^R0S5t13PD?T6~_Px_7P z_x>SBilNY_cwbdK6XK{5;#+<$7P&rmwYL<0KR6 zqayjrVE>*seC{XLdi2aYX;c0#=KjRC`?cTaPQUpp)cn-chu3Qx@3`EqW7;YEUCrUa zpUR2Xon17gz=O382mZ1MEZDuD*Z0Z;Sz))ltrPWPt*-7a&o6y&fbr^bfBDwPg%_e0 zdQH{JdUeo~M<1YRa;+ z)wkm2T9wu`{yH<$cPF<4Af*ff5%tMGP}BbGT&#p&s(#vuljz!KHk;MZI+2_ z*)|J}MJm--UGvF>dU0-*R}* zS~JzO3!k4nylfCyBDkQYcvr~X73xk-nkAs|NCu7_pizVG+ZU$r&YJw`$|SbDD}O&8 zm;e23#{J^+w#$4D@d;+!+OqQ2j>5&SuCAW$HQ#Qp@XQj0*y(1uPcT z6OVi}GJm;brm@WQWgk5j1cc1Bt-c02(0$E{6&fGQ_!s4WY!LIl*IYfFxi-s5;O*kA z=S}kO-MO{1I9=oJ&5!5fb{4s68|Q6S@tkC_?_OToR!*YCkGiuiFY}$}q_gqAP4%}o zw71maX_# zW4`K@me6DOmQ0s7C87Qko9%DEeX=$C`jzGL>sE1z>#g}A(loz*+g(*%4;7>9%RLTq z`+k|y!STc}d6HB0g+jhv^YXZKLCv-YmY@d6^(D8orZ~=C7A^8|<};h>zDIIQS677w ze|~m0c(Ge=(9h4$%O^cnJvlQ{WwFO5%aexvKZ+V(1$I7RUw$S1+nbxKl8$z*0_DVG zJ(7Nf+8XvMX%|Z8HTE&su1GryThA#V#K`hO@!{t$hn3Rjd^8HZ7u@y8k7xIQeqq6USJanZ9omXl@B>xsmXDMQLYaK;?kcTKm)-y8 z)9F*5%qRC&fBz*Eur_+TU+%pM9{Xg#ic}nI- z)IulLscO8(XS~y3 zx5Iod+gWt;YlBe&kZOgsgBirfSoS1!ak?XY&4-f0kV%(Oo?W|VtvL4sQO&PY#4`-NW zhrNEeeEzl!vkSjoE}y?5{A&$XDSih0&%k9UF zUvhW9%e}K>qw7y$rO@>BaBc^Q~;r_lJ%(#~>N8;lNuC z1y}7~t}!fam-VA&9ypx7@N?12q@!J$c1ju-QXjDM%Y_{8mk*yKICK3Tk-6)w%ies5 zed*0`|Ldcp-D;~A-(}-{6xu1IT64Ora++=Nvop7HUj$iXU(@;eYV~@p&b?a|e_70( z_ugldu8VEOpLnJkvA+?Ml=2!5-Mr7vBeCGqv$L-y$}72f>djv2oSv>9{{4Ra{zuA} zCOq-wzjKokvaS9Bvo%v=32QbbhVcHyO+;f zykd8ie4M-Z-GM{L*}s%8h|eq4G_Bd^Xl&(;1x+j*W_e#zBue%#LApINVOF~Q}cKLewc-B$a>SM)EPc7ZM_J!=pXP?StL5qDF7&tftJye#6XYF-t z5YGDg*)8-Srq?tNwQdvP0&vdF8EFR@S}0z1<&l2KTm|+e=@Ez1^m%-dZ*{K%L_%jCWZm*XtoYaY?Gx(8WU z&A_rnz@cFs>*D8AYdlQny!;u}7RXvzsXu@1y(ON)uD`GJUf)yu`&-u0F429eKlpU# zOs!$(+_bm-oEPQ1P@wn~(3fo~F9f1@mB!<;ZVl<1wZqrFi7q==eZ+U#?{~ZXbz^n} z?EQKzTFX-?F7e%tNi%JJH9e^o(y8WOTWNObF|Vhb@=sHf&|mYOg{qc`cFqy_`Khqa zPUJ3&#?QHVQ`hhtzYq#p2x*xzupH_+@PEZVp_@4iFDu5(HqXyn8@c&dh0(LGudhe< z+x=Q``8VV9WDnW2_j^K0;}wqX;kA9R&+o=eL>9E^V^Vb{C&2!6Jd+ClF=Ql;G zhXdX=%@r!$@=;y3+g}(6$U1S2f9qWE3DXkc$Os|esiWWX3xtC zv)AkQ|1+{OlQ+qj;QHJ;n?J+k`^tMu^qaTGL7F{ocFr6%Sc; z|9=1Q@bI-eJB!!y+yA)$+8#1h-CyqQzF*P*A06$^UMW1~j*o+egMHFB(39V|~-|Ts3x%~@+vs3y!H!t&_pI2gIU;NA`x>>>FNAiqITTpX9BfsZ~agDWnAwD zUPi(IP7@7+O!||ie%-}>^}=#A2mq$(K60 za`XC4dUp48))jqt;0Uh%kIUERY|X!aZ&k#`MNIJyrEKp$1s8d*8{(I-uYPk}7pCWV4_vfF!o~t6WFG8U;lFuyjeiocf_2tMp2i%$Bm5vHw0OKJ0_v?fo7% zS1a=RdzBwWe&(SsAT1{bMgalE1HZRhF4Fe>#BtJC#eYJFMk6i>tEBx}x!Tb8hjoGaFA$)71`APyA<7Any`1yJi0tuIoXQ zwC;7Ze1G@(l(_k}rGfKzm%YvUW6RCne0rMhC(M=LB1A50>s%epti$UwLD-cH6sf4Q0(Ib9iz+Ejs1a zm+X8qt?sRg{r#HHzK`FBTS&MxtouE+9XweIZVU)~Fl$^CvX@bXeXfYkopaNZj&?;( zsl5ARM&0*!cR|aMeORxkz4N&z@8Ygtna?Y-3S6$O>M}SaJT7w&5qC z*h+1N_bOC#wa65na+NiBY&*bG-o2H%;F)e)La&>jMzH8*O-kV}ZM>e0+ zd78JlUizDS+?`r({e>17>e5LA-bUP*9qXLba(|?+HAWzeRa=~)J3=h7wDide?ytrty z?`*SezWctuxajOHJLin}KFjUzy|?nFT}ZVHN;^MK_hV%v^Xs|a!iE2VItUHT94bW< z^b1&7931!?PcCWOygytya)JBOINdGgF`;XtLUV6!a$TQfzvb(jo52@@s=po)o>MKr z%Cg6i!T80!4EHOr(=G)TEaq=$DChj+5c>E?(jNDp>dQkXe=A$XC91VTzAnN1>@*=& zuN5aJtN(8K-^;|5r#?X|RBL}LNM;PfUnKaiq9*fR^v<5#gF|xdf%W%EI$ik$2;CM`^LS@&J?FZzh?*9Gx zynQ%mWO>fpyM2??e5J1Ludly9srsILKNC})QiEiP`Bt$Sh$#$>J3!~4y=Q3rplZ;$ zDz0sbCa3)Mv}({|34M!admomGZaeR2CC?tdLO@=>kBRA=dV^%iOfwbFVr>X$yReF-XCu1;OCLIX4`3EJWrzhItec3AY^#=_^q4}uwAU0M0q z+vdm9>G7*lPfyc4z3EDythLB|xdpou*ka8C;iX$Ohs&*Gu`ovl78$<>;h)wkaV|G~ z?>p&?UVY`s>bJMHhCV+x_v-KW`}3zu+wEQ%y!;#ME8D6s0rGV}7S1wAZ2I-t-#zF4 z_Nm@Gr1gWAbUd2*(J1xQikhFFR)X5SPtVV{_tO#Dd{@Zo@ZQ*+|HSn=RAR&fyS{;I zW`PfEpzV<0B)^2C#-r=`B%V&r8%y7)tk|A^f8Rdi)AqmL7~f9cFj>ua)vmI)uO{p7 z`{Cp}%fz$x^I3DwYmDYQW*@j)e*Z1^9`C7IPfvRXEOOzTsvB)K)hzc`gO-}%ZQX^& z3%nktfnpk5*6FecEXY2{p{np8lj-%!vZ)@sChy5k_qE(zb#qhdRd@N?C34ko46S2- z9xt1$<|}gg)Ku-O9fHbNUR+!(`%ruiN1wwYm(GxnkB){;(}}EMte9t0Sra}_(toB= zYJpdNrB~9nXs6}VPVI`}{I+2C9>#}upxn1(0s~WtxS3Q88{=$_4?*SgeC1t>*8AG6 z*jxR5)vvFwSI6zGT4{c-;;^3izvSuDO*elK`ce4!*iWXfXJ?yRAG5dk6wd@2X8C@v zdcA)|rxp9Nnk{iIE-e~*oj3D1=PnXh0AK3yU>j(kKym{E2aD4K^IbbFIQ1**H7Br_ z-v13c!Lju9wV!EgnPZdI+@3D|wXn$G+@EusGA=5amc5Di`uF?&)z0mFp0irtv2YYT zs6B7{{l}7sjY(bScV9PEmeZ&K+tzsPbocjUw!7VHyR5)7?3+PrEX#f$uofuLYTWkZ zM$n}5o;kl|9_qYb9k%up>%pg|rt67cQK z&05ae7M0PhT%scHWuL3Q_R|C>m$`?y>p;aRXt2OSa6@i_tlxydaDfjRjh!L-_vYKR zEtwKq`egBW3y#M;@8`U{yRxlq8hg!L>{`%S@pen(%r>LoQ z`l`?0nC7XjkJ-8DttX4{s_r8>+gr}Hyb|QwFMjG#ot?~$g?*4V*g;U2PR87Zl}X`) zdE-_U{z*K_nR)6{K+Ajll)k@QK7ZAo%Fnl6dNpm+4qde*Vuy@f&5i9M^ZK)Y|9n0l zyeguRnO*3Lpr3g`li59W(1c37z&S?CbpP_#m0!T#JG`?0XlS_IZaLUImyeJ`L*68_ zoW=%o&X{FcTNQ3PUAlfw>)d?%`{H{*b1S7UE*$g=|Fi9E^)+d;oQlhT=fvc_zP2{& z=clJxx3}eHotGS()BfPNtP4H%*gTQ#?ql8_@L_rl%%HeTSbRWLpg^;+?#cJENrEab->f|9NWW+qn_%c0A@g zdZ^JXzA}}W{eeu+=c&xa^H`^!o0T`~?9p!VtMBgau8m(MV_$ct{HbK#Kl^?EzDYli zx)N>Byl%Ss7Erok;Am)w1x?Vp%9S}Dn9Z^*aBJA48rMVK_j9%9*t}cVE*F%0d)wEy z{@b;axBD?{j6CuB>gw{zx3t68{a`AM)7xMC-0$e-I(B}!FR?%W|2XAc`g4|wr_g;< zBco5t<|qHR|8|Pe^nA?csqdfez4ymB{^y#4eMJef)lYv{m@>p0r=9t6{;$>R_a?D> zWE=OJJbXRRwz_7uoQ1@5hdU()d3Ny>rW8(p$h8)dVhTYk5AHECDJ+=H;QxG@^3NGd z=H@+Zd?js^(xG2mwLR}{$nS4&nQQNeelHG?wSIjr-fKaN8)yJzpU-blb)fD)?@R2@ z^thD=j34b`ZDjs*dU|DfyRp}&Cnx7VD# zpA4I$!W)h=OQph9f6iI5M>y+zdjEdVJj9C&3tvqQj|)6+|9_A0ohE)qp$9CPb1eFs zKidEMakzY&&3oqiTf6s5bM+sJe7`<^|GU%t4U76gE>7n3h1dXF;lj$KARyH!`^92; z@O!sQ*5HAZhIN^jm%Wk8_ba*IcA3AWNv8UN>cf?4bHbepKI|=f8#TY8(9I^G zVoy}V_apAEuB^W_-hod;1O;`003*u_zAT;{OiYOm3;3@VN}kl1WaGE;{i&(ip?`mU zt$kkbIqs{P?<|X>TQ_`Y{@z%8;Oz1K!k}$Dl13Wme9l)N{h7{p>ihfq?`KQ8@3dvS zXMTQlJ=aTOm1#;QX-1?=DxO}RZ|GbbHXIsYP5c9xmlthb=G7NAkXtUEh4 zW?f%5_x%k65nGl%S?gz~8}^mF47$JO`=->>HOCLlwJd(7##}Q;dVYHUBYVbkdi_t| z{`-6gx>`x$K?oDag}JwkK5(<_@qNG&y58_4o6vEc%6`{#&!hH#y%xPH|Ng#LE0@pv zbavHe$tN0(f)5zxY!}pt+;n8S`JCyCe+LW9`R)AjS@jQZUX~Y)#ojMC-#Ger2-HEE zh6_N=l)Ekq`B@wk1eo?bspaK7zwGwBr+>qapPy^J+^t{k?c`HawO70KO086%UlUa5 zq&KCW^MkmQjqy1~i~qmB->(mk-kuk_Ctb#M9z%M;^S{q0PW&->-Ry4*o!d)Rx4^n8 z9n%^9&05^tz`$|C_kncLgK(j9pW^Q3r9axVzu=+M(My|By+hYVnSOoH%)biMGCtJG zz530~&DB-!_0!p(*FM;o-v0jX?(5}g7Vo8>YrhwF-`LN<{$hsX_4EHP``d@^(RE%h zNB9EgR7l#AQ*795VS8!93O0_4mIJ>-`p@O9@$QqctZA%T7qheG`j?lNf3GXQTRQ#G z{lZ6^MKptMgqfb+1eztPaWDK>mm24G&OUx`)z$CD>^EzkN;?0mzo&f8{7skWg9D902Q95D5Jg-4)cuC05+I`(Y^1?T+wR4P6Cw?kIcAiKMw zpF#d`*t{j8CnMj7@|!X>Uf?KT+MjZAlHzfP42l1hQ5wa+*WT-0`u{;nA?&Eq0?;ml z7Xk_lOnHh1O)_WwKea~7w9QvYXkvJ7_JG0mN|Oz1y|9Tv^SQL5$vs?K&qB91G<*l` zm5Q6a$W7rvDpUK4qVtokJT2TZUAt>nW5a$Hi`Vw)ANjWyG@RRIpO}cQ5*V5Mpt7kj4~$xxdxpo{}Z6g@V92mP^ZgUt5RiU(tCd zv*7c^x`nR_tD|#nZaSJGI&0F#b!xna#6V5Yh6Y6QjG^%d=a)tC;tD@G7C0!xa2{cM zVfAXhY4)`Z{1+^{cR#$;{^qJtj_@-`M9FwDFz#}eX3P7#f3J1p^_92e?d#?g^hz41 zo>-G2r|s$I($ zrrS@K^2gp;v0tdxFs8F%KZ{Z7DUo0AdtXa!yt+F4wU*YUBBPVsS9~8Axl}1WS8iZn z;$ZP^;H}zlZ1O#Y28WnAw^sajmb-q+`R>oT;!K*Hb0*kZJT0GhW~OobzvP#@juqVA zmb2&7X2SbH7k*@mbTt$W1AUlh-9OOxKHDwNND7^^WTL zXY-`iaqN^}WD)qV-Jz=9eEv0%Lo>Nn^xpjYDL}sZy;{Hfr9Dl;f3y~uJ(~Sw;jx&z zFJDVn)~NT}UwU!j@~7wWr=9PvS-tbVRs71Jr50Ze%j4d$URxXee4oH~)fJ{*f14&& zXYJU&goQ=G;Xpal%bM#+Qaubz96N+HRP^5~^|wC_JP;cgBdg4~_2)h1e$!6@@tFbf zGXFf~cAIQ@&KG$spz_LvfN9TNr)UH!#C zjoUWIoo~)syy^O@ z*u%1)0^T>tPjY9goU?bu$IX9=7u#If{e<0CWR~XXFn9J!o+<6SrZ;X~zbbU~vCwrf zmU_|Ka;|N=sLwmwJbzxUZ*9EUigh+Ub~EmpvD|8AVB%=;ZQ!lC;Wp==QiDTKBj+dm zR{@>{<&}3d`OB>C9X}x%c{HhV#d+a+RsOAp+aGN{>bc7<^51r=Tc;iuR<4k)i2NG# zeujDGC6#p^6P0TI#~ePP6S>L7Su?8pguZvMd~x{uC7+!b7+C~3IvJ$DOyDuO>%!0& z!g?hwQ1+Gaq3x%w!(Ur@;xA96J zTls$e^HWn#_qZI${`qF}`J6Y2wKrFIetMCS{5V6H37p2j#4?sEyTj)`HH?#c_4{0t za%l74OV6___h|P!ehS$CL?b(EgUzbt{k_Sc{{O|T+2M-sE%f~6*=Sbm6rUiUzrD7O z|Fgz1O)*AL#2Yc*bKIWekio~q5uyB{JLlw)?)I!HyB6N*{j@@%zefE38SVdDep#QA zGQFC7qU@CO-%U<`XI89ue|**KZJO&B?750PY1S2ub&;FX z3SGO!dQZ=%AwHEuxsMX zTPx!A`)xjHsPTX8c`GFTKkmz;`&W-YPyXtC@$;sg=iVn%`0?XMMM3Z?g}Os9fQ&X427yqD#6g z0vrn)c0HWAYx54POI0h=Emof0ZFOZ?+~1Y=m_qAU_1{=!FTDT#8na8!pG^F*{MY|i zea~LKU*-2T{n5g@W&eIZIco2(@-z6a&)@pEOzu58{*@+gFYmE;-fO(h>`D2ZLid=j zudY7!nx-Q;-Mai8_xl;ky^p`YR@!$UI)Cre>1TJo+V(5tyzZv}f71u8pps6&f$`r| z{s#*#sj>(-Ff?|sXr0=8e}enlj&+}2JUP_Lef;G68OKdCE<8B2`+4Q(XT7^0b!pqI z>P^xPTO+Z(Ztwhe(GuTVWwtKskwHpQ90~#^jqR!JSKR-v-QhXoPu$LmuUEs5etUa+ zC*z#o)%%x59@_nWU-r=*?t=B}*>jaH$%8Bh#UVJ^uXo_P`Stsv8xob97HS7C>xtM= zu<*y*?e~u?bZ$Sgv-tU?J26E~){H;r7AxAXeQ>fus%!P}L)Nt~Es>qT;_7ghBX9FU z-;i0-2iWCn0%UBfuH4O=yjodI!lt5NR&ug;&yq`hZH_aid|`%J?ZCjua!CC{i|_1p zoWg1@dp15{`p(oXuK%s1c%E%_ng3~jp~LM@>sPCLK%y0-UI0YYC>QkRysU{fdmg$v zOjO!DuVnw_B`qshp3MDdd)wi3`c>|qF{S5E`Kz^EO}=jQJ5B9U0E(BlI*8w_&dy`G zzPtSW3bUy(OWYSkZ_k^TH}8Jk@3-8%vUW8)mVb@e6gXe%m89QuL6DVTdj%X0h%>#v z@oC-8nwVKXUM%ka^2SJ0Rjcv)z3TIqeT&z{?EH6WUEJQP%BcIQ8*LAX8&7gm0##7p z;!~l);RQ?HRNJ`h)6e#Vt`19jer|4HuGUVE{)SKAf9-zQZ~N^=YAwrD(Qo^pU)UqmCcy)$m_wg+4@XK*F+eef9?0_^a`u6 z^L|q8pyUR#d!c}aR`t(?y6at1QUpcnq-M#gh_tW3+_va@igU%$K zXqfDF{&s=kxB5x-V%$f2mQMy3T2LZksRQ@TRq?qu=aj#_6?*>Mq@Wn?Et!{(eeNxs zrW1K&o^5qd?rTuWue6?Y8%QLOMZRH z)ZTr0p)tc5wF~47<+$U?D=6bzP-d-&euu(Z$L;ve)koJ2S`9coA>Z1-~%qq_2OoOXpaXYAw4P+#j?$ zboI22XWz$`-xUq5-~az#^+fahxZt-os?U3VZQ;~Mj$a3d*#}}bEm`}?VCzQDt@HY1 zt-GAt`CPX;a$jTt@@c?d~&8f-%w(tMzyXVs>?ThbD?>NWY*eR^uRr2!E%sU^lc1k{25xCfA z+t0@V>lI4mkaK1XcZ|AsM9S%Bd&=J4O1itNR4&I*($pSY7@7-9@wS zn_h#4Stq}(Kl-(22?Mf^IF=r$-E=)Y_vW1MZ*Pa+Ue?oehdbx~zSt|P!_Pl?_RT3a zbahzi{U6?5J0AC0`+R#mF<_lqi4?LE772N%um81OSNby(D_6@uw}M;cOZ2#F9`~BN zY|FXnlb7{>4QK{gFS`EcQ};d@!PHYz3~$blUOa1NOba;Pp~OO=42|mSv%L>)ZOhfJ z`}Z^bt+WwWkDo)Y>*;B_zIiGCgRZ~0xOj2)j^@>%eMl2ky~ToSe}|siY_u>c@`Vm^ zVsugYutoR%tkq?E{(L&kw=Hx|lGlT+*W-kD7CklE+PHVkJiobCmG`dJ|Nnho?e}(< zV?RX&&j$FpAt#*!+*796{^{49{TXyk&QkB`Rr@3tGo>@h*M6C}B4p*HlfAD~OF^fa zMkbqrum77|8yc_r5L|)4ax_PbzzdCj=WRLXs=vHgnAq(qXvK1`?ssnB>M-5Ov#+MS z4%#mRnlC6RIaw(AO7A1v^CO$rxI*(W#E=6L&9f(jnA=zuKNFd(=3BI<@sZ14rsaNf zh3xAO{Lt7Uk9QTNsC`}=AaB^+#0 zv(0KLwp?@_$zd(w3+C%e7hmlYkE>7&`@R0c_0@8^+j4Jjn{jWd?a~OHpd}p94oSh*&UpPOr~&L?N1 z5wdgrH9m87^S=8Pk9jYy3e}#d=*)IKd8PHTSJ&2Re|vLN zIC%9Ft?>J&uiw2Ma;n<)K(=5kQZb@%g-KufPQ;R3oq^{sgw1x2JIOuAzCLb+^K_iKV}e!W<%q^Rha za%#%SCv3)xc2#|Qlliw|o<*Tk$cg~PMRhyp)SqSABzBP(DN{S?UO4;on8RzeCGq>~ zuI2ChbI;-Hx!)fjA3u6+ZS>I|N#i5k`uj9ynP!(II%j@97IXCFWqB6()z@f7*3x&Az|iZtqL}|6*}}%vZ}pKX*pWn}7CrwvewoI1s>u z!W5?R6LIgm41RvkS$uI{ZFS*`3ySx1_x-t$@HKDeuN_-=y_~&E`uB>!#Vxx&@9Zs4 z@z<2|o~BdzQ29q)Ew8-Yoy|KZ_uQNkur33oP@2!RC*kz5n5~buUXT0ydf#dBw{}%u zUbLQFdrJj$XU-G1K<`*t>#{u`R+#VKFIV|QP*;xc`8#jB*x4CoNCnA4!GQbzbKe^r z{9a=mxIS(#_xl&0jFdl|F+SgMW~Onq-MU?mwC(Kv9V&m^{3Ywcf=18(atkAGzR*B2 z!cKTc{I>5M>&{NTUG(o`e?3d){nXNUP$K8qU;VmDIBIQ_DR{%^TPfeid@>da>vleq zx^5?UX1|qP^zsZnB%>O|PN-Cyn>DrEyL{HUk%{#PyL^qn*?Vo-iv&Q;L5<*LJeYPjur(2imzMkIXZd_P^-)vog=pV7MM$v%DsmqPH_lGAHh+1~!8Lkb zRnPVH`~SU~KX=Oc=vDL5<=#ddeY8u;G^<0^d)kkfyOE#oS3Z}WoV@vf`fJg%F5svG z6ABxcn3Ff2^jdjNP}$Am_RfN76R$1X3tJ12-FUQHyjv@D)r>m~yH;tJzq^xkV?*M) z-*2}wfd;ov=^py|*DoR5%Bl_IAc)f%jxvRx-u5@X<>c;k>DDe$?XLCvex1s%R=>Zk z{K0|7dA&=;4MEps)K-6g_jT>|+imx&-|tmB{@Szqy6!9_a~vM9yqjqI>uPszh)L?V zcXy*#NKg6rDbC@q(35G=d4@Z0UJeTH6jD{IUZ0%Ln^kvZO=NKQ(!-Xw^a@tX$s*Oy z2b>tQ^H`>v=f@c)9%893cV*1J`T4wkeo^!Cz3c31f1TmFF~Q}^+}Pb^oi>%9GRl1u z57)W<`|l;TF5ZL_QBO8HaNJR;-gxHW?(}*2Oj4#8dcb=SiGWjxBeAidZ z6qGQ}o72(XUv6V&cGR;d_vAd=-)hE1->w;DUD25Q_~%B~*Al*t;P?U)2d*7ke+4t+~>-M_Ic|R^ztp8CZy5u9Y002c% zgu(@%Z4cAuN-LYEmcF{;ImfQn${{+TdiSDvbLXmhPjkpSC!G9Y>GZf;>F+saWZsM| zznfar^E+b0vWuXR5U>jv7+GpG4KAHci+aBG<>lq#!s>n|o0B;!bwNwMe*C`wKdtZBd3EG#un4l58ZOuu;j3=kBPH;mikOY()Pi=|=#m|HZ3fI;~i@)-nvhv*O z_@*bPr=Ne4ru(dPs#fT$ADzPLK7!Ga{ks?wmif%|={=fXRI4evcx!JKQn%s5R0sW= zx00>y|1Ap+`~UCn+B+9m)&_!FEU#WO=N&t>IQx1<$h-Jox7J2)U%;Dr5^WZSQy$GlYw9~RU z=(?4pI`5N-k#gB{kM!Iwe)9dI@^S7PqW<=Ow@lu6vGklv^K0o)lON_O)rFMf7#kHcbEACz)jT;dv2DBZ!!>!&&dhwY>-9SC?9VB` zo=c~$xjWbCOu4yW`>V7}8&!vns;{qR%KZM#v!*zt5y_mZOs*-f#b(_2VzF{@*40&a zIL=*o&&9?gkx=yc>6UfnDRWlzZ(jb*=#wZH_xO%d@=pNQM#otHFB zYME%bapxrc{eOa2Et67}?Zf*&&$23A zb+&rSfi1Zg7C5>cGdXnQm&3gIwud4^edpDi9I9IM>i3_YpP7yST`Wtvv!gKZrmLmh zX5}7MKcxEWz;>pusi(u;XIf(#ZQ)I`W)NY!L5hvT5+boCaUM7guW&o zZeuMsPYyiKV{ddiGp9x=dEgDZI__AR+tD*5#Ebn$L6-LAWO$||PoV|RzCsHp6a(?45S95rqE@4UOGO|~0G zZeHlz-lkF%^zIpG%cEBKx*VfrQBm7xT~a`5V8n3T(Ohqvk;MFXN#DBI-EDP~lbIeY zogODN(>UF1=ft9*>(7ncPVMY?Iz>-czrNs<=bxRn>A$|bRBJo`%4%EQU9EL{K6$A> zUi)~?W4WU}?1>%|k@C(GJ%eL!+gz@H&Dv~{c}ZopxtwFhooTw!F5P0fB{@AM(?8BQ zK6&fhbrHU6=d518FG|Ly!hmDpqgDL#YroBW_rqiDp07ndN_#sO9DnGBTy9y2uh8>1 z{Uo8KK6?=xuN24Eb<+CztoLd@`%W~?4x22ku3ma}vf-k4JMtcV?V4OsQth|ct#^;C z$NVXFH9rc}AFqEsM^lZd!wRV(cR}|;xLC!tw`wlezxvyLo#MYu`d{v|dwZ)}cXiHO zXLvc{T)^FfZx`&*H{E9MdRfuA?T2}S$+kV=>*LfOzf)y@d|ngD-w}!hQ*&CY=50CI zVtI7ey8ZvE43m%X^hPswdHFfm+S`S%iwWzgoOI*2+rRI{ zoUeZc72V0ldOjXscj)-qIcB-D0?f59o94|rbyMT?&YQ6s*?WIQ`u_F0x-;|gGP^#N zTHpAsSyMau`^`ls??16oca>?B1`i`5T}@|7efrhgC&y{dmB8I)xuBC!Y9;MeW5L%r zUR)b(9z1)2$1BN~M$`80s@XRAMrrlA;FH`?Qbrq(E0H5`TXvpr>Az_z4BsT-R_=+$HLBZJds{_FV%L1_PJo~^iNMt z%DFe#cYzj}zmxD@yJx#jpDj|$LV&4}XH)-wvyBf6g4_=_u^#>M^77w}#UBc_tG~a? zExP=8%esq3Zkv82oHH#JI-Pg^K|zr4Hb?JJYEk~!vA*bO~|5n;-t zQLy{XWwq_noUzx-UtDl}b9=jge3-xIbj~w#t;0c$ljCY`>5}#*B(h#_{`qyzx*h&& z=UA1#5;z*PkZrTyn0O?-wJ&iWDKu-AJ^*rcpC&z0SJ5|kfpJaA#5 zb8l}t%f_$sY|Q)ppI;Ie{9>H-+g-l)%HtCs+&_YjTs|?|JpW3cVBgiu$~w{c$5hWE zdd43nI%M9wc3#OR%+|YWb?9ofX?n4*`emE^qkn$A9?xBR*f#pupCs!mv76t2zPQJ8 z-OAP{|L>$7D!sJC)2`QU@7b{V42BPDH}aWotNZ(O;`!xbXW@nEA;k-RWuH3^vY1~@ z+2!6ZSGBp^Yq!sXpU>x;?_5|Ib$z)J8#i0ZDN}R9`9|sIbpHLm|6k}~P{NlN7yTal z9IyP(=`rULFCsCWW{ET2II$q8eb-OWYP$1jhn*XBqqlYJDt-Ox#)20*k6U{B+jVA( zTg@^);CW}a?ee(2RdQ}U`@7yy_@l zySw~%w)un2*H*p%{8~!C_vx8QsiGH!E|!UX+UT}gkH5_AKwX?WbSH z6cpc+&foJeSK;T9FV5|Jou8hbw(fP5eZKPe>yJn+RfQzR($8Aic`V@@lUxn+@7c^> z^7miPvl)iTEx%qh%$qLKtNi`D z#FC$@U!>2gJm#76%IdkTeslXKL^k@PAK+S+xbt>P{PnM|-aVXcp8qYp?fv3waux*+ zC9kjfUQcsQw>y4*f*6NP9ZWOA)0`ob? zJO_SZX~yNHJQ4;6+@oXvn|___ZzssgE#{N`IpNpyEaR%^56h;lmb?3^Tvcm$FE8i7*Yo=T~$p$)BHtFA=pK?p@id4V4qPfuS z(wh_=p81E37X`esy&K9gr>&HrS z&V9N^FaXVe4XEZr*a&{_I@q@^w4@{d#@*mc)#IKjkE)UtN~oqa?iIU5ejJ zi}a&iqW?IH`lD~HkGG%v`SH~gPEDJUVp``ysM)_AeJpYAlKnQHI*zX_-O*kD=i_nT zJe@h$zHaN88&fyW#W3&pVXJ3xQK?h3LcL^ct4!_)Yk0oD>i++-(d8eX)stkBL;B$j z*asUA+)w%W>hTe^$!A1f2c5t3@55n!&wsW;5ql~&?s&Ou_8N)TDu&zR|9!WWJ6;*l zRe$_QOy2!{d))-T zJT!TBciwWlmm&8aODw8@8O*?Vn5p@$+6$}o@|HzQzDJgLWJm0++UnuqQLtO{LhWBh zNqc_DzMmUH!kx>$tU32{W>Dm-cmMbN+kfE9Oykn?6R({5?bqkIZ3BzRUwD7MNhctr z?A?DKmG^$HR>bVw6tOKw(sG|W(<{Coe#Z`euryAoRc*F8sq-RQTsS#uU5w?&*X#FJ ziR}HS9d`HWy_Vlct?V``oXcQ>C-??##;>;b=kuyfSgE%9)yKH>^YgyOi@j?Wdw*l2 z^PRfiZ`I7X{a#rqC$C@M{p0DS6D(I^_s{L=US0fd&u2gRGaSXfH7^#n$5gsmq$w+L zbDl#~L>pWad|Eo^r+cP>MnZmke0(y4jMxFsMi{MxjW0*lIO zWS>^Jir721^YPx)@!q?;{C;h@OP${F7ZU}J8ppz0-8K3P@>tSUJj*Agm}OjW$hp67 zZpuC8#@gTCI-i}LJ^PM?#oFwK_vsVstryg3CO!GsS^VtGM}<{?BcJ^H``h*9rKNMv z@yk9p{gmHvsR$NL3N}oy)MBhA+3TkA$l2VOe{&mu)Zc5-`JH!m7H3PU_Zn_?nii^R zbNTG8dG}Tq`ULkFemyw@v@twk+lmk-F@BG6Jt=UfI@DI;qS?@RMam^mq5!9fDsu`QrWy z&#2uet&it@EQlaX`C6^cxy_kqMcXk@H7+dzdeOZyPM0m0IALx)(9UF=I@^Di z$F8|oKK^*zZ+$+(^76(5KR-Wroo`p`qxQq^bye&!*FF5teP_)6(=>VKn{RVkT3C*M zlx-6(e{)0e)ARH1OX7CgzMmqqKPr*0=vN=CFqt8CLQ%Wsbgt0a*T0gEc6IvO{Z!$p z-1gB9bgtGE?eKHCht~c66>C)XFVE`5O8?mhYGRA+w-){S_BOj_-;J1ukB)Yio){GUhf)}KCqV`H+dxxdl6|Ic$J0grzgZHX%iE-Y|dXXfH}Ouwsm*@^5= znSGgE-Fpvg4m{#?|;xU|$e z-6*m==z54`z3SaogYe%D53+6^vz0P$(mZx;_xpXXYl2!HoGE>Mt@F%GW9ymSR_A`k z_7!HzA5r#&m!)e&c7$%rTH3kfrl;)L+2+r89+S(FFw42204myKPi{YFDPHn#FotwO<+`heV&=$Ww+zLcX!Q<5uV3cz;oFYmaQDR9lRq? zZK-mcOr7`?YVhha$W1%`6ii@PE6OIzjDd#Oxx@fpDP~}mT4ME zF#VmoMl$dG%E-;jK(}1AZZ<3PjoO&hdf9T#<2`qac-C{dow&pecl6u?i$8q|&J&J_ zz0NObq*5lC>5%>JalgIG^K)}cRW9y2U2!k=MNz2-%dyu{@j=?ltG~ZvjAdN({@Ra^ zk4w-0ymBg9W>Uqn*|11**u?bn$^W@IN*_yu+;<+ z?Xzj_m92rtT$rD!GV!q%o%p=XBGUcNyw9h!*Ke2rdwZ)h`FP(%iEI&z;%7ZCuCAWGZb@XirE=<>6pkx7i;UG+@~&*X zwCb)&mBn+S$Zu)_@DUeibF0Af$Xr*P3Uf@TGM+nMf>QkM~@#LUA=yv zR1eR!MR8|lnR*qGa`1Mny#OJF=yLi&E@{{#mw)P zOg?G4w04VQ(Z^jrpZvdi&)t98Irqm^-hkt$k~?g!)bhTY>KoCEtWZN?LYmzD=Px$?N*n({a;1+?W?)(3_n>sF661vIGr!?>n0nl zWXTZDQ1QO?ppfaYMPT;jWxY3cm#_c7Ik>xOL)qJ?h5NJ;PD{k+wExO@ReNjEj3xn( zxCPTYckF++>-CX^&h0w0zLuFRO+PewoHkDze{ z>y_RDAGH9@Yo$j;!#f@xZofS-lx>CRdAr|hL?2gs&Z*V=A7}7t#ZxC1CEmDS zZ*9+)Uoh1sooiuD4W0IzwLhnrlUIXzmoPx!2I z_ZQV8tCsLen{~9buuSgUICWu<$++>_0-Sl#+$G&iN5PCNQTt#h;f zllpk+7c*U-=ZLM)kS@P>WS4pRIhnJ@xBedm?VMAp{q<$rT2HlGpSyc@&NK7pxdm&+ zZ4|9I?9%jVNuP{mQOC;Q<-hDdZ&|^9dt0usZqycoi6w4P$CEemR%f|CXlmH?+;Pc9 z>5o5;c8Llf?~~n}k-A~A=H+F+-8U{BsgPXde7D8a{IdWoC_J=2OkC)qa#m%H=VY~{ z>+536QhFIPkIv5Dr@3y=r&A_xd5<5kiHzr6rpP45De+Tv>92dH>rb<`@yTZ0mP*}Z zYk#ux!l^|&9fF~aM1?k{%{=*Mf_$n#+g(0|^)kKc`z~u;W->FyYVGTn6347Vl_$(P zU?lunF+27XckFV%xpUSjI@-SXm8^et^9?Na6-c^YK2Yk{l7U7mM6eJYo8C1ZD$2&((fQwhAPQt;6bZ|PW}~l zNoc1?Q^R+rxp&uP`>oTD+Op!u%jNS;&i;8IvN`!UU*XrQ;ntDCO?Bs9-)pxr1-CpD z8X9<+IQ=HMuRnisl4^Iw<6iTo$)QmfCi~m}4H40cxv_0Y>ExcJ(YYKow;CK+n9f)4 zWn1+LbV$g-Q;G4yV!BZ&x2?ohe_P?db7lQzSUbtVf%VeKx?IDF70bfh@9rvX-L=|6 zzn1Cl?(+UnrkPQD*Rzz!U0hqhQInapR>mNqVPC6)gX+rJ(X&2$_muT-OFnhc8&c66 zQa3QUcJjo5MrP(IPRI6Xzp7sI^wiYNx)c989*cbZ!B@XZ#-Q=hCVO|EH8Vk{n79h}zcwt0_FpYkow_(Pw4cSDE|Ue2iI`G(K$V^sRDo za@rwg)V|lY?9Gf7fs5O6U&pSwZLHDoxknFDTM1Y-{!^QDW=Uzvi3yIN#%iL}u}nXf zc{QI-MyR))y!wBh%=emwvja;ke3&--u9@G=##^+Br{&$8t=ZSRK)0{$_;z%Y@8Uxy zj4!nz-gOj_$W}V&v&MPv;oU_~PhC)*6jvG%d2MB|`m~b?MWz3Bj_-~ZQ0K07dLYy& z^yz)I&zgn7%X~g&Nq#Kd3A(>K_wVL~w)0QVICCNg){Cs?+LNiYGo;k!(+TB$ek{4! ze>wz}b39n|a}TE%t>OM%taTxaWsy)uW)kn&xz^inY{{IQdwPQC+scne#dBl0lkYD3 ze`<%0XsAoEAjFLvM?wyKe*SBfv~2B{i|%16MUELquC0xB-COlFY3`rcsQ;dlNBNJN zOj;?^c!QJ2WTWT$`2BSP(+vE775xAET{>R4TU=jHuHpfsVcHpqi@VG71DALRKF;+} zes^X0%!(qnH`iFRApL3utwz2$^=ZA*=HFBlxsw+vyZ3F;Wej;cQ@KAW&{bYsQ9!0q ze@~ou=udw8KLrxg?c8g_{$H!GWh;GsP4w}xUg6u@a=o|t&ae5@nQ?JZ>+`pLGrdz7 z7$kRlx;Tb(Y?xo$WPJ7oC&X6=#ZSmTwEq&QD%Z@;Up6J7Fz6GL{htrb1`})C1i4k} z4#q3LSZLh1=hK$jz%vUwu7mdZYzk3R-jIG?E^t@L%MRPQJu|D;%&rP*yL^57{W|Ta z?RjrKqvvcfpILn6Z(0Q;#WXbdvn+G{$zSJk^0;_>%|nyz5BI1rB_Hn-wJdtlapKm2 z3cX3CAzwUeF8i?faNbEwc-Pq@Y20;lbNXgKHRTOCH;vY2ryg$OJvvF%d(pOepz*4o z&t`AkcG9)y?DXra;#J_|ucukFcK%?$U-&3+LxSVH>URofe}6nK-}-CDlMRW7U6y)H zmH9nO;&6BAm(4cwGUb>yib!N7={-9;d%Akkk`43x=Gol*x+`*DO{HPxB^7qc0!m!O+lGK14^`f!|=vaj2-uSoLXgeUFnO%Vg6Z z9*N{=iF%OC|NPT_7+Gox3r>CY0zX~?rqbF`r`DsbTqfT{~X*!WIe|MMN&fVS#T0iGi z`R`BV#|O>)R$2XxKVH7knPUm7x06%@Ji`9$ZCv88qFktgb7R3nr-|C(deM`%KDo8g z?U?i72v(J^N)M75P4j!swASW$2DHz+P#{C>q5Zo+)djD9ZhY0ZJFyOQ zM#PHrBeOsBZR#^z*im8C*-*~Z?_&8~DNa0Z@7HSv`pfsd*qyY5^7%5at^Z1|+aklb znl;aC<21Ev7dNM$_n4-9ZmUPag$0fqe{6UB8+{%YTQv#=?JJjT%DA`)RC$Xn^}J{L z^u@)+8$AvLtuAhoc^+fe;XbRQVLq#z@z!~(s(yWY`}(eu+sS!cD`u~Fc7Fc-FZ+cn z|Jdxzu!aO)qL9I-nlDF=lpgDmoTp}ICi3s;^!QnRdxBQIUr@4N-RGcBykN)111^(i ze@Q&tc5}m%i)|V#W$*52t_oY5_33`sB*S^q@KIbr4v9*;U0yN8&(3IW%fBz@YV~+N z=rHOeqnBPQ*PXnyJA=jWz)B8<2XP9Mb&{r@^!=5+e($sSM<-7E=lbBs$H$9uZ*N=n zZ|{y5s6tOf?A|H3cwvx?_MoNr>~X4<)oZDVj2cxiv| z|1h7#BuMkBp`o6&$41`PaN!(-L??k_{lGmHg~6TI!!K>xQ-8R3nzBGfW1^b*%bCXM zVxXIJpUje4;mx;2X1`6 z7&<9vRfy)t-|zRctN#DBS$?Kbs?pSzk9&)kPdr=6am4L`ZL_pd;I^E|kB|H9+46k9 zR=1nw-_zj|)k=AFzx7B}+Yz-VD@CDg<`Qm+TDz*t%Y6UNtB$?)4|LXXh>}^{_Xojp zOdJ{F0sVF+Th%(erfPK_Zs%vui~XA2ZkBf^D%7bg6`%5!!Z_8bj zbhK;PKV6R~|KjD1Co7?bJ>YM2+BEakN1bCr-SvN8$Jd?S8B-ApA`7(nR*60gw^S{eybX~cj!LTuF(=unZ`=0Ob@2@vGEq2{Squ|L2!G-^L zjV-r{zkZdiQ?-%fv~F^|vbKAAYU*dLLTk;t>pCizTwq`kD9{RUpI33~ ziCf-_3kwDF%q?w&8im#Uj${?v9mu>;D96OHLtNozQN9N!sKj{CqLVb)#%hQDsYuT3 zYil}Bg9g6$2yfiXT~icxZ%^f8yMI5D^`mCTiS6>1%ig0g$4Jn@VfTUlO-Fb?Wh~zN zM1(75OGaSKG@ZytdAnY!1&6jRliO+8pM7bG=bcHa-ag-V&R83CH`Ymk-GmpnUm5I`z)>>e!sXr!F|RBE*60fhX-<#vsbNpeb)T`m!nZH zr@PIwF84cecIU==@ySO{PvCge0~@YTSitl&W&g7oUK*Rz&+CP)k9#}a=4_z#Ref2T zPr>H%9wq*8Q)AsX#f{`V|j|Fw6X{}q3>1+-fdv=DKR zNI-v);iM@mo}ZX!Q)%>8=cIdj#g89zyW;q)Qk5GT(wSZ@KIL}p%8@F&|9^_**Ul<4 z+nRZKncML&;c-@iiB<&6B@# ze#n1vsfcBbXvMiJvsS%2In#J~#Eyc*DXS%>Z_U1bZguIL@^fqFE;4~GB00^vDt!IF zi7Q)*E-Y|tJjqf1=ElR&B=Z}eCM>MvP?)gm!0BbzLPGuL*;F1Wzh5gpW9!ur&<$FT zuS(5}+PU7S5>oj(Ff^L5o|>k+`%Z|HW!@c&;Gff z1{<|8>FAMdxwmcNKQ{$A-rknGH)8i?tJ?&TW_Liwu{Pg6L z*3b3Sgr-BvVS%tlu8$u-*6;9fl2NsD?H1#8QPQ06`DVp_!CC)=t}!gR&%qLq5Z3bf z{?%DQ%l%{ve|^c+|Gs^n-fs7Pxpg&*Wln!&?8)8*+ZfQs@~*>(vD4z^&Y#a_*Uo*h z@>um3+b^5jj?Kyva5zxicxF>q<+5v`q33hA-+lIb>(y?)lK1y)AJs26>A5ZP-nmB# z8e|GDnEslosP+jh{QZ9a{cf8x88an~QVOnI=kW1ou|4oYo=H*og#Pc{dQGMWzRtR| zDpY&%>jiJ8etmWI^wvy~$KUHtJeu-YcD0v+jlH0sTk zGfyu~|J`<^L@N-w$K#>Mk24`gFWXg${{H&vH+j3q`NunVKAaQ(#cB>yt?$~^onL+C z+udEgchkqB^s}>6y{2l3zLZ-1`H$))Q+EsJ>2c7&cUZ%^ZVK;@VJ{hMX z`t9{~|MW@Ix2&<-D3|fdoq=&NQ~&I!@KD>AmzD~H7C5Ht-2Caz^ZE7nR-4|)+^M~E zdDSsneMtL5z(FC6>1yg(bsv?9Rouw;|JFkn_c<9tu)3t7I@9&Q{$-855sWkNa&(}BS9M4)6pbss|Vze$C z3Q>w&5um6&`NZ=1by4M;rf=D^rbUK{qb2A;ZgBSMRm)ROPD;AG%s2CG``TYWw`5*+ zxwofsZ%qB%DSI7%iSnejT*`#Hb3<6df|V{t$;Wyg{r!G_yPBs>{l7gLK}$L&tLV)t zzLH#3q1fP1!Ftbl>$X)@r>1JF^U2v{oc%Q`%2}@V%f*aqA$PB@nVh%uu=KnyuvI)c zVn4Q@bh$L``479_Z#M4|-nZoG-R#c|m(5rN43rks1wMaj^?CZH)#2;)_~h+!-m29; zKGv(GsCaOOyVf`R6Z5AU3o(YkDtitW%?&qFlq^$DOqiiIv7Jv=sPfa3k6M8?+PcMV zmV7a7pxyc&>bn=c<9l~CsyK4zE9<+@&&}yj4&n^iu^|Nr5x!Wp~dxgSr~gbVsC0v!QC#Z79pJ#EIVP@OrT?;gYsn0C97Uvi_SOwx7V}ucyj;mn_4VRcSA`m1du~$m{q+3n+l*~8M4{2E zFkzE}Imo!xMNdy9ot*Kc~94vRP5(Ki7;IrvBGL)S@_psP#ewi{P}%Q-*U^XuL6{@>qL#Iw&WQ*LN@ z&NMZZ_qa`5^S@2Ucx5aud@eQ3WKBOeM^M(f>`T?$-X(v^ZRJC?Ks7Nq=y*8J7|nE1 zyY}^7_4~?cK6$(@|5#ZNBTwR&Tf--hF!A1^H6vHR=5 z!068!RlP?ncH6bTujBuJDw+K6QMZ28-hFOC|AJmdpS&!%qyUw4-vEW+Drr6zO6IIGD&RM-LdX_3%vddHsg$MqP)jsRj1~2ouxNF_2Lwqt83Riev z`g~WN`pfN?u}p?3ED|30EO1^Uq(Ak`T${>ErA|M8Jno0s!{TRWR$RYwgq!zHf$^l$%0?5N zrS%yag3v-(U_BN0ktXXoU?hVL+mv=zYnk8NR~8HZd^)Y~ zy3A+h9F_9C^O54GJQiH$P*@P{P+NZMZPk+>ziNJd>g<&^w~7nC+WE@*4J(&OK}`Gc zzds|V-H-UL5FiH+LG#9NTfbdFzW(;k&iCXPRKHj%EQ*YI$mVLFqXGI0iz4E!UL@VK~#w7z-{2tigaAx1+b(5|iY-V3R z!$0rlrlU`MyF-l5f`$t&Xnxpv(zmLn=Fh3p*Vjs?b+7vM_IXj|pIIf1cQ+(9?|8fI z_MDtqzH=|ftDB|5qsCFN;zEj0WoGR6JH_WyXMdSr_sesNR_LjaNfja6Rwe|nO|DaD zXb5F8=3T$Od-At9y><1I-7ki%jk2vjDjI&|N#N|0U+VY%sox%L>Se+Pj~|}}ojLut zR?NC3@_*?(HeRWYW_JF#8!J|)e+*k6cQ?g)SEQMk2|FW8lkx=TveedxTfcUD|2QVO z&VK9H=(|fyq6^xl&x6hhFfiTYoHE@tzc*A#{k_|sk1LnYtJ+lX@X&3ZZH~1pQ$fo$ z9xQdJi~Nz+{Cd_ch5qU8p_OY4WAd|Re|F#NvMdJ{cnTd%uNL3ioHXOYT*HX(d6Czz zI?A~GYGGiy#2)rl@r_EeyMa? zDW|-AAM+_t`q<#OVEXy%SC+iL@?Y)urGsoCx4>Ql5iPC@dfu$??SIqxC3#NoA)|mV z!i+36$_wOd#a>3G-TwJGRlY*0E#IlH4O(b9OklZm`rMf>iB6UA6WAK}DS%E?o%ikG ztXV(2nXZ;0E#);7tGMdU`E-Lsbf7I0hr)zu4fC&sY_+_v+pm^c+BF~A@?c=%m?8Y( z@NT<3yOZ_gR&X-1+~M5wcyfGAox<(N3$fulrC=$`;Q)8zJTdhtuVghrwlvIVQH$QQ zY*qO=_FtTnw?Uo9z?3KwAYc6F@TMi7_8Rc9)VeV=I&hrXm}46%{aN?Z4qbs=B}_0A zIT{^AZysMeO=W7Z^8;UTK?j8!Os91t{jWZ&>9V=P>jaxeVqoI<;jy42=k*;4^{M|q zP89bAO+y3;olvjeV07&D%3E_*uQvo2|KMsu;KRlPTO?Gc8rS5wT^4j;X!K_FI{km6 zvfJyIS&{jrZSYmE4hj-X>m~fOex9o|c+?iB07^USrq|nMRM>{TF1KL@jfp`bRzRom zUfU$EeZ_KXb}TgKQ1}quX!U9Rah^5H+f!xl9)OHBfNErpbq?+~w-(E(OgmUx1nt$H&zHy| z;GmGgWSUxkw@&Nj{}jnr7iYj`Cm9%7ob)yXURL|NZ-VuuS{4D0?FZIqT)))#Fm3U7 zSVNhCX*$=6^872kor`RbIe~{*1(xr7_V|lo&i#|cSI<6!O+J7M^MaWU_chF4tWN|V zqV!?8gW1pc{?m_Nr(C;o`P2WEvok;aFkyn1Q4R{ejVzVNw)2_4`u(($e@Ud0Iw+VQ zik{Hf9Tz8O`Xtb74-dRSC*W|P*P*)dV@ajVzLd@D<}F+|@BD3dx%%Q@#_I^*-_Se| zTmM!@9K7~iqjAxv6N>%9pMJ#2Jx@g169|eTcyj`pSOOmWXFM1@DOe!agP(zcfiE?} eGtJkRL5qQbfr9}8E(K2pF+5%UT-G@yGywo2ocp@~ diff --git a/slutpet.6 b/slutpet.6 deleted file mode 100644 index a9a1447..0000000 --- a/slutpet.6 +++ /dev/null @@ -1,23 +0,0 @@ -.Dd June 28, 2025 -.Dt SLUTPET 6 -.Os -. -.Sh NAME -.Nm slutpet -.Nd a desktop pet for perverts -. -.Sh SYNOPSIS -.Nm -. -.Sh DESCRIPTION -.Nm -.Em will -be a desktop pet thing, -but currently it doesn't actually exist. -Try again later. -. -.Sh INTERNALS -Currently this section is just notes on how I'm going to -try to implement everything. Later this will just be -describing the program's layout, to hopefully make -it easier to figure out how to modify it. diff --git a/slutpet.c b/slutpet.c deleted file mode 100644 index e69de29..0000000 diff --git a/sp.c b/sp.c new file mode 100644 index 0000000..745326b --- /dev/null +++ b/sp.c @@ -0,0 +1,4 @@ +#define SDL_MAIN_USE_CALLBACKS +#include +#include +#include "s7.h"