From b4b372c5b4e6e61edd1f81723f2a55e06deb1cfe Mon Sep 17 00:00:00 2001 From: Da Shen Date: Mon, 28 Sep 2026 23:54:34 +0800 Subject: [PATCH] =?UTF-8?q?[6010]=20=E6=81=A2=E5=A4=8D=20s7.c=20=E5=8E=9F?= =?UTF-8?q?=E5=A7=8B=E6=A0=BC=E5=BC=8F=E5=B9=B6=E5=9C=A8=20gf=5Ffmt.json?= =?UTF-8?q?=20=E4=B8=AD=E6=8E=92=E9=99=A4?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- TeXmacs/plugins/goldfish/src/s7.c | 169261 ++++++++++++--------------- gf_fmt.json | 6 +- 2 files changed, 74928 insertions(+), 94339 deletions(-) diff --git a/TeXmacs/plugins/goldfish/src/s7.c b/TeXmacs/plugins/goldfish/src/s7.c index 7d96db5f8b..72aebb3633 100644 --- a/TeXmacs/plugins/goldfish/src/s7.c +++ b/TeXmacs/plugins/goldfish/src/s7.c @@ -6,9 +6,8 @@ * 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 + * 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. @@ -56,34 +55,29 @@ * 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 numbers (usually), o is - * opt_info*. + * 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 numbers (usually), o is opt_info*. * * ---------------- compile time switches ---------------- */ #if defined __has_include -#if __has_include("mus-config.h") -#include "mus-config.h" -#endif +# if __has_include ("mus-config.h") +# include "mus-config.h" +# endif #else -#include "mus-config.h" +# 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). + * 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++, + * 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 @@ -95,446 +89,409 @@ * * 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 + * 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). + * 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. * - * and we use these predefined macros: __cplusplus, _MSC_VER, __GNUC__, - * __clang__, __ANDROID__ + * 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 + * 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 + * 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 +#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 + #define WITH_GCC 0 #endif -#if (defined(__clang__) && \ - __cplusplus) /* pointless -- this is a moving target */ -#define WITH_CLANG_PP 1 +#if (defined(__clang__) && __cplusplus) /* pointless -- this is a moving target */ + #define WITH_CLANG_PP 1 #else -#define WITH_CLANG_PP 0 + #define WITH_CLANG_PP 0 #endif + /* ---------------- initial sizes ---------------- */ #ifndef INITIAL_HEAP_SIZE -#ifdef __EMSCRIPTEN__ -#define INITIAL_HEAP_SIZE 64000 /* wasm 内存受限，保持小堆 */ -#else -#define INITIAL_HEAP_SIZE \ - 256000 /* [0137] 更大的初始堆减少 GC 频率，read 密集负载约快 12% */ + #ifdef __EMSCRIPTEN__ + #define INITIAL_HEAP_SIZE 64000 /* wasm 内存受限，保持小堆 */ + #else + #define INITIAL_HEAP_SIZE 256000 /* [0137] 更大的初始堆减少 GC 频率，read 密集负载约快 12% */ + #endif #endif -#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. +/* 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 + #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) +/* 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 */ + #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 */ +/* 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 */ +#define STACK_RESIZE_TRIGGER 256 /* was INITIAL_STACK_SIZE/2 which seems excessive */ #ifndef GC_TEMPS_SIZE -#define GC_TEMPS_SIZE 256 + #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. +/* 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 + #define INITIAL_PROTECTED_OBJECTS_SIZE 16 #endif -/* a vector of objects that are (semi-permanently) protected from the GC, grows - * as needed */ +/* a vector of objects that are (semi-permanently) protected from the GC, grows as needed */ + /* ---------------- scheme choices ---------------- */ + #ifndef WITH_PURE_S7 -#define WITH_PURE_S7 0 + #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. - */ + #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_R7RS -#define WITH_R7RS !WITH_PURE_S7 -/* this also requires (set! (*s7* 'scheme-version) 'r7rs) */ + #define WITH_R7RS !WITH_PURE_S7 + /* this also requires (set! (*s7* 'scheme-version) 'r7rs) */ #endif #ifndef WITH_EXTRA_EXPONENT_MARKERS -#define WITH_EXTRA_EXPONENT_MARKERS 0 + #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") */ +/* 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 */ + #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" */ + #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 + #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) */ + #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 */ + #define DEFAULT_HISTORY_SIZE 8 + /* this is the default length of the eval history buffer */ #endif #if WITH_HISTORY -#define MAX_HISTORY_SIZE 1048576 + #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 */ + #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 + #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 + #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 -#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 + #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 */ + #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) */ + #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 + #define S7_DEBUGGING 0 #endif #undef DEBUGGING -#define DEBUGGING typo ! -#define HAVE_GMP typo ! +#define DEBUGGING typo! +#define HAVE_GMP typo! #define SHOW_EVAL_OPS 0 #ifndef _GNU_SOURCE -#define _GNU_SOURCE /* for qsort_r, grumble... */ + #define _GNU_SOURCE /* for qsort_r, grumble... */ #endif #ifndef _MSC_VER -#include -#include -#include -#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 */ + /* 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 + #define Inline inline __attribute__((__always_inline__)) #else -#define Inline inline -#endif + #ifdef _MSC_VER + #define Inline __forceinline + #else + #define Inline inline + #endif #endif #ifndef WITH_VECTORIZE -#define WITH_VECTORIZE 1 + #define WITH_VECTORIZE 1 #endif -#if (WITH_VECTORIZE) && \ - (defined(__GNUC__) && (__GNUC__ >= 5)) /* is this included -in -O2 now? */ -#define Vectorized __attribute__ ((optimize ("tree-vectorize"))) +#if (WITH_VECTORIZE) && (defined(__GNUC__) && (__GNUC__ >= 5)) /* is this included -in -O2 now? */ + #define Vectorized __attribute__((optimize("tree-vectorize"))) #else -#define Vectorized + #define Vectorized #endif #if WITH_GCC -#define Sentinel __attribute__ ((sentinel)) + #define Sentinel __attribute__((sentinel)) #else -#define Sentinel + #define Sentinel #endif #ifdef _MSC_VER -#define no_return _Noreturn /* deprecated in C23 */ + #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) */ + #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 */ + #define S7_ALIGNED 0 + /* memclr, local_memset, local_strncmp */ #endif -#include -#include -#include -#include -#include -#include -#include -#include #include -#include +#include +#include #include +#include #include #include +#include +#include +#include +#include +#include +#include #ifdef _MSC_VER -#define MS_WINDOWS 1 + #define MS_WINDOWS 1 #else -#define MS_WINDOWS 0 + #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) + #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 slower than setjmp. In one case, - * the sigsetjmp version runs in 24 seconds, but the setjmp version takes 10 - * seconds, yet callgrind says there is almost no difference? - */ + #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 slower than setjmp. In one case, the sigsetjmp version runs + * in 24 seconds, but the setjmp version takes 10 seconds, yet callgrind says there is almost no difference? + */ #endif #if !MS_WINDOWS -#include + #include #endif #if __cplusplus -#include + #include #else -#include + #include #endif #include "s7.h" -#include "s7_ctables.h" -#include "s7_dtoa.h" #include "s7_internal_helpers.h" +#include "s7_scheme_format.h" +#include "s7_scheme_base.h" +#include "s7_scheme_inexact.h" +#include "s7_scheme_complex.h" +#include "s7_scheme_char.h" +#include "s7_scheme_write.h" +#include "s7_scheme_read.h" +#include "s7_scheme_symbol.h" +#include "s7_scheme_predicate.h" #include "s7_liii_bitwise.h" +#include "s7_liii_string.h" #include "s7_liii_hash_table.h" #include "s7_liii_list.h" -#include "s7_liii_string.h" -#include "s7_liii_tree.h" #include "s7_liii_vector.h" -#include "s7_module.h" -#include "s7_op_names.h" -#include "s7_scheme_base.h" -#include "s7_scheme_char.h" -#include "s7_scheme_complex.h" +#include "s7_liii_tree.h" #include "s7_scheme_cxr.h" -#include "s7_scheme_format.h" -#include "s7_scheme_inexact.h" +#include "s7_module.h" +#include "s7_dtoa.h" #include "s7_scheme_let.h" -#include "s7_scheme_predicate.h" -#include "s7_scheme_read.h" -#include "s7_scheme_symbol.h" -#include "s7_scheme_write.h" +#include "s7_op_names.h" +#include "s7_ctables.h" /* there is also apparently __STDC_NO_COMPLEX__ */ #if WITH_CLANG_PP -#define CMPLX(x, y) __builtin_complex ((double) (x), (double) (y)) + #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 + #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) + #define s7_complex_i ((double)1.0i) #else #if (defined(__GNUC__)) -#define s7_complex_i 1.0i + #define s7_complex_i 1.0i #else -#define s7_complex_i (s7_complex) _Complex_I /* a float, but we want a double \ - */ + #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 + #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 + #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 */ +#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__ +#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 +#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 + #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 */ + typedef double long_double; /* (- .1 1) -> 0.9! and others similarly: (- double long_double) is broken */ #else -typedef long double long_double; + typedef long double long_double; #endif typedef uint64_t s7_uint; @@ -542,137 +499,70 @@ typedef uint64_t s7_uint; /* #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? */ +#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, +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; + void *data; s7_pointer d_ptr; - s7_int* i_ptr; - s7_int tag; + s7_int *i_ptr; + s7_int tag; } dx; int32_t index; union { - bool needs_free; + bool needs_free; uint32_t iter_or_size; } ln; union { - s7_int size; + 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 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; + void *ex_info; + s7_int ckey; } ex; } block_t; @@ -680,4247 +570,3241 @@ typedef struct block_t { #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) */ +#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 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; +#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 */ + 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; + 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); + 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 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_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 */ + 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; + s7_pointer *arg_defaults; + s7_pointer bool_setter; } dam; union { - s7_pointer* arg_names; - s7_pointer c_sym; + s7_pointer *arg_names; + s7_pointer c_sym; } sam; union { s7_pointer call_args; - void (*marker) (s7_pointer p, s7_int len); + 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_int type, outer_type; s7_pointer scheme_name, getter, setter; - void (*mark) (void* val); - void (*free) (void* value); - bool (*eql) (void* val1, void* val2); + void (*mark)(void *val); + void (*free)(void *value); + bool (*eql)(void *val1, void *val2); #if !DISABLE_DEPRECATED - char* (*print) (s7_scheme* sc, void* value); + 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); + 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 */ + +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 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* gen; - opt_info* o1; + s7_int i; + s7_double x; + s7_pointer p; + void *gen; + 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); + 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; + vunion v[num_vunions]; + s7_scheme *sc; }; #define q_temp(o) o->v[num_vunions - 1] + typedef intptr_t opcode_t; typedef struct unlet_entry_t { - s7_pointer symbol; - struct unlet_entry_t* next; + s7_pointer symbol; + struct unlet_entry_t *next; } unlet_entry_t; -/* -------------------------------- cell structure - * -------------------------------- */ + +/* -------------------------------- cell structure -------------------------------- */ typedef struct s7_cell { union { - s7_uint u64_type; /* type info */ - s7_int s64_type; + 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 */ + 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 */ + s7_int integer_value; /* integers */ + s7_double real_value; /* floats */ - struct { /* ratios */ - s7_int numerator; - s7_int denominator; + struct { /* ratios */ + s7_int numerator; + s7_int denominator; } fraction_value; union { #if !WITH_CLANG_PP - s7_complex z; + s7_complex z; #endif - struct { /* complex numbers */ - s7_double rl; - s7_double im; - } complex_value; + struct { /* complex numbers */ + s7_double rl; + s7_double im; + } complex_value; } cz; + } number; - struct { /* ports */ - port_t* port; - uint8_t* data; - s7_int size, point; - block_t* block; + struct { /* ports */ + port_t *port; + uint8_t *data; + s7_int size, point; + block_t *block; } prt; - struct { /* characters */ + struct{ /* characters */ uint32_t c, up_c; - int32_t length; - bool alpha_c, digit_c, space_c, upper_c, lower_c; - char c_name[12]; + 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; + struct { /* c-pointers */ + void *c_pointer; s7_pointer c_type, info, weak1, weak2; } cptr; - struct { /* vectors */ + struct { /* vectors */ s7_int length; union { - s7_pointer* objects; - s7_int* ints; - s7_double* floats; - s7_complex* complexes; - uint8_t* bytes; + 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); + block_t *block; + s7_pointer (*vget)(s7_scheme *sc, s7_pointer vec, s7_int loc); union { - s7_pointer (*vset) (s7_scheme* sc, s7_pointer vec, s7_int loc, - s7_pointer val); - s7_pointer fset; + s7_pointer (*vset)(s7_scheme *sc, s7_pointer vec, s7_int loc, s7_pointer val); + s7_pointer fset; } setv; } vector; - struct { /* stacks (internal) struct must match vector above for - length/objects */ - s7_int length; - s7_pointer* objects; - block_t* block; - s7_int top, flags; + 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 */ + 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_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; + hash_map_t *loc; + block_t *block; } hasher; - struct { /* iterators */ + struct { /* iterators */ s7_pointer seq, cur; union { - s7_int loc; - s7_pointer slot; /* let iterator current slow */ + 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 */ + 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); + s7_pointer (*next)(s7_scheme *sc, s7_pointer iterator); } iter; struct { - c_proc_t* c_proc; /* C functions, macros */ + c_proc_t *c_proc; /* C functions, macros */ s7_function ff; - s7_int required_args, optional_args, - all_args; /* these could be uint32_t */ + s7_int required_args, optional_args, all_args; /* these could be uint32_t */ } fnc; - struct { /* pairs */ + struct { /* pairs */ s7_pointer car, cdr, opt1; - union { - s7_pointer opt2; - s7_int n; + union + { + s7_pointer opt2; + s7_int n; } o2; union { - s7_pointer opt3; - s7_int n; - uint8_t opt_type; + s7_pointer opt3; + s7_int n; + uint8_t opt_type; } o3; } cons; - 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 */ + 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, let, - setter; /* args can be a symbol, as well as a list, setter can be #f - as well as a procedure/closure */ + struct { /* scheme functions */ + s7_pointer args, body, let, 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; + struct { /* strings */ + s7_int length; + char *svalue; + s7_uint hash; /* string hash-index */ + block_t *block; + block_t *gensym_block; } string; - struct { /* symbols */ + 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 */ + 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; + 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 */ + 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) */ + struct { /* lets (environments) */ s7_pointer slots, nxt; - s7_int id; /* id of rootlet is -1 */ + 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 */ + 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; } let; - 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; + 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 */ + struct { /* #<...> */ + char *name; /* not const because the GC frees it */ s7_int len; /* 3 unused */ } undef; - struct { /* # */ - const char* name; - s7_int len; + struct { /* # */ + const char *name; + s7_int len; /* 3 unused */ } eof; - struct { /* counter (internal) */ - s7_pointer result, list, let, - slots; /* let = counter_let (curlet after map/for-each let created) */ - s7_uint cap; /* sc->capture_let_counter for let reuse */ + struct { /* counter (internal) */ + s7_pointer result, list, let, slots; /* let = counter_let (curlet after map/for-each let created) */ + s7_uint cap; /* sc->capture_let_counter for let reuse */ } ctr; - struct { /* random-state */ + struct { /* random-state */ s7_uint seed, carry; /* for 64-bit floats we probably need 4 state fields */ } rng; - struct { /* additional object types (C) */ - s7_int type; - void* value; /* the value the caller associates with the c_object */ - s7_pointer let; /* the method list, if any (openlet) */ - s7_scheme* sc; + struct { /* additional object types (C) */ + s7_int type; + void *value; /* the value the caller associates with the c_object */ + s7_pointer let; /* the method list, if any (openlet) */ + s7_scheme *sc; /* 1 unused */ } c_obj; - struct { /* continuations */ - block_t* block; - s7_pointer stack, op_stack; + 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; + 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; + struct { /* catch */ + s7_uint goto_loc, op_stack_loc; s7_pointer tag; s7_pointer handler; - Jmp_Buf* cstack; + Jmp_Buf *cstack; } rcatch; /* C++ reserves "catch" I guess */ - struct { /* dynamic-wind */ + struct { /* dynamic-wind */ s7_pointer in, out, body; - dwind_t state; + 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; + s7_int alloc_type, debugger_bits; const char *alloc_func, *gc_func, *root; - s7_pointer holder; + s7_pointer holder; #endif } s7_cell; + typedef struct s7_big_cell { s7_cell cell; - s7_int big_hloc; + s7_int big_hloc; } s7_big_cell; -typedef struct s7_big_cell* s7_big_pointer; +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; + intptr_t start, end; + s7_int offset; + struct heap_block_t *next; } heap_block_t; typedef struct shared_info { - 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; + 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 gc_obj_t { - s7_pointer p; - struct gc_obj_t* nxt; + s7_pointer p; + struct gc_obj_t *nxt; } gc_obj_t; typedef struct { - s7_pointer* list; - s7_int size, loc; + s7_pointer *list; + s7_int size, loc; } gc_list_t; typedef struct { - s7_int size, top, excl_size, excl_top; + s7_int size, top, excl_size, excl_top; s7_pointer *funcs, *let_names, *files; - s7_int * timing_data, *excl, *lines; + 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 - * -------------------------------- */ +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 code; /* layout of first 4 entries should match stack frame layout */ s7_pointer curlet; s7_pointer args; - opcode_t cur_op; + opcode_t cur_op; s7_pointer value, cur_code; - 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 stack; /* stack is a vector */ - uint32_t stack_size; + 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 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; + 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_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; + 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; + 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; + 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 */ + 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 symbol_table; - s7_pointer rootlet, rootlet_slots, shadow_rootlet; - unlet_entry_t* unlet_entries; /* original bindings of predefined functions */ + 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) */ + 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 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 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* */ - s7_pointer exit_hook; /* *exit-hook* hook object */ - token_t tok; - 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; + s7_pointer error_hook, read_error_hook; /* *error-hook* hook object, and *read-error-hook* */ + s7_pointer exit_hook; /* *exit-hook* hook object */ + token_t tok; + 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 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; + 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, scheme_version; - - 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_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, scheme_version; + + 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; + bool rec_bool; - int32_t float_format_precision; - vdims_t* wrap_only; + 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 */ + 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_FILE_NAMES_SIZE 8 + s7_pointer *file_names; + int32_t file_names_size, file_names_top; -#define INITIAL_STRBUF_SIZE 1024 + #define INITIAL_STRBUF_SIZE 1024 s7_int strbuf_size; - char* strbuf; + char *strbuf; - char* read_line_buf; + 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 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 must not overlap */ + s7_pointer qlist_2, qlist_3, clist_1, clist_2, dlist_1, mlist_1, mlist_2; /* dlist|clist and ulist must not overlap */ - Jmp_Buf* goto_start; - bool longjmp_ok; + Jmp_Buf *goto_start; + bool longjmp_ok; setjmp_loc_t setjmp_loc; - void (*begin_hook) (s7_scheme* sc, bool* val); + 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; - - 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; + 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; + + 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, - alloc_big_pointer_k; - s7_cell* alloc_pointer_cells; - c_proc_t* alloc_function_cells; - 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 alloc_pointer_k, alloc_function_k, alloc_symbol_k, alloc_big_pointer_k; + s7_cell *alloc_pointer_cells; + c_proc_t *alloc_function_cells; + 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; + 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 - s7_int baffle_ctr, map_call_ctr; + 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; + 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, 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_eq_symbol, char_geq_symbol, char_gt_symbol, char_leq_symbol, - char_lt_symbol, char_position_symbol, char_to_integer_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_size_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_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_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_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, 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_member_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; + 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, 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_eq_symbol, char_geq_symbol, char_gt_symbol, char_leq_symbol, char_lt_symbol, + char_position_symbol, char_to_integer_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_size_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_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_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_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, + 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_member_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 integer_length_symbol, is_char_ready_symbol, let_to_list_symbol, - list_to_string_symbol, list_to_vector_symbol, make_polar_symbol, - string_length_symbol, string_to_list_symbol, vector_length_symbol, - vector_to_list_symbol; + s7_pointer integer_length_symbol, + is_char_ready_symbol, let_to_list_symbol, list_to_string_symbol, list_to_vector_symbol, make_polar_symbol, string_length_symbol, + string_to_list_symbol, vector_length_symbol, vector_to_list_symbol; #endif #if WITH_R7RS s7_pointer clock_gettime_symbol, uname_symbol; #endif - bool r7rs_inited; - s7_pointer s7_symbol, r5rs_symbol, r7rs_symbol, global_is_eq, initial_is_eq, - global_memq, initial_memq, global_assq, initial_assq; + bool r7rs_inited; + s7_pointer s7_symbol, r5rs_symbol, r7rs_symbol, global_is_eq, initial_is_eq, global_memq, initial_memq, global_assq, initial_assq; /* 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, type_error_symbol, value_error_symbol; + 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, type_error_symbol, value_error_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; + 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; + 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, 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 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, 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; + 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; + 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; + 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; s7_pointer unicode_chars_table; -#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 */ + #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; - int32_t** current_distance; + int32_t current_safe_list; + int32_t **current_distance; #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; + 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; + 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; + 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]; /* this form is a lot faster than opt_info**! */ + #define OPTS_SIZE 256 /* pqw-vox needs 178 */ + opt_info *opts[OPTS_SIZE]; /* this form is a lot faster than opt_info**! */ -#define INITIAL_SAVED_POINTERS_SIZE 256 - void** saved_pointers; + #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; -}; /* store all s7_scheme bools in one int? ca 60 bytes saved out of 11440? */ + s7_int overall_start_time; +}; /* store all s7_scheme bools in one int? ca 60 bytes saved out of 11440? */ -no_return void error_nr (s7_scheme* sc, s7_pointer type, s7_pointer info); -s7_pointer wrap_string (s7_scheme* sc, const char* str, s7_int len); -s7_pointer splice_in_values (s7_scheme* sc, s7_pointer args); -void let_temp_done (s7_scheme* sc, s7_pointer args, s7_pointer let); +no_return void error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info); +s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len); +s7_pointer splice_in_values(s7_scheme *sc, s7_pointer args); +void let_temp_done(s7_scheme *sc, s7_pointer args, s7_pointer let); #if S7_DEBUGGING -static void gdb_break (void) {}; + static void gdb_break(void) {}; #endif #ifndef DISABLE_FILE_OUTPUT -#define DISABLE_FILE_OUTPUT 0 + #define DISABLE_FILE_OUTPUT 0 #endif #if S7_DEBUGGING || DISABLE_FILE_OUTPUT || POINTER_32 -static s7_scheme* cur_sc= NULL; + static s7_scheme *cur_sc = NULL; #endif #if S7_DEBUGGING || ((DISABLE_FILE_OUTPUT || POINTER_32) && (!WITH_GCC)) -static s7_scheme* original_cur_sc= NULL; + static s7_scheme *original_cur_sc = NULL; #endif -s7_pointer set_elist_1 (s7_scheme* sc, s7_pointer x1); +s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1); -static inline FILE* -xfopen (const char* path, const char* mode) { - setlocale (LC_ALL, ".UTF8"); - return fopen (path, mode); +static inline FILE *xfopen(const char *path, const char *mode) +{ + setlocale(LC_ALL, ".UTF8"); + return fopen(path, mode); } -#define fopen(path, mode) xfopen (path, mode) +#define fopen(path, mode) xfopen(path, mode) #if DISABLE_FILE_OUTPUT -static FILE* -old_fopen (const char* pathname, const char* mode) { - return (fopen (pathname, mode)); -} +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) */ +/* I assume that MS C can't handle the ({...}) business (WITH_GCC include clang and tinyc) */ #define fwrite local_fwrite -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); -} -FILE* -local_fopen (const char* pathname, const char* mode) { +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); +} +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)); + 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); \ - }) +#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! */ -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); +/* passing in sc here gloms up the 64-bit code intolerably -- 32-bit users will just have to live with cur_sc! */ +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); } -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); +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); } -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); +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) +#define Malloc(Size) malloc(Size) +#define Calloc(N, Size) calloc(N, Size) +#define Realloc(Ptr, Size) realloc(Ptr, Size) #endif -/* -------------------------------- mallocate -------------------------------- - */ -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; -} - -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}; - -void -memclr (void* s, size_t n) { - uint8_t* s2; + +/* -------------------------------- mallocate -------------------------------- */ +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; +} + +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}; + +void memclr(void *s, size_t n) +{ + uint8_t *s2; #if S7_ALIGNED - s2= (uint8_t*) s; + 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; + 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; + s2 = (uint8_t *)s; #endif #endif - while (n > 0) { - *s2++= 0; - n--; - } + 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 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 -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); +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 -void -init_block_lists (s7_scheme* sc) { - for (int32_t i= 0; i < NUM_BLOCK_LISTS; i++) - sc->block_lists[i]= NULL; +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; + sc->blocks_allocated = 0; + for (int32_t i = 0; i < NUM_BLOCK_LISTS; i++) + sc->blocks_borrowed[i] = 0; #endif } -extern inline void -liberate (s7_scheme* sc, block_t* blk) { +extern inline void liberate(s7_scheme *sc, block_t *blk) +{ #if S7_DEBUGGING - sc->blocks_freed[block_index (blk)]++; + sc->blocks_freed[block_index(blk)]++; #endif - if (block_index (blk) != TOP_BLOCK_LIST) { - block_next (blk)= (struct block_t*) sc->block_lists[block_index (blk)]; - sc->block_lists[block_index (blk)]= blk; - } - else /* biggest blocks (allocated according to each particular size) are freed - and placed on the 0-th list */ - { - if (block_data (blk)) { - free (block_data (blk)); - block_data (blk)= NULL; + if (block_index(blk) != TOP_BLOCK_LIST) + { + block_next(blk) = (struct block_t *)sc->block_lists[block_index(blk)]; + sc->block_lists[block_index(blk)] = blk; + } + else /* biggest blocks (allocated according to each particular size) are freed and placed on the 0-th list */ + { + if (block_data(blk)) + { + free(block_data(blk)); + block_data(blk) = NULL; + } + block_next(blk) = (struct block_t *)sc->block_lists[BLOCK_LIST]; + sc->block_lists[BLOCK_LIST] = blk; } - block_next (blk) = (struct block_t*) sc->block_lists[BLOCK_LIST]; - sc->block_lists[BLOCK_LIST]= blk; - } } -void -liberate_block (s7_scheme* sc, block_t* blk) { +void liberate_block(s7_scheme *sc, block_t *blk) +{ #if S7_DEBUGGING sc->blocks_freed[BLOCK_LIST]++; #endif - block_next (blk)= - (struct block_t*) sc->block_lists[BLOCK_LIST]; /* BLOCK_LIST==0 */ - sc->block_lists[BLOCK_LIST]= blk; -} - -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 */ + block_next(blk) = (struct block_t *)sc->block_lists[BLOCK_LIST]; /* BLOCK_LIST==0 */ + sc->block_lists[BLOCK_LIST] = blk; +} + +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; + 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; + 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; } -extern inline block_t* -mallocate_block (s7_scheme* sc) { - block_t* p; +extern 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); -} - -extern 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 */ + 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); +} + +extern 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; - } + 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); + 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, s7_int bytes) { - block_t* blk; - 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]; +static Inline block_t *inline_mallocate(s7_scheme *sc, s7_int bytes) +{ + block_t *blk; + 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 - index= (bytes <= 65536) ? (8 + intlen_bits[(bytes - 1) >> 8]) - : TOP_BLOCK_LIST; /* expansion to (1 << 17) made - no difference */ - } - blk= sc->block_lists[index]; - if (blk) { + { + 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 */ + } + blk = sc->block_lists[index]; + if (blk) + { #if S7_DEBUGGING - sc->blocks_mallocated[index]++; + sc->blocks_mallocated[index]++; #endif - sc->block_lists[index]= (block_t*) block_next (blk); - } - else { - if (index < (TOP_BLOCK_LIST - 1)) { - blk= sc->block_lists[index + 1]; - if (blk) { - /* we are "borrowing" a block from the next larger bin -- this saves - * space but costs a bit of time. in a tauto run repeating every call - * 1000 times, the old form ends up at 129M and 31.1 secs, whereas the - * borrowing form ends at 116M and 31.5 secs, but most of my tests - * show a slight speed-up, probably because grabbing a block here is - * faster than making a new one. Worst case is tlet: 8 slower in - * callgrind. - */ + sc->block_lists[index] = (block_t *)block_next(blk); + } + else + { + if (index < (TOP_BLOCK_LIST - 1)) + { + blk = sc->block_lists[index + 1]; + if (blk) + { + /* 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]++; + sc->blocks_mallocated[index + 1]++; + sc->blocks_borrowed[index + 1]++; #endif - sc->block_lists[index + 1]= (block_t*) block_next (blk); - block_set_size (blk, bytes); - return (blk); - } - } - blk = mallocate_block (sc); - block_data (blk)= (index < TOP_BLOCK_LIST) - ? (void*) permalloc (sc, (size_t) (1 << index)) - : Malloc (bytes); - block_set_index (blk, index); + sc->block_lists[index + 1] = (block_t *)block_next(blk); + block_set_size(blk, bytes); + return(blk); + }} + blk = mallocate_block(sc); + block_data(blk) = (index < TOP_BLOCK_LIST) ? (void *)permalloc(sc, (size_t)(1 << index)) : Malloc(bytes); + block_set_index(blk, index); #if S7_DEBUGGING - sc->blocks_mallocated[index]++; + sc->blocks_mallocated[index]++; #endif - } - } - else { + }} + else + { #if S7_DEBUGGING - sc->blocks_mallocated[BLOCK_LIST]++; + sc->blocks_mallocated[BLOCK_LIST]++; #endif - blk= mallocate_block (sc); - } - block_set_size (blk, bytes); - return (blk); + blk = mallocate_block(sc); + } + block_set_size(blk, bytes); + return(blk); } -block_t* -mallocate (s7_scheme* sc, s7_int bytes) { - return (inline_mallocate (sc, bytes)); -} +block_t *mallocate(s7_scheme *sc, s7_int bytes) {return(inline_mallocate(sc, bytes));} -block_t* -callocate (s7_scheme* sc, s7_int bytes) { - block_t* blk= inline_mallocate (sc, bytes); - if ((block_data (blk)) && (block_index (blk) != BLOCK_LIST)) { - if ((bytes & (~0x3f)) > 0) - memclr64 ((void*) block_data (blk), bytes & (~0x3f)); - if ((bytes & 0x3f) > 0) - memclr ((void*) ((uint8_t*) block_data (blk) + (bytes & (~0x3f))), - bytes & 0x3f); - } - return (blk); +block_t *callocate(s7_scheme *sc, s7_int bytes) +{ + block_t *blk = inline_mallocate(sc, bytes); + if ((block_data(blk)) && (block_index(blk) != BLOCK_LIST)) + { + if ((bytes & (~0x3f)) > 0) + memclr64((void *)block_data(blk), bytes & (~0x3f)); + if ((bytes & 0x3f) > 0) + memclr((void *)((uint8_t *)block_data(blk) + (bytes & (~0x3f))), bytes & 0x3f); + } + return(blk); } -block_t* -reallocate (s7_scheme* sc, block_t* old_blk, size_t bytes) { - block_t* new_blk= inline_mallocate (sc, bytes); - if ((S7_DEBUGGING) && (bytes < (size_t) block_size (old_blk))) - fprintf (stderr, "reallocate to smaller block?\n"); - if (block_data (old_blk)) /* presumably block_data(new_blk) is not null */ - memcpy ((uint8_t*) (block_data (new_blk)), - (uint8_t*) (block_data (old_blk)), block_size (old_blk)); - liberate (sc, old_blk); - return (new_blk); +block_t *reallocate(s7_scheme *sc, block_t *old_blk, size_t bytes) +{ + block_t *new_blk = inline_mallocate(sc, bytes); + if ((S7_DEBUGGING) && (bytes < (size_t)block_size(old_blk))) fprintf(stderr, "reallocate to smaller block?\n"); + if (block_data(old_blk)) /* presumably block_data(new_blk) is not null */ + memcpy((uint8_t *)(block_data(new_blk)), (uint8_t *)(block_data(old_blk)), block_size(old_blk)); + liberate(sc, old_blk); + return(new_blk); } -/* 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 +/* 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; - -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; - -bool t_number_p[NUM_TYPES], t_small_real_p[NUM_TYPES], t_rational_p[NUM_TYPES], - t_real_p[NUM_TYPES]; + +/* -------------------------------------------------------------------------------- */ +typedef enum {p_display, p_write, p_readable, p_key, p_code} use_write_t; + +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; + +bool t_number_p[NUM_TYPES], t_small_real_p[NUM_TYPES], t_rational_p[NUM_TYPES], t_real_p[NUM_TYPES]; bool t_simple_p[NUM_TYPES], t_structure_p[NUM_TYPES], t_immutable_p[NUM_TYPES]; -bool t_any_macro_p[NUM_TYPES], t_any_closure_p[NUM_TYPES], - t_has_closure_let[NUM_TYPES]; +bool t_any_macro_p[NUM_TYPES], t_any_closure_p[NUM_TYPES], t_has_closure_let[NUM_TYPES]; bool t_mappable_p[NUM_TYPES], t_sequence_p[NUM_TYPES], t_vector_p[NUM_TYPES]; -bool t_procedure_p[NUM_TYPES], t_applicable_p[NUM_TYPES], - t_macro_setter_p[NUM_TYPES]; +bool t_procedure_p[NUM_TYPES], t_applicable_p[NUM_TYPES], t_macro_setter_p[NUM_TYPES]; #if S7_DEBUGGING -bool t_ext_p[NUM_TYPES], - t_exs_p[NUM_TYPES]; /* make sure internal types don't leak out */ +bool t_ext_p[NUM_TYPES], t_exs_p[NUM_TYPES]; /* make sure internal types don't leak out */ #endif -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; +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; + t_ext_p[i] = false; + t_exs_p[i] = false; #endif - } + } { - const int32_t nums[4]= {T_INTEGER, T_RATIO, T_REAL, T_COMPLEX}; - for (int32_t i= 0; i < 4; i++) - t_number_p[nums[i]]= true; + const int32_t nums[4] = {T_INTEGER, T_RATIO, T_REAL, T_COMPLEX}; + for (int32_t i = 0; i < 4; i++) t_number_p[nums[i]] = true; } - t_rational_p[T_INTEGER]= true; - t_rational_p[T_RATIO] = true; + t_rational_p[T_INTEGER] = true; + t_rational_p[T_RATIO] = true; - t_small_real_p[T_INTEGER]= true; - t_small_real_p[T_RATIO] = true; - t_small_real_p[T_REAL] = 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_INTEGER] = true; + t_real_p[T_RATIO] = true; + t_real_p[T_REAL] = 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 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}; + 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; + 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 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 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; + 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 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; + 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; + 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. */ + /* 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; + 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; - /* 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; + 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; + /* 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; #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) +#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) +#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 full_type(p) ((p)->tf.u64_type) #define low_type_bits(p) ((p)->tf.bits.low_bits) -#define TYPE_MASK 0xff +#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 type_unchecked(p) ((p)->tf.type_field) + 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 type_unchecked(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_; \ - }) + #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 + #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_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 */ + #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_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 type_unchecked(p) ((p)->tf.type_field) -#define type(p) ((p)->tf.type_field) -#define set_full_type(p, f) full_type (p)= f + /* 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 type_unchecked(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_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_boolean(p) (type (p) == T_BOOLEAN) - -#define is_free(p) (type_unchecked (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) +#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_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_boolean(p) (type(p) == T_BOOLEAN) + +#define is_free(p) (type_unchecked(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(Sc, 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_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(Sc, 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_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) +#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_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 */ +#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) + #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) + #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) +#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) +#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) +#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_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_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_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) +#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) +#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) +#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(Sc, 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_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(Sc, 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" */ +#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_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_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) +#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_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) +#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) +#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) +#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) - */ +/* 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_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) +#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) + #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) + #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) +#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) +#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_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) +#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, Let) \ - mid_type (T_Let (p))|= \ - (mid_type (Let) & (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 */ +#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, Let) mid_type(T_Let(p)) |= (mid_type(Let) & (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) +#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) +#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) +#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_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))) +#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_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_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_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_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(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) +#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(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); -} + 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) + #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(Sc, p) \ - (((p) == Sc->quote_symbol) || \ - ((p) == Sc->quote_function)) /* order here apparently does not matter */ -#define is_safe_quote(Sc, p) \ - ((((p) == Sc->quote_symbol) && (is_global (Sc->quote_symbol))) || \ - ((p) == Sc->quote_function)) -#define is_quoted_pair(Sc, p) ((is_pair (p)) && (is_quote (Sc, car (p)))) -#define is_safe_quoted_pair(Sc, p) \ - ((is_pair (p)) && (is_safe_quote (Sc, car (p)))) -#define is_unquoted_pair(Sc, p) ((is_pair (p)) && (!is_quote (Sc, car (p)))) -#define is_quoted_symbol(Sc, p) \ - ((is_quoted_pair (Sc, p)) && (is_pair (cdr (p))) && (is_symbol (cadr (p)))) +#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(Sc, p) (((p) == Sc->quote_symbol) || ((p) == Sc->quote_function)) /* order here apparently does not matter */ +#define is_safe_quote(Sc, p) ((((p) == Sc->quote_symbol) && (is_global(Sc->quote_symbol))) || ((p) == Sc->quote_function)) +#define is_quoted_pair(Sc, p) ((is_pair(p)) && (is_quote(Sc, car(p)))) +#define is_safe_quoted_pair(Sc, p) ((is_pair(p)) && (is_safe_quote(Sc, car(p)))) +#define is_unquoted_pair(Sc, p) ((is_pair(p)) && (!is_quote(Sc, car(p)))) +#define is_quoted_symbol(Sc, p) ((is_quoted_pair(Sc, 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)) +#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) +#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. +/* 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) +#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) /* can be -1 (arity), check_lambda[78617] */ -#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) +#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) /* can be -1 (arity), check_lambda[78617] */ +#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__) +#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) +#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 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 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) +#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_; \ - }) -/* this warning can happen when calling apply_mv from splice_in_values -- it - * appears to be innocuous */ + #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_;}) + /* this warning can happen when calling apply_mv from splice_in_values -- it appears to be innocuous */ #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_)); \ - }) + #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)) +#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 car_unchecked(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 set_cdr_unchecked(p, Val) cdr (p)= T_Exs (Val) /* # in g_gc */ -#define cdr_unchecked(p) (T_Exs (p))->object.cons.cdr +#define car(p) (T_Pair(p))->object.cons.car +#define car_unchecked(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 set_cdr_unchecked(p, Val) cdr(p) = T_Exs(Val) /* # in g_gc */ +#define cdr_unchecked(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__) + 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) + #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[8178], set_elist_2, we're \ - clearing the elists */ -#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)) +#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[8178], set_elist_2, we're clearing the elists */ +#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_; \ - }) + /* 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) + #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(Sc, 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(Sc, A, B) \ - (set_car (Sc->t2_1, A), set_car (Sc->t2_2, B), Sc->t2_1) -#define with_list_t3(Sc, 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(Sc, 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 string_block_unchecked(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 optimize_op_unchecked(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) +#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(Sc, 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(Sc, A, B) (set_car(Sc->t2_1, A), set_car(Sc->t2_2, B), Sc->t2_1) +#define with_list_t3(Sc, 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(Sc, 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 string_block_unchecked(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 optimize_op_unchecked(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__) -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); +#define s7_t_slot(Sc, P) s7_t_slot_1(Sc, P, __func__, __LINE__) +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) +#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_bound_symbol(Sc, p) \ - (is_slot (s7_slot (Sc, p))) /* (s7_slot(Sc, p) != Sc->undefined) is the same \ - speed apparently */ -#define is_safe_symbol(Sc, p) ((is_symbol (p)) && (is_bound_symbol (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 +#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_bound_symbol(Sc, p) (is_slot(s7_slot(Sc, p))) /* (s7_slot(Sc, p) != Sc->undefined) is the same speed apparently */ +#define is_safe_symbol(Sc, p) ((is_symbol(p)) && (is_bound_symbol(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 -void -symbol_set_id (s7_pointer sym, s7_int id) { - if (id < symbol_id (sym)) { - fprintf (stderr, "%s[%d]: id mismatch: sym: %s %" ld64 ", let: %" ld64 "\n", - __func__, __LINE__, symbol_name (sym), symbol_id (sym), id); - abort (); - } - (T_Sym (sym))->object.sym.id= id; +void symbol_set_id(s7_pointer sym, s7_int id) +{ + if (id < symbol_id(sym)) + { + fprintf(stderr, "%s[%d]: id mismatch: sym: %s %" ld64 ", let: %" ld64 "\n", __func__, __LINE__, symbol_name(sym), symbol_id(sym), id); + abort(); + } + (T_Sym(sym))->object.sym.id = id; } #else -#define symbol_set_id(p, X) (T_Sym (p))->object.sym.id= X +#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! +/* 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 -- can be gensym, eval unopt section */ -#define starlet_symbol_set_id(p, F) \ - block_size (symbol_info (p))= \ - ((block_size (symbol_info (p)) & ~0xff00) | (((F) & 0xff) << 8)) +#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 -- can be gensym, eval unopt section */ +#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__) + /* 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 {} */ + #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) /* # from new_symbol and g_gensym */ -#define local_slot(p) \ - T_Slt ((T_Sym (p))->object.sym.local_slot) /* was T_Sld 1-Aug-25 */ -#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 local_value_unchecked(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 - */ /* checked in new_symbol that it's 0 for a gensym */ -/* field incremented in add_symbol_to_big_symbol_set and decremented in - * cleanup_big_symbol_set */ -#define symbol_clear_shadows(p) symbol_info (p)->ln.iter_or_size= 0 - -#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) */ - -/* block_index(symbol_info()) is free. We won't deallocate a symbol unless it is - * a gensym. remove_gensym_from_symbol_table could be opt'd by using this as - * the location. high bits of block_size(symbol_info()) might be free. Maybe - * use the gensym block instead? +#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) /* # from new_symbol and g_gensym */ +#define local_slot(p) T_Slt((T_Sym(p))->object.sym.local_slot) /* was T_Sld 1-Aug-25 */ +#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 local_value_unchecked(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 */ /* checked in new_symbol that it's 0 for a gensym */ +/* field incremented in add_symbol_to_big_symbol_set and decremented in cleanup_big_symbol_set */ +#define symbol_clear_shadows(p) symbol_info(p)->ln.iter_or_size = 0 + +#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) */ + +/* block_index(symbol_info()) is free. We won't deallocate a symbol unless it is a gensym. remove_gensym_from_symbol_table could be opt'd by using this as the location. + * high bits of block_size(symbol_info()) might be free. Maybe use the gensym block instead? */ -#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) +#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) +/* 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) +#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) +#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); -} +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 +#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_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) +#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 is_not_slot_end(p) ((p) && (T_Slt (p))) + #define is_not_slot_end(p) ((p) && (T_Slt(p))) #else -#define is_not_slot_end(p) \ - (p) /* used for loop through let slots which end in null, not for general \ - slot recognition */ + #define is_not_slot_end(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 curlet_has_slots(Sc) is_not_slot_end (let_slots (Sc->curlet)) - -#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.let.id -#define is_let(p) (type (p) == T_LET) -#define is_let_unchecked(p) (type_unchecked (p) == T_LET) -#define let_slots(p) T_Sln ((T_Let (p))->object.let.slots) -#define let_outlet(p) T_Out ((T_Let (p))->object.let.nxt) -#define let_set_outlet(p, ol) (T_Let (p))->object.let.nxt= T_Out (ol) +#define slot_end NULL +#define is_slot_end(p) (!(p)) +#define curlet_has_slots(Sc) is_not_slot_end(let_slots(Sc->curlet)) + +#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.let.id +#define is_let(p) (type(p) == T_LET) +#define is_let_unchecked(p) (type_unchecked(p) == T_LET) +#define let_slots(p) T_Sln((T_Let(p))->object.let.slots) +#define let_outlet(p) T_Out((T_Let(p))->object.let.nxt) +#define let_set_outlet(p, ol) (T_Let(p))->object.let.nxt = T_Out(ol) #if S7_DEBUGGING -#define let_set_id(p, Id) \ - do { \ - (T_Let (p))->object.let.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__) + #define let_set_id(p, Id) do {(T_Let(p))->object.let.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.let.id= Id -#define let_set_slots(p, Slot) (T_Let (p))->object.let.slots= T_Sln (Slot) -#define C_Let(p, role) p -#define S_Let(p, role) p + #define let_set_id(p, Id) (T_Let(p))->object.let.id = Id + #define let_set_slots(p, Slot) (T_Let(p))->object.let.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.let.edat.efnc.function) -#define funclet_set_function(p, F) \ - (S_Let (p, L_FUNC))->object.let.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.let.edat.key -#define let_set_baffle_key(p, K) (T_Let (p))->object.let.edat.key= K - -#define let_line(p) (C_Let (p, L_FUNC))->object.let.edat.efnc.line -#define let_set_line(p, L) (S_Let (p, L_FUNC))->object.let.edat.efnc.line= L -#define let_file(p) (C_Let (p, L_FUNC))->object.let.edat.efnc.file -#define let_set_file(p, F) (S_Let (p, L_FUNC))->object.let.edat.efnc.file= F - -#define let_dox_slot1(p) T_Slt ((C_Let (p, L_DOX))->object.let.edat.dox.dox1) -#define let_set_dox_slot1(p, S) \ - do { \ - (S_Let (p, L_DOX))->object.let.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.let.edat.dox.dox2) /* # from opt_cell_do */ -#define let_set_dox_slot2(p, S) \ - do { \ - (S_Let (p, L_DOX))->object.let.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.let.edat.dox.dox2) -#define let_set_dox_slot2_unchecked(p, S) \ - do { \ - S_Let (p, L_DOX)->object.let.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 vector_elements_unchecked(p) (p)->object.vector.elements.objects +#define funclet_function(p) T_Sym((C_Let(p, L_FUNC))->object.let.edat.efnc.function) +#define funclet_set_function(p, F) (S_Let(p, L_FUNC))->object.let.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.let.edat.key +#define let_set_baffle_key(p, K) (T_Let(p))->object.let.edat.key = K + +#define let_line(p) (C_Let(p, L_FUNC))->object.let.edat.efnc.line +#define let_set_line(p, L) (S_Let(p, L_FUNC))->object.let.edat.efnc.line = L +#define let_file(p) (C_Let(p, L_FUNC))->object.let.edat.efnc.file +#define let_set_file(p, F) (S_Let(p, L_FUNC))->object.let.edat.efnc.file = F + +#define let_dox_slot1(p) T_Slt((C_Let(p, L_DOX))->object.let.edat.dox.dox1) +#define let_set_dox_slot1(p, S) do {(S_Let(p, L_DOX))->object.let.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.let.edat.dox.dox2) /* # from opt_cell_do */ +#define let_set_dox_slot2(p, S) do {(S_Let(p, L_DOX))->object.let.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.let.edat.dox.dox2) +#define let_set_dox_slot2_unchecked(p, S) do {S_Let(p, L_DOX)->object.let.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 vector_elements_unchecked(p) (p)->object.vector.elements.objects #define vector_element_unchecked(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 vector_block_unchecked(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) vector_element_unchecked (T_Stk (p), i) -#define stack_elements(p) vector_elements_unchecked (T_Stk (p)) -#define stack_block(p) vector_block_unchecked (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 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 vector_block_unchecked(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) vector_element_unchecked(T_Stk(p), i) +#define stack_elements(p) vector_elements_unchecked(T_Stk(p)) +#define stack_block(p) vector_block_unchecked(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 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 hash_table_block_unchecked(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) +#define hash_table_size(p) ((T_Hsh(p))->object.hasher.mask + 1) +#define hash_table_block(p) (T_Hsh(p))->object.hasher.block +#define hash_table_block_unchecked(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__) + #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 + #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 port_data_block_unchecked(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_par_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 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.let) -#define closure_set_let(p, L) (T_Clo (p))->object.func.let= 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 +#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 port_data_block_unchecked(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_par_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 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.let) +#define closure_set_let(p, L) (T_Clo(p))->object.func.let = 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.let) -#define c_object_set_let(p, L) (T_Obj (p))->object.c_obj.let= 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 +#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.let) +#define c_object_set_let(p, L) (T_Obj(p))->object.c_obj.let = 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 + #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.let) -#define counter_set_let(p, L) (T_Ctr (p))->object.ctr.let= 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) +#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.let) +#define counter_set_let(p, L) (T_Ctr(p))->object.ctr.let = 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) -void -begin_temp_1 (s7_scheme* sc, s7_pointer p, s7_pointer val, const char* func, - int line) { - if (p != sc->unused) { - char* str; - 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)), - str= s7_object_to_c_string (sc, p)); - free (str); - /* 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; +#define begin_temp(P, Val) do {s7_pointer __val__ = Val; begin_temp_1(sc, P, __val__, __func__, __LINE__); P = __val__;} while (0) +void begin_temp_1(s7_scheme *sc, s7_pointer p, s7_pointer val, const char *func, int line) +{ + if(p != sc->unused) + { + char *str; + 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)), + str = s7_object_to_c_string(sc, p)); + free(str); + /* 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 +#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) +#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)); -} + 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 +#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) +#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 +#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)) + #define to_c_complex(p) CMPLX(real_part(p), imag_part(p)) #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); +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)) +#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)) +#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); -} - -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; +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); +} + +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, type_unchecked (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; + 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, type_unchecked(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 @@ -4929,185 +3813,140 @@ 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_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) { -/* 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 - 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 void init_int_limits(void) +{ + /* 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 + 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); +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 + #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 +#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 */ +/* 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; +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) +#define is_small_int(n) ((n & ~(NUM_SMALL_INTS - 1)) == 0) /* ((n >= 0) && (n < NUM_SMALL_INTS)) is slower */ - 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); +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; + 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)); -} +/* -------------------------------------------------------------------------------- */ +#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 + #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 + #define GC_TRIGGER_SIZE 64 #endif #if S7_DEBUGGING -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__) + 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 -void try_to_call_gc (s7_scheme* sc); + void try_to_call_gc(s7_scheme *sc); #endif #define GC_STATS 1 @@ -5115,91188 +3954,74269 @@ void try_to_call_gc (s7_scheme* sc); #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) +#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_unchecked(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. +/* 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_unchecked(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); \ +#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_unchecked(Sc, Obj, Type) \ - do { \ - if (Sc->gc_in_progress) \ - fprintf (stderr, "%s[%d]: new_cell_unchecked 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) +#define new_cell_unchecked(Sc, Obj, Type) \ + do { \ + if (Sc->gc_in_progress) fprintf(stderr, "%s[%d]: new_cell_unchecked 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) */ +/* #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_unchecked (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_unchecked (Sc, _R_, T_REAL); \ - set_real (_R_, _N_); \ - _R_; \ - }) +#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_unchecked(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_unchecked(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_; \ - }); \ - }) +#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_; \ - }) +#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_unchecked (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_)); \ - }) +#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_unchecked(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) +#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! + * 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; +static void local_memset(void *s, uint8_t val, size_t n) +{ + uint8_t *s2; #if S7_ALIGNED - s2= (uint8_t*) s; + 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; + 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; + s2 = (uint8_t *)s; #endif #endif - while (n > 0) { - *s2++= val; - n--; - } + while (n > 0) + { + *s2++ = val; + n--; + } } -#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 */ +#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 */ -#define strings_are_equal_with_length(Str1, Str2, Len) \ - (local_strncmp (Str1, Str2, Len)) +#define strings_are_equal_with_length(Str1, Str2, Len) (local_strncmp(Str1, Str2, Len)) -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)); -} - -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)); +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)); } -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)); +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)); +} + +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 -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))); \ - }) + #if S7_DEBUGGING + 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 + 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 -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)); \ - }) + 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 -#else -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 -s7_pointer symbol_to_local_slot (s7_scheme* sc, s7_pointer symbol, - s7_pointer let); +s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer let); + /* ---------------- 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 -}; +/* 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; +typedef enum {combine_p, combine_pp, combine_cp, combine_sp, combine_pc, combine_ps} combine_op_t; /* op_names[] moved to s7_op_names.c */ -#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 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)); +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_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_scheme_version, - 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?", - "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", - "scheme-version", - "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); -const char* type_name (s7_scheme* sc, s7_pointer arg, article_t article); -s7_pointer cons_unchecked (s7_scheme* sc, s7_pointer a, s7_pointer b); -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" +typedef enum {sl_no_field=0, sl_accept_all_keyword_arguments, sl_autoloading, 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_scheme_version, 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?", "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", "scheme-version", "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); +const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article); +s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b); +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); + +/* -------------------------------- 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 siglet; /* 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 (siglet, 1); -} +static Jmp_Buf siglet; /* 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(siglet, 1);} #endif #if S7_DEBUGGING -static bool -s7_is_in_heap (s7_scheme* sc, s7_pointer arg) /* for heap analysis where we only - care about stuff in the heap */ +static bool s7_is_in_heap(s7_scheme *sc, s7_pointer arg) /* for heap analysis where we only care about stuff in the heap */ { - s7_pointer heap0= *(sc->heap); - s7_pointer heap1= (s7_pointer) (heap0 + sc->heap_size); - return ((arg >= heap0) && (arg < heap1)); + s7_pointer heap0 = *(sc->heap); + s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size); + return((arg >= heap0) && (arg < heap1)); } #endif -bool -s7_is_valid (s7_scheme* sc, s7_pointer arg) { - bool result= false; - if (!arg) return (false); +bool s7_is_valid(s7_scheme *sc, s7_pointer arg) +{ + bool result = false; + if (!arg) return(false); { - s7_pointer heap0= *(sc->heap); - s7_pointer heap1= (s7_pointer) (heap0 + sc->heap_size); - if ((arg >= heap0) && (arg < heap1)) return (true); + s7_pointer heap0 = *(sc->heap); + s7_pointer heap1 = (s7_pointer)(heap0 + sc->heap_size); + if ((arg >= heap0) && (arg < heap1)) return(true); } #if TRAP_SEGFAULT - if (SetJmp (siglet, 1) == 0) { - void (*old_segv) (int32_t sig); - can_jump= 1; - old_segv= signal (SIGSEGV, segv); + if (SetJmp(siglet, 1) == 0) + { + void (*old_segv)(int32_t sig); + can_jump = 1; + old_segv = signal(SIGSEGV, segv); #endif - if ((type_unchecked (arg) > T_FREE) && (type_unchecked (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 ((type_unchecked(arg) > T_FREE) && + (type_unchecked(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; + signal(SIGSEGV, old_segv); + } + else result = false; + can_jump = 0; #endif - return (result); + 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_; \ +#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) { +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 { - s7_pointer p= cdr (sc->cur_code); - fprintf (stderr, "history:\n"); - for (int32_t i= 0, size= sc->history_size; 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"); - } + if (sc->cur_code == sc->history_sink) + fprintf(stderr, "history diabled\n"); + else + { + s7_pointer p = cdr(sc->cur_code); + fprintf(stderr, "history:\n"); + for (int32_t i = 0, size = sc->history_size; 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)); + 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 = type_unchecked (obj); - char str[900]; - - str[0]= '\0'; - catstrs ( - str, 900, /* if debugging, all of these bits are being watched, so we need - to access them directly */ - /* bit 8 (the first 8 bits (after the 8 type bits) are easy...) */ - ((full_typ & T_MULTIFORM) != 0) - ? ((is_any_closure (obj)) - ? (((full_typ & T_ONE_FORM) != 0) ? " closure-one-form-has-fx" - : " closure-multiform") - : " ?0?") - : "", - /* bit 9 */ - ((full_typ & T_SYNTACTIC) != 0) - ? (((is_pair (obj)) || (is_syntax (obj)) || (is_normal_symbol (obj))) - ? " syntactic" - : " ?1?") - : "", - /* bit 10 */ - ((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) - ? ((is_pair (obj)) - ? " simple-args|in-use" - : ((is_any_closure (obj)) ? " closure-one-form" : " ?2?")) - : "", - /* bit 11 */ - ((full_typ & T_OPTIMIZED) != 0) - ? ((is_c_function (obj)) ? " scope-safe" - : ((is_pair (obj)) ? " optimized" : " ?3?")) - : "", - /* bit 12 */ - ((full_typ & T_SAFE_CLOSURE) != 0) - ? (((has_closure_let (obj)) || (is_pair (obj))) ? " safe-closure" - : " ?4?") - : "", - /* bit 13 */ - ((full_typ & T_DONT_EVAL_ARGS) != 0) - ? (((is_any_macro (obj)) || (is_syntax (obj))) ? " dont-eval-args" - : " ?5?") - : "", - /* bit 14 */ - ((full_typ & T_EXPANSION) != 0) - ? (((is_normal_symbol (obj)) || (is_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" - : "", - (((is_any_macro (obj)) || (is_syntax (obj))) && - ((full_typ & T_DONT_EVAL_ARGS) == 0)) - ? " dont-eval-args not set" - : "", - /* for is_applicable, e.g. goto is not a safe procedure -- maybe check - goto/continuation...? */ - NULL); +#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 = type_unchecked(obj); + char str[900]; + + str[0] = '\0'; + catstrs(str, 900, /* if debugging, all of these bits are being watched, so we need to access them directly */ + /* bit 8 (the first 8 bits (after the 8 type bits) are easy...) */ + ((full_typ & T_MULTIFORM) != 0) ? ((is_any_closure(obj)) ? + (((full_typ & T_ONE_FORM) != 0) ? " closure-one-form-has-fx" : " closure-multiform") : + " ?0?") : "", + /* bit 9 */ + ((full_typ & T_SYNTACTIC) != 0) ? (((is_pair(obj)) || (is_syntax(obj)) || (is_normal_symbol(obj))) ? + " syntactic" : + " ?1?") : "", + /* bit 10 */ + ((full_typ & T_SIMPLE_ARG_DEFAULTS) != 0) ? ((is_pair(obj)) ? " simple-args|in-use" : + ((is_any_closure(obj)) ? " closure-one-form" : + " ?2?")) : "", + /* bit 11 */ + ((full_typ & T_OPTIMIZED) != 0) ? ((is_c_function(obj)) ? " scope-safe" : + ((is_pair(obj)) ? " optimized" : + " ?3?")) : "", + /* bit 12 */ + ((full_typ & T_SAFE_CLOSURE) != 0) ? (((has_closure_let(obj)) || (is_pair(obj))) ? " safe-closure" : " ?4?") : "", + /* bit 13 */ + ((full_typ & T_DONT_EVAL_ARGS) != 0) ? (((is_any_macro(obj)) || (is_syntax(obj))) ? " dont-eval-args" : " ?5?") : "", + /* bit 14 */ + ((full_typ & T_EXPANSION) != 0) ? (((is_normal_symbol(obj)) || (is_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" : "", + (((is_any_macro(obj)) || (is_syntax(obj))) && ((full_typ & T_DONT_EVAL_ARGS) == 0)) ? " dont-eval-args not set" : "", + /* for is_applicable, e.g. goto is not a safe procedure -- maybe check goto/continuation...? */ + NULL); { - char* 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, optimize_op_unchecked (obj), - (optimize_op_unchecked (obj) < NUM_OPS) - ? op_names[optimize_op_unchecked (obj)] - : "", - full_typ, str); - return (buf); + char *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, + optimize_op_unchecked(obj), (optimize_op_unchecked(obj) < NUM_OPS) ? op_names[optimize_op_unchecked(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)))) */ +/* 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) { -#define HEAPED_SIZE 20 - const int32_t heaped[HEAPED_SIZE]= { - 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, but can be unheaped slot value - */ - for (int32_t i= 0; i < NUM_TYPES; i++) - never_unheaped[i]= false; - for (int32_t i= 0; i < HEAPED_SIZE; 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); +static void init_never_unheaped(void) +{ + #define HEAPED_SIZE 20 + const int32_t heaped[HEAPED_SIZE] = { + 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, but can be unheaped slot value */ + for (int32_t i = 0; i < NUM_TYPES; i++) never_unheaped[i] = false; + for (int32_t i = 0; i < HEAPED_SIZE; 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)) && - (type_unchecked (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 (((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)) && (type_unchecked(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= type_unchecked (obj); - if (never_unheaped[typ]) { - fprintf (stderr, "unheap %s!\n", s7_type_names[typ]); - print_gc_info (cur_sc, obj, __func__, __LINE__); - return (true); + if (!in_heap(obj)) + { + uint8_t typ = type_unchecked(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); + /* 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 */ +void s7_show_let(s7_scheme *sc); +void s7_show_let(s7_scheme *sc) /* debugging convenience */ { - for (s7_pointer let= sc->curlet; let; let= let_outlet (let)) { - if (let == sc->owlet) fprintf (stderr, "(owlet): "); - else if (let == sc->rootlet) fprintf (stderr, "(rootlet): "); - else if (is_funclet (let)) - fprintf (stderr, "(%s funclet): ", display (funclet_function (let))); - else if (let == sc->shadow_rootlet) fprintf (stderr, "(shadow rootlet): "); - fprintf (stderr, "%s\n", display (let)); - } + for (s7_pointer let = sc->curlet; let; let = let_outlet(let)) + { + if (let == sc->owlet) + fprintf(stderr, "(owlet): "); + else + if (let == sc->rootlet) + fprintf(stderr, "(rootlet): "); + else + if (is_funclet(let)) + fprintf(stderr, "(%s funclet): ", display(funclet_function(let))); + else + if (let == sc->shadow_rootlet) + fprintf(stderr, "(shadow rootlet): "); + fprintf(stderr, "%s\n", display(let)); + } } -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!"); +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)); +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", type_unchecked (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= type_unchecked (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 (); - } +static char *object_raw_type_to_string(s7_pointer p) +{ + char *buf = (char *)Malloc(128); + snprintf(buf, 128, "type: %d", type_unchecked(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(); } - } - return (p); + else + { + const uint8_t typ = type_unchecked(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); } -void -check_let_set_slots (s7_scheme* sc, s7_pointer let, s7_pointer slot, - const char* func, int32_t line) { - if ((!in_heap (let)) && (slot) && (in_heap (slot))) - fprintf (stderr, "%s[%d]: let+slot mismatch\n", func, line); - if ((let == sc->rootlet) && (slot != slot_end)) { - fprintf (stderr, "%s[%d]: setting rootlet slots!\n", func, line); - if (sc->stop_at_error) abort (); - } - T_Let (let)->object.let.slots= T_Sln (slot); +void check_let_set_slots(s7_scheme *sc, s7_pointer let, s7_pointer slot, const char *func, int32_t line) +{ + if ((!in_heap(let)) && (slot) && (in_heap(slot))) fprintf(stderr, "%s[%d]: let+slot mismatch\n", func, line); + if ((let == sc->rootlet) && (slot != slot_end)) + { + fprintf(stderr, "%s[%d]: setting rootlet slots!\n", func, line); + if (sc->stop_at_error) abort(); + } + T_Let(let)->object.let.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_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_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) { +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= type_unchecked (p); - if ((typ != expected_type) && (typ != other_type)) - return (check_ref_one (p, expected_type, func, line, func1, func2)); - } - return (p); + fprintf(stderr, "%s[%d]: null pointer passed to check_ref_two\n", func, line); + else + { + uint8_t typ = type_unchecked(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= type_unchecked (p); +static s7_pointer check_ref_prf(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(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); + 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= type_unchecked (p); +static s7_pointer check_ref_prt(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(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); + 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= type_unchecked (p); +static s7_pointer check_ref_pri(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(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); + 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= type_unchecked (p); +static s7_pointer check_ref_pro(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(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= type_unchecked (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); + 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_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= type_unchecked (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= type_unchecked (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= type_unchecked (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= type_unchecked (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= type_unchecked (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= type_unchecked (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= type_unchecked (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_vec(s7_pointer p, const char *func, int32_t line) +{ + if ((strcmp(func, "sweep") != 0) && + (strcmp(func, "process_multivector") != 0)) + { + uint8_t typ = type_unchecked(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_app (s7_pointer p, const char* func, int32_t line) { - uint8_t typ= type_unchecked (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_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 = type_unchecked(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_sln (s7_pointer p, const char* func, int32_t line) { - uint8_t typ; - if (is_slot_end (p)) return (p); - typ= type_unchecked (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_cfn(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(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_out (s7_pointer p, const char* func, int32_t line) { - uint8_t typ; - if (!p) return (NULL); - typ= type_unchecked (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, - type_unchecked (p)); - if (!is_subvector (p)) - complain (cur_sc, - "%s%s[%d]: subvector is %s (%s), but not a subvector?%s\n", p, - func, line, type_unchecked (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, - type_unchecked (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, type_unchecked (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_ref_fnc(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(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_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 (type_unchecked (p) >= NUM_TYPES) { - fprintf (stderr, "%s%s[%d]: attempt to use messed up cell (type: %d)%s\n", - bold_text, func, line, type_unchecked (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_num(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(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_nmv (s7_pointer p, const char* func, int32_t line) { - uint8_t typ; - check_nref (p, func, line); - typ= type_unchecked (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* str; - fprintf (stderr, "%s[%d]: odd bits: %s\n", __func__, __LINE__, - str= describe_type_bits (cur_sc, p)); - free (str); - } - if (t_exs_p[typ]) /* can be t_slot, make_funclet[81614] */ - { - 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, - type_unchecked (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, - type_unchecked (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[type_unchecked (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* str; - fprintf (stderr, "odd bits: %s\n", str= describe_type_bits (cur_sc, p)); - free (str); - } - } - return (p); +static s7_pointer check_ref_seq(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(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_ext (s7_pointer p, const char* func, int32_t line) { - uint8_t typ; - check_nref (p, func, line); - typ= type_unchecked (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_met(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(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_exs (s7_pointer p, const char* func, int32_t line) { - uint8_t typ; - check_nref (p, func, line); - typ= type_unchecked (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_ref_arg(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(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_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) { /* set-car! is a bother to check -- many calls on - lists not in the heap etc */ - if ((is_immutable (p)) && (!in_heap (p))) { - fprintf ( - stderr, - "%s[%d]: set-cdr! target is immutable and not in the heap, %p %s\n", - func, line, p, display (p)); - if (cur_sc->stop_at_error) abort (); - } - 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 %s, %p %s\n", - func, line, p, display (p), val, display (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 s7_pointer check_ref_app(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ = type_unchecked(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 void -base_opt1 (s7_pointer p, s7_uint role) { - set_opt1_role (p, role); - set_opt1_is_set (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 = type_unchecked(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 -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 check_ref_out(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ; + if (!p) return(NULL); + typ = type_unchecked(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 -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); -} - -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 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, type_unchecked(p)); + if (!is_subvector(p)) complain(cur_sc, "%s%s[%d]: subvector is %s (%s), but not a subvector?%s\n", p, func, line, type_unchecked(p)); + return(p); } -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 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, type_unchecked(p)); + return(p); } -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 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, type_unchecked(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 (type_unchecked(p) >= NUM_TYPES) + { + fprintf(stderr, "%s%s[%d]: attempt to use messed up cell (type: %d)%s\n", bold_text, func, line, type_unchecked(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 void -set_opt2_name_1 (s7_pointer p, const char* str) { - p->object.sym_cons.fstr= str; - base_opt2 (p, OPT2_NAME); +static s7_pointer check_ref_nmv(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ; + check_nref(p, func, line); + typ = type_unchecked(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 *str; fprintf(stderr, "%s[%d]: odd bits: %s\n", __func__, __LINE__, str = describe_type_bits(cur_sc, p)); free(str);} + if (t_exs_p[typ]) /* can be t_slot, make_funclet[81614] */ + { + 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 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 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, type_unchecked(p)); + return(p); } -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 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, type_unchecked(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[type_unchecked(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 *str; fprintf(stderr, "odd bits: %s\n", str = describe_type_bits(cur_sc, p)); free(str);} + } + return(p); } -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_pointer check_ref_ext(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ; + check_nref(p, func, line); + typ = type_unchecked(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_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 s7_pointer check_ref_exs(s7_pointer p, const char *func, int32_t line) +{ + uint8_t typ; + check_nref(p, func, line); + typ = type_unchecked(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 void -base_opt3 (s7_pointer p, s7_uint role) { - set_opt3_role (p, role); - set_opt3_is_set (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); +} -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 check_set_cdr(s7_pointer p, s7_pointer val, const char *func, int32_t line) +{ /* set-car! is a bother to check -- many calls on lists not in the heap etc */ + if ((is_immutable(p)) && (!in_heap(p))) + { + fprintf(stderr, "%s[%d]: set-cdr! target is immutable and not in the heap, %p %s\n", func, line, p, display(p)); + if (cur_sc->stop_at_error) abort(); + } + 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 %s, %p %s\n", func, line, p, display(p), val, display(val)); + cdr(p) = val; } -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 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 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 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 -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 void base_opt1(s7_pointer p, s7_uint role) +{ + set_opt1_role(p, role); + set_opt1_is_set(p); } -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 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); +} + +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); +} + +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 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); } -void -print_debugging_state (s7_scheme* sc, s7_pointer obj, s7_pointer port) { +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* str = 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), str); - free (str); - if (is_slot (slot)) fprintf (stderr, ", slot: %s", display (slot)); - fprintf (stderr, "\n"); - if (sc->stop_at_error) abort (); - } - return (p); + 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 *str = 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), str); + free(str); + 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 */ +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 wrapped_int= car (sc->integer_wrappers); + s7_pointer wrapped_int = car(sc->integer_wrappers); #if S7_DEBUGGING - if ((full_type (wrapped_int) & (~T_GC_MARK)) != (T_INTEGER | T_UNHEAP)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, wrapped_int)); + if ((full_type(wrapped_int) & (~T_GC_MARK)) != (T_INTEGER | T_UNHEAP)) + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, wrapped_int)); sc->integer_wrapper_allocs++; #endif - set_integer (wrapped_int, x); - sc->integer_wrappers= cdr (sc->integer_wrappers); - return (wrapped_int); + set_integer(wrapped_int, x); + sc->integer_wrappers = cdr(sc->integer_wrappers); + return(wrapped_int); } -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_integer(s7_scheme *sc, s7_int x) +{ + if (is_small_int(x)) return(small_int(x)); + return(wrap_mutable_integer(sc, x)); } -s7_pointer -wrap_real (s7_scheme* sc, s7_double x) { - s7_pointer wrapped_real= car (sc->real_wrappers); +s7_pointer wrap_real(s7_scheme *sc, s7_double x) +{ + s7_pointer wrapped_real = car(sc->real_wrappers); #if S7_DEBUGGING - if ((full_type (wrapped_real) & (~T_GC_MARK)) != (T_REAL | T_UNHEAP)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, wrapped_real)); + if ((full_type(wrapped_real) & (~T_GC_MARK)) != (T_REAL | T_UNHEAP)) + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, wrapped_real)); sc->real_wrapper_allocs++; #endif - set_real (wrapped_real, x); - sc->real_wrappers= cdr (sc->real_wrappers); - return (wrapped_real); + set_real(wrapped_real, x); + sc->real_wrappers = cdr(sc->real_wrappers); + return(wrapped_real); } -static s7_pointer -wrap_complex (s7_scheme* sc, s7_double rl, s7_double im) { - s7_pointer wrapped_complex= car (sc->complex_wrappers); +static s7_pointer wrap_complex(s7_scheme *sc, s7_double rl, s7_double im) +{ + s7_pointer wrapped_complex = car(sc->complex_wrappers); #if S7_DEBUGGING - if ((full_type (wrapped_complex) & (~T_GC_MARK)) != (T_COMPLEX | T_UNHEAP)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, wrapped_complex)); + if ((full_type(wrapped_complex) & (~T_GC_MARK)) != (T_COMPLEX | T_UNHEAP)) + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, wrapped_complex)); sc->complex_wrapper_allocs++; #endif - set_real_part (wrapped_complex, rl); - set_imag_part (wrapped_complex, im); - sc->complex_wrappers= cdr (sc->complex_wrappers); - return (wrapped_complex); + set_real_part(wrapped_complex, rl); + set_imag_part(wrapped_complex, im); + sc->complex_wrappers = cdr(sc->complex_wrappers); + return(wrapped_complex); } -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)); +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)); } -static s7_pointer -wrap_let (s7_scheme* sc, s7_pointer old_let) { - s7_pointer wrapped_let= car (sc->let_wrappers); +static s7_pointer wrap_let(s7_scheme *sc, s7_pointer old_let) +{ + s7_pointer wrapped_let = car(sc->let_wrappers); #if S7_DEBUGGING - if ((full_type (wrapped_let) & (~T_GC_MARK)) != - (T_LET | T_SAFE_PROCEDURE | T_UNHEAP)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, wrapped_let)); + if ((full_type(wrapped_let) & (~T_GC_MARK)) != (T_LET | T_SAFE_PROCEDURE | T_UNHEAP)) + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, wrapped_let)); sc->let_wrapper_allocs++; #endif - let_set_id (wrapped_let, ++sc->let_number); - let_set_slots (wrapped_let, slot_end); - let_set_outlet (wrapped_let, old_let); - sc->let_wrappers= cdr (sc->let_wrappers); - return (wrapped_let); + let_set_id(wrapped_let, ++sc->let_number); + let_set_slots(wrapped_let, slot_end); + let_set_outlet(wrapped_let, old_let); + sc->let_wrappers = cdr(sc->let_wrappers); + return(wrapped_let); } -static s7_pointer -wrap_slot (s7_scheme* sc, s7_pointer symbol, s7_pointer value) { - s7_pointer wrapped_slot= car (sc->slot_wrappers); +static s7_pointer wrap_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer value) +{ + s7_pointer wrapped_slot = car(sc->slot_wrappers); #if S7_DEBUGGING - if ((full_type (wrapped_slot) & (~T_GC_MARK)) != (T_SLOT | T_UNHEAP)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, wrapped_slot)); + if ((full_type(wrapped_slot) & (~T_GC_MARK)) != (T_SLOT | T_UNHEAP)) + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, wrapped_slot)); sc->slot_wrapper_allocs++; #endif - slot_set_symbol_and_value (wrapped_slot, symbol, value); - sc->slot_wrappers= cdr (sc->slot_wrappers); - return (wrapped_slot); + slot_set_symbol_and_value(wrapped_slot, symbol, value); + sc->slot_wrappers = cdr(sc->slot_wrappers); + return(wrapped_slot); } /* -------- prebuilt lists -------- */ -s7_pointer -set_elist_1 (s7_scheme* sc, s7_pointer x1) { - set_car (sc->elist_1, x1); - return (sc->elist_1); -} - -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); -} - -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); -} - -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); +s7_pointer set_elist_1(s7_scheme *sc, s7_pointer x1) +{ + set_car(sc->elist_1, x1); + return(sc->elist_1); } -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); +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_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); +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_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); +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_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); +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_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_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); } -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_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); } -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 */ +static s7_pointer set_wlist_3(s7_pointer lst, s7_pointer x1, s7_pointer x2, s7_pointer x3) { - set_car (sc->mlist_2, x1); - set_cadr (sc->mlist_2, x2); - return (sc->mlist_2); + s7_pointer p = lst; + set_car(p, x1); p = cdr(p); + set_car(p, x2); p = cdr(p); + set_car(p, x3); + return(lst); } -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_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); } -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); +s7_pointer set_mlist_1(s7_scheme *sc, s7_pointer x1) +{ + set_car(sc->mlist_1, x1); + return(sc->mlist_1); } -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)); +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_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)); +s7_pointer set_plist_1(s7_scheme *sc, s7_pointer x1) +{ + set_car(sc->plist_1, x1); + return(sc->plist_1); } -s7_pointer -set_qlist_2 (s7_scheme* sc, s7_pointer x1, s7_pointer x2) /* let_ref_fallback */ +s7_pointer set_plist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) { - set_car (sc->qlist_2, x1); - set_cadr (sc->qlist_2, x2); - return (sc->qlist_2); + set_car(sc->plist_2, x1); + set_car(sc->plist_2_2, x2); + return(sc->plist_2); } -s7_pointer -set_qlist_3 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, - s7_pointer x3) /* let_set_fallback */ +s7_pointer set_plist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) { - return (set_wlist_3 (sc->qlist_3, x1, x2, x3)); + return(set_wlist_3(sc->plist_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 */ +static s7_pointer set_plist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4) { - set_car (sc->clist_1, x1); - return (sc->clist_1); + return(set_wlist_4(sc->plist_4, x1, x2, x3, x4)); } -static s7_pointer -set_clist_2 (s7_scheme* sc, s7_pointer x1, - s7_pointer x2) /* for c_object equal method etc, a "weak" list */ +s7_pointer set_qlist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) /* let_ref_fallback */ { - set_car (sc->clist_2, x1); - set_cadr (sc->clist_2, x2); - return (sc->clist_2); + set_car(sc->qlist_2, x1); + set_cadr(sc->qlist_2, x2); + return(sc->qlist_2); } -s7_pointer -set_dlist_1 (s7_scheme* sc, - s7_pointer x1) /* another like clist: temp usage, "weak" (not - gc_marked), but semipermanent list */ +s7_pointer set_qlist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) /* let_set_fallback */ { - set_car (sc->dlist_1, x1); - return (sc->dlist_1); + return(set_wlist_3(sc->qlist_3, x1, x2, x3)); } -s7_pointer -set_ulist_1 (s7_scheme* sc, s7_pointer x1, s7_pointer x2) { - set_car (sc->u1_1, x1); - set_cdr_unchecked (sc->u1_1, x2); - return (sc->u1_1); +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); } -/* ---------------- 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_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 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); } -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 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); } -s7_pointer -s7_function_let (s7_scheme* sc, s7_pointer obj) { - return (c_function_let (obj)); +s7_pointer set_ulist_1(s7_scheme *sc, s7_pointer x1, s7_pointer x2) +{ + set_car(sc->u1_1, x1); + set_cdr_unchecked(sc->u1_1, x2); + return(sc->u1_1); } -static inline s7_pointer lookup_slot_from (s7_pointer symbol, s7_pointer let); -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)); -} - -s7_pointer -s7i_find_method_with_let (s7_scheme* sc, s7_pointer obj, s7_pointer method) { - return (find_method_with_let (sc, obj, method)); -} - -bool -s7i_has_active_methods (s7_scheme* sc, s7_pointer obj) { - return (has_active_methods (sc, obj)); -} - -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)); -} - -const char* -type_name (s7_scheme* sc, s7_pointer arg, article_t article) { - switch (type_unchecked (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 (type_unchecked (arg), article); - if (str) return (str); - } - } - return ("messed up object"); +/* ---------------- 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); } -s7_pointer -object_type_name (s7_scheme* sc, - s7_pointer obj) /* used only by the error handlers */ +static const char *type_name_from_type(int32_t typ, article_t article) { - 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)); + /* 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_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); +} + +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); } -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))); -} - -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); -} - -/* 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); -} - -void -s7i_wrong_type_error_nr (s7_scheme* sc, s7_pointer caller, s7_int arg_num, - s7_pointer arg, s7_pointer typ) { - wrong_type_error_nr (sc, caller, arg_num, arg, typ); -} - -void -sole_arg_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->type_error_symbol, sc->sole_arg_wrong_type_info); -} - -/* Inline */ no_return void -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); - 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->type_error_symbol, sc->wrong_type_arg_info); -} - -s7_pointer -s7_type_error (s7_scheme* sc, const char* caller, s7_int arg_n, s7_pointer arg, - const char* descr) { - if (arg_n > 0) - type_error_nr (sc, wrap_string (sc, caller, safe_strlen (caller)), arg_n, - arg, wrap_string (sc, descr, safe_strlen (descr))); - sole_arg_type_error_nr (sc, wrap_string (sc, caller, safe_strlen (caller)), - arg, wrap_string (sc, descr, safe_strlen (descr))); - return (sc->type_error_symbol); -} +s7_pointer s7_function_let(s7_scheme *sc, s7_pointer obj) {return(c_function_let(obj));} -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); -} - -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 inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer let); -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 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); } -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 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)); } -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)); +s7_pointer s7i_find_method_with_let(s7_scheme *sc, s7_pointer obj, s7_pointer method) +{ + return(find_method_with_let(sc, obj, method)); } -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)); +bool s7i_has_active_methods(s7_scheme *sc, s7_pointer obj) +{ + return(has_active_methods(sc, 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 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)); } -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); +const char *type_name(s7_scheme *sc, s7_pointer arg, article_t article) +{ + switch (type_unchecked(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(type_unchecked(arg), article); + if (str) return(str); + }} + return("messed up object"); } -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))); +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)); } -void -immutable_object_error_nr (s7_scheme* sc, s7_pointer info) { - error_nr (sc, sc->immutable_error_symbol, info); +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))); } -/* -------- 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) */ +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); } -s7_pointer -s7i_apply_boolean_method (s7_scheme* sc, s7_pointer obj, s7_pointer method) { - return apply_boolean_method (sc, obj, method); +/* 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); } -/* 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)); \ - } +void s7i_wrong_type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int arg_num, s7_pointer arg, s7_pointer typ) +{ + wrong_type_error_nr(sc, caller, arg_num, arg, typ); +} -static s7_pointer apply_method_closure (s7_scheme* sc, s7_pointer func, - s7_pointer args); +void sole_arg_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->type_error_symbol, sc->sole_arg_wrong_type_info); +} -s7_pointer -find_and_apply_method (s7_scheme* sc, s7_pointer obj, s7_pointer sym, - s7_pointer args) /* slower if inline */ +/* Inline */ no_return void type_error_nr(s7_scheme *sc, s7_pointer caller, s7_int arg_num, s7_pointer arg, s7_pointer typ) { - s7_pointer func= find_method_with_let ( - sc, obj, - sym); /* perhaps find_and_apply_c_object_method for g_c_object_let */ - /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(args)); */ - 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)); -} - -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)); -} - -s7_pointer -s7i_method_or_bust (s7_scheme* sc, s7_pointer obj, const char* method_name, - s7_pointer args, const char* type_name, s7_int arg_pos) { - return (method_or_bust (sc, obj, s7_make_symbol (sc, method_name), args, - wrap_string (sc, type_name, safe_strlen (type_name)), - (int32_t) arg_pos)); -} - -bool -s7i_method_or_bust_bool (s7_scheme* sc, s7_pointer obj, const char* method_name, - s7_pointer args, const char* type_name, - s7_int arg_pos) { - return (s7i_method_or_bust (sc, obj, method_name, args, type_name, arg_pos) != - sc->F); -} - -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 */ -} - -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))); -} - -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 -methods_or_bust_pp (s7_scheme* sc, s7_pointer obj, s7_pointer method1, - s7_pointer method2, s7_pointer x1, s7_pointer x2, - s7_pointer typ, - int32_t num) { /* this is for the memq/memv and assq/assv - equivalence in r7rs */ - s7_pointer func; - if (!has_active_methods (sc, obj)) - wrong_type_error_nr (sc, method1, num, obj, typ); - func= find_method_with_let (sc, obj, method1); - if (func == sc->undefined) func= find_method_with_let (sc, obj, method2); - if (func == sc->undefined) missing_method_error_nr (sc, method1, obj); - return (s7_apply_function (sc, func, 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)); -} - -s7_pointer -s7i_sole_arg_method_or_bust (s7_scheme* sc, s7_pointer obj, - const char* method_name, s7_pointer args, - const char* type_name) { - return (sole_arg_method_or_bust ( - sc, obj, s7_make_symbol (sc, method_name), args, - wrap_string (sc, type_name, safe_strlen (type_name)))); -} - -bool -s7i_sole_arg_method_or_bust_bool (s7_scheme* sc, s7_pointer obj, - const char* method_name, s7_pointer args, - const char* type_name) { - return s7i_sole_arg_method_or_bust (sc, obj, method_name, args, type_name) != - sc->F; -} - -static s7_pointer -vector_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)) type_error_nr (sc, method, num, obj, typ); - return (find_and_apply_method (sc, obj, method, args)); -} - -s7_pointer -s7i_vector_method_or_bust (s7_scheme* sc, s7_pointer obj, - const char* method_name, s7_pointer args, - const char* type_name, s7_int arg_pos) { - return (vector_method_or_bust ( - sc, obj, s7_make_symbol (sc, method_name), args, - wrap_string (sc, type_name, safe_strlen (type_name)), (int32_t) arg_pos)); -} - -static s7_pointer -vector_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_type_error_nr (sc, method, obj, typ); - return (find_and_apply_method (sc, obj, method, args)); -} - -s7_pointer -s7i_vector_sole_arg_method_or_bust (s7_scheme* sc, s7_pointer obj, - const char* method_name, s7_pointer args, - const char* type_name) { - return (vector_sole_arg_method_or_bust ( - sc, obj, s7_make_symbol (sc, method_name), args, - wrap_string (sc, type_name, safe_strlen (type_name)))); -} - -static s7_pointer -vector_method_or_bust_p (s7_scheme* sc, s7_pointer obj, s7_pointer method, - s7_pointer typ) { - if (!has_active_methods (sc, obj)) - sole_arg_type_error_nr (sc, method, obj, typ); - return (find_and_apply_method (sc, obj, method, set_mlist_1 (sc, obj))); -} - -s7_pointer -s7i_vector_method_or_bust_p (s7_scheme* sc, s7_pointer obj, - const char* method_name, const char* type_name) { - return (vector_method_or_bust_p ( - sc, obj, s7_make_symbol (sc, method_name), - wrap_string (sc, type_name, safe_strlen (type_name)))); -} - -static s7_pointer -vector_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)) 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 -vector_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)) type_error_nr (sc, method, num, obj, typ); - return ( - find_and_apply_method (sc, obj, method, set_qlist_3 (sc, x1, x2, x3))); -} + s7_pointer p = cdr(sc->wrong_type_arg_info); + 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->type_error_symbol, sc->wrong_type_arg_info); +} -s7_double -s7i_default_rationalize_error (s7_scheme* sc) { - return (sc->default_rationalize_error); +s7_pointer s7_type_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr) +{ + if (arg_n > 0) + type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), arg_n, arg, wrap_string(sc, descr, safe_strlen(descr))); + sole_arg_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), arg, wrap_string(sc, descr, safe_strlen(descr))); + return(sc->type_error_symbol); } -/* -------------------------------- constants -------------------------------- - */ -/* #f and #t */ -s7_pointer -s7_f (s7_scheme* sc) { - return (sc->F); +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_t (s7_scheme* sc) { - return (sc->T); + +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 */ } -/* () */ -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)); -} -bool -is_null_b_p (s7_pointer p) { - return (type (p) == T_NIL); -} /* faster than b_7p because opt_b_p is faster */ +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); +} -#define H_is_null "(null? obj) returns #t if obj is the empty list" -#define Q_is_null sc->pl_bt -/* g_is_null is now defined in s7_liii_list.c */ +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); +} -/* # and # */ -s7_pointer -s7_undefined (s7_scheme* sc) { - return (sc->undefined); +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); } -s7_pointer -s7_unspecified (s7_scheme* sc) { - return (sc->unspecified); + +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)); } -bool -s7_is_unspecified (s7_scheme* sc, s7_pointer val) { - return (is_unspecified (val)); +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); } -/* g_is_undefined is now defined in s7_scheme_predicate.c */ -#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 -/* g_is_unspecified is now defined in s7_scheme_predicate.c */ -#define H_is_unspecified \ - "(unspecified? val) returns #t if val is #" -#define Q_is_unspecified sc->pl_bt +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)); +} -/* -------------------------------- eof-object? -------------------------------- - */ -s7_pointer eof_object= - NULL; /* # is an entry in the chars array, so it's not a part of sc */ +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)); +} -s7_pointer -s7_eof_object (s7_scheme* sc) { - return (eof_object); +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)); } -/* g_is_eof_object is now defined in s7_scheme_predicate.c */ -#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 +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 bool -is_eof_object_b_p (s7_pointer p) { - return (p == eof_object); +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); } -/* -------------------------------- not -------------------------------- */ -static bool -not_b_7p (s7_scheme* sc, s7_pointer p) { - return (p == sc->F); +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))); } -/* g_not is now defined in s7_scheme_predicate.c */ -#define H_not "(not obj) returns #t if obj is #f, otherwise #f: (not ()) -> #f" -#define Q_not sc->pl_bt +void immutable_object_error_nr(s7_scheme *sc, s7_pointer info) {error_nr(sc, sc->immutable_error_symbol, info);} -/* -------------------------------- 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); +/* -------- 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); } -/* g_is_boolean is now defined in s7_scheme_predicate.c */ -#define H_is_boolean \ - "(boolean? obj) returns #t if obj is #f or #t: (boolean? ()) -> #f" -#define Q_is_boolean sc->pl_bt +/* 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)); \ + } -/* -------------------------------- constant? -------------------------------- - */ -extern 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))); +#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)); \ } - return (false); -} -#define is_constant(sc, p) \ - ((type (p) != T_SYMBOL) || (is_constant_symbol (sc, p))) +#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)); \ + } -/* g_is_constant is now defined in s7_scheme_predicate.c */ -#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 - -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))); +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) */ } -/* -------------------------------- immutable? -------------------------------- - */ +s7_pointer s7i_apply_boolean_method(s7_scheme *sc, s7_pointer obj, s7_pointer method) +{ + return apply_boolean_method(sc, obj, method); +} -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 let= cadr (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->is_immutable_symbol, let, new_let, 2, - args); - let= new_let; - } - if (let == sc->rootlet) slot= global_slot (obj); - else - slot= lookup_slot_from ((is_keyword (obj)) ? keyword_symbol (obj) : obj, - let); - } - else slot= s7_slot (sc, obj); - if (is_slot (slot)) /* might be # */ - return (make_boolean (sc, is_immutable_slot (slot))); +/* 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)); \ } - 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)))); + +static s7_pointer apply_method_closure(s7_scheme *sc, s7_pointer func, s7_pointer args); + +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 */ + /* fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(args)); */ + 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)); } -/* -------------------------------- immutable! -------------------------------- - */ -s7_pointer -s7_set_immutable (s7_scheme* sc, s7_pointer obj) { - if (is_symbol (obj)) /* trying to mimic g_immutable */ - { - s7_pointer slot; - if (is_keyword (obj)) return (obj); - slot= s7_slot (sc, obj); - if (is_slot (slot)) set_immutable_slot (slot); - /* symbol is not set immutable (as below) */ - } - else set_immutable (obj); - return (obj); +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)); } -#if (!DISABLE_DEPRECATED) && (S7_DEBUGGING || DISABLE_FILE_OUTPUT || POINTER_32) -s7_pointer -s7_immutable (s7_pointer obj) { - return (s7_set_immutable (cur_sc, obj)); +s7_pointer s7i_method_or_bust(s7_scheme *sc, s7_pointer obj, const char *method_name, + s7_pointer args, const char *type_name, s7_int arg_pos) +{ + return(method_or_bust(sc, obj, + s7_make_symbol(sc, method_name), + args, + wrap_string(sc, type_name, safe_strlen(type_name)), + (int32_t)arg_pos)); } -#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 let= cadr (args); - if ((!is_let (let)) || (let == sc->rootlet)) { - s7_pointer new_let= find_let (sc, let); - if ((!is_let (new_let)) || (new_let == sc->rootlet)) - find_let_error_nr (sc, sc->immutable_symbol, let, new_let, 2, args); - let= new_let; - } - slot= symbol_to_local_slot ( - sc, (is_keyword (obj)) ? keyword_symbol (obj) : obj, - let); /* 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), but this error could be - better (find_let etc) */ - wrong_type_error_nr (sc, sc->immutable_symbol, 2, cadr (args), - a_let_string); - set_immutable (obj); - return (obj); +bool s7i_method_or_bust_bool(s7_scheme *sc, s7_pointer obj, const char *method_name, + s7_pointer args, const char *type_name, s7_int arg_pos) +{ + return(s7i_method_or_bust(sc, obj, method_name, args, type_name, arg_pos) != sc->F); } -/* there's no way to make a slot setter (as setter) immutable (t_multiform as - * bit) */ +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); +} -/* -------------------------------- 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. - */ +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 */ +} -#if S7_DEBUGGING -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 (sc->stop_at_error) abort (); - } - return (loc); +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))); } -#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* old_b = vector_block (sc->protected_objects); - const s7_int new_size= 2 * size; - block_t* new_b = reallocate (sc, old_b, new_size * sizeof (s7_pointer)); - block_info (new_b) = NULL; - vector_block (sc->protected_objects) = new_b; - vector_elements (sc->protected_objects)= (s7_pointer*) block_data (new_b); - 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_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))); } -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; - } +static s7_pointer methods_or_bust_pp(s7_scheme *sc, s7_pointer obj, s7_pointer method1, s7_pointer method2, s7_pointer x1, s7_pointer x2, s7_pointer typ, int32_t num) +{ /* this is for the memq/memv and assq/assv equivalence in r7rs */ + s7_pointer func; + if (!has_active_methods(sc, obj)) wrong_type_error_nr(sc, method1, num, obj, typ); + func = find_method_with_let(sc, obj, method1); + if (func == sc->undefined) func = find_method_with_let(sc, obj, method2); + if (func == sc->undefined) missing_method_error_nr(sc, method1, obj); + return(s7_apply_function(sc, func, set_mlist_2(sc, x1, x2))); } -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); +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 */ } -#define gc_protected_at(Sc, Loc) vector_element (Sc->protected_objects, Loc) +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))); +} -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); +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)); } -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); +s7_pointer s7i_sole_arg_method_or_bust(s7_scheme *sc, s7_pointer obj, const char *method_name, s7_pointer args, const char *type_name) +{ + return(sole_arg_method_or_bust(sc, obj, s7_make_symbol(sc, method_name), args, wrap_string(sc, type_name, safe_strlen(type_name)))); } -/* 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[type_unchecked (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 (type_unchecked (seq) == T_HASH_TABLE) weak_hash_iters (seq)--; - } +bool s7i_sole_arg_method_or_bust_bool(s7_scheme *sc, s7_pointer obj, const char *method_name, s7_pointer args, const char *type_name) +{ + return s7i_sole_arg_method_or_bust(sc, obj, method_name, args, type_name) != sc->F; } -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 s7_pointer vector_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)) type_error_nr(sc, method, num, obj, typ); + return(find_and_apply_method(sc, obj, method, args)); } -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)); +s7_pointer s7i_vector_method_or_bust(s7_scheme *sc, s7_pointer obj, const char *method_name, + s7_pointer args, const char *type_name, s7_int arg_pos) +{ + return(vector_method_or_bust(sc, obj, + s7_make_symbol(sc, method_name), + args, + wrap_string(sc, type_name, safe_strlen(type_name)), + (int32_t)arg_pos)); } -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 s7_pointer vector_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_type_error_nr(sc, method, obj, typ); + return(find_and_apply_method(sc, obj, method, args)); } -static void close_input_function_port (s7_scheme* sc, s7_pointer port); -static void close_output_port (s7_scheme* sc, s7_pointer port); +s7_pointer s7i_vector_sole_arg_method_or_bust(s7_scheme *sc, s7_pointer obj, const char *method_name, s7_pointer args, const char *type_name) +{ + return(vector_sole_arg_method_or_bust(sc, obj, s7_make_symbol(sc, method_name), args, wrap_string(sc, type_name, safe_strlen(type_name)))); +} -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); +static s7_pointer vector_method_or_bust_p(s7_scheme *sc, s7_pointer obj, s7_pointer method, s7_pointer typ) +{ + if (!has_active_methods(sc, obj)) sole_arg_type_error_nr(sc, method, obj, typ); + return(find_and_apply_method(sc, obj, method, set_mlist_1(sc, obj))); +} - if (port_filename (port)) { - liberate (sc, port_filename_block (port)); - port_filename (port)= NULL; - } - liberate (sc, port_block (port)); +s7_pointer s7i_vector_method_or_bust_p(s7_scheme *sc, s7_pointer obj, const char *method_name, const char *type_name) +{ + return(vector_method_or_bust_p(sc, obj, s7_make_symbol(sc, method_name), wrap_string(sc, type_name, safe_strlen(type_name)))); } -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 s7_pointer vector_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)) type_error_nr(sc, method, num, obj, typ); + return(find_and_apply_method(sc, obj, method, set_mlist_2(sc, x1, x2))); } -#define s7_integer_clamped_if_gmp(Sc, P) integer (P) +static s7_pointer vector_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)) type_error_nr(sc, method, num, obj, typ); + return(find_and_apply_method(sc, obj, method, set_qlist_3(sc, x1, x2, x3))); +} -void process_continuation (s7_scheme* sc, s7_pointer cc); -void mark_continuation (s7_pointer cc); +s7_double s7i_default_rationalize_error(s7_scheme *sc) {return(sc->default_rationalize_error);} -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); +/* -------------------------------- constants -------------------------------- */ +/* #f and #t */ +s7_pointer s7_f(s7_scheme *sc) {return(sc->F);} +s7_pointer s7_t(s7_scheme *sc) {return(sc->T);} -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 gc_obj= gp->list[i]; \ - if (is_free_and_clear (gc_obj)) { \ - Code; /* may access gc_obj internally */ \ - } \ - else if (in_heap (gc_obj)) gp->list[j++]= gc_obj; \ - } \ - gp->loc= j; \ - } +/* () */ +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));} +bool is_null_b_p(s7_pointer p) {return(type(p) == T_NIL);} /* faster than b_7p because opt_b_p is faster */ - gp= sc->strings; - process_gc_list (liberate (sc, string_block (gc_obj))); - - gp= sc->gensyms; - process_gc_list (remove_gensym_from_symbol_table (sc, gc_obj); - liberate (sc, gensym_block (gc_obj))); - if (gp->loc == 0) mark_function[T_SYMBOL]= mark_noop; - - gp= sc->undefineds; - process_gc_list (free (undefined_name (gc_obj))); - - gp= sc->c_objects; - process_gc_list ( - if (c_object_gc_free (sc, gc_obj)) (*(c_object_gc_free (sc, gc_obj))) ( - sc, gc_obj); - else (*(c_object_free (sc, gc_obj))) (c_object_value (gc_obj))); - - gp= sc->vectors; - process_gc_list (liberate (sc, vector_block (gc_obj))); - - gp= sc->multivectors; - process_gc_list (process_multivector (sc, gc_obj)); - - gp= sc->hash_tables; - if (gp->loc > 0) { - for (i= 0, j= 0; i < gp->loc; i++) { - s7_pointer gc_obj= gp->list[i]; - if (is_free_and_clear (gc_obj)) free_hash_table (sc, gc_obj); - else { - if ((is_weak_hash_table (gc_obj)) && (weak_hash_iters (gc_obj) == 0) && - (hash_table_entries (gc_obj) > 0)) - cull_weak_hash_table (sc, gc_obj); - gp->list[j++]= gc_obj; - } - } - gp->loc= j; - } +#define H_is_null "(null? obj) returns #t if obj is the empty list" +#define Q_is_null sc->pl_bt +/* g_is_null is now defined in s7_liii_list.c */ - gp= sc->weak_hash_iterators; - process_gc_list (process_iterator (sc, gc_obj)); - gp= sc->opt1_funcs; - if (gp->loc > 0) { - for (i= 0, j= 0; i < gp->loc; i++) { - s7_pointer gc_obj= gp->list[i]; - if (!is_free_and_clear (gc_obj)) gp->list[j++]= gc_obj; - } - gp->loc= j; - } +/* # and # */ +s7_pointer s7_undefined(s7_scheme *sc) {return(sc->undefined);} +s7_pointer s7_unspecified(s7_scheme *sc) {return(sc->unspecified);} - gp= sc->input_ports; - process_gc_list (process_input_port (sc, gc_obj)); - - gp= sc->input_string_ports; - process_gc_list (process_input_string_port (sc, gc_obj)); - - gp= sc->output_ports; - process_gc_list (process_output_port (sc, gc_obj)); - - gp= sc->continuations; - process_gc_list (process_continuation (sc, gc_obj)); - - gp= sc->weak_refs; - if (gp->loc > 0) { - for (i= 0, j= 0; i < gp->loc; i++) { - s7_pointer gc_obj= gp->list[i]; - if (!is_free_and_clear (gc_obj)) { - if (is_free_and_clear (c_pointer_weak1 (gc_obj))) - c_pointer_weak1 (gc_obj)= sc->F; - if (is_free_and_clear (c_pointer_weak2 (gc_obj))) - c_pointer_weak2 (gc_obj)= sc->F; - if ((c_pointer_weak1 (gc_obj) != sc->F) || - (c_pointer_weak2 (gc_obj) != sc->F)) - gp->list[j++]= gc_obj; - } - } - gp->loc= j; - } -} +bool s7_is_unspecified(s7_scheme *sc, s7_pointer val) {return(is_unspecified(val));} -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; -} +/* g_is_undefined is now defined in s7_scheme_predicate.c */ + #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 -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); -} - -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_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 */ - -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 (); +/* g_is_unspecified is now defined in s7_scheme_predicate.c */ +#define H_is_unspecified "(unspecified? val) returns #t if val is #" +#define Q_is_unspecified sc->pl_bt - /* 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); +/* -------------------------------- eof-object? -------------------------------- */ +s7_pointer eof_object = NULL; /* # is an entry in the chars array, so it's not a part of sc */ -static void -add_setter (s7_scheme* sc, s7_pointer func, 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) == func) { - set_cdr_unchecked ( - 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, func, T_Prc (setter), T_PAIR | T_IMMUTABLE); -} +s7_pointer s7_eof_object(s7_scheme *sc) {return(eof_object);} -static inline void -gc_mark (s7_pointer p) { - if (!is_marked (p)) (*mark_function[type_unchecked (p)]) (p); -} +/* g_is_eof_object is now defined in s7_scheme_predicate.c */ + #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 -static void -mark_symbol_vector (s7_pointer vec, s7_int len) { - set_mark (vec); - if (mark_function[T_SYMBOL] != mark_noop) /* else no gensyms */ - { - s7_pointer* els= vector_elements (vec); - for (s7_int i= 0; i < len; i++) - if ((is_symbol (els[i])) && - (is_gensym ( - els[i]))) /* need is_symbol: make-vector + set! vector-typer - symbol? where init is not a symbol */ - set_mark (els[i]); - } -} +static bool is_eof_object_b_p(s7_pointer p) {return(p == eof_object);} -static void -mark_simple_vector (s7_pointer vec, s7_int len) { - s7_pointer* vels= vector_elements (vec); - set_mark (vec); - for (s7_int i= 0; i < len; i++) - set_mark (vels[i]); -} -static void -just_mark_vector (s7_pointer vect, s7_int unused_len) { - set_mark (vect); -} +/* -------------------------------- not -------------------------------- */ +static bool not_b_7p(s7_scheme *sc, s7_pointer p) {return(p == sc->F);} -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 (; (let) && (!is_marked (let)); let= let_outlet (let)) { - set_mark (let); - if (has_dox_slot1 (let)) mark_slot (let_dox_slot1 (let)); - if ((has_dox_slot2 (let)) && (is_slot (let_dox_slot2 (let)))) - mark_slot (let_dox_slot2 (let)); - /* 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 (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (!is_marked (slot)) /* slot value might be the enclosing let */ - mark_slot (slot); - } -} +/* g_not is now defined in s7_scheme_predicate.c */ + #define H_not "(not obj) returns #t if obj is #f, otherwise #f: (not ()) -> #f" + #define Q_not sc->pl_bt -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)); is_not_slot_end (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 */ -} +/* -------------------------------- 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));} -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)); is_not_slot_end (slot); - slot = next_slot (slot)) - clear_mark (slot); - p= cdr (p); - } while (p != end_p); -} +bool s7_is_boolean(s7_pointer x) {return(type(x) == T_BOOLEAN);} -#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[type_unchecked (tp)]) (tp); -} -#endif +/* g_is_boolean is now defined in s7_scheme_predicate.c */ + #define H_is_boolean "(boolean? obj) returns #t if obj is #f or #t: (boolean? ()) -> #f" + #define Q_is_boolean sc->pl_bt -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 */ + +/* -------------------------------- constant? -------------------------------- */ +extern 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))); } - } -#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)); + return(false); } -static void -mark_c_pointer (s7_pointer cp) { - set_mark (cp); - gc_mark (c_pointer_type (cp)); - gc_mark (c_pointer_info (cp)); -} +#define is_constant(sc, p) ((type(p) != T_SYMBOL) || (is_constant_symbol(sc, p))) -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)); -} +/* g_is_constant is now defined in s7_scheme_predicate.c */ + #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 -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 ctr) { - set_mark (ctr); - gc_mark (counter_result (ctr)); - gc_mark (counter_list (ctr)); - gc_mark (counter_let (ctr)); -} - -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)); -} - -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 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)));} -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_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)); +/* -------------------------------- immutable? -------------------------------- */ + +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)); } -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)); +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) - /* 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 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 let = cadr(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->is_immutable_symbol, let, new_let, 2, args); + let = new_let; + } + if (let == sc->rootlet) + slot = global_slot(obj); + else slot = lookup_slot_from((is_keyword(obj)) ? keyword_symbol(obj) : obj, let); + } + 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)))); } -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 */ +/* -------------------------------- immutable! -------------------------------- */ +s7_pointer s7_set_immutable(s7_scheme *sc, s7_pointer obj) { - if (is_subvector (vect)) - mark_int_or_float_vector_possibly_shared (subvector_vector (vect)); - set_mark (vect); + if (is_symbol(obj)) /* trying to mimic g_immutable */ + { + s7_pointer slot; + if (is_keyword(obj)) return(obj); + slot = s7_slot(sc, obj); + if (is_slot(slot)) + set_immutable_slot(slot); + /* symbol is not set immutable (as below) */ + } + else set_immutable(obj); + return(obj); } -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)); -} +#if (!DISABLE_DEPRECATED) && (S7_DEBUGGING || DISABLE_FILE_OUTPUT || POINTER_32) + s7_pointer s7_immutable(s7_pointer obj) {return(s7_set_immutable(cur_sc, obj));} +#endif -static void -mark_catch (s7_pointer catcher) /* C++ reserves "catch" */ +static s7_pointer g_immutable(s7_scheme *sc, s7_pointer args) { - set_mark (catcher); - gc_mark (catch_tag (catcher)); - gc_mark (catch_handler (catcher)); -} + #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)) -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)); + const s7_pointer obj = car(args); + if (is_symbol(obj)) + { + s7_pointer slot; + if (is_pair(cdr(args))) + { + s7_pointer let = cadr(args); + if ((!is_let(let)) || (let == sc->rootlet)) + { + s7_pointer new_let = find_let(sc, let); + if ((!is_let(new_let)) || (new_let == sc->rootlet)) + find_let_error_nr(sc, sc->immutable_symbol, let, new_let, 2, args); + let = new_let; + } + slot = symbol_to_local_slot(sc, (is_keyword(obj)) ? keyword_symbol(obj) : obj, let); /* 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), but this error could be better (find_let etc) */ + wrong_type_error_nr(sc, sc->immutable_symbol, 2, cadr(args), a_let_string); + set_immutable(obj); + return(obj); } -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* entry; - for (entry= *entries++; entry; entry= hash_entry_next (entry)) - gc_mark (hash_entry_value (entry)); - for (entry= *entries++; entry; entry= hash_entry_next (entry)) - gc_mark (hash_entry_value (entry)); - } - else - while (entries < last) /* counting entries here was slightly faster */ - { - hash_entry_t* entry; - for (entry= *entries++; entry; entry= hash_entry_next (entry)) { - gc_mark (hash_entry_key (entry)); - gc_mark (hash_entry_value (entry)); - } - for (entry= *entries++; entry; entry= hash_entry_next (entry)) { - gc_mark (hash_entry_key (entry)); - gc_mark (hash_entry_value (entry)); - } - } - } -} +/* 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. + */ -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); +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 (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 *old_b = vector_block(sc->protected_objects); + const s7_int new_size = 2 * size; + block_t *new_b = reallocate(sc, old_b, new_size * sizeof(s7_pointer)); + block_info(new_b) = NULL; + vector_block(sc->protected_objects) = new_b; + vector_elements(sc->protected_objects) = (s7_pointer *)block_data(new_b); + 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; + } } -static void -mark_input_port (s7_pointer port) { - set_mark (port); - gc_mark (port_string_or_function (port)); +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); } -static void -mark_output_port (s7_pointer port) { - set_mark (port); - if (is_function_port (port)) gc_mark (port_string_or_function (port)); +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; + } } -static void -mark_free (s7_pointer p) { - if (S7_DEBUGGING) { - fprintf (stderr, "mark_free!\n"); - abort (); - } -} /* set_mark also checks */ - -static void -init_mark_functions (void) { - mark_function[T_BACRO] = mark_closure; - mark_function[T_BACRO_STAR] = mark_closure; - 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; is_not_slot_end (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). - */ +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); } -/* 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? - */ +#define gc_protected_at(Sc, Loc) vector_element(Sc->protected_objects, Loc) -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 - */ +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); } -/* 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) { - for (gc_obj_t* g= sc->semipermanent_objects; g; g= (gc_obj_t*) (g->nxt)) - clear_mark (g->p); - for (gc_obj_t* g= sc->semipermanent_lets; g; - g= (gc_obj_t*) (g->nxt)) /* there are lets and slots in this list */ - clear_mark (g->p); +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); } -#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 +/* 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[type_unchecked(p)])(p);} +static void mark_noop(s7_pointer unused_p) {} -#if S7_DEBUGGING -s7_int -gc (s7_scheme* sc, const char* func, int32_t line) -#else -s7_int -gc (s7_scheme* sc) -#endif +static void process_iterator(s7_scheme *unused_sc, s7_pointer iter) { - s7_cell** old_free_heap_top; + if (is_weak_hash_iterator(iter)) + { + s7_pointer seq = iterator_sequence(iter); + clear_weak_hash_iterator(iter); + if (type_unchecked(seq) == T_HASH_TABLE) + weak_hash_iters(seq)--; + } +} - 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++; +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)); +} - 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]); - } +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)); +} - { - gc_list_t* gp= sc->opt1_funcs; - for (s7_int i= 0; i < gp->loc; i++) { - s7_pointer gc_obj= T_Pair (gp->list[i]); - if ((is_marked (gc_obj)) && - (!is_marked (opt1_any (gc_obj)))) /* opt1_lambda, but op_unknown* can - change to opt1_cfunc etc */ - gc_mark (opt1_any (gc_obj)); /* not set_mark -- need to protect - let/body/args as well */ +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; } - } - - /* 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); + port_needs_free(port) = false; +} -#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* str; \ - fprintf (stderr, "odd bits: %s\n", str= describe_type_bits (sc, p)); \ - free (str); \ - } \ - if (!in_heap (p)) { \ - char* str; \ - fprintf (stderr, "not in heap: %s\n", str= describe_type_bits (sc, p)); \ - free (str); \ - } \ - 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; /* gc_object defined above needs this pointer */ - 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); - } +static void close_input_function_port(s7_scheme *sc, s7_pointer port); +static void close_output_port(s7_scheme *sc, s7_pointer port); - unmark_semipermanent_objects (sc); - unmark_wrappers (sc); +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); - 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 (port_filename(port)) + { + liberate(sc, port_filename_block(port)); + port_filename(port) = NULL; + } + liberate(sc, port_block(port)); +} - 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); +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; + }} } -#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 s7_integer_clamped_if_gmp(Sc, P) integer(P) -#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 - */ +void process_continuation(s7_scheme *sc, s7_pointer cc); +void mark_continuation(s7_pointer cc); -#if S7_DEBUGGING -#define resize_heap_to(Sc, Size) resize_heap_to_1 (Sc, Size, __func__, __LINE__) -void -resize_heap_to_1 (s7_scheme* sc, s7_int size, const char* func, int line) -#else -void -resize_heap_to (s7_scheme* sc, s7_int size) -#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) { - const s7_int old_size= sc->heap_size; - const s7_int old_free= sc->free_heap_top - sc->free_heap; + 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 gc_obj = gp->list[i]; \ + if (is_free_and_clear(gc_obj)) \ + { \ + Code; /* may access gc_obj internally */ \ + } \ + else if (in_heap(gc_obj)) gp->list[j++] = gc_obj; \ + } \ + gp->loc = j; \ + } \ -#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 + gp = sc->strings; + process_gc_list(liberate(sc, string_block(gc_obj))); - 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; - } - } + gp = sc->gensyms; + process_gc_list(remove_gensym_from_symbol_table(sc, gc_obj); liberate(sc, gensym_block(gc_obj))); + if (gp->loc == 0) mark_function[T_SYMBOL] = mark_noop; - /* 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: %" ld64 "\n", - sc->heap_size, - (2 * sc->heap_size * sizeof (s7_cell*)) + - ((sc->heap_size - old_size) * sizeof (s7_cell)), - (s7_int) 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? */ + gp = sc->undefineds; + process_gc_list(free(undefined_name(gc_obj))); + + gp = sc->c_objects; + process_gc_list(if (c_object_gc_free(sc, gc_obj)) (*(c_object_gc_free(sc, gc_obj)))(sc, gc_obj); else (*(c_object_free(sc, gc_obj)))(c_object_value(gc_obj))); + + gp = sc->vectors; + process_gc_list(liberate(sc, vector_block(gc_obj))); + + gp = sc->multivectors; + process_gc_list(process_multivector(sc, gc_obj)); + + gp = sc->hash_tables; + if (gp->loc > 0) { - 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*)); + for (i = 0, j = 0; i < gp->loc; i++) + { + s7_pointer gc_obj = gp->list[i]; + if (is_free_and_clear(gc_obj)) + free_hash_table(sc, gc_obj); + else + { + if ((is_weak_hash_table(gc_obj)) && + (weak_hash_iters(gc_obj) == 0) && + (hash_table_entries(gc_obj) > 0)) + cull_weak_hash_table(sc, gc_obj); + gp->list[j++] = gc_obj; + }} + gp->loc = j; } - } - 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++); - } + gp = sc->weak_hash_iterators; + process_gc_list(process_iterator(sc, gc_obj)); + + gp = sc->opt1_funcs; + if (gp->loc > 0) + { + for (i = 0, j = 0; i < gp->loc; i++) + { + s7_pointer gc_obj = gp->list[i]; + if (!is_free_and_clear(gc_obj)) + gp->list[j++] = gc_obj; + } + gp->loc = j; } + + gp = sc->input_ports; + process_gc_list(process_input_port(sc, gc_obj)); + + gp = sc->input_string_ports; + process_gc_list(process_input_string_port(sc, gc_obj)); + + gp = sc->output_ports; + process_gc_list(process_output_port(sc, gc_obj)); + + gp = sc->continuations; + process_gc_list(process_continuation(sc, gc_obj)); + + gp = sc->weak_refs; + if (gp->loc > 0) { - 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; + for (i = 0, j = 0; i < gp->loc; i++) + { + s7_pointer gc_obj = gp->list[i]; + if (!is_free_and_clear(gc_obj)) + { + if (is_free_and_clear(c_pointer_weak1(gc_obj))) + c_pointer_weak1(gc_obj) = sc->F; + if (is_free_and_clear(c_pointer_weak2(gc_obj))) + c_pointer_weak2(gc_obj) = sc->F; + if ((c_pointer_weak1(gc_obj) != sc->F) || + (c_pointer_weak2(gc_obj) != sc->F)) + gp->list[j++] = gc_obj; + }} + gp->loc = j; } - } - 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__) -void -try_to_call_gc_1 (s7_scheme* sc, const char* func, int32_t line) -#else -#define call_gc(Sc) gc (Sc) -void -try_to_call_gc (s7_scheme* sc) -#endif +} + +void add_to_gc_list(s7_scheme *sc, gc_list_t *gp, s7_pointer p) { - /* 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); + 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 ((s7_int) (sc->free_heap_top - sc->free_heap) < - (sc->heap_size * sc->gc_resize_heap_fraction)) /* changed 21-Jul-22 */ - resize_heap (sc); - } + 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; } -/* 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); +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); } -s7_pointer -s7_gc_on (s7_scheme* sc, bool on) { - sc->gc_off= !on; - return (make_boolean (sc, on)); -} +void just_mark(s7_pointer p) {set_mark(p);} -#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 +static void add_gensym(s7_scheme *sc, s7_pointer p) { - 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); - } + add_to_gc_list(sc, sc->gensyms, p); + mark_function[T_SYMBOL] = just_mark; } -#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 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_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 */ + + +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(); + + /* slightly unrelated... */ + sc->setters_size = 4; + sc->setters_loc = 0; + sc->setters = (s7_pointer *)Malloc(sc->setters_size * sizeof(s7_pointer)); } -#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 +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 func, 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. */ - return (p); + for (s7_int i = 0; i < sc->setters_loc; i++) + { + s7_pointer x = sc->setters[i]; + if (car(x) == func) + { + set_cdr_unchecked(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, func, T_Prc(setter), T_PAIR | T_IMMUTABLE); } -static void -add_semipermanent_object (s7_scheme* sc, - s7_pointer obj) /* called by remove_from_heap */ + +static inline void gc_mark(s7_pointer p) {if (!is_marked(p)) (*mark_function[type_unchecked(p)])(p);} + +static void mark_symbol_vector(s7_pointer vec, s7_int len) { - gc_obj_t* g = (gc_obj_t*) Malloc (sizeof (gc_obj_t)); - g->p = obj; - g->nxt = sc->semipermanent_objects; - sc->semipermanent_objects= g; + set_mark(vec); + if (mark_function[T_SYMBOL] != mark_noop) /* else no gensyms */ + { + s7_pointer *els = vector_elements(vec); + for (s7_int i = 0; i < len; i++) + if ((is_symbol(els[i])) && (is_gensym(els[i]))) /* need is_symbol: make-vector + set! vector-typer symbol? where init is not a symbol */ + set_mark(els[i]); + } } -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 void mark_simple_vector(s7_pointer vec, s7_int len) +{ + s7_pointer *vels = vector_elements(vec); + set_mark(vec); + for (s7_int i = 0; i < len; i++) + set_mark(vels[i]); } -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 (x); /* set_immutable(x); */ /* if there are GC troubles, this might - catch them? */ - return (x); -} +static void just_mark_vector(s7_pointer vect, s7_int unused_len) {set_mark(vect);} -#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 +static void mark_vector_1(s7_pointer vect, s7_int top) { - 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 (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; - } - } + 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 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 ((!x) || (is_free (x))) return; - if (type_unchecked (x) == T_CHARACTER) { - /* Unicode characters >255 are interned in sc->unicode_chars_table and can - * be shared across multiple syntax trees. Removing them from the heap here - * can double-remove the same cached character when another closure refers - * to it later. - */ - return; - } - 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); +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); } -/* -------------------------------- stacks -------------------------------- */ +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)); +} -/* -------- op stack -------- */ -#define OP_STACK_INITIAL_SIZE 64 +static void mark_let(s7_pointer let) +{ + for (; (let) && (!is_marked(let)); let = let_outlet(let)) + { + set_mark(let); + if (has_dox_slot1(let)) mark_slot(let_dox_slot1(let)); + if ((has_dox_slot2(let)) && (is_slot(let_dox_slot2(let)))) mark_slot(let_dox_slot2(let)); + /* 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(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (!is_marked(slot)) /* slot value might be the enclosing let */ + mark_slot(slot); + } +} -#define op_stack_entry(Sc) (*(Sc->op_stack_now - 1)) +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)); is_not_slot_end(slot); slot = next_slot(slot)) + if (!is_marked(slot)) mark_slot(slot); + p = cdr(p); + } while (p != end_p); -#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 (); - } + /* dox1|2? gensyms? maybe don't wrap gensym-slot */ } -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)); +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)); is_not_slot_end(slot); slot = next_slot(slot)) clear_mark(slot); + p = cdr(p); + } while (p != end_p); } -#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; +#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[type_unchecked(tp)])(tp); } +#endif -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 +static void mark_owlet(s7_scheme *sc) +{ +#if WITH_HISTORY { - 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))); + 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 - 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); + set_mark(sc->owlet); + mark_let(let_outlet(sc->owlet)); } -/* -------- 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. - */ +static void mark_c_pointer(s7_pointer cp) +{ + set_mark(cp); + gc_mark(c_pointer_type(cp)); + gc_mark(c_pointer_info(cp)); +} -#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 stack_top_op_unchecked(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 +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)); +} -#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] +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); +} -void s7_show_stack (s7_scheme* sc); +static void mark_counter(s7_pointer ctr) +{ + set_mark(ctr); + gc_mark(counter_result(ctr)); + gc_mark(counter_list(ctr)); + gc_mark(counter_let(ctr)); +} -#if S7_DEBUGGING -#define pop_stack(Sc) pop_stack_1 (Sc, __func__, __LINE__) -void -pop_stack_1 (s7_scheme* sc, const char* func, int32_t line) { - /* 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 (hence not set_curlet), 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) { - /* 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); -} - -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) { - /* 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) +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)); +} -#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 */ +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 */ + } +} -#else +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)); +} -#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) +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)); +} -#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) +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)); -#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) + /* 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)); +} -#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) +static void mark_int_or_float_vector(s7_pointer vect) {set_mark(vect);} -#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) +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); +} -#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) +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)); +} -#define push_stack_op(Sc, Op) \ - do { \ - stack_end_op (Sc)= (s7_pointer) (opcode_t) (Op); \ - Sc->stack_end+= 4; \ - } while (0) +static void mark_catch(s7_pointer catcher) /* C++ reserves "catch" */ +{ + set_mark(catcher); + gc_mark(catch_tag(catcher)); + gc_mark(catch_handler(catcher)); +} -#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. - */ +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 *entry; + for (entry = *entries++; entry; entry = hash_entry_next(entry)) + gc_mark(hash_entry_value(entry)); + for (entry = *entries++; entry; entry = hash_entry_next(entry)) + gc_mark(hash_entry_value(entry)); + } + else + while (entries < last) /* counting entries here was slightly faster */ + { + hash_entry_t *entry; + for (entry = *entries++; entry; entry = hash_entry_next(entry)) + { + gc_mark(hash_entry_key(entry)); + gc_mark(hash_entry_value(entry)); + } + for (entry = *entries++; entry; entry = hash_entry_next(entry)) + { + gc_mark(hash_entry_key(entry)); + gc_mark(hash_entry_value(entry)); + }}} +} + +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 -#define unstack_with(Sc, Op) unstack_1 (Sc, Op, __func__, __LINE__) -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 + else fprintf(stderr, "mark_iterator[%d]: has_carrier set (at line %d), but no carrier!\n", __LINE__, iter->carrier_line); #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* old_b = stack_block (sc->stack); - block_t* new_b= reallocate (sc, old_b, new_size * sizeof (s7_pointer)); - block_info (new_b) = NULL; - stack_block (sc->stack) = new_b; - stack_elements (sc->stack)= (s7_pointer*) block_data (new_b); - { - 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)]); +static void mark_input_port(s7_pointer port) +{ + set_mark(port); + gc_mark(port_string_or_function(port)); } -#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__) -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 -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 */ +static void mark_output_port(s7_pointer port) +{ + set_mark(port); + if (is_function_port(port)) + gc_mark(port_string_or_function(port)); } -#endif -#define check_stack_size(Sc) \ - do { \ - if (Sc->stack_end >= Sc->stack_resize_trigger) resize_stack (Sc); \ - } while (0) +static void mark_free(s7_pointer p) {if (S7_DEBUGGING) {fprintf(stderr, "mark_free!\n"); abort();}} /* set_mark also checks */ -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); +static void init_mark_functions(void) +{ + mark_function[T_BACRO] = mark_closure; + mark_function[T_BACRO_STAR] = mark_closure; + 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++); } -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); +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); } -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); +static void mark_rootlet(s7_scheme *sc) +{ + for (s7_pointer slot = sc->rootlet_slots; is_not_slot_end(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). + */ } -#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)); -} +/* 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 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 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 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)); +static void unmark_semipermanent_objects(s7_scheme *sc) +{ + for (gc_obj_t *g = sc->semipermanent_objects; g; g = (gc_obj_t *)(g->nxt)) + clear_mark(g->p); + for (gc_obj_t *g = sc->semipermanent_lets; g; g = (gc_obj_t *)(g->nxt)) /* there are lets and slots in this list */ + clear_mark(g->p); } -#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) +#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 - -#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 +static void s7_warn(s7_scheme *sc, s7_int len, const char *ctrl, ...); #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]); +#if S7_DEBUGGING +s7_int gc(s7_scheme *sc, const char *func, int32_t line) #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]); - } +s7_int gc(s7_scheme *sc) #endif - } -} +{ + s7_cell **old_free_heap_top; -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); /* undefined_slot? */ - 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_clear_shadows (new_sym); - 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); - set_cdr_unchecked (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)); + 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++; -#if 0 - { /* high 6 bytes are probably unused, and index */ - uint32_t high_bits = block_size(symbol_info(new_sym)) >> 32; - int32_t index = block_index(symbol_info(new_sym)); - if (high_bits != 0) fprintf(stderr, "%x ", high_bits); - /* for use of index, need this above: - * block_set_index(symbol_info(new_sym), location); symbol_location(new_sym), if gensym clear before free, or use only if not gensym - * or use sz bits instead -- only useful in remove_gensym_from_symbol_table. - * if (index != location) fprintf(stderr, "index: %d ", index); - */ - } -#endif - return (new_sym); -} + 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); -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)); -} - -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 - * -------------------------------- */ -extern 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))")) + 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. */ - 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); + 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); -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); -} + 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]); + } -/* -------------------------------- 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) { - set_cdr_unchecked (symbols, cdr (syms)); /* delete z */ - return; - } -} + { + gc_list_t *gp = sc->opt1_funcs; + for (s7_int i = 0; i < gp->loc; i++) + { + s7_pointer gc_obj = T_Pair(gp->list[i]); + if ((is_marked(gc_obj)) && (!is_marked(opt1_any(gc_obj)))) /* opt1_lambda, but op_unknown* can change to opt1_cfunc etc */ + gc_mark(opt1_any(gc_obj)); /* not set_mark -- need to protect let/body/args as well */ + }} -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'; + /* free up all unmarked objects */ + old_free_heap_top = sc->free_heap_top; { - 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); + 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 *str; fprintf(stderr, "odd bits: %s\n", str = describe_type_bits(sc, p)); free(str);} \ + if (!in_heap(p)) {char *str; fprintf(stderr, "not in heap: %s\n", str = describe_type_bits(sc, p)); free(str);} \ + 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; /* gc_object defined above needs this pointer */ + 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); } -} -bool -is_gensym_b_p (s7_pointer g) { - return ((is_symbol (g)) && (is_gensym (g))); -} + unmark_semipermanent_objects(sc); + unmark_wrappers(sc); -/* g_is_gensym is now defined in s7_scheme_predicate.c */ -#define H_is_gensym "(gensym? sym) returns #t if sym is a gensym" -#define Q_is_gensym sc->pl_bt + 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); -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) + 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); +} - 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; - } +#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 - { - 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 */ +#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 */ - { - 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); - } +#if S7_DEBUGGING +#define resize_heap_to(Sc, Size) resize_heap_to_1(Sc, Size, __func__, __LINE__) +void resize_heap_to_1(s7_scheme *sc, s7_int size, const char *func, int line) +#else +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; - /* 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; +#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 - /* 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); /* undefined_slot? */ - 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_clear_shadows (new_gensym); - symbol_clear_type (new_gensym); - gensym_block (new_gensym)= b; + 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; + }} - /* 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); - set_cdr_unchecked (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); + /* 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: %" ld64 "\n", + sc->heap_size, + (2 * sc->heap_size * sizeof(s7_cell *)) + ((sc->heap_size - old_size) * sizeof(s7_cell)), + (s7_int)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?!? */ -/* -------------------------------- syntax? -------------------------------- */ -bool -s7_is_syntax (s7_pointer p) { - return (is_syntax (p)); + { + 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); + } } -/* g_is_syntax is now defined in s7_scheme_predicate.c */ -#define H_is_syntax \ - "(syntax? obj) returns #t if obj is a syntactic value (e.g. lambda)" -#define Q_is_syntax sc->pl_bt - -/* -------------------------------- symbol helpers - * -------------------------------- */ -bool -s7i_is_gensym (s7_pointer p) { - return (is_gensym (p)); -} -s7_pointer -s7i_symbol_name_cell (s7_pointer sym) { - return (symbol_name_cell (sym)); -} -s7_int -s7i_symbol_name_length (s7_pointer sym) { - return (symbol_name_length (sym)); -} -s7_pointer -s7i_make_symbol_with_length (s7_scheme* sc, const char* name, s7_int len) { - return (make_symbol (sc, name, len)); -} -s7_pointer -s7i_initial_value (s7_pointer symbol) { - return (initial_value (symbol)); -} -void -s7i_set_initial_value (s7_pointer symbol, s7_pointer value) { - set_initial_value (symbol, value); -} -bool -s7i_initial_value_is_defined (s7_scheme* sc, s7_pointer symbol) { - return (initial_value_is_defined (sc, symbol)); -} +#define resize_heap(Sc) resize_heap_to(Sc, 0) -/* -------------------------------- symbol? -------------------------------- */ -bool -s7_is_symbol (s7_pointer p) { - return (is_symbol (p)); +#if S7_DEBUGGING +#define call_gc(Sc) gc(Sc, __func__, __LINE__) +void try_to_call_gc_1(s7_scheme *sc, const char *func, int32_t line) +#else +#define call_gc(Sc) gc(Sc) +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. + */ -/* g_is_symbol is now defined in s7_scheme_predicate.c */ -#define H_is_symbol "(symbol? obj) returns #t if obj is a symbol" -#define Q_is_symbol sc->pl_bt - -const char* -s7_symbol_name (s7_pointer sym) { - return (symbol_name (sym)); +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_name_to_value (s7_scheme* sc, const char* name) { - return (s7_symbol_value (sc, make_symbol_with_strlen (sc, name))); +s7_pointer s7_gc_on(s7_scheme *sc, bool on) +{ + sc->gc_off = !on; + return(make_boolean(sc, on)); } -/* 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!) */ -s7_pointer -s7i_nil_string (void) { - return (nil_string); +#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); + } } -s7_pointer -s7i_set_plist_2 (s7_scheme* sc, s7_pointer x1, s7_pointer x2) { - return (set_plist_2 (sc, x1, x2)); -} -s7_pointer -s7i_set_ulist_1 (s7_scheme* sc, s7_pointer x1, s7_pointer x2) { - return (set_ulist_1 (sc, x1, x2)); +#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++])); } -void -s7i_string_append_length_error (s7_scheme* sc, s7_pointer caller, s7_int len) { - 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))); +#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); } -bool -s7i_is_string_append_or_symbol_caller (s7_scheme* sc, s7_pointer caller) { - return ((caller == sc->string_append_symbol) || - (caller == sc->symbol_symbol)); +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; } -void -s7i_set_string_value (s7_pointer str, const char* val) { - string_value (str)= (char*) val; -} -char* -s7i_string_value_ptr (s7_pointer str) { - return (string_value (str)); +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; } -/* string comparison bridge functions (defined after scheme_strcmp etc.) */ - -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)); - if (str) 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); -} - -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 */ -} - -/* g_symbol_to_string, g_symbol_to_string_uncopied, symbol_to_string_p_p, - symbol_to_string_uncopied_p migrated to s7_scheme_symbol.c */ -#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) - -#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) - -/* g_string_to_symbol_1 still needed by g_symbol in s7.c */ -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 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(x); /* set_immutable(x); */ /* if there are GC troubles, this might catch them? */ + return(x); } -/* -------------------------------- symbol -------------------------------- */ -s7_pointer s7i_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, s7i_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)); +#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(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; + }} +} - { /* 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); - } +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 ((!x) || (is_free(x))) return; + if (type_unchecked(x) == T_CHARACTER) + { + /* Unicode characters >255 are interned in sc->unicode_chars_table and can be shared + * across multiple syntax trees. Removing them from the heap here can double-remove the + * same cached character when another closure refers to it later. + */ + return; } - name[len]= '\0'; - sym = mark_as_symbol_from_symbol (inline_make_symbol (sc, name, len)); - liberate (sc, b); - return (sym); - } + 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); } -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 -------- */ -/* g_symbol_initial_value migrated to s7_scheme_symbol.c */ -#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) - -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 (sc, 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)); -} - -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))); */ - } -} +/* -------------------------------- stacks -------------------------------- */ -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)); -} +/* -------- op stack -------- */ +#define OP_STACK_INITIAL_SIZE 64 -/* -------- small symbol set -------- */ +#define op_stack_entry(Sc) (*(Sc->op_stack_now - 1)) #if S7_DEBUGGING -enum { set_ignore, set_begin, set_end }; +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(); + } +} -#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); +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 -#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; +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; +} - 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++; +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); } -#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 +/* -------- 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 stack_top_op_unchecked(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] -#define symbol_is_in_small_symbol_set(Sc, Sym) \ - (small_symbol_tag (Sym) == Sc->small_symbol_tag) +void s7_show_stack(s7_scheme *sc); -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); +#if S7_DEBUGGING +#define pop_stack(Sc) pop_stack_1(Sc, __func__, __LINE__) +void pop_stack_1(s7_scheme *sc, const char *func, int32_t line) +{ + /* 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 (hence not set_curlet), 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) +{ + /* 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 /* 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++; +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) +{ + /* 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 begin_small_symbol_set(Sc) clear_small_symbol_set (Sc) -#define end_small_symbol_set(Sc) -#endif +#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) -void -s7i_begin_small_symbol_set (s7_scheme* sc) { - begin_small_symbol_set (sc); -} -void -s7i_end_small_symbol_set (s7_scheme* sc) { - end_small_symbol_set (sc); -} -s7_pointer -s7i_add_symbol_to_small_symbol_set (s7_scheme* sc, s7_pointer sym) { - return (add_symbol_to_small_symbol_set (sc, sym)); -} -bool -s7i_symbol_is_in_small_symbol_set (s7_scheme* sc, s7_pointer sym) { - return (symbol_is_in_small_symbol_set (sc, sym)); -} +#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 */ -/* -------- 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++ +#else -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_clear_shadows (sym); - set_big_symbol_tag (sym, sc->big_symbol_tag); - return (sym); -} +#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) -/* -------------------------------- lets/slots -------------------------------- +#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. */ -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); -} -extern inline s7_pointer -make_let (s7_scheme* sc, s7_pointer old_let) { - return (inline_make_let (sc, old_let)); -} +#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) -extern 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_unchecked (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_unchecked (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_unchecked (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 */ -extern 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_unchecked (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); -} +#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) -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_unchecked (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 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 add_slot(Sc, Let, Symbol, Value) \ - add_slot_unchecked (Sc, Let, Symbol, Value, let_id (Let)) +#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) -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); -} +#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) -extern 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); -} +#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. + */ -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 */ +#if S7_DEBUGGING +#define unstack_with(Sc, Op) unstack_1(Sc, Op, __func__, __LINE__) +void unstack_1(s7_scheme *sc, opcode_t op, const char *func, int32_t line) { - 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); + 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 s7_pointer -add_slot_unchecked_with_id (s7_scheme* sc, s7_pointer let, s7_pointer symbol, - s7_pointer value) { - s7_pointer slot; - new_cell_unchecked (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); -} - -extern 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_unchecked (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); -} - -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 void stack_reset(s7_scheme *sc) +{ + sc->stack_end = sc->stack_start; + push_stack_op(sc, OP_EVAL_DONE); } -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_unchecked (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; - if ((S7_DEBUGGING) && (slot == slot_end)) - fprintf (stderr, "%s[%d]: no slot!\n", __func__, __LINE__); - 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); -} - -s7_pointer call_setter (s7_scheme* sc, s7_pointer slot, s7_pointer old_value); - -extern 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); +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 *old_b = stack_block(sc->stack); + block_t *new_b = reallocate(sc, old_b, new_size * sizeof(s7_pointer)); + block_info(new_b) = NULL; + stack_block(sc->stack) = new_b; + stack_elements(sc->stack) = (s7_pointer *)block_data(new_b); + { + 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; } - return (slot_value (slot)); + 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); } -static s7_pointer -let_fill (s7_scheme* sc, s7_pointer args) { - const s7_pointer let= car (args); - s7_pointer val; - if (let == sc->rootlet) - out_of_range_error_nr (sc, sc->fill_symbol, int_one, let, - wrap_string (sc, "can't fill! rootlet", 19)); - if (let == sc->starlet) - out_of_range_error_nr (sc, sc->fill_symbol, int_one, let, - wrap_string (sc, "can't fill! *s7*", 16)); - /* (owlet) copies sc->owlet, so let can't be sc->owlet */ - if (is_funclet (let)) - out_of_range_error_nr (sc, sc->fill_symbol, int_one, let, - wrap_string (sc, "can't fill! a funclet", 21)); - val= cadr (args); - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - checked_slot_set_value (sc, slot, val); - return (val); +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)]); } -static s7_int starlet_length (void); - -static s7_int -let_length (s7_scheme* sc, s7_pointer let) { - /* used by length, applicable_length, copy, and some length optimizations */ - if (let == sc->rootlet) { - s7_int i= 0; - for (s7_pointer slot= sc->rootlet_slots; is_not_slot_end (slot); - i++, slot= next_slot (slot)) - ; - return (i); - } - if (let == sc->starlet) return (starlet_length ()); - if (has_active_methods (sc, let)) { - s7_pointer length_func= find_method (sc, let, sc->length_symbol); - if (length_func != sc->undefined) { - s7_pointer num= - s7_apply_function (sc, length_func, set_plist_1 (sc, let)); - return ((s7_is_integer (num)) ? s7_integer (num) : -1); /* ?? */ +#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"); } - } - { - s7_int i= 0; - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - i++, slot= next_slot (slot)) - ; - return (i); - } + sc->stop_at_error = old_stop; } -void -slot_set_setter (s7_pointer slot, s7_pointer val) { - if ((type (val) == T_C_FUNCTION) && (c_function_has_bool_setter (val))) - slot_set_setter_1 (slot, c_function_bool_setter (val)); - else slot_set_setter_1 (slot, val); +#define resize_stack(Sc) resize_stack_1(Sc, __func__, __LINE__) +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); } - -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); +#else +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 -static void -remove_function_from_heap (s7_scheme* sc, - s7_pointer value); /* calls remove_let_from_heap */ +#define check_stack_size(Sc) do {if (Sc->stack_end >= Sc->stack_resize_trigger) resize_stack(Sc);} while (0) -static void -remove_let_from_heap (s7_scheme* sc, s7_pointer let) { - for (s7_pointer slot= let_slots (let); is_not_slot_end (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 (let); +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); } -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); +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); } -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) */ +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); +} - { /* 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); - } +#if S7_DEBUGGING + static s7_pointer stack_protected1_1(s7_scheme *sc, opcode_t op, const char *func, int line) { - s7_pointer let= closure_let (value); - if ((is_let (let)) && (!let_removed (let)) && (let != sc->shadow_rootlet)) { - let= let_outlet (let); - if ((is_let (let)) && (!let_removed (let)) && - (let != sc->shadow_rootlet)) { - remove_let_from_heap (sc, let); - let= let_outlet (let); - if ((is_let (let)) && (!let_removed (let)) && - (let != sc->shadow_rootlet)) - remove_let_from_heap (sc, let); + 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 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 (sc, 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 lets 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 lets -- 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. - */ + static s7_pointer stack_protected2_1(s7_scheme *sc, opcode_t op, const char *func, int line) + { + if (stack_top_op(sc) != op) { - 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); + fprintf(stderr, "%s[%d]: stack_protected2 %s\n", func, line, op_names[stack_top_op(sc)]); + if (sc->stop_at_error) abort(); } - set_local_slot (symbol, slot); - } - symbol_increment_ctr (symbol); - if (is_gensym (symbol)) remove_gensym_from_heap (sc, symbol); - return (slot); + return(stack_top_code(sc)); } - 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 let) { - return (is_let (let)); -} -/* g_is_let is now defined in s7_scheme_predicate.c */ -#define H_is_let "(let? obj) returns #t if obj is a let." -#define Q_is_let sc->pl_bt + 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)); + } -/* -------------------------------- funclet? -------------------------------- */ -/* g_is_funclet is now defined in s7_scheme_predicate.c */ -#define H_is_funclet \ - "(funclet? obj) returns #t if obj is a funclet (a function's environment)." -#define Q_is_funclet sc->pl_bt + #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__) -/* -------------------------------- unlet -------------------------------- */ -/* g_unlet moved to s7_scheme_let.c */ -#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) + #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) -/* -------------------------------- openlet? -------------------------------- */ -/* s7_is_openlet moved to s7_scheme_let.c */ +#else -/* g_is_openlet is now defined in s7_scheme_predicate.c */ -#define H_is_openlet "(openlet? obj) returns #t if 'obj' has methods." -#define Q_is_openlet sc->pl_bt + #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) -/* -------------------------------- openlet -------------------------------- */ -/* s7_openlet moved to s7_scheme_let.c */ + #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 -/* g_openlet moved to s7_scheme_let.c */ -#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)) +#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) -/* -------------------------------- coverlet -------------------------------- */ -/* g_coverlet moved to s7_scheme_let.c */ -#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)) +#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) -/* -------------------------------- varlet -------------------------------- */ -/* check_let_fallback moved to s7_scheme_let.c */ +#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) -/* append_let moved to s7_scheme_let.c */ +#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) -/* s7_varlet moved to s7_scheme_let.c */ -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); +/* -------------------------------- 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 + } } -s7_int -s7i_position_of (const s7_pointer p, s7_pointer args) { - return ((s7_int) position_of (p, args)); +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); } -/* g_varlet moved to s7_scheme_let.c */ -#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) +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); +} -/* -------------------------------- cutlet -------------------------------- */ -/* g_cutlet moved to s7_scheme_let.c */ -#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) +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); /* undefined_slot? */ + 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_clear_shadows(new_sym); + 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); + set_cdr_unchecked(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)); -/* -------------------------------- sublet -------------------------------- */ -/* sublet_1 moved to s7_scheme_let.c */ - -/* s7_sublet moved to s7_scheme_let.c */ - -/* g_sublet moved to s7_scheme_let.c */ -#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 - -/* g_sublet_curlet moved to s7_scheme_let.c */ - -/* sublet_chooser moved to s7_scheme_let.c */ +#if 0 + { /* high 6 bytes are probably unused, and index */ + uint32_t high_bits = block_size(symbol_info(new_sym)) >> 32; + int32_t index = block_index(symbol_info(new_sym)); + if (high_bits != 0) fprintf(stderr, "%x ", high_bits); + /* for use of index, need this above: + * block_set_index(symbol_info(new_sym), location); symbol_location(new_sym), if gensym clear before free, or use only if not gensym + * or use sz bits instead -- only useful in remove_gensym_from_symbol_table. + * if (index != location) fprintf(stderr, "index: %d ", index); + */ + } +#endif + return(new_sym); +} -/* -------------------------------- inlet -------------------------------- */ -/* s7_inlet moved to s7_scheme_let.c */ -#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) +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; -#define g_inlet s7_inlet + 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)); +} -/* g_simple_inlet moved to s7_scheme_let.c */ +s7_pointer make_symbol(s7_scheme *sc, const char *name, s7_int len) {return(inline_make_symbol(sc, name, len));} -/* inlet_p_pp moved to s7_scheme_let.c */ +s7_pointer s7_make_symbol(s7_scheme *sc, const char *name) {return(inline_make_symbol(sc, name, safe_strlen(name)));} -/* internal_inlet moved to s7_scheme_let.c */ +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); +} -bool -is_proper_quote (s7_scheme* sc, s7_pointer p) { - return ((is_safe_quoted_pair (sc, p)) && (is_pair (cdr (p))) && - (is_null (cddr (p)))); +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); } -/* inlet_chooser moved to s7_scheme_let.c */ -/* -------------------------------- let->list -------------------------------- - */ -s7_pointer proper_list_reverse_in_place (s7_scheme* sc, s7_pointer list); +/* -------------------------------- symbol-table -------------------------------- */ +extern inline s7_pointer make_simple_vector(s7_scheme *sc, s7_int len); -/* abbreviate_let moved to s7_scheme_let.c */ +static s7_pointer g_symbol_table(s7_scheme *sc, s7_pointer unused_args) +{ + #define H_symbol_table "(symbol-table) returns a vector containing the current contents (symbols) of s7's symbol-table" + #define Q_symbol_table s7_make_signature(sc, 1, sc->is_vector_symbol) -/* s7_let_to_list moved to s7_scheme_let.c */ + int32_t syms = 0; + s7_pointer *entries = vector_elements(sc->symbol_table); -/* g_let_to_list moved to s7_scheme_let.c */ -#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)) + /* 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); + } +} -/* -------------------------------- let-ref -------------------------------- */ -/* call_let_ref_fallback moved to s7_scheme_let.c */ +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); +} -/* call_let_set_fallback moved to s7_scheme_let.c */ -/* g_unlet_disabled is now defined in s7_scheme_predicate.c */ -/* 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 */ +/* -------------------------------- 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) + { + set_cdr_unchecked(symbols, cdr(syms)); /* delete z */ + return; + } +} -/* let_ref moved to s7_scheme_let.c */ +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); + } +} -/* s7_let_ref moved to s7_scheme_let.c */ +bool is_gensym_b_p(s7_pointer g) {return((is_symbol(g)) && (is_gensym(g)));} -/* g_let_ref moved to s7_scheme_let.c */ -#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) +/* g_is_gensym is now defined in s7_scheme_predicate.c */ + #define H_is_gensym "(gensym? sym) returns #t if sym is a gensym" + #define Q_is_gensym sc->pl_bt -/* slot_in_let moved to s7_scheme_let.c */ +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) -/* let_ref_p_pp moved to s7_scheme_let.c */ + const char *prefix; + s7_int plen; -/* g_cdr_let_ref moved to s7_scheme_let.c */ + /* 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_pointer starlet (s7_scheme* sc, s7_int choice); -/* g_starlet_ref moved to s7_scheme_let.c */ + { + 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 */ -/* g_rootlet_ref moved to s7_scheme_let.c */ + { + 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); + } -/* let_ref_chooser moved to s7_scheme_let.c */ + /* 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; -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); -} + /* 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); /* undefined_slot? */ + 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_clear_shadows(new_gensym); + symbol_clear_type(new_gensym); + gensym_block(new_gensym) = b; -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); -} + /* 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); + set_cdr_unchecked(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)); -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))); + add_gensym(sc, new_gensym); + return(new_gensym); + }} } -/* -------------------------------- let-set! -------------------------------- */ -/* let_set_1 moved to s7_scheme_let.c */ - -/* let_set_2 moved to s7_scheme_let.c */ -/* s7_let_set moved to s7_scheme_let.c */ +/* -------------------------------- syntax? -------------------------------- */ +bool s7_is_syntax(s7_pointer p) {return(is_syntax(p));} -/* g_let_set moved to s7_scheme_let.c */ -#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) +/* g_is_syntax is now defined in s7_scheme_predicate.c */ + #define H_is_syntax "(syntax? obj) returns #t if obj is a syntactic value (e.g. lambda)" + #define Q_is_syntax sc->pl_bt -/* let_set_p_ppp_2 moved to s7_scheme_let.c */ -/* g_cdr_let_set moved to s7_scheme_let.c */ +/* -------------------------------- symbol helpers -------------------------------- */ +bool s7i_is_gensym(s7_pointer p) {return(is_gensym(p));} +s7_pointer s7i_symbol_name_cell(s7_pointer sym) {return(symbol_name_cell(sym));} +s7_int s7i_symbol_name_length(s7_pointer sym) {return(symbol_name_length(sym));} +s7_pointer s7i_make_symbol_with_length(s7_scheme *sc, const char *name, s7_int len) {return(make_symbol(sc, name, len));} +s7_pointer s7i_initial_value(s7_pointer symbol) {return(initial_value(symbol));} +void s7i_set_initial_value(s7_pointer symbol, s7_pointer value) {set_initial_value(symbol, value);} +bool s7i_initial_value_is_defined(s7_scheme *sc, s7_pointer symbol) {return(initial_value_is_defined(sc, symbol));} -s7_pointer starlet_set_1 (s7_scheme* sc, s7_pointer sym, s7_pointer val); +/* -------------------------------- symbol? -------------------------------- */ +bool s7_is_symbol(s7_pointer p) {return(is_symbol(p));} -/* g_starlet_set moved to s7_scheme_let.c */ +/* g_is_symbol is now defined in s7_scheme_predicate.c */ + #define H_is_symbol "(symbol? obj) returns #t if obj is a symbol" + #define Q_is_symbol sc->pl_bt -/* g_unlet_set moved to s7_scheme_let.c */ +const char *s7_symbol_name(s7_pointer sym) {return(symbol_name(sym));} -/* let_set_chooser moved to s7_scheme_let.c */ +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"? */ -/* reverse_slots moved to s7_scheme_let.c */ -/* let_copy moved to s7_scheme_let.c */ +/* -------------------------------- 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!) */ -/* -------------------------------- rootlet -------------------------------- */ -/* g_rootlet is now defined in s7_scheme_predicate.c */ -#define H_rootlet \ - "(rootlet) returns the current top-level definitions (symbol bindings)." -#define Q_rootlet s7_make_signature (sc, 1, sc->is_let_symbol) +s7_pointer s7i_nil_string(void) {return(nil_string);} -/* s7_rootlet moved to s7_scheme_let.c */ +s7_pointer s7i_set_plist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) {return(set_plist_2(sc, x1, x2));} +s7_pointer s7i_set_ulist_1(s7_scheme *sc, s7_pointer x1, s7_pointer x2) {return(set_ulist_1(sc, x1, x2));} -/* 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_shadow_rootlet moved to s7_scheme_let.c */ +void s7i_string_append_length_error(s7_scheme *sc, s7_pointer caller, s7_int len) +{ + 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))); +} -/* s7_set_shadow_rootlet moved to s7_scheme_let.c */ +bool s7i_is_string_append_or_symbol_caller(s7_scheme *sc, s7_pointer caller) +{ + return((caller == sc->string_append_symbol) || (caller == sc->symbol_symbol)); +} -/* -------------------------------- curlet -------------------------------- */ -/* s7_curlet moved to s7_scheme_let.c */ +void s7i_set_string_value(s7_pointer str, const char *val) {string_value(str) = (char *)val;} +char *s7i_string_value_ptr(s7_pointer str) {return(string_value(str));} -/* g_curlet is now defined in s7_scheme_predicate.c */ -#define H_curlet "(curlet) returns the current definitions (symbol bindings)" -#define Q_curlet s7_make_signature (sc, 1, sc->is_let_symbol) +/* string comparison bridge functions (defined after scheme_strcmp etc.) */ -/* update_symbol_ids moved to s7_scheme_let.c */ +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)); + if (str) 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); +} + +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 */ +} -/* s7_set_curlet moved to s7_scheme_let.c */ +/* g_symbol_to_string, g_symbol_to_string_uncopied, symbol_to_string_p_p, symbol_to_string_uncopied_p + migrated to s7_scheme_symbol.c */ +#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) -/* -------------------------------- outlet -------------------------------- */ -/* s7_outlet moved to s7_scheme_let.c */ +#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) -/* outlet_p_p moved to s7_scheme_let.c */ +/* g_string_to_symbol_1 still needed by g_symbol in s7.c */ +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))); +} -/* g_outlet_unlet migrated to s7_scheme_predicate.c */ -/* s7i_outlet_p_p moved to s7_scheme_let.c */ +/* -------------------------------- symbol -------------------------------- */ +s7_pointer s7i_string_append_1(s7_scheme *sc, s7_pointer args, s7_pointer caller); -#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)) +static s7_pointer mark_as_symbol_from_symbol(s7_pointer sym) +{ + set_is_symbol_from_symbol(sym); + return(sym); +} -/* outlet_chooser moved to s7_scheme_let.c */ +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; -/* g_set_outlet moved to s7_scheme_let.c */ + 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, s7i_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)); -/* -------------------------------- symbol lookup - * -------------------------------- */ -static Inline s7_pointer -inline_lookup_from (s7_scheme* sc, const s7_pointer symbol, s7_pointer let) { - /* 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 (let) == symbol_id (symbol)) return (local_value (symbol)); - if (let_id (let) > - symbol_id (symbol)) /* let is newer so look back in the outlet chain */ - { - do { - let= let_outlet (let); - } while (let_id (let) > symbol_id (symbol)); - if (let_id (let) == symbol_id (symbol)) return (local_value (symbol)); + { /* 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); } - for (; let; let= let_outlet (let)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (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 -s7_pointer -lookup_1 (s7_scheme* sc, const s7_pointer symbol) -#else -s7_pointer -lookup (s7_scheme* sc, - const s7_pointer - symbol) /* lookup_checked includes the unbound_variable call */ -#endif +static s7_pointer symbol_p_pp(s7_scheme *sc, s7_pointer str1, s7_pointer str2) { - return (inline_lookup_from (sc, symbol, sc->curlet)); + 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))); } -s7_pointer -s7i_lookup_p_p (s7_scheme* sc, s7_pointer symbol) { - return (lookup (sc, symbol)); -} +/* -------- symbol-initial-value -------- */ +/* g_symbol_initial_value migrated to s7_scheme_symbol.c */ +#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) -static inline s7_pointer -lookup_slot_from (s7_pointer symbol, s7_pointer let) { - if (let_id (let) == symbol_id (symbol)) return (T_Slt (local_slot (symbol))); - if (let_id (let) > symbol_id (symbol)) { - do { - let= let_outlet (let); - } while (let_id (let) > symbol_id (symbol)); - if (let_id (let) == symbol_id (symbol)) - return (T_Slt (local_slot (symbol))); - } - for (; let; let= let_outlet (let)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == symbol) return (T_Slt (slot)); - return (T_Sld (global_slot ( - symbol))); /* # when (define x ...) and x is not yet defined */ +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(sc, 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_slot (s7_scheme* sc, s7_pointer symbol) { - return (lookup_slot_from (symbol, sc->curlet)); +s7_pointer s7_symbol_initial_value(s7_pointer symbol) {return(initial_value(symbol));} + +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 s7_pointer -lookup_slot_with_let (s7_scheme* sc, s7_pointer symbol, s7_pointer let) { - return (lookup_slot_from (symbol, let)); +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)))); } -s7_pointer -s7_slot_value (s7_pointer slot) { - return (slot_value (slot)); +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_slot_set_value (s7_scheme* sc, s7_pointer slot, s7_pointer value) { - slot_set_value (slot, value); - return (value); +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)); } -void -s7_slot_set_real_value (s7_scheme* sc, s7_pointer slot, s7_double value) { - set_real (slot_value (slot), value); + +/* -------- 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); } -s7_pointer -symbol_to_local_slot (s7_scheme* sc, s7_pointer symbol, - s7_pointer let) /* assumes e is a let */ +#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 (T_Let (let) == 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 (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == symbol) return (slot); - return (sc->undefined); + 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); } -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); +#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++; } -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); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == sym) return (slot_value (slot)); +#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__) - /* maybe let is local but sym is global but previously shadowed */ - if (is_slot (global_slot (sym))) return (global_value (sym)); +#else + +#define symbol_is_in_small_symbol_set(Sc, Sym) (small_symbol_tag(Sym) == Sc->small_symbol_tag) - /* (let ((e (curlet))) (let ((a 1)) (symbol->value 'a e))) -> # not - * 1 */ - return (sc->undefined); /* 29-Nov-17 */ +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); } -/* -------------------------------- symbol->value - * -------------------------------- */ -#define lookup_global(Sc, Sym) \ - ((is_defined_global (Sym)) ? global_value (Sym) : lookup_checked (Sc, 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++; +} -/* g_symbol_to_value moved to s7_scheme_let.c */ -#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)) +#define begin_small_symbol_set(Sc) clear_small_symbol_set(Sc) +#define end_small_symbol_set(Sc) +#endif -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); -} +void s7i_begin_small_symbol_set(s7_scheme *sc) { begin_small_symbol_set(sc); } +void s7i_end_small_symbol_set(s7_scheme *sc) { end_small_symbol_set(sc); } +s7_pointer s7i_add_symbol_to_small_symbol_set(s7_scheme *sc, s7_pointer sym) { return(add_symbol_to_small_symbol_set(sc, sym)); } +bool s7i_symbol_is_in_small_symbol_set(s7_scheme *sc, s7_pointer sym) { return(symbol_is_in_small_symbol_set(sc, sym)); } -/* symbol_to_value_chooser moved to s7_scheme_let.c */ +/* -------- 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++ -/* -------------------------------- symbol->dynamic-value - * -------------------------------- */ -/* find_dynamic_value moved to s7_scheme_let.c */ +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_clear_shadows(sym); + set_big_symbol_tag(sym, sc->big_symbol_tag); + return(sym); +} -/* g_symbol_to_dynamic_value moved to s7_scheme_let.c */ -#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) - -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); + +/* -------------------------------- 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 bool -direct_assq (const s7_pointer symbol, - s7_pointer symbols) /* used only below in do_symbol_is_safe */ +extern inline s7_pointer make_let(s7_scheme *sc, s7_pointer old_let) {return(inline_make_let(sc, old_let));} + +extern 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_unchecked(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) { - for (s7_pointer syms= symbols; is_pair (syms); syms= cdr (syms)) - if (caar (syms) == symbol) return (true); - return (false); + 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 bool -do_symbol_is_safe (s7_scheme* sc, s7_pointer sym, s7_pointer var_list) { - return ((is_slot (global_slot (sym))) || (direct_assq (sym, var_list)) || - (is_bound_symbol (sc, sym))); +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 bool -let_symbol_is_safe (s7_scheme* sc, s7_pointer sym, s7_pointer var_list) { - if (is_slot (global_slot (sym))) return (true); - if (var_list == sc->rootlet) return (false); - return ((!is_with_let_let (var_list)) && (is_bound_symbol (sc, sym))); +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_unchecked(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_unchecked(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 bool -let_symbol_is_safe_or_listed (s7_scheme* sc, s7_pointer sym, - s7_pointer var_list) { - return ((symbol_is_in_big_symbol_set (sc, sym)) || - (let_symbol_is_safe (sc, sym, var_list))); +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)); } -static bool -let_star_symbol_is_safe (s7_scheme* sc, s7_pointer sym, s7_pointer var_list) { - return ((symbol_is_in_big_symbol_set (sc, sym)) || - (is_slot (global_slot (sym))) || - ((is_let (var_list)) && (!is_with_let_let (var_list)) && - (is_bound_symbol (sc, sym)))); +/* 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 */ +extern 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_unchecked(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 bool -pair_symbol_is_safe (s7_scheme* unused_sc, s7_pointer sym, s7_pointer symbols) { - return ( - (is_slot (global_slot (sym))) || - (direct_memq (sym, symbols))); /* optimize_syntax pushes :if (and others - like () I think) on this list */ +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_unchecked(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); } -static s7_pointer -collect_variables (s7_scheme* sc, s7_pointer lst, s7_pointer var_list) { - /* collect local variable names from let/do (pre-error-check), 20 overhead in - * tgen -> 14 if cons_unchecked below */ - begin_temp (sc->y, var_list); - 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); +#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 s7_pointer -collect_parameters (s7_scheme* sc, s7_pointer lst, s7_pointer var_list) { - /* 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), var_list)); - } - begin_temp (sc->y, var_list); - 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 (sc, 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)); - } +extern inline s7_pointer add_slot_checked_with_id(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value) +{ + s7_pointer slot; + new_cell(sc, slot, T_SLOT); + slot_set_symbol_and_value(slot, symbol, value); + set_local(symbol); + if (let_id(let) >= symbol_id(symbol)) + symbol_set_local_slot(symbol, let_id(let), slot); + slot_set_next(slot, let_slots(let)); + let_set_slots(let, slot); + return(slot); } -static s7_pointer -add_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 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_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); +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_unchecked(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); } -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 let_or_list); +extern 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_unchecked(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 -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); +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); +} - if (sc->debug > 1) /* no profile here */ - closure_set_body (mac, add_trace (sc, body)); +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_unchecked(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); +} - 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 */ +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); +} - /* 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 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 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_unchecked (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 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); } -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 -- this code is repetitive but faster */ - 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); +#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; + if ((S7_DEBUGGING) && (slot == slot_end)) fprintf(stderr, "%s[%d]: no slot!\n", __func__, __LINE__); + let_set_id(let, id); + update_slot(slot, val, id); + return(let); } -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 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 int32_t -closure_length (s7_scheme* sc, s7_pointer clo) { - /* we can't use let_length(sc, closure_let(clo)) 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 (clo), sc->length_symbol); - if (length_func != sc->undefined) - return ((int32_t) s7_integer ( - s7_apply_function (sc, length_func, set_plist_1 (sc, clo)))); - /* there are cases where this should raise a wrong-type-arg error, but for - * now... */ - return (-1); +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 -cons_unchecked_with_type (s7_scheme* sc, s7_pointer p, s7_pointer a, - s7_pointer b) /* (used only in copy_tree_with_type) */ +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 new_pair; - new_cell_unchecked (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 (sc, car (_p))) ? copy_tree_with_type (sc, car (_p)) \ - : car (_p), \ - (is_unquoted_pair (sc, 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 (sc, car (tree))) ? COPY_TREE_WITH_TYPE (car (tree)) - : car (tree), - (is_unquoted_pair (sc, cdr (tree))) ? COPY_TREE_WITH_TYPE (cdr (tree)) - : cdr (tree))); + 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 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 (sc, 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 (sc, car (tree))) ? COPY_TREE (car (tree)) : car (tree), - (is_pair (cdr (tree))) ? COPY_TREE (cdr (tree)) : cdr (tree))); +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); } -/* -------------------------------- tree-cyclic? - * -------------------------------- */ -/* tree_is_cyclic, g_tree_is_cyclic migrated to s7_liii_tree.c */ +s7_pointer call_setter(s7_scheme *sc, s7_pointer slot, s7_pointer old_value); -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); +extern 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)); } -/* -------------------------------- defined? -------------------------------- */ -/* g_is_defined moved to s7_scheme_let.c */ -#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) - -static s7_pointer -is_defined_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - if (args == 2) { - const s7_pointer arg2= caddr (expr); - if ((is_pair (arg2)) && (is_null (cdr (arg2)))) { - if (car (arg2) == sc->rootlet_symbol) return (sc->is_defined_in_rootlet); - if (car (arg2) == sc->unlet_symbol) { - set_fn_direct (arg2, g_unlet_disabled); - return (sc->is_defined_in_unlet); - } +static s7_pointer let_fill(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer let = car(args); + s7_pointer val; + if (let == sc->rootlet) + out_of_range_error_nr(sc, sc->fill_symbol, int_one, let, wrap_string(sc, "can't fill! rootlet", 19)); + if (let == sc->starlet) + out_of_range_error_nr(sc, sc->fill_symbol, int_one, let, wrap_string(sc, "can't fill! *s7*", 16)); + /* (owlet) copies sc->owlet, so let can't be sc->owlet */ + if (is_funclet(let)) + out_of_range_error_nr(sc, sc->fill_symbol, int_one, let, wrap_string(sc, "can't fill! a funclet", 21)); + val = cadr(args); + for (s7_pointer slot = let_slots(let); is_not_slot_end(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 let) +{ + /* used by length, applicable_length, copy, and some length optimizations */ + if (let == sc->rootlet) + { + s7_int i = 0; + for (s7_pointer slot = sc->rootlet_slots; is_not_slot_end(slot); i++, slot = next_slot(slot)); + return(i); } + if (let == sc->starlet) + return(starlet_length()); + if (has_active_methods(sc, let)) + { + s7_pointer length_func = find_method(sc, let, sc->length_symbol); + if (length_func != sc->undefined) + { + s7_pointer num = s7_apply_function(sc, length_func, set_plist_1(sc, let)); + return((s7_is_integer(num)) ? s7_integer(num) : -1); /* ?? */ + }} + { + s7_int i = 0; + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); i++, slot = next_slot(slot)); + return(i); } - 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_bound_symbol (sc, symbol)); +void slot_set_setter(s7_pointer slot, s7_pointer val) +{ + if ((type(val) == T_C_FUNCTION) && + (c_function_has_bool_setter(val))) + slot_set_setter_1(slot, c_function_bool_setter(val)); + else slot_set_setter_1(slot, val); } -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_bound_symbol (sc, sym)); +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 bool -is_defined_b_7pp (s7_scheme* sc, s7_pointer sym, s7_pointer let) { - return (g_is_defined (sc, set_plist_2 (sc, sym, let)) != sc->F); +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 let) +{ + for (s7_pointer slot = let_slots(let); is_not_slot_end(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(let); } -void -s7_define (s7_scheme* sc, s7_pointer let, s7_pointer symbol, - s7_pointer value) /* assumes let is a let */ +static s7_pointer funclet_entry(s7_scheme *sc, s7_pointer x, s7_pointer sym) { - 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)); + 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 let = closure_let(value); + if ((is_let(let)) && (!let_removed(let)) && (let != sc->shadow_rootlet)) + { + let = let_outlet(let); + if ((is_let(let)) && (!let_removed(let)) && (let != sc->shadow_rootlet)) + { + remove_let_from_heap(sc, let); + let = let_outlet(let); + if ((is_let(let)) && (!let_removed(let)) && (let != sc->shadow_rootlet)) + remove_let_from_heap(sc, let); + }}} } -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); +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; } -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); +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_define_constant_with_environment (s7_scheme* sc, s7_pointer let, - const char* name, s7_pointer value) { - const s7_pointer sym= make_symbol_with_strlen (sc, name); - s7_define (sc, T_Let (let), 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_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(sc, 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 lets 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 lets -- 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 */ } -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)); +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); } -/* (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? */ -} +/* -------------------------------- let? -------------------------------- */ +bool s7_is_let(s7_pointer let) {return(is_let(let));} -/* -------------------------------- keyword? -------------------------------- */ -bool -s7_is_keyword (s7_pointer obj) { - return (is_symbol_and_keyword (obj)); -} +/* g_is_let is now defined in s7_scheme_predicate.c */ + #define H_is_let "(let? obj) returns #t if obj is a let." + #define Q_is_let sc->pl_bt -#define H_is_keyword \ - "(keyword? obj) returns #t if obj is a keyword, (keyword? :rest) -> #t" -#define Q_is_keyword sc->pl_bt -/* g_is_keyword is now defined in s7_scheme_predicate.c */ +/* -------------------------------- funclet? -------------------------------- */ +/* g_is_funclet is now defined in s7_scheme_predicate.c */ + #define H_is_funclet "(funclet? obj) returns #t if obj is a funclet (a function's environment)." + #define Q_is_funclet sc->pl_bt -/* -------------------------------- 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); - } -} -/* g_string_to_keyword migrated to s7_scheme_symbol.c */ -#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) +/* -------------------------------- unlet -------------------------------- */ +/* g_unlet moved to s7_scheme_let.c */ + #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) -/* -------------------------------- keyword->symbol - * -------------------------------- */ -/* g_keyword_to_symbol migrated to s7_scheme_symbol.c */ -#define H_keyword_to_symbol \ - "(keyword->symbol key) returns a symbol with the same name as key but no " \ - "prepended or appended colon" -#define Q_keyword_to_symbol \ - s7_make_signature (sc, 2, sc->is_symbol_symbol, sc->is_keyword_symbol) -s7_pointer -s7_keyword_to_symbol (s7_scheme* sc, s7_pointer key) { - return (keyword_symbol (key)); -} +/* -------------------------------- openlet? -------------------------------- */ +/* s7_is_openlet moved to s7_scheme_let.c */ + +/* g_is_openlet is now defined in s7_scheme_predicate.c */ + #define H_is_openlet "(openlet? obj) returns #t if 'obj' has methods." + #define Q_is_openlet sc->pl_bt -/* -------------------------------- symbol->keyword - * -------------------------------- */ -#define symbol_to_keyword(Sc, Sym) s7_make_keyword (Sc, symbol_name (Sym)) -/* g_symbol_to_keyword migrated to s7_scheme_symbol.c */ -#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) +/* -------------------------------- openlet -------------------------------- */ +/* s7_openlet moved to s7_scheme_let.c */ -/* -------------------------------- c-pointer? -------------------------------- - */ -bool -s7_is_c_pointer (s7_pointer arg) { - return (is_c_pointer (arg)); -} +/* g_openlet moved to s7_scheme_let.c */ + #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)) -bool -s7_is_c_pointer_of_type (s7_pointer arg, s7_pointer type) { - return ((is_c_pointer (arg)) && (c_pointer_type (arg) == type)); -} +/* -------------------------------- coverlet -------------------------------- */ +/* g_coverlet moved to s7_scheme_let.c */ + #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)) -/* g_is_c_pointer is now defined in s7_scheme_predicate.c */ -#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) -/* -------------------------------- 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); -} +/* -------------------------------- varlet -------------------------------- */ +/* check_let_fallback moved to s7_scheme_let.c */ -s7_pointer -s7_make_c_pointer (s7_scheme* sc, void* ptr) { - return (s7_make_c_pointer_with_type (sc, ptr, sc->F, sc->F)); -} +/* append_let moved to s7_scheme_let.c */ -#define NUM_C_POINTER_WRAPPERS 16 /* need at least 9 for gsl */ +/* s7_varlet moved to s7_scheme_let.c */ -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_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); - } +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); } -/* -------------------------------- 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)); +s7_int s7i_position_of(const s7_pointer p, s7_pointer args) +{ + return((s7_int)position_of(p, args)); } -/* g_c_pointer_info is now defined in s7_scheme_predicate.c */ -#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) +/* g_varlet moved to s7_scheme_let.c */ + #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) -/* -------------------------------- 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); -} +/* -------------------------------- cutlet -------------------------------- */ +/* g_cutlet moved to s7_scheme_let.c */ + #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) -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)); -} -/* g_c_pointer_type is now defined in s7_scheme_predicate.c */ -#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) +/* -------------------------------- sublet -------------------------------- */ +/* sublet_1 moved to s7_scheme_let.c */ -/* -------------------------------- 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)); -} +/* s7_sublet moved to s7_scheme_let.c */ -/* g_c_pointer_weak1 is now defined in s7_scheme_predicate.c */ -#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) +/* g_sublet moved to s7_scheme_let.c */ + #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 -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)); -} +/* g_sublet_curlet moved to s7_scheme_let.c */ -/* g_c_pointer_weak2 is now defined in s7_scheme_predicate.c */ -#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) - -/* -------------------------------- 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))); -} - -s7_pointer b_simple_setter (s7_scheme* sc, int32_t typer, s7_pointer args); +/* sublet_chooser moved to s7_scheme_let.c */ -#include "s7_continuation.h" -/* -------------------------------- 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); -} +/* -------------------------------- inlet -------------------------------- */ +/* s7_inlet moved to s7_scheme_let.c */ + #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) -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); -} +#define g_inlet s7_inlet -static s7_pointer -block_to_string (s7_scheme* sc, block_t* block, s7_int len) { - return (inline_block_to_string (sc, block, len)); -} +/* g_simple_inlet moved to s7_scheme_let.c */ -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); -} +/* inlet_p_pp moved to s7_scheme_let.c */ -static /* inline */ s7_pointer -make_simpler_ratio (s7_scheme* sc, s7_int num, - s7_int den) /* no gcd needed, and den > 1 */ +/* internal_inlet moved to s7_scheme_let.c */ + +bool is_proper_quote(s7_scheme *sc, s7_pointer p) { - 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); + return((is_safe_quoted_pair(sc, p)) && + (is_pair(cdr(p))) && + (is_null(cddr(p)))); } -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); - -/* is_NaN is declared in s7_scheme_inexact.h and defined in s7_scheme_inexact.c - */ -/* callgrind says this is faster than isnan, I think (very confusing data...) */ +/* inlet_chooser moved to s7_scheme_let.c */ -#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 */ +/* -------------------------------- let->list -------------------------------- */ +s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list); -static s7_pointer -make_nan_with_payload (s7_scheme* sc, s7_int payload) { - return (make_real (sc, nan_with_payload (payload))); -} +/* abbreviate_let moved to s7_scheme_let.c */ -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_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 */ +/* s7_let_to_list moved to s7_scheme_let.c */ -/* -------- gmp stuff -------- */ +/* g_let_to_list moved to s7_scheme_let.c */ + #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)) -#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 +/* -------------------------------- let-ref -------------------------------- */ +/* call_let_ref_fallback moved to s7_scheme_let.c */ -/* s7_int_abs is defined in s7_internal_helpers.h */ -/* can't use abs even in gcc -- it doesn't work with s7_ints! */ +/* call_let_set_fallback moved to s7_scheme_let.c */ -#if !__NetBSD__ -#define s7_fabsl(X) fabsl (X) -#else -static double -s7_fabsl (long_double x) { - return ((signbit (x)) ? -x : x); -} -#endif +/* g_unlet_disabled is now defined in s7_scheme_predicate.c */ +/* 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 */ -/* 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)); -} +/* let_ref moved to s7_scheme_let.c */ -#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 +/* s7_let_ref moved to s7_scheme_let.c */ -#if !HAVE_COMPLEX_TRIG -#if __cplusplus +/* g_let_ref moved to s7_scheme_let.c */ + #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) -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 +/* slot_in_let moved to s7_scheme_let.c */ -#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 */ +/* let_ref_p_pp moved to s7_scheme_let.c */ -#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 +/* g_cdr_let_ref moved to s7_scheme_let.c */ -#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 +s7_pointer starlet(s7_scheme *sc, s7_int choice); +/* g_starlet_ref moved to s7_scheme_let.c */ -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) { - return (is_t_integer (p)); -} +/* g_rootlet_ref moved to s7_scheme_let.c */ -bool -s7_is_ratio (s7_pointer p) { - return (is_t_ratio (p)); -} +/* let_ref_chooser moved to s7_scheme_let.c */ -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)); +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); } -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); +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); } -#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 +static s7_pointer fx_implicit_let_ref_c(s7_scheme *sc, s7_pointer arg) { - s7_pointer new_int; - new_cell (sc, new_int, T_INTEGER | T_MUTABLE); -#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 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))); } -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); - 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 +/* -------------------------------- let-set! -------------------------------- */ +/* let_set_1 moved to s7_scheme_let.c */ -s7_pointer -s7_make_mutable_real (s7_scheme* sc, s7_double n) { - s7_pointer x; - new_cell (sc, x, T_REAL | T_MUTABLE); - set_real (x, n); - return (x); -} +/* let_set_2 moved to s7_scheme_let.c */ -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); -} +/* s7_let_set moved to s7_scheme_let.c */ -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); /* do we need to change to real if imag==0? */ - set_real_part (x, rl); - set_imag_part (x, im); - return (x); -} +/* g_let_set moved to s7_scheme_let.c */ + #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) -static s7_complex -s7_to_c_complex (s7_pointer z) { -#if HAVE_COMPLEX_NUMBERS - return (CMPLX (s7_real_part (z), s7_imag_part (z))); -#else - return (0.0); -#endif -} +/* let_set_p_ppp_2 moved to s7_scheme_let.c */ -static inline s7_pointer -c_complex_to_s7 (s7_scheme* sc, s7_complex z) { - return (make_complex (sc, creal (z), cimag (z))); -} +/* g_cdr_let_set moved to s7_scheme_let.c */ -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)); -} +s7_pointer starlet_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val); -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)); -} +/* g_starlet_set moved to s7_scheme_let.c */ -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); - } -} +/* g_unlet_set moved to s7_scheme_let.c */ -/* 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)); -} +/* let_set_chooser moved to s7_scheme_let.c */ -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 +/* reverse_slots moved to s7_scheme_let.c */ -#define INT64_TO_DOUBLE_LIMIT (1LL << 53) -#define DOUBLE_TO_INT64_LIMIT (1LL << 53) +/* let_copy moved to s7_scheme_let.c */ -/* 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. + +/* -------------------------------- rootlet -------------------------------- */ +/* g_rootlet is now defined in s7_scheme_predicate.c */ + #define H_rootlet "(rootlet) returns the current top-level definitions (symbol bindings)." + #define Q_rootlet s7_make_signature(sc, 1, sc->is_let_symbol) + +/* s7_rootlet moved to s7_scheme_let.c */ + +/* 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_shadow_rootlet moved to s7_scheme_let.c */ -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)); - 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)); - default: - sole_arg_wrong_type_error_nr (sc, caller, x, sc->type_names[T_REAL]); - } - return (0.0); -} +/* s7_set_shadow_rootlet moved to s7_scheme_let.c */ -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)); - sole_arg_wrong_type_error_nr (sc, - wrap_string (sc, caller, safe_strlen (caller)), - x, sc->type_names[T_INTEGER]); - return (0); -} +/* -------------------------------- curlet -------------------------------- */ +/* s7_curlet moved to s7_scheme_let.c */ -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")); -} +/* g_curlet is now defined in s7_scheme_predicate.c */ +#define H_curlet "(curlet) returns the current definitions (symbol bindings)" +#define Q_curlet s7_make_signature(sc, 1, sc->is_let_symbol) -s7_int -s7_numerator (s7_pointer x) { - switch (type (x)) { - case T_INTEGER: - return (integer (x)); - case T_RATIO: - return (numerator (x)); - } - return (0); -} +/* update_symbol_ids moved to s7_scheme_let.c */ -s7_int -s7_denominator (s7_pointer x) { - if (is_t_ratio (x)) return (denominator (x)); - return (1); -} +/* s7_set_curlet moved to s7_scheme_let.c */ -s7_int -s7_integer (s7_pointer p) { - if (is_t_integer (p)) return (integer (p)); - 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)); - } - return (0.0); -} +/* -------------------------------- outlet -------------------------------- */ +/* s7_outlet moved to s7_scheme_let.c */ -static bool -is_one (s7_pointer x) { - return (((is_t_integer (x)) && (integer (x) == 1)) || - ((is_t_real (x)) && (real (x) == 1.0))); -} +/* outlet_p_p moved to s7_scheme_let.c */ -/* -------- optimize exponents -------- */ +/* g_outlet_unlet migrated to s7_scheme_predicate.c */ -#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]); -} +/* s7i_outlet_p_p moved to s7_scheme_let.c */ -/* dtoa (Grisu2 double-to-ASCII) is now in s7_dtoa.c */ -#ifndef WITH_DTOA -#define WITH_DTOA 1 -#endif +#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)) -/* -------------------------------- number->string - * -------------------------------- */ -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); -} +/* outlet_chooser moved to s7_scheme_let.c */ + +/* g_set_outlet moved to s7_scheme_let.c */ -const char* -integer_to_string (s7_scheme* sc, s7_int num, - s7_int* nlen) /* do not free the returned string */ +/* -------------------------------- symbol lookup -------------------------------- */ +static Inline s7_pointer inline_lookup_from(s7_scheme *sc, const s7_pointer symbol, s7_pointer let) { - char *p, *op; - bool sign= (num < 0); - if (sign) { - if (num == S7_INT64_MIN) { - (*nlen)= 20; - return ((const char*) "-9223372036854775808"); + /* 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(let) == symbol_id(symbol)) + return(local_value(symbol)); + if (let_id(let) > symbol_id(symbol)) /* let is newer so look back in the outlet chain */ + { + do {let = let_outlet(let);} while (let_id(let) > symbol_id(symbol)); + if (let_id(let) == symbol_id(symbol)) + return(local_value(symbol)); } - 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); + for (; let; let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(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 } -const char* -integer_to_string_no_length (s7_scheme* sc, - s7_int num) /* do not free the returned string */ +#if WITH_GCC && S7_DEBUGGING +s7_pointer lookup_1(s7_scheme *sc, const s7_pointer symbol) +#else +s7_pointer lookup(s7_scheme *sc, const s7_pointer symbol) /* lookup_checked includes the unbound_variable call */ +#endif { - 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); + return(inline_lookup_from(sc, symbol, sc->curlet)); } -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; - } +s7_pointer s7i_lookup_p_p(s7_scheme *sc, s7_pointer symbol) {return(lookup(sc, symbol));} + +static inline s7_pointer lookup_slot_from(s7_pointer symbol, s7_pointer let) +{ + if (let_id(let) == symbol_id(symbol)) + return(T_Slt(local_slot(symbol))); + if (let_id(let) > symbol_id(symbol)) + { + do {let = let_outlet(let);} while (let_id(let) > symbol_id(symbol)); + if (let_id(let) == symbol_id(symbol)) + return(T_Slt(local_slot(symbol))); } - str[len] = '.'; - str[len + 1]= '0'; - str[len + 2]= '\0'; - (*nlen) = len + 2; - } - return (str); + for (; let; let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(T_Slt(slot)); + return(T_Sld(global_slot(symbol))); /* # when (define x ...) and x is not yet defined */ } -void -insert_spaces (s7_scheme* sc, const char* src, s7_int width, s7_int len) { - s7_int spaces= width - len; - if ((spaces <= 0) || (len <= 0)) return; - 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); -} +s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol) {return(lookup_slot_from(symbol, sc->curlet));} -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; - } +static s7_pointer lookup_slot_with_let(s7_scheme *sc, s7_pointer symbol, s7_pointer let) {return(lookup_slot_from(symbol, let));} - /* 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); - } +s7_pointer s7_slot_value(s7_pointer slot) {return(slot_value(slot));} - 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); - } +s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value) {slot_set_value(slot, value); return(value);} - 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)); +void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value) {set_real(slot_value(slot), value);} - sc->num_to_str[0]= '\0'; - number_to_string_base_10 (sc, wrap_real (sc, real_part (obj)), 0, precision, - float_choice, &len, choice); +s7_pointer symbol_to_local_slot(s7_scheme *sc, s7_pointer symbol, s7_pointer let) /* assumes e is a let */ +{ + if (T_Let(let) == 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(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == symbol) + return(slot); + return(sc->undefined); +} - 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); +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); +} - if (width > len) /* (format #f "~20g" 1+i) */ +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)) { - insert_spaces (sc, sc->num_to_str, width, - len); /* this checks sc->num_to_str_size */ - (*nlen)= width; + do {let = let_outlet(let);} while (let_id(let) > symbol_id(sym)); + if (let_id(let) == symbol_id(sym)) + return(local_value(sym)); } - else (*nlen)= len; - return (sc->num_to_str); - } + for (; let; let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + return(slot_value(slot)); - /* 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); + /* 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 */ } -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 (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); -} +/* -------------------------------- symbol->value -------------------------------- */ +#define lookup_global(Sc, Sym) ((is_defined_global(Sym)) ? global_value(Sym) : lookup_checked(Sc, Sym)) + +/* g_symbol_to_value moved to s7_scheme_let.c */ + #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)) -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, sc->float_format_precision, 'g', &nlen); - char* str= copy_string_with_length ((char*) block_data (b), nlen); - liberate (sc, b); - return (str); +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); } -#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) -/* ctables moved to s7_ctables.c */ +/* symbol_to_value_chooser moved to s7_scheme_let.c */ -#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; - const bool need_loader_port= is_loader_port (current_input_port (sc)); +/* -------------------------------- symbol->dynamic-value -------------------------------- */ +/* find_dynamic_value moved to s7_scheme_let.c */ - /* *#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 args= sc->F, 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); +/* g_symbol_to_dynamic_value moved to s7_scheme_let.c */ + #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) + +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 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 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 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 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); } -/* bridges for s7_scheme_read.c */ -void -s7i_backchar (char c, s7_pointer port) { - backchar (c, port); +static bool do_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer var_list) +{ + return((is_slot(global_slot(sym))) || + (direct_assq(sym, var_list)) || + (is_bound_symbol(sc, sym))); } -void -s7i_resize_strbuf (s7_scheme* sc, s7_int needed_size) { - resize_strbuf (sc, needed_size); + +static bool let_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer var_list) +{ + if (is_slot(global_slot(sym))) + return(true); + if (var_list == sc->rootlet) + return(false); + return((!is_with_let_let(var_list)) && (is_bound_symbol(sc, sym))); } -bool -s7i_is_loader_port (s7_pointer p) { - return (is_loader_port (p)); + +static bool let_symbol_is_safe_or_listed(s7_scheme *sc, s7_pointer sym, s7_pointer var_list) +{ + return((symbol_is_in_big_symbol_set(sc, sym)) || + (let_symbol_is_safe(sc, sym, var_list))); } -s7_pointer* chars; +static bool let_star_symbol_is_safe(s7_scheme *sc, s7_pointer sym, s7_pointer var_list) +{ + return((symbol_is_in_big_symbol_set(sc, sym)) || + (is_slot(global_slot(sym))) || + ((is_let(var_list)) && (!is_with_let_let(var_list)) && (is_bound_symbol(sc, sym)))); +} -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 bool pair_symbol_is_safe(s7_scheme *unused_sc, s7_pointer sym, s7_pointer symbols) +{ + return((is_slot(global_slot(sym))) || + (direct_memq(sym, symbols))); /* optimize_syntax pushes :if (and others like () I think) on this list */ } -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 collect_variables(s7_scheme *sc, s7_pointer lst, s7_pointer var_list) +{ + /* collect local variable names from let/do (pre-error-check), 20 overhead in tgen -> 14 if cons_unchecked below */ + begin_temp(sc->y, var_list); + 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 -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); +static s7_pointer collect_parameters(s7_scheme *sc, s7_pointer lst, s7_pointer var_list) +{ + /* 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), var_list)); + } + begin_temp(sc->y, var_list); + 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); +} - 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 (sc, sym))) -#if 0 - return(initial_value(sym)); -#else +static void clear_all_optimizations(s7_scheme *sc, s7_pointer p) +{ + if (is_unquoted_pair(sc, p)) { - if (!is_initial_value (initial_value (sym))) copy_initial_value (sc, sym); - return (initial_value (sym)); + 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)); } -#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); - } +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)); +} - 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); - } +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); +} - /* -------- #\... -------- */ - 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]); +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))); +} - if (c_strings_are_equal (name + 1, "newline")) - return (chars[(uint8_t) '\n']); - break; +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); +} - 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")) */ +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 let_or_list); - 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 new_int - * is -593310740 -> segfault unless caught - */ - bool happy = true; - const char* tmp = (const char*) (name + 2); - int32_t new_int= 0; - - while ((*tmp) && (happy) && (new_int >= 0) && (new_int < 0x110000)) { - int32_t dig= digits[(int32_t) (*tmp++)]; - if (dig < 16) new_int= dig + (new_int * 16); - else happy= false; - } - if ((happy) && (new_int >= 0) && (new_int < 0x110000)) - return (s7_make_character (sc, (uint32_t) new_int)); - } +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; } - /* 尝试解析为多字节 UTF-8 字符 */ + 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) { - int32_t nlen= safe_strlen (name); - if (nlen >= 3 && nlen <= 5) { - uint32_t cp= 0; - const uint8_t* u = (const uint8_t*) (name + 1); - if (nlen == 3 && (u[0] & 0xE0) == 0xC0 && (u[1] & 0xC0) == 0x80) { - cp= ((u[0] & 0x1F) << 6) | (u[1] & 0x3F); - if (cp >= 0x80) return (s7_make_character (sc, cp)); - } - else if (nlen == 4 && (u[0] & 0xF0) == 0xE0 && (u[1] & 0xC0) == 0x80 && - (u[2] & 0xC0) == 0x80) { - cp= ((u[0] & 0x0F) << 12) | ((u[1] & 0x3F) << 6) | (u[2] & 0x3F); - if (cp >= 0x800 && (cp < 0xD800 || cp > 0xDFFF)) - return (s7_make_character (sc, cp)); - } - else if (nlen == 5 && (u[0] & 0xF8) == 0xF0 && (u[1] & 0xC0) == 0x80 && - (u[2] & 0xC0) == 0x80 && (u[3] & 0xC0) == 0x80) { - cp= ((u[0] & 0x07) << 18) | ((u[1] & 0x3F) << 12) | - ((u[2] & 0x3F) << 6) | (u[3] & 0x3F); - if (cp >= 0x10000 && cp <= 0x10FFFF) - return (s7_make_character (sc, cp)); - } - } - } - } - return (unknown_sharp_constant (sc, name, NULL)); -} + 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)); -/* bridge for s7_scheme_read.c */ -s7_pointer -s7i_make_sharp_constant (s7_scheme* sc, const char* name, bool with_error, - s7_pointer port, bool error_if_bad_number) { - return ( - make_sharp_constant (sc, name, with_error, port, error_if_bad_number)); -} - -static const char* radstr[17]= {NULL, - NULL, - "01", - "012", - "0123", - "01234", - "012345", - "0123456", - "01234567", - "012345678", - "0123456789", - "0123456789aA", - "0123456789aAbB", - "0123456789aAbBcC", - "0123456789aAbBcCdD", - "0123456789aAbBcCdDeE", - "0123456789aAbBcCdDeEfF"}; - -static s7_double -string_to_double_with_radix (const char* ur_str, int32_t radix) { - /* Use simple implementation for base 10 to avoid precision issues on Windows - */ - if (radix == 10) return s7_string_to_double_simple (ur_str, radix); + /* 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 */ - /* 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 (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. */ - if (*str == '-') { - str++; - sign= -1; - } - else if (*str == '+') str++; - while (*str == '0') { - str++; - }; + return(mac); +} - 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; +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_unchecked(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); +} - 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 */ +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 -- this code is repetitive but faster */ + 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) { -#if HAVE_OVERFLOW_CHECKS - if ((int32_multiply_overflow (exponent, 10, &exponent)) || - (int32_add_overflow (exponent, dig, &exponent))) { - exponent= 1000000; /* see below */ - break; - } + 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 clo) +{ + /* we can't use let_length(sc, closure_let(clo)) 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(clo), sc->length_symbol); + if (length_func != sc->undefined) + return((int32_t)s7_integer(s7_apply_function(sc, length_func, set_plist_1(sc, clo)))); + /* 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_unchecked(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(sc, car(_p))) ? copy_tree_with_type(sc, car(_p)) : car(_p), \ + (is_unquoted_pair(sc, cdr(_p))) ? copy_tree_with_type(sc, cdr(_p)) : cdr(_p));}) #else - exponent= dig + (exponent * 10); + #define COPY_TREE_WITH_TYPE(P) copy_tree_with_type(sc, P) #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 */ + return(cons_unchecked_with_type(sc, tree, + (is_unquoted_pair(sc, car(tree))) ? COPY_TREE_WITH_TYPE(car(tree)) : car(tree), + (is_unquoted_pair(sc, 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(sc, 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 - 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 - */ - } + return(cons_unchecked(sc, + (is_unquoted_pair(sc, car(tree))) ? COPY_TREE(car(tree)) : car(tree), + (is_pair(cdr(tree))) ? COPY_TREE(cdr(tree)) : cdr(tree))); +} - 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; - } +/* -------------------------------- tree-cyclic? -------------------------------- */ +/* tree_is_cyclic, g_tree_is_cyclic migrated to s7_liii_tree.c */ - /* 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 (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); - } +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)); +} - /* 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); +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); } - 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); - } + 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); +} - 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); - } - } - } - return (sign * dval); +/* -------------------------------- defined? -------------------------------- */ +/* g_is_defined moved to s7_scheme_let.c */ + #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) + +static s7_pointer is_defined_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 2) + { + const s7_pointer arg2 = caddr(expr); + if ((is_pair(arg2)) && (is_null(cdr(arg2)))) + { + if (car(arg2) == sc->rootlet_symbol) + return(sc->is_defined_in_rootlet); + if (car(arg2) == sc->unlet_symbol) + { + set_fn_direct(arg2, g_unlet_disabled); + return(sc->is_defined_in_unlet); + }}} + return(func); } -static s7_pointer -make_undefined_overflow (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); - liberate (sc, b); - return (result); +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_bound_symbol(sc, symbol)); } -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 */ +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_bound_symbol(sc, sym)); +} + +static bool is_defined_b_7pp(s7_scheme *sc, s7_pointer sym, s7_pointer let) {return(g_is_defined(sc, set_plist_2(sc, sym, let)) != 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)); } - } - 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); +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); } -#if WITH_NUMBER_SEPARATOR +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); +} -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; +s7_pointer s7_define_constant_with_environment(s7_scheme *sc, s7_pointer let, const char *name, s7_pointer value) +{ + const s7_pointer sym = make_symbol_with_strlen(sc, name); + s7_define(sc, T_Let(let), 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); +} - 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= s7i_string_to_number (sc, new_name, radix); - liberate (sc, b); - return (result); - } +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)); } -#endif -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= - s7_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, s7_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; +/* (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 + */ - 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; +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? */ +} - 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); +/* -------------------------------- keyword? -------------------------------- */ +bool s7_is_keyword(s7_pointer obj) {return(is_symbol_and_keyword(obj));} + +#define H_is_keyword "(keyword? obj) returns #t if obj is a keyword, (keyword? :rest) -> #t" +#define Q_is_keyword sc->pl_bt - case '0': /* these two are always digits */ - case '1': - break; +/* g_is_keyword is now defined in s7_scheme_predicate.c */ - 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 */ +/* -------------------------------- 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'; { - 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; - bool overflow = false; /* for string_to_integer */ - 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; + 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); + } +} - /* -------- 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= - s7_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; +/* g_string_to_keyword migrated to s7_scheme_symbol.c */ +#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) - 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); +/* -------------------------------- keyword->symbol -------------------------------- */ +/* g_keyword_to_symbol migrated to s7_scheme_symbol.c */ +#define H_keyword_to_symbol "(keyword->symbol key) returns a symbol with the same name as key but no prepended or appended colon" +#define Q_keyword_to_symbol s7_make_signature(sc, 2, sc->is_symbol_symbol, sc->is_keyword_symbol) -#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 +s7_pointer s7_keyword_to_symbol(s7_scheme *sc, s7_pointer key) {return(keyword_symbol(key));} - if (has_i) { - s7_double rl= 0.0, im= 0.0; - 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)); - /* look for cases like 1+i */ - q[len - 1]= ((q[len - 2] == '+') || (q[len - 2] == '-')) - ? '1' - : '\0'; /* remove 'i' */ - - (*((char*) (plus - 1)))= '\0'; - - 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= s7_string_to_integer (q, radix, &overflow); - if (overflow) return (make_undefined_overflow (sc, q)); - den= s7_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_overflow (sc, q)); /* denominator overflow */ - rl= (long_double) num / - (long_double) den; /* no gmp, so we do what we can */ - } - } - } - else { - rl= (s7_double) s7_string_to_integer (q, radix, &overflow); - if (overflow) return (make_undefined_overflow (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= s7_string_to_integer (plus, radix, &overflow); - if (overflow) return (make_undefined_overflow (sc, q)); - den= s7_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_overflow (sc, q)); /* denominator overflow */ - im= (long_double) num / (long_double) den; - } - } - } - else { - im= (s7_double) s7_string_to_integer (plus, radix, &overflow); - if (overflow) return (make_undefined_overflow (sc, q)); - } - } - if ((has_plus_or_minus == -1) && (im != 0.0)) im= -im; - result= make_complex (sc, rl, im); - /* restore original string */ - q[len - 1] = ql1; - (*((char*) (plus - 1)))= pl1; - return (result); - } +/* -------------------------------- symbol->keyword -------------------------------- */ +#define symbol_to_keyword(Sc, Sym) s7_make_keyword(Sc, symbol_name(Sym)) - /* 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); +/* g_symbol_to_keyword migrated to s7_scheme_symbol.c */ +#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) - result= make_real (sc, string_to_double_with_radix (q, radix)); - return (result); - } - /* rational */ - if (slash1) { - s7_int d; - const s7_int n= s7_string_to_integer (q, radix, &overflow); - if (overflow) return (make_undefined_overflow (sc, q)); - d= s7_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_overflow (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)); - } - /* integer */ - { - s7_int x= s7_string_to_integer (q, radix, &overflow); - if (overflow) return (make_undefined_overflow (sc, q)); - return (make_integer (sc, x)); - } - } +/* -------------------------------- 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));} + +/* g_is_c_pointer is now defined in s7_scheme_predicate.c */ + #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) + + +/* -------------------------------- 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); } -/* -------------------------------- string->number - * -------------------------------- */ -#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) -/* g_string_to_number is now defined in s7_liii_string.c */ +s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr) {return(s7_make_c_pointer_with_type(sc, ptr, sc->F, sc->F));} -/* (abs|magnitude -9223372036854775808) won't work here */ +#define NUM_C_POINTER_WRAPPERS 16 /* need at least 9 for gsl */ -/* -------------------------------- inexact helpers - * -------------------------------- */ -#if !HAVE_COMPLEX_NUMBERS -static s7_pointer no_complex_numbers_string; +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_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); +} -/* -------------------------------- log -------------------------------- */ -static s7_pointer -log_chooser (s7_scheme* sc, s7_pointer func, int32_t args, s7_pointer expr) { - 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); +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); } - return (func); } -/* ---------------------------------------- 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_WARNINGS) - s7_warn (sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, - y); - return (make_real (sc, (long_double) x + (long_double) y)); - } - return (make_integer (sc, val)); -#else - return (make_integer (sc, x + y)); -#endif + +/* -------------------------------- 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)); +} + +/* g_c_pointer_info is now defined in s7_scheme_predicate.c */ + #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) + + +/* -------------------------------- 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))); } -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 */ +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) { -#if HAVE_OVERFLOW_CHECKS - s7_int z; - if ((multiply_overflow (integer (x), denominator (y), &z)) || - (add_overflow (z, numerator (y), &z))) { - 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))); - } - return (make_ratio (sc, z, denominator (y))); -#else - return (make_ratio (sc, integer (x) * denominator (y) + numerator (y), - denominator (y))); -#endif + return((is_c_pointer(cptr)) ? c_pointer_type(cptr) : method_or_bust_lp(sc, cptr, sc->c_pointer_type_symbol, T_C_POINTER)); } -#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% */ +/* g_c_pointer_type is now defined in s7_scheme_predicate.c */ + #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) -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 (is_t_real (y)) - return (make_real (sc, (long_double) integer (x) + real (y))); - } - else if (is_t_real (x)) { - if (is_t_real (y)) return (make_real (sc, real (x) + real (y))); - } - else if ((is_t_complex (x)) && (is_t_complex (y))) - return (make_complex (sc, real_part (x) + real_part (y), - imag_part (x) + imag_part (y))); - switch (type (x)) { - case T_INTEGER: - switch (type (y)) { - case T_INTEGER: - return (add_if_overflow_to_real_or_big_integer (sc, integer (x), - integer (y))); - case T_RATIO: - return (integer_ratio_add_if_overflow_to_real_or_rational (sc, x, y)); - case T_REAL: - 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))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->add_symbol, x, y, - a_number_string, 2)); - } +/* -------------------------------- 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)); +} - 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_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)); - } - 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 - } +/* g_c_pointer_weak1 is now defined in s7_scheme_predicate.c */ +#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) -#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_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))); - } - 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))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->add_symbol, x, y, - a_number_string, 2)); - } +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)); +} - case T_REAL: - switch (type (y)) { - case T_INTEGER: - 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))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->add_symbol, x, y, - a_number_string, 2)); - } +/* g_c_pointer_weak2 is now defined in s7_scheme_predicate.c */ +#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) - 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))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->add_symbol, x, y, - a_number_string, 2)); - } - default: - return ( - method_or_bust_pp (sc, x, sc->add_symbol, x, y, a_number_string, 1)); - } +/* -------------------------------- 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))); } -s7_pointer -s7i_add_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (add_p_pp (sc, x, y)); +s7_pointer b_simple_setter(s7_scheme *sc, int32_t typer, s7_pointer args); + +#include "s7_continuation.h" + + +/* -------------------------------- 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 -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 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 -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 (is_t_real (y)) - return (wrap_real (sc, (long_double) integer (x) + real (y))); - } - 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))); - } +static s7_pointer block_to_string(s7_scheme *sc, block_t *block, s7_int len) {return(inline_block_to_string(sc, block, len));} - 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))); +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); } - - 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))); + 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 (add_p_pp (sc, x, y)); + return(new_ratio); } -s7_pointer -s7i_add_p_pp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (add_p_pp_wrapped (sc, x, y)); +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 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_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))); -#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); - } +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); } -s7_pointer -s7i_add_p_ppp (s7_scheme* sc, s7_pointer x, s7_pointer y, s7_pointer z) { - return (add_p_ppp (sc, x, y, z)); -} +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 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))); +/* is_NaN is declared in s7_scheme_inexact.h and defined in s7_scheme_inexact.c */ +/* 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 - return (wrap_integer (sc, integer (x) + integer (y) + integer (z))); + 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 - } - 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); - } -} +#endif /* windows */ +#endif /* not sun */ -s7_pointer -s7i_add_p_ppp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y, - s7_pointer z) { - return (add_p_ppp_wrapped (sc, x, y, z)); -} -static s7_pointer -g_add (s7_scheme* sc, s7_pointer args) { -#define H_add "(+ ...) adds its arguments" -#define Q_add sc->pcl_n +static s7_pointer make_nan_with_payload(s7_scheme *sc, s7_int payload) +{ + return(make_real(sc, nan_with_payload(payload))); +} - 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_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))); - 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); -} - -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)); -} -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))); - 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))); - 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 (sc, 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_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_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)))); } -static s7_pointer g_random_i (s7_scheme* sc, s7_pointer args); +/* no similar support for +inf.0 because inf is just a single bit pattern in ieee754 */ -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) - sole_arg_out_of_range_error_nr ( - sc, sc->subtract_symbol, x, - wrap_string (sc, "most-negative-fixnum can't be negated", 37)); - 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))); - - default: - return (method_or_bust_p (sc, x, sc->subtract_symbol, a_number_string)); - } -} -s7_pointer -s7i_negate_p_p (s7_scheme* sc, s7_pointer x) { - return (negate_p_p (sc, x)); -} +/* -------- gmp stuff -------- */ -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_WARNINGS) - s7_warn (sc, 128, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", - x, y); - return (make_real (sc, (long_double) x - (long_double) y)); - } - return (make_integer (sc, val)); +#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 - return (make_integer (sc, x - y)); +#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 -} -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))); +/* s7_int_abs is defined in s7_internal_helpers.h */ +/* can't use abs even in gcc -- it doesn't work with s7_ints! */ - 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_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))); - } - return (make_ratio (sc, z, denominator (y))); +#if !__NetBSD__ + #define s7_fabsl(X) fabsl(X) #else - return (make_ratio (sc, integer (x) * denominator (y) - numerator (y), - denominator (y))); + static double s7_fabsl(long_double x) {return((signbit(x)) ? -x : x);} #endif - } - case T_REAL: - 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))); - 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_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))); - } - return (make_ratio (sc, z, denominator (x))); -#else - return (make_ratio (sc, numerator (x) - (integer (y) * denominator (x)), - denominator (x))); +/* 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 - } - 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_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)); - } - return (make_ratio_with_div_check (sc, sc->subtract_symbol, q, d1)); + + +#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 - return ( - make_ratio (sc, numerator (x) - numerator (y), denominator (x))); + +#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 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_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))); - } - 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)); +#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 - } - 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))); - 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: - 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))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->subtract_symbol, - x, y, a_number_string, 2)); - } +#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 - 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))); - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->subtract_symbol, - x, y, a_number_string, 2)); - } +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));} - default: - return (method_or_bust_pp (sc, x, sc->subtract_symbol, x, y, - a_number_string, 1)); - } +bool s7_is_integer(s7_pointer p) +{ + return(is_t_integer(p)); } -s7_pointer -s7i_subtract_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (subtract_p_pp (sc, x, y)); +bool s7_is_ratio(s7_pointer p) +{ + return(is_t_ratio(p)); } -static s7_pointer -negate_p_p_wrapped ( - s7_scheme* sc, - s7_pointer x) /* can't use "negate" because it confuses C++! */ +s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error) { - 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)); + 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 -s7i_negate_p_p_wrapped (s7_scheme* sc, s7_pointer x) { - return (negate_p_p_wrapped (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); } -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)); +#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 - return (wrap_integer (sc, x - y)); +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); +#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); } -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)); -} - -s7_pointer -s7i_subtract_p_pp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (subtract_p_pp_wrapped (sc, x, y)); -} - -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 -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))); - 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); - /* 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))); - 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))); - 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))); - default: - return (method_or_bust_pp (sc, x, sc->subtract_symbol, x, - make_integer (sc, y), a_number_string, 1)); - } - return (x); +s7_pointer s7_make_real(s7_scheme *sc, s7_double n) +{ + s7_pointer x; + new_cell(sc, x, T_REAL); + set_real(x, n); + return(x); } -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); +#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); + x->carrier_line = __LINE__; + x->gc_line = line; + x->gc_func = func; + set_real(x, n); + return(x); } - -/* ---------------------------------------- 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_WARNINGS) - s7_warn (sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", - x, y); - return (make_real (sc, (s7_double) x * (s7_double) y)); - } - return (make_integer (sc, val)); #else - return (make_integer (sc, x * y)); +#define make_mutable_real(Sc, N) s7_make_mutable_real(Sc, N) #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_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))); - } - return (make_ratio (sc, z, denominator (y))); -#else - return (make_ratio (sc, x * numerator (y), denominator (y))); -#endif +s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n) +{ + s7_pointer x; + new_cell(sc, x, T_REAL | T_MUTABLE); + set_real(x, n); + return(x); } -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: - 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))); - 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_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))); - } - 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: - 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))); - 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: - return (make_real (sc, real (x) * (long_double) integer (y))); - case T_RATIO: - 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))); - 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)); +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); } - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->multiply_symbol, - x, y, a_number_string, 2)); + else + { + new_cell(sc, x, T_COMPLEX); + set_real_part(x, a); + set_imag_part(x, b); } - - default: - return (method_or_bust_pp (sc, x, sc->multiply_symbol, x, y, - a_number_string, 1)); - } + return(x); } -s7_pointer -s7i_multiply_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (multiply_p_pp (sc, x, y)); +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); /* do we need to change to real if imag==0? */ + set_real_part(x, rl); + set_imag_part(x, im); + return(x); } -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)); +static s7_complex s7_to_c_complex(s7_pointer z) +{ +#if HAVE_COMPLEX_NUMBERS + return(CMPLX(s7_real_part(z), s7_imag_part(z))); #else - return (wrap_integer (sc, x * y)); + return(0.0); #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), - real_part (x) * imag_part (y))); - case T_REAL: - return (wrap_real_or_complex (sc, real_part (x) * real (y), - imag_part (x) * imag_part (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)); -} - -s7_pointer -s7i_multiply_p_pp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (multiply_p_pp_wrapped (sc, x, y)); -} - -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 inline s7_pointer c_complex_to_s7(s7_scheme *sc, s7_complex z) {return(make_complex(sc, creal(z), cimag(z)));} -s7_pointer -s7i_multiply_p_ppp (s7_scheme* sc, s7_pointer x, s7_pointer y, s7_pointer z) { - return (multiply_p_ppp (sc, x, y, 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 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); -} - -s7_pointer -s7i_multiply_p_ppp_wrapped (s7_scheme* sc, s7_pointer x, s7_pointer y, - s7_pointer z) { - return (multiply_p_ppp_wrapped (sc, x, y, z)); -} - -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 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 -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_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)); - 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)); +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); } - 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)); - default: - return (method_or_bust_pp (sc, x, sc->multiply_symbol, x, make_real (sc, y), - a_number_string, num)); - } - 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_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_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)); } -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)); -} +#define WITH_OVERFLOW_ERROR true +#define WITHOUT_OVERFLOW_ERROR false -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 num) { - switch (type (num)) { - case T_INTEGER: - if (integer (num) == 0) - division_by_zero_error_1_nr (sc, sc->divide_symbol, num); - return (make_simple_ratio (sc, 1, integer (num))); /* this checks for int */ - case T_RATIO: - return (make_simple_ratio (sc, denominator (num), numerator (num))); - case T_REAL: - if (real (num) == 0.0) - division_by_zero_error_1_nr (sc, sc->divide_symbol, num); - return (make_real (sc, 1.0 / real (num))); - case T_COMPLEX: - return (complex_invert (sc, num)); - - default: - if_method_exists_return_value (sc, num, sc->divide_symbol, - set_plist_1 (sc, num)); - wrong_type_error_nr (sc, sc->divide_symbol, 1, num, a_number_string); - } - return (NULL); -} +#define INT64_TO_DOUBLE_LIMIT (1LL << 53) +#define DOUBLE_TO_INT64_LIMIT (1LL << 53) -s7_pointer -s7i_invert_p_p (s7_scheme* sc, s7_pointer x) { - return (invert_p_p (sc, x)); -} +/* 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. + */ -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_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)) { - s7_int dn; - if (multiply_overflow (integer (x), denominator (y), &dn)) { - 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))); - } - 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); - 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))); - } - - 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_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)))); - } - 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))) { - 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)); - } - 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) */ - } - - default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->divide_symbol, x, - y, a_number_string, 2)); - } - - /* -------- real x -------- */ - case T_REAL: - switch (type (y)) { - case T_INTEGER: - if (integer (y) == 0) - division_by_zero_error_2_nr (sc, sc->divide_symbol, x, y); - if (is_NaN (real (x))) return (x); /* what is (/ +nan.0 0)? */ - if (is_inf (real (x))) - return ( - (real (x) > 0.0) - ? ((integer (y) > 0) ? real_infinity : real_minus_infinity) - : ((integer (y) > 0) ? real_minus_infinity : real_infinity)); - return ( - make_real (sc, (long_double) real (x) / (long_double) integer (y))); - case T_RATIO: - if (is_NaN (real (x))) return (x); - if (is_inf (real (x))) - return ( - (real (x) > 0) - ? ((numerator (y) > 0) ? real_infinity : real_minus_infinity) - : ((numerator (y) > 0) ? real_minus_infinity : real_infinity)); - return (make_real (sc, real (x) * inverted_fraction (y))); - case T_REAL: - if (is_NaN (real (y))) return (y); - if (real (y) == 0.0) - division_by_zero_error_2_nr (sc, sc->divide_symbol, x, y); - if (is_NaN (real (x))) return (x); - if (is_inf (real (y))) - return ((is_inf (real (x))) ? real_NaN : real_zero); - return (make_real (sc, real (x) / real (y))); - case T_COMPLEX: { - s7_double den, r2, i2; - if (is_NaN (real (x))) return (complex_NaN); - r2= real_part (y); - i2= imag_part (y); - if ((is_NaN (r2)) || (is_inf (r2))) return (complex_NaN); - if ((is_NaN (i2)) || (is_inf (i2))) return (complex_NaN); - den= 1.0 / (r2 * r2 + i2 * i2); - return (make_complex (sc, real (x) * r2 * den, -real (x) * i2 * den)); - } - + case T_INTEGER: return((s7_double)integer(x)); + case T_RATIO: return(fraction(x)); 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)); + 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)); default: - return (method_or_bust_with_type_and_loc_pp (sc, y, sc->divide_symbol, x, - y, a_number_string, 2)); + sole_arg_wrong_type_error_nr(sc, caller, x, sc->type_names[T_REAL]); } - - 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) */ - } - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - return (NULL); /* make the compiler happy */ + return(0.0); } -s7_pointer -s7i_divide_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (divide_p_pp (sc, x, y)); +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)); + sole_arg_wrong_type_error_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, sc->type_names[T_INTEGER]); + return(0); } -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_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_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_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_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))); - } - return (make_ratio (sc, numerator (num) / 2, denominator (num))); +s7_int s7_numerator(s7_pointer x) +{ + switch (type(x)) + { + case T_INTEGER: return(integer(x)); + case T_RATIO: return(numerator(x)); } - 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)); - - default: - return (method_or_bust_pp (sc, num, sc->divide_symbol, num, int_two, - a_number_string, 1)); - } + return(0); } -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)); +s7_int s7_denominator(s7_pointer x) +{ + if (is_t_ratio(x)) return(denominator(x)); + return(1); } -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); +s7_int s7_integer(s7_pointer p) +{ + if (is_t_integer(p)) return(integer(p)); + return(0); } -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); +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)); + } + return(0.0); } -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 bool is_one(s7_pointer x) +{ + return(((is_t_integer(x)) && (integer(x) == 1)) || + ((is_t_real(x)) && (real(x) == 1.0))); } -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) */ -} +/* -------- optimize exponents -------- */ -static s7_pointer -s7_truncate (s7_scheme* sc, s7_pointer caller, - s7_double xf) /* can't use "truncate" -- it's in unistd.h */ +#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) { - 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))); + 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 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)); -} - -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) { +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]); +} - 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))); +/* dtoa (Grisu2 double-to-ASCII) is now in s7_dtoa.c */ +#ifndef WITH_DTOA + #define WITH_DTOA 1 #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)); + +/* -------------------------------- number->string -------------------------------- */ +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; } - default: - return (method_or_bust_pp (sc, x, sc->quotient_symbol, x, y, - sc->type_names[T_REAL], 2)); - } + 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 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))); +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); } -s7_pointer -s7i_quotient_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (quotient_p_pp (sc, x, y)); +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); } -#define H_quotient \ - "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 " \ - "3) = 1" -#define Q_quotient sc->pcl_r - -/* -------------------------------- remainder -------------------------------- - */ - -#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); +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 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 x, s7_double y) { - if (y == 0.0) - division_by_zero_error_2_nr (sc, sc->remainder_symbol, wrap_real (sc, x), - real_zero); - if (is_NaN (x)) return (x); - if (is_inf (x)) return (NAN); /* match remainder_p_pp */ - return (c_rem_dbl (sc, x, y)); +void insert_spaces(s7_scheme *sc, const char *src, s7_int width, s7_int len) +{ + s7_int spaces = width - len; + if ((spaces <= 0) || (len <= 0)) return; + 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 s7_pointer -remainder_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - 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)))); +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; + } - 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)); + /* 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); } - 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)); + 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 - 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)); - } -} + 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)); -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))); -} + sc->num_to_str[0] = '\0'; + number_to_string_base_10(sc, wrap_real(sc, real_part(obj)), 0, precision, float_choice, &len, choice); -s7_pointer -s7i_remainder_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (remainder_p_pp (sc, x, y)); -} + 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); -#define H_remainder \ - "(remainder x y) returns the remainder of x/y; (remainder 10 3) = 1" -#define Q_remainder sc->pcl_r + 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); + } -/* -------------------------------- 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); + /* 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 s7_int -modulo_i_ii_unchecked (s7_int i1, s7_int i2) /* here we know i2 > 1 */ +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) { - s7_int z= i1 % i2; - return ((z < 0) ? (z + i2) : z); -} + /* 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; -static s7_double -modulo_d_7dd (s7_scheme* sc, s7_double x, s7_double y) { - s7_double z; - if (is_NaN (x)) return (x); - if (is_NaN (y)) return (y); - if ((is_inf (x)) || (is_inf (y))) return (NAN); - if (y == 0.0) return (x); - if (fabs (x) > 1e17) - out_of_range_error_nr (sc, sc->modulo_symbol, int_one, wrap_real (sc, x), - it_is_too_large_string); - z= x / y; - if ((z > 1e19) || (z < -1e19)) - sole_arg_out_of_range_error_nr (sc, sc->modulo_symbol, - set_elist_3 (sc, sc->divide_symbol, - wrap_real (sc, x), - wrap_real (sc, y)), - intermediate_too_large_string); - return (x - y * (s7_int) floor (z)); -} + 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)); + } -static s7_pointer -modulo_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - 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)) { + switch (type(obj)) + { case T_INTEGER: - return (make_integer (sc, modulo_i_ii (integer (x), integer (y)))); + { + 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: - 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; + { + 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: - 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; + { + 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: - 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)); - } + { + 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; } -#else + if (width > len) { - 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: - 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: { - s7_double c= a / b; - if (fabs (c) > 1e19) - sole_arg_out_of_range_error_nr ( - sc, sc->modulo_symbol, set_elist_3 (sc, sc->divide_symbol, x, y), - intermediate_too_large_string); - return (make_real (sc, a - b * (s7_int) floor (c))); - } - default: - return (method_or_bust_pp (sc, y, sc->modulo_symbol, x, y, - sc->type_names[T_REAL], 2)); + s7_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; } - default: - return (method_or_bust_pp (sc, x, sc->modulo_symbol, x, y, - sc->type_names[T_REAL], 1)); - } + else (*nlen) = len; + return(b); } -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))); +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, sc->float_format_precision, 'g', &nlen); + char *str = copy_string_with_length((char *)block_data(b), nlen); + liberate(sc, b); + return(str); } -s7_pointer -s7i_modulo_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (modulo_p_pp (sc, x, y)); -} +#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) -#define H_modulo \ - "(modulo x y) returns x mod y; (modulo 4 3) = 1. The arguments can be " \ - "real numbers." -#define Q_modulo sc->pcl_r -/* ---------------------------------------- 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); -} +/* ctables moved to s7_ctables.c */ -#define is_real_via_method(sc, p) \ - ((is_real (p)) || \ - ((has_active_methods (sc, p)) && (is_real_via_method_1 (sc, p)))) +#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 + */ -#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) +/* -------------------------------- *#readers* -------------------------------- */ +static s7_pointer check_sharp_readers(s7_scheme *sc, const char *name) +{ + s7_pointer value = sc->F; + const bool need_loader_port = is_loader_port(current_input_port(sc)); -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. + /* *#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 (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); - } - 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); - 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); - 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); - default: - return (max_out_y (sc, x, y)); - } - break; + if (need_loader_port) + clear_loader_port(current_input_port(sc)); - default: - return (max_out_x (sc, x, y)); - } - return (x); + /* 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 args = sc->F, 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 -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_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 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 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 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))); + +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'; } -/* ---------------------------------------- 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) +/* bridges for s7_scheme_read.c */ +void s7i_backchar(char c, s7_pointer port) {backchar(c, port);} +void s7i_resize_strbuf(s7_scheme *sc, s7_int needed_size) {resize_strbuf(sc, needed_size);} +bool s7i_is_loader_port(s7_pointer p) {return(is_loader_port(p));} -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); - } - 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); - 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); - 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); - default: - return (min_out_y (sc, x, y)); +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); } - break; + 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 */ - default: - return (min_out_x (sc, x, y)); - } - return (x); -} + 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)); +} + +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 -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_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)); -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))); -} + /* stupid r7rs special cases */ + if ((name[0] == 't') && + ((name[1] == '\0') || (c_strings_are_equal(name, "true")))) + return(sc->T); -/* ---------------------------------------- = - * ---------------------------------------- */ -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); -} + if ((name[0] == 'f') && + ((name[1] == '\0') || (c_strings_are_equal(name, "false")))) + return(sc->F); -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); -} + 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(sc, 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? */ + } -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 (is_pair(slot_value(sc->sharp_readers))) + { + s7_pointer x = check_sharp_readers(sc, name); + if (x != sc->F) + return(x); + } - switch (type (x)) { - case T_INTEGER: - switch (type (y)) { - case T_RATIO: - return (false); - case T_REAL: - return (integer (x) == real (y)); - case T_COMPLEX: - return (false); - 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); - 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); - default: - return (eq_out_y (sc, x, y)); - } - break; - case T_COMPLEX: - if (is_real (y)) return (false); - return (eq_out_y (sc, x, y)); + 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'! */ - default: - return (eq_out_x (sc, x, y)); - } - return (false); -} + 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); + } -bool -s7i_num_eq_b_7pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (num_eq_b_7pp (sc, x, y)); + /* -------- #\... -------- */ + 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 new_int is -593310740 -> segfault unless caught + */ + bool happy = true; + const char *tmp = (const char *)(name + 2); + int32_t new_int = 0; + + while ((*tmp) && (happy) && (new_int >= 0) && (new_int < 0x110000)) + { + int32_t dig = digits[(int32_t)(*tmp++)]; + if (dig < 16) + new_int = dig + (new_int * 16); + else happy = false; + } + if ((happy) && + (new_int >= 0) && + (new_int < 0x110000)) + return(s7_make_character(sc, (uint32_t)new_int)); + } + break; + } + /* 尝试解析为多字节 UTF-8 字符 */ + { + int32_t nlen = safe_strlen(name); + if (nlen >= 3 && nlen <= 5) + { + uint32_t cp = 0; + const uint8_t *u = (const uint8_t *)(name + 1); + if (nlen == 3 && (u[0] & 0xE0) == 0xC0 && (u[1] & 0xC0) == 0x80) + { + cp = ((u[0] & 0x1F) << 6) | (u[1] & 0x3F); + if (cp >= 0x80) + return(s7_make_character(sc, cp)); + } + else if (nlen == 4 && (u[0] & 0xF0) == 0xE0 && (u[1] & 0xC0) == 0x80 && (u[2] & 0xC0) == 0x80) + { + cp = ((u[0] & 0x0F) << 12) | ((u[1] & 0x3F) << 6) | (u[2] & 0x3F); + if (cp >= 0x800 && (cp < 0xD800 || cp > 0xDFFF)) + return(s7_make_character(sc, cp)); + } + else if (nlen == 5 && (u[0] & 0xF8) == 0xF0 && (u[1] & 0xC0) == 0x80 && (u[2] & 0xC0) == 0x80 && (u[3] & 0xC0) == 0x80) + { + cp = ((u[0] & 0x07) << 18) | ((u[1] & 0x3F) << 12) | ((u[2] & 0x3F) << 6) | (u[3] & 0x3F); + if (cp >= 0x10000 && cp <= 0x10FFFF) + return(s7_make_character(sc, cp)); + } + } + } + } + return(unknown_sharp_constant(sc, name, NULL)); } + +/* bridge for s7_scheme_read.c */ +s7_pointer s7i_make_sharp_constant(s7_scheme *sc, const char *name, bool with_error, s7_pointer port, bool error_if_bad_number) {return(make_sharp_constant(sc, name, with_error, port, error_if_bad_number));} -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 x, s7_int y) { - 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_number (x)) return (sc->F); /* complex/ratio can't == int */ - if (has_active_methods (sc, x)) - return (find_and_apply_method (sc, x, sc->num_eq_symbol, - set_plist_2 (sc, x, make_integer (sc, y)))); - wrong_type_error_nr (sc, sc->num_eq_symbol, 1, x, a_number_string); -#ifdef __TINYC__ - return (sc->F); -#endif -} +static const char *radstr[17] = {NULL, NULL, "01", "012", "0123", "01234", "012345", "0123456", "01234567", "012345678", "0123456789", + "0123456789aA", "0123456789aAbB", "0123456789aAbBcC", "0123456789aAbBcCdD", "0123456789aAbBcCdDeE", "0123456789aAbBcCdDeEfF"}; -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 (!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_double string_to_double_with_radix(const char *ur_str, int32_t radix) +{ + /* Use simple implementation for base 10 to avoid precision issues on Windows */ + if (radix == 10) + return s7_string_to_double_simple(ur_str, radix); + + /* 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; -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))); - return (sc->F); -} + /* 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++;}; -s7_pointer -s7i_num_eq_xx (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (num_eq_xx (sc, x, y)); -} + 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; -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)); - } - 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)); - 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)); - 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)); - default: - return (lt_out_y (sc, x, y)); + 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 + */ } - break; - default: - return (lt_out_x (sc, x, y)); - } - return (true); -} + 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 + */ -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) + 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; + } - s7_pointer x= car (args), p= cdr (args); - if (is_null (cdr (p))) return (make_boolean (sc, lt_b_7pp (sc, x, car (p)))); + /* 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 (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; - 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); -} + /* 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 */ -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); -} + 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); + } -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))); - return ( - method_or_bust (sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); -} + /* 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; -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); + /* 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 (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))); - return ( - method_or_bust (sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); -} + 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); -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); + 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); - 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)); - return ( - method_or_bust (sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); + 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); + }}} + return(sign * dval); +} + +static s7_pointer make_undefined_overflow(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); + liberate(sc, b); + return(result); } -static inline s7_pointer -lt_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (make_boolean (sc, lt_b_7pp (sc, x, y))); +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); } -s7_pointer -s7i_lt_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (lt_p_pp (sc, x, y)); +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); } -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)); -} +#if WITH_NUMBER_SEPARATOR -static bool -lt_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 (is_t_ratio (x)) return (ratio_lt_pi (x, y)); - return (lt_out_x (sc, x, make_integer (sc, y))); -} -static s7_pointer -lt_p_pi (s7_scheme* sc, s7_pointer x, s7_int y) { - return (make_boolean (sc, lt_b_pi (sc, x, y))); -} +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; -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 (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 = s7i_string_to_number(sc, new_name, radix); + liberate(sc, b); + return(result); } - 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)); - 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)); - 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)); - default: - return (leq_out_y (sc, x, y)); - } - break; +} +#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 x, s7_pointer y) { - return (make_boolean (sc, leq_b_7pp (sc, x, y))); -} -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))); - 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 x, s7_int y) { - if (is_t_integer (x)) return (integer (x) <= y); - if (is_t_real (x)) return (real (x) <= y); - if (is_t_ratio (x)) return (ratio_leq_pi (x, y)); - if (has_active_methods (sc, x)) - return (find_and_apply_method ( - sc, x, sc->leq_symbol, - list_2 (sc, x, make_integer (sc, y)))); /* not plist */ - wrong_type_error_nr (sc, sc->leq_symbol, 1, x, sc->type_names[T_REAL]); -#ifdef __TINYC__ - return (false); +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; -static s7_pointer -leq_p_pi (s7_scheme* sc, s7_pointer x, s7_int y) { - return (make_boolean (sc, leq_b_pi (sc, x, y))); -} + 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 = s7_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, s7_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; -/* bridge for g_leq_2 migration */ -bool -s7i_leq_b_7pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (leq_b_7pp (sc, x, y)); -} - -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)); -} + 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; -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)); - } - 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)); - 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)); - 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)); default: - return (gt_out_y (sc, x, y)); + if (!is_digit(c, radix)) + return((want_symbol) ? make_symbol_with_strlen(sc, q) : sc->F); + break; } - break; - default: - return (gt_out_x (sc, x, y)); - } - return (true); -} + /* 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; + bool overflow = false; /* for string_to_integer */ + 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 = s7_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); -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) +#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) + { + s7_double rl = 0.0, im = 0.0; + 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)); + /* look for cases like 1+i */ + q[len - 1] = ((q[len - 2] == '+') || (q[len - 2] == '-')) ? '1' : '\0'; /* remove 'i' */ + + (*((char *)(plus - 1))) = '\0'; + + 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 = s7_string_to_integer(q, radix, &overflow); + if (overflow) return(make_undefined_overflow(sc, q)); + den = s7_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_overflow(sc, q)); /* denominator overflow */ + rl = (long_double)num / (long_double)den; /* no gmp, so we do what we can */ + }}} + else + { + rl = (s7_double)s7_string_to_integer(q, radix, &overflow); + if (overflow) return(make_undefined_overflow(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 = s7_string_to_integer(plus, radix, &overflow); + if (overflow) return(make_undefined_overflow(sc, q)); + den = s7_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_overflow(sc, q)); /* denominator overflow */ + im = (long_double)num / (long_double)den; + }}} + else + { + im = (s7_double)s7_string_to_integer(plus, radix, &overflow); + if (overflow) return(make_undefined_overflow(sc, q)); + }} + if ((has_plus_or_minus == -1) && + (im != 0.0)) + im = -im; + result = make_complex(sc, rl, im); + /* restore original string */ + q[len - 1] = ql1; + (*((char *)(plus - 1))) = pl1; + return(result); + } - s7_pointer x= car (args), p= cdr (args); + /* 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 (is_null (cdr (p))) return (make_boolean (sc, gt_b_7pp (sc, x, car (p)))); + result = make_real(sc, string_to_double_with_radix(q, radix)); + return(result); + } - 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); + /* rational */ + if (slash1) + { + s7_int d; + const s7_int n = s7_string_to_integer(q, radix, &overflow); + if (overflow) return(make_undefined_overflow(sc, q)); + d = s7_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_overflow(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)); + } + /* integer */ + { + s7_int x = s7_string_to_integer(q, radix, &overflow); + if (overflow) return(make_undefined_overflow(sc, q)); + return(make_integer(sc, x)); } - 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))); - return (method_or_bust (sc, x, sc->gt_symbol, args, a_number_string, 1)); -} +/* -------------------------------- string->number -------------------------------- */ +#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) +/* g_string_to_number is now defined in s7_liii_string.c */ -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)); +/* (abs|magnitude -9223372036854775808) won't work here */ - 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)); - default: - return (method_or_bust (sc, x, sc->gt_symbol, args, a_number_string, 1)); - } - return (sc->T); -} +/* -------------------------------- inexact helpers -------------------------------- */ +#if !HAVE_COMPLEX_NUMBERS + static s7_pointer no_complex_numbers_string; +#endif -static inline s7_pointer -gt_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (make_boolean (sc, gt_b_7pp (sc, x, y))); -} -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)); +/* -------------------------------- log -------------------------------- */ +static s7_pointer log_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + 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); + } + return(func); } -static bool -gt_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 (is_t_ratio (x)) return (!ratio_leq_pi (x, y)); - return (gt_out_x (sc, x, make_integer (sc, y))); -} -static s7_pointer -gt_p_pi (s7_scheme* sc, s7_pointer x, s7_int y) { - return (make_boolean (sc, gt_b_pi (sc, x, y))); +/* ---------------------------------------- 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_WARNINGS) s7_warn(sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", x, y); + return(make_real(sc, (long_double)x + (long_double)y)); + } + return(make_integer(sc, val)); +#else + return(make_integer(sc, x + y)); +#endif } -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))); - 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))); - default: - return (make_boolean (sc, gt_out_y (sc, x, y))); +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_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))); } - break; - - default: - return (make_boolean (sc, gt_out_x (sc, x, y))); - } - return (sc->T); + return(make_ratio(sc, z, denominator(y))); +#else + return(make_ratio(sc, integer(x) * denominator(y) + numerator(y), denominator(y))); +#endif } -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)); - } - 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)); - 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)); - default: - return (geq_out_y (sc, x, y)); +#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 (is_t_real(y)) + return(make_real(sc, (long_double)integer(x) + real(y))); } - case T_REAL: - switch (type (y)) { + else + if (is_t_real(x)) + { + if (is_t_real(y)) + return(make_real(sc, real(x) + real(y))); + } + else + if ((is_t_complex(x)) && (is_t_complex(y))) + return(make_complex(sc, real_part(x) + real_part(y), imag_part(x) + imag_part(y))); + + switch (type(x)) + { case T_INTEGER: - return (real (x) >= integer (y)); + 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: + 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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } + case T_RATIO: - return (real (x) >= fraction (y)); - default: - return (geq_out_y (sc, x, y)); - } - break; + 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_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)); + } + 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 + } - default: - return (geq_out_x (sc, x, y)); - } - return (true); -} +#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_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))); + } + 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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } -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) + case T_REAL: + switch (type(y)) + { + case T_INTEGER: + 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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } - s7_pointer x= car (args), p= cdr (args); - if (is_null (cdr (p))) return (make_boolean (sc, geq_b_7pp (sc, x, car (p)))); + 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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->add_symbol, x, y, a_number_string, 2)); + } - 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); + default: + return(method_or_bust_pp(sc, x, sc->add_symbol, x, y, a_number_string, 1)); } - return (sc->T); -} - -static inline s7_pointer -geq_p_pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (make_boolean (sc, geq_b_7pp (sc, x, y))); -} -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)); } -/* bridge for g_geq_2 migration */ -bool -s7i_geq_b_7pp (s7_scheme* sc, s7_pointer x, s7_pointer y) { - return (geq_b_7pp (sc, x, y)); -} +s7_pointer s7i_add_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(add_p_pp(sc, x, y));} -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 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 -g_geq_xi (s7_scheme* sc, s7_pointer args) { - const s7_int y= integer (cadr (args)); - const s7_pointer x= car (args); +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 (is_t_real(y)) + return(wrap_real(sc, (long_double)integer(x) + real(y))); + } + 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))); + } - 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))); - return ( - method_or_bust (sc, x, sc->geq_symbol, args, sc->type_names[T_REAL], 1)); -} + 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))); + } -static bool -geq_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 (is_t_ratio (x)) return (!ratio_lt_pi (x, 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, make_integer (sc, y)))); /* not plist */ + 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)); } -static s7_pointer -geq_p_pi (s7_scheme* sc, s7_pointer x, s7_int y) { - return (make_boolean (sc, geq_b_pi (sc, x, y))); -} +s7_pointer s7i_add_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(add_p_pp_wrapped(sc, x, y));} -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)); +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_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))); +#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); } - return (0.0); } -/* ---------------------------------------- imag-part - * ---------------------------------------- */ -s7_double -s7_imag_part (s7_pointer x) { - if (is_t_complex (x)) return (imag_part (x)); - return (0.0); -} +s7_pointer s7i_add_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) {return(add_p_ppp(sc, x, y, z));} -/* ---------------------------------------- numerator denominator - * ---------------------------------------- */ -static s7_int -numerator_i_7p (s7_scheme* sc, s7_pointer x) { - if (is_t_ratio (x)) return (numerator (x)); - if (is_t_integer (x)) return (integer (x)); - return (integer ( - method_or_bust_p (sc, x, sc->numerator_symbol, a_rational_string))); +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); + } } -/* g_numerator is now defined in s7_scheme_predicate.c */ -#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) - -/* g_denominator is now defined in s7_scheme_predicate.c */ -#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) -static s7_int -denominator_i_7p (s7_scheme* sc, s7_pointer x) { - if (is_t_ratio (x)) return (denominator (x)); - if (is_t_integer (x)) return (1); - return (integer ( - method_or_bust_p (sc, x, sc->denominator_symbol, a_rational_string))); -} +s7_pointer s7i_add_p_ppp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) {return(add_p_ppp_wrapped(sc, x, y, z));} -/* ---------------------------------------- number? bignum? complex? integer? - * byte? rational? real? ---------------------------------------- */ -/* g_is_number is now defined in s7_scheme_predicate.c */ -#define H_is_number "(number? obj) returns #t if obj is a number" -#define Q_is_number sc->pl_bt -/* g_is_integer is now defined in s7_scheme_predicate.c */ -#define H_is_integer "(integer? obj) returns #t if obj is an integer" -#define Q_is_integer sc->pl_bt +static s7_pointer g_add(s7_scheme *sc, s7_pointer args) +{ + #define H_add "(+ ...) adds its arguments" + #define Q_add sc->pcl_n -static bool -is_byte (s7_pointer x) { - return ((s7_is_integer (x)) && (s7_integer (x) >= 0) && - (s7_integer (x) < 256)); + 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); } -/* g_is_byte is now defined in s7_scheme_predicate.c */ -#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 - -/* g_is_real is now defined in s7_scheme_predicate.c */ -#define H_is_real "(real? obj) returns #t if obj is a real number" -#define Q_is_real sc->pl_bt - -/* g_is_complex is now defined in s7_scheme_predicate.c */ -#define H_is_complex "(complex? obj) returns #t if obj is a number" -#define Q_is_complex sc->pl_bt - -/* g_is_rational is now defined in s7_scheme_predicate.c */ -#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 -/* g_is_float is now defined in s7_scheme_predicate.c */ -#define H_is_float "(float? x) returns #t is x is real and not rational." -#define Q_is_float sc->pl_bt +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)); -static bool -is_float_b (s7_pointer x) { - return (is_t_real (x)); + 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))); + 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); } -/* ---------------------------------------- nan? - * ---------------------------------------- */ -static bool -is_nan_b_7p (s7_scheme* sc, s7_pointer x) { - return s7_is_nan (sc, x); +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)); } +static s7_pointer g_add_1x(s7_scheme *sc, s7_pointer args) {return(g_add_x1_1(sc, cadr(args), 2));} -/* ---------------------------------------- zero? - * ---------------------------------------- */ +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)); -static bool -is_zero (s7_pointer x) { - if (s7_is_integer (x)) return s7_integer (x) == 0; - if (s7_is_real (x)) return s7_real (x) == 0.0; - return false; /* ratios and complex numbers here are already collapsed into - integers and reals */ + 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))); + default: return(method_or_bust_pp(sc, x, sc->add_symbol, x, make_integer(sc, y), a_number_string, loc)); + } + return(x); } -static bool -is_positive (s7_scheme* sc, s7_pointer x) { - if (s7_is_integer (x)) return s7_integer (x) > 0; - if (s7_is_rational (x) && !s7_is_integer (x)) return s7_numerator (x) > 0; - if (s7_is_real (x)) return s7_real (x) > 0.0; - s7_wrong_type_arg_error (sc, "positive?", 1, x, "a real number"); - return false; -} +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))); + 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(sc, car(arg1))) + return((is_pair(cdr(arg1))) ? s7_type_of(sc, cadr(arg1)) : NULL); /* arg1 = (quote) */ -static bool -is_negative (s7_scheme* sc, s7_pointer x) { - if (s7_is_integer (x)) return s7_integer (x) < 0; - if (s7_is_rational (x) && !s7_is_integer (x)) return s7_numerator (x) < 0; - if (s7_is_real (x)) return s7_real (x) < 0.0; - s7_wrong_type_arg_error (sc, "negative?", 1, x, "a real number"); - return false; + 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); } -#if !WITH_PURE_S7 -/* ---------------------------------------- exact<->inexact exact? inexact? - * ---------------------------------------- */ - -/* ---------------------------------------- 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 +static s7_pointer g_random_i(s7_scheme *sc, s7_pointer args); - 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))); - } - return (sole_arg_method_or_bust (sc, num, sc->integer_length_symbol, args, - sc->type_names[T_INTEGER])); +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)); } -static s7_int -integer_length_i_i (s7_int x) { - return ((x < 0) ? integer_length (-(x + 1)) : integer_length (x)); -} -#endif /* !pure s7 */ +/* ---------------------------------------- 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) + sole_arg_out_of_range_error_nr(sc, sc->subtract_symbol, x, wrap_string(sc, "most-negative-fixnum can't be negated", 37)); + return(make_integer(sc, -integer(x))); -/* ---------------------------------------- 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)); - } - return (method_or_bust_p (sc, x, sc->integer_decode_float_symbol, - wrap_string (sc, "a non-rational real", 19))); -} - -/* -------------------------------- 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 - */ + 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))); -static s7_pointer -random_state_copy (s7_scheme* sc, s7_pointer args) { - 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); + default: + return(method_or_bust_p(sc, x, sc->subtract_symbol, a_number_string)); + } } -#ifndef MWC_32 -#define MWC_32 1 +s7_pointer s7i_negate_p_p(s7_scheme *sc, s7_pointer x) {return(negate_p_p(sc, x));} + +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_WARNINGS) s7_warn(sc, 128, "integer subtract overflow: (- %" ld64 " %" ld64 ")\n", x, y); + return(make_real(sc, (long_double)x - (long_double)y)); + } + return(make_integer(sc, val)); +#else + return(make_integer(sc, x - y)); #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) +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))); - s7_pointer r1, r2, rs; - s7_int i1, i2; /* actually want s7_uint here -- we lose the sign bit? */ - 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 MWC_32 - if (i1 < 0) - out_of_range_error_nr (sc, sc->random_state_symbol, int_one, r1, - it_is_negative_string); + 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_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))); + } + return(make_ratio(sc, z, denominator(y))); +#else + return(make_ratio(sc, integer(x) * denominator(y) - numerator(y), denominator(y))); #endif - 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); - } + } + case T_REAL: + 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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } - 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 MWC_32 - if (i2 < 0) - out_of_range_error_nr (sc, sc->random_state_symbol, int_two, r2, - it_is_negative_string); + 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_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))); + } + return(make_ratio(sc, z, denominator(x))); +#else + return(make_ratio(sc, numerator(x) - (integer(y) * denominator(x)), denominator(x))); #endif - new_cell (sc, rs, T_RANDOM_STATE); - random_seed (rs) = (s7_uint) i1; - random_carry (rs)= (s7_uint) i2; - return (rs); -} - -#define g_random_state s7_random_state + } + 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_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)); + } + return(make_ratio_with_div_check(sc, sc->subtract_symbol, q, d1)); +#else + return(make_ratio(sc, numerator(x) - numerator(y), denominator(x))); +#endif + } -static s7_pointer -random_state_getter (s7_scheme* sc, s7_pointer r, s7_int loc) { - if (loc == 0) return (make_integer (sc, random_seed (r))); - if (loc == 1) return (make_integer (sc, random_carry (r))); - return (sc->F); -} +#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_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))); + } + 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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } -static s7_pointer -random_state_setter (s7_scheme* sc, s7_pointer r, s7_int loc, s7_pointer val) { - 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; - } - return (sc->F); -} + case T_REAL: + switch (type(y)) + { + case T_INTEGER: + 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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } -/* -------------------------------- random-state? - * -------------------------------- */ -/* g_is_random_state is now defined in s7_scheme_predicate.c */ -#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 - -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, sc->is_pair_symbol, sc->is_random_state_symbol) + 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))); + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->subtract_symbol, x, y, a_number_string, 2)); + } - 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)))); + default: + return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, y, a_number_string, 1)); + } } -#define g_random_state_to_list s7_random_state_to_list +s7_pointer s7i_subtract_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(subtract_p_pp(sc, x, y));} -void -s7_set_default_random_state (s7_scheme* sc, s7_int seed, s7_int carry) { - 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; +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)); } -/* -------------------------------- random -------------------------------- */ -static double -next_random (s7_pointer r) { -#if MWC_32 -/* 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 s7_random_state for 64 bit version of this, L26622 - * here's a check that things are not totally broken: - (define (check-random-integers lo hi) - (let* ((range (- hi lo)) - (num-bins 32) - (bins (make-int-vector num-bins 0))) - (do ((i 0 (+ i 1)) - (x (random range) (random range))) - ((= i 10000) bins) - (let ((bin (floor (* (/ x range) num-bins)))) - (set! (bins bin) (+ (bins bin) 1)))))) - (display (check-random-integers 0 9223372036854775807)) (newline) - - (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)))) - (display (list mn mx)) (newline)) - */ -#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)) - */ +s7_pointer s7i_negate_p_p_wrapped(s7_scheme *sc, s7_pointer x) {return(negate_p_p_wrapped(sc, x));} + +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 - /* 64-bit MWC from https://prng.di.unimi.it/#shootout */ - double result; -#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= random_seed (r), c= random_carry (r); - s7_uint u_result= x; - /* Or, result = x ^ (x << 32) (see above) */ /* s7_uint == uint64_t */ - const __uint128_t t= MWC_A1 * (__uint128_t) x + c; - random_seed (r) = t; - random_carry (r) = t >> 64; - result= ((long_double) (random_seed (r)) / (long_double) 4294967296.0) / - (long_double) 4294967295.5; + return(wrap_integer(sc, x - y)); #endif - - return (result); } -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)) { - 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))); - default: - return ( - method_or_bust (sc, num, sc->random_symbol, args, a_number_string, 1)); - } - return (sc->F); +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)); } -s7_double -s7_random (s7_scheme* sc, s7_pointer state) { - return (next_random ((state) ? state : sc->default_random_state)); -} +s7_pointer s7i_subtract_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(subtract_p_pp_wrapped(sc, x, y));} -static s7_double -random_d_7d (s7_scheme* sc, s7_double x) { - return (x * next_random (sc->default_random_state)); -} +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 -static s7_int -random_i_7i (s7_scheme* sc, s7_int i) { - return ((s7_int) (i * next_random (sc->default_random_state))); + 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_random_i (s7_scheme* sc, s7_pointer args) { - return (make_integer (sc, (s7_int) (integer (car (args)) * - next_random (sc->default_random_state)))); +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))); + default: + return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, int_one, a_number_string, 1)); + } + return(x); } -static s7_pointer -g_random_f (s7_scheme* sc, s7_pointer args) { - return (make_real (sc, real (car (args)) * - next_random (sc->default_random_state))); +static s7_pointer g_subtract_x1(s7_scheme *sc, s7_pointer args) +{ + s7_pointer num = car(args); + /* 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_random_1 (s7_scheme* sc, s7_pointer args) { - 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))); - return (g_random (sc, args)); +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))); + default: + return(method_or_bust(sc, x, sc->subtract_symbol, args, a_number_string, 1)); + } + return(x); } -static s7_pointer -random_p_p (s7_scheme* sc, s7_pointer num) { - 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))); - return (g_random (sc, set_plist_1 (sc, num))); -} +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 */ -static s7_pointer -random_p_p_wrapped (s7_scheme* sc, s7_pointer num) { - 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))); - return (g_random (sc, set_plist_1 (sc, num))); + 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))); + default: + return(method_or_bust(sc, x, sc->subtract_symbol, args, a_number_string, 1)); + } + return(x); } -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_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_add_i_random (s7_scheme* sc, s7_pointer args) { - 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! */ -} +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)); -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); - } + 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))); + default: return(method_or_bust_pp(sc, x, sc->subtract_symbol, x, make_integer(sc, y), a_number_string, 1)); + } + return(x); } -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; +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); } -s7_pointer -s7_make_character (s7_scheme* sc, uint32_t c) { - if (c < 256) return (chars[c]); - if (!sc->unicode_chars_table) { - sc->unicode_chars_table= s7_make_hash_table (sc, 128); - s7_gc_protect (sc, sc->unicode_chars_table); - if (mark_function[T_CHARACTER] == mark_noop) - mark_function[T_CHARACTER]= just_mark; - } - { - s7_pointer key= s7_make_integer (sc, (s7_int) c); - s7_pointer val= s7_hash_table_ref (sc, sc->unicode_chars_table, key); - if (val != sc->F) return (val); + +/* ---------------------------------------- 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)) { - s7_pointer cp; - new_cell (sc, cp, T_CHARACTER | T_IMMUTABLE); - character (cp) = c; - upper_character (cp) = c; - is_char_alphabetic (cp)= false; - is_char_numeric (cp) = false; - is_char_whitespace (cp)= false; - is_char_uppercase (cp) = false; - is_char_lowercase (cp) = false; - if (c < 32 || (c >= 127 && c < 160)) - character_name_length (cp)= - snprintf ((char*) (&(character_name (cp))), 12, "#\\x%x", c); - else { - char buf[12]; - int len= 2; - buf[0] = '#'; - buf[1] = '\\'; - if (c < 0x80) buf[len++]= c; - else if (c < 0x800) { - buf[len++]= 0xC0 | (c >> 6); - buf[len++]= 0x80 | (c & 0x3F); - } - else if (c < 0x10000) { - buf[len++]= 0xE0 | (c >> 12); - buf[len++]= 0x80 | ((c >> 6) & 0x3F); - buf[len++]= 0x80 | (c & 0x3F); - } - else { - buf[len++]= 0xF0 | (c >> 18); - buf[len++]= 0x80 | ((c >> 12) & 0x3F); - buf[len++]= 0x80 | ((c >> 6) & 0x3F); - buf[len++]= 0x80 | (c & 0x3F); - } - character_name_length (cp)= len; - memcpy ((void*) (&(character_name (cp))), buf, len); - } - add_semipermanent_object (sc, cp); - s7_hash_table_set (sc, sc->unicode_chars_table, key, cp); - return (cp); + if (WITH_WARNINGS) s7_warn(sc, 128, "integer multiply overflow: (* %" ld64 " %" ld64 ")\n", x, y); + return(make_real(sc, (s7_double)x * (s7_double)y)); } - } + return(make_integer(sc, val)); +#else + return(make_integer(sc, x * y)); +#endif } -bool -s7_is_character (s7_pointer c) { - return (is_character (c)); +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_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))); + } + return(make_ratio(sc, z, denominator(y))); +#else + return(make_ratio(sc, x * numerator(y), denominator(y))); +#endif } -uint32_t -s7_character (s7_pointer c) { - return (character (c)); -} +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: + 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))); + 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_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))); + } + 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: + 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))); + 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: + return(make_real(sc, real(x) * (long_double)integer(y))); + case T_RATIO: + 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))); + 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)); + } + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->multiply_symbol, x, y, a_number_string, 2)); + } -static bool -returns_char (s7_scheme* sc, s7_pointer arg) { - return (argument_type (sc, arg) == sc->is_char_symbol); + default: + return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, y, a_number_string, 1)); + } } -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); +s7_pointer s7i_multiply_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(multiply_p_pp(sc, x, y));} + +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)); } - else if (returns_char (sc, arg2)) return (sc->simple_char_eq2); - } - return (sc->char_equal_2); + return(wrap_integer(sc, val)); +#else + return(wrap_integer(sc, x * y)); +#endif } -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); +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), real_part(x) * imag_part(y))); + case T_REAL: return(wrap_real_or_complex(sc, real_part(x) * real(y), imag_part(x) * imag_part(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)); } -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); +s7_pointer s7i_multiply_p_pp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(multiply_p_pp_wrapped(sc, x, y));} + +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); } -/* -------------------------------- string-position - * -------------------------------- */ -#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_pointer s7i_multiply_p_ppp(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) {return(multiply_p_ppp(sc, x, y, z));} -/* -------------------------------- strings -------------------------------- */ -bool -s7_is_string (s7_pointer p) { - return (is_string (p)); +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); } -#define H_is_string "(string? obj) returns #t if obj is a string" -#define Q_is_string sc->pl_bt -/* g_is_string is now defined in s7_liii_string.c */ +s7_pointer s7i_multiply_p_ppp_wrapped(s7_scheme *sc, s7_pointer x, s7_pointer y, s7_pointer z) {return(multiply_p_ppp_wrapped(sc, x, y, z));} -s7_int -s7_string_length (s7_pointer str) { - return (string_length (str)); +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); } -#define NUM_STRING_WRAPPERS 8 +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 -wrap_string (s7_scheme* sc, const char* str, s7_int len) { - const s7_pointer temp_str= car (sc->string_wrappers); -#if S7_DEBUGGING - if ((full_type (temp_str) & (~T_GC_MARK)) != - (T_STRING | T_UNHEAP | T_SAFE_PROCEDURE)) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, - describe_type_bits (sc, temp_str)); - sc->string_wrapper_allocs++; -#endif - sc->string_wrappers = cdr (sc->string_wrappers); - string_value (temp_str) = (char*) str; - string_length (temp_str)= len; - return (temp_str); + 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); } -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 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)); + 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 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 multiply_p_pi(s7_scheme *sc, s7_pointer p1, s7_int i1) {return(g_mul_xi(sc, p1, i1, 1));} -static s7_pointer -make_empty_string (s7_scheme* sc, s7_int len, char fill) { - return (inline_make_empty_string (sc, len, fill)); +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)); + default: return(method_or_bust_pp(sc, x, sc->multiply_symbol, x, make_real(sc, y), a_number_string, num)); + } + return(x); } -s7_pointer -s7i_make_empty_string (s7_scheme* sc, s7_int len, char fill) { - return (make_empty_string (sc, len, fill)); +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 } -s7_int -s7i_max_string_length (s7_scheme* sc) { - return (sc->max_string_length); +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 } -s7_int -s7i_max_vector_length (s7_scheme* sc) { - return (sc->max_vector_length); -} +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));} -s7_int -s7i_max_list_length (s7_scheme* sc) { - return (sc->max_list_length); +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); } -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); + +/* ---------------------------------------- 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 char* -make_semipermanent_c_string (s7_scheme* sc, - const char* str) /* strcpy but avoid malloc */ +static s7_pointer invert_p_p(s7_scheme *sc, s7_pointer num) { - s7_int len = safe_strlen (str); - char* new_str= (char*) permalloc (sc, len + 1); - memcpy ((void*) new_str, (const void*) str, len); - new_str[len]= 0; - return (new_str); + switch (type(num)) + { + case T_INTEGER: + if (integer(num) == 0) + division_by_zero_error_1_nr(sc, sc->divide_symbol, num); + return(make_simple_ratio(sc, 1, integer(num))); /* this checks for int */ + case T_RATIO: + return(make_simple_ratio(sc, denominator(num), numerator(num))); + case T_REAL: + if (real(num) == 0.0) + division_by_zero_error_1_nr(sc, sc->divide_symbol, num); + return(make_real(sc, 1.0 / real(num))); + case T_COMPLEX: + return(complex_invert(sc, num)); + + default: + if_method_exists_return_value(sc, num, sc->divide_symbol, set_plist_1(sc, num)); + wrong_type_error_nr(sc, sc->divide_symbol, 1, num, a_number_string); + } + return(NULL); } -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 s7i_invert_p_p(s7_scheme *sc, s7_pointer x) {return(invert_p_p(sc, x));} + +static s7_pointer divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) { - 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); + /* 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_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))); + } + 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 - keyword_value_missing_string= make_permanent_string ( - "~A: keyword argument's value is missing: ~S in ~S", 49); + 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); + 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))); + } + + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } + break; - 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); + /* -------- 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_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)))); + } + 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))) + { + 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)); + } + 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) */ + } + + 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)); + } + + 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)); + } + + default: + return(method_or_bust_with_type_and_loc_pp(sc, y, sc->divide_symbol, x, y, a_number_string, 2)); + } + + + 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) */ + } + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + return(NULL); /* make the compiler happy */ +} + +s7_pointer s7i_divide_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(divide_p_pp(sc, x, y));} + +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 - 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); + 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); } -/* -------------------------------- 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_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_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))); + } + 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)); -#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) -/* g_make_string is now defined in s7_liii_string.c */ + default: + return(method_or_bust_pp(sc, num, sc->divide_symbol, num, int_two, a_number_string, 1)); + } +} -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')); +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)); } -#if !WITH_PURE_S7 -/* -------------------------------- string-length - * -------------------------------- */ +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_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)); +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); } -#endif -/* -------------------------------- string-ref -------------------------------- - */ -/* string_ref_p_pi, string_ref_p_pp, string_ref_p_p0, string_plast_via_method, - string_ref_p_plast, string_ref_p_pi_unchecked, string_ref_p_pi_direct, - string_set_p_pip, string_set_p_pip_unchecked, string_set_p_pip_direct - migrated to s7_liii_string.c */ +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));} -/* -------------------------------- 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 (!is_not_slot_end (let_slots (seq))); /* (append (rootlet) #f) */ - default: - return (false); - } +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); } -static s7_int -pair_length_1 (s7_scheme* sc, s7_pointer seq) { - s7_int len= s7_list_length (sc, seq); - return ((len == 0) ? -1 : len); -} - -static s7_int -cobj_len (s7_scheme* sc, s7_pointer seq) { - s7_pointer len= c_object_length (sc, seq); - if (s7_is_integer (len)) return (s7_integer_clamped_if_gmp (sc, len)); - return (-1); -} - -static s7_int -sequence_length (s7_scheme* sc, s7_pointer seq) { - switch (type (seq)) { - case T_PAIR: - return (pair_length_1 (sc, seq)); - 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: - return (cobj_len (sc, seq)); - default: - return (-1); - } -} -bool -s7i_is_sequence (s7_pointer p) { - return (is_sequence (p)); +/* -------------------------------- 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) */ } -bool -s7i_sequence_is_empty (s7_scheme* sc, s7_pointer seq) { - return (sequence_is_empty (sc, seq)); +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))); } -s7_int -s7i_sequence_length (s7_scheme* sc, s7_pointer seq) { - return (sequence_length (sc, seq)); +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)); } -static s7_pointer s7_copy_1 (s7_scheme* sc, s7_pointer caller, s7_pointer args); +static s7_int quotient_i_ii_unchecked(s7_int i1, s7_int i2) {return(i1 / i2);} /* i2 > 0 */ -/* string_append_2, s7i_string_append_1, string_append_1, string_append_p_pp, - g_string_append_2 migrated to s7_liii_string.c */ +static s7_pointer quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ -#define H_string_append \ - "(string-append str1 ...) appends all its string arguments into one string" -#define Q_string_append sc->pcl_s -/* g_string_append is now defined in s7_liii_string.c */ + 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)))); -static void check_for_substring_temp (s7_scheme* sc, s7_pointer expr); + 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)); + } -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); + 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)); + } } -/* -------------------------------- 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 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))); } -#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) -/* g_substring is now defined in s7_liii_string.c */ +s7_pointer s7i_quotient_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(quotient_p_pp(sc, x, y));} -#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) -/* g_substring_uncopied is now defined in s7_liii_string.c */ +#define H_quotient "(quotient x1 x2) returns the integer quotient of x1 and x2; (quotient 4 3) = 1" +#define Q_quotient sc->pcl_r -/* substring_uncopied_p_pii migrated to s7_liii_string.c */ -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); - } - } -} +/* -------------------------------- remainder -------------------------------- */ -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); +#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); } -/* -------------------------------- string-copy -------------------------------- - */ -#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) -/* g_string_copy is now defined in s7_liii_string.c */ +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_pointer -string_copy_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - if (args == 1) check_for_substring_temp (sc, expr); - return (func); +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 x, s7_double y) +{ + if (y == 0.0) + division_by_zero_error_2_nr(sc, sc->remainder_symbol, wrap_real(sc, x), real_zero); + if (is_NaN(x)) return(x); + if (is_inf(x)) return(NAN); /* match remainder_p_pp */ + return(c_rem_dbl(sc, x, y)); } -/* -------------------------------- string comparisons - * -------------------------------- */ -static int32_t -scheme_strcmp (s7_pointer s1, s7_pointer s2) { - /* tricky here because str[i] must be treated as unsigned: (stringchar #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); +static s7_pointer remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + 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)); } - } - 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 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 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))); } -/* string comparison bridge functions */ -int32_t -s7i_scheme_strcmp (s7_pointer s1, s7_pointer s2) { - return (scheme_strcmp (s1, s2)); -} -bool -s7i_scheme_strings_are_equal (s7_pointer x, s7_pointer y) { - return (scheme_strings_are_equal (x, y)); -} -bool -s7i_is_string_via_method (s7_scheme* sc, s7_pointer obj) { - return (is_string_via_method (sc, obj)); -} +s7_pointer s7i_remainder_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(remainder_p_pp(sc, x, y));} -s7_pointer -s7i_method_or_bust_sym (s7_scheme* sc, s7_pointer obj, s7_pointer method_sym, - s7_pointer args, s7_pointer typ, s7_int arg_pos) { - return (method_or_bust (sc, obj, method_sym, args, typ, (int32_t) arg_pos)); -} +#define H_remainder "(remainder x y) returns the remainder of x/y; (remainder 10 3) = 1" +#define Q_remainder sc->pcl_r -s7_pointer -s7i_set_plist_1 (s7_scheme* sc, s7_pointer x1) { - return (set_plist_1 (sc, x1)); -} -s7_pointer -s7i_string_type_name (s7_scheme* sc) { - return (sc->type_names[T_STRING]); -} -s7_pointer -s7i_character_type_name (s7_scheme* sc) { - return (sc->type_names[T_CHARACTER]); -} -void -s7i_check_free_heap_size (s7_scheme* sc, s7_int size) { - check_free_heap_size (sc, size); -} -s7_pointer -s7i_string_eq_symbol (s7_scheme* sc) { - return (sc->string_eq_symbol); -} -s7_pointer -s7i_string_lt_symbol (s7_scheme* sc) { - return (sc->string_lt_symbol); -} -s7_pointer -s7i_string_gt_symbol (s7_scheme* sc) { - return (sc->string_gt_symbol); -} -s7_pointer -s7i_string_leq_symbol (s7_scheme* sc) { - return (sc->string_leq_symbol); -} -s7_pointer -s7i_string_geq_symbol (s7_scheme* sc) { - return (sc->string_geq_symbol); -} -bool -s7i_is_true (s7_scheme* sc, s7_pointer p) { - return (is_true (sc, p)); -} -s7_pointer -s7i_is_string_symbol (s7_scheme* sc) { - return (sc->is_string_symbol); -} -s7_pointer -s7i_is_boolean_symbol (s7_scheme* sc) { - return (sc->is_boolean_symbol); -} -s7_pointer -s7i_is_unspecified_symbol (s7_scheme* sc) { - return (sc->is_unspecified_symbol); -} -s7_pointer -s7i_is_number_symbol (s7_scheme* sc) { - return (sc->is_number_symbol); -} -s7_pointer -s7i_is_integer_symbol (s7_scheme* sc) { - return (sc->is_integer_symbol); -} -s7_pointer -s7i_is_real_symbol (s7_scheme* sc) { - return (sc->is_real_symbol); -} -s7_pointer -s7i_is_complex_symbol (s7_scheme* sc) { - return (sc->is_complex_symbol); -} -s7_pointer -s7i_is_rational_symbol (s7_scheme* sc) { - return (sc->is_rational_symbol); -} -s7_pointer -s7i_is_keyword_symbol (s7_scheme* sc) { - return (sc->is_keyword_symbol); -} -s7_pointer -s7i_is_dilambda_symbol (s7_scheme* sc) { - return (sc->is_dilambda_symbol); -} -s7_pointer -s7i_is_sequence_symbol (s7_scheme* sc) { - return (sc->is_sequence_symbol); -} -s7_pointer -s7i_is_symbol_symbol (s7_scheme* sc) { - return (sc->is_symbol_symbol); -} -s7_pointer -s7i_is_input_port_symbol (s7_scheme* sc) { - return (sc->is_input_port_symbol); -} -s7_pointer -s7i_is_output_port_symbol (s7_scheme* sc) { - return (sc->is_output_port_symbol); -} -s7_pointer -s7i_is_macro_symbol (s7_scheme* sc) { - return (sc->is_macro_symbol); -} -s7_pointer -s7i_is_undefined_symbol (s7_scheme* sc) { - return (sc->is_undefined_symbol); -} -s7_pointer -s7i_is_eof_object_symbol (s7_scheme* sc) { - return (sc->is_eof_object_symbol); -} -s7_pointer -s7i_is_byte_symbol (s7_scheme* sc) { - return (sc->is_byte_symbol); -} -s7_pointer -s7i_is_float_symbol (s7_scheme* sc) { - return (sc->is_float_symbol); -} -s7_pointer -s7i_is_random_state_symbol (s7_scheme* sc) { - return (sc->is_random_state_symbol); -} -s7_pointer -s7i_is_continuation_symbol (s7_scheme* sc) { - return (sc->is_continuation_symbol); -} -s7_pointer -s7i_is_iterator_symbol (s7_scheme* sc) { - return (sc->is_iterator_symbol); -} -s7_pointer -s7i_is_gensym_symbol (s7_scheme* sc) { - return (sc->is_gensym_symbol); -} -s7_pointer -s7i_is_syntax_symbol (s7_scheme* sc) { - return (sc->is_syntax_symbol); -} -s7_pointer -s7i_is_let_symbol (s7_scheme* sc) { - return (sc->is_let_symbol); -} -bool -s7i_is_goto (s7_pointer p) { - return (is_goto (p)); -} -bool -s7i_is_constant (s7_scheme* sc, s7_pointer p) { - return (is_constant (sc, p)); -} -s7_pointer -s7i_is_c_object_symbol (s7_scheme* sc) { - return (sc->is_c_object_symbol); -} -s7_pointer -s7i_help_symbol (s7_scheme* sc) { - return (sc->help_symbol); -} -bool -s7i_is_undefined (s7_pointer p) { - return (is_undefined (p)); -} -bool -s7i_is_eof (s7_pointer p) { - return (is_eof (p)); -} -bool -s7i_is_t_real (s7_pointer p) { - return (is_t_real (p)); -} -bool -s7i_is_continuation (s7_pointer p) { - return (is_continuation (p)); -} -const uint8_t* -s7i_uppers_ptr (void) { - return (uppers); -} -/* bridge functions for s7_scheme_predicate.c migration */ -s7_pointer -s7i_c_pointer_type (s7_pointer p) { - return (c_pointer_type (p)); -} -bool -s7i_has_methods (s7_pointer p) { - return (has_methods (p)); -} -bool -s7i_is_funclet (s7_pointer p) { - return (is_funclet (p)); -} -bool -s7i_is_maclet (s7_pointer p) { - return (is_maclet (p)); -} -s7_pointer -s7i_rootlet (s7_scheme* sc) { - return (sc->rootlet); -} -s7_pointer -s7i_is_c_pointer_symbol (s7_scheme* sc) { - return (sc->is_c_pointer_symbol); -} -s7_pointer -s7i_is_openlet_symbol (s7_scheme* sc) { - return (sc->is_openlet_symbol); +/* -------------------------------- 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); } -s7_pointer -s7i_is_funclet_symbol (s7_scheme* sc) { - return (sc->is_funclet_symbol); + +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); } -/* bridge functions for g_c_pointer_info and g_c_pointer_type migration */ -s7_pointer -s7i_c_pointer_info_p_p (s7_scheme* sc, s7_pointer cptr) { - return (c_pointer_info_p_p (sc, cptr)); +static s7_double modulo_d_7dd(s7_scheme *sc, s7_double x, s7_double y) +{ + s7_double z; + if (is_NaN(x)) return(x); + if (is_NaN(y)) return(y); + if ((is_inf(x)) || (is_inf(y))) return(NAN); + if (y == 0.0) return(x); + if (fabs(x) > 1e17) + out_of_range_error_nr(sc, sc->modulo_symbol, int_one, wrap_real(sc, x), it_is_too_large_string); + z = x / y; + if ((z > 1e19) || (z < -1e19)) + sole_arg_out_of_range_error_nr(sc, sc->modulo_symbol, + set_elist_3(sc, sc->divide_symbol, wrap_real(sc, x), wrap_real(sc, y)), + intermediate_too_large_string); + return(x - y * (s7_int)floor(z)); } -s7_pointer -s7i_c_pointer_type_p_p (s7_scheme* sc, s7_pointer cptr) { - return (c_pointer_type_p_p (sc, cptr)); + +static s7_pointer modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + 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: + 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: + { + s7_double 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)); + } } -/* bridge functions for g_tree_is_cyclic and g_type_of migration */ -/* s7i_tree_is_cyclic migrated to s7_liii_tree.c */ -s7_pointer -s7i_type_of (s7_scheme* sc, s7_pointer p) { - return (sc->type_to_typers[type (p)]); +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))); } -/* g_string_cmp, g_string_cmp_not, g_strings_are_equal, g_strings_are_less, - g_strings_are_greater, g_strings_are_geq, g_strings_are_leq, - g_string_equal_2, g_string_equal_2c, string_eq_p_pp, g_string_less_2, - string_lt_p_pp, g_string_greater_2, string_gt_p_pp, - string_lt_b_unchecked/7pp, string_leq_b_unchecked/7pp, - string_gt_b_unchecked/7pp, string_geq_b_unchecked/7pp, - string_eq_b_unchecked/7pp migrated to s7_liii_string.c */ +s7_pointer s7i_modulo_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(modulo_p_pp(sc, x, y));} -#define H_strings_are_equal \ - "(string=? str ...) returns #t if all the string arguments are equal" -#define Q_strings_are_equal sc->pcl_bs -#define H_strings_are_less \ - "(stringpcl_bs -#define H_strings_are_greater \ - "(string>? str ...) returns #t if all the string arguments are decreasing" -#define Q_strings_are_greater sc->pcl_bs -#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 -#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 +#define H_modulo "(modulo x y) returns x mod y; (modulo 4 3) = 1. The arguments can be real numbers." +#define Q_modulo sc->pcl_r -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); +/* ---------------------------------------- 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); } -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); -} +#define is_real_via_method(sc, p) ((is_real(p)) || ((has_active_methods(sc, p)) && (is_real_via_method_1(sc, p)))) -#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); -} +#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 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; +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); + } + 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); + 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); + 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); + default: + return(max_out_y(sc, x, y)); + } + break; - 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); + default: + return(max_out_x(sc, x, y)); + } + return(x); } -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 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)); } -#endif /* pure s7 */ +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)));} -/* -------------------------------- string-fill! - * -------------------------------- */ - -#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) -/* g_string_fill is now defined in s7_liii_string.c */ -/* -------------------------------- string -------------------------------- */ -const char* -s7_string (s7_pointer str) { - return (string_value (str)); -} +/* ---------------------------------------- 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) -s7_pointer -s7i_string_1 (s7_scheme* sc, s7_pointer args, s7_pointer sym) { - int32_t len; - s7_pointer chrs, newstr; - char* str; - const char* unicode_string_hint= - "string only accepts characters in range #x00..#xFF; use utf8-string for " - "Unicode characters"; +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); + } + 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); + 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); + 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); + default: + return(min_out_y(sc, x, y)); + } + break; - /* 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 (s7i_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]); + default: + return(min_out_x(sc, x, y)); } - if (s7_character (chr) > 0xFF) - out_of_range_error_nr (sc, sym, wrap_integer (sc, len + 1), chr, - wrap_string (sc, unicode_string_hint, - safe_strlen (unicode_string_hint))); - } - 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); -} - -#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) -/* g_string is now defined in s7_liii_string.c */ - -s7_pointer -s7i_string_c1 (s7_scheme* sc, s7_pointer args) { - s7_pointer c= car (args), str; - const char* unicode_string_hint= - "string only accepts characters in range #x00..#xFF; use utf8-string for " - "Unicode characters"; - /* 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)); - if (s7_character (c) > 0xFF) - out_of_range_error_nr (sc, sc->string_symbol, int_one, c, - wrap_string (sc, unicode_string_hint, - safe_strlen (unicode_string_hint))); - 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); + return(x); } -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 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)); } -/* string_p_p migrated to s7_liii_string.c */ +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)));} -/* -------------------------------- list->string - * -------------------------------- */ -#if !WITH_PURE_S7 -#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) -/* g_list_to_string is now defined in s7_liii_string.c */ -#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); +/* ---------------------------------------- = ---------------------------------------- */ +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); } -#if !WITH_PURE_S7 -#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) -/* g_string_to_list is now defined in s7_liii_string.c */ +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); +} -/* string_to_list_p_p migrated to s7_liii_string.c */ -#endif +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))); + } -/* -------------------------------- port-closed? - * -------------------------------- */ -/* g_is_port_closed is now defined in s7_scheme_predicate.c */ -#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)) - -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* new_b; + switch (type(x)) + { + case T_INTEGER: + switch (type(y)) + { + case T_RATIO: + return(false); + case T_REAL: + return(integer(x) == real(y)); + case T_COMPLEX: + return(false); + 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); + 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); + default: return(eq_out_y(sc, x, y)); + } + break; + case T_COMPLEX: + if (is_real(y)) return(false); + return(eq_out_y(sc, x, y)); - 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 */ - new_b = inline_mallocate (sc, new_size); - port_data_block (port)= new_b; - port_data (port) = (uint8_t*) (block_data (new_b)); - 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); + default: return(eq_out_x(sc, x, y)); + } + return(false); } -/* -------------------------------- 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)); -} +bool s7i_num_eq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(num_eq_b_7pp(sc, x, y));} -/* -------------------------------- 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 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); } -/* g_port_line_number is now defined in s7_scheme_predicate.c */ -#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) - -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_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)))); -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))); + 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); } -/* -------------------------------- 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 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 x, s7_int y) +{ + 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_number(x)) + return(sc->F); /* complex/ratio can't == int */ + if (has_active_methods(sc, x)) + return(find_and_apply_method(sc, x, sc->num_eq_symbol, set_plist_2(sc, x, make_integer(sc, y)))); + wrong_type_error_nr(sc, sc->num_eq_symbol, 1, x, a_number_string); +#ifdef __TINYC__ + return(sc->F); +#endif } -/* g_pair_line_number is now defined in s7_scheme_predicate.c */ -#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) - -/* -------------------------------- 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 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 (!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 bool -is_input_port_b (s7_pointer p) { - return (is_input_port (p)); + +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))); + return(sc->F); } -/* g_is_input_port is now defined in s7_scheme_predicate.c */ -#define H_is_input_port "(input-port? p) returns #t if p is an input port" -#define Q_is_input_port sc->pl_bt +s7_pointer s7i_num_eq_xx(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(num_eq_xx(sc, x, y));} -/* -------------------------------- output-port? - * -------------------------------- */ -bool -s7_is_output_port (s7_scheme* sc, s7_pointer p) { - return (is_output_port (p)); +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 -is_output_port_b (s7_pointer p) { - return (is_output_port (p)); + + +/* ---------------------------------------- < ---------------------------------------- */ +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); } -/* g_is_output_port is now defined in s7_scheme_predicate.c */ -#define H_is_output_port "(output-port? p) returns #t if p is an output port" -#define Q_is_output_port sc->pl_bt - -/* -------------------------------- current-input-port - * -------------------------------- */ -#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) -s7_pointer -s7_current_input_port (s7_scheme* sc) { - 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 - * -------------------------------- */ -#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)) -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_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 - * -------------------------------- */ -#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)) -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_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); +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); } -/* -------------------------------- 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; +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)); + } + 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)); + 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)); + 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)); + default: return(lt_out_y(sc, x, y)); + } + break; - 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 */ - } + default: return(lt_out_x(sc, x, y)); + } + return(true); } -#endif -/* -------- ports -------- */ -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 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) -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; -} + s7_pointer x = car(args), p = cdr(args); + if (is_null(cdr(p))) + return(make_boolean(sc, lt_b_7pp(sc, x, car(p)))); -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; + 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 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); +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); } -/* -------- read character/line functions moved to s7_scheme_read.c -------- */ +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))); + return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); +} -/* -------- write character functions -------- */ +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); -void -resize_port_data (s7_scheme* sc, s7_pointer port, s7_int new_size) { - const s7_int loc= port_data_size (port); - block_t* new_b; - 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))); - new_b = reallocate (sc, port_data_block (port), new_size); - port_data_block (port)= new_b; - port_data (port) = (uint8_t*) (block_data (new_b)); - 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; + 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))); + return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); } -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 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); -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); + 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)); + return(method_or_bust(sc, x, sc->lt_symbol, args, sc->type_names[T_REAL], 1)); } -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 */ -} +static inline s7_pointer lt_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, lt_b_7pp(sc, x, y)));} -#ifndef OUTPUT_FILE_PORT_LENGTH -#define OUTPUT_FILE_PORT_LENGTH 2048 -#endif +s7_pointer s7i_lt_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(lt_p_pp(sc, x, y));} -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 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 x, s7_int y) +{ + if (is_t_integer(x)) return(integer(x) < y); + if (is_t_real(x)) return(real(x) < y); + if (is_t_ratio(x)) return(ratio_lt_pi(x, y)); + return(lt_out_x(sc, x, make_integer(sc, y))); } -static void -file_write_char (s7_scheme* sc, uint8_t c, s7_pointer port) { - inline_file_write_char (sc, c, port); +static s7_pointer lt_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) {return(make_boolean(sc, lt_b_pi(sc, x, y)));} + +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 void -input_write_char (s7_scheme* sc, uint8_t c, - s7_pointer port) /* not reachable I think */ + +/* ---------------------------------------- <= ---------------------------------------- */ +static bool leq_out_x(s7_scheme *sc, s7_pointer x, s7_pointer y) { - sole_arg_wrong_type_error_nr (sc, sc->write_char_symbol, port, - an_output_port_string); + 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 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); +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); } -/* -------- write string functions -------- */ +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)); + } + 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)); + 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)); + 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)); + default: return(leq_out_y(sc, x, y)); + } + break; -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); + default: return(leq_out_x(sc, x, y)); + } + return(true); } -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 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) -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); -} + s7_pointer x = car(args), p = cdr(args); -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); + 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 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 inline s7_pointer leq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, leq_b_7pp(sc, x, y)));} +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 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); -} - -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 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 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 s7_pointer g_leq_xi(s7_scheme *sc, s7_pointer args) +{ + const s7_int y = integer(cadr(args)); + const s7_pointer x = car(args); -static void -string_display (s7_scheme* sc, const char* str, s7_pointer port) { - if (str) string_write_string (sc, str, safe_strlen (str), port); + 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))); + return(method_or_bust(sc, x, sc->leq_symbol, args, sc->type_names[T_REAL], 1)); } -static void -file_display (s7_scheme* sc, const char* str, s7_pointer port) { - if (str) { - 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 (str, port_file (port)) == EOF) - s7_warn (sc, 64, "write to %s: %s\n", port_filename (port), - strerror (errno)); -#else - fputs (str, port_file (port)); +static bool leq_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 (is_t_ratio(x)) return(ratio_leq_pi(x, y)); + if (has_active_methods(sc, x)) + return(find_and_apply_method(sc, x, sc->leq_symbol, list_2(sc, x, make_integer(sc, y)))); /* not plist */ + wrong_type_error_nr(sc, sc->leq_symbol, 1, x, sc->type_names[T_REAL]); +#ifdef __TINYC__ + return(false); #endif - } } -static void -function_display (s7_scheme* sc, const char* str, s7_pointer port) { - if (!str) return; - push_stack_direct (sc, OP_NO_VALUES); - for (; *str; str++) - (*(port_output_function (port))) (sc, *str, 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* str, s7_pointer port) { - if (str) fputs (str, stdout); -} -static void -stderr_display (s7_scheme* sc, const char* str, s7_pointer port) { - if (str) fputs (str, stderr); -} - -/* -------- skip-to-newline / white space / name readers moved to - * s7_scheme_read.c -------- */ -static token_t token (s7_scheme* sc); -token_t file_read_semicolon (s7_scheme* sc, s7_pointer port); -token_t string_read_semicolon (s7_scheme* sc, s7_pointer port); -int32_t -s7i_token (s7_scheme* sc) { - return (token (sc)); -} - -static void -port_set_filename (s7_scheme* sc, s7_pointer port, const char* name, - size_t len) { - block_t* b = inline_mallocate (sc, len + 1); - port_filename_block (port)= b; - port_filename (port) = (char*) block_data (b); - memcpy ((void*) block_data (b), (const void*) name, len); - port_filename (port)[len]= '\0'; -} - -static block_t* -mallocate_port (s7_scheme* sc) { -#define PORT_LIST 8 /* sizeof(port_t): 160 */ - block_t* blk= sc->block_lists[PORT_LIST]; - if (blk) sc->block_lists[PORT_LIST]= (block_t*) block_next (blk); - else { /* this is mallocate without the index calc */ - blk = mallocate_block (sc); - block_data (blk)= (void*) permalloc (sc, (size_t) (1 << PORT_LIST)); - block_set_index (blk, PORT_LIST); - } - block_set_size (blk, sizeof (port_t)); -#if S7_DEBUGGING - sc->blocks_mallocated[PORT_LIST]++; -#endif - return (blk); -} - -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}; - -/* read_file moved to s7_scheme_read.c */ -const port_functions_t* -s7i_input_file_functions (void) { - return (&input_file_functions); -} -const port_functions_t* -s7i_input_string_functions_1 (void) { - return (&input_string_functions_1); -} -block_t* -s7i_mallocate_port (s7_scheme* sc) { - return (mallocate_port (sc)); -} -void -s7i_port_set_filename (s7_scheme* sc, s7_pointer port, const char* name, - s7_int len) { - port_set_filename (sc, port, name, (size_t) len); -} +static s7_pointer leq_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) {return(make_boolean(sc, leq_b_pi(sc, x, y)));} -/* -------------------------------- 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); +/* bridge for g_leq_2 migration */ +bool s7i_leq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(leq_b_7pp(sc, x, y));} - 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); +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)); } -#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")); +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); } -#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 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 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 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 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)); +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)); + } + 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)); + 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)); + 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)); + default: return(gt_out_y(sc, x, y)); + } + break; -#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")); - } + default: return(gt_out_x(sc, x, y)); + } + return(true); } -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; +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) - /* 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 */ + s7_pointer x = car(args), p = cdr(args); - 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. - */ + if (is_null(cdr(p))) + return(make_boolean(sc, gt_b_7pp(sc, x, car(p)))); -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); + 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 /* 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); -} +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); -s7_pointer -s7_open_input_string (s7_scheme* sc, const char* input_string) { - return (open_input_string (sc, input_string, safe_strlen (input_string))); + 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))); + return(method_or_bust(sc, x, sc->gt_symbol, args, a_number_string, 1)); } -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)); -} +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); -/* -------------------------------- 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) - */ + if (is_t_real(x)) + return(make_boolean(sc, real(x) > y)); -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); + 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)); + + default: + return(method_or_bust(sc, x, sc->gt_symbol, args, a_number_string, 1)); + } + return(sc->T); } -#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) - -/* -------------------------------- 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 inline s7_pointer gt_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, gt_b_7pp(sc, x, y)));} +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 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; - port = car (args); - if (port == sc->F) { - s7_pointer clear; - if ((is_null (cdr (args))) || (is_boolean (cadr (args)))) - return (nil_string); - clear= cadr (args); - if_method_exists_return_value (sc, clear, sc->get_output_string_symbol, - set_mlist_2 (sc, port, clear)); - wrong_type_error_nr (sc, sc->get_output_string_symbol, 2, clear, - sc->type_names[T_BOOLEAN]); - } - if ((!is_output_port (port)) || (!is_string_port (port))) { - 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 (is_pair (cdr (args))) { - s7_pointer clear= cadr (args); - if (!is_boolean (clear)) { - if_method_exists_return_value (sc, clear, sc->get_output_string_symbol, - set_mlist_2 (sc, port, clear)); - wrong_type_error_nr (sc, sc->get_output_string_symbol, 2, clear, - sc->type_names[T_BOOLEAN]); - } - clear_port= (clear == sc->T); - } - 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 bool gt_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 (is_t_ratio(x)) return(!ratio_leq_pi(x, y)); + return(gt_out_x(sc, x, make_integer(sc, y))); } -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); +static s7_pointer gt_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) {return(make_boolean(sc, gt_b_pi(sc, x, y)));} - /* 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 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))); + 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))); + default: return(make_boolean(sc, gt_out_y(sc, x, y))); + } + break; -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)) - - 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)); - { - s7_pointer port= s7_open_input_function (sc, input_scheme_function_wrapper); - port_set_string_or_function (port, func); - return (port); - } + default: return(make_boolean(sc, gt_out_x(sc, x, y))); + } + return(sc->T); } -/* -------------------------------- 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)) - - 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)); - { - s7_pointer 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); - } +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); } -/* -------- current-input-port stack -------- */ -#define INPUT_PORT_STACK_INITIAL_SIZE 4 -/* 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 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 */ } -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 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 */ } -/* input_port_if_not_loading, s7i_input_port_if_not_loading and - * s7i_port_read_line moved to s7_scheme_read.c */ - -/* Export helper functions for s7_scheme_base.c */ -const char* -s7i_an_input_port_string (void) { - return ("an input port"); -} -const char* -s7i_a_boolean_string (void) { - return ("a boolean"); -} - -s7_pointer -s7i_an_input_port_string_obj (void) { - return (an_input_port_string); -} -s7_pointer -s7i_an_open_input_port_string_obj (void) { - return (an_open_input_port_string); -} +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)); + } + 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)); + 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)); + 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)); + default: return(geq_out_y(sc, x, y)); + } + break; -/* read-char functions moved to s7_scheme_read.c */ -/* their H_/Q_ doc/signature macros stay here: defun() in init_s7 references - * them below */ -#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) -#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) -#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) -#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) -#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) -#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) - -/* -------------------------------- write-char -------------------------------- - */ -void -port_write_unicode_char (s7_scheme* sc, uint32_t c, s7_pointer port) { - if (c < 0x80) port_write_character (port) (sc, (uint8_t) c, port); - else if (c < 0x800) { - char buf[2]; - buf[0]= 0xC0 | (c >> 6); - buf[1]= 0x80 | (c & 0x3F); - port_write_string (port) (sc, buf, 2, port); - } - else if (c < 0x10000) { - char buf[3]; - buf[0]= 0xE0 | (c >> 12); - buf[1]= 0x80 | ((c >> 6) & 0x3F); - buf[2]= 0x80 | (c & 0x3F); - port_write_string (port) (sc, buf, 3, port); - } - else { - char buf[4]; - buf[0]= 0xF0 | (c >> 18); - buf[1]= 0x80 | ((c >> 12) & 0x3F); - buf[2]= 0x80 | ((c >> 6) & 0x3F); - buf[3]= 0x80 | (c & 0x3F); - port_write_string (port) (sc, buf, 4, port); - } + default: return(geq_out_x(sc, x, y)); + } + return(true); } -/* (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 */ +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) -/* peek-char, read-byte, read-line, read-string functions moved to - * s7_scheme_read.c */ + s7_pointer x = car(args), p = cdr(args); + if (is_null(cdr(p))) + return(make_boolean(sc, geq_b_7pp(sc, x, car(p)))); -/* -------------------------------- 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) + 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); +} -#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) +static inline s7_pointer geq_p_pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(make_boolean(sc, geq_b_7pp(sc, x, y)));} +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));} -#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) +/* bridge for g_geq_2 migration */ +bool s7i_geq_b_7pp(s7_scheme *sc, s7_pointer x, s7_pointer y) {return(geq_b_7pp(sc, x, y));} -static s7_pointer eval (s7_scheme* sc, opcode_t first_op); -s7_pointer -s7i_eval (s7_scheme* sc, s7_int op) { - return (eval (sc, (opcode_t) op)); -} /* bridge for s7_scheme_read.c */ +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))))); +} -/* -------------------------------- 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 s7_pointer g_geq_xi(s7_scheme *sc, s7_pointer args) +{ + const s7_int y = integer(cadr(args)); + const s7_pointer x = car(args); -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); - } + 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))); + return(method_or_bust(sc, x, sc->geq_symbol, args, sc->type_names[T_REAL], 1)); } -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); - } +static bool geq_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 (is_t_ratio(x)) return(!ratio_lt_pi(x, 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, make_integer(sc, y)))); /* not plist */ } -#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 s7_pointer geq_p_pi(s7_scheme *sc, s7_pointer x, s7_int y) {return(make_boolean(sc, geq_b_pi(sc, x, y)));} -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); +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); } -#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 /* can this happen in glibc? */ +/* ---------------------------------------- real-part ---------------------------------------- */ +s7_double s7_real_part(s7_pointer x) +{ + switch(type(x)) { - if (sc->safety > no_safety) - s7_warn (sc, 256, "getcwd: %s\n", strerror (errno)); - memcpy ((void*) new_name, (const void*) filename, filename_len); - new_name[filename_len]= '\0'; + 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)); } - } - return (block); + return(0.0); } -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); +/* ---------------------------------------- imag-part ---------------------------------------- */ +s7_double s7_imag_part(s7_pointer x) +{ + if (is_t_complex(x)) + return(imag_part(x)); + return(0.0); } -#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); - if ((is_string_port (port)) && (port_data_size (port) >= 2) && - (port_data (port)[0] == '#') && (port_data (port)[1] == '!')) { - uint8_t* data= port_data (port); - s7_int pos = 0; - while (pos < port_data_size (port) && data[pos] != '\n') - pos++; - if (pos < port_data_size (port)) port_position (port)= pos + 1; - else port_position (port)= port_data_size (port); - } - else if (is_file_port (port)) { - int32_t c0= fgetc (port_file (port)); - if (c0 != EOF) { - int32_t c1= fgetc (port_file (port)); - if ((c0 == '#') && (c1 == '!')) { - int32_t c; - while (((c= fgetc (port_file (port))) != EOF) && (c != '\n')) { - } - } - else { - if (c1 != EOF) ungetc (c1, port_file (port)); - ungetc (c0, port_file (port)); - } - } - } - push_input_port (sc, port); - return (port); - } - return (NULL); +/* ---------------------------------------- numerator denominator ---------------------------------------- */ +static s7_int numerator_i_7p(s7_scheme *sc, s7_pointer x) +{ + if (is_t_ratio(x)) return(numerator(x)); + if (is_t_integer(x)) return(integer(x)); + return(integer(method_or_bust_p(sc, x, sc->numerator_symbol, a_rational_string))); } -s7_pointer -s7_load_with_environment (s7_scheme* sc, const char* filename, s7_pointer let) { - /* returns either the value of the load or NULL if filename not found or if - * the optional let is *s7* */ - s7_pointer port; - declare_jump_info (); - TRACK (sc); - if (let == sc->starlet) return (NULL); - if (!is_let (let)) { - s7_pointer obj_let= find_let (sc, let); - if (!is_let (obj_let)) - s7_warn (sc, 128, - "third argument to s7_load_with_environment is not a let or an " - "object that has a let"); - else let= obj_let; - } -#if WITH_C_LOADER - port= load_shared_object (sc, filename, let); - if (port) return (port); -#endif - - if (is_directory (filename)) return (NULL); - port= load_file_1 (sc, filename); - if (!port) return (NULL); +/* g_numerator is now defined in s7_scheme_predicate.c */ + #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) - set_curlet (sc, let); - 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); +/* g_denominator is now defined in s7_scheme_predicate.c */ + #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) - if (is_multiple_value (sc->value)) - sc->value= splice_in_values (sc, multiple_value (sc->value)); - return (sc->value); +static s7_int denominator_i_7p(s7_scheme *sc, s7_pointer x) +{ + if (is_t_ratio(x)) return(denominator(x)); + if (is_t_integer(x)) return(1); + return(integer(method_or_bust_p(sc, x, sc->denominator_symbol, a_rational_string))); } -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 let) { - s7_pointer port; - s7_int port_loc; - declare_jump_info (); - TRACK (sc); - - if (bytes == 0) bytes= strlen (content); - else 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, let); - 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)) +/* ---------------------------------------- number? bignum? complex? integer? byte? rational? real? ---------------------------------------- */ +/* g_is_number is now defined in s7_scheme_predicate.c */ +#define H_is_number "(number? obj) returns #t if obj is a number" +#define Q_is_number sc->pl_bt - const s7_pointer name= car (args); - const char* fname; +/* g_is_integer is now defined in s7_scheme_predicate.c */ +#define H_is_integer "(integer? obj) returns #t if obj is an integer" +#define Q_is_integer sc->pl_bt - if (!is_string (name)) - return (method_or_bust (sc, name, sc->load_symbol, args, - sc->type_names[T_STRING], 1)); +static bool is_byte(s7_pointer x) {return((s7_is_integer(x)) && (s7_integer(x) >= 0) && (s7_integer(x) < 256));} +/* g_is_byte is now defined in s7_scheme_predicate.c */ + #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 - if (is_pair (cdr (args))) { - s7_pointer let= cadr (args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if (!is_let (new_let)) - find_let_error_nr (sc, sc->load_symbol, let, new_let, 2, args); - let= new_let; - } - if (let == 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, let); - } - 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); +/* g_is_real is now defined in s7_scheme_predicate.c */ +#define H_is_real "(real? obj) returns #t if obj is a real number" +#define Q_is_real sc->pl_bt - 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); -} +/* g_is_complex is now defined in s7_scheme_predicate.c */ +#define H_is_complex "(complex? obj) returns #t if obj is a number" +#define Q_is_complex sc->pl_bt -/* -------- *load-path* -------- */ -s7_pointer -s7_load_path (s7_scheme* sc) { - return (s7_symbol_local_value (sc, sc->load_path_symbol, sc->curlet)); -} +/* g_is_rational is now defined in s7_scheme_predicate.c */ +#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 -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); -} +/* g_is_float is now defined in s7_scheme_predicate.c */ + #define H_is_float "(float? x) returns #t is x is real and not rational." + #define Q_is_float sc->pl_bt -/* ---------------- autoload ---------------- */ -#define INITIAL_AUTOLOAD_NAMES_SIZE 4 +static bool is_float_b(s7_pointer x) {return(is_t_real(x));} -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++; -} -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); +/* ---------------------------------------- nan? ---------------------------------------- */ +static bool is_nan_b_7p(s7_scheme *sc, s7_pointer x) +{ + return s7_is_nan(sc, x); } -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); -} -bool -s7i_is_closure (s7_pointer p) { - return is_closure (p); -} -bool -s7i_is_closure_star (s7_pointer p) { - return is_closure_star (p); -} -s7_pointer -s7i_missing_key_value (s7_scheme* sc) { - return missing_key_value (sc); -} -const char* -s7i_find_autoload_name (s7_scheme* sc, s7_pointer symbol, bool* already_loaded, - bool loading) { - return find_autoload_name (sc, symbol, already_loaded, loading); -} +/* ---------------------------------------- zero? ---------------------------------------- */ -/* -------- *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); -} - -static s7_pointer -g_autoload (s7_scheme* sc, s7_pointer args) { - 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)); -#ifdef __TINYC__ - return (NULL); /* make tcc happy */ -#endif +static bool is_zero(s7_pointer x) +{ + if (s7_is_integer(x)) + return s7_integer(x) == 0; + if (s7_is_real(x)) + return s7_real(x) == 0.0; + return false; /* ratios and complex numbers here are already collapsed into integers and reals */ } -/* -------------------------------- *autoload* -------------------------------- - */ -static s7_pointer -g_autoloader (s7_scheme* sc, s7_pointer args) /* the *autoload* function */ -{ - 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); +static bool is_positive(s7_scheme *sc, s7_pointer x) +{ + if (s7_is_integer(x)) + return s7_integer(x) > 0; + if (s7_is_rational(x) && !s7_is_integer(x)) + return s7_numerator(x) > 0; + if (s7_is_real(x)) + return s7_real(x) > 0.0; + s7_wrong_type_arg_error(sc, "positive?", 1, x, "a real number"); + return false; } -/* ---------------- 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 bool is_negative(s7_scheme *sc, s7_pointer x) +{ + if (s7_is_integer(x)) + return s7_integer(x) < 0; + if (s7_is_rational(x) && !s7_is_integer(x)) + return s7_numerator(x) < 0; + if (s7_is_real(x)) + return s7_real(x) < 0.0; + s7_wrong_type_arg_error(sc, "negative?", 1, x, "a real number"); + 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) */ +#if !WITH_PURE_S7 +/* ---------------------------------------- exact<->inexact exact? inexact? ---------------------------------------- */ - 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)); + +/* ---------------------------------------- integer-length ---------------------------------------- */ +static int32_t integer_length(s7_int a) +{ + if (a < 0) + { + if (a == S7_INT64_MIN) return(63); + a = -a; } - } - 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); + 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]); } -/* ---------------- 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, let; - 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 (let= sc->curlet; let_id (let) > symbol_id (sc->features_symbol); - let= let_outlet (let)) - ; - for (; let; let= let_outlet (let)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (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))); -} +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 -/* ---------------- provide ---------------- */ -static s7_pointer -c_provide (s7_scheme* sc, s7_pointer sym) { - /* this has to be relative to the curlet: (load file let) - * the things loaded are only present in let, 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); + 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))); + } + return(sole_arg_method_or_bust(sc, num, sc->integer_length_symbol, args, sc->type_names[T_INTEGER])); } -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) +static s7_int integer_length_i_i(s7_int x) {return((x < 0) ? integer_length(-(x + 1)) : integer_length(x));} +#endif /* !pure s7 */ + - 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))); -} +/* ---------------------------------------- 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) -void -s7_provide (s7_scheme* sc, const char* feature) { - c_provide (sc, make_symbol_with_strlen (sc, feature)); + 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)); + } + return(method_or_bust_p(sc, x, sc->integer_decode_float_symbol, wrap_string(sc, "a non-rational real", 19))); } -/* -------------------------------- eval-string -------------------------------- + +/* -------------------------------- 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 */ -s7_pointer -s7_eval_c_string_with_environment (s7_scheme* sc, const char* str, - s7_pointer let) { - 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), let); - if (stack_top_op_unchecked (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)) - - 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 let= cadr (args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if (!is_let (new_let)) - find_let_error_nr (sc, sc->eval_string_symbol, let, new_let, 2, args); - let= new_let; - } - set_curlet (sc, let); - } - begin_temp (sc->temp6, sc->args); /* see t101-17.scm */ - push_stack (sc, OP_EVAL_STRING, args, sc->code); - { - s7_pointer 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 random_state_copy(s7_scheme *sc, s7_pointer args) +{ + 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); } -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); - if (SHOW_EVAL_OPS) - fprintf (stderr, " call_with_input %s %s\n", display (car (args)), - display (proc)); - 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 */ +#ifndef MWC_32 + #define MWC_32 1 +#endif - 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 (!is_procedure (proc)) - if_method_exists_return_value (sc, proc, sc->call_with_input_file_symbol, - args); - if (!s7_is_aritable (sc, proc, 1)) - wrong_type_error_nr ( - sc, sc->call_with_input_file_symbol, 2, proc, - wrap_string (sc, "a procedure of one argument (the port)", 38)); - 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)); +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) + + s7_pointer r1, r2, rs; + s7_int i1, i2; /* actually want s7_uint here -- we lose the sign bit? */ + 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 MWC_32 + if (i1 < 0) + out_of_range_error_nr(sc, sc->random_state_symbol, int_one, r1, it_is_negative_string); +#endif + 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); } - 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 let= sc->value; - if (has_active_methods (sc, let)) { - 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, let, sc->code); - sc->code = caddr (sc->code); - sc->value= op_lambda (sc, sc->code); /* don't unstack */ - sc->value= - find_and_apply_method (sc, let, method, list_2 (sc, let, 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, let, 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, let, 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); + 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 MWC_32 + if (i2 < 0) + out_of_range_error_nr(sc, sc->random_state_symbol, int_two, r2, it_is_negative_string); +#endif + new_cell(sc, rs, T_RANDOM_STATE); + random_seed(rs) = (s7_uint)i1; + random_carry(rs) = (s7_uint)i2; + return(rs); } -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); -} +#define g_random_state s7_random_state -/* -------------------------------- 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, type_unchecked (iterator_sequence (iter))), - unbold_text); - if (sc->stop_at_error) abort (); - } - return (iter); +static s7_pointer random_state_getter(s7_scheme *sc, s7_pointer r, s7_int loc) +{ + if (loc == 0) return(make_integer(sc, random_seed(r))); + if (loc == 1) return(make_integer(sc, random_carry(r))); + return(sc->F); } -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, type_unchecked (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, type_unchecked (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, type_unchecked (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, type_unchecked (iterator_sequence (iter))), - unbold_text); - if (sc->stop_at_error) abort (); - } - return (iter); +static s7_pointer random_state_setter(s7_scheme *sc, s7_pointer r, s7_int loc, s7_pointer val) +{ + 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; + } + return(sc->F); } -#endif -/* -------------------------------- iterator? -------------------------------- - */ -/* g_is_iterator is now defined in s7_scheme_predicate.c */ -#define H_is_iterator "(iterator? obj) returns #t if obj is an iterator." -#define Q_is_iterator sc->pl_bt -bool -s7_is_iterator (s7_pointer obj) { - return (is_iterator (obj)); -} +/* -------------------------------- random-state? -------------------------------- */ +/* g_is_random_state is now defined in s7_scheme_predicate.c */ + #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 -static bool -is_iterator_b_7p (s7_scheme* sc, s7_pointer obj) { - return (g_is_iterator (sc, set_plist_1 (sc, obj)) != sc->F); -} +bool s7_is_random_state(s7_pointer r) {return(type(r) == T_RANDOM_STATE);} -static s7_pointer -iterator_copy (s7_scheme* sc, s7_pointer old_iter) { - s7_pointer iter; - new_cell (sc, iter, T_ITERATOR | T_SAFE_PROCEDURE); - memcpy ((void*) iter, (void*) old_iter, - 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); -} +/* -------------------------------- 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, sc->is_pair_symbol, sc->is_random_state_symbol) -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); + 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)))); } -static s7_pointer -let_iterate_uncarried (s7_scheme* sc, s7_pointer iterator) { - s7_pointer slot= let_iterator_slot (iterator); - if (!is_not_slot_end (slot)) return (iterator_quit (sc, iterator)); - let_iterator_set_slot (iterator, next_slot (slot)); - return (cons (sc, slot_symbol (slot), slot_value (slot))); -} +#define g_random_state_to_list s7_random_state_to_list -static s7_pointer -let_iterate_carried (s7_scheme* sc, s7_pointer iterator) { - s7_pointer result, slot= let_iterator_slot (iterator); - if (!is_not_slot_end (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); +void s7_set_default_random_state(s7_scheme *sc, s7_int seed, s7_int carry) +{ + 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; } -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); -} -s7_pointer -hash_table_iterate (s7_scheme* sc, s7_pointer iterator) { - s7_pointer table; - hash_entry_t** elements; - hash_entry_t* lst= hash_iterator_entry (iterator); +/* -------------------------------- random -------------------------------- */ +static double next_random(s7_pointer r) +{ +#if MWC_32 + /* 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 s7_random_state for 64 bit version of this, L26622 + * here's a check that things are not totally broken: + (define (check-random-integers lo hi) + (let* ((range (- hi lo)) + (num-bins 32) + (bins (make-int-vector num-bins 0))) + (do ((i 0 (+ i 1)) + (x (random range) (random range))) + ((= i 10000) bins) + (let ((bin (floor (* (/ x range) num-bins)))) + (set! (bins bin) (+ (bins bin) 1)))))) + (display (check-random-integers 0 9223372036854775807)) (newline) + + (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)))) + (display (list mn mx)) (newline)) + */ + #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)) + */ +#else + /* 64-bit MWC from https://prng.di.unimi.it/#shootout */ + double result; + #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 = random_seed(r), c = random_carry(r); + s7_uint u_result = x; /* Or, result = x ^ (x << 32) (see above) */ /* s7_uint == uint64_t */ + const __uint128_t t = MWC_A1 * (__uint128_t)x + c; + random_seed(r) = t; + random_carry(r) = t >> 64; + result = ((long_double)(random_seed(r)) / (long_double)4294967296.0) / (long_double)4294967295.5; +#endif - 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 */ - elements= hash_table_elements (table); - for (s7_int len= (s7_int) hash_table_size (table), - 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)); + return(result); } -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 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; -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)); + /* 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)) + { + 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))); + default: + return(method_or_bust(sc, num, sc->random_symbol, args, a_number_string, 1)); + } + return(sc->F); } -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)); +s7_double s7_random(s7_scheme *sc, s7_pointer state) +{ + return(next_random((state) ? state : sc->default_random_state)); } -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_double random_d_7d(s7_scheme *sc, s7_double x) +{ + return(x * next_random(sc->default_random_state)); } -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_int random_i_7i(s7_scheme *sc, s7_int i) +{ + return((s7_int)(i * next_random(sc->default_random_state))); } -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 g_random_i(s7_scheme *sc, s7_pointer args) +{ + return(make_integer(sc, (s7_int)(integer(car(args)) * next_random(sc->default_random_state)))); } -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 g_random_f(s7_scheme *sc, s7_pointer args) +{ + return(make_real(sc, real(car(args)) * next_random(sc->default_random_state))); } -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 g_random_1(s7_scheme *sc, s7_pointer args) +{ + 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))); + return(g_random(sc, args)); } -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 random_p_p(s7_scheme *sc, s7_pointer num) +{ + 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))); + return(g_random(sc, set_plist_1(sc, num))); } -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 random_p_p_wrapped(s7_scheme *sc, s7_pointer num) +{ + 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))); + return(g_random(sc, set_plist_1(sc, num))); } -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 let, s7_pointer iter) { - s7_pointer func; - if ((has_active_methods (sc, let)) && - ((func= find_method_with_let (sc, let, 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, let)); - 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); +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); } -/* -------------------------------- 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 g_add_i_random(s7_scheme *sc, s7_pointer args) +{ + 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! */ } -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 seq) { - s7_pointer iter; - new_cell (sc, iter, T_ITERATOR | T_SAFE_PROCEDURE | T_ITER_OK); - iterator_sequence (iter)= seq; - if (is_pair (seq)) /* by far the most common case */ - { - iterator_current (iter)= seq; - iterator_next (iter) = pair_iterate; - pair_iterator_set_slow (iter, seq); - return (iter); - } - iterator_carrier (iter)= NULL; - if (!is_let (seq)) iterator_position (iter)= 0; - - switch (type (seq)) { - case T_LET: - if (seq == sc->rootlet) { - let_iterator_set_slot (iter, sc->rootlet_slots); - iterator_next (iter)= let_iterate_uncarried; - return (iter); - } - if (seq == sc->starlet) return (starlet_make_iterator (sc, iter)); - { - s7_pointer func= find_make_iterator_method (sc, seq, iter); - if (func) return (func); - } - let_iterator_set_slot (iter, let_slots (seq)); - 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 (seq)) { - set_weak_hash_iterator (iter); - weak_hash_iters (seq)++; - add_weak_hash_iterator (sc, iter); - } - break; - - case T_STRING: - iterator_length (iter)= string_length (seq); - iterator_next (iter) = string_iterate; - break; - - case T_BYTE_VECTOR: - iterator_length (iter)= byte_vector_length (seq); - iterator_next (iter) = byte_vector_iterate; - break; - - case T_VECTOR: - iterator_length (iter)= vector_length (seq); - iterator_next (iter) = vector_iterate; - break; - - case T_INT_VECTOR: - iterator_length (iter)= vector_length (seq); - iterator_next (iter) = int_vector_iterate_uncarried; - break; - - case T_FLOAT_VECTOR: - iterator_length (iter)= vector_length (seq); - iterator_next (iter) = float_vector_iterate_uncarried; - break; - - case T_COMPLEX_VECTOR: - iterator_length (iter)= vector_length (seq); - 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, seq)) { - 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, seq)) - ? closure_length (sc, seq) - : S7_INT64_MAX; +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); } - else - sole_arg_wrong_type_error_nr ( - sc, sc->make_iterator_symbol, seq, - 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, seq); - { - s7_pointer func= find_make_iterator_method (sc, seq, iter); - if (func) return (func); - } - iterator_carrier (iter)= list_2_unchecked ( - sc, seq, 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, seq, - 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 */ +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++) { - 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)) */ + 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; + }} +} + + +s7_pointer s7_make_character(s7_scheme *sc, uint32_t c) { + if (c < 256) return(chars[c]); + if (!sc->unicode_chars_table) + { + sc->unicode_chars_table = s7_make_hash_table(sc, 128); + s7_gc_protect(sc, sc->unicode_chars_table); + if (mark_function[T_CHARACTER] == mark_noop) + mark_function[T_CHARACTER] = just_mark; + } + { + s7_pointer key = s7_make_integer(sc, (s7_int)c); + s7_pointer val = s7_hash_table_ref(sc, sc->unicode_chars_table, key); + if (val != sc->F) + return(val); + { + s7_pointer cp; + new_cell(sc, cp, T_CHARACTER | T_IMMUTABLE); + character(cp) = c; + upper_character(cp) = c; + is_char_alphabetic(cp) = false; + is_char_numeric(cp) = false; + is_char_whitespace(cp) = false; + is_char_uppercase(cp) = false; + is_char_lowercase(cp) = false; + if (c < 32 || (c >= 127 && c < 160)) + character_name_length(cp) = snprintf((char *)(&(character_name(cp))), 12, "#\\x%x", c); + else + { + char buf[12]; + int len = 2; + buf[0] = '#'; + buf[1] = '\\'; + if (c < 0x80) + buf[len++] = c; + else if (c < 0x800) + { + buf[len++] = 0xC0 | (c >> 6); + buf[len++] = 0x80 | (c & 0x3F); + } + else if (c < 0x10000) + { + buf[len++] = 0xE0 | (c >> 12); + buf[len++] = 0x80 | ((c >> 6) & 0x3F); + buf[len++] = 0x80 | (c & 0x3F); + } + else + { + buf[len++] = 0xF0 | (c >> 18); + buf[len++] = 0x80 | ((c >> 12) & 0x3F); + buf[len++] = 0x80 | ((c >> 6) & 0x3F); + buf[len++] = 0x80 | (c & 0x3F); + } + character_name_length(cp) = len; + memcpy((void *)(&(character_name(cp))), buf, len); } - set_has_carrier (iter); - } + add_semipermanent_object(sc, cp); + s7_hash_table_set(sc, sc->unicode_chars_table, key, cp); + return(cp); } } - 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 iter= lookup_checked (sc, car (sc->code)); - if (!is_iterator (iter)) { - sc->last_function= iter; - return (false); - } - sc->value= (iterator_next (iter)) (sc, iter); - 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 - * -------------------------------- */ -/* g_iterator_sequence is now defined in s7_scheme_predicate.c */ -#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) +bool s7_is_character(s7_pointer c) {return(is_character(c));} -/* iterator-length and iterator-position run up against the function iterator */ +uint32_t s7_character(s7_pointer c) {return(character(c));} -/* g_cyclic_sequences is now defined in s7_scheme_predicate.c */ -#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) -/* pair_append: general pair utility used by eval and the writer */ -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 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); } -/* -------------------------------- s7i helpers for s7_scheme_write.c - * -------------------------------- */ +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);} -bool -s7i_port_is_closed (s7_pointer p) { - return port_is_closed (p); -} -void -s7i_port_write_character (s7_scheme* sc, char c, s7_pointer port) { - port_write_character (port) (sc, c, port); +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); } -void -s7i_port_write_string (s7_scheme* sc, const char* str, s7_int len, - s7_pointer port) { - port_write_string (port) (sc, str, len, port); -} -void -s7i_port_write_unicode_char (s7_scheme* sc, uint32_t c, s7_pointer port) { - port_write_unicode_char (sc, c, port); -} +/* -------------------------------- string-position -------------------------------- */ +#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_pointer -s7i_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) { - return start_and_end (sc, caller, args, position, index_args, start, end); -} -s7_pointer -s7i_vector_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) { - const s7_pointer pstart= car (index_args); - s7_int index; +/* -------------------------------- strings -------------------------------- */ +bool s7_is_string(s7_pointer p) {return(is_string(p));} + +#define H_is_string "(string? obj) returns #t if obj is a string" +#define Q_is_string sc->pl_bt +/* g_is_string is now defined in s7_liii_string.c */ + - if (!s7_is_integer (pstart)) - return (vector_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)) - out_of_range_error_nr (sc, caller, small_int (position), pstart, - (index < 0) ? it_is_negative_string - : it_is_too_large_string); - *start= index; +s7_int s7_string_length(s7_pointer str) {return(string_length(str));} - if (is_pair (cdr (index_args))) { - const s7_pointer pend= cadr (index_args); - if (!s7_is_integer (pend)) - return (vector_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); -} -bool -s7i_is_unused (s7_scheme* sc, s7_pointer p) { - return p == sc->unused; -} +#define NUM_STRING_WRAPPERS 8 -s7_pointer -s7i_method_or_bust_p (s7_scheme* sc, s7_pointer obj, const char* method_name, - const char* type_name) { - return method_or_bust_p ( - sc, obj, s7_make_symbol (sc, method_name), - wrap_string (sc, type_name, safe_strlen (type_name))); +s7_pointer wrap_string(s7_scheme *sc, const char *str, s7_int len) +{ + const s7_pointer temp_str = car(sc->string_wrappers); +#if S7_DEBUGGING + if ((full_type(temp_str) & (~T_GC_MARK)) != (T_STRING | T_UNHEAP | T_SAFE_PROCEDURE)) + fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, describe_type_bits(sc, temp_str)); + sc->string_wrapper_allocs++; +#endif + sc->string_wrappers = cdr(sc->string_wrappers); + string_value(temp_str) = (char *)str; + string_length(temp_str) = len; + return(temp_str); } -s7_pointer -s7i_method_or_bust_pp (s7_scheme* sc, s7_pointer obj, const char* method_name, - s7_pointer x1, s7_pointer x2, const char* type_name, - s7_int arg_pos) { - return method_or_bust_pp ( - sc, obj, s7_make_symbol (sc, method_name), x1, x2, - wrap_string (sc, type_name, safe_strlen (type_name)), (int32_t) arg_pos); -} +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));} -void -s7i_division_by_zero_error (s7_scheme* sc, const char* caller, s7_pointer x, - s7_pointer y) { - division_by_zero_error_2_nr ( - sc, wrap_string (sc, caller, safe_strlen (caller)), x, y); +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); } -bool -s7i_is_subvector (s7_pointer p) { - return (is_subvector (p)); +static s7_pointer make_empty_string(s7_scheme *sc, s7_int len, char fill) {return(inline_make_empty_string(sc, len, fill));} + +s7_pointer s7i_make_empty_string(s7_scheme *sc, s7_int len, char fill) +{ + return(make_empty_string(sc, len, fill)); } -s7_pointer -s7i_int_one (s7_scheme* sc) { - (void) sc; - return (int_one); +s7_int s7i_max_string_length(s7_scheme *sc) +{ + return(sc->max_string_length); } -s7_pointer -s7i_iterator_sequence (s7_pointer iter) { - return (iterator_sequence (iter)); +s7_int s7i_max_vector_length(s7_scheme *sc) +{ + return(sc->max_vector_length); } -s7_int -s7i_subvector_position (s7_pointer p) { - if (is_subvector (p)) switch (type (p)) { - case T_VECTOR: - return ((s7_int) (vector_elements (p) - - vector_elements (subvector_vector (p)))); - case T_INT_VECTOR: - return ((s7_int) (int_vector_ints (p) - - int_vector_ints (subvector_vector (p)))); - case T_FLOAT_VECTOR: - return ((s7_int) (float_vector_floats (p) - - float_vector_floats (subvector_vector (p)))); - case T_COMPLEX_VECTOR: - return ((s7_int) (complex_vector_complexes (p) - - complex_vector_complexes (subvector_vector (p)))); - case T_BYTE_VECTOR: - return ((s7_int) (byte_vector_bytes (p) - - byte_vector_bytes (subvector_vector (p)))); - } - return (-1); -} - -s7_pointer -s7i_subvector_vector (s7_scheme* sc, s7_pointer p) { - return (subvector_vector (p)); -} -bool -s7i_is_typed_t_vector (s7_pointer p) { - return (is_typed_t_vector (p)); -} -s7_pointer -s7i_typed_vector_typer (s7_scheme* sc, s7_pointer p) { - return (typed_vector_typer (p)); -} - -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); +s7_int s7i_max_list_length(s7_scheme *sc) +{ + return(sc->max_list_length); } -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); +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 void -close_format_port (s7_scheme* sc, s7_pointer port) { - port_next (port)= (struct block_t*) (sc->format_ports); - sc->format_ports= port; +static char *make_semipermanent_c_string(s7_scheme *sc, const char *str) /* strcpy but avoid malloc */ +{ + s7_int len = safe_strlen(str); + char *new_str = (char *)permalloc(sc, len + 1); + memcpy((void *)new_str, (const void *)str, len); + new_str[len] = 0; + return(new_str); } -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); - s7i_object_out (sc, T_Pos (obj), strport, S7I_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 */ -{ - 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); - { - s7_pointer result; - const s7_pointer strport= open_format_port (sc); - s7i_object_out (sc, obj, strport, - (use_write) ? S7I_P_WRITE : S7I_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); - } +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 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_int 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)); - } - } - } - } +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); - 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 */ + 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); - 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); - { - s7_int out_len; - const s7_pointer strport= open_format_port (sc); - sc->objstr_max_len = pending_max; - s7i_object_out (sc, obj, strport, (s7i_use_write_t) 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); - } - } + 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); } -/* -------------------------------- write -------------------------------- */ -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); +/* -------------------------------- 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));} + +#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) +/* g_make_string is now defined in s7_liii_string.c */ + +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')); } -/* -------------------------------- display -------------------------------- */ -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); -} - -/* 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)) - - 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)); - { - const s7_pointer 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 - - 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)); - { - const s7_pointer 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); +#if !WITH_PURE_S7 +/* -------------------------------- string-length -------------------------------- */ + +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 -/* -------------------------------- 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)) - - 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); - { - const s7_pointer 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 - - 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)); + +/* -------------------------------- string-ref -------------------------------- */ +/* string_ref_p_pi, string_ref_p_pp, string_ref_p_p0, string_plast_via_method, + string_ref_p_plast, string_ref_p_pi_unchecked, string_ref_p_pi_direct, + string_set_p_pip, string_set_p_pip_unchecked, string_set_p_pip_direct + migrated to s7_liii_string.c */ + + +/* -------------------------------- 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(!is_not_slot_end(let_slots(seq))); /* (append (rootlet) #f) */ + default: return(false); } - 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); - { - const s7_pointer 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); } -/* -------------------------------- 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_int pair_length_1(s7_scheme *sc, s7_pointer seq) +{ + s7_int len = s7_list_length(sc, seq); + return((len == 0) ? -1 : len); } -s7_pointer -cons_unchecked (s7_scheme* sc, s7_pointer a, s7_pointer b) { - /* apparently slightly faster as a function? */ - s7_pointer p; - new_cell_unchecked (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); - set_cdr_unchecked (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) set_cdr_unchecked (end, back); - if (i < len) - s7_warn (sc, 256, "s7_make_circular_signature got too few entries: %s\n", - display (result)); - return (result); +static s7_int cobj_len(s7_scheme *sc, s7_pointer seq) +{ + s7_pointer len = c_object_length(sc, seq); + if (s7_is_integer(len)) + return(s7_integer_clamped_if_gmp(sc, len)); + return(-1); } -bool -s7_is_pair (s7_pointer p) { - return (is_pair (p)); -} -s7_pointer -is_pair_p_p (s7_scheme* sc, s7_pointer p) { - return ((is_pair (p)) ? sc->T : sc->F); +static s7_int sequence_length(s7_scheme *sc, s7_pointer seq) +{ + switch (type(seq)) + { + case T_PAIR: return(pair_length_1(sc, seq)); + 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: return(cobj_len(sc, seq)); + default: return(-1); + } } -s7_pointer -s7_car (s7_pointer p) { - return (car (p)); -} -s7_pointer -s7_cdr (s7_pointer p) { - return (cdr (p)); +bool s7i_is_sequence(s7_pointer p) +{ + return(is_sequence(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)); +bool s7i_sequence_is_empty(s7_scheme *sc, s7_pointer seq) +{ + return(sequence_is_empty(sc, seq)); } -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); +s7_int s7i_sequence_length(s7_scheme *sc, s7_pointer seq) +{ + return(sequence_length(sc, seq)); } -/* -------------------------------------------------------------------------------- - */ -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; -} +static s7_pointer s7_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args); -/* ---------------- tree-leaves, tree-memq, tree-set-memq, tree-count - * ---------------- */ -/* migrated to s7_liii_tree.c */ +/* string_append_2, s7i_string_append_1, string_append_1, string_append_p_pp, g_string_append_2 + migrated to s7_liii_string.c */ -/* -------------------------------- pair? -------------------------------- */ -#define H_is_pair "(pair? obj) returns #t if obj is a pair (a non-empty list)" -#define Q_is_pair sc->pl_bt -/* g_is_pair is now defined in s7_liii_list.c */ +#define H_string_append "(string-append str1 ...) appends all its string arguments into one string" +#define Q_string_append sc->pcl_s +/* g_string_append is now defined in s7_liii_string.c */ -/* -------------------------------- list? -------------------------------- */ -bool -s7_is_list (s7_scheme* sc, s7_pointer p) { - return (is_list (p)); -} +static void check_for_substring_temp(s7_scheme *sc, s7_pointer expr); -static bool -is_list_b (s7_pointer p) { - return ((is_pair (p)) || (type (p) == T_NIL)); +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); } -#define H_is_list "(list? obj) returns #t if obj is a pair or null" -#define Q_is_list sc->pl_bt -/* g_is_list is now defined in s7_liii_list.c */ -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); -} +/* -------------------------------- 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; -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); -} + 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; -/* -------------------------------- 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))); + 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; } - else break; - } - end_temp (sc->temp6); - end_temp (sc->x); - return (tp); -} - -s7_pointer -s7i_copy_proper_list (s7_scheme* sc, s7_pointer lst) { - return (copy_proper_list (sc, lst)); + return(sc->unused); } -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); -} +#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) +/* g_substring is now defined in s7_liii_string.c */ -#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 -/* g_is_proper_list is now defined in s7_liii_list.c */ +#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) +/* g_substring_uncopied is now defined in s7_liii_string.c */ -/* is_proper_list_p_p migrated to s7_liii_list.c */ +/* substring_uncopied_p_pii migrated to s7_liii_string.c */ -bool -is_proper_list_1 (s7_scheme* sc, s7_pointer p) { - return ((is_pair (p)) && (is_null (cdr (p)))); -} -bool -is_proper_list_2 (s7_scheme* sc, s7_pointer p) { - return ((is_pair (p)) && (is_pair (cdr (p))) && (is_null (cddr (p)))); -} -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); -} +static s7_pointer g_get_output_string(s7_scheme *sc, s7_pointer args); -/* -------------------------------- 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)); +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); + }} } -s7_pointer -s7_make_list (s7_scheme* sc, s7_int len, s7_pointer init) { - return (make_list (sc, len, init)); +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); } -/* make_list_p_pp migrated to s7_liii_list.c */ -#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) -/* g_make_list is now defined in s7_liii_list.c */ +/* -------------------------------- string-copy -------------------------------- */ +#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) +/* g_string_copy is now defined in s7_liii_string.c */ -/* -------------------------------- 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 string_copy_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer expr) +{ + if (args == 1) check_for_substring_temp(sc, expr); + return(func); } -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); - -s7_pointer -s7i_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))); -} - -#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) -/* g_list_ref is now defined in s7_liii_list.c */ +/* -------------------------------- string comparisons -------------------------------- */ +static int32_t scheme_strcmp(s7_pointer s1, s7_pointer s2) +{ + /* tricky here because str[i] must be treated as unsigned: (stringchar #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); -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))); + 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 -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); +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 (func); + return(false); } -/* list_ref_p_pi_unchecked, list_ref_p_pi, list_ref_p_pp migrated to - * s7_liii_list.c */ - -/* -------------------------------- 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 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 */ } -/* g_list_set and g_list_set_i are now defined in s7_liii_list.c */ - -#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) +/* string comparison bridge functions */ +int32_t s7i_scheme_strcmp(s7_pointer s1, s7_pointer s2) {return(scheme_strcmp(s1, s2));} +bool s7i_scheme_strings_are_equal(s7_pointer x, s7_pointer y) {return(scheme_strings_are_equal(x, y));} +bool s7i_is_string_via_method(s7_scheme *sc, s7_pointer obj) {return(is_string_via_method(sc, obj));} -/* list_set_index_check_nr, list_set_p_pip_unchecked, list_set_p_pip migrated to - * s7_liii_list.c */ +s7_pointer s7i_method_or_bust_sym(s7_scheme *sc, s7_pointer obj, s7_pointer method_sym, s7_pointer args, s7_pointer typ, s7_int arg_pos) +{ + return(method_or_bust(sc, obj, method_sym, args, typ, (int32_t)arg_pos)); +} + +s7_pointer s7i_set_plist_1(s7_scheme *sc, s7_pointer x1) {return(set_plist_1(sc, x1));} +s7_pointer s7i_string_type_name(s7_scheme *sc) {return(sc->type_names[T_STRING]);} +s7_pointer s7i_character_type_name(s7_scheme *sc) {return(sc->type_names[T_CHARACTER]);} +void s7i_check_free_heap_size(s7_scheme *sc, s7_int size) {check_free_heap_size(sc, size);} +s7_pointer s7i_string_eq_symbol(s7_scheme *sc) {return(sc->string_eq_symbol);} +s7_pointer s7i_string_lt_symbol(s7_scheme *sc) {return(sc->string_lt_symbol);} +s7_pointer s7i_string_gt_symbol(s7_scheme *sc) {return(sc->string_gt_symbol);} +s7_pointer s7i_string_leq_symbol(s7_scheme *sc) {return(sc->string_leq_symbol);} +s7_pointer s7i_string_geq_symbol(s7_scheme *sc) {return(sc->string_geq_symbol);} +bool s7i_is_true(s7_scheme *sc, s7_pointer p) {return(is_true(sc, p));} +s7_pointer s7i_is_string_symbol(s7_scheme *sc) {return(sc->is_string_symbol);} +s7_pointer s7i_is_boolean_symbol(s7_scheme *sc) {return(sc->is_boolean_symbol);} +s7_pointer s7i_is_unspecified_symbol(s7_scheme *sc) {return(sc->is_unspecified_symbol);} +s7_pointer s7i_is_number_symbol(s7_scheme *sc) {return(sc->is_number_symbol);} +s7_pointer s7i_is_integer_symbol(s7_scheme *sc) {return(sc->is_integer_symbol);} +s7_pointer s7i_is_real_symbol(s7_scheme *sc) {return(sc->is_real_symbol);} +s7_pointer s7i_is_complex_symbol(s7_scheme *sc) {return(sc->is_complex_symbol);} +s7_pointer s7i_is_rational_symbol(s7_scheme *sc) {return(sc->is_rational_symbol);} +s7_pointer s7i_is_keyword_symbol(s7_scheme *sc) {return(sc->is_keyword_symbol);} +s7_pointer s7i_is_dilambda_symbol(s7_scheme *sc) {return(sc->is_dilambda_symbol);} +s7_pointer s7i_is_sequence_symbol(s7_scheme *sc) {return(sc->is_sequence_symbol);} +s7_pointer s7i_is_symbol_symbol(s7_scheme *sc) {return(sc->is_symbol_symbol);} +s7_pointer s7i_is_input_port_symbol(s7_scheme *sc) {return(sc->is_input_port_symbol);} +s7_pointer s7i_is_output_port_symbol(s7_scheme *sc) {return(sc->is_output_port_symbol);} +s7_pointer s7i_is_macro_symbol(s7_scheme *sc) {return(sc->is_macro_symbol);} +s7_pointer s7i_is_undefined_symbol(s7_scheme *sc) {return(sc->is_undefined_symbol);} +s7_pointer s7i_is_eof_object_symbol(s7_scheme *sc) {return(sc->is_eof_object_symbol);} +s7_pointer s7i_is_byte_symbol(s7_scheme *sc) {return(sc->is_byte_symbol);} +s7_pointer s7i_is_float_symbol(s7_scheme *sc) {return(sc->is_float_symbol);} +s7_pointer s7i_is_random_state_symbol(s7_scheme *sc) {return(sc->is_random_state_symbol);} +s7_pointer s7i_is_continuation_symbol(s7_scheme *sc) {return(sc->is_continuation_symbol);} +s7_pointer s7i_is_iterator_symbol(s7_scheme *sc) {return(sc->is_iterator_symbol);} +s7_pointer s7i_is_gensym_symbol(s7_scheme *sc) {return(sc->is_gensym_symbol);} +s7_pointer s7i_is_syntax_symbol(s7_scheme *sc) {return(sc->is_syntax_symbol);} +s7_pointer s7i_is_let_symbol(s7_scheme *sc) {return(sc->is_let_symbol);} +bool s7i_is_goto(s7_pointer p) {return(is_goto(p));} +bool s7i_is_constant(s7_scheme *sc, s7_pointer p) {return(is_constant(sc, p));} +s7_pointer s7i_is_c_object_symbol(s7_scheme *sc) {return(sc->is_c_object_symbol);} +s7_pointer s7i_help_symbol(s7_scheme *sc) {return(sc->help_symbol);} +bool s7i_is_undefined(s7_pointer p) {return(is_undefined(p));} +bool s7i_is_eof(s7_pointer p) {return(is_eof(p));} +bool s7i_is_t_real(s7_pointer p) {return(is_t_real(p));} +bool s7i_is_continuation(s7_pointer p) {return(is_continuation(p));} +const uint8_t *s7i_uppers_ptr(void) {return(uppers);} -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); -} +/* bridge functions for s7_scheme_predicate.c migration */ +s7_pointer s7i_c_pointer_type(s7_pointer p) {return(c_pointer_type(p));} +bool s7i_has_methods(s7_pointer p) {return(has_methods(p));} +bool s7i_is_funclet(s7_pointer p) {return(is_funclet(p));} +bool s7i_is_maclet(s7_pointer p) {return(is_maclet(p));} +s7_pointer s7i_rootlet(s7_scheme *sc) {return(sc->rootlet);} +s7_pointer s7i_is_c_pointer_symbol(s7_scheme *sc) {return(sc->is_c_pointer_symbol);} +s7_pointer s7i_is_openlet_symbol(s7_scheme *sc) {return(sc->is_openlet_symbol);} +s7_pointer s7i_is_funclet_symbol(s7_scheme *sc) {return(sc->is_funclet_symbol);} -/* -------------------------------- list-tail -------------------------------- - */ -/* list_tail_p_pp migrated to s7_liii_list.c */ +/* bridge functions for g_c_pointer_info and g_c_pointer_type migration */ +s7_pointer s7i_c_pointer_info_p_p(s7_scheme *sc, s7_pointer cptr) {return(c_pointer_info_p_p(sc, cptr));} +s7_pointer s7i_c_pointer_type_p_p(s7_scheme *sc, s7_pointer cptr) {return(c_pointer_type_p_p(sc, cptr));} -#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 */ -/* g_list_tail is now defined in s7_liii_list.c */ +/* bridge functions for g_tree_is_cyclic and g_type_of migration */ +/* s7i_tree_is_cyclic migrated to s7_liii_tree.c */ +s7_pointer s7i_type_of(s7_scheme *sc, s7_pointer p) {return(sc->type_to_typers[type(p)]);} -/* -------------------------------- cons -------------------------------- */ -#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) -/* g_cons is now defined in s7_liii_list.c */ +/* g_string_cmp, g_string_cmp_not, g_strings_are_equal, g_strings_are_less, g_strings_are_greater, + g_strings_are_geq, g_strings_are_leq, g_string_equal_2, g_string_equal_2c, string_eq_p_pp, + g_string_less_2, string_lt_p_pp, g_string_greater_2, string_gt_p_pp, + string_lt_b_unchecked/7pp, string_leq_b_unchecked/7pp, string_gt_b_unchecked/7pp, + string_geq_b_unchecked/7pp, string_eq_b_unchecked/7pp + migrated to s7_liii_string.c */ -/* cons_p_pp migrated to s7_liii_list.c */ +#define H_strings_are_equal "(string=? str ...) returns #t if all the string arguments are equal" +#define Q_strings_are_equal sc->pcl_bs +#define H_strings_are_less "(stringpcl_bs +#define H_strings_are_greater "(string>? str ...) returns #t if all the string arguments are decreasing" +#define Q_strings_are_greater sc->pcl_bs +#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 +#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 -/* -------- car -------- */ +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); +} -#define H_car "(car pair) returns the first element of the pair" -#define Q_car sc->pl_p -/* g_car is now defined in s7_liii_list.c */ +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); +} -/* car_p_p migrated to s7_liii_list.c */ +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); +} -/* g_list_ref_at_0 is now defined in s7_liii_list.c */ -#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) -/* g_set_car is now defined in s7_liii_list.c */ +#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); -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); + 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); } -/* set_car_p_pp migrated to s7_liii_list.c */ +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; -/* -------- cdr -------- */ -#define H_cdr "(cdr pair) returns the second element of the pair" -#define Q_cdr sc->pl_p -/* g_cdr is now defined in s7_liii_list.c */ + 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); +} -/* cdr_p_p migrated to s7_liii_list.c */ +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); +} -#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) -/* g_set_cdr is now defined in s7_liii_list.c */ +#endif /* pure s7 */ -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); -} -/* set_cdr_p_pp migrated to s7_liii_list.c */ +/* -------------------------------- string-fill! -------------------------------- */ -/* -------- caar --------*/ -#define H_caar "(caar lst) returns (car (car lst)): (caar '((1 2))) -> 1" -#define Q_caar sc->pl_p -/* g_caar is now defined in s7_liii_list.c */ +#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) +/* g_string_fill is now defined in s7_liii_string.c */ -/* caar_p_p is now defined in s7_scheme_cxr.c */ -/* -------- cadr --------*/ -#define H_cadr "(cadr lst) returns (car (cdr lst)): (cadr '(1 2 3)) -> 2" -#define Q_cadr sc->pl_p -/* g_cadr is now defined in s7_liii_list.c */ +/* -------------------------------- string -------------------------------- */ +const char *s7_string(s7_pointer str) {return(string_value(str));} -/* cadr_p_p is now defined in s7_scheme_cxr.c */ +s7_pointer s7i_string_1(s7_scheme *sc, s7_pointer args, s7_pointer sym) +{ + int32_t len; + s7_pointer chrs, newstr; + char *str; + const char *unicode_string_hint = "string only accepts characters in range #x00..#xFF; use utf8-string for Unicode characters"; -/* g_list_ref_at_1 is now defined in s7_liii_list.c */ + /* 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(s7i_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 (s7_character(chr) > 0xFF) + out_of_range_error_nr(sc, sym, wrap_integer(sc, len + 1), chr, + wrap_string(sc, unicode_string_hint, safe_strlen(unicode_string_hint))); + } + 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); +} + +#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) +/* g_string is now defined in s7_liii_string.c */ -/* -------- cdar -------- */ -#define H_cdar "(cdar lst) returns (cdr (car lst)): (cdar '((1 2 3))) -> '(2 3)" -#define Q_cdar sc->pl_p -/* g_cdar is now defined in s7_liii_list.c */ +s7_pointer s7i_string_c1(s7_scheme *sc, s7_pointer args) +{ + s7_pointer c = car(args), str; + const char *unicode_string_hint = "string only accepts characters in range #x00..#xFF; use utf8-string for Unicode characters"; + /* 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)); + if (s7_character(c) > 0xFF) + out_of_range_error_nr(sc, sc->string_symbol, int_one, c, + wrap_string(sc, unicode_string_hint, safe_strlen(unicode_string_hint))); + 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); +} -/* cdar_p_p is now defined in s7_scheme_cxr.c */ +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); +} -/* -------- cddr -------- */ -#define H_cddr "(cddr lst) returns (cdr (cdr lst)): (cddr '(1 2 3 4)) -> '(3 4)" -#define Q_cddr sc->pl_p -/* g_cddr is now defined in s7_liii_list.c */ +/* string_p_p migrated to s7_liii_string.c */ -/* cddr_p_p is now defined in s7_scheme_cxr.c */ -/* -------- caaar -------- */ -/* caaar_p_p is now defined in s7_scheme_cxr.c */ +/* -------------------------------- list->string -------------------------------- */ +#if !WITH_PURE_S7 +#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) +/* g_list_to_string is now defined in s7_liii_string.c */ +#endif -#define H_caaar \ - "(caaar lst) returns (car (car (car lst))): (caaar '(((1 2)))) -> 1" -#define Q_caaar sc->pl_p -/* g_caaar is now defined in s7_liii_list.c */ -/* -------- caadr -------- */ -/* caadr_p_p is now defined in s7_scheme_cxr.c */ +/* -------------------------------- 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); +} -#define H_caadr \ - "(caadr lst) returns (car (car (cdr lst))): (caadr '(1 (2 3))) -> 2" -#define Q_caadr sc->pl_p -/* g_caadr is now defined in s7_liii_list.c */ +#if !WITH_PURE_S7 +#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) +/* g_string_to_list is now defined in s7_liii_string.c */ -/* -------- cadar -------- */ -#define H_cadar \ - "(cadar lst) returns (car (cdr (car lst))): (cadar '((1 2 3))) -> 2" -#define Q_cadar sc->pl_p -/* g_cadar is now defined in s7_liii_list.c */ +/* string_to_list_p_p migrated to s7_liii_string.c */ +#endif -/* cadar_p_p is now defined in s7_scheme_cxr.c */ -/* -------- cdaar -------- */ -/* cdaar_p_p is now defined in s7_scheme_cxr.c */ +/* -------------------------------- port-closed? -------------------------------- */ +/* g_is_port_closed is now defined in s7_scheme_predicate.c */ + #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)) -#define H_cdaar \ - "(cdaar lst) returns (cdr (car (car lst))): (cdaar '(((1 2 3)))) -> '(2 3)" -#define Q_cdaar sc->pl_p -/* g_cdaar is now defined in s7_liii_list.c */ +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); +} -/* -------- caddr -------- */ -#define H_caddr \ - "(caddr lst) returns (car (cdr (cdr lst))): (caddr '(1 2 3 4)) -> 3" -#define Q_caddr sc->pl_p -/* g_caddr is now defined in s7_liii_list.c */ -/* caddr_p_p is now defined in s7_scheme_cxr.c */ +/* -------------------------------- 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 *new_b; -/* g_list_ref_at_2 is now defined in s7_liii_list.c */ + 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 */ + new_b = inline_mallocate(sc, new_size); + port_data_block(port) = new_b; + port_data(port) = (uint8_t *)(block_data(new_b)); + port_data_size(port) = new_size; +} -/* -------- cdddr -------- */ -/* cdddr_p_p is now defined in s7_scheme_cxr.c */ -#define H_cdddr \ - "(cdddr lst) returns (cdr (cdr (cdr lst))): (cdddr '(1 2 3 4)) -> '(4)" -#define Q_cdddr sc->pl_p -/* g_cdddr is now defined in s7_liii_list.c */ +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); +} -/* -------- cdadr -------- */ -/* cdadr_p_p is now defined in s7_scheme_cxr.c */ +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); +} -#define H_cdadr \ - "(cdadr lst) returns (cdr (car (cdr lst))): (cdadr '(1 (2 3 4))) -> '(3 4)" -#define Q_cdadr sc->pl_p -/* g_cdadr is now defined in s7_liii_list.c */ -/* -------- cddar -------- */ -/* cddar_p_p is now defined in s7_scheme_cxr.c */ +/* -------------------------------- 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)); +} -#define H_cddar \ - "(cddar lst) returns (cdr (cdr (car lst))): (cddar '((1 2 3 4))) -> '(3 4)" -#define Q_cddar sc->pl_p -/* g_cddar is now defined in s7_liii_list.c */ -/* -------- caaaar -------- */ -#define H_caaaar \ - "(caaaar lst) returns (car (car (car (car lst)))): (caaaar '((((1 2))))) " \ - "-> 1" -#define Q_caaaar sc->pl_p -/* g_caaaar is now defined in s7_liii_list.c */ +/* -------------------------------- 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))); +} -/* -------- caaadr -------- */ -#define H_caaadr \ - "(caaadr lst) returns (car (car (car (cdr lst)))): (caaadr '(1 ((2 3)))) " \ - "-> 2" -#define Q_caaadr sc->pl_p -/* g_caaadr is now defined in s7_liii_list.c */ +/* g_port_line_number is now defined in s7_scheme_predicate.c */ +#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) -/* -------- caadar -------- */ -#define H_caadar \ - "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) " \ - "-> 2" -#define Q_caadar sc->pl_p -/* g_caadar is now defined in s7_liii_list.c */ +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)); +} -/* -------- cadaar -------- */ -#define H_cadaar \ - "(cadaar lst) returns (car (cdr (car (car lst)))): (cadaar '(((1 2 3)))) " \ - "-> 2" -#define Q_cadaar sc->pl_p -/* g_cadaar is now defined in s7_liii_list.c */ +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); +} -/* -------- caaddr -------- */ -/* caaddr_p_p is now defined in s7_scheme_cxr.c */ +/* -------------------------------- 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); +} -#define H_caaddr \ - "(caaddr lst) returns (car (car (cdr (cdr lst)))): (caaddr '(1 2 (3 4))) " \ - "-> 3" -#define Q_caaddr sc->pl_p -/* g_caaddr is now defined in s7_liii_list.c */ +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))); +} -/* -------- cadddr -------- */ -/* cadddr_p_p is now defined in s7_scheme_cxr.c */ +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))); +} -#define H_cadddr \ - "(cadddr lst) returns (car (cdr (cdr (cdr lst)))): (cadddr '(1 2 3 4 5)) " \ - "-> 4" -#define Q_cadddr sc->pl_p -/* g_cadddr is now defined in s7_liii_list.c */ -/* -------- cadadr -------- */ -/* cadadr_p_p is now defined in s7_scheme_cxr.c */ +/* -------------------------------- 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); +} -#define H_cadadr \ - "(cadadr lst) returns (car (cdr (car (cdr lst)))): (cadadr '(1 (2 3 4))) " \ - "-> 3" -#define Q_cadadr sc->pl_p -/* g_cadadr is now defined in s7_liii_list.c */ +/* g_pair_line_number is now defined in s7_scheme_predicate.c */ +#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) -/* -------- caddar -------- */ -/* caddar_p_p is now defined in s7_scheme_cxr.c */ -#define H_caddar \ - "(caddar lst) returns (car (cdr (cdr (car lst)))): (caddar '((1 2 3 4))) " \ - "-> 3" -#define Q_caddar sc->pl_p -/* g_caddar is now defined in s7_liii_list.c */ +/* -------------------------------- 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) -/* -------- cdaaar -------- */ -#define H_cdaaar \ - "(cdaaar lst) returns (cdr (car (car (car lst)))): (cdaaar '((((1 2 3))))) " \ - "-> '(2 3)" -#define Q_cdaaar sc->pl_p -/* g_cdaaar is now defined in s7_liii_list.c */ + 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); +} -/* -------- cdaadr -------- */ -#define H_cdaadr \ - "(cdaadr lst) returns (cdr (car (car (cdr lst)))): (cdaadr '(1 ((2 3 4)))) " \ - "-> '(3 4)" -#define Q_cdaadr sc->pl_p -/* g_cdaadr is now defined in s7_liii_list.c */ -/* -------- cdadar -------- */ -#define H_cdadar \ - "(cdadar lst) returns (cdr (car (cdr (car lst)))): (cdadar '((1 (2 3 4)))) " \ - "-> '(3 4)" -#define Q_cdadar sc->pl_p -/* g_cdadar is now defined in s7_liii_list.c */ +/* -------------------------------- 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));} -/* -------- cddaar -------- */ -#define H_cddaar \ - "(cddaar lst) returns (cdr (cdr (car (car lst)))): (cddaar '(((1 2 3 4)))) " \ - "-> '(3 4)" -#define Q_cddaar sc->pl_p -/* g_cddaar is now defined in s7_liii_list.c */ +/* g_is_input_port is now defined in s7_scheme_predicate.c */ + #define H_is_input_port "(input-port? p) returns #t if p is an input port" + #define Q_is_input_port sc->pl_bt -/* -------- cdaddr -------- */ -#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 -/* g_cdaddr is now defined in s7_liii_list.c */ -/* -------- cddddr -------- */ +/* -------------------------------- 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));} -/* cddddr_p_p is now defined in s7_scheme_cxr.c */ +/* g_is_output_port is now defined in s7_scheme_predicate.c */ + #define H_is_output_port "(output-port? p) returns #t if p is an output port" + #define Q_is_output_port sc->pl_bt -#define H_cddddr \ - "(cddddr lst) returns (cdr (cdr (cdr (cdr lst)))): (cddddr '(1 2 3 4 5)) " \ - "-> '(5)" -#define Q_cddddr sc->pl_p -/* g_cddddr is now defined in s7_liii_list.c */ -/* -------- cddadr -------- */ -/* cddadr_p_p is now defined in s7_scheme_cxr.c */ +/* -------------------------------- current-input-port -------------------------------- */ +#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) +s7_pointer s7_current_input_port(s7_scheme *sc) {return(current_input_port(sc));} -#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 -/* g_cddadr is now defined in s7_liii_list.c */ +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) -/* -------- cdddar -------- */ + 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); +} -/* cdddar_p_p is now defined in s7_scheme_cxr.c */ +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); +} -#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 -/* g_cdddar is now defined in s7_liii_list.c */ -/* -------------------------------- 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 == car_unchecked (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 */ -} +/* -------------------------------- current-output-port -------------------------------- */ +#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)) +s7_pointer s7_current_output_port(s7_scheme *sc) {return(current_output_port(sc));} -/* assq_p_pp migrated to s7_liii_list.c */ +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); +} -/* g_assq migrated to s7_scheme_predicate.c */ -#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) -/* bridge for g_assq migration */ -s7_pointer -s7i_assq_p_pp (s7_scheme* sc, s7_pointer a, s7_pointer b) { - return (assq_p_pp (sc, a, b)); +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); } -/* assv_p_pp migrated to s7_liii_list.c */ -/* g_assv migrated to s7_scheme_predicate.c */ -#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 +/* -------------------------------- current-error-port -------------------------------- */ +#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)) +s7_pointer s7_current_error_port(s7_scheme *sc) {return(current_error_port(sc));} -/* bridge for g_assv migration */ -s7_pointer -s7i_assv_p_pp (s7_scheme* sc, s7_pointer a, s7_pointer b) { - return (assv_p_pp (sc, a, b)); +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); } -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); +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 (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 */ + return(old_port); } -static bool -closure_has_two_normal_args (s7_scheme* sc, - s7_pointer eq_func) /* sc for is_null */ + +/* -------------------------------- char-ready? -------------------------------- */ +#if !WITH_PURE_S7 +static s7_pointer g_is_char_ready(s7_scheme *sc, s7_pointer args) { - 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 */ + #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 -/* g_is_eq and g_is_eqv migrated to s7_scheme_predicate.c */ -static s7_pfunc s7_bool_optimize (s7_scheme* sc, s7_pointer expr); +/* -------- ports -------- */ +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); -/* a naming experiment, "q_" to match signature "Q_" */ -#define q_call(o) o->v[0] +static void close_closed_port(s7_scheme *sc, s7_pointer port) {return;} -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 (q_call (o).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 (q_call (o).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); - } - } - } +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}; - /* 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_ppp (sc, eq_func, sc->assoc_symbol, car (args), - lst, eq_func, a_procedure_string, 3)); - 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)); - } -} -/* assoc_p_pp migrated to s7_liii_list.c */ +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 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 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 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); +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; } -/* ---------------- member, memv, memq ---------------- */ -/* s7_memq, g_memq migrated to s7_liii_list.c */ -#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 +void s7_close_input_port(s7_scheme *sc, s7_pointer port) {port_close(port)(sc, port);} -/* 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 */ -/* memq_2_p_pp migrated to s7_liii_list.c */ +/* -------------------------------- close-input-port -------------------------------- */ +static s7_pointer g_close_input_port(s7_scheme *sc, s7_pointer args) +{ + #define H_close_input_port "(close-input-port port) closes the port" + #define Q_close_input_port s7_make_signature(sc, 2, sc->is_unspecified_symbol, sc->is_input_port_symbol) -s7_pointer -s7i_memq_2_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - return (memq_2_p_pp (sc, obj, lst)); + 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); } -/* memq_3_p_pp migrated to s7_liii_list.c */ - -/* g_memq_3 migrated to s7_liii_list.c */ -/* memq_4_p_pp migrated to s7_liii_list.c */ +/* -------------------------------- 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))); +} -s7_pointer -s7i_memq_4_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - return (memq_4_p_pp (sc, obj, lst)); +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); } -/* g_memq_any migrated to s7_liii_list.c */ +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)) -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); + 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); } - } - return (func); -} - -static bool -numbers_are_eqv (s7_scheme* sc, s7_pointer x, s7_pointer y) { - /* 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; - uint8_t obj_type= type (obj); - while (true) { - 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)); - slow= cdr (slow); - if (lst == slow) return (sc->F); - } - return (sc->F); + 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); } -/* memv_p_pp migrated to s7_liii_list.c */ - -/* g_memv migrated to s7_scheme_predicate.c */ -#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 -/* bridge for g_memv migration */ -s7_pointer -s7i_memv_p_pp (s7_scheme* sc, s7_pointer a, s7_pointer b) { - return (memv_p_pp (sc, a, b)); -} - -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); +/* -------------------------------- 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; } - 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); + 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; } - return (sc->F); + port_port(port)->pf = &closed_port_functions; + port_set_closed(port, true); + port_position(port) = 0; } -static bool p_to_b (opt_info* p); +static void close_output_port(s7_scheme *sc, s7_pointer port) {port_close(port)(sc, port);} -/* -------- s7i_ bridges for list p_p migration to s7_liii_list.c -------- */ -s7_pointer -s7i_cons_safe (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); -} -s7_pointer -s7i_inline_set_car (s7_scheme* sc, s7_pointer lst, s7_pointer value) { - return (inline_set_car (sc, lst, value)); -} -s7_pointer -s7i_inline_set_cdr (s7_scheme* sc, s7_pointer lst, s7_pointer value) { - return (inline_set_cdr (sc, lst, value)); -} -bool -s7i_is_simple (s7_pointer p) { - return (is_simple (p)); -} -bool -s7i_scheme_version_is_s7 (s7_scheme* sc) { - return (sc->scheme_version == sc->s7_symbol); -} -s7_pointer -s7i_methods_or_bust_pp (s7_scheme* sc, s7_pointer obj, const char* method_name1, - const char* method_name2, s7_pointer x1, s7_pointer x2, - s7_pointer typ, s7_int num) { - return (methods_or_bust_pp (sc, obj, s7_make_symbol (sc, method_name1), - s7_make_symbol (sc, method_name2), x1, x2, typ, - (int32_t) num)); -} -s7_pointer -s7i_assoc_1 (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - return (assoc_1 (sc, obj, lst)); -} -s7_pointer -s7i_memv_number (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - return (memv_number (sc, obj, lst)); -} -s7_pointer -s7i_member (s7_scheme* sc, s7_pointer obj, s7_pointer lst) { - return (member (sc, obj, lst)); +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); } -/* s7i_tree_len, s7i_tree_is_cyclic_checked migrated to s7_liii_tree.c */ -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) +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)) - /* 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 (q_call (o).fb == p_to_b) { - s7_pointer (*fp) (opt_info* o)= q_temp (o).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 (q_call (o).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 (q_call (o).fb (o)) return (lst); - } - return (sc->F); - } - set_no_bool_opt (body); - } + 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); } - 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)); - } + s7_close_output_port(sc, port); + return(sc->unspecified); } -/* member_p_pp migrated to s7_liii_list.c */ -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); -} +/* -------- read character/line functions moved to s7_scheme_read.c -------- */ -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 -------------------------------- */ -#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) -/* g_list is now defined in s7_liii_list.c */ +/* -------- write character functions -------- */ -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); +void resize_port_data(s7_scheme *sc, s7_pointer port, s7_int new_size) +{ + const s7_int loc = port_data_size(port); + block_t *new_b; + 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))); + new_b = reallocate(sc, port_data_block(port), new_size); + port_data_block(port) = new_b; + port_data(port) = (uint8_t *)(block_data(new_b)); + port_data_size(port) = new_size; } -/* list_p_p, list_p_pp, list_p_ppp migrated to s7_liii_list.c */ -/* if the GC sees a free cell here, protect it in the caller, not here, but - * sometimes the GC is called here! */ - -const char* ordinal[11] = {"zeroth", "first", "second", "third", - "fourth", "fifth", "sixth", "seventh", - "eighth", "ninth", "tenth"}; -const s7_int ordinal_length[11]= {6, 5, 6, 5, 6, 5, 5, 7, 6, 5, 5}; - -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)); - } +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; } -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 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 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 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 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 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 */ } -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]++; +#ifndef OUTPUT_FILE_PORT_LENGTH + #define OUTPUT_FILE_PORT_LENGTH 2048 #endif - return (sc->safe_lists[num_args]); + +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; } - } - return (make_big_list (sc, num_args, sc->nil)); + port_data(port)[port_position(port)++] = c; } -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)); +static void file_write_char(s7_scheme *sc, uint8_t c, s7_pointer port) {inline_file_write_char(sc, c, port);} - 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 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 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 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); } -/* append_in_place migrated to s7_liii_list.c */ -/* -------------------------------- 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)); -} +/* -------- write string functions -------- */ -static bool -is_byte_vector_b_p (s7_pointer b) { - return (is_byte_vector (b)); +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); } -s7_int -s7_vector_length (s7_pointer vec) { - return (vector_length (vec)); +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 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 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 s7_pointer -typed_vector_typer_symbol (s7_scheme* sc, s7_pointer vec) { - s7_pointer typer_name, typer= typed_vector_typer (vec); - if (is_c_function (typer)) return (c_function_symbol (typer)); - typer_name= find_typer (sc, typer); - return ((is_symbol (typer_name)) ? typer_name : sc->anon_symbol); +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 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 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); } -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 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 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->type_error_symbol, - set_elist_3 (sc, - wrap_string (sc, - "vector-set! new value ~$ is rejected by " - "the vector's vector-typer, ~A", - 69), - val, wrap_string (sc, descr, safe_strlen (descr)))); +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 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 */ +static void string_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) { - 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); + 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 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 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 s7_pointer -byte_vector_getter (s7_scheme* sc, s7_pointer vec, s7_int loc) { - return (small_int (byte_vector (vec, loc))); + +static void string_display(s7_scheme *sc, const char *str, s7_pointer port) +{ + if (str) string_write_string(sc, str, safe_strlen(str), port); } -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 - type_error_nr (sc, sc->int_vector_set_symbol, 3, val, - sc->type_names[T_INTEGER]); - return (val); +static void file_display(s7_scheme *sc, const char *str, s7_pointer port) +{ + if (str) + { + 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(str, port_file(port)) == EOF) + s7_warn(sc, 64, "write to %s: %s\n", port_filename(port), strerror(errno)); +#else + fputs(str, port_file(port)); +#endif + } } -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 void function_display(s7_scheme *sc, const char *str, s7_pointer port) +{ + if (!str) return; + push_stack_direct(sc, OP_NO_VALUES); + for (; *str; str++) + (*(port_output_function(port)))(sc, *str, port); + unstack_with(sc, OP_NO_VALUES); + memcpy((void *)sc, (void *)(sc->stack_end), 3 * sizeof(s7_pointer)); /* code/let/args */ } -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 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 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)) - 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)) - 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 void stdout_display(s7_scheme *sc, const char *str, s7_pointer port) {if (str) fputs(str, stdout);} +static void stderr_display(s7_scheme *sc, const char *str, s7_pointer port) {if (str) fputs(str, stderr);} + + +/* -------- skip-to-newline / white space / name readers moved to s7_scheme_read.c -------- */ +static token_t token(s7_scheme *sc); +token_t file_read_semicolon(s7_scheme *sc, s7_pointer port); +token_t string_read_semicolon(s7_scheme *sc, s7_pointer port); +int32_t s7i_token(s7_scheme *sc) {return(token(sc));} + + +static void port_set_filename(s7_scheme *sc, s7_pointer port, const char *name, size_t len) +{ + block_t *b = inline_mallocate(sc, len + 1); + port_filename_block(port) = b; + port_filename(port) = (char *)block_data(b); + memcpy((void *)block_data(b), (const void *)name, len); + port_filename(port)[len] = '\0'; } -static block_t* -mallocate_empty_block (s7_scheme* sc) { - block_t* b= mallocate_block (sc); +static block_t *mallocate_port(s7_scheme *sc) +{ + #define PORT_LIST 8 /* sizeof(port_t): 160 */ + block_t *blk = sc->block_lists[PORT_LIST]; + if (blk) + sc->block_lists[PORT_LIST] = (block_t *)block_next(blk); + else + { /* this is mallocate without the index calc */ + blk = mallocate_block(sc); + block_data(blk) = (void *)permalloc(sc, (size_t)(1 << PORT_LIST)); + block_set_index(blk, PORT_LIST); + } + block_set_size(blk, sizeof(port_t)); #if S7_DEBUGGING - sc->blocks_mallocated[BLOCK_LIST]++; + sc->blocks_mallocated[PORT_LIST]++; #endif - block_data (b)= NULL; - block_info (b)= NULL; - return (b); + return(blk); } -#define mallocate_vector(Sc, Len) \ - ((Len) > 0) ? inline_mallocate (Sc, Len) : mallocate_empty_block (Sc) +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}; -extern inline s7_pointer -make_simple_vector (s7_scheme* sc, s7_int len) /* len >= 0 and < max */ +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}; + +/* read_file moved to s7_scheme_read.c */ +const port_functions_t *s7i_input_file_functions(void) {return(&input_file_functions);} +const port_functions_t *s7i_input_string_functions_1(void) {return(&input_string_functions_1);} +block_t *s7i_mallocate_port(s7_scheme *sc) {return(mallocate_port(sc));} +void s7i_port_set_filename(s7_scheme *sc, s7_pointer port, const char *name, s7_int len) {port_set_filename(sc, port, name, (size_t)len);} + + +/* -------------------------------- open-input-file -------------------------------- */ +static int32_t remember_file_name(s7_scheme *sc, const char *file) { - 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); + 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); } -static inline s7_pointer -make_simple_float_vector (s7_scheme* sc, s7_int len) /* len >= 0 and < max */ +#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) { - 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); + return(read_file(sc, fp, name, MAX_SIZE_FOR_FILE_TO_STRING_PORT_CONVERSION, "open")); } -static inline s7_pointer -make_simple_complex_vector (s7_scheme* sc, s7_int len) /* len >= 0 and < max */ + +#if !MS_WINDOWS +#include +#endif + +static bool is_directory(const char *filename) { - 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); +#if !MS_WINDOWS + #ifdef S_ISDIR + struct stat statbuf; + return((stat(filename, &statbuf) >= 0) && + (S_ISDIR(statbuf.st_mode))); + #endif +#endif + return(false); } -static inline s7_pointer -make_simple_int_vector (s7_scheme* sc, s7_int len) /* len >= 0 and < max */ +static block_t *expand_filename(s7_scheme *sc, const char *name) { - 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; +#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 -make_vector_1 (s7_scheme* sc, s7_int len, bool filled, uint8_t typ) { - s7_pointer vect; +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 (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)); +#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)); } - vector_getter (vect)= complex_vector_getter; - vector_setter (vect)= complex_vector_setter; - } - else /* byte-vector */ +#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")); { - 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); - } + 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")); } - vector_set_dimension_info (vect, NULL); - return (vect); } -#define FILLED true -#define NOT_FILLED false +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;} -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); -} +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}; -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 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 vdims_t* -make_wrap_only (s7_scheme* sc) /* this makes sc->wrap_only */ +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) { - vdims_t* vd= (vdims_t*) mallocate_block (sc); -#if S7_DEBUGGING - sc->blocks_mallocated[BLOCK_LIST]++; -#endif - vdims_original (vd) = sc->F; - vector_elements_should_be_freed (vd)= false; - vdims_rank (vd) = 1; - vdims_dims (vd) = NULL; - vdims_offsets (vd) = NULL; - return (vd); -} - -static vdims_t* -make_vdims (s7_scheme* sc, bool elements_should_be_freed, s7_int dims, - const s7_int* dim_info) { - vdims_t* vd; - if ((dims == 1) && (!elements_should_be_freed)) return (sc->wrap_only); - if (dims > 1) { - vd = (vdims_t*) mallocate (sc, dims * 2 * sizeof (s7_int)); - vdims_original (vd)= sc->F; - vector_elements_should_be_freed (vd)= elements_should_be_freed; - vdims_rank (vd) = dims; - vdims_offsets (vd) = (s7_int*) (vdims_dims (vd) + dims); - for (s7_int i= 0; i < dims; i++) - vdims_dims (vd)[i]= dim_info[i]; - for (s7_int i= dims - 1, offset= 1; i >= 0; i--) { - vdims_offsets (vd)[i]= offset; - offset*= vdims_dims (vd)[i]; - } - return (vd); - } - vd= (vdims_t*) mallocate_block (sc); -#if S7_DEBUGGING - sc->blocks_mallocated[BLOCK_LIST]++; -#endif - vdims_original (vd) = sc->F; - vector_elements_should_be_freed (vd)= elements_should_be_freed; - vdims_rank (vd) = 1; - vdims_dims (vd) = NULL; - vdims_offsets (vd) = NULL; - return (vd); -} - -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); -} + 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; -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)); -} + /* 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; -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); -} + /* 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 */ -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); -} + 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) -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); + 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)))); } -/* -------------------------------- 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; - } -} +/* -------------------------------- open-input-string -------------------------------- */ -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); -} +/* 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 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; - } +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); } -void -s7_vector_fill (s7_scheme* sc, s7_pointer vec, s7_pointer obj) { - switch (type (vec)) { - case T_FLOAT_VECTOR: - if (!is_real (obj)) - 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 */ - 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)) - 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)) - 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 /* 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 -s7i_make_simple_complex_vector (s7_scheme* sc, s7_int len) { - return (make_simple_complex_vector (sc, len)); +s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string) +{ + return(open_input_string(sc, input_string, safe_strlen(input_string))); } -s7_complex -s7i_to_c_complex (s7_pointer z) { - return (s7_to_c_complex (z)); +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)); } -s7_pointer -s7i_vector_fill_1 (s7_scheme* sc, s7_pointer caller, s7_pointer args) { - const s7_pointer vect= car (args); - s7_pointer fill; - 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" - */ - 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); - 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 (vector_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 (vector_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 (vector_method_or_bust (sc, fill, caller, args, - sc->type_names[T_COMPLEX], 2)); - } - { - s7_int start= 0, 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! - * -------------------------------- */ -#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) -/* g_vector_fill is now defined in s7_liii_vector.c */ - -/* -------------------------------- vector-append - * -------------------------------- */ -#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 -/* g_vector_append, vector_append_p_pp, vector_append_p_ppp migrated to - * s7_liii_vector.c */ -#endif +/* -------------------------------- 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) + */ -/* -------------------------------- 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)); -} +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_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_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); } -s7_pointer* -s7_vector_elements (s7_pointer vec) { - return (vector_elements (vec)); -} +#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) -/* 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); +/* -------------------------------- 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_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_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))); } -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); -} +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? + */ -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); -} +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; + port = car(args); + if (port == sc->F) + { + s7_pointer clear; + if ((is_null(cdr(args))) || (is_boolean(cadr(args)))) return(nil_string); + clear = cadr(args); + if_method_exists_return_value(sc, clear, sc->get_output_string_symbol, set_mlist_2(sc, port, clear)); + wrong_type_error_nr(sc, sc->get_output_string_symbol, 2, clear, sc->type_names[T_BOOLEAN]); + } + if ((!is_output_port(port)) || (!is_string_port(port))) + { + 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 (is_pair(cdr(args))) + { + s7_pointer clear = cadr(args); + if (!is_boolean(clear)) + { + if_method_exists_return_value(sc, clear, sc->get_output_string_symbol, set_mlist_2(sc, port, clear)); + wrong_type_error_nr(sc, sc->get_output_string_symbol, 2, clear, sc->type_names[T_BOOLEAN]); + } + clear_port = (clear == sc->T); + } + 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); -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); + /* 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; } -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]); +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))); } - } - va_end (ap); - return (index); + 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))); } -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); +/* -------------------------------- 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); } -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); +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 -#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) -/* g_vector_to_list, vector_to_list_p_p migrated to s7_liii_vector.c */ + sc->open_input_function_choices[S7_IS_CHAR_READY] = sc->is_char_ready_symbol; #endif +} -/* -------------------------------- vector -------------------------------- */ -/* g_vector, g_vector_2, g_vector_3 are now defined in s7_liii_vector.c */ - -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 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 -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); +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)) + + 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)); + { + s7_pointer port = s7_open_input_function(sc, input_scheme_function_wrapper); + port_set_string_or_function(port, func); + return(port); + } } -/* -------------------------------- float-vector - * -------------------------------- */ -/* g_float_vector is now defined in s7_liii_vector.c */ -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); +/* -------------------------------- 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 s7_pointer -float_vector_p_i (s7_scheme* sc, s7_int x) /* thash */ +static void close_output_function_port(s7_scheme *sc, s7_pointer port) { - s7_pointer vec = make_simple_float_vector (sc, 1); - float_vector (vec, 0)= (s7_double) x; - return (vec); + port_port(port)->pf = &closed_port_functions; + port_set_string_or_function(port, sc->closed_output_function); + port_set_closed(port, true); } -/* p_dd case doesn't get any hits */ -/* -------------------------------- int-vector -------------------------------- - */ -/* g_int_vector is now defined in s7_liii_vector.c */ +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}; -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); +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))); } -/* p_ii case doesn't get any hits */ - -/* -------------------------------- byte-vector -------------------------------- - */ -/* g_byte_vector is now defined in s7_liii_vector.c */ - -/* -------------------------------- complex-vector - * -------------------------------- */ -/* g_complex_vector is now defined in s7_liii_vector.c */ - -#if !WITH_PURE_S7 -/* -------------------------------- list->vector - * -------------------------------- */ -/* g_list_to_vector is now defined in s7_liii_vector.c */ - -/* -------------------------------- vector-length - * -------------------------------- */ -/* g_vector_length, vector_length_i_7p, vector_length_p_p are now defined in - * s7_liii_vector.c */ -#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_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)) + + 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)); + { + s7_pointer 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); + } } -/* g_is_subvector is now defined in s7_liii_vector.c */ -/* g_subvector_position is now defined in s7_liii_vector.c */ -/* g_subvector_vector is now defined in s7_liii_vector.c */ -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* vd= (vdims_t*) mallocate_block (sc); -#if S7_DEBUGGING - sc->blocks_mallocated[BLOCK_LIST]++; -#endif - vdims_rank (vd) = dims; - vdims_dims (vd) = (s7_int*) (vector_dimensions (vect) + skip_dims); - vdims_offsets (vd) = (s7_int*) (vector_offsets (vect) + skip_dims); - vdims_original (vd)= vect; - vector_elements_should_be_freed (vd)= false; - vector_set_dimension_info (subvect, vd); - } - else { - vector_set_dimension_info (subvect, NULL); - subvector_set_vector (subvect, vect); - } +/* -------- current-input-port stack -------- */ +#define INPUT_PORT_STACK_INITIAL_SIZE 4 - 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* vd = (vdims_t*) inline_mallocate (sc, len * 2 * sizeof (s7_int)); - vdims_rank (vd) = len; - vdims_offsets (vd) = (s7_int*) (vdims_dims (vd) + len); - vector_elements_should_be_freed (vd)= false; - ds = vdims_dims (vd); - os = vdims_offsets (vd); - 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 (vd); +/* 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); } -#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) -/* g_subvector migrated to s7_liii_vector.c */ +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); +} -s7_pointer -s7i_subvector_1 (s7_scheme* sc, s7_pointer args) { - /* (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); - vdims_t* vd = NULL; - s7_int new_len, orig_len, offset= 0; +/* input_port_if_not_loading, s7i_input_port_if_not_loading and s7i_port_read_line moved to s7_scheme_read.c */ - if (!is_any_vector (orig)) - return (vector_method_or_bust (sc, orig, sc->subvector_symbol, args, - sc->type_names[T_VECTOR], 1)); +/* Export helper functions for s7_scheme_base.c */ +const char *s7i_an_input_port_string(void) {return("an input port");} +const char *s7i_a_boolean_string(void) {return("a boolean");} - orig_len= vector_length (orig); - new_len = orig_len; +s7_pointer s7i_an_input_port_string_obj(void) {return(an_input_port_string);} +s7_pointer s7i_an_open_input_port_string_obj(void) {return(an_open_input_port_string);} - if (is_pair (cdr (args))) /* get start point in vector */ - { - const s7_pointer start= cadr (args); - if (!s7_is_integer (start)) - return (vector_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 (vector_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 (vector_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->type_error_symbol, - set_elist_1 ( - sc, wrap_string ( - sc, "a subvector must fit in the original vector", - 43))); - - vd= list_to_vdims (sc, dims); - if (vdims_rank (vd) > sc->max_vector_dimensions) { - liberate (sc, vd); - 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 (vd)[0]; - for (s7_int i= 1; i < vdims_rank (vd); i++) - new_len*= vdims_dims (vd)[i]; - if (new_len != new_end - offset) { - liberate (sc, vd); /* 14-Sep-23 */ - error_nr ( - sc, sc->value_error_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 (vd)= orig; - } +/* read-char functions moved to s7_scheme_read.c */ +/* their H_/Q_ doc/signature macros stay here: defun() in init_s7 references them below */ +#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) +#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) +#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) +#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) +#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) +#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) + + +/* -------------------------------- write-char -------------------------------- */ +void port_write_unicode_char(s7_scheme *sc, uint32_t c, s7_pointer port) +{ + if (c < 0x80) + port_write_character(port)(sc, (uint8_t)c, port); + else if (c < 0x800) + { + char buf[2]; + buf[0] = 0xC0 | (c >> 6); + buf[1] = 0x80 | (c & 0x3F); + port_write_string(port)(sc, buf, 2, port); + } + else if (c < 0x10000) + { + char buf[3]; + buf[0] = 0xE0 | (c >> 12); + buf[1] = 0x80 | ((c >> 6) & 0x3F); + buf[2] = 0x80 | (c & 0x3F); + port_write_string(port)(sc, buf, 3, port); } - } - - 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 */ - - { - s7_pointer subvect; - 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, vd); - if (!vd) 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); - } + { + char buf[4]; + buf[0] = 0xF0 | (c >> 18); + buf[1] = 0x80 | ((c >> 12) & 0x3F); + buf[2] = 0x80 | ((c >> 6) & 0x3F); + buf[3] = 0x80 | (c & 0x3F); + port_write_string(port)(sc, buf, 4, port); + } } -/* -------------------------------- vector-ref -------------------------------- +/* (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. */ -s7_pointer -s7i_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 (vector_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 (vector_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)); -} +/* should write-char, write, write-string, display, and newline count newlines for port-line-number? Currently we only accept input ports */ -/* g_vector_ref is now defined in s7_liii_vector.c */ -/* vector_ref_p_pi, vector_ref_p_pi_unchecked, t_vector_ref_p_pi_unchecked, - vector_ref_p_pii, vector_ref_p_pii_direct, t_vector_ref_p_pi_direct - migrated to s7_liii_vector.c */ +/* peek-char, read-byte, read-line, read-string functions moved to s7_scheme_read.c */ -s7_pointer -s7i_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)); -} +/* -------------------------------- 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 -/* g_vector_ref_2 is now defined in s7_liii_vector.c */ +#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) -/* -------- s7i_ bridges for vector p_p migration to s7_liii_vector.c -------- - */ -bool -s7i_is_any_vector (s7_pointer p) { - return (is_any_vector (p)); -} -bool -s7i_is_t_vector (s7_pointer p) { - return (is_t_vector (p)); -} -bool -s7i_is_typed_vector (s7_pointer p) { - return (is_typed_vector (p)); -} -bool -s7i_is_immutable_vector (s7_pointer p) { - return (is_immutable_vector (p)); -} -s7_pointer -s7i_vector_element (s7_pointer p, s7_int i) { - return (vector_element (p, i)); -} -void -s7i_vector_element_set (s7_pointer p, s7_int i, s7_pointer v) { - vector_element (p, i)= v; -} -s7_pointer -s7i_vector_getter_ref (s7_scheme* sc, s7_pointer p, s7_int i) { - return (vector_getter (p) (sc, p, i)); -} -s7_pointer -s7i_vector_setter_set (s7_scheme* sc, s7_pointer p, s7_int i, s7_pointer v) { - vector_setter (p) (sc, p, i, v); -} -s7_pointer -s7i_typed_vector_setter (s7_scheme* sc, s7_pointer p, s7_int i, s7_pointer v) { - return (typed_vector_setter (sc, p, i, v)); -} -s7_int -s7i_vector_offset (s7_pointer p, s7_int i) { - return (vector_offset (p, i)); -} -s7_pointer -s7i_small_int (s7_int val) { - return (small_int (val)); -} -uint8_t -s7i_byte_vector_element (s7_pointer p, s7_int i) { - return (byte_vector (p, i)); -} -void -s7i_byte_vector_element_set (s7_pointer p, s7_int i, uint8_t v) { - byte_vector (p, i)= v; -} -s7_pointer -s7i_g_vector_set (s7_scheme* sc, s7_pointer plist) { - return (g_vector_set (sc, plist)); -} -s7_pointer -s7i_set_plist_4 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, - s7_pointer x4) { - return (set_plist_4 (sc, x1, x2, x3, x4)); -} -s7_pointer -s7i_vector_append_2 (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); - sc->temp7= sc->unused; - return (val); -} -s7_pointer -s7i_vector_append_3 (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); - sc->temp7= sc->unused; - return (val); -} +#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) -/* g_vector_ref_3 migrated to s7_liii_vector.c */ +#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 -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); -} +static s7_pointer eval(s7_scheme *sc, opcode_t first_op); +s7_pointer s7i_eval(s7_scheme *sc, s7_int op) {return(eval(sc, (opcode_t)op));} /* bridge for s7_scheme_read.c */ -/* -------------------------------- vector-set! -------------------------------- - */ -#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) -/* g_vector_set, g_vector_set_3, g_vector_set_4 migrated to s7_liii_vector.c */ -/* vector_set_p_pip, vector_set_p_pip_unchecked, vector_set_p_piip, - vector_set_p_piip_direct, typed_vector_set_p_pip_unchecked, - typed_vector_set_p_piip_direct, t_vector_set_p_pip_direct, - typed_t_vector_set_p_pip_direct migrated to s7_liii_vector.c */ -/* vector_set_p_ppp migrated to s7_liii_vector.c */ +/* -------------------------------- 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 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); +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); + } } -/* -------------------------------- 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 */ - 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)) - 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); +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 - len*= s7_integer_clamped_if_gmp (sc, dim); +#define TRACK(Sc) #endif - if (len < 0) - 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))))) - type_error_nr (sc, caller, 2, typf, - wrap_string (sc, "a boolean procedure", 19)); - if (!c_function_name (typf)) - 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 lst) { - vdims_t* vd = list_to_vdims (sc, lst); - vdims_original (vd)= sc->F; - vector_set_dimension_info (vec, vd); - add_multivector (sc, vec); - return (vec); -} - -s7_pointer -s7i_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) - type_error_nr (sc, caller, 1, dims, a_non_negative_integer_string); - } - else { - if (!is_pair (dims)) - return (vector_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))) - 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 */ - 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)))) - 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)) - 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)) - type_error_nr (sc, caller, 2, fill, sc->type_names[T_INTEGER]); - result_type= T_INT_VECTOR; - } - else if (typf == global_value (sc->is_byte_symbol)) { - if (!is_byte (fill)) - 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)) - 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); - 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); +/* various changes in this section courtesy of Woody Douglass 12-Jul-19 */ - if ((is_c_function (typf)) && (c_function_has_simple_elements (typf))) - set_has_simple_elements (vec); +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); } - 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); - } + return(NULL); } -#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? */ -/* g_make_vector is now defined in s7_liii_vector.c */ - -/* -------------------------------- make-float-vector - * -------------------------------- */ -#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) -/* g_make_float_vector migrated to s7_liii_vector.c */ +#if WITH_C_LOADER +#include -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 - * -------------------------------- */ -#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) -/* g_make_complex_vector migrated to s7_liii_vector.c */ - -/* -------------------------------- make-int-vector - * -------------------------------- */ -#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) -/* g_make_int_vector migrated to s7_liii_vector.c */ - -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 - * -------------------------------- */ -#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) -/* g_make_byte_vector migrated to s7_liii_vector.c */ - -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)) - 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); - } +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 /* can this happen in glibc? */ + { + if (sc->safety > no_safety) + s7_warn(sc, 256, "getcwd: %s\n", strerror(errno)); + memcpy((void *)new_name, (const void *)filename, filename_len); + new_name[filename_len] = '\0'; + }} + return(block); } -/* -------------------------------- vector? -------------------------------- */ -/* g_is_vector is now defined in s7_liii_vector.c */ +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; -/* -------------------------------- vector-rank -------------------------------- - */ -s7_int -s7_vector_rank (s7_pointer vec) { - return ((s7_int) (vector_rank (vec))); + 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 -/* g_vector_rank is now defined in s7_liii_vector.c */ +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); + if ((is_string_port(port)) && + (port_data_size(port) >= 2) && + (port_data(port)[0] == '#') && + (port_data(port)[1] == '!')) + { + uint8_t *data = port_data(port); + s7_int pos = 0; + while (pos < port_data_size(port) && data[pos] != '\n') + pos++; + if (pos < port_data_size(port)) + port_position(port) = pos + 1; + else port_position(port) = port_data_size(port); + } + else + if (is_file_port(port)) + { + int32_t c0 = fgetc(port_file(port)); + if (c0 != EOF) + { + int32_t c1 = fgetc(port_file(port)); + if ((c0 == '#') && + (c1 == '!')) + { + int32_t c; + while (((c = fgetc(port_file(port))) != EOF) && + (c != '\n')) + {} + } + else + { + if (c1 != EOF) + ungetc(c1, port_file(port)); + ungetc(c0, port_file(port)); + } + } + } + push_input_port(sc, port); + return(port); + } + return(NULL); +} -/* -------------------------------- vector-dimension - * -------------------------------- */ -/* g_vector_dimension is now defined in s7_liii_vector.c */ +s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer let) +{ + /* returns either the value of the load or NULL if filename not found or if the optional let is *s7* */ + s7_pointer port; + declare_jump_info(); + TRACK(sc); + if (let == sc->starlet) return(NULL); + if (!is_let(let)) + { + s7_pointer obj_let = find_let(sc, let); + if (!is_let(obj_let)) + s7_warn(sc, 128, "third argument to s7_load_with_environment is not a let or an object that has a let"); + else let = obj_let; + } +#if WITH_C_LOADER + port = load_shared_object(sc, filename, let); + if (port) return(port); +#endif -/* -------------------------------- vector-dimensions - * -------------------------------- */ -/* g_vector_dimensions is now defined in s7_liii_vector.c */ + if (is_directory(filename)) return(NULL); + port = load_file_1(sc, filename); + if (!port) return(NULL); -/* -------------------------------- vector-typer - * -------------------------------- */ -/* g_vector_typer, g_set_vector_typer migrated to s7_liii_vector.c */ + set_curlet(sc, let); + push_stack(sc, OP_LOAD_RETURN_IF_EOF, port, sc->code); -s7_pointer -s7i_set_vector_typer_1 (s7_scheme* sc, s7_pointer args) { - s7_pointer vec= car (args), typer= cadr (args); - - if (!is_any_vector (vec)) - 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->type_error_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 */ + store_jump_info(sc); + set_jump_info(sc, load_set_jump); + if (jump_loc == no_jump) + { + eval(sc, OP_READ_INTERNAL); } - } - else { - if (is_c_function (typer)) - check_vector_typer_c_function (sc, sc->vector_typer_symbol, - typer); /* this is just error checking */ - else { - s7_pointer typer_name; - if (!is_any_closure (typer)) - type_error_nr ( - sc, sc->vector_typer_symbol, 2, typer, - wrap_string (sc, "a built-in procedure, a closure, #f or #t", 41)); - typer_name= find_typer (sc, typer); - if (!is_symbol (typer_name)) - error_nr ( - sc, sc->type_error_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "can't set! vector-typer to ~A because it has no name", - 52), - typer)); - } - 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); + 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); } -/* -------------------------------- multivector -------------------------------- - */ -#define MULTIVECTOR_TOO_MANY_ELEMENTS -1 -#define MULTIVECTOR_NOT_ENOUGH_ELEMENTS -2 +s7_pointer s7_load(s7_scheme *sc, const char *filename) {return(s7_load_with_environment(sc, filename, sc->rootlet));} -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); -} +s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer let) +{ + s7_pointer port; + s7_int port_loc; + declare_jump_info(); + TRACK(sc); -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); -} + if (bytes == 0) + bytes = strlen(content); + else + 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, let); + 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); -s7_pointer -proper_list_reverse_in_place (s7_scheme* sc, s7_pointer list) { - return (reverse_in_place_unchecked (sc, sc->nil, list)); + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return(sc->value); } -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)); +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)); } -/* g_multivector migrated to s7_liii_vector.c */ -s7_pointer -s7i_multivector_1 (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; +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)) - /* (#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 - */ + const s7_pointer name = car(args); + const char *fname; - 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); - } - } + 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 let = cadr(args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->load_symbol, let, new_let, 2, args); + let = new_let; + } + if (let == 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, let); + } + 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 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); + s7_pointer p = load_shared_object(sc, fname, sc->curlet); + if (p) return(p); } -} - -/* g_int_multivector migrated to s7_liii_vector.c */ -s7_pointer -s7i_int_multivector_1 (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])) - type_error_nr (sc, wrap_string (sc, "#i(...)", 7), i + 1, src[i], - sc->type_names[T_INTEGER]); - sc->args= s7i_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))); -} +#endif + errno = 0; + if (!load_file_1(sc, fname)) + file_error_nr(sc, "load", strerror(errno), fname); -/* g_byte_multivector migrated to s7_liii_vector.c */ -s7_pointer -s7i_byte_multivector_1 (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])) - type_error_nr (sc, wrap_string (sc, "#u8(...)", 8), i + 1, src[i], - wrap_string (sc, "a byte", 6)); - sc->args= s7i_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))); + 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); } -/* g_float_multivector migrated to s7_liii_vector.c */ -s7_pointer -s7i_float_multivector_1 (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])) - type_error_nr (sc, wrap_string (sc, "#r(...)", 7), i + 1, src[i], - sc->type_names[T_REAL]); - sc->args= s7i_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))); -} -/* g_complex_multivector migrated to s7_liii_vector.c */ -s7_pointer -s7i_complex_multivector_1 (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])) - type_error_nr (sc, wrap_string (sc, "#c(...)", 7), i + 1, src[i], - sc->type_names[T_COMPLEX]); - sc->args= s7i_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); - 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) */ - { - s7_pointer* 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= s7i_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= s7i_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= s7i_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= s7i_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 ( - vector_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 (vector_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 (vector_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 ( - vector_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 (vector_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 (vector_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); - } +/* -------- *load-path* -------- */ +s7_pointer s7_load_path(s7_scheme *sc) {return(s7_symbol_local_value(sc, sc->load_path_symbol, sc->curlet));} - if (typ == T_FLOAT_VECTOR) { - if (!is_real (val)) - return (vector_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 (vector_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 (vector_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 (vector_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 - * -------------------------------- */ -#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) -s7_pointer -s7i_univect_ref_complex (s7_scheme* sc, s7_pointer args) { - return ( - univect_ref (sc, args, sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR)); +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); } -/* g_complex_vector_ref migrated to s7_liii_vector.c */ -static s7_pointer -complex_vector_ref_p_pp (s7_scheme* sc, s7_pointer vec, s7_pointer index) { - if (!is_complex_vector (vec)) - return (vector_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 (vector_method_or_bust_pp (sc, index, sc->complex_vector_ref_symbol, - vec, index, sc->type_names[T_INTEGER], - 2)); - { - s7_int 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))); - } -} +/* ---------------- autoload ---------------- */ +#define INITIAL_AUTOLOAD_NAMES_SIZE 4 -s7_pointer -s7i_complex_vector_ref_p_pp (s7_scheme* sc, s7_pointer vec, s7_pointer index) { - return (complex_vector_ref_p_pp (sc, vec, index)); +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 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))); +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); } -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! - * -------------------------------- */ -#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) -s7_pointer -s7i_univect_set_complex (s7_scheme* sc, s7_pointer args) { - return ( - univect_set (sc, args, sc->complex_vector_set_symbol, T_COMPLEX_VECTOR)); +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); } -/* g_complex_vector_set migrated to s7_liii_vector.c */ -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) { - if (!is_complex_vector (vec)) - return (vector_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 (vector_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 (vector_method_or_bust_ppp (sc, value, sc->complex_vector_set_symbol, - vec, index, value, - sc->type_names[T_COMPLEX], 3)); - { - s7_int 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); +bool s7i_is_closure(s7_pointer p) { return is_closure(p); } +bool s7i_is_closure_star(s7_pointer p) { return is_closure_star(p); } +s7_pointer s7i_missing_key_value(s7_scheme *sc) { return missing_key_value(sc); } +const char *s7i_find_autoload_name(s7_scheme *sc, s7_pointer symbol, bool *already_loaded, bool loading) +{ + return find_autoload_name(sc, symbol, already_loaded, loading); } -s7_pointer -s7i_complex_vector_set_p_ppp (s7_scheme* sc, s7_pointer vec, s7_pointer index, - s7_pointer value) { - return (complex_vector_set_p_ppp (sc, vec, index, value)); +/* -------- *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); } -/* 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 g_autoload(s7_scheme *sc, s7_pointer args) +{ + 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)); -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); -} + 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)); -/* -------------------------------- float-vector-ref - * -------------------------------- */ -#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) -s7_pointer -s7i_univect_ref_float (s7_scheme* sc, s7_pointer args) { - return (univect_ref (sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR)); + 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)); +#ifdef __TINYC__ + return(NULL); /* make tcc happy */ +#endif } -/* g_float_vector_ref, g_fv_ref_3 migrated to s7_liii_vector.c */ -static inline s7_pointer -float_vector_ref_p_pp (s7_scheme* sc, s7_pointer vec, s7_pointer index) { - if (!is_float_vector (vec)) - return (vector_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 (vector_method_or_bust_pp (sc, index, sc->float_vector_ref_symbol, - vec, index, sc->type_names[T_INTEGER], - 2)); - { - s7_int 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))); - } +/* -------------------------------- *autoload* -------------------------------- */ +static s7_pointer g_autoloader(s7_scheme *sc, s7_pointer args) /* the *autoload* function */ +{ + 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); } -s7_pointer -s7i_float_vector_ref_p_pp (s7_scheme* sc, s7_pointer vec, s7_pointer index) { - return (float_vector_ref_p_pp (sc, vec, index)); +/* ---------------- 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 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! - * -------------------------------- */ -#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) -s7_pointer -s7i_univect_set_float (s7_scheme* sc, s7_pointer args) { - return (univect_set (sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR)); -} -/* g_float_vector_set, g_fv_set_3 migrated to s7_liii_vector.c */ +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) */ -static s7_pointer -float_vector_set_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - return ((args == 3) ? sc->fv_set_3 : 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)) - 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 - * -------------------------------- */ -#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) -s7_pointer -s7i_univect_ref_int (s7_scheme* sc, s7_pointer args) { - return (univect_ref (sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR)); + 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); } -/* g_int_vector_ref, g_iv_ref_3 migrated to s7_liii_vector.c */ -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 (vector_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 (vector_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))); -} - -s7_pointer -s7i_int_vector_ref_p_pp (s7_scheme* sc, s7_pointer vec, s7_pointer index) { - return (int_vector_ref_p_pp (sc, vec, index)); -} - -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! - * -------------------------------- */ -#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) -s7_pointer -s7i_univect_set_int (s7_scheme* sc, s7_pointer args) { - return (univect_set (sc, args, sc->int_vector_set_symbol, T_INT_VECTOR)); -} -/* g_int_vector_set, g_iv_set_3 migrated to s7_liii_vector.c */ -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 (vector_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 (vector_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 (vector_method_or_bust_ppp (sc, value, sc->int_vector_set_symbol, - vec, index, value, - sc->type_names[T_INTEGER], 3)); - if (S7_DEBUGGING) - fprintf (stderr, "fell through %s[%d]\n", __func__, __LINE__); - } - 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 - * -------------------------------- */ -#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) -s7_pointer -s7i_univect_ref_byte (s7_scheme* sc, s7_pointer args) { - return (univect_ref (sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR)); +/* ---------------- 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, let; + 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 (let = sc->curlet; let_id(let) > symbol_id(sc->features_symbol); let = let_outlet(let)); + for (; let; let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(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 */ } -/* g_byte_vector_ref, g_bv_ref_2, g_bv_ref_3 migrated to s7_liii_vector.c */ -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 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))); } -/* byte_vector_ref_p_pi_direct migrated to s7_liii_vector.c */ -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 -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 - * -------------------------------- */ -#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) -s7_pointer -s7i_univect_set_byte (s7_scheme* sc, s7_pointer args) { - return (univect_set (sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR)); -} -/* g_byte_vector_set, g_bv_set_3 migrated to s7_liii_vector.c */ -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)) - type_error_nr (sc, sc->byte_vector_set_symbol, 1, vec, - a_byte_vector_string); - if ((byte < 0) || (byte > 255)) - 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); +/* ---------------- provide ---------------- */ +static s7_pointer c_provide(s7_scheme *sc, s7_pointer sym) +{ + /* this has to be relative to the curlet: (load file let) + * the things loaded are only present in let, 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_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 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))); } -/* byte_vector_set_p_pip_direct migrated to s7_liii_vector.c */ +void s7_provide(s7_scheme *sc, const char *feature) {c_provide(sc, make_symbol_with_strlen(sc, feature));} -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)) - 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 -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)); +/* -------------------------------- eval-string -------------------------------- */ +s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer let) +{ + 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), let); + if (stack_top_op_unchecked(sc) == OP_GC_PROTECT) unstack_gc_protect(sc); /* pop_stack(sc); */ + return(result); } -/* -------------------------------- sort! -------------------------------- */ -static int32_t -dbl_less (const void* x1, const void* x2) { - if ((*((const s7_double*) x1)) < (*((const s7_double*) x2))) return (-1); - return (((*((const s7_double*) x1)) > (*((const s7_double*) x2))) ? 1 : 0); -} +s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str) {return(s7_eval_c_string_with_environment(sc, str, sc->nil));} -static int32_t -int_less (const void* x1, const void* x2) { - if ((*((const s7_int*) x1)) < (*((const s7_int*) x2))) return (-1); - return (((*((const s7_int*) x1)) > (*((const s7_int*) x2))) ? 1 : 0); +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)) + + 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 let = cadr(args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->eval_string_symbol, let, new_let, 2, args); + let = new_let; + } + set_curlet(sc, let); + } + begin_temp(sc->temp6, sc->args); /* see t101-17.scm */ + push_stack(sc, OP_EVAL_STRING, args, sc->code); + { + s7_pointer 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 int32_t -dbl_greater (const void* x1, const void* x2) { - return (-dbl_less (x1, x2)); -} -static int32_t -int_greater (const void* x1, const void* x2) { - return (-int_less (x1, x2)); +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); + if (SHOW_EVAL_OPS) fprintf(stderr, " call_with_input %s %s\n", display(car(args)), display(proc)); + 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 int32_t -byte_less (const void* x1, const void* x2) { - if ((*((const uint8_t*) x1)) < (*((const uint8_t*) x2))) return (-1); - return (((*((const uint8_t*) x1)) > (*((const uint8_t*) x2))) ? 1 : 0); -} +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 */ -static int32_t -byte_greater (const void* x1, const void* x2) { - return (-byte_less (x1, x2)); + 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)); } -static int32_t -dbl_less_2 (const void* x1, const void* x2) { - s7_double x= real (*((const s7_pointer*) x1)); - s7_double y= real (*((const s7_pointer*) x2)); - if (x < y) return (-1); - return ((x > y) ? 1 : 0); -} -static int32_t -int_less_2 (const void* x1, const void* x2) { - s7_int i1= integer (*((const s7_pointer*) x1)); - s7_int i2= integer (*((const s7_pointer*) x2)); - if (i1 < i2) return (-1); - return ((i1 > i2) ? 1 : 0); -} +/* -------------------------------- 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 -static int32_t -dbl_greater_2 (const void* x1, const void* x2) { - return (-dbl_less_2 (x1, x2)); -} -static int32_t -int_greater_2 (const void* x1, const void* x2) { - return (-int_less_2 (x1, x2)); + 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 (!is_procedure(proc)) + if_method_exists_return_value(sc, proc, sc->call_with_input_file_symbol, args); + if (!s7_is_aritable(sc, proc, 1)) + wrong_type_error_nr(sc, sc->call_with_input_file_symbol, 2, proc, + wrap_string(sc, "a procedure of one argument (the port)", 38)); + 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)); } -static int32_t -str_less_2 (const void* s1, const void* s2) { - s7_pointer str1= (*((const s7_pointer*) s1)); - s7_pointer str2= (*((const s7_pointer*) s2)); - return (scheme_strcmp (str1, str2)); -} -static int32_t -str_greater_2 (const void* s1, const void* s2) { - return (-str_less_2 (s1, s2)); +/* -------------------------------- 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 int32_t -chr_less_2 (const void* p1, const void* p2) { - uint8_t c1= character (*((const s7_pointer*) p1)); - uint8_t c2= character (*((const s7_pointer*) p2)); - if (c1 < c2) return (-1); - return ((c1 > c2) ? 1 : 0); +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 int32_t -chr_greater_2 (const void* c1, const void* c2) { - return (-chr_less_2 (c1, c2)); -} +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 -#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); + 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)); } -#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); +/* -------------------------------- 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 int32_t -vector_sort_lt (const void* v1, const void* v2, void* arg) /* for qsort_r */ +static s7_pointer with_string_in(s7_scheme *sc, s7_pointer unused_args) { - 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); + 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 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 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 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 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 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 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 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 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 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 ((q_temp (sc->opts[0]).fp (sc->opts[0]) == sc->F) ? 1 : -1); +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)); } -#define sort_o1 1 -#define q_sort(o, i) o->v[sort_o1 + i] -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= q_sort (top, i).o1; - q_call (o).fp (o); - } - o= q_sort (top, i).o1; - if (int_expr) return ((q_call (o).fb (o)) ? -1 : 1); - return ((q_call (o).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= q_sort (top, 0).o1; - q_call (o).fp (o); - o= q_sort (top, 1).o1; - return ((q_call (o).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= cadr (args); - 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 */ - 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)); - if (is_let (data)) - if_method_exists_return_value (sc, data, sc->sort_symbol, args); - - if (type (lessp) <= T_GOTO) - 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); - if ((is_any_macro (lessp)) && (!is_c_macro (lessp))) - clear_all_optimizations (sc, closure_body (lessp)); - sort_func = NULL; - sc->sort_f= NULL; +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* */ +} - 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); - } +#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); - if (!sort_func) { - s7_pointer init_val; - const s7_pointer old_let = sc->curlet; - const s7_pointer lessp_body= closure_body (lessp); - 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 (lessp_body))) { - if (!no_bool_opt (lessp_body)) { - s7_pfunc sf1= s7_bool_optimize (sc, lessp_body); - if (sf1) { - if (q_call (sc->opts[0]).fb == p_to_b) - sort_func= opt_bool_sort_p; - else { - sc->sort_o = sc->opts[0]; - sc->sort_fb= q_call (sc->sort_o).fb; - sort_func = (sc->pc == 1) ? opt_bool_sort_0 : opt_bool_sort; - } - } - else set_no_bool_opt (lessp_body); - } - } - else { - sc->sort_body_len= s7_list_length (sc, lessp_body); - 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= 0, p= lessp_body; is_pair (cdr (p)); - ctr++, p = cdr (p)) { - q_sort (top, ctr).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, p)) break; - } - if (is_null (cdr (p))) { - int32_t start = sc->pc; - q_sort (top, 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_let); - } - 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)); - } - } +static void op_with_io_1_method(s7_scheme *sc) +{ + const s7_pointer let = sc->value; + if (has_active_methods(sc, let)) + { + 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, let, sc->code); + sc->code = caddr(sc->code); + sc->value = op_lambda(sc, sc->code); /* don't unstack */ + sc->value = find_and_apply_method(sc, let, method, list_2(sc, let, sc->value)); } - } - - { - s7_int len= 0; - 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; + 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, let, 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, let, sc->type_names[T_STRING]); +} - default: - return (method_or_bust (sc, data, sc->sort_symbol, args, - wrap_string (sc, "a sortable sequence", 19), 1)); - } - { - s7_int n = len - 1; - s7_int k = (n / 2) + 1; - s7_pointer 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); +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); } - } - 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. - */ + push_stack_no_args_direct(sc, OP_WITH_IO_1); + sc->code = sc->value; + return(true); } -/* 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); - const s7_int len = vector_length (vect); - s7_int i = 0; - 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 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 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 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); } -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(Sc) integer (vector_element (Sc->code, 0)) -#define sort_k(Sc) integer (vector_element (Sc->code, 1)) -#define sort_j(Sc) integer (vector_element (Sc->code, 2)) -#define sort_k1(Sc) integer (vector_element (Sc->code, 3)) -#define sort_calls(Sc) integer (vector_element (Sc->code, 4)) -#define sort_stop(Sc) integer (vector_element (Sc->code, 5)) -#define sort_data(Sc, K) vector_element (car (Sc->args), K) -#define sort_lessp(Sc) cadr (Sc->args) - -static s7_pointer -op_heapsort (s7_scheme* sc) { - s7_int n= sort_n (sc), j, k= sort_k1 (sc); - 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 (sc)++; - if (sort_calls (sc) > sort_stop (sc)) - 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 (sc))); - } - j = 2 * k; - sort_j (sc)= j; - if (j < n) { - const s7_pointer lx= sort_lessp (sc); /* cadr of sc->args */ - push_stack_direct (sc, OP_SORT1); - if (needs_copied_args (lx)) - sc->args= list_2 (sc, sort_data (sc, j), sort_data (sc, j + 1)); - else sc->args= with_list_t2 (sc, sort_data (sc, j), sort_data (sc, j + 1)); - sc->code = lx; - sc->value= sc->T; /* for eval */ - } - else sc->value= sc->F; - return (NULL); -} -static void -op_sort1 (s7_scheme* sc) { - s7_int j= sort_j (sc), k= sort_k1 (sc); - s7_pointer lx= sort_lessp (sc); - if (is_true (sc, sc->value)) { - j = j + 1; - sort_j (sc)= j; - } - push_stack_direct (sc, OP_SORT2); - if (needs_copied_args (lx)) - sc->args= list_2 (sc, sort_data (sc, k), sort_data (sc, j)); - else sc->args= with_list_t2 (sc, sort_data (sc, k), sort_data (sc, j)); - sc->code= lx; -} - -static bool -op_sort2 (s7_scheme* sc) { - s7_int j= sort_j (sc), k= sort_k1 (sc); - if (j == k) return (true); - if (is_true (sc, sc->value)) { - s7_pointer lx = sort_data (sc, j); - sort_data (sc, j)= sort_data (sc, k); - sort_data (sc, k)= lx; - } - else return (true); - sort_k1 (sc)= sort_j (sc); - return (false); +/* -------------------------------- 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, type_unchecked(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); } -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 (sc); - if (k > 0) { - sort_k (sc) = k - 1; - sort_k1 (sc)= k - 1; - push_stack_direct (sc, OP_SORT); - return (false); - } - return (true); +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, type_unchecked(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); } -static bool -op_sort3 (s7_scheme* sc) { - s7_int n= sort_n (sc); - s7_pointer lx; - if (n <= 0) { - sc->value= car (sc->args); - return (true); - } - lx = sort_data (sc, 0); - sort_data (sc, 0)= sort_data (sc, n); - sort_data (sc, n)= lx; - sort_n (sc) = n - 1; - sort_k1 (sc) = 0; - push_stack_direct (sc, OP_SORT3); - return (false); +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, type_unchecked(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); } -/* -------- 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); - } +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, type_unchecked(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); } - } - liberate (sc, hash_table_block (table)); + return(iter); } -static hash_entry_t* -make_hash_entry (s7_scheme* sc, s7_pointer key, s7_pointer value, - s7_int raw_hash) { - hash_entry_t* entry= (hash_entry_t*) mallocate_block (sc); -#if S7_DEBUGGING - sc->blocks_mallocated[BLOCK_LIST]++; -#endif - hash_entry_key (entry)= key; - hash_entry_set_value (entry, value); - hash_entry_set_raw_hash (entry, raw_hash); - return (entry); +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, type_unchecked(iterator_sequence(iter))), unbold_text); + if (sc->stop_at_error) abort(); + } + return(iter); } +#endif -/* -------------------------------- hash-table? -------------------------------- - */ -bool -s7_is_hash_table (s7_pointer p) { - return (is_hash_table (p)); -} -/* g_is_hash_table is now defined in s7_liii_hash_table.c */ +/* -------------------------------- iterator? -------------------------------- */ +/* g_is_iterator is now defined in s7_scheme_predicate.c */ + #define H_is_iterator "(iterator? obj) returns #t if obj is an iterator." + #define Q_is_iterator sc->pl_bt -s7_int -s7i_hash_table_entries (s7_pointer table) { - return (hash_table_entries (table)); -} - -s7_pointer -s7i_hash_table_key_typer (s7_scheme* sc, s7_pointer table) { - if (is_typed_hash_table (table)) return (hash_table_key_typer (table)); - return (sc->F); -} - -s7_pointer -s7i_hash_table_value_typer (s7_scheme* sc, s7_pointer table) { - if (is_typed_hash_table (table)) return (hash_table_value_typer (table)); - return (sc->F); -} - -/* -------------------------------- hash-table-entries - * -------------------------------- */ -#define H_hash_table_size \ - "(hash-table-size obj) returns the number of entries in the hash-table obj" -#define Q_hash_table_size \ - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_hash_table_symbol) -/* g_hash_table_size and hash_table_size_i_7p are now defined in - * s7_liii_hash_table.c */ - -/* -------------------------------- hash-table-key|value-typer - * -------------------------------- */ -#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) -/* g_hash_table_key_typer is now defined in s7_liii_hash_table.c */ +bool s7_is_iterator(s7_pointer obj) {return(is_iterator(obj));} -#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) -/* g_hash_table_value_typer is now defined in s7_liii_hash_table.c */ +static bool is_iterator_b_7p(s7_scheme *sc, s7_pointer obj) {return(g_is_iterator(sc, set_plist_1(sc, obj)) != sc->F);} -bool -s7i_is_weak_hash_table (s7_pointer p) { - return (is_weak_hash_table (p)); -} -void -s7i_set_weak_hash_table (s7_pointer p) { - set_weak_hash_table (p); +static s7_pointer iterator_copy(s7_scheme *sc, s7_pointer old_iter) +{ + s7_pointer iter; + new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE); + memcpy((void *)iter, (void *)old_iter, sizeof(s7_cell)); /* picks up ITER_OK I hope */ + return(iter); } -void -s7i_set_weak_hash_table_iters (s7_pointer p, s7_int val) { - weak_hash_iters (p)= val; -} +static s7_pointer iterator_finished(s7_scheme *sc, s7_pointer iterator) {return(sc->iterator_at_end_value);} -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 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 -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 { - s7_pointer typer_name; - 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)); - typer_name= find_typer (sc, typer); - if (!is_symbol (typer_name)) - 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); +static s7_pointer let_iterate_uncarried(s7_scheme *sc, s7_pointer iterator) +{ + s7_pointer slot = let_iterator_slot(iterator); + if (!is_not_slot_end(slot)) + return(iterator_quit(sc, iterator)); + let_iterator_set_slot(iterator, next_slot(slot)); + return(cons(sc, slot_symbol(slot), slot_value(slot))); } -/* ---------------- hash map and equality tables ---------------- */ -/* built in hash loc tables for eq? eqv? equal? equivalent? = string=? char=? - * (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]; -/* 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 */ +static s7_pointer let_iterate_carried(s7_scheme *sc, s7_pointer iterator) { - 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_pointer result, slot = let_iterator_slot(iterator); + if (!is_not_slot_end(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); } -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 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); } -#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) -/* g_hash_code is now defined in s7_liii_hash_table.c */ - -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); +s7_pointer hash_table_iterate(s7_scheme *sc, s7_pointer iterator) +{ + s7_pointer table; + hash_entry_t **elements; + hash_entry_t *lst = hash_iterator_entry(iterator); -/* ---------------- hash empty ---------------- */ -static hash_entry_t* -hash_empty (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (sc->unentry); + 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 */ + elements = hash_table_elements(table); + for (s7_int len = (s7_int)hash_table_size(table), 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)); } -/* ---------------- hash syntax ---------------- */ -static s7_uint -hash_map_syntax (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (pointer_map (syntax_symbol (key))); +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 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); +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)); } -/* ---------------- hash symbols ---------------- */ -static s7_uint -hash_map_symbol (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (pointer_map (key)); +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 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); +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)); } -/* ---------------- 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_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_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)); +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 - /* 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 + 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)); } -/* 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_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_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_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_uint -hash_map_complex (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (hash_complex_location (real_part (key))); +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 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); +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); } - /* 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); + return(result); } -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 */ - 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); -} - -static hash_entry_t* -hash_int (s7_scheme* sc, s7_pointer table, s7_pointer key) { - if (is_t_integer (key)) { - const s7_uint hash_mask= hash_table_mask (table); - hash_entry_t* entry; - const s7_int kv = integer (key); - const s7_uint loc= s7_int_abs (kv) % hash_mask; - for (entry= hash_table_element (table, loc); entry; - entry= hash_entry_next (entry)) - if (integer (hash_entry_key (entry)) == kv) return (entry); - } - 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 (is_t_real (key)) { - s7_double keyval; - s7_uint loc; - keyval= real (key); - if (is_NaN (keyval)) return (sc->unentry); - 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); +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 (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); + return(result); } -static hash_entry_t* -hash_real_num_eq (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return ((is_NaN (s7_real (key))) ? sc->unentry - : hash_num_eq (sc, table, key)); +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 hash_entry_t* -hash_complex_num_eq (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (((is_NaN (real_part (key))) || (is_NaN (imag_part (key)))) - ? sc->unentry - : hash_num_eq (sc, table, key)); +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 hash_entry_t* -hash_number_num_eq (s7_scheme* sc, s7_pointer table, s7_pointer key) { - if (is_number (key)) { - const 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 */ +static s7_pointer find_make_iterator_method(s7_scheme *sc, s7_pointer let, s7_pointer iter) +{ + s7_pointer func; + if ((has_active_methods(sc, let)) && + ((func = find_method_with_let(sc, let, sc->make_iterator_symbol)) != sc->undefined)) { - 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); + s7_pointer it; + gc_protect_via_stack(sc, iter); + it = s7_apply_function(sc, func, set_plist_1(sc, let)); + 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); } - else - return ((is_real (key)) ? hash_real_num_eq (sc, table, key) - : hash_complex_num_eq (sc, table, key)); - } - return (sc->unentry); + return(NULL); } -/* ---------------- 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); +/* -------------------------------- 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)); } -/* ---------------- 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)) { - 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 (hash_entry_t* 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); +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 seq) +{ + s7_pointer iter; + new_cell(sc, iter, T_ITERATOR | T_SAFE_PROCEDURE | T_ITER_OK); + iterator_sequence(iter) = seq; + if (is_pair(seq)) /* by far the most common case */ + { + iterator_current(iter) = seq; + iterator_next(iter) = pair_iterate; + pair_iterator_set_slow(iter, seq); + return(iter); } - else - for (hash_entry_t* 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); -} + iterator_carrier(iter) = NULL; + if (!is_let(seq)) + iterator_position(iter) = 0; -#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 + switch (type(seq)) + { + case T_LET: + if (seq == sc->rootlet) + { + let_iterator_set_slot(iter, sc->rootlet_slots); + iterator_next(iter) = let_iterate_uncarried; + return(iter); + } + if (seq == sc->starlet) + return(starlet_make_iterator(sc, iter)); + { + s7_pointer func = find_make_iterator_method(sc, seq, iter); + if (func) return(func); + } + let_iterator_set_slot(iter, let_slots(seq)); + iterator_next(iter) = let_iterate_uncarried; + break; -/* ---------------- hash eq? ---------------- */ -static s7_uint -hash_map_nil (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (type (key)); -} + case T_HASH_TABLE: + hash_iterator_entry(iter) = NULL; + iterator_position(iter) = -1; + iterator_next(iter) = hash_table_iterate; + if (is_weak_hash_table(seq)) + { + set_weak_hash_iterator(iter); + weak_hash_iters(seq)++; + add_weak_hash_iterator(sc, iter); + } + break; -static s7_uint -hash_map_eq (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (pointer_map (key)); -} + case T_STRING: + iterator_length(iter) = string_length(seq); + iterator_next(iter) = string_iterate; + break; -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); -} + case T_BYTE_VECTOR: + iterator_length(iter) = byte_vector_length(seq); + iterator_next(iter) = byte_vector_iterate; + break; -/* ---------------- hash eqv? ---------------- */ -static hash_entry_t* -hash_eqv (s7_scheme* sc, s7_pointer table, s7_pointer key) { - const s7_uint loc= hash_loc (sc, table, key) % hash_table_mask (table); - if (is_number (key)) { - uint8_t key_type= type (key); - for (hash_entry_t* 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); - } - else - for (hash_entry_t* 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); -} + case T_VECTOR: + iterator_length(iter) = vector_length(seq); + iterator_next(iter) = vector_iterate; + break; -/* ---------------- 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)))); - } - } - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - return (0); /* placate the compiler */ -} + case T_INT_VECTOR: + iterator_length(iter) = vector_length(seq); + iterator_next(iter) = int_vector_iterate_uncarried; + break; -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 */ -} + case T_FLOAT_VECTOR: + iterator_length(iter) = vector_length(seq); + iterator_next(iter) = float_vector_iterate_uncarried; + break; -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)); -} + case T_COMPLEX_VECTOR: + iterator_length(iter) = vector_length(seq); + iterator_next(iter) = complex_vector_iterate_uncarried; + break; -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); -} + 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; -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); -} + 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, seq)) + { + 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, seq)) ? closure_length(sc, seq) : S7_INT64_MAX; + } + else + sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, seq, + wrap_string(sc, "a function or macro with a '+iterator+ local that is not #f", 59)); + break; -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 ((!is_any_c_function (f)) && (!is_any_closure (f))) - error_nr (sc, sc->wrong_type_arg_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "hash-table map function is not a procedure: ~S", 46), - f)); - gc_protect_via_stack (sc, f); - sc->value= s7_call (sc, f, set_plist_1 (sc, key)); - unstack_gc_protect (sc); - 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; + case T_C_OBJECT: + iterator_length(iter) = c_object_length_to_int(sc, seq); + { + s7_pointer func = find_make_iterator_method(sc, seq, iter); + if (func) return(func); + } + iterator_carrier(iter) = list_2_unchecked(sc, seq, int_zero); /* if not unchecked, gc protect iter */ + set_has_carrier(iter); + iterator_next(iter) = c_object_iterate; + break; - if ((key == sc->rootlet) || (!is_not_slot_end (let_slots (key)))) return (0); - for (slot= let_slots (key), slots= 0; is_not_slot_end (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++; + default: + sole_arg_wrong_type_error_nr(sc, sc->make_iterator_symbol, seq, a_sequence_string); } - for (slot= let_slots (key); is_not_slot_end (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); - } - 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); - } - 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); - } - 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); - - 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); - } - 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); + return(iter); } -/* ---------------- 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 (sc, key)))); -} +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); -static s7_uint -hash_map_c_pointer (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return (pointer_map (c_pointer (key))); + 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); } -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 */ + +/* -------------------------------- 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_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 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)); } -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); +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 iter = lookup_checked(sc, car(sc->code)); + if (!is_iterator(iter)) {sc->last_function = iter; return(false);} + sc->value = (iterator_next(iter))(sc, iter); + return(true); } -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 p = 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 (p)) { - if (!is_sequence_or_iterator (car (p))) - loc+= hash_loc (sc, table, car (p)) + 1; - else if ((is_pair (car (p))) && (!is_sequence_or_iterator (caar (p)))) - loc+= hash_loc (sc, table, caar (p)) + 1; - } - else if (!is_sequence_or_iterator (p)) /* include () */ - loc+= hash_loc (sc, table, p); - 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)); + +/* -------------------------------- 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 hash_entry_t* -hash_equal (s7_scheme* sc, s7_pointer table, s7_pointer key) { - return ((*(equal_hash_checks[type (key)])) (sc, table, key)); +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)); } -/* ---------------- 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)) { - entry= hash_number_equivalent (sc, table, key); - if ((entry != sc->unentry) || (!is_nan_b_7p (sc, key))) return (entry); - 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); -} - -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) { - /* 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++; - } - { - s7_pointer table; - block_t* 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 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))); } -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); -} - -s7_pointer -s7i_make_hash_table_1 (s7_scheme* sc, s7_pointer args, s7_pointer caller) { -#define H_make_hash_table \ - "(s7-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 << 32))) /* s7test tests >= */ - out_of_range_error_nr (sc, caller, int_one, len, it_is_too_large_string); - if (size == 0) size= sc->default_hash_table_length; - - 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); +/* -------------------------------- iterator-sequence -------------------------------- */ +/* g_iterator_sequence is now defined in s7_scheme_predicate.c */ + #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) - if (!s7_is_aritable (sc, proc, 2)) - wrong_type_error_nr (sc, caller, 2, proc, an_eq_func_string); +/* iterator-length and iterator-position run up against the function iterator */ - 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 (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); - } + + +/* g_cyclic_sequences is now defined in s7_scheme_predicate.c */ +#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) + + +/* pair_append: general pair utility used by eval and the writer */ +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); } - } - return (s7_make_hash_table (sc, size)); + unstack_gc_protect(sc); + return(tp); } -/* g_make_hash_table is now defined in s7_liii_hash_table.c */ +/* -------------------------------- s7i helpers for s7_scheme_write.c -------------------------------- */ -/* -------------------------------- make-weak-hash-table - * -------------------------------- */ -#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)) -/* g_make_weak_hash_table is now defined in s7_liii_hash_table.c */ +bool s7i_port_is_closed(s7_pointer p) { return port_is_closed(p); } -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=?"); -#endif - if (hash_table_checker (table) == hash_char) return ("char=?"); - if (hash_table_checker (table) == hash_number_num_eq) return ("="); - return ("#f"); +void s7i_port_write_character(s7_scheme *sc, char c, s7_pointer port) +{ + port_write_character(port)(sc, c, port); } -/* -------------------------------- weak-hash-table? - * -------------------------------- */ -#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 -/* g_is_weak_hash_table is now defined in s7_liii_hash_table.c */ +void s7i_port_write_string(s7_scheme *sc, const char *str, s7_int len, s7_pointer port) +{ + port_write_string(port)(sc, str, len, port); +} -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; - 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; - 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; - - 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* new_block= - (block_t*) callocate (sc, new_size * sizeof (hash_entry_t*)); - hash_entry_t** new_els = (hash_entry_t**) (block_data (new_block)); - 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* next; - for (hash_entry_t* entry= old_els[i]; entry; entry= next) { - s7_uint loc= hash_loc (sc, table, hash_entry_key (entry)); - hash_entry_set_raw_hash (entry, loc); - loc%= hash_mask; - next = 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, new_block); - hash_table_elements (table)= new_els; - hash_table_set_procedures (table, dproc); - hash_table_entries (table)= entries; +void s7i_port_write_unicode_char(s7_scheme *sc, uint32_t c, s7_pointer port) +{ + port_write_unicode_char(sc, c, port); } -/* -------------------------------- 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))); +s7_pointer s7i_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) +{ + return start_and_end(sc, caller, args, position, index_args, start, end); } -#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) -/* g_hash_table_ref is now defined in s7_liii_hash_table.c */ -/* g_hash_table_ref_2 is now defined in s7_liii_hash_table.c */ +s7_pointer s7i_vector_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) +{ + const s7_pointer pstart = car(index_args); + s7_int index; -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; - } - } -} + if (!s7_is_integer(pstart)) + return(vector_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)) + out_of_range_error_nr(sc, caller, small_int(position), pstart, (index < 0) ? it_is_negative_string : it_is_too_large_string); + *start = index; -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); + if (is_pair(cdr(index_args))) + { + const s7_pointer pend = cadr(index_args); + if (!s7_is_integer(pend)) + return(vector_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 -hash_table_typer_symbol (s7_scheme* sc, s7_pointer typer) { - s7_pointer typer_name; - if (typer == sc->T) return (sc->T); - if (is_c_function (typer)) return (c_function_symbol (typer)); - typer_name= find_typer (sc, typer); - return ((is_symbol (typer_name)) ? typer_name : sc->anon_symbol); +bool s7i_is_unused(s7_scheme *sc, s7_pointer p) +{ + return p == sc->unused; } -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 */ - { - const 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_3 (sc, - wrap_string (sc, - "hash-table-set! key ~$ is rejected by " - "the hash-table's key-typer, ~A", - 68), - key, wrap_string (sc, descr, safe_strlen (descr)))); - } - } - } - if (has_hash_value_type (table)) { - const 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_3 (sc, - wrap_string (sc, - "hash-table-set! value ~$ is rejected by " - "the hash-table's value-typer, ~A", - 72), - value, wrap_string (sc, descr, safe_strlen (descr)))); - } - } - } +s7_pointer s7i_method_or_bust_p(s7_scheme *sc, s7_pointer obj, const char *method_name, const char *type_name) +{ + return method_or_bust_p(sc, obj, s7_make_symbol(sc, method_name), wrap_string(sc, type_name, safe_strlen(type_name))); } -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) && (!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_ci_string) - ? sc->string_eq_symbol - : ((hash_table_checker (table) == hash_char) - ? sc->char_eq_symbol - : sc->string_eq_symbol)))); -#endif +s7_pointer s7i_method_or_bust_pp(s7_scheme *sc, s7_pointer obj, const char *method_name, s7_pointer x1, s7_pointer x2, const char *type_name, s7_int arg_pos) +{ + return method_or_bust_pp(sc, obj, s7_make_symbol(sc, method_name), x1, x2, wrap_string(sc, type_name, safe_strlen(type_name)), (int32_t)arg_pos); } -s7_pointer -s7_hash_table_set (s7_scheme* sc, s7_pointer table, s7_pointer key, - s7_pointer value) { - hash_entry_t* entry; +void s7i_division_by_zero_error(s7_scheme *sc, const char *caller, s7_pointer x, s7_pointer y) +{ + division_by_zero_error_2_nr(sc, wrap_string(sc, caller, safe_strlen(caller)), x, y); +} - 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); +bool s7i_is_subvector(s7_pointer p) {return(is_subvector(p));} - 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); - { - s7_uint hash_mask, loc; - 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); -} +s7_pointer s7i_int_one(s7_scheme *sc) {(void)sc; return(int_one);} -#define H_hash_table_set \ - "(s7-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) -/* g_hash_table_set is now defined in s7_liii_hash_table.c */ +s7_pointer s7i_iterator_sequence(s7_pointer iter) {return(iterator_sequence(iter));} -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(table) 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))) { - const 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)) { - const s7_pointer or1= cadr (add1); - if ((is_pair (or1)) && (car (or1) == sc->hash_table_ref_symbol) && - (is_proper_list_3 (sc, or1)) && (cadr (or1) == cadr (expr)) && - (caddr (or1) == caddr (expr))) - /* (hash-table-set! counts p (+ (or (hash-table-ref counts p) 0) 1)) - */ - set_optimize_op (expr, HOP_HASH_TABLE_INCREMENT); +s7_int s7i_subvector_position(s7_pointer p) +{ + if (is_subvector(p)) + switch (type(p)) + { + case T_VECTOR: return((s7_int)(vector_elements(p) - vector_elements(subvector_vector(p)))); + case T_INT_VECTOR: return((s7_int)(int_vector_ints(p) - int_vector_ints(subvector_vector(p)))); + case T_FLOAT_VECTOR: return((s7_int)(float_vector_floats(p) - float_vector_floats(subvector_vector(p)))); + case T_COMPLEX_VECTOR: return((s7_int)(complex_vector_complexes(p) - complex_vector_complexes(subvector_vector(p)))); + case T_BYTE_VECTOR: return((s7_int)(byte_vector_bytes(p) - byte_vector_bytes(subvector_vector(p)))); } - } - } - return (func); + return(-1); } -/* -------------------------------- 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); +s7_pointer s7i_subvector_vector(s7_scheme *sc, s7_pointer p) {return(subvector_vector(p));} +bool s7i_is_typed_t_vector(s7_pointer p) {return(is_typed_t_vector(p));} +s7_pointer s7i_typed_vector_typer(s7_scheme *sc, s7_pointer p) {return(typed_vector_typer(p));} + +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->blocks_mallocated[BLOCK_LIST]++; + sc->format_ports_allocated++; #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); + return(port); } -s7_pointer -s7i_hash_table_add (s7_scheme* sc, s7_pointer table, s7_pointer key, - s7_pointer value) { - return (hash_table_add (sc, table, key, value)); +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); } -s7_pointer -s7i_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= cdr_unchecked (cdr (y))) - if (car (y) != missing_key_value (sc)) - hash_table_add (sc, table, car (x), car (y)); - return (table); - } +static void close_format_port(s7_scheme *sc, s7_pointer port) +{ + port_next(port) = (struct block_t *)(sc->format_ports); + sc->format_ports = port; } -#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) -/* g_hash_table is now defined in s7_liii_hash_table.c */ -/* g_hash_table_2 is now defined in s7_liii_hash_table.c */ - -/* -------------------------------- weak-hash-table - * -------------------------------- */ -#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 -/* g_weak_hash_table is now defined in s7_liii_hash_table.c */ - -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) { - 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, count= 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; +char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj) +{ + char *str; + s7_pointer strport; + s7_int len; - if (is_typed_hash_table (new_table)) - check_old_table (sc, old_table, new_table, start, end); + 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); + s7i_object_out(sc, T_Pos(obj), strport, S7I_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); +} - 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... */ +/* -------------------------------- object->string -------------------------------- */ +s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer obj, bool use_write) /* unavoidable backwards compatibility rigidity here */ +{ + 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); { - set_weak_hash_table (new_table); - weak_hash_iters (new_table)= 0; + s7_pointer result; + const s7_pointer strport = open_format_port(sc); + s7i_object_out(sc, obj, strport, (use_write) ? S7I_P_WRITE : S7I_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); } - unstack_gc_protect (sc); - return (new_table); } -/* -------------------------------- functions -------------------------------- - */ -bool -s7_is_function (s7_pointer p) { - return (is_c_function (p)); -} +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_int 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 */ -static s7_pointer -fallback_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer expr) { - return (func); + 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); + { + s7_int out_len; + const s7_pointer strport = open_format_port(sc); + sc->objstr_max_len = pending_max; + s7i_object_out(sc, obj, strport, (s7i_use_write_t)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); + }} } -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 (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)); +/* -------------------------------- write -------------------------------- */ + +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); } -/* g_is_procedure is now defined in s7_scheme_predicate.c */ -#define H_is_procedure "(procedure? obj) returns #t if obj is a procedure" -#define Q_is_procedure sc->pl_bt -#if !DISABLE_DEPRECATED -s7_pointer -s7_closure_body (s7_scheme* sc, s7_pointer clo) { - return ((has_closure_let (clo)) ? closure_body (clo) : sc->nil); -} -s7_pointer -s7_closure_let (s7_scheme* sc, s7_pointer clo) { - return ((has_closure_let (clo)) ? closure_let (clo) : sc->rootlet); -} -s7_pointer -s7_closure_args (s7_scheme* sc, s7_pointer clo) { - return ((has_closure_let (clo)) ? closure_pars (clo) : sc->nil); -} -#endif -s7_pointer -s7_lambda_body (s7_scheme* sc, s7_pointer clo) { - return ((has_closure_let (clo)) ? closure_body (clo) : sc->nil); -} -s7_pointer -s7_lambda_let (s7_scheme* sc, s7_pointer clo) { - return ((has_closure_let (clo)) ? closure_let (clo) : sc->rootlet); -} -s7_pointer -s7_lambda_parameters (s7_scheme* sc, s7_pointer clo) { - return ((has_closure_let (clo)) ? closure_pars (clo) : 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); +/* -------------------------------- display -------------------------------- */ + +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); } -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 let) { - if ((!let) || (let == sc->rootlet) || (!is_let (let))) return (sc->F); - if (!((is_funclet (let)) || (is_maclet (let)))) return (sc->F); - if ((has_let_file (let)) && (let_file (let) <= (s7_int) sc->file_names_top) && - (let_line (let) > 0)) - return (list_3 (sc, funclet_function (let), sc->file_names[let_file (let)], - make_integer (sc, let_line (let)))); - return (funclet_function (let)); -} - -static s7_pointer -g_function (s7_scheme* sc, - s7_pointer args) /* does the env parameter make any sense? */ -{ -#define H_function \ - "(*function* let field) returns the current function. (*function*) is like __func__ in C. \ -If 'let 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)" +/* 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 */ -#define Q_function \ - s7_make_signature (sc, 3, sc->T, has_let_signature (sc), sc->is_symbol_symbol) - s7_pointer let, sym= NULL; - if (is_null (args)) /* (*function*) is akin to __func__ in C */ - { - for (let= sc->curlet; let; let= let_outlet (let)) - if ((is_funclet (let)) || (is_maclet (let))) break; - return (let_to_function (sc, let)); - } - let= car (args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); /* ?? not sure this makes sense */ - if (!is_let (new_let)) - find_let_error_nr (sc, sc->_function__symbol, let, new_let, 1, args); - let= 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 (let == sc->rootlet) return (sc->F); - if (!((is_funclet (let)) || (is_maclet (let)))) let= let_outlet (let); - if (is_null (cdr (args))) return (let_to_function (sc, let)); - if ((let == sc->rootlet) || (!is_let (let))) return (sc->F); - if (!((is_funclet (let)) || (is_maclet (let)))) return (sc->F); +/* -------------------------------- 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)) - if (is_keyword (sym)) sym= keyword_symbol (sym); + 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)); { - s7_pointer fname= funclet_function (let); - s7_pointer fval = s7_symbol_local_value (sc, fname, let); - - 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 (let))) - return (make_integer (sc, let_line (let))); - if ((sym == sc->file_symbol) && (has_let_file (let))) - return (sc->file_names[let_file (let)]); - if (sym == make_symbol (sc, "funclet", 7)) return (let); - 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)); + const s7_pointer 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); + 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)?? */ - -/* g_funclet moved to s7_scheme_let.c */ -#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_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) { - 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); +/* -------------------------------- 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 + + 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)); { - s7_pointer bfunc= - s7_make_safe_function (sc, name, bool_setter, 2, 0, false, NULL); - c_function_set_bool_setter (func, bfunc); - c_function_set_has_bool_setter (func); - c_function_set_setter (bfunc, func); - set_is_bool_function (bfunc); + const s7_pointer 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 (sym); + return(sc->F); } -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) { - const s7_int len= safe_strlen (arglist); - s7_pointer local_args; - s7_int gc_loc, n_args; - { - block_t* b = inline_mallocate (sc, len + 4); - char* 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; - } - { - const s7_pointer 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_par_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); -} +/* -------------------------------- 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)) -/* -------------------------------- 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)); + 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); + { + const s7_pointer 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); } -/* g_is_macro is now defined in s7_scheme_predicate.c */ -#define H_is_macro "(macro? arg) returns #t if 'arg' is a macro or a bacro" -#define Q_is_macro sc->pl_bt -static bool closure_is_aritable (s7_scheme* sc, s7_pointer x, s7_pointer x_args, - int32_t args); +/* -------------------------------- 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 -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) { - 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)); + 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); { - s7_pointer 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))); - } + const s7_pointer 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)); } - return (NULL); + push_stack(sc, OP_APPLY, sc->nil, proc); + return(sc->F); } -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); +/* -------------------------------- 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); } -/* -------------------------------- 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); +s7_pointer cons_unchecked(s7_scheme *sc, s7_pointer a, s7_pointer b) +{ + /* apparently slightly faster as a function? */ + s7_pointer p; + new_cell_unchecked(sc, p, T_PAIR | T_SAFE_PROCEDURE); + set_car(p, a); + set_cdr(p, b); + return(p); } -/* g_help is now defined in s7_scheme_predicate.c */ -#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) +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); + set_cdr_unchecked(p, b); + return(p); +} -/* -------------------------------- 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); - } +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); +} - 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 */ - { - const 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))); - } +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); } - break; - - default: - break; - } - return (sc->F); + va_end(ap); + return(result); } -s7_pointer -s7_signature (s7_scheme* sc, s7_pointer func) { - return (g_signature (sc, set_plist_1 (sc, func))); +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) set_cdr_unchecked(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));} +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; } -/* -------------------------------- 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 (sc, caar (body))) ? sc->F : obj); -} +/* ---------------- tree-leaves, tree-memq, tree-set-memq, tree-count ---------------- */ +/* migrated to s7_liii_tree.c */ -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) */ -} +/* -------------------------------- pair? -------------------------------- */ +#define H_is_pair "(pair? obj) returns #t if obj is a pair (a non-empty list)" +#define Q_is_pair sc->pl_bt +/* g_is_pair is now defined in s7_liii_list.c */ -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)); +/* -------------------------------- list? -------------------------------- */ +bool s7_is_list(s7_scheme *sc, s7_pointer p) {return(is_list(p));} - /* 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_list_b(s7_pointer p) {return((is_pair(p)) || (type(p) == T_NIL));} -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) ? */ -} +#define H_is_list "(list? obj) returns #t if obj is a pair or null" +#define Q_is_list sc->pl_bt +/* g_is_list is now defined in s7_liii_list.c */ -static int32_t -is_ok_thunk (s7_scheme* sc, - s7_pointer arg) /* used only in dynamic_wind_chooser */ +static s7_int proper_list_length(s7_pointer a) { - /* 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_int i = 0; + for (s7_pointer b = a; is_pair(b); i++, b = cdr(b)) {}; + return(i); } -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 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); } -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)); +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); } -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)); +/* -------------------------------- 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); } -/* g_is_c_object is now defined in s7_scheme_predicate.c */ -#define H_is_c_object "(c-object? obj) returns #t is obj is a c-object." -#define Q_is_c_object sc->pl_bt - -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) {} - -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); +s7_pointer s7i_copy_proper_list(s7_scheme *sc, s7_pointer lst) +{ + return(copy_proper_list(sc, lst)); } -/* g_c_object_type is now defined in s7_scheme_predicate.c */ -#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_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*)); +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); } - } - 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); + return(true); } -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; -} +#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 +/* g_is_proper_list is now defined in s7_liii_list.c */ -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 */ -} +/* is_proper_list_p_p migrated to s7_liii_list.c */ -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; -} +bool is_proper_list_1(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_null(cdr(p))));} +bool is_proper_list_2(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) && (is_pair(cdr(p))) && (is_null(cddr(p))));} +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);} -/* 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; +/* -------------------------------- 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); } -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; +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)); } -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); -} +s7_pointer s7_make_list(s7_scheme *sc, s7_int len, s7_pointer init) {return(make_list(sc, len, init));} -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; -} +/* make_list_p_pp migrated to s7_liii_list.c */ + +#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) +/* g_make_list is now defined in s7_liii_list.c */ -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; + +/* -------------------------------- 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); } -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; +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); } -/* -------------------------------- c-object-let - * -------------------------------- */ -s7_pointer -s7_c_object_let (s7_pointer obj) { - return (c_object_let (obj)); +static s7_pointer implicit_index(s7_scheme *sc, s7_pointer obj, s7_pointer indices); + +s7_pointer s7i_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))); } -/* g_c_object_let is now defined in s7_scheme_predicate.c */ -#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 -s7_c_object_set_let (s7_scheme* sc, s7_pointer cobj, s7_pointer let) { - if ((!is_immutable (cobj)) && (is_let (let))) c_object_set_let (cobj, let); - return (let); -} - -static s7_pointer -g_c_object_set_let (s7_scheme* sc, s7_pointer args) { - const s7_pointer cobj= car (args), let= cadr (args); - if (is_immutable (cobj)) - immutable_object_error_nr ( - sc, set_elist_2 ( - sc, wrap_string (sc, "can't set ~S's let: it is immutable", 35), - cobj)); - if (!is_let (let)) - wrong_type_error_nr (sc, make_symbol (sc, "#", 19), 2, - let, sc->type_names[T_LET]); - c_object_set_let (cobj, let); - return (let); -} - -/* -------------------------------- 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); -} +#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) +/* g_list_ref is now defined in s7_liii_list.c */ -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)); +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); } -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)); +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)))); } -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 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 s7_pointer -c_object_length (s7_scheme* sc, s7_pointer obj) { - return ((*(c_object_len (sc, obj))) (sc, set_clist_1 (sc, obj))); +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_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 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 s7_pointer -copy_c_object (s7_scheme* sc, s7_pointer args) { - const 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)); -} +/* list_ref_p_pi_unchecked, list_ref_p_pi, list_ref_p_pp migrated to s7_liii_list.c */ -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 -------- */ +/* -------------------------------- list-set! -------------------------------- */ +s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, s7_int num, s7_pointer val) { - 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); + 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 -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)); -} +/* g_list_set and g_list_set_i are now defined in s7_liii_list.c */ -/* We could add implicit c-pointer ref/set referring to its let, but that seems - * confusing -- c-object-ref|set! would be different */ +#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) -/* -------- dilambda -------- */ +/* list_set_index_check_nr, list_set_p_pip_unchecked, list_set_p_pip migrated to s7_liii_list.c */ -s7_pointer -s7_dilambda_with_environment ( - s7_scheme* sc, s7_pointer let, 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 (let), 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 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); } -/* g_is_dilambda is now defined in s7_scheme_predicate.c */ -#define H_is_dilambda \ - "(dilambda? obj) returns #t if obj is a procedure with setter." -#define Q_is_dilambda sc->pl_bt - -/* -------------------------------- 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 */ - } - } -} +/* -------------------------------- list-tail -------------------------------- */ +/* list_tail_p_pp migrated to s7_liii_list.c */ -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)))); -} +#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 */ +/* g_list_tail is now defined in s7_liii_list.c */ -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)); -} - -static s7_pointer -c_object_arity_to_int (s7_scheme* sc, s7_pointer obj) { - if_c_object_method_exists_return_value (sc, obj, sc->arity_symbol, - set_plist_1 (sc, obj)); - return ((is_safe_procedure (obj)) ? cons (sc, int_zero, max_arity) : sc->F); -} - -static s7_pointer -vector_arity_to_int (s7_scheme* sc, s7_pointer obj) { - if (vector_length (obj) == 0) return (sc->F); - if (has_simple_elements (obj)) - return (cons (sc, int_one, make_integer (sc, vector_rank (obj)))); - return (cons (sc, int_one, max_arity)); -} - -static s7_pointer -syntax_arity_to_int (s7_scheme* sc, s7_pointer obj) { - return (cons (sc, small_int (syntax_min_args (obj)), - (syntax_max_args (obj) == MAX_ARITY) - ? max_arity - : small_int (syntax_max_args (obj)))); -} - -s7_pointer -s7_arity (s7_scheme* sc, s7_pointer obj) { - switch (type (obj)) { - case T_C_FUNCTION: - return (cons (sc, make_integer (sc, c_function_min_args (obj)), - make_integer_unchecked (sc, c_function_max_args (obj)))); - 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 (obj)))); - case T_CLOSURE: - case T_MACRO: - case T_BACRO: - return (closure_arity_to_cons (sc, obj, closure_pars (obj))); - case T_CLOSURE_STAR: - case T_MACRO_STAR: - case T_BACRO_STAR: - return (closure_star_arity_to_cons (sc, obj, closure_pars (obj))); - case T_C_MACRO: - return (cons (sc, make_integer (sc, c_macro_min_args (obj)), - make_integer_unchecked (sc, c_macro_max_args (obj)))); - case T_C_OBJECT: - return (c_object_arity_to_int (sc, obj)); - 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_GOTO: - case T_CONTINUATION: - return (cons (sc, int_zero, max_arity)); - case T_STRING: - return ((string_length (obj) == 0) ? sc->F : cons (sc, int_one, int_one)); - case T_LET: - return (cons (sc, int_one, int_one)); - case T_SYNTAX: - return (syntax_arity_to_int (sc, obj)); - case T_VECTOR: - return (vector_arity_to_int (sc, obj)); - case T_INT_VECTOR: - case T_FLOAT_VECTOR: - case T_BYTE_VECTOR: - case T_COMPLEX_VECTOR: - return ((vector_length (obj) == 0) - ? sc->F - : cons (sc, int_one, make_integer (sc, vector_rank (obj)))); - } - return (sc->F); -} +/* -------------------------------- cons -------------------------------- */ +#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) +/* g_cons is now defined in s7_liii_list.c */ -/* g_arity is now defined in s7_scheme_predicate.c */ -#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) - -/* -------------------------------- 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 */ -} +/* cons_p_pp migrated to s7_liii_list.c */ -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))); -} -static bool -c_object_is_aritable (s7_scheme* sc, s7_pointer clo, int32_t args) { - 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? */ -} - -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_CLOSURE: - case T_MACRO: - case T_BACRO: - return (closure_is_aritable (sc, clo, closure_pars (clo), args)); - case T_CLOSURE_STAR: - case T_MACRO_STAR: - case T_BACRO_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_ITERATOR: - return (args == 0); - case T_SYNTAX: - return ((args >= syntax_min_args (clo)) && (args <= syntax_max_args (clo))); - case T_HASH_TABLE: - return (args == 1); /* refers to implicit ref (table key) */ - case T_LET: - case T_PAIR: - return (args == 1); - case T_C_OBJECT: - return (c_object_is_aritable (sc, clo, args)); - 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) && - (args <= vector_rank (clo))); /* (#() 0) -> error */ - } - 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 num_args= cadr (args); - s7_int num; - if (!s7_is_integer (num_args)) /* remember gmp case! */ - return (method_or_bust (sc, num_args, sc->is_aritable_symbol, args, - sc->type_names[T_INTEGER], 2)); - num= s7_integer_clamped_if_gmp (sc, num_args); - if (num < 0) - out_of_range_error_nr (sc, sc->is_aritable_symbol, int_two, num_args, - it_is_negative_string); - if (num > MAX_ARITY) num= MAX_ARITY; - return (make_boolean (sc, s7_is_aritable (sc, car (args), num))); -} +/* -------- car -------- */ -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); -} +#define H_car "(car pair) returns the first element of the pair" +#define Q_car sc->pl_p +/* g_car is now defined in s7_liii_list.c */ -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_CLOSURE: - case T_MACRO: - case T_BACRO: - args= closure_arity_to_int (sc, clo); - return ((args < 0) ? MAX_ARITY : args); - case T_CLOSURE_STAR: - case T_MACRO_STAR: - case T_BACRO_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 */ -} +/* car_p_p migrated to s7_liii_list.c */ -/* -------------------------------- sequence? -------------------------------- - */ -/* g_is_sequence is now defined in s7_scheme_predicate.c */ -#define H_is_sequence \ - "(sequence? obj) returns #t if obj is a sequence (vector, string, pair, " \ - "etc)" -#define Q_is_sequence sc->pl_bt +/* g_list_ref_at_0 is now defined in s7_liii_list.c */ -static bool -is_sequence_b (s7_pointer seq) { - return (is_simple_sequence (seq)); -} +#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) +/* g_set_car is now defined in s7_liii_list.c */ -/* -------------------------------- setter - * ------------------------------------------------ */ -s7_pointer -b_simple_setter (s7_scheme* sc, int32_t typer, - s7_pointer args) /* see bool_defun -> define_bool_function */ +static Inline s7_pointer inline_set_car(s7_scheme *sc, s7_pointer lst, s7_pointer value) { - 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)); + 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); } -/* 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_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)); -} +/* set_car_p_pp migrated to s7_liii_list.c */ -#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); -} +/* -------- cdr -------- */ +#define H_cdr "(cdr pair) returns the second element of the pair" +#define Q_cdr sc->pl_p +/* g_cdr is now defined in s7_liii_list.c */ -static s7_pointer -symbol_setter (s7_scheme* sc, s7_pointer sym, s7_pointer let) { - s7_pointer slot; - if (is_keyword (sym)) return (sc->F); - if (let == sc->rootlet) slot= global_slot (sym); - else { - s7_pointer old_let= sc->curlet; - set_curlet (sc, let); - slot= s7_slot (sc, sym); - set_curlet (sc, old_let); - } - 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); - } -} +/* cdr_p_p migrated to s7_liii_list.c */ -static s7_pointer -setter_p_pp (s7_scheme* sc, s7_pointer obj, s7_pointer let) { - 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->setter_symbol, let, new_let, 2, - set_mlist_2 (sc, obj, let)); - let= 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, let)); - 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, let)); - 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, let)); /* (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); -} +#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) +/* g_set_cdr is now defined in s7_liii_list.c */ -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)); +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); } -s7_pointer -s7_setter (s7_scheme* sc, s7_pointer obj) { - return (setter_p_pp (sc, obj, sc->curlet)); -} +/* set_cdr_p_pp migrated to s7_liii_list.c */ -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) { - 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* old_b = vector_block ( - sc->protected_setters); /* old_b is liberated by reallocate below */ - block_t* new_b = reallocate (sc, old_b, new_size * sizeof (s7_pointer)); - block_info (new_b)= NULL; - vector_block (sc->protected_setters) = new_b; - vector_elements (sc->protected_setters)= (s7_pointer*) block_data (new_b); - vector_length (sc->protected_setters) = new_size; - - old_b= vector_block (sc->protected_setter_symbols); /* old_b is liberated by - reallocate below */ - new_b= reallocate (sc, old_b, new_size * sizeof (s7_pointer)); - vector_block (sc->protected_setter_symbols)= new_b; - vector_elements (sc->protected_setter_symbols)= - (s7_pointer*) block_data (new_b); - 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; - } - { - s7_int 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; - } -} +/* -------- caar --------*/ +#define H_caar "(caar lst) returns (car (car lst)): (caar '((1 2))) -> 1" +#define Q_caar sc->pl_p +/* g_caar is now defined in s7_liii_list.c */ -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 let= - cadr (args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) - ...))): args is (x (inlet 'x 1) #) */ - func= caddr (args); - if (let == sc->rootlet) slot= global_slot (sym); - else { - 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, wrap_string (sc, "set! setter", 11), let, - new_let, 2, args); - let= new_let; - } - slot= lookup_slot_with_let (sc, sym, let); - } - } - 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)) /* this will 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)); /* c_functions 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? */ -} +/* caar_p_p is now defined in s7_scheme_cxr.c */ -/* (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 (sc, symbol, new_value, sc->curlet))); - return (c_function_call (func) (sc, with_list_t2 (sc, symbol, new_value))); -} - -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); - } -} +/* -------- cadr --------*/ +#define H_cadr "(cadr lst) returns (car (cdr lst)): (cadr '(1 2 3)) -> 2" +#define Q_cadr sc->pl_p +/* g_cadr is now defined in s7_liii_list.c */ -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 */ -} +/* cadr_p_p is now defined in s7_scheme_cxr.c */ -/* -------------------------------- 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 */ -} +/* g_list_ref_at_1 is now defined in s7_liii_list.c */ -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)))))); -} -/* g_is_eq migrated to s7_scheme_predicate.c */ -#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 +/* -------- cdar -------- */ +#define H_cdar "(cdar lst) returns (cdr (car lst)): (cdar '((1 2 3))) -> '(2 3)" +#define Q_cdar sc->pl_p +/* g_cdar is now defined in s7_liii_list.c */ -bool -s7_is_eqv (s7_scheme* sc, s7_pointer x, s7_pointer y) { - 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); -} +/* cdar_p_p is now defined in s7_scheme_cxr.c */ -/* g_is_eqv migrated to s7_scheme_predicate.c */ -#define H_is_eqv "(eqv? obj1 obj2) returns #t if obj1 is equivalent to obj2" -#define Q_is_eqv sc->pcl_bt -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))); -} +/* -------- cddr -------- */ +#define H_cddr "(cddr lst) returns (cdr (cdr lst)): (cddr '(1 2 3 4)) -> '(3 4)" +#define Q_cddr sc->pl_p +/* g_cddr is now defined in s7_liii_list.c */ -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))); -} - -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: - if (!local_strncmp ((const char*) port_filename (x), - (const char*) port_filename (y), - port_filename_length (x))) - return (false); - if (is_input_port (x)) return (port_position (x) == port_position (y)); -#if MS_WINDOWS - return (false); -#else - return (ftell (port_file (x)) == ftell (port_file (y))); -#endif - 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); -} +/* cddr_p_p is now defined in s7_scheme_cxr.c */ -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; -} +/* -------- caaar -------- */ +/* caaar_p_p is now defined in s7_scheme_cxr.c */ -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); -} +#define H_caaar "(caaar lst) returns (car (car (car lst))): (caaar '(((1 2)))) -> 1" +#define Q_caaar sc->pl_p +/* g_caaar is now defined in s7_liii_list.c */ -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)); -} +/* -------- caadr -------- */ +/* caadr_p_p is now defined in s7_scheme_cxr.c */ -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; +#define H_caadr "(caadr lst) returns (car (car (cdr lst))): (caadr '(1 (2 3))) -> 2" +#define Q_caadr sc->pl_p +/* g_caadr is now defined in s7_liii_list.c */ - 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))); +/* -------- cadar -------- */ +#define H_cadar "(cadar lst) returns (car (cdr (car lst))): (cadar '((1 2 3))) -> 2" +#define Q_cadar sc->pl_p +/* g_cadar is now defined in s7_liii_list.c */ - 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); - { - s7_pointer pa= to_list (sc, set_plist_1 (sc, a)); - s7_pointer pb= to_list (sc, set_plist_1 (sc, b)); - for (; 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 */ - } -} +/* cadar_p_p is now defined in s7_scheme_cxr.c */ -#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) +/* -------- cdaar -------- */ +/* cdaar_p_p is now defined in s7_scheme_cxr.c */ -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 hash_func; - 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); - } +#define H_cdaar "(cdaar lst) returns (cdr (car (car lst))): (cdaar '(((1 2 3)))) -> '(2 3)" +#define Q_cdaar sc->pl_p +/* g_cdaar is now defined in s7_liii_list.c */ - 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; - - hash_func= hash_table_checker (y); - if ((hash_func != hash_equal) && (hash_func != hash_equivalent)) { - for (s7_int i= 0; i < len; i++) - for (hash_entry_t* entry= lists[i]; entry; - entry = hash_entry_next (entry)) { - hash_entry_t* y_val= hash_func (sc, y, hash_entry_key (entry)); - if (y_val == sc->unentry) return (false); - if (!eqf (sc, hash_entry_value (entry), 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 hash_func? - */ - return (true); - } +/* -------- caddr -------- */ +#define H_caddr "(caddr lst) returns (car (cdr (cdr lst))): (caddr '(1 2 3 4)) -> 3" +#define Q_caddr sc->pl_p +/* g_caddr is now defined in s7_liii_list.c */ - /* 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)) /* entry declared below */ - { - 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); is_not_slot_end (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); is_not_slot_end (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) { - int32_t x_len, y_len; +/* caddr_p_p is now defined in s7_scheme_cxr.c */ - 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); is_not_slot_end (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++; - } +/* g_list_ref_at_2 is now defined in s7_liii_list.c */ - for (s7_pointer e= y_let; e; e= let_outlet (e)) - for (s7_pointer slot= let_slots (e); is_not_slot_end (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); is_not_slot_end (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); - { - shared_info_t* nci= ci; - 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); is_not_slot_end (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); -} +/* -------- cdddr -------- */ +/* cdddr_p_p is now defined in s7_scheme_cxr.c */ -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))); -} +#define H_cdddr "(cdddr lst) returns (cdr (cdr (cdr lst))): (cdddr '(1 2 3 4)) -> '(4)" +#define Q_cdddr sc->pl_p +/* g_cdddr is now defined in s7_liii_list.c */ -/* 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))); -} +/* -------- cdadr -------- */ +/* cdadr_p_p is now defined in s7_scheme_cxr.c */ -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))); - } -} +#define H_cdadr "(cdadr lst) returns (cdr (car (cdr lst))): (cdadr '(1 (2 3 4))) -> '(3 4)" +#define Q_cdadr sc->pl_p +/* g_cdadr is now defined in s7_liii_list.c */ -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)))); - } -} +/* -------- cddar -------- */ +/* cddar_p_p is now defined in s7_scheme_cxr.c */ -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); -} +#define H_cddar "(cddar lst) returns (cdr (cdr (car lst))): (cddar '((1 2 3 4))) -> '(3 4)" +#define Q_cddar sc->pl_p +/* g_cddar is now defined in s7_liii_list.c */ -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); -} +/* -------- caaaar -------- */ +#define H_caaaar "(caaaar lst) returns (car (car (car (car lst)))): (caaaar '((((1 2))))) -> 1" +#define Q_caaaar sc->pl_p +/* g_caaaar is now defined in s7_liii_list.c */ -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) +/* -------- caaadr -------- */ +#define H_caaadr "(caaadr lst) returns (car (car (car (cdr lst)))): (caaadr '(1 ((2 3)))) -> 2" +#define Q_caaadr sc->pl_p +/* g_caaadr is now defined in s7_liii_list.c */ -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); -} +/* -------- caadar -------- */ +#define H_caadar "(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2" +#define Q_caadar sc->pl_p +/* g_caadar is now defined in s7_liii_list.c */ -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)); -} +/* -------- cadaar -------- */ +#define H_cadaar "(cadaar lst) returns (car (cdr (car (car lst)))): (cadaar '(((1 2 3)))) -> 2" +#define Q_cadaar sc->pl_p +/* g_cadaar is now defined in s7_liii_list.c */ -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)); -} +/* -------- caaddr -------- */ -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); -} +/* caaddr_p_p is now defined in s7_scheme_cxr.c */ -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; - 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); +#define H_caaddr "(caaddr lst) returns (car (car (cdr (cdr lst)))): (caaddr '(1 2 (3 4))) -> 3" +#define Q_caaddr sc->pl_p +/* g_caaddr is now defined in s7_liii_list.c */ - 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)); - { - shared_info_t* nci= ci; - 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); -} +/* -------- cadddr -------- */ +/* cadddr_p_p is now defined in s7_scheme_cxr.c */ -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; +#define H_cadddr "(cadddr lst) returns (car (cdr (cdr (cdr lst)))): (cadddr '(1 2 3 4 5)) -> 4" +#define Q_cadddr sc->pl_p +/* g_cadddr is now defined in s7_liii_list.c */ - 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); - is_not_slot_end (xs) && is_not_slot_end (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); -} +/* -------- cadadr -------- */ +/* cadadr_p_p is now defined in s7_scheme_cxr.c */ -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)); -} +#define H_cadadr "(cadadr lst) returns (car (cdr (car (cdr lst)))): (cadadr '(1 (2 3 4))) -> 3" +#define Q_cadadr sc->pl_p +/* g_cadadr is now defined in s7_liii_list.c */ -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)); - return (false); -} +/* -------- caddar -------- */ +/* caddar_p_p is now defined in s7_scheme_cxr.c */ -/* 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))); - 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)); - 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))); - return (false); -} - -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)))); - } - 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)))); - } - 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)))); - } - 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)))); - } - return (false); -} +#define H_caddar "(caddar lst) returns (car (cdr (cdr (car lst)))): (caddar '((1 2 3 4))) -> 3" +#define Q_caddar sc->pl_p +/* g_caddar is now defined in s7_liii_list.c */ -static bool -random_state_equal (s7_scheme* sc, s7_pointer x, s7_pointer y, - shared_info_t* ci) { - return ((x == y) || - ((is_random_state (y)) && (random_seed (x) == random_seed (y)) && - (random_carry (x) == random_carry (y)))); -} +/* -------- cdaaar -------- */ +#define H_cdaaar "(cdaaar lst) returns (cdr (car (car (car lst)))): (cdaaar '((((1 2 3))))) -> '(2 3)" +#define Q_cdaaar sc->pl_p +/* g_cdaaar is now defined in s7_liii_list.c */ -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))); -} +/* -------- cdaadr -------- */ +#define H_cdaadr "(cdaadr lst) returns (cdr (car (car (cdr lst)))): (cdaadr '(1 ((2 3 4)))) -> '(3 4)" +#define Q_cdaadr sc->pl_p +/* g_cdaadr is now defined in s7_liii_list.c */ -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; - 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; - 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)); -} +/* -------- cdadar -------- */ +#define H_cdadar "(cdadar lst) returns (cdr (car (cdr (car lst)))): (cdadar '((1 (2 3 4)))) -> '(3 4)" +#define Q_cdadar sc->pl_p +/* g_cdadar is now defined in s7_liii_list.c */ -/* g_is_equal and g_is_equivalent are now in s7_scheme_predicate.c */ -#define H_is_equal "(equal? obj1 obj2) returns #t if obj1 is equal to obj2" -#define Q_is_equal sc->pcl_bt -#define H_is_equivalent \ - "(equivalent? obj1 obj2) returns #t if obj1 is close enough to obj2." -#define Q_is_equivalent sc->pcl_bt +/* -------- cddaar -------- */ +#define H_cddaar "(cddaar lst) returns (cdr (cdr (car (car lst)))): (cddaar '(((1 2 3 4)))) -> '(3 4)" +#define Q_cddaar sc->pl_p +/* g_cddaar is now defined in s7_liii_list.c */ -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); -} +/* -------- cdaddr -------- */ +#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 +/* g_cdaddr is now defined in s7_liii_list.c */ -/* ---------------------------------------- length, copy, fill - * ---------------------------------------- */ -static s7_pointer s7_length (s7_scheme* sc, - s7_pointer lst); /* why isn't this in s7.h? */ +/* -------- cddddr -------- */ -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); -} +/* cddddr_p_p is now defined in s7_scheme_cxr.c */ -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); -} +#define H_cddddr "(cddddr lst) returns (cdr (cdr (cdr (cdr lst)))): (cddddr '(1 2 3 4 5)) -> '(5)" +#define Q_cddddr sc->pl_p +/* g_cddddr is now defined in s7_liii_list.c */ -static s7_pointer -nil_length (s7_scheme* sc, s7_pointer lst) { - return (int_zero); -} -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 -rs_length (s7_scheme* sc, s7_pointer rs) { - return (int_two); -} +/* -------- cddadr -------- */ +/* cddadr_p_p is now defined in s7_scheme_cxr.c */ -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)); -} +#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 +/* g_cddadr is now defined in s7_liii_list.c */ -static s7_pointer -let_length_with_method (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))); -} +/* -------- cdddar -------- */ -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); -} +/* cdddar_p_p is now defined in s7_scheme_cxr.c */ -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 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] = let_length_with_method; - 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[type_unchecked (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[type_unchecked (car (args))]) (sc, car (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 +/* g_cdddar is now defined in s7_liii_list.c */ -/* -------------------------------- 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)); /* cadr (caller) is set in s7_copy_1 */ - 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 */ +/* -------------------------------- 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 == car_unchecked(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 -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 (sc, cobj, wrap_mutable_integer (sc, loc), - val))); /* was make_integer 14-Nov-23 */ -} +/* assq_p_pp migrated to s7_liii_list.c */ -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 */ -} +/* g_assq migrated to s7_scheme_predicate.c */ +#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) -static s7_pointer -let_setter (s7_scheme* sc, s7_pointer let, 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 let, its value is changed, otherwise a new slot is - * added to let - */ - 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, let, sym); - if (is_slot (slot)) checked_slot_set_value (sc, slot, cdr (val)); - else add_slot_checked_with_id (sc, let, 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, table is the hash-table, val has to be of the form - * (cons key value) if key is already in table, its value is changed, - * otherwise a new slot is added to table, cadr(elist_3) is caller, set in - * s7_copy_1 - */ - if (!is_pair (val)) { - set_car (sc->elist_3, - wrap_string (sc, "~S: ~S is not (cons key value)", 30)); - set_caddr (sc->elist_3, val); - error_nr (sc, sc->wrong_type_arg_symbol, sc->elist_3); - } - return (s7_hash_table_set (sc, 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) */ +/* bridge for g_assq migration */ +s7_pointer s7i_assq_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) { - s7_pointer dest; - switch (type (source)) { - case T_VECTOR: - return (copy_vector (sc, source)); - case T_PAIR: - return (copy_any_list (sc, source)); /* top level only, as in the other - cases, checks for circles */ - case T_HASH_TABLE: - return ( - copy_hash_table (sc, source)); /* this has to copy nearly everything */ - case T_C_OBJECT: - return (copy_c_object (sc, args)); - case T_RANDOM_STATE: - return (random_state_copy (sc, args)); - case T_ITERATOR: - return (iterator_copy (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_STRING: - if (string_length (source) == 0) return (nil_string); - return (make_string_with_length (sc, string_value (source), - string_length (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_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); - - 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); - /* default here it to return the source without comment */ - } - return (source); + return(assq_p_pp(sc, a, b)); } -static s7_pointer -copy_p_p (s7_scheme* sc, s7_pointer source) { - return (copy_source_no_dest (sc, source, set_plist_1 (sc, source))); +/* assv_p_pp migrated to s7_liii_list.c */ + +/* g_assv migrated to s7_scheme_predicate.c */ +#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 + +/* bridge for g_assv migration */ +s7_pointer s7i_assv_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) +{ + return(assv_p_pp(sc, a, b)); } -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 (sc, source, mi))); - set_integer (mj, j); - cset (sc, sc->t3_1); - } - } - else { - s7_pointer mi = make_mutable_integer (sc, 0); - const s7_int gc_loc1= gc_protect_1 (sc, mi); - s7_pointer mj = make_mutable_integer (sc, 0); - const 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 (sc, 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); - } +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); - 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: - random_seed (dest) = random_seed (source); - random_carry (dest)= random_carry (source); - 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); - } + 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); - 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; + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + return(sc->F); +} - 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 new_cobj= (*(c_object_copy (sc, source))) (sc, args); - if (new_cobj == 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); is_not_slot_end (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); is_not_slot_end (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); is_not_slot_end (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)); - } +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); - 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); + 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); - 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); - } + 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 */ +} - 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 new_cobj= (*(c_object_copy (sc, dest))) (sc, args); - if (new_cobj == 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)); - } +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 */ +} - if (dest_len == 0) return (dest); +/* g_is_eq and g_is_eqv migrated to s7_scheme_predicate.c */ +static s7_pfunc s7_bool_optimize(s7_scheme *sc, s7_pointer expr); - /* end is source_len if not set explicitly */ - if (dest_len < source_len) { - end = dest_len + start; - source_len= dest_len; - } +/* a naming experiment, "q_" to match signature "Q_" */ +#define q_call(o) o->v[0] - 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); - } +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) - 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); + 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 */ } - return (dest); - } + 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? */ - case T_LET: - if (source == sc->starlet) /* *s7* */ /* this could be more direct via - starlet_make_iterator, but it - hardly matters */ - { - const s7_pointer iter = s7_make_iterator (sc, sc->starlet); - const 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 (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 (q_call(o).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 (q_call(o).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_ppp(sc, eq_func, sc->assoc_symbol, car(args), lst, eq_func, a_procedure_string, 3)); + 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)); { - if ((has_let_fallback (source)) && (has_let_fallback (dest))) { - for (slot= let_slots (source); is_not_slot_end (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)); + 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 - 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); - } + { + 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); } - return (dest); + 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)); } +} - 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; - /* default (random_state, simple_block etc) is to let "set" handle it below - */ - } +/* assoc_p_pp migrated to s7_liii_list.c */ - 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])); +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); } - 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])); + if (!is_pair(cdr(opt1_fast(orig_args)))) /* (assoc 3 '((1 . 2) . 3) =) or nil */ + { + sc->value = sc->F; + return(true); } - 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 + 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 */ - return (dest); + 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); } -s7_pointer -s7_copy (s7_scheme* sc, s7_pointer args) { - return (s7_copy_1 (sc, sc->copy_symbol, args)); -} -#define g_copy s7_copy - -s7_pointer -s7i_copy_1 (s7_scheme* sc, s7_pointer caller, s7_pointer args) { - return (s7_copy_1 (sc, caller, args)); +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); } -/* -------------------------------- reverse -------------------------------- */ -/* s7_reverse migrated to s7_liii_list.c */ -/* 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) - */ +/* ---------------- member, memv, memq ---------------- */ +/* s7_memq, g_memq migrated to s7_liii_list.c */ +#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 -static s7_pointer -string_reverse (s7_scheme* sc, s7_pointer str) { - const char* source = string_value (str); - const s7_int len = string_length (str); - const char* end = (char*) (source + len); - const s7_pointer new_str= make_empty_string (sc, len, '\0'); - char* 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) { - 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); - const s7_pointer new_bv= make_simple_byte_vector (sc, len); - uint8_t* 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= s7i_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= s7i_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= s7i_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); -} +/* 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 -c_object_reverse_1 (s7_scheme* sc, s7_pointer obj) { - 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))); -} +/* memq_2_p_pp migrated to s7_liii_list.c */ -static s7_pointer -let_reverse (s7_scheme* sc, s7_pointer obj) { - 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)); -#ifdef __TINYC__ - return (NULL); /* won't happen but placate tcc */ -#endif -} +s7_pointer s7i_memq_2_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) {return(memq_2_p_pp(sc, obj, lst));} -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: - return (c_object_reverse_1 (sc, obj)); - case T_LET: - return (let_reverse (sc, obj)); - default: - return (method_or_bust_p (sc, obj, sc->reverse_symbol, a_sequence_string)); - } - return (sc->nil); -} +/* memq_3_p_pp migrated to s7_liii_list.c */ -/* g_reverse is now defined in s7_scheme_predicate.c */ -#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) +/* g_memq_3 migrated to s7_liii_list.c */ -/* any_list_reverse_in_place migrated to s7_liii_list.c */ +/* memq_4_p_pp migrated to s7_liii_list.c */ -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)); +s7_pointer s7i_memq_4_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer lst) {return(memq_4_p_pp(sc, obj, lst));} -#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); +/* g_memq_any migrated to s7_liii_list.c */ + +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 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 bool numbers_are_eqv(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + /* 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 -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 memv_number(s7_scheme *sc, s7_pointer obj, s7_pointer lst) +{ + s7_pointer slow = lst; + uint8_t obj_type = type(obj); + while (true) + { + 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)); + slow = cdr(slow); + if (lst == slow) return(sc->F); + } + return(sc->F); } -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); +/* memv_p_pp migrated to s7_liii_list.c */ + +/* g_memv migrated to s7_scheme_predicate.c */ +#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 + +/* bridge for g_memv migration */ +s7_pointer s7i_memv_p_pp(s7_scheme *sc, s7_pointer a, s7_pointer b) +{ + return(memv_p_pp(sc, a, b)); } -static s7_pointer -reverse_pair_in_place (s7_scheme* sc, s7_pointer obj, s7_pointer args) { - 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)) - type_error_nr (sc, sc->reverseb_symbol, 1, car (args), - wrap_string (sc, "a proper list", 13)); - 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 - */ + +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 -reverse_in_place_via_method (s7_scheme* sc, s7_pointer obj) { - 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_type_error_nr (sc, sc->reverseb_symbol, obj, a_sequence_string); - } - if ((is_simple_sequence (obj)) && (!has_active_methods (sc, obj))) - sole_arg_type_error_nr (sc, sc->reverseb_symbol, obj, - wrap_string (sc, "a vector, string, or list", 25)); - return (vector_method_or_bust_p (sc, obj, sc->reverseb_symbol, - a_sequence_string)); +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 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_PAIR: - return (reverse_pair_in_place (sc, obj, args)); - 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)); - case T_NIL: - return (sc->nil); /* (reverse! ()) -> () */ - default: - return (reverse_in_place_via_method (sc, obj)); - } - return (obj); +static bool p_to_b(opt_info *p); + +/* -------- s7i_ bridges for list p_p migration to s7_liii_list.c -------- */ +s7_pointer s7i_cons_safe(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); +} +s7_pointer s7i_inline_set_car(s7_scheme *sc, s7_pointer lst, s7_pointer value) {return(inline_set_car(sc, lst, value));} +s7_pointer s7i_inline_set_cdr(s7_scheme *sc, s7_pointer lst, s7_pointer value) {return(inline_set_cdr(sc, lst, value));} +bool s7i_is_simple(s7_pointer p) {return(is_simple(p));} +bool s7i_scheme_version_is_s7(s7_scheme *sc) {return(sc->scheme_version == sc->s7_symbol);} +s7_pointer s7i_methods_or_bust_pp(s7_scheme *sc, s7_pointer obj, const char *method_name1, const char *method_name2, + s7_pointer x1, s7_pointer x2, s7_pointer typ, s7_int num) +{ + return(methods_or_bust_pp(sc, obj, s7_make_symbol(sc, method_name1), s7_make_symbol(sc, method_name2), x1, x2, typ, (int32_t)num)); } +s7_pointer s7i_assoc_1(s7_scheme *sc, s7_pointer obj, s7_pointer lst) {return(assoc_1(sc, obj, lst));} +s7_pointer s7i_memv_number(s7_scheme *sc, s7_pointer obj, s7_pointer lst) {return(memv_number(sc, obj, lst));} +s7_pointer s7i_member(s7_scheme *sc, s7_pointer obj, s7_pointer lst) {return(member(sc, obj, lst));} +/* s7i_tree_len, s7i_tree_is_cyclic_checked migrated to s7_liii_tree.c */ -/* -------------------------------- fill! -------------------------------- */ -static s7_pointer -pair_fill (s7_scheme* sc, - s7_pointer args) /* args=(list tree-to-fill fill-val start end) */ +static s7_pointer g_member(s7_scheme *sc, s7_pointer args) { - /* 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; + #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) -#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! + /* 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. */ - const s7_pointer obj= car (args); - switch (type (obj)) { - case T_STRING: - return (g_string_fill (sc, 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 (s7i_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 + 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)); -/* -------------------------------- 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]); - if (n < 0) - wrong_type_error_nr (sc, caller, i, seq, - (is_pair (seq)) ? a_proper_list_string - : a_sequence_string); - len+= n; - } - return (len); -} - -s7_pointer -s7i_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 vec= car (p); - const s7_int n = sequence_length (sc, vec); - if (n > 0) { - if ((typed) && (is_typed_t_vector (vec))) { - if (!vtyper) vtyper= typed_vector_typer (vec); - else if (vtyper != typed_vector_typer (vec)) typed= false; - } - else typed= false; - vector_length (new_vec)= n; - set_car (pargs, vec); - 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 (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 (q_call(o).fb == p_to_b) + { + s7_pointer (*fp)(opt_info *o) = q_temp(o).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 (q_call(o).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 (q_call(o).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 ((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? */ + if (is_null(lst)) return(sc->F); { - set_weak_hash_table (new_table); - weak_hash_iters (new_table)= 0; + 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)); } - 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 let= car (args); - if_let_method_exists_return_value (sc, let, 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 (s7i_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 (s7i_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? */ - sc->temp7= b; /* GC protect b across the copy loop below (it is not - otherwise protected here) */ - 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); - sc->temp7= sc->unused; - 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 -append_chooser (s7_scheme* sc, s7_pointer func, int32_t args, - s7_pointer unused_expr) { - if (args == 2) return (sc->append_2); - return (func); +/* member_p_pp migrated to s7_liii_list.c */ + +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); } -/* -------------------------------- 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; - } +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 (val != sc->no_value) { - if (is_null (result)) { - if (is_multiple_value (val)) { - result= multiple_value (val); - clear_multiple_value (val); - for (p= result; is_pair (cdr (p)); p= cdr (p)) - ; - } - else { - result= list_1 (sc, val); - p = result; - } - gc_protect_via_stack (sc, result); /* unstacked above */ - } - else if (is_multiple_value (val)) { - set_cdr (p, multiple_value (val)); - clear_multiple_value (val); - for (; is_pair (cdr (p)); p= cdr (p)) - ; - } - else { - set_cdr (p, list_1 (sc, val)); - p= cdr (p); - } + if (!is_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); } -static s7_pointer -c_obj_to_list (s7_scheme* sc, - s7_pointer obj) /* "c_object_to_list" is the ->list method - mentioned below */ + +/* -------------------------------- list -------------------------------- */ +#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) +/* g_list is now defined in s7_liii_list.c */ + + +static s7_pointer list_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) { - s7_int len; - s7_pointer obj_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))); - - obj_len= c_object_length (sc, obj); - if (!s7_is_integer (obj_len)) return (sc->F); - len= s7_integer_clamped_if_gmp (sc, obj_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); + 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); } -/* ---------------- 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); -} +/* list_p_p, list_p_pp, list_p_ppp migrated to s7_liii_list.c */ +/* if the GC sees a free cell here, protect it in the caller, not here, but sometimes the GC is called here! */ -static s7_pointer -random_state_to_let (s7_scheme* sc, s7_pointer rs) { - 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)))); +const char *ordinal[11] = {"zeroth", "first", "second", "third", "fourth", "fifth", "sixth", "seventh", "eighth", "ninth", "tenth"}; +const s7_int ordinal_length[11] = {6, 5, 6, 5, 6, 5, 5, 7, 6, 5, 5}; + +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)); + } } -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 */ +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)) { - 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; + 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); } - 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, "symtab-stats:empty|1|2|n|most", - 29), /* "symtab-stats" to distinguish from hash-stats below */ - 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 + 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); - 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); -} - -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 (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 - 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)))))); - } + sc->safe_list_uses[1]++; #endif - s7_gc_unprotect_at (sc, gc_loc); - return (let); + return(sc->safe_lists[1]); + } + return(cons(sc, sc->nil, sc->nil)); } -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); +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]); } - 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); + return(cons_unchecked(sc, sc->nil, list_1(sc, sc->nil))); } -static s7_pointer -port_to_let (s7_scheme* sc, s7_pointer port) /* note the underbars! */ +static s7_pointer make_safe_list(s7_scheme *sc, s7_int num_args) { - 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)); - } - } + 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 - } - 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? - */ + 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) { - 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 (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]); } - } - 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: - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_integer_symbol)); - case T_RATIO: - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_rational_symbol)); - case T_REAL: - return (internal_inlet (sc, 4, sc->value_symbol, obj, sc->type_symbol, - sc->is_real_symbol)); - case T_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); + return(make_safe_list(sc, num_args)); } -/* g_object_to_let is now defined in s7_scheme_predicate.c */ -#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) +static s7_pointer g_list_append(s7_scheme *sc, s7_pointer args) +{ + s7_pointer tp = sc->nil, np = NULL, pp; -/* bridge functions for s7_scheme_predicate.c migration (round 2) */ -s7_pointer -s7i_c_pointer_weak1_p_p (s7_scheme* sc, s7_pointer cptr) { - return (c_pointer_weak1_p_p (sc, cptr)); -} -s7_pointer -s7i_c_pointer_weak2_p_p (s7_scheme* sc, s7_pointer cptr) { - return (c_pointer_weak2_p_p (sc, cptr)); -} -/* s7i_tree_leaves_p_p migrated to s7_liii_tree.c */ -s7_pointer -s7i_cyclic_sequences_p_p (s7_scheme* sc, s7_pointer p) { - return (cyclic_sequences_p_p (sc, p)); -} -s7_pointer -s7i_object_to_let_p_p (s7_scheme* sc, s7_pointer p) { - return (object_to_let_p_p (sc, p)); + /* 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); } -s7_pointer -s7i_pair_line_number_p_p (s7_scheme* sc, s7_pointer p) { - return (pair_line_number_p_p (sc, p)); + +/* append_in_place migrated to s7_liii_list.c */ + + +/* -------------------------------- 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); } -s7_pointer -s7i_reverse_p_p (s7_scheme* sc, s7_pointer p) { - return (reverse_p_p (sc, p)); + +static s7_pointer typed_vector_typer_symbol(s7_scheme *sc, s7_pointer vec) +{ + s7_pointer typer_name, typer = typed_vector_typer(vec); + if (is_c_function(typer)) + return(c_function_symbol(typer)); + typer_name = find_typer(sc, typer); + return((is_symbol(typer_name)) ? typer_name : sc->anon_symbol); } -s7_pointer -s7i_port_line_number_p_p (s7_scheme* sc, s7_pointer p) { - return (port_line_number_p_p (sc, p)); + +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))); } -/* s7i_tree_memq_b_7pp, s7i_tree_set_memq_b_7pp migrated to s7_liii_tree.c */ -s7_pointer -s7i_unlet_disabled (s7_scheme* sc) { - return (sc->unlet_disabled); + +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); } -s7_pointer -s7i_curlet (s7_scheme* sc) { - return (sc->curlet); + +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->type_error_symbol, + set_elist_3(sc, wrap_string(sc, "vector-set! new value ~$ is rejected by the vector's vector-typer, ~A", 69), + val, wrap_string(sc, descr, safe_strlen(descr)))); } -void -s7i_capture_let_counter_inc (s7_scheme* sc) { - sc->capture_let_counter++; + +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); } -bool -s7i_is_defined_in_rootlet (s7_scheme* sc, s7_pointer sym) { - return ((is_slot (global_slot (sym))) && - (global_value (sym) != sc->undefined)); + +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 type_error_nr(sc, sc->int_vector_set_symbol, 3, val, sc->type_names[T_INTEGER]); + return(val); } -/* ---------------- stacktrace ---------------- */ -static s7_pointer -stacktrace_find_caller (s7_scheme* sc, s7_pointer let) { - if ((is_let (let)) && (let != sc->rootlet)) - return (((is_funclet (let)) || (is_maclet (let))) - ? funclet_function (let) - : stacktrace_find_caller (sc, let_outlet (let))); - return (sc->F); +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 bool -stacktrace_find_let (s7_scheme* sc, s7_int loc, s7_pointer let) { - return ((loc > 0) && ((stack_let (sc->stack, loc) == let) || - (stacktrace_find_let (sc, loc - 4, let)))); +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_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 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)) + 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)) + 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 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 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); } -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 let, 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, let); - add_symbol_to_small_symbol_set (sc, code); - if ((val) && (val != sc->undefined) && (!is_any_macro (val)) && - (type (val) < T_CONTINUATION)) { - char* objstr; - 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); - } - { - char* str; - 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), let, notes, code_cols, total_cols, - notes_start_col, as_comment, depth + 1); - return (stacktrace_walker (sc, cdr (code), let, 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; - block_t* newp; - 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); - { - block_t* b = mallocate (sc, newlen); - char* 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); - } +#define mallocate_vector(Sc, Len) ((Len) > 0) ? inline_mallocate(Sc, Len) : mallocate_empty_block(Sc) + +extern 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 -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 let= stack_let ( - sc->stack, - true_loc); /* might not be let (gc stack protection etc) */ - const s7_pointer func= stacktrace_find_caller (sc, let); - if (!stacktrace_error_hook_function (sc, func)) { - 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 (let)) && (let != sc->rootlet)) - notes= - stacktrace_walker (sc, code, let, NULL, code_cols, total_cols, - notes_start_col, as_comment, 0); - newp = stacktrace_add_func (sc, func, 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 (let)) && - (let != 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); - } - } - } +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); } - } - 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)); - } - } + 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); } - } - } - return (stacktrace_1 (sc, max_frames, code_cols, total_cols, notes_start_col, - as_comment)); + 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); } -/* -------- s7_history, s7_add_to_history, s7_history_enabled -------- */ +#define FILLED true +#define NOT_FILLED false -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_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_history (s7_scheme* sc) { -#if WITH_HISTORY - if (sc->cur_code == sc->history_sink) return (sc->old_cur_code); -#endif - return (sc->cur_code); +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); } -bool -s7_history_enabled (s7_scheme* sc) { -#if WITH_HISTORY - return (sc->cur_code != sc->history_sink); -#else - return (false); +static vdims_t *make_wrap_only(s7_scheme *sc) /* this makes sc->wrap_only */ +{ + vdims_t *vd = (vdims_t *)mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; #endif + vdims_original(vd) = sc->F; + vector_elements_should_be_freed(vd) = false; + vdims_rank(vd) = 1; + vdims_dims(vd) = NULL; + vdims_offsets(vd) = NULL; + return(vd); } -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); +static vdims_t *make_vdims(s7_scheme *sc, bool elements_should_be_freed, s7_int dims, const s7_int *dim_info) +{ + vdims_t *vd; + if ((dims == 1) && (!elements_should_be_freed)) + return(sc->wrap_only); + if (dims > 1) + { + vd = (vdims_t *)mallocate(sc, dims * 2 * sizeof(s7_int)); + vdims_original(vd) = sc->F; + vector_elements_should_be_freed(vd) = elements_should_be_freed; + vdims_rank(vd) = dims; + vdims_offsets(vd) = (s7_int *)(vdims_dims(vd) + dims); + for (s7_int i = 0; i < dims; i++) + vdims_dims(vd)[i] = dim_info[i]; + for (s7_int i = dims - 1, offset = 1; i >= 0; i--) + { + vdims_offsets(vd)[i] = offset; + offset *= vdims_dims(vd)[i]; + } + return(vd); + } + vd = (vdims_t *)mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; #endif + vdims_original(vd) = sc->F; + vector_elements_should_be_freed(vd) = elements_should_be_freed; + vdims_rank(vd) = 1; + vdims_dims(vd) = NULL; + vdims_offsets(vd) = NULL; + return(vd); } -#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); - set_cdr_unchecked (p, args); - return (p); +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); } -#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, let; - opcode_t op; - sc->stack_end-= 4; - code= stack_end_code (sc); - let = 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) = let; - stack_end_args (sc)= args; - stack_end_op (sc) = (s7_pointer) op; - sc->stack_end+= 4; +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); } -static s7_pointer -find_funclet (s7_scheme* sc, s7_pointer let) { - if ((let == sc->rootlet) || (!is_let (let))) return (sc->F); - if (!((is_funclet (let)) || (is_maclet (let)))) let= let_outlet (let); - if ((let == sc->rootlet) || (!is_let (let))) return (sc->F); - return (((is_funclet (let)) || (is_maclet (let))) ? let : sc->F); +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); } -#define PD_INITIAL_SIZE 16 -enum { pd_calls= 0, pd_recur, pd_start, pd_itotal, pd_etotal, pd_block_size }; +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); +} -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 let; - const s7_int pos= integer (car (args)); - if (sc->profile == 0) return (sc->F); - - let= find_funclet (sc, cadr (args)); - if ((is_let (let)) && (is_symbol (funclet_function (let)))) { - const s7_pointer func_name= funclet_function (let); - s7_int* timing_data; - 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, let); - if (is_symbol (let_name)) pd->let_names[pos]= let_name; - } - if (has_let_file (let)) { - pd->files[pos]= sc->file_names[let_file (let)]; - pd->lines[pos]= let_line (let); - } + +/* -------------------------------- 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)); } - timing_data= - (s7_int*) (sc->profile_data->timing_data + (pos * pd_block_size)); - timing_data[pd_calls]++; - if (timing_data[pd_recur] == 0) { - timing_data[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; + 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; } - timing_data[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); +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)); } - 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 - * -------------------------------- */ -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)); /* ?? */ + { + 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; + } } -/* -------------------------------- 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); +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); } -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; +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; } - 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) */ +void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj) +{ + switch (type(vec)) + { + case T_FLOAT_VECTOR: + if (!is_real(obj)) + 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 */ + 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)) + 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)) + 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 void -op_c_catch_all_a (s7_scheme* sc) { - op_c_catch_all (sc); - sc->value= fx_call (sc, sc->code); +s7_pointer s7i_make_simple_complex_vector(s7_scheme *sc, s7_int len) +{ + return(make_simple_complex_vector(sc, len)); } -/* -------------------------------- 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 let= make_let (sc, sc->rootlet); - begin_temp (sc->x, let); - sc->error_type= add_slot_checked_with_id ( - sc, let, 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, let, 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, let, 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, let, 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, let, make_symbol (sc, "error-file", 10), - sc->F); /* the file name of that code */ - sc->error_position= add_slot_unchecked_with_id ( - sc, let, 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, let, make_symbol (sc, "error-history", 13), - sc->F); /* buffer of previous evaluations */ -#endif - end_temp (sc->x); - return (let); +s7_complex s7i_to_c_complex(s7_pointer z) +{ + return(s7_to_c_complex(z)); } -#if WITH_HISTORY -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 (sc, 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); +s7_pointer s7i_vector_fill_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) +{ + const s7_pointer vect = car(args); + s7_pointer fill; + + 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" + */ + 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); + 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(vector_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(vector_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(vector_method_or_bust(sc, fill, caller, args, sc->type_names[T_COMPLEX], 2)); + } + { + s7_int start = 0, 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); } -#endif -/* g_owlet moved to s7_scheme_let.c */ -#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." +#if !WITH_PURE_S7 +/* -------------------------------- vector-fill! -------------------------------- */ +#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) +/* g_vector_fill is now defined in s7_liii_vector.c */ + +/* -------------------------------- vector-append -------------------------------- */ +#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 +/* g_vector_append, vector_append_p_pp, vector_append_p_ppp migrated to s7_liii_vector.c */ #endif -#define Q_owlet s7_make_signature (sc, 1, sc->is_let_symbol) -/* -------- catch handlers -------- (don't free the catcher) */ -static void -load_catch_cstack (s7_scheme* sc, s7_pointer catcher) { - if (catch_cstack (catcher)) sc->goto_start= catch_cstack (catcher); -} - -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 cat= T_Cat (stack_code (sc->stack, catch_loc)); - if (SHOW_EVAL_OPS) fprintf (stderr, "catcher: %s\n", __func__); - if ((catch_tag (cat) == sc->T) || (catch_tag (cat) == type) || - (type == sc->T)) { - sc->op_stack_now= (s7_pointer*) (sc->op_stack + catch_op_loc (cat)); - sc->stack_end = (s7_pointer*) (sc->stack_start + catch_goto_loc (cat)); - sc->code = catch_handler (cat); - load_catch_cstack (sc, cat); - if (needs_copied_args (sc->code)) sc->args= list_2 (sc, type, info); - else - sc->args= with_list_t2 ( - sc, 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); - const s7_pointer error_func= catch_handler (catcher); - const s7_uint loc = catch_goto_loc (catcher); - s7_pointer error_body, error_pars; - - 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 (sc, 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); +/* -------------------------------- 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)); } -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); +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); } -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); +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); } -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); +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); } -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= 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); -} - -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); +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 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); +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); } -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? */ +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)); } -/* -------------------------------- 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) +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)); +} - 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); +/* -------------------------------- 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; } - } - 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); + unstack_gc_protect(sc); + return_with_end_temp(sc->y); } -/* -------------------------------- 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) */ +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 +#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) +/* g_vector_to_list, vector_to_list_p_p migrated to s7_liii_vector.c */ #endif + + +/* -------------------------------- vector -------------------------------- */ +/* g_vector, g_vector_2, g_vector_3 are now defined in s7_liii_vector.c */ + +static inline s7_pointer vector_p_pp(s7_scheme *sc, s7_pointer p1, s7_pointer p2) { - 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); - } + s7_pointer vec = make_simple_vector(sc, 2); + vector_element(vec, 0) = p1; + vector_element(vec, 1) = p2; + return(vec); } -/* -------------------------------- 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 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); } -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 */ + +/* -------------------------------- float-vector -------------------------------- */ +/* g_float_vector is now defined in s7_liii_vector.c */ + +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); } -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 +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 */ - 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; + +/* -------------------------------- int-vector -------------------------------- */ +/* g_int_vector is now defined in s7_liii_vector.c */ + +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 -------------------------------- */ +/* g_byte_vector is now defined in s7_liii_vector.c */ + +/* -------------------------------- complex-vector -------------------------------- */ +/* g_complex_vector is now defined in s7_liii_vector.c */ + +#if !WITH_PURE_S7 +/* -------------------------------- list->vector -------------------------------- */ +/* g_list_to_vector is now defined in s7_liii_vector.c */ + +/* -------------------------------- vector-length -------------------------------- */ +/* g_vector_length, vector_length_i_7p, vector_length_p_p are now defined in s7_liii_vector.c */ #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, - 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 (type_unchecked (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; - } +/* -------------------------------- subvector subvector? subvector-vector subvector-position -------------------------------- */ +static bool s7_is_subvector(s7_pointer vec) {return((is_any_vector(vec)) && (is_subvector(vec)));} + +/* g_is_subvector is now defined in s7_liii_vector.c */ +/* g_subvector_position is now defined in s7_liii_vector.c */ +/* g_subvector_vector is now defined in s7_liii_vector.c */ + +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 *vd = (vdims_t *)mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; #endif - if (is_pair (cur_code)) /* not redundant -- maybe use type_unchecked 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]); + vdims_rank(vd) = dims; + vdims_dims(vd) = (s7_int *)(vector_dimensions(vect) + skip_dims); + vdims_offsets(vd) = (s7_int *)(vector_offsets(vect) + skip_dims); + vdims_original(vd) = vect; + vector_elements_should_be_freed(vd) = false; + vector_set_dimension_info(subvect, vd); } - } - 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); + else + { + vector_set_dimension_info(subvect, NULL); + subvector_set_vector(subvect, vect); } - } - /* 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_t_vector(vect)) + mark_function[T_VECTOR] = mark_vector_possibly_shared; + else mark_function[type(vect)] = mark_int_or_float_vector_possibly_shared; - 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); - } + 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 - 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); + 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); } -s7_pointer -s7_error (s7_scheme* sc, s7_pointer type, - s7_pointer info) /* s7.h backwards compatibility */ +static inline vdims_t *list_to_vdims(s7_scheme *sc, s7_pointer lst) { - 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); + s7_int *ds, *os; + const s7_int len = proper_list_length(lst); + vdims_t *vd = (vdims_t *)inline_mallocate(sc, len * 2 * sizeof(s7_int)); + vdims_rank(vd) = len; + vdims_offsets(vd) = (s7_int *)(vdims_dims(vd) + len); + vector_elements_should_be_freed(vd) = false; + ds = vdims_dims(vd); + os = vdims_offsets(vd); + 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(vd); } -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. +#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) +/* g_subvector migrated to s7_liii_vector.c */ + +s7_pointer s7i_subvector_1(s7_scheme *sc, s7_pointer args) +{ + /* (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 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]; - } + const s7_pointer orig = car(args); + vdims_t *vd = NULL; + s7_int new_len, orig_len, offset = 0; - 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 (!is_any_vector(orig)) + return(vector_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(vector_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(vector_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(vector_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->type_error_symbol, + set_elist_1(sc, wrap_string(sc, "a subvector must fit in the original vector", 43))); + + vd = list_to_vdims(sc, dims); + if (vdims_rank(vd) > sc->max_vector_dimensions) + { + liberate(sc, vd); + 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(vd)[0]; + for (s7_int i = 1; i < vdims_rank(vd); i++) new_len *= vdims_dims(vd)[i]; + if (new_len != new_end - offset) + { + liberate(sc, vd); /* 14-Sep-23 */ + error_nr(sc, sc->value_error_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(vd) = 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 */ - 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); + { + s7_pointer subvect; + 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, vd); + if (!vd) 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 - 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)); + 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); } - 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); -} -/* g_error is now implemented in s7_scheme_base.c */ -#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) - -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'; +/* -------------------------------- vector-ref -------------------------------- */ +s7_pointer s7i_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(vector_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 { - 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); + 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(vector_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 -object_to_string_truncated (s7_scheme* sc, s7_pointer obj) { - 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, obj, 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); - } +/* g_vector_ref is now defined in s7_liii_vector.c */ + +/* vector_ref_p_pi, vector_ref_p_pi_unchecked, t_vector_ref_p_pi_unchecked, + vector_ref_p_pii, vector_ref_p_pii_direct, t_vector_ref_p_pi_direct + migrated to s7_liii_vector.c */ + +s7_pointer s7i_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 -tree_descend (s7_scheme* sc, s7_pointer tree, uint32_t line) { - s7_pointer tp; - if (!is_pair (tree)) return (NULL); - if (has_location (tree)) { - uint32_t cur_line= (uint32_t) pair_line_number (tree); - 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 (tree); - } - } - tp= tree_descend (sc, car (tree), line); - return ((tp) ? tp : tree_descend (sc, cdr (tree), line)); +/* g_vector_ref_2 is now defined in s7_liii_vector.c */ + +/* -------- s7i_ bridges for vector p_p migration to s7_liii_vector.c -------- */ +bool s7i_is_any_vector(s7_pointer p) {return(is_any_vector(p));} +bool s7i_is_t_vector(s7_pointer p) {return(is_t_vector(p));} +bool s7i_is_typed_vector(s7_pointer p) {return(is_typed_vector(p));} +bool s7i_is_immutable_vector(s7_pointer p) {return(is_immutable_vector(p));} +s7_pointer s7i_vector_element(s7_pointer p, s7_int i) {return(vector_element(p, i));} +void s7i_vector_element_set(s7_pointer p, s7_int i, s7_pointer v) {vector_element(p, i) = v;} +s7_pointer s7i_vector_getter_ref(s7_scheme *sc, s7_pointer p, s7_int i) {return(vector_getter(p)(sc, p, i));} +s7_pointer s7i_vector_setter_set(s7_scheme *sc, s7_pointer p, s7_int i, s7_pointer v) {vector_setter(p)(sc, p, i, v);} +s7_pointer s7i_typed_vector_setter(s7_scheme *sc, s7_pointer p, s7_int i, s7_pointer v) {return(typed_vector_setter(sc, p, i, v));} +s7_int s7i_vector_offset(s7_pointer p, s7_int i) {return(vector_offset(p, i));} +s7_pointer s7i_small_int(s7_int val) {return(small_int(val));} +uint8_t s7i_byte_vector_element(s7_pointer p, s7_int i) {return(byte_vector(p, i));} +void s7i_byte_vector_element_set(s7_pointer p, s7_int i, uint8_t v) {byte_vector(p, i) = v;} +s7_pointer s7i_g_vector_set(s7_scheme *sc, s7_pointer plist) {return(g_vector_set(sc, plist));} +s7_pointer s7i_set_plist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4) {return(set_plist_4(sc, x1, x2, x3, x4));} +s7_pointer s7i_vector_append_2(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); + sc->temp7 = sc->unused; + return(val); +} +s7_pointer s7i_vector_append_3(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); + sc->temp7 = sc->unused; + return(val); } -static no_return void -missing_close_paren_error_nr (s7_scheme* sc) { - char* syntax_msg= NULL; - const s7_pointer port = current_input_port (sc); +/* g_vector_ref_3 migrated to s7_liii_vector.c */ - if (type_unchecked (sc->curlet) != T_LET) set_curlet (sc, sc->rootlet); +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); +} - /* 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); -} +/* -------------------------------- vector-set! -------------------------------- */ +#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) +/* g_vector_set, g_vector_set_3, g_vector_set_4 migrated to s7_liii_vector.c */ -/* -------------------------------- 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); +/* vector_set_p_pip, vector_set_p_pip_unchecked, vector_set_p_piip, + vector_set_p_piip_direct, typed_vector_set_p_pip_unchecked, + typed_vector_set_p_piip_direct, t_vector_set_p_pip_direct, + typed_t_vector_set_p_pip_direct migrated to s7_liii_vector.c */ + +/* vector_set_p_ppp migrated to s7_liii_vector.c */ + +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); } -/* -------------------------------- 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); + +/* -------------------------------- 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 */ + 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)) + 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 - 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); + if (len < 0) + type_error_nr(sc, caller, position_of(dims, dim_list), dim, a_non_negative_integer_string); + } + return(len); } -/* -------------------------------- 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 arg, next_arg; - if (is_immutable ( - args)) /* (apply '(1) '(1)) where sc->t2_1 gets used in op_x_aa? */ - args= copy_proper_list (sc, args); - for (arg= args, next_arg= cdr (args); is_pair (cdr (next_arg)); - arg= next_arg, next_arg= cdr (next_arg)) - ; - /* 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 (next_arg))) /* (apply + #f) etc, the cycle protection here - is checked in s7test */ - apply_list_error_nr (sc, args); - set_cdr (arg, car (next_arg)); /* 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. - */ - if (needs_copied_args (sc->code)) sc->args= copy_proper_list (sc, 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 - */ - switch (type (obj)) { - case T_VECTOR: /* (#(#(1 2) #(3 4)) 1 1) -> 4 */ - return (s7i_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 */ - { - s7_pointer 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 */ - { - s7_pointer 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: { - s7_pointer 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 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))))) + type_error_nr(sc, caller, 2, typf, wrap_string(sc, "a boolean procedure", 19)); + if (!c_function_name(typf)) + 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 lst) +{ + vdims_t *vd = list_to_vdims(sc, lst); + vdims_original(vd) = sc->F; + vector_set_dimension_info(vec, vd); + add_multivector(sc, vec); + return(vec); } -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]); +s7_pointer s7i_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) + type_error_nr(sc, caller, 1, dims, a_non_negative_integer_string); + } 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); + { + if (!is_pair(dims)) + return(vector_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))) + 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); } -} -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; - const int32_t n_args= - c_function_max_args (func); /* not counting keywords, I think, "par" and - "arg" are not used consistently here */ + 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 */ + 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)))) + 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)) 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)) type_error_nr(sc, caller, 2, fill, sc->type_names[T_INTEGER]); + result_type = T_INT_VECTOR; + } + else + if (typf == global_value(sc->is_byte_symbol)) + { + if (!is_byte(fill)) 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)) 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); + 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_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; - s7_pointer* par_names; - /* 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); - par_names= c_function_par_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 (par_names[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 ((is_c_function(typf)) && + (c_function_has_simple_elements(typf))) + set_has_simple_elements(vec); } - if (ki < n_args) { - s7_pointer* par_defaults= 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, par_defaults[ki]); - } - else - for (ki= i, kpar= par; ki < n_args; ki++, kpar= cdr (kpar)) - if (!is_checked (kpar)) { - s7_pointer defval= par_defaults[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); + 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); } - 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 let) { - 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, let)) - s7_warn (sc, 256, - "the third argument to %s (the environment): %p, is not an s7 " - "object\n", - __func__, let); - } - 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 (let)) ? let : 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 let, - 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, (let == sc->nil) ? sc->rootlet : let); - if (caller) { - sc->s7_call_name= NULL; - sc->s7_call_file= NULL; - sc->s7_call_line= -1; - } - return (result); -} +#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? */ +/* g_make_vector is now defined in s7_liii_vector.c */ -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 let= cadr (args); - if (!is_let (let)) { - s7_pointer new_let= find_let (sc, let); - if (!is_let (new_let)) - find_let_error_nr (sc, sc->eval_symbol, let, new_let, 2, args); - let= new_let; - } - set_curlet (sc, let); - } - 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); -} +/* -------------------------------- make-float-vector -------------------------------- */ +#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) +/* g_make_float_vector migrated to s7_liii_vector.c */ -/* -------------------------------- type-of -------------------------------- */ -#if !WITH_GCC -static inline bool -gen_type_match (s7_scheme* sc, s7_pointer val, - uint8_t typ) /* opt3_byte = uint8_t */ +static s7_pointer make_float_vector_p_pp(s7_scheme *sc, s7_pointer len, s7_pointer fill) { - return ((type (val) == typ) || - ((has_active_methods (sc, val)) && - (apply_boolean_method (sc, val, sc->type_to_typers[typ]) != sc->F))); + 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))); } -#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_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)]); -} -/* g_type_of migrated to s7_scheme_predicate.c */ -#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) - -/* -------------------------------- 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); -} +/* -------------------------------- make-complex-vector -------------------------------- */ +#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) +/* g_make_complex_vector migrated to s7_liii_vector.c */ -#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) +/* -------------------------------- make-int-vector -------------------------------- */ +#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) +/* g_make_int_vector migrated to s7_liii_vector.c */ - 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); /* for s7_free */ +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); } -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); - } - if (hook_has_functions (sc->exit_hook)) { - s7_pointer exit_code; - if (is_null (args)) exit_code= s7_make_integer (sc, EXIT_SUCCESS); - else { - s7_pointer obj= car (args); - if (obj == sc->F) exit_code= s7_make_integer (sc, EXIT_FAILURE); - else if ((obj == sc->T) || (!s7_is_integer (obj))) - exit_code= s7_make_integer (sc, EXIT_SUCCESS); - else exit_code= obj; - } - s7_apply_function (sc, sc->exit_hook, set_plist_1 (sc, exit_code)); - } - 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 ()); +/* -------------------------------- make-byte-vector -------------------------------- */ +#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) +/* g_make_byte_vector migrated to s7_liii_vector.c */ - if (is_null (args)) exit (EXIT_SUCCESS); /* allow atexit functions etc */ +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)) + type_error_nr(sc, sc->make_byte_vector_symbol, 2, wrap_integer(sc, init), an_unsigned_byte_string); { - 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)); + s7_pointer bvect = make_simple_byte_vector(sc, len); + if (len > 0) + local_memset((void *)(byte_vector_bytes(bvect)), init, len); + return(bvect); } -#if __TINYC__ - return (sc->F); /* never reached, but tcc complains */ -#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 let, const char* func, s7_pointer expr, - s7_pointer var) { - if (let_slots (let) != 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), - (is_not_slot_end (let_slots (let))) ? display (let_slots (let)) - : "no slots", - unbold_text); - if (sc->stop_at_error) abort (); - /* this usually signals a problem with enviroments (or arglists if - * optimize_lambda) */ - } -} +/* -------------------------------- vector? -------------------------------- */ +/* g_is_vector is now defined in s7_liii_vector.c */ -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)))); -} +/* -------------------------------- vector-rank -------------------------------- */ +s7_int s7_vector_rank(s7_pointer vec) {return((s7_int)(vector_rank(vec)));} -static void -check_u_1 (s7_scheme* sc, s7_pointer let, const char* func, s7_pointer expr, - s7_pointer var) { - if (next_slot (let_slots (let)) != 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 (let), - (is_not_slot_end (next_slot (let_slots (let)))) - ? display (next_slot (let_slots (let))) - : "no next slot", - unbold_text); - if (sc->stop_at_error) abort (); - } -} +/* g_vector_rank is now defined in s7_liii_vector.c */ -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))))); -} +/* -------------------------------- vector-dimension -------------------------------- */ +/* g_vector_dimension is now defined in s7_liii_vector.c */ -static void -check_v_1 (s7_scheme* sc, s7_pointer let, const char* func, s7_pointer expr, - s7_pointer var) { - if (next_slot (next_slot (let_slots (let))) != 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 (let), - (is_not_slot_end (next_slot (next_slot (let_slots (let))))) - ? display (next_slot (next_slot (let_slots (let)))) - : "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))))); -} +/* -------------------------------- vector-dimensions -------------------------------- */ +/* g_vector_dimensions is now defined in s7_liii_vector.c */ -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 let, const char* func, s7_pointer expr, - s7_pointer var) { - s7_pointer slot= s7_t_slot (sc, var); - if (lookup_slot_with_let (sc, var, let) != slot) { - fprintf (stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, - func, display (expr), display (var), display (let), - (is_not_slot_end (slot)) ? display (slot) : "undefined", - unbold_text); - if (sc->stop_at_error) abort (); - } -} +/* -------------------------------- vector-typer -------------------------------- */ +/* g_vector_typer, g_set_vector_typer migrated to s7_liii_vector.c */ + +s7_pointer s7i_set_vector_typer_1(s7_scheme *sc, s7_pointer args) +{ + s7_pointer vec = car(args), typer = cadr(args); -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))); + if (!is_any_vector(vec)) + 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->type_error_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 + { + s7_pointer typer_name; + if (!is_any_closure(typer)) + type_error_nr(sc, sc->vector_typer_symbol, 2, typer, wrap_string(sc, "a built-in procedure, a closure, #f or #t", 41)); + typer_name = find_typer(sc, typer); + if (!is_symbol(typer_name)) + error_nr(sc, sc->type_error_symbol, set_elist_2(sc, wrap_string(sc, "can't set! vector-typer to ~A because it has no name", 52), typer)); + } + 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); } -#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) +/* -------------------------------- multivector -------------------------------- */ +#define MULTIVECTOR_TOO_MANY_ELEMENTS -1 +#define MULTIVECTOR_NOT_ENOUGH_ELEMENTS -2 -/* 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)); -} -s7_pointer -fx_unsafe_s (s7_scheme* sc, s7_pointer arg) { - return (lookup_checked (sc, T_Sym (arg))); +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 -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)); +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); } -#define fx_c_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - return ( \ - fn_proc (arg) (sc, with_list_t1 (sc, Lookup (sc, cadr (arg), arg)))); \ - } +s7_pointer proper_list_reverse_in_place(s7_scheme *sc, s7_pointer list) +{ + return(reverse_in_place_unchecked(sc, sc->nil, list)); +} -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) */ +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)); +} -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) +/* g_multivector migrated to s7_liii_vector.c */ +s7_pointer s7i_multivector_1(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; -#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))); \ - } + /* (#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 + */ - 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))); \ - } + 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))); - 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))); \ - } + 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)))); - 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); - default: - return (method_or_bust_pp (sc, val, sc->num_eq_symbol, val, cadr (args), - a_number_string, 1)); + 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); } - 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))); +/* g_int_multivector migrated to s7_liii_vector.c */ +s7_pointer s7i_int_multivector_1(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])) + type_error_nr(sc, wrap_string(sc, "#i(...)", 7), i + 1, src[i], sc->type_names[T_INTEGER]); + sc->args = s7i_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))); } -#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)); \ - } +/* g_byte_multivector migrated to s7_liii_vector.c */ +s7_pointer s7i_byte_multivector_1(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])) + type_error_nr(sc, wrap_string(sc, "#u8(...)", 8), i + 1, src[i], wrap_string(sc, "a byte", 6)); + sc->args = s7i_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))); +} - 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) { - return (make_integer (sc, (s7_int) (integer (cadr (arg)) * - next_random (sc->default_random_state)))); -} - -static s7_pointer -fx_random_i_wrapped (s7_scheme* sc, s7_pointer arg) { - return (wrap_integer (sc, (s7_int) (integer (cadr (arg)) * - next_random (sc->default_random_state)))); -} - -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! */ -} - -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)); -} -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 ((is_t_integer (x))) return (make_integer (sc, integer (x) + 1)); \ - return (g_add_x1_1 (sc, x, 1)); /* arg=(+ x 1) */ \ - } +/* g_float_multivector migrated to s7_liii_vector.c */ +s7_pointer s7i_float_multivector_1(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])) + type_error_nr(sc, wrap_string(sc, "#r(...)", 7), i + 1, src[i], sc->type_names[T_REAL]); + sc->args = s7i_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))); +} -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) { \ - const s7_pointer x= Lookup (sc, cadr (arg), arg); \ - if ((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) */ \ - } +/* g_complex_multivector migrated to s7_liii_vector.c */ +s7_pointer s7i_complex_multivector_1(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])) + type_error_nr(sc, wrap_string(sc, "#c(...)", 7), i + 1, src[i], sc->type_names[T_COMPLEX]); + sc->args = s7i_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))); +} - 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 ((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 - */ +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; -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) { \ - const s7_pointer x= Lookup (sc, cadr (arg), arg); \ - if ((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) */ \ - } + if (is_t_vector(old_vec)) + { + const s7_pointer *src = (const s7_pointer *)vector_elements(old_vec); + 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) */ + { + s7_pointer *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 = s7i_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 = s7i_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 = s7i_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 = s7i_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); +} - 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) */ \ - } +s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vec) {return(s7_vector_copy_1(sc, old_vec));} /* repeated for Vectorized */ - fx_subtract_sf_any (fx_subtract_sf, s_lookup) - fx_subtract_sf_any (fx_subtract_tf, t_lookup) +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; -#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))); \ - } + if (type(vec) != typ) + return(vector_method_or_bust(sc, vec, caller, args, sc->type_names[typ], 1)); - 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) { - const s7_double n= real (cadr (arg)); - const 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))); - default: - return (method_or_bust_pp (sc, x, sc->subtract_symbol, cadr (arg), x, - a_number_string, 2)); - } - return (x); + if (vector_rank(vec) == 1) + { + index = cadr(args); + if (!s7_is_integer(index)) + return(vector_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(vector_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))); } -#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)))); \ - } +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; - 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))))); \ - } + if (type(vec) != typ) + return(vector_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)); -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))))); \ - } + 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(vector_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(vector_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(vector_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(vector_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(vector_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(vector_method_or_bust(sc, val, caller, args, sc->type_names[T_COMPLEX], 3)); + complex_vector(vec, ind) = s7_to_c_complex(val); + } + return(val); +} - 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))))); \ - } +/* -------------------------------- complex-vector-ref -------------------------------- */ +#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) +s7_pointer s7i_univect_ref_complex(s7_scheme *sc, s7_pointer args) +{ + return(univect_ref(sc, args, sc->complex_vector_ref_symbol, T_COMPLEX_VECTOR)); +} +/* g_complex_vector_ref migrated to s7_liii_vector.c */ - 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))))); \ +static s7_pointer complex_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) +{ + if (!is_complex_vector(vec)) + return(vector_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(vector_method_or_bust_pp(sc, index, sc->complex_vector_ref_symbol, vec, index, sc->type_names[T_INTEGER], 2)); + { + s7_int 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))); } +} - 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) +s7_pointer s7i_complex_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) {return(complex_vector_ref_p_pp(sc, vec, index));} -#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))))); \ - } +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))); +} - 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) +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))); +} -#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))))); \ - } +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)));} - 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))))); \ - } +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); +} - 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))))); +/* -------------------------------- complex-vector-set! -------------------------------- */ +#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) +s7_pointer s7i_univect_set_complex(s7_scheme *sc, s7_pointer args) +{ + return(univect_set(sc, args, sc->complex_vector_set_symbol, T_COMPLEX_VECTOR)); } +/* g_complex_vector_set migrated to s7_liii_vector.c */ + -static s7_pointer -fx_floor_sqrt_s (s7_scheme* sc, s7_pointer arg) { - s7_pointer p= lookup (sc, opt3_sym (arg)); - if (!negative_b_7p (sc, p)) - return (make_integer ( - sc, (s7_int) floor (sqrt ( - s7_number_to_real_with_location (sc, p, sc->sqrt_symbol))))); - return (floor_p_p (sc, sqrt_p_p (sc, p))); +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 -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, positive_b_7p (sc, num))); +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 -fx_is_zero_u (s7_scheme* sc, s7_pointer arg) { - return (make_boolean (sc, zero_b_7p (sc, u_lookup (sc, cadr (arg), arg)))); +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); } -#define fx_real_part_s_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer x= Lookup (sc, cadr (arg), arg); \ - return ((is_t_complex (x)) ? make_real (sc, real_part (x)) \ - : real_part_p_p (sc, x)); \ +static s7_pointer complex_vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer index, s7_pointer value) +{ + if (!is_complex_vector(vec)) + return(vector_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(vector_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(vector_method_or_bust_ppp(sc, value, sc->complex_vector_set_symbol, vec, index, value, sc->type_names[T_COMPLEX], 3)); + { + s7_int 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); +} -fx_real_part_s_any (fx_real_part_s, s_lookup) - fx_real_part_s_any (fx_real_part_t, t_lookup) +s7_pointer s7i_complex_vector_set_p_ppp(s7_scheme *sc, s7_pointer vec, s7_pointer index, s7_pointer value) {return(complex_vector_set_p_ppp(sc, vec, index, value));} -#define fx_imag_part_s_any(Name, Lookup) \ - static s7_pointer Name (s7_scheme* sc, s7_pointer arg) { \ - s7_pointer x= Lookup (sc, cadr (arg), arg); \ - return ((is_t_complex (x)) ? make_real (sc, imag_part (x)) \ - : imag_part_p_p (sc, x)); \ - } +/* 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)));} */ - 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 */ +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); +} -#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); +/* -------------------------------- float-vector-ref -------------------------------- */ +#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) +s7_pointer s7i_univect_ref_float(s7_scheme *sc, s7_pointer args) +{ + return(univect_ref(sc, args, sc->float_vector_ref_symbol, T_FLOAT_VECTOR)); } +/* g_float_vector_ref, g_fv_ref_3 migrated to s7_liii_vector.c */ -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)))); -} -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); -} -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 inline s7_pointer float_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) +{ + if (!is_float_vector(vec)) + return(vector_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(vector_method_or_bust_pp(sc, index, sc->float_vector_ref_symbol, vec, index, sc->type_names[T_INTEGER], 2)); + { + s7_int 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 -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); + +s7_pointer s7i_float_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) {return(float_vector_ref_p_pp(sc, vec, index));} + +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 -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 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 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 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_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_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 -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 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)); } -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); + + +/* -------------------------------- float-vector-set! -------------------------------- */ +#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) +s7_pointer s7i_univect_set_float(s7_scheme *sc, s7_pointer args) +{ + return(univect_set(sc, args, sc->float_vector_set_symbol, T_FLOAT_VECTOR)); } -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); +/* g_float_vector_set, g_fv_set_3 migrated to s7_liii_vector.c */ + +static s7_pointer float_vector_set_chooser(s7_scheme *sc, s7_pointer func, int32_t args, s7_pointer unused_expr) +{ + return((args == 3) ? sc->fv_set_3 : func); } -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); + +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); } -#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)); \ - } +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);} -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)); \ - } +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); +} -fx_char_eq_sc_any (fx_char_eq_sc, s_lookup) - fx_char_eq_sc_any (fx_char_eq_tc, t_lookup) +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); +} -#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)); \ - } +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)) + 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 -------------------------------- */ +#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) +s7_pointer s7i_univect_ref_int(s7_scheme *sc, s7_pointer args) +{ + return(univect_ref(sc, args, sc->int_vector_ref_symbol, T_INT_VECTOR)); +} +/* g_int_vector_ref, g_iv_ref_3 migrated to s7_liii_vector.c */ - 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_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_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_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_pointer -fx_cons_cs (s7_scheme* sc, s7_pointer arg) { - return (cons (sc, opt1_con (cdr (arg)), lookup (sc, caddr (arg)))); +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_pointer -fx_cons_ct (s7_scheme* sc, s7_pointer arg) { - return (cons (sc, opt1_con (cdr (arg)), t_lookup (sc, caddr (arg), arg))); + +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)))); } -#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)); \ - } +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(vector_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(vector_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))); +} -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 (s7i_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 (s7i_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 (s7i_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 (s7i_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 (s7i_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 (s7i_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))); \ - } +s7_pointer s7i_int_vector_ref_p_pp(s7_scheme *sc, s7_pointer vec, s7_pointer index) {return(int_vector_ref_p_pp(sc, vec, index));} -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))); - - 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); +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)); } -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 (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)); -} - -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) +/* -------------------------------- int-vector-set! -------------------------------- */ +#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) +s7_pointer s7i_univect_set_int(s7_scheme *sc, s7_pointer args) +{ + return(univect_set(sc, args, sc->int_vector_set_symbol, T_INT_VECTOR)); +} +/* g_int_vector_set, g_iv_set_3 migrated to s7_liii_vector.c */ + +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 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 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 -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 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_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))); + +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); } -#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) */ \ - } +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); +} -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 x1= lookup_global (sc, cadr (arg)); - const s7_pointer x2= lookup (sc, opt1_sym (cdr (arg))); /* caddr(arg) */ - const s7_pointer x3= - lookup_global (sc, opt2_sym (cdr (arg))); /* cadddr(arg) */ - if ((is_t_integer (x1)) && (is_t_integer (x2)) && (is_t_integer (x3))) - return (make_boolean ( - sc, ((integer (x1) < integer (x2)) && (integer (x2) < integer (x3))))); - if (!is_real (x3)) - wrong_type_error_nr ( - sc, sc->lt_symbol, 3, x3, - sc->type_names[T_REAL]); /* else (< 2 1 1+i) returns #f */ - return ( - make_boolean (sc, (lt_b_7pp (sc, x1, x2)) && (lt_b_7pp (sc, x2, x3)))); -} - -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) */ \ - } +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(vector_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(vector_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(vector_method_or_bust_ppp(sc, value, sc->int_vector_set_symbol, vec, index, value, sc->type_names[T_INTEGER], 3)); + if (S7_DEBUGGING) fprintf(stderr, "fell through %s[%d]\n", __func__, __LINE__); + } + 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); +} -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))); +/* -------------------------------- byte-vector-ref -------------------------------- */ +#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) +s7_pointer s7i_univect_ref_byte(s7_scheme *sc, s7_pointer args) +{ + return(univect_ref(sc, args, sc->byte_vector_ref_symbol, T_BYTE_VECTOR)); } +/* g_byte_vector_ref, g_bv_ref_2, g_bv_ref_3 migrated to s7_liii_vector.c */ -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_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_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_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 -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) */ +/* byte_vector_ref_p_pi_direct migrated to s7_liii_vector.c */ +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 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)); } -#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) +/* -------------------------------- byte-vector-set -------------------------------- */ +#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) +s7_pointer s7i_univect_set_byte(s7_scheme *sc, s7_pointer args) +{ + return(univect_set(sc, args, sc->byte_vector_set_symbol, T_BYTE_VECTOR)); +} +/* g_byte_vector_set, g_bv_set_3 migrated to s7_liii_vector.c */ - 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))); +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)) + type_error_nr(sc, sc->byte_vector_set_symbol, 1, vec, a_byte_vector_string); + if ((byte < 0) || (byte > 255)) + 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); } -#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))); \ - } +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); +} -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))))); \ - } +/* byte_vector_set_p_pip_direct migrated to s7_liii_vector.c */ - 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_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)) + 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 -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 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 s7_pointer -fx_cdr_let_ref_s (s7_scheme* sc, s7_pointer arg) { - s7_pointer sym; - s7_pointer let= s_lookup ( - sc, opt2_sym (arg), - arg); /* (var-ref local-var) -> local-var, opt_sym2(arg) == cadr(arg) */ - if (!is_pair (let)) - 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), let)); - let= cdr (let); - if (!is_let (let)) - wrong_type_error_nr (sc, sc->let_ref_symbol, 1, let, 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 (let); is_not_slot_end (slot); - slot = next_slot (slot)) - if (slot_symbol (slot) == sym) return (slot_value (slot)); - return (let_ref_p_pp (sc, let_outlet (let), 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 (sc, 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 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 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 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 s7_pointer -fx_vset_sts (s7_scheme* sc, s7_pointer arg) { - return (vector_set_p_ppp (sc, lookup (sc, cadr (arg)), - t_lookup (sc, opt1_sym (cdr (arg)), arg), - lookup (sc, opt2_sym (cdr (arg))))); +static 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)); } -#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))); \ - } +/* -------------------------------- sort! -------------------------------- */ +static int32_t dbl_less(const void *x1, const void *x2) +{ + if ((*((const s7_double *)x1)) < (*((const s7_double *)x2))) return(-1); + return(((*((const s7_double *)x1)) > (*((const s7_double *)x2))) ? 1 : 0); +} - 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)); \ - } +static int32_t int_less(const void *x1, const void *x2) +{ + if ((*((const s7_int *)x1)) < (*((const s7_int *)x2))) return(-1); + return(((*((const s7_int *)x1)) > (*((const s7_int *)x2))) ? 1 : 0); +} -fx_c_css_any (fx_c_css, s_lookup, s_lookup) - fx_c_css_any (fx_c_ctv, t_lookup, v_lookup) +static int32_t dbl_greater(const void *x1, const void *x2) {return(-dbl_less(x1, x2));} +static int32_t int_greater(const void *x1, const void *x2) {return(-int_less(x1, x2));} - 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 int32_t byte_less(const void *x1, const void *x2) +{ + if ((*((const uint8_t *)x1)) < (*((const uint8_t *)x2))) return(-1); + return(((*((const uint8_t *)x1)) > (*((const uint8_t *)x2))) ? 1 : 0); } -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)); +static int32_t byte_greater(const void *x1, const void *x2) {return(-byte_less(x1, x2));} + +static int32_t dbl_less_2(const void *x1, const void *x2) +{ + s7_double x = real(*((const s7_pointer *)x1)); + s7_double y = real(*((const s7_pointer *)x2)); + if (x < y) return(-1); + return((x > y) ? 1 : 0); } -#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)); \ - } +static int32_t int_less_2(const void *x1, const void *x2) +{ + s7_int i1 = integer(*((const s7_pointer *)x1)); + s7_int i2 = integer(*((const s7_pointer *)x2)); + if (i1 < i2) return(-1); + return((i1 > i2) ? 1 : 0); +} -fx_c_ssc_any (fx_c_ssc, s_lookup, s_lookup) - fx_c_ssc_any (fx_c_tuc, t_lookup, u_lookup) +static int32_t dbl_greater_2(const void *x1, const void *x2) {return(-dbl_less_2(x1, x2));} +static int32_t int_greater_2(const void *x1, const void *x2) {return(-int_less_2(x1, x2));} - static s7_pointer fx_c_opncq (s7_scheme* sc, s7_pointer arg) { - return (fn_proc (arg) (sc, with_list_t1 (sc, fn_call (sc, cadr (arg))))); +static int32_t str_less_2(const void *s1, const void *s2) +{ + s7_pointer str1 = (*((const s7_pointer *)s1)); + s7_pointer str2 = (*((const s7_pointer *)s2)); + return(scheme_strcmp(str1, str2)); } -#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 (sc, 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 int32_t str_greater_2(const void *s1, const void *s2) {return(-str_less_2(s1, s2));} - 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)))); +static int32_t chr_less_2(const void *p1, const void *p2) +{ + uint8_t c1 = character(*((const s7_pointer *)p1)); + uint8_t c2 = character(*((const s7_pointer *)p2)); + if (c1 < c2) return(-1); + return((c1 > c2) ? 1 : 0); } -#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)); \ - } +static int32_t chr_greater_2(const void *c1, const void *c2) {return(-chr_less_2(c1, c2));} -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) +#if MS_WINDOWS || defined(__APPLE__) || defined(__FreeBSD__) +struct sort_r_data {void *arg; int32_t (*compar)(const void *a1, const void *a2, void *aarg);}; -#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)); \ - } +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 +} - fx_c_cdr_s_any (fx_c_cdr_s, s_lookup) - fx_c_cdr_s_any (fx_c_cdr_t, t_lookup) +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); +} -#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)))); \ - } +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); +} - 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); \ - } +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); +} -fx_not_opsq_any (fx_not_opsq, s_lookup) fx_not_opsq_any (fx_not_optq, t_lookup) +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 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); +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); } -#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 (sc, fn_proc (cadr (arg)) (sc, sc->t2_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); +} -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) +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((q_temp(sc->opts[0]).fp(sc->opts[0]) == sc->F) ? 1 : -1); +} -#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)))); \ - } +#define sort_o1 1 +#define q_sort(o, i) o->v[sort_o1 + i] +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 = q_sort(top, i).o1; + q_call(o).fp(o); + } + o = q_sort(top, i).o1; + if (int_expr) + return((q_call(o).fb(o)) ? -1 : 1); + return((q_call(o).fp(o) != sc->F) ? -1 : 1); +} - 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) +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));} -#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); \ - } +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 = q_sort(top, 0).o1; + q_call(o).fp(o); + o = q_sort(top, 1).o1; + return((q_call(o).fb(o)) ? -1 : 1); +} - 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, 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 x= o_lookup (sc, opt3_sym (arg), arg); - s7_pointer y= s_lookup (sc, opt1_sym (cdr (arg)), arg); - if ((is_t_integer (x)) && (is_t_integer (y))) - return ( - make_boolean (sc, remainder_i_7ii (sc, integer (x), integer (y)) == 0)); - return (make_boolean (sc, zero_b_7p (sc, remainder_p_pp (sc, x, y)))); -} - -#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 (sc, fn_proc (arg1) (sc, sc->t2_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); +} -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, 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 (sc, 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)); - } +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 - return (make_integer (sc, (integer (a) * integer (b)) + integer (c))); +static bool cell_optimize(s7_scheme *sc, s7_pointer expr); #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, - s7i_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)), - s7i_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)) == - s7i_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)), - s7i_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)), - s7i_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 (s7i_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 vec, s7_pointer num1, - s7_pointer num2) { - if ((is_t_integer (num1)) && (is_t_integer (num2)) && - ((is_t_vector (vec)) && (vector_rank (vec) == 1))) { - const s7_int index1= integer (num1), index2= integer (num2); - if ((index1 >= 0) && (index2 >= 0) && (index1 < vector_length (vec))) { - s7_pointer vec_in_vec= vector_element (vec, index1); - if ((is_t_vector (vec_in_vec)) && (vector_rank (vec_in_vec) == 1) && - (index2 < vector_length (vec_in_vec))) - return (vector_element (vec_in_vec, index2)); - } - } - return (s7i_vector_ref_p_pp (sc, s7i_vector_ref_p_pp (sc, vec, 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))); \ - } +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) -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)); \ - } + const s7_pointer data = car(args); + s7_pointer lessp = cadr(args); + int32_t (*sort_func)(const void *v1, const void *v2, void *arg); -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 ( \ - sc, 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)); \ - } + /* 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 */ + 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)); + if (is_let(data)) + if_method_exists_return_value(sc, data, sc->sort_symbol, args); + + if (type(lessp) <= T_GOTO) + 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); + if ((is_any_macro(lessp)) && (!is_c_macro(lessp))) + clear_all_optimizations(sc, closure_body(lessp)); + sort_func = NULL; + sc->sort_f = NULL; -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))); \ - } + 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); - 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) + 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_let = sc->curlet; + const s7_pointer lessp_body = closure_body(lessp); + 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(lessp_body))) + { + if (!no_bool_opt(lessp_body)) + { + s7_pfunc sf1 = s7_bool_optimize(sc, lessp_body); + if (sf1) + { + if (q_call(sc->opts[0]).fb == p_to_b) + sort_func = opt_bool_sort_p; + else + { + sc->sort_o = sc->opts[0]; + sc->sort_fb = q_call(sc->sort_o).fb; + sort_func = (sc->pc == 1) ? opt_bool_sort_0 : opt_bool_sort; + }} + else set_no_bool_opt(lessp_body); + }} + else + { + sc->sort_body_len = s7_list_length(sc, lessp_body); + 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 = 0, p = lessp_body; is_pair(cdr(p)); ctr++, p = cdr(p)) + { + q_sort(top, ctr).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + break; + } + if (is_null(cdr(p))) + { + int32_t start = sc->pc; + q_sort(top, 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_let); + } + 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)); + }}}} -#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))); \ - } + { + s7_int len = 0; + 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; - 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 (sc, 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)); \ - } + 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; -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 (sc, 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)); \ - } + default: + return(method_or_bust(sc, data, sc->sort_symbol, args, wrap_string(sc, "a sortable sequence", 19), 1)); + } + { + s7_int n = len - 1; + s7_int k = (n / 2) + 1; + s7_pointer 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. + */ +} - fx_c_opsq_c_any (fx_c_opsq_c, s_lookup) - fx_c_opsq_c_any (fx_c_optq_c, t_lookup) +/* 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); + const s7_int len = vector_length(vect); + s7_int i = 0; + 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 - 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 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 -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 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); } -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 (sc, 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)))); \ - } +#define sort_n(Sc) integer(vector_element(Sc->code, 0)) +#define sort_k(Sc) integer(vector_element(Sc->code, 1)) +#define sort_j(Sc) integer(vector_element(Sc->code, 2)) +#define sort_k1(Sc) integer(vector_element(Sc->code, 3)) +#define sort_calls(Sc) integer(vector_element(Sc->code, 4)) +#define sort_stop(Sc) integer(vector_element(Sc->code, 5)) +#define sort_data(Sc, K) vector_element(car(Sc->args), K) +#define sort_lessp(Sc) cadr(Sc->args) -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 (s7i_vector_ref_p_pp ( - sc, lookup_global (sc, cadr (arg)), - s7i_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 (s7i_vector_ref_p_pp ( - sc, lookup_global (sc, cadr (arg)), - s7i_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 (sc, 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)); \ - } +static s7_pointer op_heapsort(s7_scheme *sc) +{ + s7_int n = sort_n(sc), j, k = sort_k1(sc); + 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(sc)++; + if (sort_calls(sc) > sort_stop(sc)) + 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(sc))); + } + j = 2 * k; + sort_j(sc) = j; + if (j < n) + { + const s7_pointer lx = sort_lessp(sc); /* cadr of sc->args */ + push_stack_direct(sc, OP_SORT1); + if (needs_copied_args(lx)) + sc->args = list_2(sc, sort_data(sc, j), sort_data(sc, j + 1)); + else sc->args = with_list_t2(sc, sort_data(sc, j), sort_data(sc, j + 1)); + sc->code = lx; + sc->value = sc->T; /* for eval */ + } + else sc->value = sc->F; + return(NULL); +} -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 ind= lookup (sc, opt3_sym (arg)); - s7_pointer vec= lookup (sc, cadr (arg)); - if ((is_t_integer (ind)) && (is_t_vector (vec)) && (vector_rank (vec) == 1)) { - s7_int index= integer (ind) + 1; - if ((index >= 0) && (vector_length (vec) > index)) - return (vector_element (vec, index)); - } - return (s7i_vector_ref_p_pp (sc, vec, g_add_xi (sc, ind, 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))))); \ - } +static void op_sort1(s7_scheme *sc) +{ + s7_int j = sort_j(sc), k = sort_k1(sc); + s7_pointer lx = sort_lessp(sc); + if (is_true(sc, sc->value)) + { + j = j + 1; + sort_j(sc) = j; + } + push_stack_direct(sc, OP_SORT2); + if (needs_copied_args(lx)) + sc->args = list_2(sc, sort_data(sc, k), sort_data(sc, j)); + else sc->args = with_list_t2(sc, sort_data(sc, k), sort_data(sc, j)); + sc->code = lx; +} -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 bool op_sort2(s7_scheme *sc) +{ + s7_int j = sort_j(sc), k = sort_k1(sc); + if (j == k) return(true); + if (is_true(sc, sc->value)) + { + s7_pointer lx = sort_data(sc, j); + sort_data(sc, j) = sort_data(sc, k); + sort_data(sc, k) = lx; + } + else return(true); + sort_k1(sc) = sort_j(sc); + return(false); +} - 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 (sc, lookup (sc, cadr (arg2))))); - set_car (sc->t2_1, lookup (sc, cadr (arg))); - return (fn_proc (arg) (sc, sc->t2_1)); +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(sc); + if (k > 0) + { + sort_k(sc) = k - 1; + sort_k1(sc) = k - 1; + push_stack_direct(sc, OP_SORT); + return(false); + } + return(true); } -#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 */ \ - } +static bool op_sort3(s7_scheme *sc) +{ + s7_int n = sort_n(sc); + s7_pointer lx; + if (n <= 0) + { + sc->value = car(sc->args); + return(true); + } + lx = sort_data(sc, 0); + sort_data(sc, 0) = sort_data(sc, n); + sort_data(sc, n) = lx; + sort_n(sc) = n - 1; + sort_k1(sc) = 0; + push_stack_direct(sc, OP_SORT3); + return(false); +} -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)); \ - } +/* -------- hash tables -------- */ - 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 (sc, lookup (sc, cadr (args))))); - set_car (sc->t2_1, lookup (sc, cadr (outer))); - return ( - fn_proc (arg) (sc, with_list_t1 (sc, 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 (sc, 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 (sc, lookup (sc, cadr (args))))); - set_car (sc->t2_2, lookup (sc, caddr (outer))); - return ( - fn_proc (arg) (sc, with_list_t1 (sc, 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 (sc, 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 (sc, 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)))))); +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)); } -/* perhaps fx_c_c_opt|T|Vq_direct tlet/tmisc */ +static hash_entry_t *make_hash_entry(s7_scheme *sc, s7_pointer key, s7_pointer value, s7_int raw_hash) +{ + hash_entry_t *entry = (hash_entry_t *)mallocate_block(sc); +#if S7_DEBUGGING + sc->blocks_mallocated[BLOCK_LIST]++; +#endif + hash_entry_key(entry) = key; + hash_entry_set_value(entry, value); + hash_entry_set_raw_hash(entry, raw_hash); + return(entry); +} -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 (sc, lookup (sc, cadar (argp))))); - argp= cadr (argp); - set_car (sc->t2_2, - fn_proc (argp) (sc, with_list_t1 (sc, 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 (sc, 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 (sc, 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) /* (- (* x1 x2) (* x3 x4)) */ -{ - s7_pointer p1= opt3_pair (arg); /* cdaddr(arg) */ - s7_pointer x1= lookup (sc, car (p1)); - s7_pointer x2= lookup (sc, cadr (p1)); - s7_pointer p2= opt1_pair (cdr (arg)); - /* cdadr(arg) */ /* here and elsewhere this should be GC safe -- opssq->* - (no methods?) etc */ - s7_pointer x3= lookup (sc, car (p2)); - s7_pointer x4= lookup (sc, cadr (p2)); - if ((is_t_real (x1)) && (is_t_real (x2)) && (is_t_real (x3)) && - (is_t_real (x4))) - return (make_real (sc, (real (x3) * real (x4)) - (real (x1) * real (x2)))); - sc->temp5= multiply_p_pp_wrapped (sc, x1, x2); - return (subtract_p_pp (sc, multiply_p_pp_wrapped (sc, x3, x4), sc->temp5)); -} - -static s7_pointer -fx_add_mul_mul (s7_scheme* sc, s7_pointer arg) /* (+ (* x1 x2) (* x3 x4)) */ -{ - s7_pointer p1= opt3_pair (arg); /* cdaddr(arg) */ - s7_pointer x1= lookup (sc, car (p1)); - s7_pointer x2= lookup (sc, cadr (p1)); - s7_pointer p2= opt1_pair (cdr (arg)); /* cdadr(arg) */ - s7_pointer x3= lookup (sc, car (p2)); - s7_pointer x4= lookup (sc, cadr (p2)); - if ((is_t_real (x1)) && (is_t_real (x2)) && (is_t_real (x3)) && - (is_t_real (x4))) - return (make_real (sc, (real (x3) * real (x4)) + (real (x1) * real (x2)))); - sc->temp5= multiply_p_pp_wrapped (sc, x1, x2); - return (add_p_pp (sc, multiply_p_pp_wrapped (sc, x3, x4), sc->temp5)); -} - -static s7_pointer -fx_mul_sub_sub (s7_scheme* sc, s7_pointer arg) /* (* (- x1 x2) (- x3 x4)) */ -{ - s7_pointer p1= opt3_pair (arg); /* cdaddr(arg) */ - s7_pointer x1= lookup (sc, car (p1)); - s7_pointer x2= lookup (sc, cadr (p1)); - s7_pointer p2= opt1_pair (cdr (arg)); /* cdadr(arg) */ - s7_pointer x3= lookup (sc, car (p2)); - s7_pointer x4= lookup (sc, cadr (p2)); - if ((is_t_real (x1)) && (is_t_real (x2)) && (is_t_real (x3)) && - (is_t_real (x4))) - return (make_real (sc, (real (x3) - real (x4)) * (real (x1) - real (x2)))); - sc->temp5= subtract_p_pp_wrapped (sc, x1, x2); - return (multiply_p_pp (sc, subtract_p_pp_wrapped (sc, x3, x4), sc->temp5)); -} - -static s7_pointer -fx_lt_sub2 (s7_scheme* sc, s7_pointer arg) { - s7_pointer p1= opt3_pair (arg); /* cdaddr(arg) */ - sc->temp5= - subtract_p_pp_wrapped (sc, lookup (sc, car (p1)), lookup (sc, cadr (p1))); - p1= opt1_pair (cdr (arg)); /* cdadr(arg) */ - return (lt_p_pp ( - sc, - subtract_p_pp_wrapped (sc, lookup (sc, car (p1)), lookup (sc, cadr (p1))), - 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, s7i_vector_ref_p_pp (sc, vec, num1), - s7i_vector_ref_p_pp (sc, vec, num2))); -} +/* -------------------------------- hash-table? -------------------------------- */ +bool s7_is_hash_table(s7_pointer p) {return(is_hash_table(p));} -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 (sc, 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)); -} +/* g_is_hash_table is now defined in s7_liii_hash_table.c */ -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 (sc, lookup (sc, opt3_sym (cdr (code)))))); - return ((fn_proc (cadr (code)) (sc, sc->t1_1) == sc->F) ? sc->T : sc->F); -} +s7_int s7i_hash_table_entries(s7_pointer table) {return(hash_table_entries(table));} -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)))))))); +s7_pointer s7i_hash_table_key_typer(s7_scheme *sc, s7_pointer table) +{ + if (is_typed_hash_table(table)) return(hash_table_key_typer(table)); + return(sc->F); } -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 */ -s7_pointer -fx_c_a (s7_scheme* sc, s7_pointer arg) { - return (fn_proc (arg) (sc, with_list_t1 (sc, 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); +s7_pointer s7i_hash_table_value_typer(s7_scheme *sc, s7_pointer table) +{ + if (is_typed_hash_table(table)) return(hash_table_value_typer(table)); + return(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)); \ - } +/* -------------------------------- hash-table-entries -------------------------------- */ +#define H_hash_table_size "(hash-table-size obj) returns the number of entries in the hash-table obj" +#define Q_hash_table_size s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_hash_table_symbol) +/* g_hash_table_size and hash_table_size_i_7p are now defined in s7_liii_hash_table.c */ -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) +/* -------------------------------- hash-table-key|value-typer -------------------------------- */ +#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) +/* g_hash_table_key_typer is now defined in s7_liii_hash_table.c */ - 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))))); -} +#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) +/* g_hash_table_value_typer is now defined in s7_liii_hash_table.c */ -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)); +bool s7i_is_weak_hash_table(s7_pointer p) +{ + return(is_weak_hash_table(p)); } -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)); +void s7i_set_weak_hash_table(s7_pointer p) +{ + set_weak_hash_table(p); } -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)); +void s7i_set_weak_hash_table_iters(s7_pointer p, s7_int val) +{ + weak_hash_iters(p) = val; } -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 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 -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 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 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 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 + { + s7_pointer typer_name; + 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)); + typer_name = find_typer(sc, typer); + if (!is_symbol(typer_name)) + 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 -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 g_set_hash_table_key_typer(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer table = car(args), typer = cadr(args); -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); -} + 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)); -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)); + 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 -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 g_set_hash_table_value_typer(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer table = car(args), typer = cadr(args); -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)))); -} + 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)); -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)); + 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); } -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)))); -} +/* ---------------- hash map and equality tables ---------------- */ +/* built in hash loc tables for eq? eqv? equal? equivalent? = string=? char=? (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]; +/* also default_hash_map */ + + +/* ---------------- hash-code ---------------- */ +/* eqfunc handling which will require other dummy tables */ -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))))); +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); } -#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)); \ - } +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)); +} -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 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) +/* g_hash_code is now defined in s7_liii_hash_table.c */ -#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)))); \ - } +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); - fx_c_sa_direct_any (fx_c_sa_direct, s_lookup) - fx_c_sa_direct_any (fx_c_ua_direct, u_lookup) +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); - 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)); \ - } +/* ---------------- hash empty ---------------- */ +static hash_entry_t *hash_empty(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(sc->unentry);} -fx_c_as_any (fx_c_as, s_lookup) fx_c_as_any (fx_c_at, t_lookup) +/* ---------------- hash syntax ---------------- */ +static s7_uint hash_map_syntax(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(pointer_map(syntax_symbol(key)));} - 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 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); } -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)); +/* ---------------- 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); } -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)); + +/* ---------------- 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_pointer -fx_multiply_sa_wrapped (s7_scheme* sc, s7_pointer arg) /* experiment */ +static s7_uint hash_map_ratio(s7_scheme *sc, s7_pointer table, s7_pointer key) { - 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)); + /* 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_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 (sc, 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 ( - sc, 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 (sc, 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 (sc, 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 (sc, 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 (sc, 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_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 } - -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 (sc, 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 (sc, 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 (sc, lst); - return (result); -} - -static s7_pointer -fx_inlet_ca (s7_scheme* sc, s7_pointer code) { - s7_pointer new_let, last_slot= NULL; - s7_int id; - - new_cell (sc, new_let, T_LET | T_SAFE_PROCEDURE); - let_set_slots (new_let, slot_end); /* needed by add_slot_unchecked */ - let_set_outlet (new_let, sc->rootlet); - gc_protect_via_stack (sc, new_let); - - /* 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. + /* 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 */ - 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 (!last_slot) - last_slot= add_slot_unchecked_no_local_slot (sc, new_let, symbol, value); - else last_slot= add_slot_at_end_no_local (sc, last_slot, symbol, value); - } - id= ++sc->let_number; - let_set_id (new_let, id); - for (s7_pointer slot= let_slots (new_let); is_not_slot_end (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_let); -} - -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 (sc, 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_uint hash_map_real(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return(hash_float_location(real(key))); } -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_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_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_uint hash_map_complex(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return(hash_complex_location(real_part(key))); } -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 ...) */ +static hash_entry_t *find_number_in_bin(s7_scheme *sc, hash_entry_t *bin, s7_pointer key) { - return ((fx_call (sc, cdr (arg)) == sc->F) ? sc->F - : fx_call (sc, cddr (arg))); + 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 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 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 */ + 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); -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))))); + 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); } -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 hash_entry_t *hash_int(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + if (is_t_integer(key)) + { + const s7_uint hash_mask = hash_table_mask(table); + hash_entry_t *entry; + const s7_int kv = integer(key); + const s7_uint loc = s7_int_abs(kv) % hash_mask; + for (entry = hash_table_element(table, loc); entry; entry = hash_entry_next(entry)) + if (integer(hash_entry_key(entry)) == kv) + return(entry); + } + return(sc->unentry); } -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 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 (is_t_real(key)) + { + s7_double keyval; + s7_uint loc; + keyval = real(key); + if (is_NaN(keyval)) return(sc->unentry); + 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); + }} + return(sc->unentry); } -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 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 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 hash_entry_t *hash_real_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return((is_NaN(s7_real(key))) ? sc->unentry : hash_num_eq(sc, table, key)); } -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 (sc, 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 (sc, 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 (s7i_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 ((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 ((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 ( - s7i_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 (sc, 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))); +static hash_entry_t *hash_complex_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return(((is_NaN(real_part(key))) || (is_NaN(imag_part(key)))) ? sc->unentry : hash_num_eq(sc, table, key)); } -typedef bool (safe_sym_t) (s7_scheme* sc, s7_pointer sym, s7_pointer var_list); - -/* #define fx_choose(Sc, Holder, Var_List, Checker) fx_choose_1(Sc, Holder, - * Var_List, Checker, __func__, __LINE__) */ -static s7_function -fx_choose (s7_scheme* sc, const s7_pointer holder, const s7_pointer var_list, - safe_sym_t* checker) /* , const char *func, int32_t line) */ +static hash_entry_t *hash_number_num_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) { - const s7_pointer arg= car (holder); -#if S7_DEBUGGING - if ((!is_let (var_list)) && (!is_list (var_list))) - fprintf (stderr, "%s[%d]: var_list: %s\n", __func__, __LINE__, - display (var_list)); -#endif - 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 (var_list)) { - if (s7_symbol_local_value (sc, arg, var_list) == sc->else_symbol) - return (fx_c); - } - else if ((is_pair (var_list)) && (!direct_memq (arg, var_list))) - return (fx_c); /* is_pair -> not () */ - } - return ((is_defined_global (arg)) - ? fx_g - : ((checker (sc, arg, var_list)) ? fx_s : fx_unsafe_s)); + if (is_number(key)) + { + const 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 + return((is_real(key)) ? hash_real_num_eq(sc, table, key) : hash_complex_num_eq(sc, table, key)); } - 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 (fn_proc (arg) == g_add_i_random) return (fx_add_i_random); - 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); + return(sc->unentry); +} - 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), 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_p_pp_function (global_value (head))); - return (fx_c_ss_direct); - } +/* ---------------- 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); } - /* fx_c_ss_direct via b_7pp is slower than fx_c_ss + g_<> */ - return (fx_c_ss); + return(sc->unentry); +} - 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_p_pp_function (global_value (head))); - set_opt3_direct (cdr (arg), - 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); +/* ---------------- 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)); +} - 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_p_ppp_function (global_value (head))); - return (fx_c_sss_direct); - } - return (fx_c_sss); +static hash_entry_t *hash_string(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + if (is_string(key)) + { + 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); - case HOP_SAFE_C_SSA: - if (is_global_and_has_func (head, s7_p_ppp_function)) { - set_opt2_direct (cdr (arg), s7_p_ppp_function (global_value (head))); - return (fx_c_ssa_direct); - } - return (fx_c_ssa); + 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 */ - case HOP_SAFE_C_SCS: - if (is_global_and_has_func (head, s7_p_ppp_function)) { - set_opt3_direct (cdr (arg), 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 (sc, cadr (arg))) || - (is_unquoted_pair (sc, caddr (arg))) || - (is_unquoted_pair (sc, 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 (sc, 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_p_pp_function (global_value (head))); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (car (s2)))); - if (opt3_direct (arg1p) == (s7_pointer) add_p_pp) - set_opt3_direct (arg1p, add_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) subtract_p_pp) - set_opt3_direct (arg1p, subtract_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) multiply_p_pp) - set_opt3_direct (arg1p, 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); + if (key_len <= 8) + { + for (hash_entry_t *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 (hash_entry_t *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); +} - 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_p_pp_function (global_value (head))); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (caar (arg1p)))); - if (opt3_direct (arg1p) == (s7_pointer) add_p_pp) - set_opt3_direct (arg1p, add_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) subtract_p_pp) - set_opt3_direct (arg1p, subtract_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) multiply_p_pp) - set_opt3_direct (arg1p, 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); +#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 - 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); +/* ---------------- hash eq? ---------------- */ +static s7_uint hash_map_nil(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(type(key));} - 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_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_p_pp_function (global_value (head))); - return (fx_c_sc_direct); - } - } - return (fx_c_sc); +static s7_uint hash_map_eq(s7_scheme *sc, s7_pointer table, s7_pointer key) {return(pointer_map(key));} - 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_p_pp_function (global_value (head))); - set_opt3_direct (arg1p, 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), 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_p_pp_function (global_value (head))); - set_opt3_direct (cdr (arg), - 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); +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); +} - 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); +/* ---------------- hash eqv? ---------------- */ +static hash_entry_t *hash_eqv(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + const s7_uint loc = hash_loc(sc, table, key) % hash_table_mask(table); + if (is_number(key)) + { + uint8_t key_type = type(key); + for (hash_entry_t *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); + } + else + for (hash_entry_t *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); +} - 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); +/* ---------------- 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)))); + }} + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + return(0); /* placate the compiler */ +} - 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); +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 */ +} - 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_p_pp_function (global_value (head))); - set_opt3_direct (arg1p, 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_p_pp_function (global_value (head))); - set_opt3_direct (arg1p, 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, add_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) subtract_p_pp) - set_opt3_direct (arg1p, subtract_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) multiply_p_pp) - set_opt3_direct (arg1p, 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); +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)); +} - 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_p_p_function (global_value (head))); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (caar (arg1p)))); - if (opt3_direct (arg1p) == (s7_pointer) add_p_pp) - set_opt3_direct (arg1p, add_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) subtract_p_pp) - set_opt3_direct (arg1p, subtract_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) multiply_p_pp) - set_opt3_direct (arg1p, 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_p_pp_function (global_value (head))); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (caaddr (arg)))); - if (opt3_direct (arg1p) == (s7_pointer) add_p_pp) - set_opt3_direct (arg1p, add_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) subtract_p_pp) - set_opt3_direct (arg1p, subtract_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) multiply_p_pp) - set_opt3_direct (arg1p, 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_p_pp_function (global_value (head))); - set_opt2_direct (arg1p, s7_p_p_function (global_value (car (arg1)))); - set_opt3_direct (arg1p, 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_p_pp_function (global_value (head))); - set_opt2_direct (arg1p, s7_p_p_function (global_value (car (arg1)))); - set_opt3_direct (arg1p, s7_p_pp_function (global_value (caadr (arg1)))); - if (opt3_direct (arg1p) == (s7_pointer) add_p_pp) - set_opt3_direct (arg1p, add_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) subtract_p_pp) - set_opt3_direct (arg1p, subtract_p_pp_wrapped); - else if (opt3_direct (arg1p) == (s7_pointer) multiply_p_pp) - set_opt3_direct (arg1p, multiply_p_pp_wrapped); - - return (fx_c_op_opssqq_s_direct); - } - } - return (fx_c_op_opssqq_s); +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); +} - 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_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); +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); +} - 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_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, 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_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); +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); +} - case HOP_SAFE_C_CA: - if ((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); +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 ((!is_any_c_function(f)) && (!is_any_closure(f))) + error_nr(sc, sc->wrong_type_arg_symbol, + set_elist_2(sc, wrap_string(sc, "hash-table map function is not a procedure: ~S", 46), f)); + gc_protect_via_stack(sc, f); + sc->value = s7_call(sc, f, set_plist_1(sc, key)); + unstack_gc_protect(sc); + 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; - case HOP_SAFE_C_SA: - if ((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_p_pp_function (global_value (head))); - return ((fn_proc (arg) == g_cons) ? fx_cons_sa : fx_c_sa_direct); + if ((key == sc->rootlet) || (!is_not_slot_end(let_slots(key)))) return(0); + for (slot = let_slots(key), slots = 0; is_not_slot_end(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++; } - return (fx_c_sa); + for (slot = let_slots(key); is_not_slot_end(slot); slot = next_slot(slot)) + clear_match_symbol(slot_symbol(slot)); - 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_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 */ + 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); +} - 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 (sc, car (arg))) { - check_quote (sc, arg); - return (fx_q); - } - return (NULL); +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); } -#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 +#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) { - set_fx_direct (p, f); - return (true); + 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); + } + return(sc->unentry); } -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 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); + } + return(sc->unentry); } -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)); +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); } - 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(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); + + 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); } - } - return (false); + return(sc->unentry); } -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_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) s7i_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), tree_set_memq_syms_direct); - else - set_opt3_direct (cdr (p), - 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_p_p_function (global_value (car (p)))); - set_opt3_direct (cdr (p), 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_p_pp_function (global_value (car (p)))); - set_opt3_direct (arg1p, 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_p_pp_function (global_value (car (p)))); - set_opt3_direct (arg1p, 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, memq_2_p_pp); - else set_opt3_direct (p, s7_p_pp_function (global_value (car (p)))); - set_opt3_direct (cdr (p), - 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_p_ii_function (global_value (car (p)))); - set_opt3_direct (cdr (p), - 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) 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_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_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_p_pp_function (global_value (car (p)))); - set_opt2_direct (arg1p, s7_p_p_function (global_value (car (arg1)))); - set_opt3_direct (arg1p, 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 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); } -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); +/* ---------------- 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(sc, key)))); } -/* 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); -} /* mus_srate, mus_float_equal_fudge_factor clm2xen.c */ -s7_d_t -s7_d_function (s7_pointer f) { - return ((s7_d_t) opt_func (f, o_d)); +static s7_uint hash_map_c_pointer(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return(pointer_map(c_pointer(key))); } -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)); +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 */ } -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)); +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))); } -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)); -} +static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key); -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)); +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); } -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)); -} +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 p = cdr(key); + s7_uint loc = 0; -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)); + 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(p)) + { + if (!is_sequence_or_iterator(car(p))) + loc += hash_loc(sc, table, car(p)) + 1; + else + if ((is_pair(car(p))) && + (!is_sequence_or_iterator(caar(p)))) + loc += hash_loc(sc, table, caar(p)) + 1; + } + else + if (!is_sequence_or_iterator(p)) /* include () */ + loc += hash_loc(sc, table, p); + return((loc << 3) + len_upto_100(key)); /* undefined sanitizer is unhappy here, hash_mask was not a solution */ } -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)); +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)); } -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)); +static hash_entry_t *hash_equal(s7_scheme *sc, s7_pointer table, s7_pointer key) +{ + return((*(equal_hash_checks[type(key)]))(sc, table, key)); } -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)); -} +/* ---------------- 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; -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)); + if (is_number(key)) + { + entry = hash_number_equivalent(sc, table, key); + if ((entry != sc->unentry) || (!is_nan_b_7p(sc, key))) + return(entry); + 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); +} + +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)); } -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)); +/* -------------------------------- make-hash-table -------------------------------- */ +s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size) +{ + /* 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++; + } + { + s7_pointer table; + block_t *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); } -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)); -} +s7_pointer s7i_make_hash_table_1(s7_scheme *sc, s7_pointer args, s7_pointer caller) +{ + #define H_make_hash_table "(s7-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; -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)); -} + 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 << 32))) /* s7test tests >= */ + out_of_range_error_nr(sc, caller, int_one, len, it_is_too_large_string); + if (size == 0) size = sc->default_hash_table_length; + + 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)); + } -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)); + /* 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 (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)); } -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)); -} +/* g_make_hash_table is now defined in s7_liii_hash_table.c */ -/* 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)); -} +/* -------------------------------- make-weak-hash-table -------------------------------- */ +#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)) +/* g_make_weak_hash_table is now defined in s7_liii_hash_table.c */ -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)); +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=?"); +#endif + if (hash_table_checker(table) == hash_char) return("char=?"); + if (hash_table_checker(table) == hash_number_num_eq) return("="); + return("#f"); } -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)); -} +/* -------------------------------- weak-hash-table? -------------------------------- */ +#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 +/* g_is_weak_hash_table is now defined in s7_liii_hash_table.c */ -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)); +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; + 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; + 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; + + 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 *new_block = (block_t *)callocate(sc, new_size * sizeof(hash_entry_t *)); + hash_entry_t **new_els = (hash_entry_t **)(block_data(new_block)); + 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 *next; + for (hash_entry_t *entry = old_els[i]; entry; entry = next) + { + s7_uint loc = hash_loc(sc, table, hash_entry_key(entry)); + hash_entry_set_raw_hash(entry, loc); + loc %= hash_mask; + next = 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, new_block); + 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))); } -/* 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)); -} +#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) +/* g_hash_table_ref is now defined in s7_liii_hash_table.c */ +/* g_hash_table_ref_2 is now defined in s7_liii_hash_table.c */ -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 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 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 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 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 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 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 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); } -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)); +/* -------------------------------- 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 -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 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 -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 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 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 s7_pointer hash_table_typer_symbol(s7_scheme *sc, s7_pointer typer) +{ + s7_pointer typer_name; + if (typer == sc->T) + return(sc->T); + if (is_c_function(typer)) + return(c_function_symbol(typer)); + typer_name = find_typer(sc, typer); + return((is_symbol(typer_name)) ? typer_name : sc->anon_symbol); } -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 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 */ + { + const 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_3(sc, wrap_string(sc, "hash-table-set! key ~$ is rejected by the hash-table's key-typer, ~A", 68), + key, wrap_string(sc, descr, safe_strlen(descr)))); + }}} + if (has_hash_value_type(table)) + { + const 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_3(sc, wrap_string(sc, "hash-table-set! value ~$ is rejected by the hash-table's value-typer, ~A", 72), + value, wrap_string(sc, descr, safe_strlen(descr)))); + }}} } -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 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) && + (!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_ci_string) ? sc->string_eq_symbol : + ((hash_table_checker(table) == hash_char) ? sc->char_eq_symbol : sc->string_eq_symbol)))); +#endif } -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)); -} +s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) +{ + hash_entry_t *entry; -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)); -} + 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); -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)); -} + 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); + { + s7_uint hash_mask, loc; + 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); +} + +#define H_hash_table_set "(s7-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) +/* g_hash_table_set is now defined in s7_liii_hash_table.c */ -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 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(table) 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 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 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))) + { + const 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)) + { + const 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; -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)); -} + 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 */ -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)); -} + 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); -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)); + 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); +} + +s7_pointer s7i_hash_table_add(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value) +{ + return(hash_table_add(sc, table, key, value)); } -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)); +s7_pointer s7i_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 = cdr_unchecked(cdr(y))) + if (car(y) != missing_key_value(sc)) + hash_table_add(sc, table, car(x), car(y)); + return(table); + } } -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)); -} +#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) +/* g_hash_table is now defined in s7_liii_hash_table.c */ +/* g_hash_table_2 is now defined in s7_liii_hash_table.c */ -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)); -} +/* -------------------------------- weak-hash-table -------------------------------- */ +#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 +/* g_weak_hash_table is now defined in s7_liii_hash_table.c */ -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 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 -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 check_old_table(s7_scheme *sc, s7_pointer old_table, s7_pointer new_table, s7_int start, s7_int end) +{ + 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, count = 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 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 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; -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)); -} + if (is_typed_hash_table(new_table)) + check_old_table(sc, old_table, new_table, start, end); -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)); -} + old_lists = hash_table_elements(old_table); + new_lists = hash_table_elements(new_table); -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)); -} + 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)); -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)); + 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 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 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); -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)); -} + /* 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)); -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); + 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); } -static s7_p_dd_t -s7_p_dd_function (s7_pointer f) { - return ((s7_p_dd_t) opt_func (f, o_p_dd)); + + +/* -------------------------------- 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 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++]; - q_temp (o).fd= NULL; /* see bool_optimize -- this is a kludge */ +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 - for (int i= 0; i < num_vunions; i++) - o->v[i].p= NULL; + sc->c_functions_allocated++; /* this probably is the same as sc->f_class (c_function_class) */ #endif - 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); + return(&(sc->alloc_function_cells[sc->alloc_function_k++])); } -#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)); +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 - fprintf (stderr, " %s%s[%d]%s: %s\n", (ok) ? blue_text : "", func, line, - (ok) ? uncolor_text : "", (ok) ? "true" : "false"); - return (ok); + { + 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); } -#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); +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(func); + return(func); } -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); +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); } -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); +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); } -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); +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); } -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) { - opt_info* o= sc->opts[0]; - return ((q_call (o).fb (o)) ? sc->T : sc->F); -} -static s7_pointer -opt_float_any_nv (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - q_call (o).fd (o); - return (NULL); -} -static s7_pointer -opt_int_any_nv (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - q_call (o).fi (o); - return (NULL); -} -static s7_pointer -opt_bool_any_nv (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - q_call (o).fb (o); - return (NULL); -} -static s7_pointer -opt_cell_any_nv (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - return (q_call (o).fp (o)); -} /* this is faster than returning null */ - -static s7_pointer -opt_make_float (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - return (make_real (sc, q_call (o).fd (o))); -} -static s7_pointer -opt_make_int (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - return (make_integer (sc, q_call (o).fi (o))); -} -static s7_pointer -opt_wrap_cell (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - return (q_call (o).fp (o)); -} -static s7_pointer -opt_wrap_bool (s7_scheme* sc) { - opt_info* o= sc->opts[0]; - return ((q_call (o).fb (o)) ? sc->T : sc->F); -} - -static bool -p_to_b (opt_info* o) { - return (q_temp (o).fp (o) != o->sc->F); -} -static s7_pointer -d_to_p (opt_info* o) { - return (make_real (o->sc, q_temp (o).fd (o))); -} -static s7_pointer -d_to_p_nr (opt_info* o) { - q_temp (o).fd (o); - return (NULL); -} -static s7_pointer -i_to_p (opt_info* o) { - return (make_integer (o->sc, q_temp (o).fi (o))); -} -static s7_pointer -i_to_p_nr (opt_info* o) { - q_temp (o).fi (o); - return (NULL); -} - -#define q_arg1(o) o->v[1] -#define q_arg2(o) o->v[2] -#define q_arg3(o) o->v[12] -#define q_arg4(o) o->v[13] -#define q_arg5(o) o->v[14] /* 14 shared with q_temp, q_sort maybe others */ -#define q_func(o) o->v[3] -#define q_func1(o) o->v[5] -#define q_func1_arg(o) o->v[4] -#define q_func2(o) o->v[11] -#define q_func2_arg(o) o->v[10] -#define q_func3(o) o->v[9] -#define q_func3_arg(o) o->v[8] -#define q_func4(o) o->v[7] -#define q_func4_arg(o) o->v[6] -#define q_i_func1_call(o) q_func1 (o).fi (q_func1_arg (o).o1) -#define q_d_func1_call(o) q_func1 (o).fd (q_func1_arg (o).o1) -#define q_b_func1_call(o) q_func1 (o).fb (q_func1_arg (o).o1) -#define q_p_func1_call(o) q_func1 (o).fp (q_func1_arg (o).o1) +/* -------------------------------- procedure? -------------------------------- */ +bool s7_is_procedure(s7_pointer obj) {return(is_procedure(obj));} -#define q_i_func2_call(o) q_func2 (o).fi (q_func2_arg (o).o1) -#define q_d_func2_call(o) q_func2 (o).fd (q_func2_arg (o).o1) -#define q_b_func2_call(o) q_func2 (o).fb (q_func2_arg (o).o1) -#define q_p_func2_call(o) q_func2 (o).fp (q_func2_arg (o).o1) +/* g_is_procedure is now defined in s7_scheme_predicate.c */ +#define H_is_procedure "(procedure? obj) returns #t if obj is a procedure" +#define Q_is_procedure sc->pl_bt -#define q_i_func3_call(o) q_func3 (o).fi (q_func3_arg (o).o1) -#define q_d_func3_call(o) q_func3 (o).fd (q_func3_arg (o).o1) -#define q_b_func3_call(o) q_func3 (o).fb (q_func3_arg (o).o1) /* none?? */ -#define q_p_func3_call(o) q_func3 (o).fp (q_func3_arg (o).o1) +#if !DISABLE_DEPRECATED +s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer clo) {return((has_closure_let(clo)) ? closure_body(clo) : sc->nil);} +s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer clo) {return((has_closure_let(clo)) ? closure_let(clo) : sc->rootlet);} +s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer clo) {return((has_closure_let(clo)) ? closure_pars(clo) : sc->nil);} +#endif +s7_pointer s7_lambda_body(s7_scheme *sc, s7_pointer clo) {return((has_closure_let(clo)) ? closure_body(clo) : sc->nil);} +s7_pointer s7_lambda_let(s7_scheme *sc, s7_pointer clo) {return((has_closure_let(clo)) ? closure_let(clo) : sc->rootlet);} +s7_pointer s7_lambda_parameters(s7_scheme *sc, s7_pointer clo) {return((has_closure_let(clo)) ? closure_pars(clo) : sc->nil);} -#define q_i_func4_call(o) q_func4 (o).fi (q_func4_arg (o).o1) -#define q_d_func4_call(o) q_func4 (o).fd (q_func4_arg (o).o1) -#define q_b_func4_call(o) q_func4 (o).fb (q_func4_arg (o).o1) /* none?? */ -#define q_p_func4_call(o) q_func4 (o).fp (q_func4_arg (o).o1) -/* TODO: also q_func(o).call -> q_func_call(o) */ +/* -------------------------------- 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 */ +} -/* -------------------------------- int opts -------------------------------- */ -static s7_int -opt_i_c (opt_info* o) { - return (q_arg1 (o).i); -} -static s7_int -opt_i_s (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p))); +/* -------------------------------- 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 bool -opt_int_not_pair (s7_scheme* sc, s7_pointer expr) { - opt_info* opc; - if (is_t_integer (expr)) { - opc = alloc_opt_info (sc); - q_arg1 (opc).i = integer (expr); - q_call (opc).fi= opt_i_c; - return_true (sc, expr); - } - { - s7_pointer slot= opt_integer_symbol (sc, expr); - if (!slot) return_false (sc, expr); - opc = alloc_opt_info (sc); - q_arg1 (opc).p = slot; - q_call (opc).fi= opt_i_s; - } - return_true (sc, expr); -} +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); -/* -------- i_i|d|p -------- */ + 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); -static s7_int -opt_i_i_c (opt_info* o) { - return (q_func (o).i_i_f (q_arg1 (o).i)); -} -static s7_int -opt_i_i_s (opt_info* o) { - return (q_func (o).i_i_f (integer (slot_value (q_arg1 (o).p)))); -} -static s7_int -opt_i_7i_c (opt_info* o) { - return (q_func (o).i_7i_f (o->sc, q_arg1 (o).i)); -} -static s7_int -opt_i_7i_s (opt_info* o) { - return (q_func (o).i_7i_f (o->sc, integer (slot_value (q_arg1 (o).p)))); -} -static s7_int -opt_i_7i_s_rand (opt_info* o) { - return (random_i_7i (o->sc, integer (slot_value (q_arg1 (o).p)))); -} -static s7_int -opt_i_d_c (opt_info* o) { - return (q_func (o).i_7d_f (o->sc, q_arg1 (o).x)); -} -static s7_int -opt_i_d_s (opt_info* o) { - return (q_func (o).i_7d_f (o->sc, real (slot_value (q_arg1 (o).p)))); -} - -static s7_int -opt_i_i_f (opt_info* o) { - return (q_func (o).i_i_f (q_i_func1_call (o))); -} -static s7_int -opt_i_7i_f (opt_info* o) { - return (q_func (o).i_7i_f (o->sc, q_i_func1_call (o))); -} -static s7_int -opt_i_7d_f (opt_info* o) { - return (q_func (o).i_7d_f (o->sc, q_d_func1_call (o))); -} -static s7_int -opt_i_7p_f (opt_info* o) { - return (q_func (o).i_7p_f (o->sc, q_p_func1_call (o))); -} -static s7_int -opt_i_7p_f_cint (opt_info* o) { - return (char_to_integer_i_7p (o->sc, q_p_func1_call (o))); -} /* from opt_set_p_i_f */ - -static s7_int -opt_i_i_s_abs (opt_info* o) { - return (abs_i_i (integer (slot_value (q_arg1 (o).p)))); -} -static s7_int -opt_i_i_f_abs (opt_info* o) { - return (abs_i_i (q_i_func1_call (o))); -} - -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_pointer arg1_slot; - const s7_pointer arg1 = cadr (expr); - const int32_t start= sc->pc; - q_func1_arg (opc).o1 = sc->opts[start]; - if (!func) func7= s7_i_7i_function (s_func); - if ((func) || (func7)) { - if (func) q_func (opc).i_i_f= func; - else q_func (opc).i_7i_f= func7; - if (is_t_integer (arg1)) { - if (q_func (opc).i_i_f == subtract_i_i) { - q_arg1 (opc).i = -integer (arg1); - q_call (opc).fi= opt_i_c; - } - else { - q_arg1 (opc).i = integer (arg1); - q_call (opc).fi= (func) ? opt_i_i_c : opt_i_7i_c; - } - return_true (sc, expr); - } - arg1_slot= opt_integer_symbol (sc, arg1); - if (arg1_slot) { - q_arg1 (opc).p= arg1_slot; - q_call (opc).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))) { - q_func1 (opc).fi= q_call (sc->opts[start]).fi; - q_call (opc).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) { - q_func (opc).i_7d_f= idf; - if (is_small_real (arg1)) { - q_arg1 (opc).x = s7_number_to_real (sc, arg1); - q_call (opc).fi= opt_i_d_c; - return_true (sc, expr); - } - arg1_slot= opt_float_symbol (sc, arg1); - if (arg1_slot) { - q_arg1 (opc).p = arg1_slot; - q_call (opc).fi= opt_i_d_s; - return_true (sc, expr); - } - if (float_optimize (sc, cdr (expr))) { - q_call (opc).fi = opt_i_7d_f; - q_func1 (opc).fd= q_call (sc->opts[start]).fd; - return_true (sc, expr); - } - sc->pc= start; - } - } - { - s7_i_7p_t ipf= s7_i_7p_function (s_func); - if (ipf) { - q_func (opc).i_7p_f= ipf; - if (cell_optimize (sc, cdr (expr))) { - q_call (opc).fi= - (ipf == char_to_integer_i_7p) ? opt_i_7p_f_cint : opt_i_7p_f; - q_func1 (opc).fp= q_call (sc->opts[start]).fp; - return_true (sc, expr); - } - sc->pc= start; + 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)); } - } - return_false (sc, expr); + 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? */ } -/* -------- i_pi -------- */ -static s7_int -opt_i_7pi_ss (opt_info* o) { - return (q_func (o).i_7pi_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_pi_ss_ivref (opt_info* o) { - return (int_vector (slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_pi_ss_bvref (opt_info* o) { - return (byte_vector (slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_7pi_sf (opt_info* o) { - return (q_func (o).i_7pi_f (o->sc, slot_value (q_arg1 (o).p), - q_i_func2_call (o))); -} +/* -------------------------------- *current-function* -------------------------------- */ +static s7_pointer let_to_function(s7_scheme *sc, s7_pointer let) +{ + if ((!let) || (let == sc->rootlet) || (!is_let(let))) + return(sc->F); + if (!((is_funclet(let)) || (is_maclet(let)))) + return(sc->F); + if ((has_let_file(let)) && + (let_file(let) <= (s7_int)sc->file_names_top) && + (let_line(let) > 0)) + return(list_3(sc, funclet_function(let), sc->file_names[let_file(let)], make_integer(sc, let_line(let)))); + return(funclet_function(let)); +} + +static s7_pointer g_function(s7_scheme *sc, s7_pointer args) /* does the env parameter make any sense? */ +{ + #define H_function "(*function* let field) returns the current function. (*function*) is like __func__ in C. \ +If 'let 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)" -/* how can i_7pi_ss be hit? */ + #define Q_function s7_make_signature(sc, 3, sc->T, has_let_signature(sc), sc->is_symbol_symbol) -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)) { - const 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); - } - } + s7_pointer let, sym = NULL; + if (is_null(args)) /* (*function*) is akin to __func__ in C */ + { + for (let = sc->curlet; let; let = let_outlet(let)) + if ((is_funclet(let)) || (is_maclet(let))) + break; + return(let_to_function(sc, let)); } - 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 arg2_slot; - q_arg1 (opc).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); - - q_func (opc).i_7pi_f= pfunc; - arg2_slot = opt_integer_symbol (sc, arg2); - if (arg2_slot) { - q_arg2 (opc).p = arg2_slot; - q_call (opc).fi= opt_i_7pi_ss; - if ((s_func == global_value (sc->int_vector_ref_symbol)) && - (loop_end_fits (q_arg2 (opc).p, - vector_length (slot_value (q_arg1 (opc).p))))) { - q_call (opc).fi = opt_i_pi_ss_ivref; - q_func (opc).i_7pi_f= int_vector_ref_i_pi_direct; - } - else if ((s_func == global_value (sc->byte_vector_ref_symbol)) && - (loop_end_fits (q_arg2 (opc).p, vector_length (slot_value ( - q_arg1 (opc).p))))) { - q_call (opc).fi = opt_i_pi_ss_bvref; - q_func (opc).i_7pi_f= byte_vector_ref_i_7pi_direct; - } - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_call (opc).fi = opt_i_7pi_sf; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; /* q_call(o1)? */ - return_true (sc, expr); - } - sc->pc= start; + let = car(args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); /* ?? not sure this makes sense */ + if (!is_let(new_let)) + find_let_error_nr(sc, sc->_function__symbol, let, new_let, 1, args); + let = 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 (let == sc->rootlet) + return(sc->F); + if (!((is_funclet(let)) || (is_maclet(let)))) + let = let_outlet(let); + if (is_null(cdr(args))) + return(let_to_function(sc, let)); + if ((let == sc->rootlet) || (!is_let(let))) + return(sc->F); + if (!((is_funclet(let)) || (is_maclet(let)))) + return(sc->F); + + if (is_keyword(sym)) + sym = keyword_symbol(sym); + { + s7_pointer fname = funclet_function(let); + s7_pointer fval = s7_symbol_local_value(sc, fname, let); + + 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(let))) return(make_integer(sc, let_line(let))); + if ((sym == sc->file_symbol) && (has_let_file(let))) return(sc->file_names[let_file(let)]); + if (sym == make_symbol(sc, "funclet", 7)) return(let); + 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_false (sc, expr); + return(sc->F); } -/* -------- i_ii -------- */ -static s7_int -opt_i_ii_cc (opt_info* o) { - return (q_func (o).i_ii_f (q_arg1 (o).i, q_arg2 (o).i)); -} -static s7_int -opt_i_ii_cs (opt_info* o) { - return ( - q_func (o).i_ii_f (q_arg1 (o).i, integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_ii_cs_mul (opt_info* o) { - return (q_arg1 (o).i * integer (slot_value (q_arg2 (o).p))); -} -static s7_int -opt_i_ii_sc (opt_info* o) { - return ( - q_func (o).i_ii_f (integer (slot_value (q_arg1 (o).p)), q_arg2 (o).i)); -} -static s7_int -opt_i_ii_sc_add (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) + q_arg2 (o).i); -} /* +1 is not faster */ -static s7_int -opt_i_ii_sc_sub (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) - q_arg2 (o).i); -} /* -1 is not faster */ -static s7_int -opt_i_ii_ss (opt_info* o) { - return (q_func (o).i_ii_f (integer (slot_value (q_arg1 (o).p)), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_ii_ss_add (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) + - integer (slot_value (q_arg2 (o).p))); -} -static s7_pointer -opt_p_ii_ss_add (opt_info* o) { - return (make_integer (o->sc, integer (slot_value (q_arg1 (o).p)) + - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_ii_cf (opt_info* o) { - return (q_func (o).i_ii_f (q_arg1 (o).i, q_i_func2_call (o))); -} -static s7_int -opt_i_ii_cf_mul (opt_info* o) { - return (q_arg1 (o).i * q_i_func2_call (o)); -} -static s7_int -opt_i_ii_sf (opt_info* o) { - return (q_func (o).i_ii_f (integer (slot_value (q_arg1 (o).p)), - q_i_func2_call (o))); -} -static s7_int -opt_i_ii_sf_add (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) + q_i_func2_call (o)); -} -static s7_int -opt_i_ii_fc (opt_info* o) { - return (q_func (o).i_ii_f (q_i_func1_call (o), q_arg2 (o).i)); -} -static s7_int -opt_i_ii_fc_add (opt_info* o) { - return (q_i_func1_call (o) + q_arg2 (o).i); -} -static s7_int -opt_i_ii_fc_mul (opt_info* o) { - return (q_i_func1_call (o) * q_arg2 (o).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. +/* -------------------------------- 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)?? */ + +/* g_funclet moved to s7_scheme_let.c */ + #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_define_function and friends -------------------------------- + * + * all c_func* are semipermanent, but they might be local: (let () (load "libm.scm" (curlet)) ...) */ -static s7_int -opt_i_ii_ff (opt_info* o) { - return (q_func (o).i_ii_f (q_i_func1_call (o), q_i_func2_call (o))); -} -static s7_int -opt_i_7ii_ff_quo (opt_info* o) { - return (quotient_i_7ii (o->sc, q_i_func1_call (o), q_i_func2_call (o))); -} -static s7_int -opt_i_7ii_fc (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, q_i_func1_call (o), q_arg2 (o).i)); -} - -static s7_int -opt_i_ii_fco (opt_info* o) { - return (q_func (o).i_ii_f ( - q_func1 (o).i_7pi_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p))), - q_arg3 (o).i)); -} - -static s7_int -opt_i_ii_fco_ivref_add (opt_info* o) { - return (int_vector_ref_i_pi_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p))) + - q_arg3 (o).i); -} /* tref */ - -static s7_int -opt_i_7ii_fco (opt_info* o) { - return (q_func (o).i_7ii_f ( - o->sc, - q_func1 (o).i_7pi_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p))), - q_arg3 (o).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 ((q_call (o1).fi == opt_i_7pi_ss) || - (q_call (o1).fi == opt_i_pi_ss_ivref)) { - q_arg3 (opc).i = q_arg2 (opc).i; - q_func1 (opc).i_7pi_f= q_func (o1).i_7pi_f; - q_arg1 (opc).p = q_arg1 (o1).p; - q_arg2 (opc).p = q_arg2 (o1).p; - if (func) - q_call (opc).fi= ((q_func (opc).i_ii_f == add_i_ii) && - (q_func1 (opc).i_7pi_f == int_vector_ref_i_pi_direct)) - ? opt_i_ii_fco_ivref_add - : opt_i_ii_fco; - else q_call (opc).fi= opt_i_7ii_fco; - backup_pc (sc); - return_true (sc, NULL); - } - } - return_false (sc, NULL); +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); } -static s7_int -opt_i_7ii_cc (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, q_arg1 (o).i, q_arg2 (o).i)); -} -static s7_int -opt_i_7ii_cs (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, q_arg1 (o).i, - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_7ii_sc (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, integer (slot_value (q_arg1 (o).p)), - q_arg2 (o).i)); -} -static s7_int -opt_i_7ii_ss (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, integer (slot_value (q_arg1 (o).p)), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_int -opt_i_7ii_cf (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, q_arg1 (o).i, q_i_func2_call (o))); +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); } -static s7_int -opt_i_7ii_sf (opt_info* o) { - return (q_func (o).i_7ii_f (o->sc, integer (slot_value (q_arg1 (o).p)), - q_i_func2_call (o))); + +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_int -opt_i_7ii_ff (opt_info* o) { - s7_int i1= q_i_func1_call (o); - s7_int i2= q_i_func2_call (o); - return (q_func (o).i_7ii_f (o->sc, i1, i2)); +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) +{ + 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); + { + s7_pointer bfunc = s7_make_safe_function(sc, name, bool_setter, 2, 0, false, NULL); + c_function_set_bool_setter(func, bfunc); + c_function_set_has_bool_setter(func); + c_function_set_setter(bfunc, func); + set_is_bool_function(bfunc); + } + return(sym); } -static s7_int -opt_add_i_random_i (opt_info* o) { - return (q_arg1 (o).i + - (s7_int) (q_arg2 (o).i * next_random (o->sc->default_random_state))); +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); } -static s7_int -opt_subtract_random_i_i (opt_info* o) { - return ((s7_int) (q_arg1 (o).i * next_random (o->sc->default_random_state)) - - q_arg2 (o).i); + +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); } -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; +s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fnc, const char *arglist, const char *doc) +{ + const s7_int len = safe_strlen(arglist); + s7_pointer local_args; + s7_int gc_loc, n_args; + { + block_t *b = inline_mallocate(sc, len + 4); + char *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; + } + { + const s7_pointer 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 (!ifunc) { - ifunc7= s7_i_7ii_function (s_func); - if (!ifunc7) return_false (sc, expr); + 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_par_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); } - 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 arg1_slot, arg2_slot; - if (ifunc) q_func (opc).i_ii_f= ifunc; - else q_func (opc).i_7ii_f= ifunc7; - - if (is_t_integer (arg1)) { - q_arg1 (opc).i= integer (arg1); - if (is_t_integer (arg2)) { - if (q_func (opc).i_ii_f == add_i_ii) { - q_arg1 (opc).i= - integer (arg1) + - integer (arg2); /* no overflow check for sc_add case above */ - q_call (opc).fi= opt_i_c; - } - else { - q_arg2 (opc).i = integer (arg2); - q_call (opc).fi= (ifunc) ? opt_i_ii_cc : opt_i_7ii_cc; - } - return_true (sc, expr); - } - arg2_slot= opt_integer_symbol (sc, arg2); - if (arg2_slot) { - q_arg2 (opc).p= arg2_slot; - if (ifunc) - q_call (opc).fi= (q_func (opc).i_ii_f == multiply_i_ii) - ? opt_i_ii_cs_mul - : opt_i_ii_cs; - else q_call (opc).fi= opt_i_7ii_cs; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - if (ifunc) { - q_call (opc).fi= - opt_i_ii_cf; /* caller(sc->opts[start]).fi -> opt_i_7i_c -> - func(same_opt).i_7i_f = random_i_7i tmap */ - if ((ifunc == add_i_ii) && (opc == sc->opts[sc->pc - 2]) && - (q_call (sc->opts[start]).fi == opt_i_7i_c) && - (q_func (sc->opts[start]).i_7i_f == random_i_7i)) { - q_call (opc).fi= opt_add_i_random_i; - q_arg2 (opc).i = q_arg1 (sc->opts[start]).i; - backup_pc (sc); - } - else if (ifunc == multiply_i_ii) q_call (opc).fi= opt_i_ii_cf_mul; - } - else q_call (opc).fi= opt_i_7ii_cf; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); - } - - /* arg1 not integer */ - arg1_slot= opt_integer_symbol (sc, arg1); - if (arg1_slot) { - q_arg1 (opc).p= arg1_slot; - if (is_t_integer (arg2)) { - q_arg2 (opc).i= integer (arg2); - if (ifunc) { - if (q_func (opc).i_ii_f == add_i_ii) q_call (opc).fi= opt_i_ii_sc_add; - else - q_call (opc).fi= (q_func (opc).i_ii_f == subtract_i_ii) - ? opt_i_ii_sc_sub - : opt_i_ii_sc; /* add1/sub1 are not faster */ - } - else q_call (opc).fi= opt_i_7ii_sc; - if ((car (expr) == sc->modulo_symbol) && (integer (arg2) > 1)) - q_func (opc).i_ii_f= modulo_i_ii_unchecked; - else { - if (car (expr) == sc->ash_symbol) { - if (q_arg2 (opc).i < 0) { - q_func (opc).i_ii_f= - (q_arg2 (opc).i == -1) ? rsh_i_i2_direct : rsh_i_ii_unchecked; - q_call (opc).fi= opt_i_ii_sc; - } - else if (q_arg2 (opc).i < S7_INT_BITS) { - q_func (opc).i_ii_f= lsh_i_ii_unchecked; - q_call (opc).fi = opt_i_ii_sc; - } - } - else if (q_arg2 (opc).i > 0) { - /* these assume vunion is a union, not a struct; i_7ii_f otherwise - * might be leftover from a previous use */ - if (q_func (opc).i_7ii_f == quotient_i_7ii) { - q_func (opc).i_ii_f= quotient_i_ii_unchecked; - q_call (opc).fi = opt_i_ii_sc; - } - else if ((q_arg2 (opc).i > 1) && - (q_func (opc).i_7ii_f == remainder_i_7ii)) { - q_func (opc).i_ii_f= remainder_i_ii_unchecked; - q_call (opc).fi = opt_i_ii_sc; - } - } - } - return_true (sc, expr); - } +} - /* arg2 not integer, arg1 is int symbol */ - arg2_slot= opt_integer_symbol (sc, arg2); - if (arg2_slot) { - q_arg2 (opc).p= arg2_slot; - if (ifunc) - q_call (opc).fi= - (q_func (opc).i_ii_f == add_i_ii) ? opt_i_ii_ss_add : opt_i_ii_ss; - else q_call (opc).fi= opt_i_7ii_ss; - return_true (sc, expr); - } - if (int_optimize (sc, cddr (expr))) { - q_func2_arg (opc).o1= sc->opts[start]; - q_func2 (opc).fi = q_call (sc->opts[start]).fi; - if (ifunc) - q_call (opc).fi= - (q_func (opc).i_ii_f == add_i_ii) ? opt_i_ii_sf_add : opt_i_ii_sf; - else q_call (opc).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)) { - q_arg2 (opc).i = integer (arg2); - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func1 (opc).fi= q_func1_arg (opc).q_call (o1).fi; - if (!i_ii_fc_combinable (sc, opc, ifunc)) { - if (ifunc) { - if (q_func (opc).i_ii_f == add_i_ii) { - q_call (opc).fi= opt_i_ii_fc_add; - return_true (sc, expr); - } - if (q_func (opc).i_ii_f == multiply_i_ii) { - q_call (opc).fi= opt_i_ii_fc_mul; - return_true (sc, expr); - } - q_call (opc).fi= opt_i_ii_fc; - - if ((q_func (opc).i_ii_f == subtract_i_ii) && - (opc == sc->opts[sc->pc - 2]) && - (q_call (sc->opts[start]).fi == opt_i_7i_c) && - (q_func (sc->opts[start]).i_7i_f == random_i_7i)) { - q_call (opc).fi= opt_subtract_random_i_i; - q_arg1 (opc).i = q_arg1 (sc->opts[start]).i; - backup_pc (sc); - } - } - else q_call (opc).fi= opt_i_7ii_fc; - if (q_arg2 (opc).i > 0) { - if (q_func (opc).i_7ii_f == quotient_i_7ii) { - q_func (opc).i_ii_f= quotient_i_ii_unchecked; - q_call (opc).fi = opt_i_ii_fc; - } - else if ((q_arg2 (opc).i > 1) && - (q_func (opc).i_7ii_f == remainder_i_7ii)) { - q_func (opc).i_ii_f= remainder_i_ii_unchecked; - q_call (opc).fi = opt_i_ii_fc; - } - } - } - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); - } - - /* arg1 not integer or symbol, arg2 not integer */ - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func1 (opc).fi = q_func1_arg (opc).q_call (o1).fi; - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_call (opc).fi = (ifunc) ? opt_i_ii_ff - : ((q_func (opc).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); +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); } -/* -------- i_iii -------- */ +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); +} -static s7_int -opt_i_iii_fff (opt_info* o) { - s7_int i1= q_i_func1_call (o); - s7_int i2= q_i_func2_call (o); - s7_int i3= q_i_func3_call (o); - return (q_func (o).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); - q_func1_arg (opc).o1= sc->opts[start]; - if (int_optimize (sc, cdr (expr))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdddr (expr))) { - q_func (opc).i_iii_f= ifunc; - q_call (opc).fi = opt_i_iii_fff; - q_func1 (opc).fi = q_func1_arg (opc).q_call (o1).fi; - q_func2 (opc).fi = q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi = q_func3_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - } - } - sc->pc= start; - return_false (sc, expr); +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); } -/* -------- i_7pii -------- */ +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); +} -static s7_int -opt_i_7pii_ssf (opt_info* o) { - return (q_func (o).i_7pii_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_i_func1_call (o))); -} - -static s7_int -opt_i_7pii_ssf_vset (opt_info* o) { - return (int_vector_set_i_7pii_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_i_func1_call (o))); -} - -static s7_int -opt_i_7pii_ssc (opt_info* o) { - return (q_func (o).i_7pii_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_arg3 (o).i)); -} - -static s7_int -opt_i_7pii_sss (opt_info* o) { - return (q_func (o).i_7pii_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)))); -} - -static s7_int -opt_i_pii_sss_ivref_unchecked (opt_info* o) { - s7_pointer vec= slot_value (q_arg1 (o).p); - return (int_vector ( - vec, ((integer (slot_value (q_arg2 (o).p)) * vector_offset (vec, 0)) + - integer (slot_value (q_arg3 (o).p))))); -} - -static s7_int -opt_i_7pii_sif (opt_info* o) { - return (q_func (o).i_7pii_f (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).i, - q_i_func3_call (o))); -} - -static s7_int -opt_i_7pii_sff (opt_info* o) { - s7_int i1= q_i_func2_call (o); - s7_int i2= q_i_func3_call (o); - return (q_func (o).i_7pii_f (o->sc, slot_value (q_arg1 (o).p), i1, i2)); -} - -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 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); - -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, arg2_slot; - const int32_t start= sc->pc; - q_arg1 (opc).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); - arg2_slot= opt_integer_symbol (sc, arg2); - if (arg2_slot) { - s7_pointer arg3_slot; - q_arg2 (opc).p= arg2_slot; - arg3_slot = opt_integer_symbol (sc, cadddr (expr)); - if (arg3_slot) { - q_arg3 (opc).p = arg3_slot; - q_func (opc).i_7pii_f= pfunc; - q_call (opc).fi = opt_i_7pii_sss; - if ((pfunc == int_vector_ref_i_7pii) && - (loop_end_fits ( - q_arg2 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 0))) && - (loop_end_fits ( - q_arg3 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 1)))) - q_call (opc).fi= opt_i_pii_sss_ivref_unchecked; - return_true (sc, expr); - } - if (int_optimize (sc, cdddr (expr))) { - q_func (opc).i_7pii_f= pfunc; - q_call (opc).fi = opt_i_7pii_ssf; - q_func1_arg (opc).o1 = sc->opts[start]; - q_func1 (opc).fi = q_call (sc->opts[start]).fi; - return_true (sc, expr); - } - return_false (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdddr (expr))) { - q_func (opc).i_7pii_f= pfunc; - q_call (opc).fi = opt_i_7pii_sff; - q_func2 (opc).fi = q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi = q_func3_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - } - sc->pc= start; - } - } - return_false (sc, expr); +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); } -/* -------- i_7piii -------- */ -static s7_int -opt_i_7piii_sssf (opt_info* o) { - return (q_func (o).i_7piii_f ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), q_i_func3_call (o))); +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); } -static s7_int -opt_i_piii_sssf_ivset_unchecked (opt_info* o) { - s7_pointer vec = slot_value (q_arg1 (o).p); - s7_int val = q_i_func3_call (o); - int_vector (vec, - ((integer (slot_value (q_arg2 (o).p)) * vector_offset (vec, 0)) + - integer (slot_value (q_arg3 (o).p))))= val; - return (val); +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); } -static s7_int -opt_i_7piii_sssc (opt_info* o) { - return (q_func (o).i_7piii_f ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), q_arg4 (o).i)); -} -static s7_int -opt_i_7piii_ssss (opt_info* o) { - return (q_func (o).i_7piii_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), - integer (slot_value (q_arg4 (o).p)))); -} +/* -------------------------------- 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_int -opt_i_7piii_sfff (opt_info* o) { - s7_int i1= q_i_func2_call (o); - s7_int i2= q_i_func3_call (o); - s7_int i3= q_i_func4_call (o); - return (q_func (o).i_7piii_f (o->sc, slot_value (q_arg1 (o).p), i1, i2, i3)); -} +/* g_is_macro is now defined in s7_scheme_predicate.c */ + #define H_is_macro "(macro? arg) returns #t if 'arg' is a macro or a bacro" + #define Q_is_macro sc->pl_bt -static bool -opt_i_7piii_args (s7_scheme* sc, opt_info* opc, s7_pointer indexp1, - s7_pointer indexp2, s7_pointer valp) { - /* opc->[5] is the called function (int-vector-set! etc) */ - s7_pointer slot2= opt_integer_symbol (sc, car (indexp2)); - if (slot2) { - s7_pointer slot1; - q_arg3 (opc).p= slot2; - slot1 = opt_integer_symbol (sc, car (indexp1)); - if (slot1) { - s7_pointer slot3; - q_arg2 (opc).p= slot1; - if (is_t_integer (car (valp))) { - q_call (opc).fi= opt_i_7piii_sssc; - q_arg4 (opc).i = integer (car (valp)); - return_true (sc, NULL); - } - slot3= opt_integer_symbol (sc, car (valp)); - if (slot3) { - q_arg4 (opc).p = slot3; - q_call (opc).fi= opt_i_7piii_ssss; - return_true (sc, NULL); - } - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, valp)) { - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - q_call (opc).fi = opt_i_7piii_sssf; - if ((q_func (opc).i_7piii_f == int_vector_set_i_7piii) && - (loop_end_fits ( - q_arg2 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 0))) && - (loop_end_fits (q_arg3 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 1)))) - q_call (opc).fi= opt_i_piii_sssf_ivset_unchecked; - return_true (sc, NULL); - } +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) +{ + 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)); + { + s7_pointer 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)); } - return_false (sc, valp); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp1)) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp2)) { - q_func4_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, valp)) { - q_call (opc).fi = opt_i_7piii_sfff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - q_func4 (opc).fi= q_func4_arg (opc).q_call (o1).fi; - return_true (sc, NULL); - } + /* 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_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)))) { - const s7_pointer vect = slot_value (settee); - const bool int_case= (is_int_vector (vect)); - q_arg1 (opc).p = settee; /* either ipii or ipiii arg1 */ - 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)) /* q_ipii case */ + 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); +} + +/* g_help is now defined in s7_scheme_predicate.c */ + #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) + + +/* -------------------------------- 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 slot; - q_func (opc).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; - q_arg2 (opc).p = slot; - if (loop_end_fits (q_arg2 (opc).p, vector_length (vect))) - q_func (opc).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)))) { - q_arg3 (opc).i = integer (car (valp)); - q_call (opc).fi= opt_i_7pii_ssc; - return_true (sc, NULL); - } - if (!int_optimize (sc, valp)) return_false (sc, valp); - q_call (opc).fi= - (q_func (opc).i_7pii_f == int_vector_set_i_7pii_direct) - ? opt_i_7pii_ssf_vset - : opt_i_7pii_ssf; - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fi = q_call (sc->opts[start]).fi; - return_true (sc, NULL); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp1)) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, valp)) { - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - if (q_func2 (opc).fi == - opt_i_c) /* (int-vector-set! v 0 (floor (sqrt i))) */ - { - q_call (opc).fi= opt_i_7pii_sif; - q_arg2 (opc).i = q_func2_arg (opc).q_arg1 (o1).i; - } - else q_call (opc).fi= opt_i_7pii_sff; - return_true (sc, NULL); - } - } - return_false (sc, valp); + 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); } - if ((indexp2) && (vector_rank (vect) == 2)) /* q_ipiii case */ + + 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); { - q_func (opc).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 -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) && /* ipi case */ - (vector_rank (obj) == 1)) { - opt_info* opc = alloc_opt_info (sc); - q_arg1 (opc).p= s_slot; - slot = opt_integer_symbol (sc, cadr (expr)); - if (slot) { - q_call (opc).fi= opt_i_7pi_ss; - q_func (opc).i_7pi_f= - (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; - q_arg2 (opc).p= slot; - if (loop_end_fits (q_arg2 (opc).p, vector_length (obj))) - q_func (opc).i_7pi_f= (int_case) ? int_vector_ref_i_pi_direct - : byte_vector_ref_i_7pi_direct; - /* not q_call(opc).fi = opt_i_pi_ss_ivref -- this causes a huge slowdown - * in dup.scm?? */ - return_true (sc, expr); + 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); } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (!int_optimize (sc, cdr (expr))) return_false (sc, expr); - q_call (opc).fi= opt_i_7pi_sf; - q_func (opc).i_7pi_f= - (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - if ((len == 3) && /* ipii case */ - (vector_rank (obj) == 2)) { - opt_info* opc = alloc_opt_info (sc); - q_arg1 (opc).p= s_slot; - slot = opt_integer_symbol (sc, cadr (expr)); - if (slot) { - q_arg2 (opc).p= slot; - slot = opt_integer_symbol (sc, caddr (expr)); - if (!slot) return_false (sc, expr); - q_func (opc).i_7pii_f= - (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; - q_arg3 (opc).p = slot; - q_call (opc).fi= opt_i_7pii_sss; - if ((int_case) && - (loop_end_fits (q_arg2 (opc).p, vector_dimension (obj, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (obj, 1)))) - q_call (opc).fi= opt_i_pii_sss_ivref_unchecked; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func (opc).i_7pii_f= - (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; - q_call (opc).fi = opt_i_7pii_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - } - } - } - 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 func= s7_i_7piii_function (s_func); - if ((func) && (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)) { - q_func (opc).i_7piii_f= func; - q_arg1 (opc).p = settee; - return (opt_i_7piii_args (sc, opc, cddr (expr), cdddr (expr), - cddddr (expr))); - } - } - } - return_false (sc, expr); -} -/* -------- i_add|multiply_any -------- */ + 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); -#define q_i_am_args(o) o->v[1] -#define q_i_am_arg(o, i) o->v[i + 2] -#define q_i_am_func(o, i) \ - o->v[i + 6] /* the following are for the special cases (2-4 args), not \ - i_add_any_f */ -#define q_i_am_func1_arg(o) o->v[2] -#define q_i_am_func1(o) o->v[6] -#define q_i_am_func2_arg(o) o->v[3] -#define q_i_am_func2(o) o->v[7] -#define q_i_am_func3_arg(o) o->v[4] -#define q_i_am_func3(o) o->v[8] -#define q_i_am_func4_arg(o) o->v[5] -#define q_i_am_func4(o) o->v[9] - -#define q_i_am_func1_call(o) q_i_am_func1 (o).fi (q_i_am_func1_arg (o).o1) -#define q_i_am_func2_call(o) q_i_am_func2 (o).fi (q_i_am_func2_arg (o).o1) -#define q_i_am_func3_call(o) q_i_am_func3 (o).fi (q_i_am_func3_arg (o).o1) -#define q_i_am_func4_call(o) q_i_am_func4 (o).fi (q_i_am_func4_arg (o).o1) - -static s7_int -opt_i_add_any_f (opt_info* o) { - s7_int sum= 0; - for (s7_int i= 0; i < q_i_am_args (o).i; i++) { - opt_info* o1= q_i_am_arg (o, i).o1; -#if WITH_WARNINGS && HAVE_OVERFLOW_CHECKS - s7_int new_val, - val= q_call (o1).fi (o1); /* this is not worth all this bother */ - if (add_overflow (sum, val, &new_val)) { - s7_warn (o->sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", - sum, val); - return (sum); - } - sum= new_val; -#else - sum+= q_call (o1).fi (o1); -#endif - } - return (sum); -} + 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)); -static s7_int -opt_i_add2 (opt_info* o) { - s7_int sum= q_i_am_func1_call (o); - return (sum + q_i_am_func2_call (o)); -} + case T_C_OBJECT: + if_c_object_method_exists_return_value(sc, obj, sc->signature_symbol, args); + return(sc->c_object_signature); -static s7_int -opt_i_mul2 (opt_info* o) { - s7_int sum= q_i_am_func1_call (o); - return (sum * q_i_am_func2_call (o)); -} + case T_LET: + if_let_method_exists_return_value(sc, obj, sc->signature_symbol, args); + return(sc->let_signature); -static s7_int -opt_i_add3 (opt_info* o) { - s7_int sum= q_i_am_func1_call (o); - sum+= q_i_am_func2_call (o); - return (sum + q_i_am_func3_call (o)); -} + case T_SYMBOL: + /* this used to get the symbol's value and call g_signature on that */ + { + const 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; -static s7_int -opt_i_mul3 (opt_info* o) { - s7_int sum= q_i_am_func1_call (o); - sum*= q_i_am_func2_call (o); - return (sum * q_i_am_func3_call (o)); + default: break; + } + return(sc->F); } -static s7_int -opt_i_add4 (opt_info* o) { - s7_int sum= q_i_am_func1_call (o); - sum+= q_i_am_func2_call (o); - sum+= q_i_am_func3_call (o); - return (sum + q_i_am_func4_call (o)); +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(sc, caar(body))) ? sc->F : obj); } -static s7_int -opt_i_mul4 (opt_info* o) { - s7_int sum= q_i_am_func1_call (o); - sum*= q_i_am_func2_call (o); - sum*= q_i_am_func3_call (o); - return (sum * q_i_am_func4_call (o)); +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 s7_int -opt_i_mul_any_f (opt_info* o) { - s7_int sum= 1; - for (s7_int i= 0; i < q_i_am_args (o).i; i++) { - opt_info* o1= q_i_am_arg (o, i).o1; - sum*= q_call (o1).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 < (num_vunions - 2)); p= cdr (p), cur_len++) { - q_i_am_arg (opc, cur_len).o1= sc->opts[sc->pc]; - if (!int_optimize (sc, p)) break; - } - if (is_null (p)) { - q_i_am_args (opc).i= cur_len; - if (cur_len <= 4) - for (int32_t i= 0; i < cur_len; i++) - q_i_am_func (opc, i).fi= q_i_am_arg (opc, i).q_call (o1).fi; - if (cur_len == 2) - q_call (opc).fi= (head == sc->add_symbol) ? opt_i_add2 : opt_i_mul2; - else if (cur_len == 3) - q_call (opc).fi= (head == sc->add_symbol) ? opt_i_add3 : opt_i_mul3; - else if (cur_len == 4) - q_call (opc).fi= (head == sc->add_symbol) ? opt_i_add4 : opt_i_mul4; - else - q_call (opc).fi= - (head == sc->add_symbol) ? opt_i_add_any_f : opt_i_mul_any_f; - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); +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) */ } -/* -------- set_i_i -------- */ +static s7_pointer g_dynamic_wind_unchecked(s7_scheme *sc, s7_pointer args) +{ + s7_pointer dw, init_func, final_func; -static s7_int -opt_set_i_i_f (opt_info* o) { - s7_int x= q_func (o).fi (q_arg2 (o).o1); - slot_set_value (q_arg1 (o).p, make_integer (o->sc, x)); - return (x); + 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); } -#if S7_DEBUGGING -static void -check_mutability (s7_scheme* sc, opt_info* o, const char* func, int line) { - if (!is_mutable_number (slot_value (q_arg1 (o).p))) { - fprintf (stderr, "%s[%d]: %s value is not mutable", func, line, - display (q_arg1 (o).p)); - if (sc->stop_at_error) abort (); - } +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); } -#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 */ +static s7_pointer g_dynamic_wind(s7_scheme *sc, s7_pointer args) { - s7_int x= q_func (o).fi (q_arg2 (o).o1); - check_mutability (o->sc, o, __func__, __LINE__); - set_integer (slot_value (q_arg1 (o).p), x); - return (x); -} + #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)); -static s7_int -opt_set_i_i_fo (opt_info* o) { - s7_int x= integer (slot_value (q_arg3 (o).p)) + q_arg2 (o).i; - slot_set_value (q_arg1 (o).p, make_integer (o->sc, x)); - return (x); + /* 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 s7_int -opt_set_i_i_fom (opt_info* o) { - s7_int x= integer (slot_value (q_arg3 (o).p)) + q_arg2 (o).i; - check_mutability (o->sc, o, __func__, __LINE__); - set_integer (slot_value (q_arg1 (o).p), x); - return (x); +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 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 (q_call (o1).fi == opt_i_ii_sc_add) { - q_arg3 (opc).p = q_arg1 (o1).p; /* i_iii, arg1(o) set earlier */ - q_arg2 (opc).i = q_arg2 (o1).i; /* i_iii */ - q_call (opc).fi= opt_set_i_i_fo; - backup_pc (sc); - return_true (sc, NULL); +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_false (sc, NULL); + return(func); } -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 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) { - 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]; - q_arg1 (opc).p= settee; - if (int_optimize (sc, cddr (expr))) { - if (set_i_i_f_combinable (sc, opc)) return_true (sc, expr); - q_call (opc).fi= (is_mutable_integer (slot_value (q_arg1 (opc).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 */ - q_arg2 (opc).o1= o1; - q_func (opc).fi= q_call (o1).fi; - return_true (sc, expr); - } - } + if (jump_loc != error_jump) + eval(sc, sc->cur_op); } - 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))); + 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); } - } - return_false (sc, expr); + restore_jump_info(sc); + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return(sc->value); } -/* ------------------------------------- float opts - * ------------------------------------------- */ -static s7_double -opt_d_c (opt_info* o) { - return (q_arg1 (o).x); +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 s7_double -opt_d_s (opt_info* o) { - return (real (slot_value (q_arg1 (o).p))); + +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 s7_double -opt_D_s (opt_info* o) { - s7_pointer x= slot_value (q_arg1 (o).p); - return ((is_t_integer (x)) ? (s7_double) (integer (x)) - : s7_number_to_real (o->sc, x)); +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); } -static bool -opt_float_not_pair (s7_scheme* sc, s7_pointer expr) { - s7_pointer slot; - if (is_small_real (expr)) { - opt_info* opc = alloc_opt_info (sc); - q_arg1 (opc).x = s7_number_to_real (sc, expr); - q_call (opc).fd= opt_d_c; - return_true (sc, expr); - } - slot= opt_real_symbol (sc, expr); - if (slot) { - opt_info* opc = alloc_opt_info (sc); - q_arg1 (opc).p = slot; - q_call (opc).fd= (is_t_real (slot_value (slot))) ? opt_d_s : opt_D_s; - return_true (sc, expr); - } - return_false (sc, expr); + +/* -------------------------------- c-object? -------------------------------- */ +bool s7_is_c_object(s7_pointer p) {return(is_c_object(p));} + +/* g_is_c_object is now defined in s7_scheme_predicate.c */ + #define H_is_c_object "(c-object? obj) returns #t is obj is a c-object." + #define Q_is_c_object sc->pl_bt + +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 */ } -/* -------- d -------- */ -static s7_double -opt_d_f (opt_info* o) { - return (q_func (o).d_f ()); +static void fallback_free(void *value) {} +static void fallback_mark(void *value) {} + +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);} + +/* g_c_object_type is now defined in s7_scheme_predicate.c */ +#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_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); } -static bool -d_ok (s7_scheme* sc, opt_info* opc, - s7_pointer s_func) /* (f): (mus-srate), ignore damned ccpcheck! */ +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)) { - const s7_d_t func= s7_d_function (s_func); - if (!func) return_false (sc, NULL); - q_call (opc).fd = opt_d_f; - q_func (opc).d_f= func; - return_true (sc, NULL); + sc->c_object_types[tag]->length = (length) ? length : fallback_length; /* is_sequence(c_obj) is #t so we need a length method */ } -/* -------- d_d -------- */ +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; +} -static s7_double -opt_d_d_c (opt_info* o) { - return (q_func (o).d_d_f (q_arg1 (o).x)); -} -static s7_double -opt_d_d_s (opt_info* o) { - return (q_func (o).d_d_f (real (slot_value (q_arg1 (o).p)))); -} -static s7_double -opt_d_d_s_abs (opt_info* o) { - return (abs_d_d (real (slot_value (q_arg1 (o).p)))); -} -static s7_double -opt_d_7d_c (opt_info* o) { - return (q_func (o).d_7d_f (o->sc, q_arg1 (o).x)); -} -static s7_double -opt_d_7d_s (opt_info* o) { - return (q_func (o).d_7d_f (o->sc, real (slot_value (q_arg1 (o).p)))); -} - -static s7_double -opt_d_d_f (opt_info* o) { - return (q_func (o).d_d_f (q_d_func1_call (o))); -} -static s7_double -opt_d_d_f_abs (opt_info* o) { - return (abs_d_d (q_d_func1_call (o))); -} -static s7_double -opt_d_d_f_sin (opt_info* o) { - return (sin_d_d (q_d_func1_call (o))); -} -static s7_double -opt_d_d_f_cos (opt_info* o) { - return (cos_d_d (q_d_func1_call (o))); -} -static s7_double -opt_d_7d_f (opt_info* o) { - return (q_func (o).d_7d_f (o->sc, q_d_func1_call (o))); -} -static s7_double -opt_d_7d_f_divide (opt_info* o) { - return (divide_d_7d (o->sc, q_d_func1_call (o))); -} - -static s7_double opt_abs_d_ss_fvref (opt_info* o); -static s7_double opt_d_7pi_ss_fvref_direct (opt_info* o); - -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 arg1_slot; - const s7_pointer arg1= cadr (expr); - if (func) q_func (opc).d_d_f= func; - else q_func (opc).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); - q_arg1 (opc).x = s7_number_to_real (sc, arg1); - q_call (opc).fd= (func) ? opt_d_d_c : opt_d_7d_c; - return_true (sc, expr); - } - arg1_slot= opt_float_symbol (sc, arg1); - if ((arg1_slot) && (!has_methods (slot_value (arg1_slot)))) { - q_arg1 (opc).p= arg1_slot; - q_call (opc).fd= - (func) ? ((func == abs_d_d) ? opt_d_d_s_abs : opt_d_d_s) : opt_d_7d_s; - return_true (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdr (expr))) { - q_call (opc).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 (q_call(opc).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) */ - q_func1 (opc).fd= q_func1_arg (opc).q_call (o1).fd; - if ((func == abs_d_d) && (q_func1 (opc).fd == opt_d_7pi_ss_fvref_direct)) - q_call (opc).fd= opt_abs_d_ss_fvref; - return_true (sc, expr); - } - sc->pc= start; - } - return_false (sc, expr); +/* 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; } -/* -------- d_v -------- */ -static s7_double -opt_d_v (opt_info* o) { - return (q_func (o).d_v_f (q_arg1 (o).gen)); -} - -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) or (next-sample reader) */ - { - s7_pointer slot= opt_types_match (sc, cadr (sig), cadr (expr)); - if (slot) { - q_arg1 (opc).gen = (void*) c_object_value (slot_value (slot)); - q_func (opc).d_v_f= flt_func; - q_call (opc).fd = opt_d_v; - return_true (sc, expr); - } - } - return_false (sc, expr); +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; } -/* -------- d_p -------- */ -static s7_double -opt_d_p_s (opt_info* o) { - return (q_func (o).d_p_f (slot_value (q_arg1 (o).p))); +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; } -static s7_double -opt_d_p_f (opt_info* o) { - return (q_func (o).d_p_f (q_p_func1_call (o))); + +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); } -static s7_double -opt_d_7p_s (opt_info* o) { - return (q_func (o).d_7p_f (o->sc, slot_value (q_arg1 (o).p))); + +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; } -static s7_double -opt_d_7p_f (opt_info* o) { - return (q_func (o).d_7p_f (o->sc, q_p_func1_call (o))); + +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; } -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 like one_pole (none built-in in s7) */ - s7_d_7p_t d7pf; - if (!dpf) d7pf= s7_d_7p_function (s_func); - if ((!dpf) && (!d7pf)) return_false (sc, expr); - if (dpf) q_func (opc).d_p_f= dpf; - else q_func (opc).d_7p_f= d7pf; - if (is_symbol (cadr (expr))) { - s7_pointer slot= opt_simple_symbol (sc, cadr (expr)); - if (!slot) return_false (sc, expr); - q_arg1 (opc).p = slot; - q_call (opc).fd= (dpf) ? opt_d_p_s : opt_d_7p_s; - return_true (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - q_call (opc).fd = (dpf) ? opt_d_p_f : opt_d_7p_f; - q_func1 (opc).fp= q_func1_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); +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; } -/* -------- d_7pi -------- */ -static s7_double -opt_d_7pi_sc (opt_info* o) { - return (q_func (o).d_7pi_f (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).i)); -} -static s7_double -opt_d_7pi_ss (opt_info* o) { - return (q_func (o).d_7pi_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_7pi_sf (opt_info* o) { - return (q_func (o).d_7pi_f (o->sc, slot_value (q_arg1 (o).p), - q_i_func2_call (o))); -} -static s7_double -opt_d_7pi_ss_fvref (opt_info* o) { - return (float_vector_ref_d_7pi (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_7pi_ss_fvref_direct (opt_info* o) { - return (float_vector (slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} - -static s7_double -opt_abs_d_ss_fvref (opt_info* o) { - opt_info* o1= q_func1_arg (o).o1; - return (abs_d_d (float_vector (slot_value (q_arg1 (o1).p), - integer (slot_value (q_arg2 (o1).p))))); -} - -static s7_double -opt_d_7pi_ff (opt_info* o) /* hit only in tbig (not even s7test) */ -{ - s7_pointer seq= q_p_func1_call (o); - return (q_func (o).d_7pi_f (o->sc, seq, q_i_func2_call (o))); -} - -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); - } - q_func (opc).d_7pi_f= ifunc; - if (is_symbol (cadr (expr))) /* (float-vector-ref v i) */ - { - s7_pointer arg2, arg2_slot, obj; - q_arg1 (opc).p= s7_slot (sc, cadr (expr)); - if (!is_slot (q_arg1 (opc).p)) return_false (sc, expr); - - obj= slot_value (q_arg1 (opc).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)) { - q_arg2 (opc).i = integer (arg2); - q_call (opc).fd= opt_d_7pi_sc; - return_true (sc, expr); - } - arg2_slot= opt_integer_symbol (sc, arg2); - if (!arg2_slot) return_false (sc, expr); - q_arg2 (opc).p = arg2_slot; - q_call (opc).fd= opt_d_7pi_ss; - if (is_target_or_its_alias (car (expr), s_func, - sc->float_vector_ref_symbol)) { - q_call (opc).fd= (loop_end_fits (q_arg2 (opc).p, vector_length (obj))) - ? opt_d_7pi_ss_fvref_direct - : opt_d_7pi_ss_fvref; - if (q_call (opc).fd == opt_d_7pi_ss_fvref_direct) - q_func (opc).d_7pi_f= float_vector_ref_d_7pi_direct; - } - return_true (sc, expr); - } - if (int_optimize (sc, cddr (expr))) { - q_call (opc).fd = opt_d_7pi_sf; - q_func2_arg (opc).o1= sc->opts[start]; - q_func2 (opc).fi = q_func2_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); - } +/* -------------------------------- c-object-let -------------------------------- */ +s7_pointer s7_c_object_let(s7_pointer obj) {return(c_object_let(obj));} - 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))) { - q_call (opc).fd = opt_d_7pi_ff; - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fp = q_call (sc->opts[start]).fp; - q_func2_arg (opc).o1= o2; - q_func2 (opc).fi = q_call (o2).fi; - return_true (sc, expr); - } - } - sc->pc= start; - return_false (sc, expr); +/* g_c_object_let is now defined in s7_scheme_predicate.c */ +#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 s7_c_object_set_let(s7_scheme *sc, s7_pointer cobj, s7_pointer let) +{ + if ((!is_immutable(cobj)) && (is_let(let))) + c_object_set_let(cobj, let); + return(let); } -/* -------- d_ip -------- */ -static s7_double -opt_d_ip_ss (opt_info* o) { - return (q_func (o).d_ip_f (integer (slot_value (q_arg1 (o).p)), - slot_value (q_arg2 (o).p))); -} - -static bool -d_ip_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) /* ina/inb clm2xen, ffitest, tgen etc */ -{ - const s7_d_ip_t pfunc= s7_d_ip_function (s_func); - if ((pfunc) && (is_symbol (caddr (expr)))) { - s7_pointer arg1_slot= opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - q_func (opc).d_ip_f= pfunc; - q_arg1 (opc).p = arg1_slot; - q_arg2 (opc).p = s7_t_slot (sc, caddr (expr)); - if (is_slot ( - q_arg2 (opc).p)) /* (with-sound (:reverb jc-reverb) (fm-violin 0 - .1 440 .4 :reverb-amount .5)) */ - { - q_call (opc).fd= opt_d_ip_ss; - return_true (sc, expr); - } - } - } - return_false (sc, expr); +static s7_pointer g_c_object_set_let(s7_scheme *sc, s7_pointer args) +{ + const s7_pointer cobj = car(args), let = cadr(args); + if (is_immutable(cobj)) + immutable_object_error_nr(sc, set_elist_2(sc, wrap_string(sc, "can't set ~S's let: it is immutable", 35), cobj)); + if (!is_let(let)) + wrong_type_error_nr(sc, make_symbol(sc, "#", 19), 2, let, sc->type_names[T_LET]); + c_object_set_let(cobj, let); + return(let); } -/* -------- d_pd -------- */ -static s7_double -opt_d_pd_sf (opt_info* o) { - return (q_func (o).d_pd_f (slot_value (q_arg1 (o).p), q_d_func2_call (o))); -} -static s7_double -opt_d_pd_ss (opt_info* o) { - return (q_func (o).d_pd_f (slot_value (q_arg1 (o).p), - real (slot_value (q_arg2 (o).p)))); -} - -static bool -d_pd_ok (s7_scheme* sc, opt_info* opc, const s7_pointer s_func, - const s7_pointer expr) /* none built-in, many in clm2xen but they're - almost never called */ -{ - if (is_symbol (cadr (expr))) { - const s7_d_pd_t func= s7_d_pd_function (s_func); - if (func) { - s7_pointer arg2_slot; - const s7_pointer arg2 = caddr (expr); - const int32_t start= sc->pc; - q_func (opc).d_pd_f = func; - q_arg1 (opc).p = s7_t_slot (sc, cadr (expr)); - if (!is_slot (q_arg1 (opc).p)) return_false (sc, expr); - arg2_slot= opt_float_symbol (sc, arg2); - if (arg2_slot) { - q_arg2 (opc).p = arg2_slot; - q_call (opc).fd= opt_d_pd_ss; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_call (opc).fd = opt_d_pd_sf; - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - return_true (sc, expr); - } - sc->pc= start; - } - } - return_false (sc, expr); + +/* -------------------------------- 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)); } -/* -------- d_vd -------- */ +void *s7_c_object_value(s7_pointer obj) {return(c_object_value(obj));} -static s7_double -opt_d_vd_c (opt_info* o) { - return (q_func (o).d_vd_f (q_arg1 (o).gen, q_arg2 (o).x)); -} -static s7_double -opt_d_vd_s (opt_info* o) { - return (q_func (o).d_vd_f (q_arg1 (o).gen, real (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_vd_f (opt_info* o) { - return (q_func (o).d_vd_f (q_arg1 (o).gen, q_d_func3_call (o))); -} -static s7_double -opt_d_vd_o (opt_info* o) { - return (q_func (o).d_vd_f (q_arg1 (o).gen, - q_func3 (o).d_v_f (q_func2_arg (o).gen))); -} -static s7_double -opt_d_vd_o1_mul (opt_info* o) { - return (q_func (o).d_vd_f (q_arg1 (o).gen, real (slot_value (q_arg2 (o).p)) * - q_d_func2_call (o))); -} -static s7_double -opt_d_vd_o3 (opt_info* o) { - return (q_func (o).d_vd_f ( - q_arg1 (o).gen, q_func3 (o).d_dd_f (q_func2_arg (o).x, - real (slot_value (q_arg2 (o).p))))); -} -static s7_double -opt_d_vd_ff (opt_info* o) { - return (q_func (o).d_vd_f ( - q_arg1 (o).gen, - q_func3 (o).d_vd_f (q_func3_arg (o).gen, q_d_func2_call (o)))); -} - -static s7_double -opt_d_vd_o1 (opt_info* o) { - return (q_func (o).d_vd_f ( - q_arg1 (o).gen, q_func3 (o).d_dd_f (real (slot_value (q_arg2 (o).p)), - q_d_func2_call (o)))); -} - -static s7_double -opt_d_vd_o2 (opt_info* o) { - return (q_func3 (o).d_vd_f ( - q_arg3 (o).gen, - q_func1 (o).d_vd_f (q_arg2 (o).gen, real (slot_value (q_arg4 (o).p))))); -} - -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 (q_call (o1).fd == opt_d_v) { - q_func2_arg (opc).gen= q_arg1 (o1).gen; - q_func3 (opc).d_v_f = q_func (o1).d_v_f; - q_call (opc).fd = opt_d_vd_o; - backup_pc (sc); - return_true (sc, NULL); - } - if (q_call (o1).fd == opt_d_vd_s) { - q_func3 (opc).d_vd_f= q_func (opc).d_vd_f; /* [4] <- opc[3] */ - q_arg3 (opc).gen = q_arg1 (opc).gen; /* [12] <- opc[5] */ - q_func1 (opc).d_vd_f= q_func (o1).d_vd_f; /* [5] <- o1[3] */ - q_arg2 (opc).gen = q_arg1 (o1).gen; /* [2] <- o1[5] */ - q_arg4 (opc).p = q_arg2 (o1).p; /* [13] <- o1[2] */ - q_call (opc).fd = opt_d_vd_o2; - backup_pc (sc); - return_true (sc, NULL); - } - if (q_call (o1).fd == opt_d_dd_cs) { - q_func3 (opc).d_dd_f= q_func (o1).d_dd_f; - q_func2_arg (opc).x = q_arg1 (o1).x; - /* fprintf(stderr, "arg1: %f, arg2: %s\n", q_arg1(o1).x, - * display(q_arg2(o1).p)); */ - q_arg2 (opc).p = T_Slt (q_arg2 (o1).p); - q_call (opc).fd= opt_d_vd_o3; - backup_pc (sc); - return_true (sc, NULL); - } - if ((q_call (o1).fd == opt_d_dd_sf_mul) || (q_call (o1).fd == opt_d_dd_sf) || - (q_call (o1).fd == opt_d_dd_sf_add)) { - q_arg2 (opc).p= q_arg1 (o1).p; - q_func3 (opc).d_dd_f= - q_func (o1).d_dd_f; /* unused in opt_d_vd_o1_mul (=> mul) */ - q_call (opc).fd= - (q_call (o1).fd == opt_d_dd_sf_mul) ? opt_d_vd_o1_mul : opt_d_vd_o1; - q_func2 (opc).fd = q_func1 (o1).fd; - q_func2_arg (opc).o1= q_func1_arg (o1).o1; - return_true (sc, NULL); - } - if (q_call (o1).fd == opt_d_vd_f) { - q_func3 (opc).d_vd_f = q_func (o1).d_vd_f; - q_func3_arg (opc).gen= q_arg1 (o1).gen; - q_call (opc).fd = opt_d_vd_ff; - q_func2 (opc).fd = q_func3 (o1).fd; - q_func2_arg (opc).o1 = q_func3_arg (o1).o1; - return_true (sc, NULL); - } - return_false (sc, NULL); +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 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; - q_func (opc).d_vd_f = vfunc; - if (!is_pair (arg2)) { - q_arg1 (opc).p = slot; - q_arg1 (opc).gen= (void*) c_object_value (slot_value (slot)); - if (is_small_real (arg2)) { - q_arg2 (opc).x = s7_number_to_real (sc, arg2); - q_call (opc).fd= opt_d_vd_c; - return_true (sc, expr); - } - q_arg2 (opc).p= s7_t_slot (sc, arg2); - if (is_slot (q_arg2 (opc).p)) { - if (is_t_real (slot_value (q_arg2 (opc).p))) { - q_call (opc).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); - q_call (opc).fd = opt_d_vd_f; - q_func3_arg (opc).o1= sc->opts[start]; - q_func3 (opc).fd = q_call (sc->opts[start]).fd; - return_true (sc, expr); - } - } - else /* is pair arg2 */ - { - if (float_optimize (sc, cddr (expr))) { - q_arg1 (opc).gen= (void*) c_object_value (slot_value (slot)); - if (d_vd_f_combinable (sc, start)) return_true (sc, expr); - q_call (opc).fd = opt_d_vd_f; - q_func3_arg (opc).o1= sc->opts[start]; - q_func3 (opc).fd = q_call (sc->opts[start]).fd; - return_true (sc, expr); - } - sc->pc= start; - } - } - } - return_false (sc, expr); +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); } -/* -------- d_id -------- */ -static s7_double -opt_d_id_ss (opt_info* o) { - return (q_func (o).d_id_f (integer (slot_value (q_arg1 (o).p)), - real (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_i2_mul (opt_info* o) { - s7_int p= integer (slot_value (q_arg1 (o).p)); - return (p * p); -} -static s7_double -opt_d_id_sf (opt_info* o) { - return (q_func (o).d_id_f (integer (slot_value (q_arg1 (o).p)), - q_d_func1_call (o))); -} -static s7_double -opt_d_id_sc (opt_info* o) { - return ( - q_func (o).d_id_f (integer (slot_value (q_arg1 (o).p)), q_arg2 (o).x)); -} -static s7_double -opt_d_id_cf (opt_info* o) { - return (q_func (o).d_id_f (q_arg1 (o).i, q_d_func1_call (o))); -} -static s7_double -opt_d_id_sfo1 (opt_info* o) { - return (q_func (o).d_id_f (integer (slot_value (q_arg1 (o).p)), - q_func1 (o).d_v_f (q_arg2 (o).gen))); -} - -static s7_double -opt_d_id_sfo (opt_info* o) { - return (q_func (o).d_id_f ( - integer (slot_value (q_arg1 (o).p)), - q_func1 (o).d_vd_f (q_arg3 (o).gen, real (slot_value (q_arg2 (o).p))))); -} - -static s7_double -opt_d_id_ff (opt_info* o) { - s7_int x1= q_i_func1_call (o); - return (q_func (o).d_id_f (x1, q_d_func2_call (o))); -} - -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 (q_call (o1).fd == opt_d_vd_s) { - q_arg3 (opc).gen = q_arg1 (o1).gen; - q_func1 (opc).d_vd_f= q_func (o1).d_vd_f; - q_arg2 (opc).p = q_arg2 (o1).p; - q_call (opc).fd = opt_d_id_sfo; /* not in s7test (see tgen) */ - backup_pc (sc); - return_true (sc, NULL); - } - if (q_call (o1).fd == opt_d_v) { - q_arg2 (opc).gen = q_arg1 (o1).gen; - q_func1 (opc).d_v_f= q_func (o1).d_v_f; - q_call (opc).fd = opt_d_id_sfo1; /* not in s7test (tgen) */ - 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 arg1_slot; - 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); - q_func (opc).d_id_f= flt_func; - arg1_slot = opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - const s7_pointer arg2= caddr (expr); - s7_pointer arg2_slot; - q_arg1 (opc).p= arg1_slot; - if (is_t_real (arg2)) { - q_call (opc).fd= opt_d_id_sc; - q_arg2 (opc).x = real (arg2); - return_true (sc, expr); - } - if ((cadr (expr) == arg2) && - (flt_func == multiply_d_id)) /* cadr(expr)==arg2 if both are symbols */ - { /* (do... (set! sum 0.0) (do ((k 1 (+ k 1))) ((> k 10)) (set! sum (+ sum - (/ (* k k)))))) tnum */ - q_call (opc).fd= opt_d_i2_mul; - return_true (sc, expr); - } - arg2_slot= opt_float_symbol (sc, arg2); - if (arg2_slot) { - q_call (opc).fd= opt_d_id_ss; - q_arg2 (opc).p = arg2_slot; - return_true (sc, expr); - } - if (float_optimize (sc, cddr (expr))) { - if (d_id_sf_combinable (sc, opc)) return_true (sc, expr); - q_call (opc).fd = opt_d_id_sf; - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fd = q_call (sc->opts[start]).fd; - return_true (sc, expr); - } - sc->pc= start; - } - if (is_t_integer (cadr (expr))) { - if (float_optimize (sc, cddr (expr))) { - q_call (opc).fd = opt_d_id_cf; - q_arg1 (opc).i = integer (cadr (expr)); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fd = q_call (sc->opts[start]).fd; - return_true (sc, expr); - } - sc->pc= start; - } - if (!expr_case) return_false (sc, expr); - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func1 (opc).fi = q_func1_arg (opc).q_call (o1).fi; - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - q_call (opc).fd = opt_d_id_ff; /* not in s7test? (once in tgsl! from - opt_d_7pid_sff_fvset (float-vector-set! v - 0 (jn (+ i 1) 1.0))) */ - return_true (sc, expr); - } - sc->pc= start; - } - return_false (sc, expr); +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)); } -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)); +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)); } -/* -------- d_dd -------- */ - -static s7_double -opt_d_dd_cc (opt_info* o) { - return (q_func (o).d_dd_f (q_arg1 (o).x, q_arg2 (o).x)); -} -static s7_double -opt_d_dd_cs (opt_info* o) { - return (q_func (o).d_dd_f (q_arg1 (o).x, real (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_dd_sc (opt_info* o) { - return (q_func (o).d_dd_f (real (slot_value (q_arg1 (o).p)), q_arg2 (o).x)); -} -static s7_double -opt_d_dd_sc_sub (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) - q_arg2 (o).x); -} -static s7_double -opt_d_dd_ss (opt_info* o) { - return (q_func (o).d_dd_f (real (slot_value (q_arg1 (o).p)), - real (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_dd_ss_add (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) + real (slot_value (q_arg2 (o).p))); -} -static s7_double -opt_d_dd_ss_mul (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) * real (slot_value (q_arg2 (o).p))); +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_double -opt_d_dd_cf (opt_info* o) { - return (q_func (o).d_dd_f (q_arg1 (o).x, q_d_func1_call (o))); -} -static s7_double -opt_d_dd_1f_subtract (opt_info* o) { - return (1.0 - q_d_func1_call (o)); -} -static s7_double -opt_d_dd_fc (opt_info* o) { - return (q_func (o).d_dd_f (q_d_func1_call (o), q_arg2 (o).x)); +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_double -opt_subtract_random_f_f (opt_info* o) { - return (q_arg1 (o).x * next_random (o->sc->default_random_state) - - q_arg2 (o).x); +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_double -opt_d_dd_fc_add (opt_info* o) { - return (q_d_func1_call (o) + q_arg2 (o).x); -} -static s7_double -opt_d_dd_fc_fvref_add (opt_info* o) { - return (q_arg2 (o).x + float_vector (slot_value (q_arg3 (o).p), - integer (slot_value (q_arg4 (o).p)))); -} -static s7_double -opt_d_dd_fc_subtract (opt_info* o) { - return (q_d_func1_call (o) - q_arg2 (o).x); -} -static s7_double -opt_d_dd_sf (opt_info* o) { - return ( - q_func (o).d_dd_f (real (slot_value (q_arg1 (o).p)), q_d_func1_call (o))); -} -static s7_double -opt_d_dd_sf_mul (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) * q_d_func1_call (o)); -} -static s7_double -opt_d_dd_sf_add (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) + q_d_func1_call (o)); -} -static s7_double -opt_d_dd_sf_sub (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) - q_d_func1_call (o)); +static s7_pointer copy_c_object(s7_scheme *sc, s7_pointer args) +{ + const 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_double -opt_d_7dd_cc (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, q_arg1 (o).x, q_arg2 (o).x)); -} -static s7_double -opt_d_7dd_cs (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, q_arg1 (o).x, - real (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_7dd_sc (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, real (slot_value (q_arg1 (o).p)), - q_arg2 (o).x)); -} -static s7_double -opt_d_7dd_ss (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, real (slot_value (q_arg1 (o).p)), - real (slot_value (q_arg2 (o).p)))); -} -static s7_double -opt_d_7dd_cf (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, q_arg1 (o).x, q_d_func1_call (o))); -} -static s7_double -opt_d_7dd_fc (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, q_d_func1_call (o), q_arg2 (o).x)); +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 s7_double -opt_d_7dd_sf (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, real (slot_value (q_arg1 (o).p)), - q_d_func1_call (o))); + +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); } -/* arg3 is index slot from opt_d_7pii_scs, also below */ -static s7_double -opt_d_dd_sf_mul_fvref (opt_info* o) { - opt_info* o1= q_func1_arg (o).o1; - return (real (slot_value (q_arg1 (o).p)) * - float_vector_ref_d_7pii (o1->sc, slot_value (q_arg1 (o1).p), - q_arg2 (o1).i, - integer (slot_value (q_arg3 (o1).p)))); -} - -static s7_double -opt_d_dd_sfo (opt_info* o) { - return (q_func (o).d_dd_f ( - real (slot_value (q_arg1 (o).p)), - q_func1 (o).d_7pi_f (o->sc, slot_value (q_arg2 (o).p), - integer (slot_value (q_arg3 (o).p))))); -} - -static s7_double -opt_d_7dd_sfo (opt_info* o) { - return (q_func (o).d_7dd_f ( - o->sc, real (slot_value (q_arg1 (o).p)), - q_func1 (o).d_7pi_f (o->sc, slot_value (q_arg2 (o).p), - integer (slot_value (q_arg3 (o).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 ((q_call (o1).fd == opt_d_7pi_ss) || - (q_call (o1).fd == opt_d_7pi_ss_fvref) || - (q_call (o1).fd == opt_d_7pi_ss_fvref_direct)) { - if (func) { - q_func (opc).d_dd_f= q_func (opc).d_dd_f; /* need room for 3 symbols */ - q_call (opc).fd = opt_d_dd_sfo; - } - else { - q_func (opc).d_7dd_f= - q_func (opc).d_7dd_f; /* need room for 3 symbols */ - q_call (opc).fd= opt_d_7dd_sfo; - } - q_arg2 (opc).p = q_arg1 (o1).p; - q_arg3 (opc).p = q_arg2 (o1).p; - q_func1 (opc).d_7pi_f= q_func (o1).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 ( - q_func (o).d_dd_f (q_d_func1_call (o), real (slot_value (q_arg1 (o).p)))); -} -static s7_double -opt_d_dd_fs_mul (opt_info* o) { - return (q_d_func1_call (o) * real (slot_value (q_arg1 (o).p))); -} -static s7_double -opt_d_dd_fs_add (opt_info* o) { - return (q_d_func1_call (o) + real (slot_value (q_arg1 (o).p))); -} -static s7_double -opt_d_dd_fs_sub (opt_info* o) { - return (q_d_func1_call (o) - real (slot_value (q_arg1 (o).p))); -} -static s7_double -opt_d_7dd_fs (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, q_d_func1_call (o), - real (slot_value (q_arg1 (o).p)))); -} - -static s7_double -opt_d_dd_fs_add_fvref (opt_info* o) { - opt_info* o1= q_func1_arg (o).o1; - return (real (slot_value (q_arg1 (o).p)) + - float_vector_ref_d_7pii (o1->sc, slot_value (q_arg1 (o1).p), - q_arg2 (o1).i, - integer (slot_value (q_arg3 (o1).p)))); -} - -static s7_double -opt_d_dd_fso (opt_info* o) { - return (q_func (o).d_dd_f ( - q_func1 (o).d_7pi_f (o->sc, slot_value (q_arg2 (o).p), - integer (slot_value (q_arg3 (o).p))), - real (slot_value (q_arg1 (o).p)))); -} - -static s7_double -opt_d_7dd_fso (opt_info* o) { - return (q_func (o).d_7dd_f ( - o->sc, - q_func1 (o).d_7pi_f (o->sc, slot_value (q_arg2 (o).p), - integer (slot_value (q_arg3 (o).p))), - real (slot_value (q_arg1 (o).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 ((q_call (o1).fd == opt_d_7pi_ss) || - (q_call (o1).fd == opt_d_7pi_ss_fvref) || - (q_call (o1).fd == opt_d_7pi_ss_fvref_direct)) { - if (func) { - q_func (opc).d_dd_f= q_func (opc).d_dd_f; /* need room for 3 symbols */ - q_call (opc).fd = opt_d_dd_fso; - } - else { - q_func (opc).d_7dd_f= q_func (opc).d_7dd_f; - q_call (opc).fd = opt_d_7dd_fso; - } - q_arg2 (opc).p = q_arg1 (o1).p; - q_arg3 (opc).p = q_arg2 (o1).p; - q_func1 (opc).d_7pi_f= q_func (o1).d_7pi_f; - backup_pc (sc); - return_true (sc, NULL); - } - } - return_false (sc, NULL); +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_double -opt_d_dd_ff (opt_info* o) { - s7_double x1= q_d_func3_call (o); - return (q_func (o).d_dd_f (x1, q_d_func2_call (o))); +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)); } -static s7_double -opt_d_dd_ff_mul (opt_info* o) { - s7_double x1= q_d_func3_call (o); - return (x1 * q_d_func2_call (o)); +/* 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 let, + 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(let), 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)); } -static s7_double -opt_d_dd_ff_square (opt_info* o) { - s7_double x1= q_d_func3_call (o); - return (x1 * x1); +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); } -static s7_double -opt_d_dd_ff_add (opt_info* o) { - s7_double x1= q_d_func1_call (o); - return (x1 + q_d_func2_call (o)); + +/* -------------------------------- 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_double -opt_d_dd_ff_add_mul (opt_info* o) { - s7_double x1= q_d_func1_call (o); - s7_double x2= q_d_func3_call (o); - return (x1 + (x2 * q_d_func2_call (o))); +/* g_is_dilambda is now defined in s7_scheme_predicate.c */ +#define H_is_dilambda "(dilambda? obj) returns #t if obj is a procedure with setter." +#define Q_is_dilambda sc->pl_bt + + +/* -------------------------------- 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); } -static s7_double -opt_d_dd_ff_add_fv_ref (opt_info* o) { - s7_double x1= q_d_func1_call (o); - return (x1 + float_vector_ref_d_7pi (o->sc, slot_value (q_arg1 (o).p), - q_i_func3_call (o))); + +/* -------------------------------- 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 s7_double -opt_d_dd_ff_sub (opt_info* o) { - s7_double x1= q_d_func1_call (o); - return (x1 - q_d_func2_call (o)); +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 s7_double -opt_d_7dd_ff (opt_info* o) { - s7_double x1= q_d_func3_call (o); - return (q_func (o).d_7dd_f (o->sc, x1, q_d_func2_call (o))); +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 s7_double -opt_d_7dd_ff_add_div (opt_info* o) { - s7_double x1= opt_d_7pi_ss_fvref_direct (q_arg1 (o).o1); - s7_double x2= opt_d_7pi_ss_fvref_direct (q_arg2 (o).o1); - return (x1 + divide_d_7dd (o->sc, x2, opt_d_id_sf (q_arg3 (o).o1))); +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)); } -static s7_double -opt_d_dd_ff_mul1 (opt_info* o) { - return (q_func3 (o).d_v_f (q_arg1 (o).gen) * q_d_func2_call (o)); +static s7_pointer c_object_arity_to_int(s7_scheme *sc, s7_pointer obj) +{ + if_c_object_method_exists_return_value(sc, obj, sc->arity_symbol, set_plist_1(sc, obj)); + return((is_safe_procedure(obj)) ? cons(sc, int_zero, max_arity) : sc->F); } -static s7_double -opt_d_dd_ff_mul2 (opt_info* o) { - return (q_func3 (o).d_v_f (q_arg1 (o).gen) * - q_func1 (o).d_v_f (q_arg2 (o).gen)); +static s7_pointer vector_arity_to_int(s7_scheme *sc, s7_pointer obj) +{ + if (vector_length(obj) == 0) return(sc->F); + if (has_simple_elements(obj)) return(cons(sc, int_one, make_integer(sc, vector_rank(obj)))); + return(cons(sc, int_one, max_arity)); } -static s7_double -opt_d_dd_ff_mul4 (opt_info* o) { - return ( - q_func3 (o).d_v_f (q_arg1 (o).gen) * - q_func2 (o).d_vd_f (q_arg2 (o).gen, q_func1 (o).d_v_f (q_arg3 (o).gen))); +static s7_pointer syntax_arity_to_int(s7_scheme *sc, s7_pointer obj) +{ + return(cons(sc, small_int(syntax_min_args(obj)), + (syntax_max_args(obj) == MAX_ARITY) ? max_arity : small_int(syntax_max_args(obj)))); } -static s7_double -opt_d_dd_ff_o1 (opt_info* o) { - s7_double x1= q_func3 (o).d_v_f (q_arg1 (o).gen); - return (q_func (o).d_dd_f (x1, q_d_func2_call (o))); +s7_pointer s7_arity(s7_scheme *sc, s7_pointer obj) +{ + switch (type(obj)) + { + case T_C_FUNCTION: return(cons(sc, make_integer(sc, c_function_min_args(obj)), make_integer_unchecked(sc, c_function_max_args(obj)))); + 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(obj)))); + case T_CLOSURE: + case T_MACRO: case T_BACRO: return(closure_arity_to_cons(sc, obj, closure_pars(obj))); + case T_CLOSURE_STAR: + case T_MACRO_STAR: case T_BACRO_STAR: return(closure_star_arity_to_cons(sc, obj, closure_pars(obj))); + case T_C_MACRO: return(cons(sc, make_integer(sc, c_macro_min_args(obj)), make_integer_unchecked(sc, c_macro_max_args(obj)))); + case T_C_OBJECT: return(c_object_arity_to_int(sc, obj)); + 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_GOTO: case T_CONTINUATION: return(cons(sc, int_zero, max_arity)); + case T_STRING: return((string_length(obj) == 0) ? sc->F : cons(sc, int_one, int_one)); + case T_LET: return(cons(sc, int_one, int_one)); + case T_SYNTAX: return(syntax_arity_to_int(sc, obj)); + case T_VECTOR: return(vector_arity_to_int(sc, obj)); + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + return((vector_length(obj) == 0) ? sc->F : cons(sc, int_one, make_integer(sc, vector_rank(obj)))); + } + return(sc->F); } -static s7_double -opt_d_dd_ff_o2 (opt_info* o) { - s7_double x1= q_func3 (o).d_v_f (q_arg1 (o).gen); - return (q_func (o).d_dd_f (x1, q_func1 (o).d_v_f (q_arg2 (o).gen))); -} - -static s7_double -opt_d_dd_ff_o3 (opt_info* o) { - s7_double x1= q_func3 (o).d_v_f (q_arg1 (o).gen); - return (q_func1 (o).d_dd_f ( - x1, - q_func2 (o).d_vd_f (q_arg2 (o).gen, real (slot_value (q_arg3 (o).p))))); -} - -static s7_double -opt_d_dd_ff_o4 (opt_info* o) { - s7_double x1= q_func3 (o).d_v_f (q_arg1 (o).gen); - return (q_func (o).d_dd_f ( - x1, - q_func2 (o).d_vd_f (q_arg2 (o).gen, q_func1 (o).d_v_f (q_arg3 (o).gen)))); -} - -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 (q_func (o).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 (q_func (o).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 (q_func (o).d_dd_f (x1, x2)); -} - -static s7_double -opt_d_dd_ff_mul_sss_unchecked (opt_info* o) { - opt_info* o1 = q_func3_arg (o).o1; - s7_pointer vec= slot_value (q_arg1 (o1).p); - s7_int i1 = integer (slot_value (q_arg2 (o1).p)); - s7_int i2 = integer (slot_value (q_arg3 (o1).p)); - s7_double x1 = float_vector (vec, (i1 * vector_offset (vec, 0)) + i2); - o1 = q_func2_arg (o).o1; - vec = slot_value (q_arg1 (o1).p); - i1 = integer ( - slot_value (q_arg2 (o1).p)); /* in (* (A i j) (B j k)) we could reuse - i2->i1 (flipping args below) */ - i2= integer (slot_value (q_arg3 (o1).p)); - return (x1 * float_vector (vec, (i1 * vector_offset (vec, 0)) + i2)); -} - -static bool -finish_dd_fso (opt_info* opc, opt_info* o1, opt_info* o2) { - opc->v[3 + 1].p = q_arg1 (o1).p; - opc->v[3 + 2].p = q_arg2 (o1).p; - opc->v[3 + 3].p = q_arg3 (o1).p; - opc->v[3 + 4].d_dd_f = q_func (o1).d_dd_f; - opc->v[3 + 5].d_7pi_f= q_func1 (o1).d_7pi_f; - opc->v[8 + 1].p = q_arg1 (o2).p; - opc->v[8 + 2].p = q_arg2 (o2).p; - opc->v[8 + 3].p = q_arg3 (o2).p; - opc->v[8 + 4].d_dd_f = q_func (o2).d_dd_f; - opc->v[8 + 5].d_7pi_f= q_func1 (o2).d_7pi_f; - return (true); -} - -static bool -d_dd_ff_combinable (s7_scheme* sc, opt_info* opc, int32_t start) { - opt_info *o1= q_func3_arg (opc).o1, *o2= q_func2_arg (opc).o1; - if (q_call (o1).fd == opt_d_v) { - /* q_func(opc) is in use */ - q_arg1 (opc).gen = q_arg1 (o1).gen; - q_func3 (opc).d_v_f= q_func (o1).d_v_f; - if ((q_call (o2).fd == opt_d_v) && (sc->pc == start + 2)) { - q_arg2 (opc).gen = q_arg1 (o2).gen; - q_func1 (opc).d_v_f= q_func (o2).d_v_f; - q_call (opc).fd= (q_func (opc).d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul2 - : opt_d_dd_ff_o2; - sc->pc-= 2; - return_true (sc, NULL); - } - if ((q_call (o2).fd == opt_d_vd_s) && (sc->pc == start + 2)) { - q_arg2 (opc).gen = q_arg1 (o2).gen; - q_func1 (opc).d_dd_f= q_func (opc).d_dd_f; - q_func2 (opc).d_vd_f= q_func (o2).d_vd_f; - q_arg3 (opc).p = q_arg2 (o2).p; - q_call (opc).fd = opt_d_dd_ff_o3; - sc->pc-= 2; - return_true (sc, NULL); - } - if ((q_call (o2).fd == opt_d_vd_o) && (sc->pc == start + 2)) { - q_func3 (opc).d_v_f = q_func (o1).d_v_f; - q_func2 (opc).d_vd_f= q_func (o2).d_vd_f; - q_func1 (opc).d_v_f = q_func3 (o2).d_v_f; - q_arg2 (opc).gen = q_arg1 (o2).gen; - q_arg3 (opc).gen = q_func2_arg (o2).gen; - q_call (opc).fd= (q_func (opc).d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul4 - : opt_d_dd_ff_o4; - sc->pc-= 2; - return_true (sc, NULL); - } - q_call (opc).fd= (q_func (opc).d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul1 - : opt_d_dd_ff_o1; - return_true (sc, NULL); - } - if (((q_call (o1).fd == opt_d_dd_fso) && (q_call (o2).fd == opt_d_dd_fso)) || - ((q_call (o1).fd == opt_d_dd_sfo) && (q_call (o2).fd == opt_d_dd_sfo))) { - if ((q_func (o1).d_dd_f == multiply_d_dd) && - (q_func (o2).d_dd_f == multiply_d_dd) && - ((q_func1 (o1).d_7pi_f == float_vector_ref_d_7pi) || - (q_func1 (o1).d_7pi_f == float_vector_ref_d_7pi_direct)) && - ((q_func1 (o2).d_7pi_f == float_vector_ref_d_7pi) || - (q_func1 (o2).d_7pi_f == float_vector_ref_d_7pi_direct))) - q_call (opc).fd= - opt_d_mm_fff; /* a placeholder (never called), see p_d_f_combinable */ - else - q_call (opc).fd= - (q_call (o1).fd == opt_d_dd_fso) ? opt_d_dd_fff : 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 (q_func (o).d_dd_f (q_arg1 (o).x, q_func1 (o).d_v_f (q_arg2 (o).gen))); -} -static s7_double -opt_d_7dd_cfo (opt_info* o) { - return (q_func (o).d_7dd_f (o->sc, q_arg1 (o).x, - q_func1 (o).d_v_f (q_arg2 (o).gen))); -} - -static s7_double -opt_d_dd_cfo1 (opt_info* o) { - return (q_func (o).d_dd_f ( - q_arg1 (o).x, - q_func1 (o).d_vd_f (q_arg3 (o).gen, real (slot_value (q_arg2 (o).p))))); -} -static s7_double -opt_d_7dd_cfo1 (opt_info* o) { - return (q_func (o).d_7dd_f ( - o->sc, q_arg1 (o).x, - q_func1 (o).d_vd_f (q_arg3 (o).gen, real (slot_value (q_arg2 (o).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 (q_call (o1).fd == opt_d_v) { - q_arg2 (opc).gen = q_arg1 (o1).gen; - q_func1 (opc).d_v_f= q_func (o1).d_v_f; - q_call (opc).fd = (func) ? opt_d_dd_cfo : opt_d_7dd_cfo; - backup_pc (sc); - return_true (sc, NULL); - } - if (q_call (o1).fd == opt_d_vd_s) { - q_arg3 (opc).gen = q_arg1 (o1).gen; - q_arg2 (opc).p = q_arg2 (o1).p; - q_func1 (opc).d_vd_f= q_func (o1).d_vd_f; - q_call (opc).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) q_func (opc).d_dd_f= func; - else q_func (opc).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); - q_arg1 (opc).x = s7_number_to_real (sc, arg1); - q_arg2 (opc).x = s7_number_to_real (sc, arg2); - q_call (opc).fd= (func) ? opt_d_dd_cc : opt_d_7dd_cc; - return_true (sc, expr); - } - slot= opt_float_symbol (sc, arg2); - if (slot) { - q_arg1 (opc).x= s7_number_to_real (sc, arg1); - q_arg2 (opc).p= slot; - q_call (opc).fd= - (func) ? opt_d_dd_cs - : opt_d_7dd_cs; /* see opt_d_vd_o3 above which uses this */ - return_true (sc, expr); - } - if (float_optimize (sc, cddr (expr))) { - q_arg1 (opc).x= s7_number_to_real (sc, arg1); - if (d_dd_call_combinable (sc, opc, func)) return_true (sc, expr); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fd = q_call (sc->opts[start]).fd; - q_call (opc).fd = (func) ? opt_d_dd_cf : opt_d_7dd_cf; - if ((q_arg1 (opc).x == 1.0) && (func == subtract_d_dd)) - q_call (opc).fd= opt_d_dd_1f_subtract; - return_true (sc, expr); - } - sc->pc= start; - return_false (sc, expr); - } +/* g_arity is now defined in s7_scheme_predicate.c */ + #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) - /* arg1 = float symbol */ - slot= opt_float_symbol (sc, arg1); - if (slot) { - q_arg1 (opc).p= slot; - if (is_small_real (arg2)) { - q_arg2 (opc).x= s7_number_to_real (sc, arg2); - if (func) - q_call (opc).fd= - (func == subtract_d_dd) ? opt_d_dd_sc_sub : opt_d_dd_sc; - else q_call (opc).fd= opt_d_7dd_sc; - return_true (sc, expr); - } - slot= opt_float_symbol (sc, arg2); - if (slot) { - q_arg2 (opc).p= slot; - if (func) { - if (func == multiply_d_dd) q_call (opc).fd= opt_d_dd_ss_mul; - else - q_call (opc).fd= (func == add_d_dd) ? opt_d_dd_ss_add : opt_d_dd_ss; - } - else q_call (opc).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); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fd = q_call (sc->opts[start]).fd; - if (func) { - q_call (opc).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) && (q_func1 (opc).fd == opt_d_7pii_scs)) - q_call (opc).fd= opt_d_dd_sf_mul_fvref; - } - else q_call (opc).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)) { - q_arg2 (opc).x = s7_number_to_real (sc, arg2); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fd = q_call (sc->opts[start]).fd; - if (func) { - if (func == add_d_dd) { - if (q_func1 (opc).fd == opt_d_7pi_ss_fvref_direct) { - q_call (opc).fd= opt_d_dd_fc_fvref_add; - q_arg3 (opc).p = q_func1_arg (opc).q_arg1 (o1).p; - q_arg4 (opc).p = q_func1_arg (opc).q_arg2 (o1).p; - } - else q_call (opc).fd= opt_d_dd_fc_add; - return_true (sc, expr); - } - if (func == subtract_d_dd) { - q_call (opc).fd= opt_d_dd_fc_subtract; - /* if q_call(o1).fd = opt_d_7d_c and its q_func(o).d_7d_f = - * random_d_7d it's (- (random f1) f2) */ - if ((opc == sc->opts[sc->pc - 2]) && - (q_call (sc->opts[start]).fd == opt_d_7d_c) && - (q_func (sc->opts[start]).d_7d_f == random_d_7d)) { - q_call (opc).fd= opt_subtract_random_f_f; - q_arg1 (opc).x = q_arg1 (sc->opts[start]).x; /* random arg */ - backup_pc (sc); - } - } - else q_call (opc).fd= opt_d_dd_fc; - } - else q_call (opc).fd= opt_d_7dd_fc; - return_true (sc, expr); - } - slot= opt_float_symbol (sc, arg2); - if (slot) { - q_arg1 (opc).p= slot; - if (d_dd_fs_combinable (sc, opc, func)) return_true (sc, expr); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fd = q_call (sc->opts[start]).fd; - if (func) { - q_call (opc).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) && (q_func1 (opc).fd == opt_d_7pii_scs)) - q_call (opc).fd= opt_d_dd_fs_add_fvref; - } - else q_call (opc).fd= opt_d_7dd_fs; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - opt_info* o2; - q_func3_arg (opc).o1= o1; - q_func3 (opc).fd = q_call (o1).fd; - q_func2 (opc).fd = q_func2_arg (opc).q_call (o1).fd; - if (func) { - if (d_dd_ff_combinable (sc, opc, start)) return_true (sc, expr); - q_call (opc).fd= opt_d_dd_ff; - if (func == multiply_d_dd) { - if (arg1 == arg2) q_call (opc).fd= opt_d_dd_ff_square; - else if ((q_func3 (opc).fd == opt_d_7pii_sss_unchecked) && - (q_func2 (opc).fd == opt_d_7pii_sss_unchecked) && - (q_func1 (o1).d_7pii_f == float_vector_ref_d_7pii)) - q_call (opc).fd= opt_d_dd_ff_mul_sss_unchecked; - else q_call (opc).fd= opt_d_dd_ff_mul; - return_true (sc, expr); - } - o2= sc->opts[start2]; /* this is q_func2_arg(opc).o1, v[10] */ - if (func == add_d_dd) { - if (q_call (o2).fd == opt_d_dd_ff_mul) { - q_call (opc).fd = opt_d_dd_ff_add_mul; - q_func1_arg (opc).o1= o1; /* add first arg */ - q_func1 (opc).fd = q_call (o1).fd; - q_func3_arg (opc).o1= q_func3_arg (o2).o1; /* mul first arg */ - q_func3 (opc).fd = q_func3 (o2).fd; - q_func2_arg (opc).o1= q_func2_arg (o2).o1; /* mul second arg */ - q_func2 (opc).fd = q_func2 (o2).fd; - return_true (sc, expr); - } - if ((q_call (o2).fd == opt_d_7pi_sf) && - ((q_func (o2).d_7pi_f == float_vector_ref_d_7pi) || - (q_func (o2).d_7pi_f == float_vector_ref_d_7pi_direct))) { - q_call (opc).fd= opt_d_dd_ff_add_fv_ref; - q_arg1 (opc).p = q_arg1 (o2).p; - q_func3_arg (opc).o1= - q_func2_arg (o2).o1; /* sc->opts[start2 + 1]; */ - q_func3 (opc).fi= - q_func2 (o2).fi; /* sc->opts[start2 + 1]-v[0].fi; */ - } - else { - q_call (opc).fd = opt_d_dd_ff_add; - q_func2_arg (opc).o1= o2; - q_func2 (opc).fd = q_call (o2).fd; - if ((q_call (o1).fd == opt_d_7pi_ss_fvref_direct) && - (q_func2 (opc).fd == opt_d_7dd_ff)) { - opt_info* ov= q_func2_arg (opc).o1; - if ((q_func (ov).d_7dd_f == divide_d_7dd) && - (q_func2 (ov).fd == opt_d_id_sf) && - (q_func3 (ov).fd == opt_d_7pi_ss_fvref_direct)) { - q_arg1 (opc).o1= o1; - q_arg3 (opc).o1= q_func2_arg (ov).o1; - q_arg2 (opc).o1= q_func3_arg (ov).o1; - q_call (opc).fd= opt_d_7dd_ff_add_div; - } - } - } - q_func1_arg (opc).o1= o1; /* sc->opts[start]; */ - q_func1 (opc).fd= q_call (o1).fd; /* q_call(sc->opts[start]).fd; */ - return_true (sc, expr); - } - if (func == subtract_d_dd) { - q_call (opc).fd = opt_d_dd_ff_sub; - q_func1_arg (opc).o1= o1; /* sc->opts[start]; */ - q_func1 (opc).fd= q_call (o1).fd; /* q_call(sc->opts[start]).fd; */ - q_func2_arg (opc).o1= o2; - q_func2 (opc).fd = q_call (o2).fd; - return_true (sc, expr); - } - } - else q_call (opc).fd= opt_d_7dd_ff; - return_true (sc, expr); +/* -------------------------------- 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); } - } - sc->pc= start; - return_false (sc, expr); + 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 */ } -/* -------- d_ddd -------- */ - -static s7_double -opt_d_ddd_sss (opt_info* o) { - return (q_func (o).d_ddd_f (real (slot_value (q_arg1 (o).p)), - real (slot_value (q_arg2 (o).p)), - real (slot_value (q_arg3 (o).p)))); -} -static s7_double -opt_d_ddd_ssf (opt_info* o) { - return (q_func (o).d_ddd_f (real (slot_value (q_arg1 (o).p)), - real (slot_value (q_arg2 (o).p)), - q_d_func2_call (o))); -} - -static s7_double -opt_d_ddd_sff (opt_info* o) { - s7_double x1= q_d_func2_call (o); - s7_double x2= q_d_func3_call (o); - return (q_func (o).d_ddd_f (real (slot_value (q_arg1 (o).p)), x1, x2)); -} - -static s7_double -opt_d_ddd_fff (opt_info* o) { - s7_double x1= q_d_func2_call (o); - s7_double x2= q_d_func3_call (o); - s7_double x3= q_d_func1_call (o); - return (q_func (o).d_ddd_f (x1, x2, x3)); -} - -static s7_double -opt_d_ddd_fff1 (opt_info* o) { - s7_double x1= q_func1 (o).d_v_f (q_func1_arg (o).gen); - s7_double x2= q_func2 (o).d_v_f (q_func2_arg (o).gen); - s7_double x3= q_func3 (o).d_v_f (q_func3_arg (o).gen); - return (q_func (o).d_ddd_f (x1, x2, x3)); -} - -static s7_double -opt_d_ddd_fff2 (opt_info* o) { - s7_double x1= q_func2 (o).d_v_f (q_func2_arg (o).gen); - s7_double x2= q_d_func3_call (o); - s7_double x3= q_d_func1_call (o); - return (q_func (o).d_ddd_f (x1, x2, x3)); -} - -static s7_double -opt_d_ddd_fff_mul (opt_info* o) { - s7_double x1= opt_D_s (q_func2_arg (o).o1); - s7_double x2= opt_D_s (q_func3_arg (o).o1); - s7_double x3= opt_d_s (q_func1_arg (o).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 (q_call (sc->opts[start]).fd != opt_d_v) return_false (sc, NULL); - o1 = sc->opts[start]; - q_func2 (opc).d_v_f = q_func (o1).d_v_f; - q_func2_arg (opc).gen= q_arg1 (o1).gen; - if ((q_call (sc->opts[start + 1]).fd == opt_d_v) && - (q_call (sc->opts[start + 2]).fd == opt_d_v)) { - opt_info* o2 = sc->opts[start + 2]; - o1 = sc->opts[start + 1]; - q_call (opc).fd = opt_d_ddd_fff1; - q_func1 (opc).d_v_f = q_func2 (opc).d_v_f; - q_func1_arg (opc).gen= q_func2_arg (opc).gen; - q_func2 (opc).d_v_f = q_func (o1).d_v_f; - q_func2_arg (opc).gen= q_arg1 (o1).gen; - q_func3 (opc).d_v_f = q_func (o2).d_v_f; - q_func3_arg (opc).gen= q_arg1 (o2).gen; - sc->pc-= 3; - return_true (sc, NULL); - } - q_call (opc).fd = opt_d_ddd_fff2; /* (* (d-v-func b) (d-v-func b) x) */ - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - q_func1 (opc).fd= q_func1_arg (opc).q_call (o1).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 arg1_slot; - const s7_pointer arg1= cadr (expr), arg2= caddr (expr); - const s7_d_ddd_t func= s7_d_ddd_function (s_func); - if (!func) return_false (sc, expr); - q_func (opc).d_ddd_f= func; - arg1_slot = opt_float_symbol (sc, arg1); - q_func2_arg (opc).o1= sc->opts[start]; - if (arg1_slot) { - s7_pointer arg2_slot; - q_arg1 (opc).p= arg1_slot; - arg2_slot = opt_float_symbol (sc, arg2); - if (arg2_slot) { - const s7_pointer arg3= cadddr (expr); - s7_pointer arg3_slot; - q_arg2 (opc).p= arg2_slot; - arg3_slot = opt_float_symbol (sc, arg3); - if (arg3_slot) { - q_arg3 (opc).p = arg3_slot; - q_call (opc).fd= opt_d_ddd_sss; - return_true (sc, expr); - } - if (float_optimize (sc, cdddr (expr))) { - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - q_call (opc).fd = opt_d_ddd_ssf; - return_true (sc, expr); - } - sc->pc= start; - } - if (float_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdddr (expr))) { - q_call (opc).fd = opt_d_ddd_sff; - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - return_true (sc, expr); - } - } - sc->pc= start; - } - if (float_optimize (sc, cdr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdddr (expr))) { - if (d_ddd_fff_combinable (sc, opc, start)) return_true (sc, expr); - q_call (opc).fd= opt_d_ddd_fff; /* tfft: (+ (* xout xin iw) (* yout yin - ih) (* zout zin id)) */ - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - q_func1 (opc).fd= q_func1_arg (opc).q_call (o1).fd; - if ((func == multiply_d_ddd) && (q_func2 (opc).fd == opt_D_s) && - (q_func3 (opc).fd == opt_D_s) && (q_func1 (opc).fd == opt_d_s)) - q_call (opc).fd= opt_d_ddd_fff_mul; - return_true (sc, expr); - } - } - } - sc->pc= start; - return_false (sc, expr); +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))); } -/* -------- d_7pid -------- */ - -static s7_double -opt_d_7pid_ssf (opt_info* o) { - return (q_func (o).d_7pid_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_d_func2_call (o))); +static bool c_object_is_aritable(s7_scheme *sc, s7_pointer clo, int32_t args) +{ + 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? */ } -static s7_pointer -opt_d_7pid_ssf_nr (opt_info* o) { - q_func (o).d_7pid_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), q_d_func2_call (o)); - return (NULL); +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_CLOSURE: + case T_MACRO: case T_BACRO: return(closure_is_aritable(sc, clo, closure_pars(clo), args)); + case T_CLOSURE_STAR: + case T_MACRO_STAR: case T_BACRO_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_ITERATOR: return(args == 0); + case T_SYNTAX: return((args >= syntax_min_args(clo)) && (args <= syntax_max_args(clo))); + case T_HASH_TABLE: return(args == 1); /* refers to implicit ref (table key) */ + case T_LET: case T_PAIR: return(args == 1); + case T_C_OBJECT: return(c_object_is_aritable(sc, clo, args)); + 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) && (args <= vector_rank(clo))); /* (#() 0) -> error */ + } + 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 num_args = cadr(args); + s7_int num; + if (!s7_is_integer(num_args)) /* remember gmp case! */ + return(method_or_bust(sc, num_args, sc->is_aritable_symbol, args, sc->type_names[T_INTEGER], 2)); + num = s7_integer_clamped_if_gmp(sc, num_args); + if (num < 0) + out_of_range_error_nr(sc, sc->is_aritable_symbol, int_two, num_args, it_is_negative_string); + if (num > MAX_ARITY) num = MAX_ARITY; + return(make_boolean(sc, s7_is_aritable(sc, car(args), num))); } -static s7_double -opt_d_7pid_sss (opt_info* o) { - return (q_func (o).d_7pid_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - real (slot_value (q_arg3 (o).p)))); -} - -static s7_double -opt_d_7pid_ssc (opt_info* o) { - return (q_func (o).d_7pid_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_arg3 (o).x)); -} - -static s7_double -opt_d_7pid_sff (opt_info* o) { - s7_int pos= q_i_func2_call (o); - return (q_func (o).d_7pid_f (o->sc, slot_value (q_arg1 (o).p), pos, - q_d_func3_call (o))); -} - -static s7_double -opt_d_7pid_sff_fvset (opt_info* o) { - s7_int pos= q_i_func2_call (o); - return (float_vector_set_d_7pid (o->sc, slot_value (q_arg1 (o).p), pos, - q_d_func3_call (o))); -} - -static s7_double -opt_d_7pid_sso (opt_info* o) { - return (q_func (o).d_7pid_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_func1 (o).d_v_f (q_func1_arg (o).gen))); -} - -static s7_double -opt_d_7pid_ss_ss (opt_info* o) { - return (q_func (o).d_7pid_f ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - q_func1 (o).d_7pi_f (o->sc, slot_value (q_arg3 (o).p), - integer (slot_value (q_arg4 (o).p))))); -} - -static s7_double -opt_d_7pid_ssfo (opt_info* o) { - s7_pointer fv= slot_value (q_arg1 (o).p); - return (q_func (o).d_7pid_f ( - o->sc, fv, integer (slot_value (q_arg2 (o).p)), - q_func2 (o).d_dd_f ( - q_func1 (o).d_7pi_f (o->sc, fv, integer (slot_value (q_arg3 (o).p))), - real (slot_value (q_arg4 (o).p))))); -} - -static s7_double -opt_d_7pid_ssfo_fv (opt_info* o) { - s7_double* els= float_vector_floats (slot_value (q_arg1 (o).p)); - s7_double val= q_func2 (o).d_dd_f (els[integer (slot_value (q_arg3 (o).p))], - real (slot_value (q_arg4 (o).p))); - els[integer (slot_value (q_arg2 (o).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 (q_arg1 (o).p)); - els[integer (slot_value (q_arg2 (o).p))]= - q_func2 (o).d_dd_f (els[integer (slot_value (q_arg3 (o).p))], - real (slot_value (q_arg4 (o).p))); - return (NULL); -} - -static s7_pointer -opt_d_7pid_ssfo_fv_add_nr (opt_info* o) { - s7_double* els= float_vector_floats (slot_value (q_arg1 (o).p)); - els[integer (slot_value (q_arg2 (o).p))]= - els[integer (slot_value (q_arg3 (o).p))] + - real (slot_value (q_arg4 (o).p)); - return (NULL); -} - -static s7_pointer -opt_d_7pid_ssfo_fv_sub_nr (opt_info* o) { - s7_double* els= float_vector_floats (slot_value (q_arg1 (o).p)); - els[integer (slot_value (q_arg2 (o).p))]= - els[integer (slot_value (q_arg3 (o).p))] - - real (slot_value (q_arg4 (o).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 (q_call (o1).fd == opt_d_v) { - q_func1_arg (opc).gen= q_arg1 (o1).gen; - q_func1 (opc).d_v_f = q_func (o1).d_v_f; - q_call (opc).fd = opt_d_7pid_sso; - backup_pc (sc); - return_true (sc, NULL); - } - if ((q_call (o1).fd == opt_d_7pi_ss) || - (q_call (o1).fd == opt_d_7pi_ss_fvref) || - (q_call (o1).fd == opt_d_7pi_ss_fvref_direct)) { - q_func1 (opc).d_7pi_f= q_func (o1).d_7pi_f; - q_arg3 (opc).p = q_arg1 (o1).p; - q_arg4 (opc).p = q_arg2 (o1).p; - q_call (opc).fd = opt_d_7pid_ss_ss; - backup_pc (sc); - return_true (sc, NULL); - } - if ((q_call (o1).fd == opt_d_dd_fso) && (q_arg1 (opc).p == q_arg2 (o1).p)) { - q_func2 (opc).d_dd_f = q_func (o1).d_dd_f; - q_func1 (opc).d_7pi_f= q_func1 (o1).d_7pi_f; - q_arg3 (opc).p = q_arg3 (o1).p; - q_arg4 (opc).p = q_arg1 (o1).p; - q_call (opc).fd = opt_d_7pid_ssfo; - if (((q_func1 (opc).d_7pi_f == float_vector_ref_d_7pi) || - (q_func1 (opc).d_7pi_f == float_vector_ref_d_7pi_direct)) && - ((q_func (opc).d_7pid_f == float_vector_set_d_7pid_direct) || - (q_func (opc).d_7pid_f == float_vector_set_d_7pid))) - q_call (opc).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 func= s7_d_7pid_function (s_func); - if ((func) && (is_symbol (cadr (expr)))) { - const s7_pointer head = car (expr); - const int32_t start= sc->pc; - q_func (opc).d_7pid_f = func; - - 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))); - - q_arg1 (opc).p= s7_slot (sc, cadr (expr)); - if (!is_slot (q_arg1 (opc).p)) return_false (sc, expr); - q_func2_arg (opc).o1= sc->opts[start]; - if (is_slot (q_arg1 (opc).p)) { - s7_pointer arg2_slot= opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - s7_pointer arg3_slot; - q_arg2 (opc).p= arg2_slot; - arg3_slot = opt_float_symbol (sc, cadddr (expr)); - if (arg3_slot) { - q_arg3 (opc).p = arg3_slot; - q_call (opc).fd= opt_d_7pid_sss; - return_true (sc, expr); - } - if (float_optimize (sc, cdddr (expr))) { - q_func2 (opc).fd= q_call (sc->opts[start]).fd; - if (d_7pid_ssf_combinable (sc, opc)) return_true (sc, expr); - q_call (opc).fd= opt_d_7pid_ssf; - return_true (sc, expr); - } - sc->pc= start; - } - if (int_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdddr (expr))) { - q_call (opc).fd = opt_d_7pid_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - return_true (sc, expr); - } - } - sc->pc= start; - } - } - return_false (sc, expr); -} +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);} -/* -------- 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) { - return (float_vector_ref_d_7pii (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)))); -} - -static s7_double -opt_d_7pii_sss_unchecked (opt_info* o) { - s7_pointer vec= slot_value (q_arg1 (o).p); - return (float_vector ( - vec, ((integer (slot_value (q_arg2 (o).p)) * vector_offset (vec, 0)) + - integer (slot_value (q_arg3 (o).p))))); -} - -static s7_double -opt_d_7pii_scs (opt_info* o) { - return (float_vector_ref_d_7pii (o->sc, slot_value (q_arg1 (o).p), - q_arg2 (o).i, - integer (slot_value (q_arg3 (o).p)))); -} - -static s7_double -opt_d_7pii_sff (opt_info* o) { - return (float_vector_ref_d_7pii (o->sc, slot_value (q_arg1 (o).p), - q_i_func2_call (o), q_i_func3_call (o))); -} - -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 arg3_slot; - const int32_t start= sc->pc; - q_arg1 (opc).p = s7_slot (sc, cadr (expr)); - if ((!is_slot (q_arg1 (opc).p)) || - (!is_float_vector (slot_value (q_arg1 (opc).p))) || - (vector_rank (slot_value (q_arg1 (opc).p)) != 2)) - return_false (sc, expr); - - arg3_slot= opt_integer_symbol (sc, cadddr (expr)); - if (arg3_slot) { - s7_pointer arg2_slot; - q_arg3 (opc).p= arg3_slot; - arg2_slot = opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - q_arg2 (opc).p = arg2_slot; - q_call (opc).fd= opt_d_7pii_sss; - if ((loop_end_fits ( - q_arg2 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), - 0))) && /* see also d_implicit_ok */ - (loop_end_fits (q_arg3 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 1)))) - q_call (opc).fd= opt_d_7pii_sss_unchecked; - return_true (sc, expr); - } - if (is_t_integer (caddr (expr))) { - q_arg2 (opc).i = integer (caddr (expr)); - q_call (opc).fd= opt_d_7pii_scs; - return_true (sc, expr); - } - } - q_func2_arg (opc).o1= sc->opts[start]; - if (int_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdddr (expr))) { - q_call (opc).fd = opt_d_7pii_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } +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_CLOSURE: + case T_MACRO: case T_BACRO: args = closure_arity_to_int(sc, clo); return((args < 0) ? MAX_ARITY : args); + case T_CLOSURE_STAR: + case T_MACRO_STAR: case T_BACRO_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) */ } - sc->pc= start; - } - return_false (sc, expr); + if (S7_DEBUGGING) fprintf(stderr, "%s -1\n", __func__); + return(-1); /* unreachable I think */ } -/* -------- d_7piid -------- */ -/* currently only float_vector_set */ -static s7_double -opt_d_7piid_sssf (opt_info* o) { - return (float_vector_set_d_7piid ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), q_d_func3_call (o))); -} - -static s7_double -opt_d_7piid_sssc (opt_info* o) { - return (float_vector_set_d_7piid ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), q_arg4 (o).x)); -} - -static s7_double -opt_d_7piid_scsf (opt_info* o) { - return (float_vector_set_d_7piid ( - o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).i, - integer (slot_value (q_arg3 (o).p)), q_d_func2_call (o))); -} - -static s7_double -opt_d_7piid_sfff (opt_info* o) { - s7_int i1 = q_i_func2_call (o); - s7_int i2 = q_i_func3_call (o); - s7_double val= q_d_func4_call (o); - return ( - float_vector_set_d_7piid (o->sc, slot_value (q_arg1 (o).p), i1, i2, val)); -} - -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 (q_arg2 (o).p)), - i2 = integer (slot_value (q_arg3 (o).p)); - s7_pointer vect= slot_value (q_arg1 (o).p); - s7_double val = q_d_func3_call (o); - 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)))) { - 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); -} +/* -------------------------------- sequence? -------------------------------- */ +/* g_is_sequence is now defined in s7_scheme_predicate.c */ +#define H_is_sequence "(sequence? obj) returns #t if obj is a sequence (vector, string, pair, etc)" +#define Q_is_sequence sc->pl_bt -/* -------- d_7piii -------- */ -static s7_double -opt_d_7piii_ssss (opt_info* o) { - return (float_vector_ref_d_7piii (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), - integer (slot_value (q_arg4 (o).p)))); -} - -static s7_double -opt_d_7piii_ssss_unchecked (opt_info* o) -/* not in s7test (tvect: ((do ((i 0...))) ((= i ...)) (do ((n 0 ...)) ((= n - ...)) (set! sum (+ sum (float-vector-ref v k i n)))))) */ -{ - s7_pointer vec= slot_value (q_arg1 (o).p); - s7_int i1 = integer (slot_value (q_arg2 (o).p)) * vector_offset (vec, 0); - s7_int i2 = integer (slot_value (q_arg3 (o).p)) * - vector_offset (vec, 1); /* offsets accumulate */ - return (float_vector (vec, (i1 + i2 + integer (slot_value (q_arg4 (o).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 arg4_slot; - q_arg1 (opc).p= s7_slot (sc, cadr (expr)); - if ((!is_slot (q_arg1 (opc).p)) || - (!is_float_vector (slot_value (q_arg1 (opc).p))) || - (vector_rank (slot_value (q_arg1 (opc).p)) != 3)) - return_false (sc, expr); - arg4_slot= opt_integer_symbol (sc, car (cddddr (expr))); - if (arg4_slot) { - s7_pointer arg3_slot; - q_arg4 (opc).p= arg4_slot; - arg3_slot = opt_integer_symbol (sc, cadddr (expr)); - if (arg3_slot) { - s7_pointer arg2_slot; - q_arg3 (opc).p= arg3_slot; - arg2_slot = opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - const s7_pointer vect= slot_value (q_arg1 (opc).p); - q_arg2 (opc).p = arg2_slot; - q_call (opc).fd = opt_d_7piii_ssss; - if ((loop_end_fits (q_arg2 (opc).p, vector_dimension (vect, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (vect, 1))) && - (loop_end_fits (q_arg4 (opc).p, vector_dimension (vect, 2)))) - q_call (opc).fd= opt_d_7piii_ssss_unchecked; - return_true (sc, expr); - } - } - } - } - return_false (sc, expr); +static bool is_sequence_b(s7_pointer seq) {return(is_simple_sequence(seq));} + + +/* -------------------------------- setter ------------------------------------------------ */ +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_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)); } -/* -------- d_7piiid -------- */ -static s7_double -opt_d_7piiid_ssssf (opt_info* o) { - return (float_vector_set_d_7piiid ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), integer (slot_value (q_arg4 (o).p)), - q_d_func2_call (o))); -} - -static s7_double -opt_d_7piiid_ssssf_unchecked (opt_info* o) { - s7_pointer vect= slot_value (q_arg1 (o).p); - s7_int i1 = integer (slot_value (q_arg2 (o).p)) * vector_offset (vect, 0); - s7_int i2 = integer (slot_value (q_arg3 (o).p)) * vector_offset (vect, 1); - s7_int i3 = integer (slot_value (q_arg4 (o).p)); - s7_double val= q_d_func2_call (o); - 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)))) { - const s7_pointer vect = slot_value (settee); - const int32_t start= sc->pc; - q_arg1 (opc).p = settee; - if (!is_float_vector (vect)) return_false (sc, vect); - q_func2_arg (opc).o1= sc->opts[start]; - if ((!indexp2) && (vector_rank (vect) == 1)) { - s7_pointer ind1_slot; - q_func (opc).d_7pid_f= float_vector_set_d_7pid; - ind1_slot = opt_integer_symbol (sc, car (indexp1)); - if (ind1_slot) { - s7_pointer val_slot; - q_arg2 (opc).p= ind1_slot; - if (loop_end_fits (q_arg2 (opc).p, vector_length (vect))) - q_func (opc).d_7pid_f= float_vector_set_d_7pid_direct; - val_slot= opt_float_symbol (sc, car (valp)); - if (val_slot) { - q_arg3 (opc).p = val_slot; - q_call (opc).fd= opt_d_7pid_sss; - return_true (sc, NULL); - } - if (is_small_real (car (valp))) { - q_arg3 (opc).x = s7_real (car (valp)); - q_call (opc).fd= opt_d_7pid_ssc; - return_true (sc, NULL); - } - if (float_optimize (sc, valp)) { - q_func2 (opc).fd= q_call (sc->opts[start]).fd; - if (d_7pid_ssf_combinable (sc, opc)) return_true (sc, NULL); - q_call (opc).fd= opt_d_7pid_ssf; - return_true (sc, NULL); - } - sc->pc= start; - } - if (int_optimize (sc, indexp1)) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, valp)) { - q_call (opc).fd = (q_func (opc).d_7pid_f == float_vector_set_d_7pid) - ? opt_d_7pid_sff_fvset - : opt_d_7pid_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - return_true (sc, NULL); - } - } - return_false (sc, indexp1); - } - if ((indexp2) && (!indexp3) && (vector_rank (vect) == 2)) { - s7_pointer ind2_slot; - q_func1 (opc).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 - * q_call(opc).fd = fvset_unchecked_d_7piid or whatever - */ - ind2_slot= opt_integer_symbol (sc, car (indexp2)); - if (ind2_slot) { - s7_pointer ind1_slot; - q_arg3 (opc).p= ind2_slot; - if (is_t_integer (car (indexp1))) { - if (!float_optimize (sc, valp)) return_false (sc, valp); - q_call (opc).fd = opt_d_7piid_scsf; - q_arg2 (opc).i = integer (car (indexp1)); - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - return_true (sc, NULL); - } - ind1_slot= opt_integer_symbol (sc, car (indexp1)); - if (ind1_slot) { - q_arg2 (opc).p= ind1_slot; - if (is_small_real (car (valp))) { - q_call (opc).fd= opt_d_7piid_sssc; - q_arg4 (opc).x = s7_real (car (valp)); - return_true (sc, NULL); - } - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, valp)) { - q_call (opc).fd = opt_d_7piid_sssf; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - if ((loop_end_fits (q_arg2 (opc).p, vector_dimension (vect, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (vect, 1)))) - q_call (opc).fd= opt_d_7piid_sssf_unchecked; - return_true (sc, NULL); - } - sc->pc= start; - } - } - if (int_optimize (sc, indexp1)) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp2)) { - q_func4_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, valp)) { - q_call (opc).fd = opt_d_7piid_sfff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - q_func4 (opc).fd= q_func4_arg (opc).q_call (o1).fd; - return_true (sc, NULL); - } - } - } - return_false (sc, indexp1); - } - if ((indexp3) && (vector_rank (vect) == 3)) { - s7_pointer ind3_slot; - ind3_slot= opt_integer_symbol (sc, car (indexp3)); - if (ind3_slot) { - s7_pointer ind2_slot; - q_arg4 (opc).p= ind3_slot; - ind2_slot = opt_integer_symbol (sc, car (indexp2)); - if (ind2_slot) { - s7_pointer ind1_slot; - q_arg3 (opc).p= ind2_slot; - ind1_slot = opt_integer_symbol (sc, car (indexp1)); - if (ind1_slot) { - q_arg2 (opc).p= ind1_slot; - if (float_optimize (sc, valp)) { - q_call (opc).fd = opt_d_7piiid_ssssf; - q_func2 (opc).fd= q_call (sc->opts[start]).fd; - if ((loop_end_fits (q_arg2 (opc).p, - vector_dimension (vect, 0))) && - (loop_end_fits (q_arg3 (opc).p, - vector_dimension (vect, 1))) && - (loop_end_fits (q_arg4 (opc).p, vector_dimension (vect, 2)))) - q_call (opc).fd= opt_d_7piiid_ssssf_unchecked; - return_true (sc, NULL); - } - } - } - } +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_false (sc, NULL); + return(sc->F); } -/* -------- d_vid -------- */ -static s7_double -opt_d_vid_ssf (opt_info* o) { - return (q_func (o).d_vid_f ( - q_arg1 (o).gen, integer (slot_value (q_arg2 (o).p)), q_d_func2_call (o))); -} - -static inline s7_double -opt_fmv (opt_info* o) { - opt_info* o1 = q_arg3 (o).o1; /* opt_d_dd_ff_mul1 */ - opt_info* o2 = q_arg4 (o).o1; /* opt_d_vd_o1 */ - opt_info* o3 = q_arg5 (o).o1; /* opt_d_dd_ff_o3 */ - s7_double amp_env = q_func3 (o1).d_v_f (q_arg1 (o1).gen); - s7_double vib = real (slot_value (q_arg2 (o2).p)); - s7_double index_env= q_func3 (o3).d_v_f (q_arg1 (o3).gen); - return (q_func (o).d_vid_f ( - q_arg1 (o).gen, integer (slot_value (q_arg2 (o).p)), - amp_env * - q_func (o2).d_vd_f ( - q_arg1 (o2).gen, - vib + (index_env * q_func2 (o3).d_vd_f (q_arg2 (o3).gen, 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); - q_func (opc).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 arg2_slot; - q_call (opc).fd = opt_d_vid_ssf; - q_arg1 (opc).p = vslot; - q_func2_arg (opc).o1= sc->opts[start]; - arg2_slot = opt_integer_symbol (sc, caddr (expr)); - if ((arg2_slot) && (float_optimize (sc, cdddr (expr)))) { - opt_info* o2; - q_arg2 (opc).p = arg2_slot; - q_arg1 (opc).gen= (void*) c_object_value (slot_value (vslot)); - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - o2 = sc->opts[start]; - if (q_call (o2).fd == opt_d_dd_ff_mul1) { - opt_info* o3= sc->opts[start + 2]; - if (q_call (o3).fd == opt_d_vd_o1) { - opt_info* o1= sc->opts[start + 4]; - if ((q_call (o1).fd == opt_d_dd_ff_o3) && - (q_func1 (o1).d_dd_f == multiply_d_dd) && - (q_func3 (o3).d_dd_f == add_d_dd)) { - q_call (opc).fd= - opt_fmv; /* expr: (locsig locs i (* (env ampf) (oscil - carrier (+ vib (* (env indf1) (polywave fmosc1 - vib)))))) */ - q_arg3 (opc).o1= o2; /* opt_d_dd_ff_mul1 */ - q_arg4 (opc).o1= o3; /* opt_d_vd_o1 */ - q_arg5 (opc).o1= o1; /* opt_d_dd_ff_o3 */ - } - } - } - return_true (sc, expr); - } - } - sc->pc= start; +static s7_pointer symbol_setter(s7_scheme *sc, s7_pointer sym, s7_pointer let) +{ + s7_pointer slot; + if (is_keyword(sym)) return(sc->F); + if (let == sc->rootlet) + slot = global_slot(sym); + else + { + s7_pointer old_let = sc->curlet; + set_curlet(sc, let); + slot = s7_slot(sc, sym); + set_curlet(sc, old_let); } + 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); } - return_false (sc, expr); } -/* -------- d_vdd -------- */ -static s7_double -opt_d_vdd_ff (opt_info* o) { - s7_double x1= q_d_func2_call (o); - s7_double x2= q_d_func3_call (o); - return (q_func (o).d_vdd_f (q_arg1 (o).gen, 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); - q_func (opc).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; - q_func2_arg (opc).o1= sc->opts[start]; - if (float_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdddr (expr))) { - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - q_arg1 (opc).gen= (void*) c_object_value (slot_value (slot)); - q_call (opc).fd = opt_d_vdd_ff; - return_true (sc, expr); - } - } - sc->pc= start; - } +static s7_pointer setter_p_pp(s7_scheme *sc, s7_pointer obj, s7_pointer let) +{ + 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->setter_symbol, let, new_let, 2, set_mlist_2(sc, obj, let)); + let = new_let; } - } - return_false (sc, expr); -} + 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)); -/* -------- d_dddd -------- */ + case T_C_FUNCTION: case T_C_FUNCTION_STAR: case T_C_RST_NO_REQ_FUNCTION: + return(c_function_setter(obj)); -static s7_double -opt_d_dddd_ffff (opt_info* o) { - s7_double x1= q_d_func1_call (o); - s7_double x2= q_d_func2_call (o); - s7_double x3= q_d_func3_call (o); - s7_double x4= q_d_func4_call (o); - return (q_func (o).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 func= s7_d_dddd_function (s_func); - if (!func) return_false (sc, expr); - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdr (expr))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdddr (expr))) { - q_func4_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddddr (expr))) { - q_func (opc).d_dddd_f= func; - q_call (opc).fd = opt_d_dddd_ffff; - q_func1 (opc).fd = q_func1_arg (opc).q_call (o1).fd; - q_func2 (opc).fd = q_func2_arg (opc).q_call (o1).fd; - q_func3 (opc).fd = q_func3_arg (opc).q_call (o1).fd; - q_func4 (opc).fd = q_func4_arg (opc).q_call (o1).fd; - return_true (sc, expr); - } - } - } - } - return_false (sc, expr); -} + case T_C_MACRO: + return(c_macro_setter(obj)); -/* -------- d_add|multiply|subtract_any ------- */ -#define q_d_am_arg(o, i) o->v[i + 2] + case T_C_OBJECT: + if_c_object_method_exists_return_value(sc, obj, sc->setter_symbol, set_plist_2(sc, obj, let)); + 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 */ -static s7_double -opt_d_add_any_f (opt_info* o) { - s7_double sum= 0.0; - for (s7_int i= 0; i < q_arg1 (o).i; i++) { - opt_info* o1= q_d_am_arg (o, i).o1; - sum+= q_call (o1).fd (o1); - } - return (sum); -} + case T_LET: + if_let_method_exists_return_value(sc, obj, sc->setter_symbol, set_plist_2(sc, obj, let)); + return(global_value(sc->let_set_symbol)); -static s7_double -opt_d_multiply_any_f (opt_info* o) { - s7_double sum= 1.0; - for (s7_int i= 0; i < q_arg1 (o).i; i++) { - opt_info* o1= q_d_am_arg (o, i).o1; - sum*= q_call (o1).fd (o1); - } - return (sum); -} + 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); -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++) { - q_d_am_arg (opc, cur_len).o1= sc->opts[sc->pc]; - if (!float_optimize (sc, p)) break; - } - if (is_null (p)) { - q_arg1 (opc).i= cur_len; - q_call (opc).fd= - (head == sc->add_symbol) ? opt_d_add_any_f : opt_d_multiply_any_f; - return_true (sc, expr); + 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, let)); /* (setter symbol let) */ } - } - sc->pc= start; - return_false (sc, expr); + /* 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); } -/* -------- d_syntax -------- */ -static s7_double -opt_set_d_d_f (opt_info* o) { - s7_double x= q_func (o).fd (q_arg2 (o).o1); - slot_set_value (q_arg1 (o).p, make_real (o->sc, x)); - return (x); -} - -static s7_double -opt_set_d_d_fm (opt_info* o) { - s7_double x= q_func (o).fd (q_arg2 (o).o1); - check_mutability (o->sc, o, __func__, __LINE__); - set_real (slot_value (q_arg1 (o).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]; - q_arg1 (opc).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 - */ - q_call (opc).fd= (is_mutable_number (slot_value (q_arg1 (opc).p))) - ? opt_set_d_d_fm - : opt_set_d_d_f; - q_arg2 (opc).o1= o1; - q_func (opc).fd= q_call (o1).fd; - return_true (sc, expr); - } - } +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));} + +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) +{ + 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 *old_b = vector_block(sc->protected_setters); /* old_b is liberated by reallocate below */ + block_t *new_b = reallocate(sc, old_b, new_size * sizeof(s7_pointer)); + block_info(new_b) = NULL; + vector_block(sc->protected_setters) = new_b; + vector_elements(sc->protected_setters) = (s7_pointer *)block_data(new_b); + vector_length(sc->protected_setters) = new_size; + + old_b = vector_block(sc->protected_setter_symbols); /* old_b is liberated by reallocate below */ + new_b = reallocate(sc, old_b, new_size * sizeof(s7_pointer)); + vector_block(sc->protected_setter_symbols) = new_b; + vector_elements(sc->protected_setter_symbols) = (s7_pointer *)block_data(new_b); + 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; } - 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))); - } + { + s7_int 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; } - return_false (sc, expr); } -static bool -d_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_float_vector (obj)) { - /* implicit float-vector-ref */ - if ((len == 2) && (vector_rank (obj) == 1)) { - s7_pointer arg1_slot; - opt_info* opc = alloc_opt_info (sc); - q_arg1 (opc).p = s_slot; - q_func (opc).d_7pi_f= float_vector_ref_d_7pi; - arg1_slot = opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - q_arg2 (opc).p= arg1_slot; - if (loop_end_fits (q_arg2 (opc).p, vector_length (obj))) - q_call (opc).fd= opt_d_7pi_ss_fvref_direct; - else q_call (opc).fd= opt_d_7pi_ss_fvref; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (!int_optimize (sc, cdr (expr))) return_false (sc, expr); - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_call (opc).fd = opt_d_7pi_sf; - return_true (sc, expr); - } - if ((len == 3) && (vector_rank (obj) == 2)) { - s7_pointer arg1_slot; - opt_info* opc= alloc_opt_info (sc); - q_arg1 (opc).p= s_slot; - q_func1 (opc).d_7pii_f= - float_vector_ref_d_7pii; /* not used in opt_d_7pii_sss_unchecked or - opt_d_7pii_sff, but d_dd_ok checks it */ - arg1_slot= opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - s7_pointer arg2_slot; - q_arg2 (opc).p= arg1_slot; - arg2_slot = opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - q_arg3 (opc).p = arg2_slot; - q_call (opc).fd= opt_d_7pii_sss; - if ((loop_end_fits (q_arg2 (opc).p, vector_dimension (obj, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (obj, 1)))) - q_call (opc).fd= opt_d_7pii_sss_unchecked; - return_true (sc, expr); - } - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_call (opc).fd = opt_d_7pii_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - } - } - if ((len == 4) && (vector_rank (obj) == 3)) { - s7_pointer arg1_slot; - opt_info* opc= alloc_opt_info (sc); - q_arg1 (opc).p= s_slot; - arg1_slot = opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - s7_pointer arg2_slot; - q_arg2 (opc).p= arg1_slot; - arg2_slot = opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - s7_pointer arg3_slot; - q_arg3 (opc).p= arg2_slot; - arg3_slot = opt_integer_symbol (sc, cadddr (expr)); - if (arg3_slot) { - q_arg4 (opc).p = arg3_slot; - q_call (opc).fd= opt_d_7piii_ssss; - if ((loop_end_fits (q_arg2 (opc).p, vector_dimension (obj, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (obj, 1))) && - (loop_end_fits (q_arg4 (opc).p, vector_dimension (obj, 2)))) - q_call (opc).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) { - s7_pointer arg1_slot; - opt_info* opc= alloc_opt_info (sc); - q_arg1 (opc).p= s_slot; - /* opc-v[4].gen = (void *)c_object_value(obj); */ - q_func (opc).d_7pi_f= func; - arg1_slot = opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - q_call (opc).fd= opt_d_7pi_ss; - q_arg2 (opc).p = arg1_slot; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_call (opc).fd = opt_d_7pi_sf; - return_true (sc, expr); - } - } +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 let = cadr(args); /* (let ((x 1)) (set! (setter 'x (curlet)) (lambda (s v e) ...))): args is (x (inlet 'x 1) #) */ + func = caddr(args); + if (let == sc->rootlet) + slot = global_slot(sym); + else + { + 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, wrap_string(sc, "set! setter", 11), let, new_let, 2, args); + let = new_let; + } + slot = lookup_slot_with_let(sc, sym, let); + }} + else + { + slot = s7_slot(sc, sym); /* (set! (setter 'x) (lambda (s v) ...)): args is: (x #) */ + func = cadr(args); } - } - return_false (sc, expr); -} + if (!is_slot(slot)) + return(sc->F); -/* -------------------------------- bool opts -------------------------------- - */ + 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)) /* this will 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)); -static bool -opt_b_s (opt_info* o) { - return (slot_value (q_arg1 (o).p) != o->sc->F); -} + 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; -static bool -opt_bool_not_pair (s7_scheme* sc, s7_pointer expr) { - s7_pointer slot; - if (!is_symbol (expr)) return_false (sc, expr); /* i.e. use cell_optimize */ - slot= opt_simple_symbol (sc, expr); - if ((slot) && (is_boolean (slot_value (slot)))) { - opt_info* opc = alloc_opt_info (sc); - q_arg1 (opc).p = slot; - q_call (opc).fb= opt_b_s; - return_true (sc, expr); - } - return_false (sc, expr); -} + 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; -/* -------- b_idp -------- */ -static bool -opt_b_i_s (opt_info* o) { - return (q_func (o).b_i_f (integer (slot_value (q_arg1 (o).p)))); -} -static bool -opt_b_i_f (opt_info* o) { - return (q_func (o).b_i_f (q_i_func1_call (o))); -} -static bool -opt_b_d_s (opt_info* o) { - return (q_func (o).b_d_f (s7_real (slot_value (q_arg1 (o).p)))); -} /* not s7test tmap */ -static bool -opt_b_d_f (opt_info* o) { - return (q_func (o).b_d_f (q_d_func1_call (o))); -} -static bool -opt_b_p_s (opt_info* o) { - return (q_func (o).b_p_f (slot_value (q_arg1 (o).p))); -} -static bool -opt_b_p_f (opt_info* o) { - return (q_func (o).b_p_f (q_p_func1_call (o))); -} /* used in opt_if_nbp_s */ -static bool -opt_b_7p_s (opt_info* o) { - return (q_func (o).b_7p_f (o->sc, slot_value (q_arg1 (o).p))); -} -static bool -opt_b_7p_s_not (opt_info* o) { - return (slot_value (q_arg1 (o).p) == o->sc->F); -} /* not s7test *shoot */ -static bool -opt_b_7p_f (opt_info* o) { - return (q_func (o).b_7p_f (o->sc, q_p_func1_call (o))); -} -static bool -opt_b_d_s_is_positive (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) > 0.0); -} -static bool -opt_b_p_s_is_integer (opt_info* o) { - return (s7_is_integer (slot_value (q_arg1 (o).p))); -} /* not s7test tmap */ -static bool -opt_b_p_s_is_pair (opt_info* o) { - return (is_pair (slot_value (q_arg1 (o).p))); -} -static bool -opt_b_p_f_is_string (opt_info* o) { - return (s7_is_string (q_p_func1_call (o))); -} -static bool -opt_b_7p_s_iter_at_end (opt_info* o) { - return (iterator_is_at_end (slot_value (q_arg1 (o).p))); -} -static bool -opt_b_7p_f_not (opt_info* o) { - return ((q_p_func1_call (o)) == o->sc->F); -} - -static bool -opt_zero_mod (opt_info* o) { - s7_int x= integer (slot_value (q_arg1 (o).p)); - return ((x % q_arg2 (o).i) == 0); -} - -static bool -just_ints (s7_scheme* sc, s7_pointer form) { - if (is_pair (form)) - return ((just_ints (sc, car (form))) && (just_ints (sc, cdr (form)))); - return ((!is_number (form)) || (is_t_integer (form))); -} - -static bool -just_floats (s7_scheme* sc, s7_pointer form) { - if (is_pair (form)) - return ((just_floats (sc, car (form))) && (just_floats (sc, cdr (form)))); - return ((!is_number (form)) || (is_t_real (form))); -} - -static bool -b_idp_ok (s7_scheme* sc, const s7_pointer s_func, const s7_pointer form, - const s7_pointer arg_type) { - opt_info* opc = alloc_opt_info (sc); - const int32_t cur_index= sc->pc; - s7_pointer expr = car (form); - - if (((arg_type == sc->is_integer_symbol) || - (arg_type == sc->is_byte_symbol)) && - (just_ints (sc, form))) { - const s7_b_i_t bif= s7_b_i_function (s_func); - if (bif) { - q_func (opc).b_i_f= bif; - if (is_symbol (cadr (expr))) { - q_arg1 (opc).p = s7_t_slot (sc, cadr (expr)); - q_call (opc).fb= opt_b_i_s; - return_true (sc, expr); - } - q_func1_arg (opc).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) && - (q_call (o1).fi == opt_i_ii_sc) && - (q_func (o1).i_ii_f == modulo_i_ii_unchecked)) { - q_call (opc).fb= opt_zero_mod; - q_arg1 (opc).p = q_arg1 (o1).p; - q_arg2 (opc).i = q_arg2 (o1).i; - backup_pc (sc); - return_true (sc, expr); - } - q_call (opc).fb = opt_b_i_f; - q_func1 (opc).fi= q_func1_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - } - } - else if ((arg_type == sc->is_float_symbol) && (just_floats (sc, form))) { - const s7_b_d_t bdf= s7_b_d_function (s_func); - if (bdf) { - q_func (opc).b_d_f= bdf; - if (is_symbol (cadr (expr))) { - q_arg1 (opc).p= s7_t_slot (sc, cadr (expr)); - q_call (opc).fb= - (bdf == positive_d) ? opt_b_d_s_is_positive : opt_b_d_s; - return_true (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdr (expr))) { - q_call (opc).fb = opt_b_d_f; - q_func1 (opc).fd= q_func1_arg (opc).q_call (o1).fd; - return_true (sc, expr); - } - } - } - sc->pc= cur_index; - { - s7_b_p_t bpf = s7_b_p_function (s_func); - s7_b_7p_t bpf7= NULL; - if (!bpf) bpf7= s7_b_7p_function (s_func); - if ((bpf) || (bpf7)) { - if (bpf) q_func (opc).b_p_f= bpf; - else q_func (opc).b_7p_f= bpf7; - if (is_symbol (cadr (expr))) { - const s7_pointer slot= opt_simple_symbol (sc, cadr (expr)); - if (!slot) return_false (sc, expr); - q_arg1 (opc).p= slot; - q_call (opc).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 (slot)))) - ? opt_b_7p_s_iter_at_end - : ((bpf7 == not_b_7p) ? opt_b_7p_s_not : opt_b_7p_s)); - return_true (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - q_call (opc).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; - q_func1 (opc).fp= q_func1_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - } - } - return_false (sc, expr); -} + case T_C_MACRO: + c_macro_set_setter(obj, setter); + if (has_closure_let(setter)) + add_setter(sc, obj, setter); + break; -/* -------- b_pp -------- */ -static s7_pointer -opt_arg_type (s7_scheme* sc, s7_pointer argp) { - 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 (sc, car (arg))) && (is_pair (cdr (arg)))) - return (s7_type_of (sc, cadr (arg))); - } - { - s7_pointer arg_slot= s7_slot (sc, car (arg)); - if ((is_slot (arg_slot)) && (is_sequence (slot_value (arg_slot)))) { - s7_pointer sig= s7_signature (sc, slot_value (arg_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)) { - s7_pointer arg_slot= opt_simple_symbol (sc, arg); - if (!arg_slot) return (sc->T); - return (s7_type_of (sc, slot_value (arg_slot))); - } - return (s7_type_of (sc, arg)); -} - -static bool -opt_b_pp_sf (opt_info* o) { - return (q_func (o).b_pp_f (slot_value (q_arg1 (o).p), q_p_func2_call (o))); -} -static bool -opt_b_pp_fs (opt_info* o) { - return (q_func (o).b_pp_f (q_p_func2_call (o), slot_value (q_arg2 (o).p))); -} -static bool -opt_b_pp_ss (opt_info* o) { - return ( - q_func (o).b_pp_f (slot_value (q_arg1 (o).p), slot_value (q_arg2 (o).p))); -} -static bool -opt_b_pp_sc (opt_info* o) { - return (q_func (o).b_pp_f (slot_value (q_arg1 (o).p), q_arg2 (o).p)); -} -static bool -opt_b_pp_sfo (opt_info* o) { - return ( - q_func (o).b_pp_f (slot_value (q_arg1 (o).p), - q_func1 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)))); -} -static bool -opt_b_7pp_sf (opt_info* o) { - return (q_func (o).b_7pp_f (o->sc, slot_value (q_arg1 (o).p), - q_p_func2_call (o))); -} -static bool -opt_b_7pp_fs (opt_info* o) { - return (q_func (o).b_7pp_f (o->sc, q_p_func2_call (o), - slot_value (q_arg2 (o).p))); -} -static bool -opt_b_7pp_ss (opt_info* o) { - return (q_func (o).b_7pp_f (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p))); -} -static bool -opt_b_7pp_ss_lt (opt_info* o) { - return ( - lt_b_7pp (o->sc, slot_value (q_arg1 (o).p), slot_value (q_arg2 (o).p))); -} -static bool -opt_b_7pp_ss_gt (opt_info* o) { - return ( - gt_b_7pp (o->sc, slot_value (q_arg1 (o).p), slot_value (q_arg2 (o).p))); -} -static bool -opt_b_7pp_ss_char_lt (opt_info* o) { - return (char_lt_b_7pp (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p))); -} -static bool -opt_b_7pp_sc (opt_info* o) { - return (q_func (o).b_7pp_f (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).p)); -} -static bool -opt_b_7pp_sfo (opt_info* o) { - return (q_func (o).b_7pp_f ( - o->sc, slot_value (q_arg1 (o).p), - q_func1 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)))); -} -static bool -opt_is_equal_sfo (opt_info* o) { - return (s7_is_equal (o->sc, slot_value (q_arg1 (o).p), - q_func1 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)))); -} -static bool -opt_is_equivalent_sfo (opt_info* o) { - return (is_equivalent_1 (o->sc, slot_value (q_arg1 (o).p), - q_func1 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)), - NULL)); -} -static bool -opt_b_pp_sf_char_eq (opt_info* o) { - return (slot_value (q_arg1 (o).p) == q_p_func2_call (o)); -} /* lt above checks for char args */ -static bool -opt_b_7pp_ff (opt_info* o) { - s7_pointer p= q_p_func3_call (o); - return (q_func (o).b_7pp_f (o->sc, p, q_p_func2_call (o))); -} -static bool -opt_b_pp_ff (opt_info* o) { - s7_pointer p= q_p_func3_call (o); - return (q_func (o).b_pp_f (p, q_p_func2_call (o))); -} -static bool -opt_b_pp_ff_char_eq (opt_info* o) { - return (q_p_func3_call (o) == q_p_func2_call (o)); -} -static bool -opt_b_pp_fc_char_eq (opt_info* o) { - return (q_p_func3_call (o) == q_arg1 (o).p); -} -static bool -opt_b_pp_fc (opt_info* o) { - return (q_func (o).b_pp_f (q_p_func3_call (o), q_arg1 (o).p)); -} -static bool -opt_b_7pp_fc (opt_info* o) { - return (q_func (o).b_7pp_f (o->sc, q_p_func3_call (o), q_arg1 (o).p)); -} - -static bool -opt_car_equal_sf (opt_info* o) { - s7_pointer p= slot_value (q_arg2 (o).p); - return (s7_is_equal (o->sc, slot_value (q_arg1 (o).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 (q_arg2 (o).p); - return (is_equivalent_1 ( - o->sc, slot_value (q_arg1 (o).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 (q_arg2 (o).p); - return (q_func (o).b_7pp_f ( - o->sc, slot_value (q_arg1 (o).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 (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_i_func1_call (o))); -} - -static bool -opt_substring_equal_sf (opt_info* o) { - return (scheme_strings_are_equal ( - slot_value (q_arg1 (o).p), - opt_p_substring_uncopied_ssf (q_func2_arg (o).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 (q_call (o1).fp == opt_p_p_s) { - q_arg2 (opc).p = q_arg1 (o1).p; - q_func1 (opc).p_p_f= q_func1 (o1).p_p_f; - if (bpf_case) q_call (opc).fb= opt_b_pp_sfo; - else if (q_func1 (opc).p_p_f == car_p_p) - q_call (opc).fb= ((q_func (opc).b_7pp_f == s7_is_equal) - ? opt_car_equal_sf - : ((q_func (opc).b_7pp_f == s7_is_equivalent) - ? opt_car_equivalent_sf - : opt_b_7pp_car_sf)); - else - q_call (opc).fb= ((q_func (opc).b_7pp_f == s7_is_equal) - ? opt_is_equal_sfo - : ((q_func (opc).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= q_func1 (o).p_p_f (o->sc, slot_value (q_arg1 (o).p)); - return (q_func (o).b_pp_f ( - b1, q_func2 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)))); -} - -static bool -opt_b_pp_ffo_is_eq (opt_info* o) { - s7_pointer b1= q_func1 (o).p_p_f (o->sc, slot_value (q_arg1 (o).p)); - s7_pointer b2= q_func2 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)); - return ((b1 == b2) || ((is_unspecified (b1)) && (is_unspecified (b2)))); -} - -static bool -opt_b_7pp_ffo (opt_info* o) { - s7_pointer b1= q_func1 (o).p_p_f (o->sc, slot_value (q_arg1 (o).p)); - return (q_func (o).b_7pp_f ( - o->sc, b1, q_func2 (o).p_p_f (o->sc, slot_value (q_arg2 (o).p)))); -} - -static bool -opt_b_cadr_cadr (opt_info* o) { - s7_pointer p1= slot_value (q_arg1 (o).p); - s7_pointer p2= slot_value (q_arg2 (o).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 (q_func (o).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 ((q_call (o1).fp == opt_p_p_s) && (q_call (o2).fp == opt_p_p_s)) { - q_arg1 (opc).p = q_arg1 (o1).p; - q_func1 (opc).p_p_f= q_func1 (o1).p_p_f; - q_arg2 (opc).p = q_arg1 (o2).p; - q_func2 (opc).p_p_f= q_func1 (o2).p_p_f; - q_call (opc).fb= - (bpf_case) ? ((q_func (opc).b_pp_f == s7_is_eq) ? opt_b_pp_ffo_is_eq - : opt_b_pp_ffo) - : (((q_func2 (opc).p_p_f == cadr_p_p) && - (q_func1 (opc).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)) { - q_call (opc).fb = fb; - q_func (opc).b_pp_f= s7_b_pp_unchecked_function (s_func); + 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); } -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))) { - q_arg1 (opc).p= opt_simple_symbol (sc, arg1); - q_arg2 (opc).p= opt_simple_symbol (sc, arg2); - if ((q_arg1 (opc).p) && (q_arg2 (opc).p)) { - const s7_b_7pp_t b7f= (bpf_case) ? NULL : q_func (opc).b_7pp_f; - q_call (opc).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)) { - q_arg1 (opc).p= opt_simple_symbol (sc, arg1); - if (!q_arg1 (opc).p) return_false (sc, expr); - if ((!is_symbol (arg2)) && (!is_pair (arg2))) { - q_arg2 (opc).p = arg2; - q_call (opc).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)) { - q_func2_arg (opc).o1= sc->opts[cur_index]; - q_func2 (opc).fp = q_func2_arg (opc).q_call (o1).fp; - q_call (opc).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 ((q_func2 (opc).fp == opt_p_substring_uncopied_ssf) && - (q_func (opc).b_pp_f == string_eq_b_unchecked)) - q_call (opc).fb= opt_substring_equal_sf; /*concordance.scm */ - else if (q_func (opc).b_pp_f == char_eq_b_unchecked) - q_call (opc).fb= opt_b_pp_sf_char_eq; - } - return_true (sc, expr); - } - sc->pc= cur_index; - } - else if ((is_symbol (arg2)) && (is_pair (arg1))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - q_arg2 (opc).p= s7_slot (sc, arg2); /* can be # */ - if ((!is_slot (q_arg2 (opc).p)) || - (has_methods (slot_value (q_arg2 (opc).p)))) - return_false (sc, expr); - q_func2 (opc).fp= q_func2_arg (opc).q_call (o1).fp; - q_call (opc).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->[8].o1 etc */ - if (cell_optimize (sc, cdr (expr))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - if (b_pp_ff_combinable (sc, opc, bpf_case)) return_true (sc, expr); - q_call (opc).fb = (bpf_case) ? opt_b_pp_ff : opt_b_7pp_ff; - q_func3_arg (opc).o1= o1; - q_func3 (opc).fp = q_call (o1).fp; - q_func2 (opc).fp = q_func2_arg (opc).q_call (o1).fp; - check_b_types (sc, opc, s_func, expr, opt_b_pp_ff); - if (q_func (opc).b_pp_f == char_eq_b_unchecked) { - if (q_func2 (opc).fp == - opt_p_c) /* q_func2(opc).fp can be opt_p_c where - q_func2_arg(opc).q_arg1(o1).p is the char */ - { - q_call (opc).fb= opt_b_pp_fc_char_eq; - q_arg1 (opc).p = q_func2_arg (opc).q_arg1 (o1).p; - } - else q_call (opc).fb= opt_b_pp_ff_char_eq; - } - else if (q_func2 (opc).fp == opt_p_c) { - q_call (opc).fb= - (q_call (opc).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 */ - q_arg1 (opc).p= q_func2_arg (opc).q_arg1 (o1).p; - } - return_true (sc, expr); +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)); /* c_functions 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_false (sc, expr); + return(g_set_setter(sc, set_plist_2(sc, obj, setter))); /* if T_Clo(setter), doesn't it need GC protection as above? */ } -/* -------- b_pi -------- */ +/* (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 bool -opt_b_pi_fs (opt_info* o) { - return (q_func4 (o).b_pi_f (o->sc, q_p_func2_call (o), - integer (slot_value (q_arg1 (o).p)))); -} -static bool -opt_b_pi_fs_num_eq (opt_info* o) { - return (num_eq_b_pi (o->sc, q_p_func2_call (o), - integer (slot_value (q_arg1 (o).p)))); -} -static bool -opt_b_pi_fc (opt_info* o) { - return (q_func4 (o).b_pi_f (o->sc, q_p_func2_call (o), q_arg1 (o).i)); -} -static bool -opt_b_pi_ff (opt_info* o) { - s7_pointer p= q_p_func2_call (o); - return (q_func4 (o).b_pi_f (o->sc, p, q_i_func3_call (o))); -} - -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) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - opt_info* o1 = sc->opts[sc->pc]; - q_func4 (opc).b_pi_f= bpif; - q_func2 (opc).fp = q_func2_arg (opc).q_call (o1).fp; - if (is_symbol (arg2)) { - q_arg1 (opc).p= s7_t_slot (sc, arg2); /* slot checked in opt_arg_type */ - q_call (opc).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)) { - q_arg1 (opc).i = integer (arg2); - q_call (opc).fb= opt_b_pi_fc; - return_true (sc, expr); - } - if (int_optimize (sc, cddr (expr))) { - q_call (opc).fb = opt_b_pi_ff; - q_func3_arg (opc).o1= o1; - q_func3 (opc).fp = q_call (o1).fp; - return_true (sc, expr); - } - } - } - return_false (sc, expr); +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(sc, symbol, new_value, sc->curlet))); + return(c_function_call(func)(sc, with_list_t2(sc, symbol, new_value))); } -/* -------- b_dd -------- */ -static bool -opt_b_dd_ss (opt_info* o) { - return (q_func (o).b_dd_f (real (slot_value (q_arg1 (o).p)), - real (slot_value (q_arg2 (o).p)))); -} -static bool -opt_b_dd_ss_lt (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) < real (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_dd_ss_gt (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) > real (slot_value (q_arg2 (o).p))); -} - -static bool -opt_b_dd_sc (opt_info* o) { - return (q_func (o).b_dd_f (real (slot_value (q_arg1 (o).p)), q_arg2 (o).x)); -} -static bool -opt_b_dd_sc_lt (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) < q_arg2 (o).x); -} -static bool -opt_b_dd_sc_geq (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) >= q_arg2 (o).x); -} -static bool -opt_b_dd_sc_eq (opt_info* o) { - return (real (slot_value (q_arg1 (o).p)) == q_arg2 (o).x); -} - -static bool -opt_b_dd_sf (opt_info* o) { - return ( - q_func (o).b_dd_f (real (slot_value (q_arg1 (o).p)), q_d_func2_call (o))); -} -static bool -opt_b_dd_fs (opt_info* o) { - return ( - q_func (o).b_dd_f (q_d_func2_call (o), real (slot_value (q_arg2 (o).p)))); -} -static bool -opt_b_dd_fs_gt (opt_info* o) { - return (q_d_func2_call (o) > real (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_dd_fc (opt_info* o) { - return (q_func (o).b_dd_f (q_d_func2_call (o), q_arg2 (o).x)); -} -static bool -opt_b_dd_fc_gt (opt_info* o) { - return (q_d_func2_call (o) > q_arg2 (o).x); -} - -static bool -opt_b_dd_ff (opt_info* o) { - s7_double x1= q_d_func2_call (o); - s7_double x2= q_d_func3_call (o); - return (q_func (o).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); - q_func (opc).b_dd_f= bif; - if (is_symbol (arg1)) { - q_arg1 (opc).p= s7_t_slot (sc, arg1); - if (is_symbol (arg2)) { - q_arg2 (opc).p = s7_t_slot (sc, arg2); - q_call (opc).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)) { - q_arg2 (opc).x= s7_number_to_real (sc, arg2); - q_call (opc).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); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - q_call (opc).fb = opt_b_dd_sf; - return_true (sc, expr); - } - } - sc->pc = cur_index; - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cdr (expr))) { - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - if (is_symbol (arg2)) { - q_arg2 (opc).p = s7_t_slot (sc, arg2); - q_call (opc).fb= (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs; - return_true (sc, expr); - } - if (is_small_real (arg2)) { - q_arg2 (opc).x = s7_number_to_real (sc, arg2); - q_call (opc).fb= (bif == gt_b_dd) ? opt_b_dd_fc_gt : opt_b_dd_fc; - return_true (sc, expr); - } - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - q_call (opc).fb = opt_b_dd_ff; - return_true (sc, expr); - } +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); } - sc->pc= cur_index; - return_false (sc, expr); } -/* -------- b_ii -------- */ -static bool -opt_b_ii_ss (opt_info* o) { - return (q_func (o).b_ii_f (integer (slot_value (q_arg1 (o).p)), - integer (slot_value (q_arg2 (o).p)))); -} -static bool -opt_b_ii_ss_lt (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) < - integer (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_ii_ss_gt (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) > - integer (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_ii_ss_leq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) <= - integer (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_ii_ss_geq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) >= - integer (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_ii_ss_eq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) == - integer (slot_value (q_arg2 (o).p))); -} -static bool -opt_b_ii_sc (opt_info* o) { - return ( - q_func (o).b_ii_f (integer (slot_value (q_arg1 (o).p)), q_arg2 (o).i)); -} -static bool -opt_b_ii_sc_lt (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) < q_arg2 (o).i); -} -static bool -opt_b_ii_sc_leq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) <= q_arg2 (o).i); -} -static bool -opt_b_ii_sc_gt (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) > q_arg2 (o).i); -} -static bool -opt_b_ii_sc_geq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) >= q_arg2 (o).i); -} -static bool -opt_b_ii_sc_eq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) == q_arg2 (o).i); -} -static bool -opt_b_ii_sc_lt_2 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) < 2); -} -static bool -opt_b_ii_sc_lt_1 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) < 1); -} -static bool -opt_b_ii_sc_lt_0 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) < 0); -} -static bool -opt_b_ii_sc_leq_0 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) <= 0); -} -static bool -opt_b_ii_sc_gt_0 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) > 0); -} -static bool -opt_b_ii_sc_geq_0 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) >= 0); -} -static bool -opt_b_ii_sc_eq_0 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) == 0); -} -static bool -opt_b_ii_sc_eq_1 (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) == 1); -} - -static bool -opt_b_7ii_ss (opt_info* o) { - return (q_func (o).b_7ii_f (o->sc, integer (slot_value (q_arg1 (o).p)), - integer (slot_value (q_arg2 (o).p)))); -} -static bool -opt_b_7ii_sc (opt_info* o) { - return (q_func (o).b_7ii_f (o->sc, integer (slot_value (q_arg1 (o).p)), - q_arg2 (o).i)); -} -static bool -opt_b_7ii_sc_bit (opt_info* o) { - return ((integer (slot_value (q_arg1 (o).p)) & - ((s7_int) (1LL << q_arg2 (o).i))) != 0); -} - -static bool -opt_b_ii_ff (opt_info* o) { - s7_int i1= q_i_func2_call (o); - s7_int i2= q_i_func3_call (o); - return (q_func (o).b_ii_f (i1, i2)); -} - -static bool -opt_b_ii_fs (opt_info* o) { - return (q_func (o).b_ii_f (q_i_func2_call (o), - integer (slot_value (q_arg2 (o).p)))); -} -static bool -opt_b_ii_sf (opt_info* o) { - return (q_func (o).b_ii_f (integer (slot_value (q_arg1 (o).p)), - q_i_func2_call (o))); -} -static bool -opt_b_ii_sf_eq (opt_info* o) { - return (integer (slot_value (q_arg1 (o).p)) == q_i_func2_call (o)); -} -static bool -opt_b_ii_fc (opt_info* o) { - return (q_func (o).b_ii_f (q_i_func2_call (o), q_arg2 (o).i)); -} -static bool -opt_b_ii_fc_eq (opt_info* o) { - return (q_i_func2_call (o) == q_arg2 (o).i); +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 */ } -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) q_func (opc).b_ii_f= bif; - else q_func (opc).b_7ii_f= b7if; - if (is_symbol (arg1)) { - q_arg1 (opc).p= s7_t_slot (sc, arg1); - if (is_symbol (arg2)) { - q_arg2 (opc).p= s7_t_slot (sc, arg2); - q_call (opc).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); - q_arg2 (opc).i = i2; - q_call (opc).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); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if ((bif) && (int_optimize (sc, cddr (expr)))) { - q_call (opc).fb = (bif == num_eq_b_ii) ? opt_b_ii_sf_eq : opt_b_ii_sf; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - return_false (sc, expr); - } - if (!bif) return_false (sc, expr); - - if (is_symbol (arg2)) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (!int_optimize (sc, cdr (expr))) return_false (sc, expr); - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_arg2 (opc).p = s7_t_slot (sc, arg2); - q_call (opc).fb = opt_b_ii_fs; - return_true (sc, expr); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - if (is_t_integer (arg2)) { - q_arg2 (opc).i = integer (arg2); - q_call (opc).fb= (bif == num_eq_b_ii) ? opt_b_ii_fc_eq : opt_b_ii_fc; - return_true (sc, expr); - } - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - q_call (opc).fb = opt_b_ii_ff; - return_true (sc, expr); - } - } - return_false (sc, expr); + +/* -------------------------------- 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 */ } -/* -------- b_or|and -------- */ -static bool -opt_and_bb (opt_info* o) { - return ((q_func (o).fb (q_arg1 (o).o1)) && (q_b_func2_call (o))); +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)))))); } -#define q_bool_call(o, i) o->v[i + 3] +/* g_is_eq migrated to s7_scheme_predicate.c */ +#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 -static bool -opt_and_any_b (opt_info* o) { - for (s7_int i= 0; i < q_arg1 (o).i; i++) { - opt_info* o1= q_bool_call (o, i).o1; - if (!q_call (o1).fb (o1)) return (false); - } - return (true); +bool s7_is_eqv(s7_scheme *sc, s7_pointer x, s7_pointer y) +{ + 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 bool -opt_or_bb (opt_info* o) { - return ((q_func (o).fb (q_arg1 (o).o1)) || (q_b_func2_call (o))); -} +/* g_is_eqv migrated to s7_scheme_predicate.c */ +#define H_is_eqv "(eqv? obj1 obj2) returns #t if obj1 is equivalent to obj2" +#define Q_is_eqv sc->pcl_bt -static bool -opt_or_any_b (opt_info* o) { - for (s7_int i= 0; i < q_arg1 (o).i; i++) { - opt_info* o1= q_bool_call (o, i).o1; - if (q_call (o1).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))) { - q_func2_arg (opc).o1= o2; - q_func2 (opc).fb = q_call (o2).fb; - q_call (opc).fb = (is_and) ? opt_and_bb : opt_or_bb; - q_arg1 (opc).o1 = o1; - q_func (opc).fb = q_call (o1).fb; - return_true (sc, expr); - } - } - return_false (sc, expr); - } - q_arg1 (opc).i= (len - 1); - for (int32_t i= 0; (is_pair (p)) && (i < 12); i++, p= cdr (p)) { - q_bool_call (opc, i).o1= sc->opts[sc->pc]; - if (!bool_optimize_nw (sc, p)) break; - } - if (!is_null (p)) return_false (sc, expr); - q_call (opc).fb= (is_and) ? opt_and_any_b : opt_or_any_b; - return_true (sc, expr); -} +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 -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)); +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))); } -/* ---------------------------------------- cell opts - * ---------------------------------------- */ -static s7_pointer -opt_p_c (opt_info* o) { - return (q_arg1 (o).p); -} -static s7_pointer -opt_p_s (opt_info* o) { - return (slot_value (q_arg1 (o).p)); +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 -opt_cell_not_pair (s7_scheme* sc, s7_pointer expr) { - s7_pointer slot; - opt_info* opc; - if (!is_symbol (expr)) { - opc = alloc_opt_info (sc); - q_arg1 (opc).p = expr; - q_call (opc).fp= opt_p_c; - return_true (sc, expr); - } - slot= opt_simple_symbol (sc, expr); - if (!slot) return_false (sc, expr); - opc = alloc_opt_info (sc); - q_arg1 (opc).p = slot; - q_call (opc).fp= opt_p_s; - return_true (sc, expr); +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))))); } -/* -------- 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 (q_func (o).p_f (o->sc)); -} -static s7_pointer -opt_p_call (opt_info* o) { - return (q_func (o).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) { - q_func (opc).p_f= func; - q_call (opc).fp = opt_p_f; - return_true (sc, expr); - } - if ((is_safe_procedure (s_func)) && (c_function_min_args (s_func) == 0)) { - q_func (opc).call= cf_call (sc, expr, s_func, 0); - q_call (opc).fp = opt_p_call; - return_true (sc, expr); - } - return_false (sc, expr); +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)); } -/* -------- p_p -------- */ -static s7_pointer -opt_p_p_c (opt_info* o) { - return (q_func1 (o).p_p_f (o->sc, q_arg1 (o).p)); -} -static s7_pointer -opt_p_i_c (opt_info* o) { - return (make_integer (o->sc, q_func (o).i_i_f (q_arg1 (o).i))); -} -static s7_pointer -opt_p_7i_c (opt_info* o) { - return (make_integer (o->sc, q_func (o).i_7i_f (o->sc, q_arg1 (o).i))); -} -static s7_pointer -opt_p_d_c (opt_info* o) { - return (make_real (o->sc, q_func (o).d_d_f (q_arg1 (o).x))); -} -static s7_pointer -opt_p_7d_c (opt_info* o) { - return (make_real (o->sc, q_func (o).d_7d_f (o->sc, q_arg1 (o).x))); -} -static s7_pointer -opt_p_p_s (opt_info* o) { - return (q_func1 (o).p_p_f (o->sc, slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_p_s_abs (opt_info* o) { - return (abs_p_p (o->sc, slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_p_s_random (opt_info* o) { - return (random_p_p (o->sc, slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_p_s_random_wrapped (opt_info* o) { - return (random_p_p_wrapped (o->sc, slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_p_s_cdr (opt_info* o) { - s7_pointer p= slot_value (q_arg1 (o).p); - return ((is_pair (p)) ? cdr (p) : cdr_p_p (o->sc, p)); -} -static s7_pointer -opt_p_p_f (opt_info* o) { - return (q_func1 (o).p_p_f (o->sc, q_p_func2_call (o))); -} -static s7_pointer -opt_p_p_f1 (opt_info* o) { - return (q_func1 (o).p_p_f ( - o->sc, q_func (o).p_p_f (o->sc, slot_value (q_arg1 (o).p)))); -} -static s7_pointer -opt_p_p_f_exp (opt_info* o) { - return (exp_p_p (o->sc, q_p_func2_call (o))); -} -static s7_pointer -opt_p_7d_c_random (opt_info* o) { - return (make_real (o->sc, random_d_7d (o->sc, q_arg1 (o).x))); -} -static s7_pointer -opt_p_p_s_iterate (opt_info* o) { - return (iterate_p_p (o->sc, slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_p_f_iterate (opt_info* o) { - return (iterate_p_p (o->sc, q_p_func2_call (o))); -} -static s7_pointer -opt_p_z_f_magnitude (opt_info* o) { - return (magnitude_p_z (o->sc, q_p_func2_call (o))); -} -static s7_pointer -opt_p_p_f_string_to_number (opt_info* o) { - return (string_to_number_p_p (o->sc, q_p_func2_call (o))); -} -static s7_pointer -opt_p_p_s_iterate_unchecked (opt_info* o) { - s7_pointer iter= slot_value (q_arg1 (o).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 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 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 (q_func1 (o).p_p_f ( - o->sc, opt_p_pi_ss_fvref_direct_wrapped (q_func2_arg (o).o1))); -} /* unwrap to fvref is not faster */ -static s7_pointer -opt_p_p_ivref (opt_info* o) { - return (q_func1 (o).p_p_f ( - o->sc, opt_p_pi_ss_ivref_direct_wrapped (q_func2_arg (o).o1))); -} /* unwrap to ivref is not faster */ -static s7_pointer -opt_p_p_vref (opt_info* o) { - return ( - q_func1 (o).p_p_f (o->sc, opt_p_pi_ss_vref_direct (q_func2_arg (o).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 (q_call (o1).fp == opt_p_p_s) { - q_func (opc).p_p_f= q_func1 (o1).p_p_f; - q_arg1 (opc).p = q_arg1 (o1).p; - q_call (opc).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 (q_func (o).call (o->sc, set_plist_1 (o->sc, q_p_func1_call (o)))); -} -static s7_pointer -opt_p_call_s (opt_info* o) { - return ( - q_func (o).call (o->sc, set_plist_1 (o->sc, slot_value (q_arg1 (o).p)))); -} -static s7_pointer -opt_p_call_c (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_1 (o->sc, q_arg1 (o).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; - q_arg1 (opc).i= integer (arg1); - if (iif) { - q_func (opc).i_i_f= iif; - q_call (opc).fp = opt_p_i_c; - return_true (sc, expr); - } - i7if= s7_i_7i_function (s_func); - if (i7if) { - q_func (opc).i_7i_f= i7if; - q_call (opc).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; - q_arg1 (opc).x= real (arg1); - if (ddf) { - q_func (opc).d_d_f= ddf; - q_call (opc).fp = opt_p_d_c; - return_true (sc, expr); - } - d7df= s7_d_7d_function (s_func); - if (d7df) { - q_func (opc).d_7d_f= d7df; - q_call (opc).fp= (d7df == random_d_7d) ? opt_p_7d_c_random : opt_p_7d_c; - return_true (sc, expr); +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); } - } - ppf= s7_p_p_function (s_func); - if (ppf) { - opt_info* o1; - q_func1 (opc).p_p_f= ppf; /* TODO: func! */ - if ((ppf == symbol_to_string_p_p) && (is_optimized (expr)) && - (fn_proc (expr) == g_symbol_to_string_uncopied)) - q_func1 (opc).p_p_f= symbol_to_string_uncopied_p; - - if (is_symbol (arg1)) { - q_arg1 (opc).p= opt_simple_symbol (sc, arg1); - if (!q_arg1 (opc).p) return_false (sc, expr); - q_call (opc).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 (q_arg1 (opc).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 (q_func1 (opc).p_p_f == s7_length) { - q_arg1 (opc).p = s7_length (sc, arg1); - q_call (opc).fp= opt_p_c; - } - else { - q_arg1 (opc).p = arg1; - q_call (opc).fp= opt_p_p_c; /* see p_pip_ssf_combinable */ - } - 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) && - ((q_call (o1).fp == opt_p_pi_ss) || - (q_call (o1).fp == opt_p_pi_sf)) && - (q_func (o1).p_pi_f == complex_vector_ref_p_pi)) { - q_func (o1).p_pi_f= complex_vector_ref_p_pi_wrapped; - q_call (opc).fp = opt_p_z_f_magnitude; - } - else - q_call (opc).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)); - q_func2_arg (opc).o1= o1; - fp = q_call (o1).fp; - q_func2 (opc).fp = fp; - if (fp == opt_p_pi_ss_fvref_direct) q_call (opc).fp= opt_p_p_fvref; - else if (fp == opt_p_pi_ss_vref_direct) q_call (opc).fp= opt_p_p_vref; - else if (fp == opt_p_pi_ss_ivref_direct) q_call (opc).fp= opt_p_p_ivref; - } - return_true (sc, expr); + 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); +} - sc->pc= start; - if ((is_safe_procedure (s_func)) && (c_function_is_aritable (s_func, 1))) { - q_func (opc).call= cf_call (sc, expr, s_func, 1); - if (is_symbol (arg1)) { - const s7_pointer slot= opt_simple_symbol (sc, arg1); - if (slot) { - q_arg1 (opc).p = slot; - q_call (opc).fp= opt_p_call_s; - return_true (sc, expr); - } +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); } - else { - opt_info* o1; - if (!is_pair (arg1)) { - q_arg1 (opc).p = arg1; - q_call (opc).fp= opt_p_call_c; - return_true (sc, expr); - } - o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - q_call (opc).fp = opt_p_call_f; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - if (q_func1 (opc).fp == opt_p_pi_ss_fvref_direct) - q_func1 (opc).fp= opt_p_pi_ss_fvref_direct_wrapped; - else if (q_func1 (opc).fp == opt_p_pi_ss_ivref_direct) - q_func1 (opc).fp= opt_p_pi_ss_ivref_direct_wrapped; - return_true (sc, expr); - } + if (c_pointer_info(x) != c_pointer_info(y)) + { + if (!nci) nci = clear_shared_info(sc->circle_info); + if (!is_equal_1(sc, c_pointer_info(x), c_pointer_info(y), nci)) + return(false); } - } - return_false (sc, expr); + return(true); } -/* -------- p_i -------- */ -static s7_pointer -opt_p_i_s (opt_info* o) { - return (q_func (o).p_i_f (o->sc, integer (slot_value (q_arg1 (o).p)))); -} /* number_to_string_p_i expanded here doesn't gain much */ -static s7_pointer -opt_p_i_f (opt_info* o) { - return (q_func (o).p_i_f (o->sc, q_i_func1_call (o))); -} -static s7_pointer -opt_p_i_f_intc (opt_info* o) { - return (integer_to_char_p_i (o->sc, q_i_func1_call (o))); -} - -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 slot; - const s7_p_i_t ifunc= s7_p_i_function (s_func); - if (!ifunc) return_false (sc, expr); - q_func (opc).p_i_f= ifunc; - slot = opt_integer_symbol (sc, cadr (expr)); - if (slot) { - q_arg1 (opc).p = slot; - q_call (opc).fp= opt_p_i_s; - return_true (sc, expr); - } - if (int_optimize (sc, cdr (expr))) { - q_call (opc).fp= - (ifunc == integer_to_char_p_i) ? opt_p_i_f_intc : opt_p_i_f; - q_func1_arg (opc).o1= sc->opts[pstart]; - q_func1 (opc).fi = q_call (sc->opts[pstart]).fi; - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); +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))); } -/* -------- p_ii -------- */ -static s7_pointer -opt_p_ii_ss (opt_info* o) { - return (q_func (o).p_ii_f (o->sc, integer (slot_value (q_arg1 (o).p)), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_ii_fs (opt_info* o) { - return (q_func (o).p_ii_f (o->sc, q_i_func1_call (o), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_ii_ff_divide (opt_info* o) { - return (make_ratio_with_div_check (o->sc, o->sc->divide_symbol, - q_i_func1_call (o), q_i_func2_call (o))); -} - -static s7_pointer -opt_p_ii_ff (opt_info* o) { - s7_int i1= q_i_func1_call (o); - return (q_func (o).p_ii_f (o->sc, i1, q_i_func2_call (o))); -} - -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 arg2_slot; - const s7_p_ii_t ifunc= s7_p_ii_function (s_func); - if (!ifunc) return_false (sc, expr); - arg2_slot= opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - const s7_pointer arg1_slot= opt_integer_symbol (sc, cadr (expr)); - if (arg1_slot) { - q_arg1 (opc).p = arg1_slot; - q_arg2 (opc).p = arg2_slot; - q_func (opc).p_ii_f= ifunc; - q_call (opc).fp = opt_p_ii_ss; - return_true (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func1 (opc).fi = q_func1_arg (opc).q_call (o1).fi; - q_arg2 (opc).p = arg2_slot; - q_func (opc).p_ii_f= ifunc; - q_call (opc).fp = opt_p_ii_fs; - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); - } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func1 (opc).fi = q_func1_arg (opc).q_call (o1).fi; - q_func2 (opc).fi = q_func2_arg (opc).q_call (o1).fi; - q_func (opc).p_ii_f= ifunc; - q_call (opc).fp= - (ifunc == divide_p_ii) ? opt_p_ii_ff_divide : opt_p_ii_ff; - return_true (sc, expr); +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: + if (!local_strncmp((const char *)port_filename(x), (const char *)port_filename(y), port_filename_length(x))) return(false); + if (is_input_port(x)) return(port_position(x) == port_position(y)); +#if MS_WINDOWS + return(false); +#else + return(ftell(port_file(x)) == ftell(port_file(y))); +#endif + 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)); } - } - sc->pc= pstart; - return_false (sc, expr); + return(false); } -/* -------- p_d -------- */ -static s7_pointer -opt_p_d_s (opt_info* o) { - return (q_func (o).p_d_f ( - o->sc, real_to_double (o->sc, slot_value (q_arg2 (o).p), __func__))); -} -static s7_pointer -opt_p_d_f (opt_info* o) { - return (q_func (o).p_d_f (o->sc, q_d_func1_call (o))); -} - -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 arg1_slot; - opt_info* o1; - const s7_p_d_t ifunc= s7_p_d_function (s_func); - if (!ifunc) return_false (sc, expr); - arg1_slot= opt_float_symbol (sc, cadr (expr)); - if (arg1_slot) { - q_arg2 (opc).p = arg1_slot; - q_func (opc).p_d_f= ifunc; - q_call (opc).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))) { - q_func (opc).p_d_f = ifunc; - q_call (opc).fp = opt_p_d_f; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fd = q_call (o1).fd; - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); +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; } -/* -------- p_dd -------- */ -static s7_pointer -opt_p_dd_sc (opt_info* o) { - return (q_func (o).p_dd_f ( - o->sc, real_to_double (o->sc, slot_value (q_arg1 (o).p), __func__), - q_arg2 (o).x)); -} -static s7_pointer -opt_p_dd_cs (opt_info* o) { - return (q_func (o).p_dd_f ( - o->sc, q_arg1 (o).x, - real_to_double (o->sc, slot_value (q_arg2 (o).p), __func__))); -} -static s7_pointer -opt_p_dd_cc (opt_info* o) { - return (q_func (o).p_dd_f (o->sc, q_arg1 (o).x, q_arg2 (o).x)); -} - -static bool -p_dd_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_dd_t ifunc= s7_p_dd_function (s_func); - if (!ifunc) return_false (sc, expr); - q_func (opc).p_dd_f= ifunc; - if (is_t_real (arg2)) { - s7_pointer arg1_slot; - q_arg2 (opc).x= real (arg2); - if (is_t_real (arg1)) { - q_arg1 (opc).x = real (arg1); - q_call (opc).fp= opt_p_dd_cc; - return_true (sc, expr); - } - arg1_slot= opt_real_symbol (sc, arg1); - if (arg1_slot) { - q_arg1 (opc).p = arg1_slot; - q_call (opc).fp= opt_p_dd_sc; - return_true (sc, expr); - } - } - if (is_t_real (arg1)) { - s7_pointer arg2_slot; - arg2_slot= opt_real_symbol (sc, arg2); - if (arg2_slot) { - q_arg1 (opc).x = real (arg1); - q_arg2 (opc).p = arg2_slot; - q_call (opc).fp= opt_p_dd_cs; - return_true (sc, expr); +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); } - } - sc->pc= pstart; - return_false (sc, expr); + 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); } -/* -------- p_pi -------- */ -static s7_pointer -opt_p_pi_ss (opt_info* o) { - return (q_func (o).p_pi_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_sref (opt_info* o) { - return (string_ref_p_pi_unchecked (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_sref_direct (opt_info* o) { - return (string_ref_p_pi_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_vref (opt_info* o) { - return (t_vector_ref_p_pi_unchecked (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_vref_direct (opt_info* o) { - return (t_vector_ref_p_pi_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_fvref_direct (opt_info* o) { - return (float_vector_ref_p_pi_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_cvref_direct (opt_info* o) { - return (complex_vector_ref_p_pi_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_ivref_direct (opt_info* o) { - return (int_vector_ref_p_pi_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).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 (q_arg1 (o).p), integer (slot_value (q_arg2 (o).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 (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_ss_pref (opt_info* o) { - return (list_ref_p_pi_unchecked (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)))); -} -static s7_pointer -opt_p_pi_sc (opt_info* o) { - return (q_func (o).p_pi_f (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).i)); -} -static s7_pointer -opt_p_pi_sc_pref (opt_info* o) { - return ( - list_ref_p_pi_unchecked (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).i)); -} -static s7_pointer -opt_p_pi_sf (opt_info* o) { - return ( - q_func (o).p_pi_f (o->sc, slot_value (q_arg1 (o).p), q_i_func1_call (o))); -} -static s7_pointer -opt_p_pi_sf_sref (opt_info* o) { - return (string_ref_p_pi_unchecked (o->sc, slot_value (q_arg1 (o).p), - q_i_func1_call (o))); -} -static s7_pointer -opt_p_pi_sf_sref_direct (opt_info* o) { - return (string_ref_p_pi_direct (o->sc, slot_value (q_arg1 (o).p), - q_i_func1_call (o))); -} -static s7_pointer -opt_p_pi_fc (opt_info* o) { - return (q_func (o).p_pi_f (o->sc, q_p_func1_call (o), q_arg2 (o).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= type_unchecked (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 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 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 (q_func(o).p_pi_f et al) because - there are so many, and copy depends on this choice */ +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; + + 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); { - case T_STRING: - if (((!expr) || (car (expr) == sc->string_ref_symbol)) && - (loop_end (slot) <= string_length (obj))) - q_func (opc).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))) - q_func (opc).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))) - q_func (opc).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))) - q_func (opc).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))) - q_func (opc).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))) - q_func (opc).p_pi_f= int_vector_ref_p_pi_direct; - break; - } + s7_pointer pa = to_list(sc, set_plist_1(sc, a)); + s7_pointer pb = to_list(sc, set_plist_1(sc, b)); + for (; 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 void -fixup_p_pi_ss (opt_info* opc) { - q_call (opc).fp= - (q_func (opc).p_pi_f == string_ref_p_pi_unchecked) - ? opt_p_pi_ss_sref - : ((q_func (opc).p_pi_f == string_ref_p_pi_direct) - ? opt_p_pi_ss_sref_direct - : ((q_func (opc).p_pi_f == t_vector_ref_p_pi_unchecked) - ? opt_p_pi_ss_vref - : ((q_func (opc).p_pi_f == float_vector_ref_p_pi_direct) - ? opt_p_pi_ss_fvref_direct - : ((q_func (opc).p_pi_f == - complex_vector_ref_p_pi_direct) - ? opt_p_pi_ss_cvref_direct - : ((q_func (opc).p_pi_f == - int_vector_ref_p_pi_direct) - ? opt_p_pi_ss_ivref_direct - : ((q_func (opc).p_pi_f == - t_vector_ref_p_pi_direct) - ? opt_p_pi_ss_vref_direct - : ((q_func (opc).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, arg1_slot, arg2_slot, checker= NULL; - opt_info* o1; - const s7_p_pi_t func= s7_p_pi_function (s_func); - if (!func) return_false (sc, expr); +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 hash_func; + bool (*eqf)(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci); - /* here we know cadr is a symbol */ - arg1_slot= opt_simple_symbol (sc, cadr (expr)); - if (!arg1_slot) return_false (sc, expr); - if ((is_any_vector (slot_value (arg1_slot))) && - (vector_rank (slot_value (arg1_slot)) > 1)) - return_false (sc, expr); - - q_func (opc).p_pi_f= func; - q_arg1 (opc).p = arg1_slot; - - if (is_symbol (cadr (sig))) checker= cadr (sig); - - obj= slot_value (q_arg1 (opc).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))) - q_func (opc).p_pi_f= (is_t_vector (obj)) - ? t_vector_ref_p_pi_unchecked - : s7_p_pi_unchecked_function (s_func); + if (x == y) + return(true); + if (!is_hash_table(y)) + { + if (equivalent) + check_equivalent_method(sc, y, x); + return(false); } - } - arg2_slot= opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - q_arg2 (opc).p= arg2_slot; - if ((obj) && /* this depends above on s7_p_pi_unchecked_function, but none - of the typed vectors have one?? */ - (has_loop_end (arg2_slot))) - check_unchecked (sc, obj, arg2_slot, opc, expr); - fixup_p_pi_ss (opc); - return_true (sc, expr); - } - if (is_t_integer (caddr (expr))) { - q_arg2 (opc).i = integer (caddr (expr)); - q_call (opc).fp= (q_func (opc).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))) { - q_call (opc).fp = (q_func (opc).p_pi_f == string_ref_p_pi_unchecked) - ? opt_p_pi_sf_sref - : ((q_func (opc).p_pi_f == string_ref_p_pi_direct) - ? opt_p_pi_sf_sref_direct - : opt_p_pi_sf); - q_func1_arg (opc).o1= o1; - q_func1 (opc).fi = q_call (o1).fi; - return_true (sc, expr); - } - return_false (sc, expr); -} + if ((ci) && (equal_ref(sc, x, y, ci))) return(true); -static s7_pointer -opt_p_pi_fco (opt_info* o) { - return (q_func (o).p_pi_f ( - o->sc, q_func1 (o).p_p_f (o->sc, slot_value (q_arg1 (o).p)), - q_arg2 (o).i)); -} + 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; -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 (q_call (o1).fp == opt_p_p_s) { - q_func1 (opc).p_p_f= q_func1 (o1).p_p_f; - q_arg1 (opc).p = q_arg1 (o1).p; - q_call (opc).fp = opt_p_pi_fco; - backup_pc (sc); - return_true (sc, NULL); + hash_func = hash_table_checker(y); + if ((hash_func != hash_equal) && (hash_func != hash_equivalent)) + { + for (s7_int i = 0; i < len; i++) + for (hash_entry_t *entry = lists[i]; entry; entry = hash_entry_next(entry)) + { + hash_entry_t *y_val = hash_func(sc, y, hash_entry_key(entry)); + if (y_val == sc->unentry) + return(false); + if (!eqf(sc, hash_entry_value(entry), 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 hash_func? + */ + return(true); } - } - return_false (sc, NULL); -} -/* -------- p_pp -------- */ -static s7_pointer -opt_p_pp_ss (opt_info* o) { - return (q_func (o).p_pp_f (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p))); -} -static s7_pointer -opt_p_pp_sc (opt_info* o) { - return (q_func (o).p_pp_f (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).p)); -} -static s7_pointer -opt_p_pp_slot_ref (opt_info* o) { - return (slot_value (q_arg1 (o).p)); -} /* not in s7test timp (set! sum (+ sum (* i (L2 'a)))) */ -static s7_pointer -opt_p_pp_cs (opt_info* o) { - return (q_func (o).p_pp_f (o->sc, q_arg1 (o).p, slot_value (q_arg2 (o).p))); -} -static s7_pointer -opt_p_pp_sf (opt_info* o) { - return ( - q_func (o).p_pp_f (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_fs (opt_info* o) { - return ( - q_func (o).p_pp_f (o->sc, q_p_func1_call (o), slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_pp_fc (opt_info* o) { - return (q_func (o).p_pp_f (o->sc, q_p_func1_call (o), q_arg2 (o).p)); -} -static s7_pointer -opt_p_pp_cc (opt_info* o) { - return (q_func (o).p_pp_f (o->sc, q_arg1 (o).p, q_arg2 (o).p)); -} -static s7_pointer -opt_p_pp_cc_make_list (opt_info* o) { - return (make_list (o->sc, q_arg1 (o).i, q_arg2 (o).p)); -} -static s7_pointer -opt_set_car_pp_ss (opt_info* o) { - return (inline_set_car (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p))); -} -static s7_pointer -opt_p_pp_ss_href (opt_info* o) { - return (s7_hash_table_ref (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p))); -} -static s7_pointer -opt_p_pp_sf_add (opt_info* o) { - return (add_p_pp (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_sf_sub (opt_info* o) { - return (subtract_p_pp (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_sf_mul (opt_info* o) { - return (multiply_p_pp (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_sf_set_car (opt_info* o) { - return ( - inline_set_car (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_sf_set_cdr (opt_info* o) { - return ( - inline_set_cdr (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_sf_href (opt_info* o) { - return ( - s7_hash_table_ref (o->sc, slot_value (q_arg1 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_pp_fs_vref (opt_info* o) { - return (s7i_vector_ref_p_pp (o->sc, q_p_func1_call (o), - slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_pp_fs_cons (opt_info* o) { - return (cons (o->sc, q_p_func1_call (o), slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_pp_fs_add (opt_info* o) { - return (add_p_pp (o->sc, q_p_func1_call (o), slot_value (q_arg1 (o).p))); -} -static s7_pointer -opt_p_pp_fs_sub (opt_info* o) { - return (subtract_p_pp (o->sc, q_p_func1_call (o), slot_value (q_arg1 (o).p))); -} - -static s7_pointer -opt_p_pp_ss_lref (opt_info* o) { - s7_pointer sym= slot_value (q_arg2 (o).p); - if (is_symbol (sym)) - return (let_ref_p_pp (o->sc, slot_value (q_arg1 (o).p), - (is_keyword (sym)) ? keyword_symbol (sym) : sym)); - return (let_ref (o->sc, slot_value (q_arg1 (o).p), sym)); -} - -static s7_pointer -opt_p_pp_sf_lref (opt_info* o) { - s7_pointer sym= q_p_func1_call (o); - if (is_symbol (sym)) - return (let_ref_p_pp (o->sc, slot_value (q_arg1 (o).p), - (is_keyword (sym)) ? keyword_symbol (sym) : sym)); - return (let_ref (o->sc, slot_value (q_arg1 (o).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, q_p_func2_call (o), - q_p_func3_call (o)); /* we do need to protect both */ - result= q_func (o).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) /* (+|- (* x1 x2) (* x3 x4)) */ -{ - opt_info * o1= q_func2_arg (o).o1, *o2= q_func3_arg (o).o1; - s7_pointer x4; - s7_scheme* sc= o->sc; - const s7_pointer x1= slot_value (q_arg1 (o1).p); - s7_pointer x3= slot_value (q_arg1 (o2).p); - const s7_pointer x2= q_func1 (o1).fp (q_func1_arg (o1).o1); - if ((is_t_real (x2)) && (is_t_real (x1)) && (is_t_real (x3))) { - s7_double r2= real (x2); - x4 = q_func1 (o2).fp (q_func1_arg (o2).o1); - if (is_t_real (x4)) - return (make_real ( - sc, (add_case) ? ((real (x1) * r2) + (real (x3) * real (x4))) - : ((real (x1) * r2) - (real (x3) * real (x4))))); - gc_protect_via_stack_no_let (sc, x2); - } - else { - gc_protect_via_stack_no_let (sc, x2); - x4= q_func1 (o2).fp (q_func1_arg (o2).o1); - } - set_gc_protected2 (sc, x4); - set_gc_protected2 (sc, multiply_p_pp_wrapped (sc, x3, x4)); - set_gc_protected1 (sc, multiply_p_pp_wrapped (sc, x1, x2)); - x3= (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 (x3); -} - -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 (q_func3 (opc).fp == opt_p_pi_ss_ivref_direct) - q_func3 (opc).fp= opt_p_pi_ss_ivref_direct_wrapped; - if (q_func3 (opc).fp == opt_p_pi_ss_fvref_direct) - q_func3 (opc).fp= opt_p_pi_ss_fvref_direct_wrapped; - if (q_func2 (opc).fp == opt_p_pi_ss_ivref_direct) - q_func2 (opc).fp= opt_p_pi_ss_ivref_direct_wrapped; - if (q_func2 (opc).fp == opt_p_pi_ss_fvref_direct) - q_func2 (opc).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)) { - q_arg1 (opc).p = slot; - q_call (opc).fp= opt_p_pp_slot_ref; - } + /* 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)) /* entry declared below */ + { + 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 s7_pointer -opt_p_unlet_ref (opt_info* o) { - return (q_arg1 (o).p); +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); is_not_slot_end(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 s7_pointer -opt_p_rootlet_ref (opt_info* o) { - return (global_value (q_arg1 (o).p)); + +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); is_not_slot_end(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 -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))) { - q_call (opc).fp= opt_p_c; - q_arg1 (opc).p = sc->undefined; - return_true (sc, expr); - } - } - q_call (opc).fp= - (car (arg1) == sc->rootlet_symbol) ? opt_p_rootlet_ref : opt_p_unlet_ref; - q_arg1 (opc).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); - q_func (opc).p_pp_f= func; - if (is_symbol (arg1)) { - s7_pointer obj; - const s7_pointer arg1_slot= opt_simple_symbol (sc, arg1); - if (!arg1_slot) { - sc->pc= pstart; - return_false (sc, expr); - } - obj= slot_value (arg1_slot); - if ((is_any_vector (obj)) && (vector_rank (obj) > 1)) { - sc->pc= pstart; - return_false (sc, expr); - } - q_arg1 (opc).p= arg1_slot; - - if ((func == hash_table_ref_p_pp) && (is_hash_table (obj))) - q_func (opc).p_pp_f= s7_hash_table_ref; - - if (is_symbol (arg2)) { - q_arg2 (opc).p= opt_simple_symbol (sc, arg2); - if (q_arg2 (opc).p) { - q_call (opc).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 ((q_call (opc).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))) { - q_arg2 (opc).p = (!is_pair (arg2)) ? arg2 : cadr (arg2); - q_call (opc).fp= opt_p_pp_sc; - if ((is_pair (arg2)) && (is_symbol (q_arg2 (opc).p)) && (is_let (obj)) && - (q_func (opc).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))) { - q_call (opc).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)) && - (q_func (opc).p_pp_f == - s7_hash_table_ref)) - ? opt_p_pp_sf_href - : (((is_let (obj)) && - (q_func (opc).p_pp_f == - let_ref)) - ? opt_p_pp_sf_lref - : opt_p_pp_sf)))))); - q_func1_arg (opc).o1= sc->opts[pstart]; - q_func1 (opc).fp = q_call (sc->opts[pstart]).fp; - if (q_func1 (opc).fp == opt_p_pi_ss_ivref_direct) - q_func1 (opc).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))) { - q_arg1 (opc).p= (!is_pair (arg1)) ? arg1 : cadr (arg1); - if ((!is_symbol (arg2)) && - ((!is_pair (arg2)) || (is_proper_quote (sc, arg2)))) { - q_arg2 (opc).p= (!is_pair (arg2)) ? arg2 : cadr (arg2); - if ((q_func (opc).p_pp_f == make_list_p_pp) && - (is_t_integer (q_arg1 (opc).p)) && - (integer (q_arg1 (opc).p) >= 0) && - (integer (q_arg1 (opc).p) < sc->max_list_length)) { - q_call (opc).fp= opt_p_pp_cc_make_list; - q_arg1 (opc).i = integer (q_arg1 (opc).p); - } - else q_call (opc).fp= opt_p_pp_cc; - return_true (sc, expr); - } - if (is_symbol (arg2)) { - q_arg2 (opc).p= opt_simple_symbol (sc, arg2); - if (q_arg2 (opc).p) { - q_call (opc).fp= opt_p_pp_cs; - if (is_pair (slot_value (q_arg2 (opc).p))) { - if (func == assq_p_pp) q_func (opc).p_pp_f= s7_assq; - else if (func == memq_p_pp) q_func (opc).p_pp_f= s7_memq; - else if ((func == member_p_pp) && (is_simple (q_arg1 (opc).p))) - q_func (opc).p_pp_f= s7_memq; - else if (func == assoc_p_pp) { - if (is_simple (q_arg1 (opc).p)) q_func (opc).p_pp_f= s7_assq; - else if (is_pair (car (slot_value (q_arg2 (opc).p)))) - q_func (opc).p_pp_f= assoc_1; - } - } - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); - } - } +static bool let_equal_1(s7_scheme *sc, s7_pointer x_let, s7_pointer y_let, shared_info_t *ci, bool equivalent) +{ + int32_t x_len, y_len; - if ((car (expr) == sc->let_ref_symbol) && (is_pair (arg1)) && - ((is_symbol_and_keyword (arg2)) || ((is_quoted_symbol (sc, 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)) { - q_arg1 (opc).p= opt_simple_symbol (sc, arg2); - if (q_arg1 (opc).p) { - q_call (opc).fp= - (func == add_p_pp) - ? opt_p_pp_fs_add - : ((func == subtract_p_pp) - ? opt_p_pp_fs_sub - : ((func == s7i_vector_ref_p_pp) - ? opt_p_pp_fs_vref - : ((func == cons_p_pp) ? opt_p_pp_fs_cons - : opt_p_pp_fs))); - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - if (q_func1 (opc).fp == opt_p_p_s_random) - q_func1 (opc).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) { - q_arg2 (opc).i = integer (arg2); - q_func (opc).p_pi_f= ifunc; - if (!p_pi_fc_combinable (sc, opc)) { - q_call (opc).fp = opt_p_pi_fc; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - } - return_true (sc, expr); - } - } - q_arg2 (opc).p = (!is_pair (arg2)) ? arg2 : cadr (arg2); - q_call (opc).fp = opt_p_pp_fc; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - return_true (sc, expr); - } - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_func2_arg (opc).o1= o1; - q_func2 (opc).fp = q_call (o1).fp; - q_func3 (opc).fp = q_func3_arg (opc).q_call (o1).fp; - q_call (opc).fp = opt_p_pp_ff; - if ((q_func3 (opc).fp == opt_p_pp_sf_mul) && - (q_func2 (opc).fp == opt_p_pp_sf_mul)) { - if (func == add_p_pp) q_call (opc).fp= opt_p_pp_ff_add_mul_mul; - else if (func == subtract_p_pp) - q_call (opc).fp= opt_p_pp_ff_sub_mul_mul; - } - check_opc_vector_wraps (opc); - return_true (sc, expr); - } - } - } - sc->pc= pstart; - return_false (sc, expr); + 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); is_not_slot_end(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); is_not_slot_end(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); is_not_slot_end(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); + { + shared_info_t *nci = ci; + 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); is_not_slot_end(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))); } -/* -------- 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, q_p_func1_call (o)); - po2= q_p_func2_call (o); - po2= q_func (o).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= q_p_func1_call (o); - return (q_func (o).call ( - o->sc, set_plist_2 (o->sc, po1, slot_value (q_arg1 (o).p)))); -} - -static s7_pointer -opt_p_call_sf (opt_info* o) { - s7_pointer po1= q_p_func1_call (o); - return (q_func (o).call ( - o->sc, set_plist_2 (o->sc, slot_value (q_arg1 (o).p), po1))); -} - -static s7_pointer -opt_p_call_fc (opt_info* o) { - s7_pointer po1= q_p_func1_call (o); - return (q_func (o).call (o->sc, set_plist_2 (o->sc, po1, q_arg2 (o).p))); -} - -static s7_pointer -opt_p_call_cc (opt_info* o) { - return ( - q_func (o).call (o->sc, set_plist_2 (o->sc, q_arg1 (o).p, q_arg2 (o).p))); -} -static s7_pointer -opt_p_call_sc (opt_info* o) { - return (q_func (o).call ( - o->sc, set_plist_2 (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).p))); -} -static s7_pointer -opt_p_call_ss (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_2 (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p)))); -} - -static void -check_opc_vector_wraps_1 (opt_info* opc) { - if (q_func1 (opc).fp == opt_p_pi_ss_ivref_direct) - q_func1 (opc).fp= opt_p_pi_ss_ivref_direct_wrapped; - if (q_func1 (opc).fp == opt_p_pi_ss_fvref_direct) - q_func1 (opc).fp= opt_p_pi_ss_fvref_direct_wrapped; - if (q_func2 (opc).fp == opt_p_pi_ss_ivref_direct) - q_func2 (opc).fp= opt_p_pi_ss_ivref_direct_wrapped; - if (q_func2 (opc).fp == opt_p_pi_ss_fvref_direct) - q_func2 (opc).fp= opt_p_pi_ss_fvref_direct_wrapped; -} - -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); - q_func (opc).call= cf_call (sc, expr, s_func, 2); - if ((is_code_constant (sc, arg1)) && (is_code_constant (sc, arg2))) { - q_call (opc).fp= opt_p_call_cc; - q_arg1 (opc).p = (is_pair (arg1)) ? cadr (arg1) : arg1; - q_arg2 (opc).p = (is_pair (arg2)) ? cadr (arg2) : arg2; - return_true (sc, expr); - } - if (is_symbol (arg1)) { - q_arg1 (opc).p= s7_slot (sc, arg1); /* can be # */ - if ((is_slot (q_arg1 (opc).p)) && - (!has_methods (slot_value (q_arg1 (opc).p)))) { - if (is_symbol (arg2)) { - q_arg2 (opc).p= opt_simple_symbol (sc, arg2); - if (q_arg2 (opc).p) { - q_call (opc).fp= opt_p_call_ss; - return_true (sc, expr); - } - sc->pc= pstart; - return_false (sc, expr); - } - if (!is_pair (arg2)) { - q_arg2 (opc).p = arg2; - q_call (opc).fp= opt_p_call_sc; - return_true (sc, expr); - } - if (cell_optimize (sc, cddr (expr))) { - q_func1_arg (opc).o1= sc->opts[pstart]; - q_func1 (opc).fp = q_func1_arg (opc).q_call (o1).fp; - q_call (opc).fp = opt_p_call_sf; - return_true (sc, expr); - } - } - else { - sc->pc= pstart; - return_false (sc, expr); - } +/* 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); } - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdr (expr))) { - q_func1 (opc).fp= q_func1_arg (opc).q_call (o1).fp; - if (is_symbol (arg2)) { - q_arg1 (opc).p= opt_simple_symbol (sc, arg2); - if (q_arg1 (opc).p) { - q_call (opc).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-ciopts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_func2 (opc).fp= q_func2_arg (opc).q_call (o1).fp; - q_call (opc).fp = opt_p_call_ff; - check_opc_vector_wraps_1 (opc); - return_true (sc, expr); - } + 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)))); } - } - sc->pc= pstart; - return_false (sc, expr); + return(false); } -/* -------- p_pip --------*/ +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 s7_pointer -opt_p_pip_ssf (opt_info* o) { - return (q_func (o).p_pip_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_p_func1_call (o))); -} - -static s7_pointer -opt_p_pip_ssf_sset (opt_info* o) { - return (string_set_p_pip_direct (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_p_func1_call (o))); -} - -static s7_pointer -opt_p_pip_ssf_vset (opt_info* o) { - return (vector_set_p_pip_unchecked (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_p_func1_call (o))); -} - -static s7_pointer -opt_p_pip_sss (opt_info* o) { - return (q_func (o).p_pip_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - slot_value (q_arg3 (o).p))); -} - -static s7_pointer -opt_p_pip_sss_vset (opt_info* o) { - return (vector_set_p_pip_unchecked (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - slot_value (q_arg3 (o).p))); -} - -static s7_pointer -opt_p_pip_ssc (opt_info* o) { - return (q_func (o).p_pip_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_arg3 (o).p)); -} - -static s7_pointer -opt_p_pip_sff (opt_info* o) { - s7_int i1= q_i_func2_call (o); - return (q_func (o).p_pip_f (o->sc, slot_value (q_arg1 (o).p), i1, - q_p_func3_call (o))); -} - -static s7_pointer -opt_p_pip_sff_lset (opt_info* o) { - s7_int i1= q_i_func2_call (o); - return (list_set_p_pip_unchecked (o->sc, slot_value (q_arg1 (o).p), i1, - q_p_func3_call (o))); -} - -static s7_pointer -opt_p_pip_sso (opt_info* o) { - return (q_func (o).p_pip_f ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - q_func3 (o).p_pi_f (o->sc, slot_value (q_arg3 (o).p), - integer (slot_value (q_arg4 (o).p))))); -} - -static s7_pointer -opt_p_pip_ssf1 (opt_info* o) { - return (q_func (o).p_pip_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - q_func1 (o).p_p_f (o->sc, q_p_func2_call (o)))); -} - -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 ((q_call (o1).fp == opt_p_pi_ss) || - (q_call (o1).fp == opt_p_pi_ss_sref) || - (q_call (o1).fp == opt_p_pi_ss_vref) || - (q_call (o1).fp == opt_p_pi_ss_sref_direct) || - (q_call (o1).fp == opt_p_pi_ss_vref_direct) || - (q_call (o1).fp == opt_p_pi_ss_fvref_direct) || - (q_call (o1).fp == opt_p_pi_ss_ivref_direct) || - (q_call (o1).fp == opt_p_pi_ss_pref)) { - q_func (opc).p_pip_f= q_func (opc).p_pip_f; - q_func3 (opc).p_pi_f= q_func (o1).p_pi_f; - q_arg3 (opc).p = q_arg1 (o1).p; - q_arg4 (opc).p = q_arg2 (o1).p; - q_call (opc).fp = opt_p_pip_sso; - backup_pc (sc); - return_true (sc, NULL); - } +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))); } - o1= sc->opts[start]; - if (q_call (o1).fp != opt_p_p_f) return_false (sc, NULL); - q_func1 (opc).p_p_f = q_func1 (o1).p_p_f; - q_func2_arg (opc).o1= sc->opts[start + 1]; - q_func2 (opc).fp = q_call (sc->opts[start + 1]).fp; - q_call (opc).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, arg1_slot, 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 */ - arg1_slot= s7_slot (sc, cadr (expr)); - if (!is_slot (arg1_slot)) return_false (sc, expr); - obj1= slot_value (arg1_slot); - 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)); - q_arg1 (opc).p = arg1_slot; - obj = slot_value (q_arg1 (opc).p); - q_func (opc).p_pip_f= func; - if ((s7_p_pip_unchecked_function (s_func)) && (checker)) { - if ((is_t_vector (obj)) && (checker == sc->is_vector_symbol)) - q_func (opc).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? */ - q_func (opc).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)))) - q_func (opc).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 arg2_slot= opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - q_arg2 (opc).p= arg2_slot; - if (has_loop_end (arg2_slot)) switch (type (obj)) { - case T_VECTOR: - if (loop_end (arg2_slot) <= vector_length (obj)) - q_func (opc).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 (arg2_slot) <= vector_length (obj)) - q_func (opc).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 (arg2_slot) <= vector_length (obj)) - q_func (opc).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 (arg2_slot) <= vector_length (obj)) - q_func (opc).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 (arg2_slot) <= vector_length (obj)) - q_func (opc).p_pip_f= complex_vector_set_p_pip_direct; - break; - case T_STRING: - if (loop_end (arg2_slot) <= string_length (obj)) - q_func (opc).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); - /* 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) { - q_arg3 (opc).p = val_slot; - q_call (opc).fp= (q_func (opc).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))) { - q_arg3 (opc).p = (is_pair (arg3)) ? cadr (arg3) : arg3; - q_call (opc).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); - q_call (opc).fp= - (q_func (opc).p_pip_f == string_set_p_pip_direct) - ? opt_p_pip_ssf_sset - : ((q_func (opc).p_pip_f == vector_set_p_pip_unchecked) - ? opt_p_pip_ssf_vset - : opt_p_pip_ssf); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fp = q_call (sc->opts[start]).fp; - return_true (sc, expr); - } +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); } - } - else /* not symbol caddr */ + 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); { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdddr (expr))) { - q_call (opc).fp = (q_func (opc).p_pip_f == list_set_p_pip_unchecked) - ? opt_p_pip_sff_lset - : opt_p_pip_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fp= q_func3_arg (opc).q_call (o1).fp; - return_true (sc, expr); + 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)))); } - return_false (sc, expr); } -/* -------- p_piip -------- */ - -static s7_pointer -opt_p_piip_sssf (opt_info* o) { - return (q_func (o).p_piip_f ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), q_p_func2_call (o))); +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 s7_pointer -vector_set_piip_sssf_unchecked (opt_info* o) { - s7_pointer vec= slot_value (q_arg1 (o).p); - s7_pointer val= q_p_func2_call (o); - vector_element ( - vec, ((integer (slot_value (q_arg2 (o).p)) * vector_offset (vec, 0)) + - integer (slot_value (q_arg3 (o).p))))= val; - return (val); +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 s7_pointer -opt_p_piip_sssc (opt_info* o) { - return (q_func (o).p_piip_f ( - o->sc, slot_value (q_arg1 (o).p), integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)), q_arg4 (o).p)); +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 s7_pointer -opt_p_piip_sfff (opt_info* o) { - s7_int i1= q_i_func2_call (o); - s7_int i2= q_i_func3_call (o); - return (q_func (o).p_piip_f (o->sc, slot_value (q_arg1 (o).p), i1, i2, - q_p_func1_call (o))); +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 -p_piip_to_sx (s7_scheme* sc, opt_info* opc, s7_pointer indexp1, - s7_pointer indexp2, s7_pointer valp, s7_pointer obj) { - s7_pointer ind1_slot; - s7_pointer ind2_slot= opt_integer_symbol (sc, car (indexp2)); - if (!ind2_slot) - return_false ( - sc, indexp1); /* normally expr, indexp1 has more context than indexp2 */ - q_arg3 (opc).p= ind2_slot; - ind1_slot = opt_integer_symbol (sc, car (indexp1)); - if (ind1_slot) { - q_arg2 (opc).p= ind1_slot; - if ((is_symbol (car (valp))) || (is_unquoted_pair (sc, car (valp)))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, valp)) return_false (sc, indexp1); - q_func2 (opc).fp= q_func2_arg (opc).q_call (o1).fp; - q_call (opc).fp = opt_p_piip_sssf; - if ((is_t_vector (obj)) && - (loop_end_fits (q_arg2 (opc).p, vector_dimension (obj, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (obj, 1)))) - q_call (opc).fp= vector_set_piip_sssf_unchecked; - return_true (sc, NULL); - } - q_call (opc).fp= opt_p_piip_sssc; - q_arg4 (opc).p = (is_pair (car (valp))) ? cadar (valp) : car (valp); - return_true (sc, NULL); - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp1)) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp2)) { - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, valp)) { - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - q_func1 (opc).fp= q_func1_arg (opc).q_call (o1).fp; - q_call (opc).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 arg1_slot= s7_slot (sc, cadr (expr)); - if (!is_slot (arg1_slot)) return_false (sc, expr); - obj= slot_value (arg1_slot); - 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)) { - q_arg1 (opc).p = arg1_slot; - q_func (opc).p_piip_f= vector_set_p_piip; - return (p_piip_to_sx (sc, opc, cddr (expr), cdddr (expr), cddddr (expr), - obj)); +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); } - } - return_false (sc, expr); + 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); } -/* -------- p_pii -------- */ -static s7_pointer -opt_p_pii_sss (opt_info* o) { - return (q_func (o).p_pii_f (o->sc, slot_value (q_arg1 (o).p), - integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)))); -} - -static s7_pointer -opt_p_pii_sff (opt_info* o) { - s7_int i1= q_i_func2_call (o); - s7_int i2= q_i_func3_call (o); - return (q_func (o).p_pii_f (o->sc, slot_value (q_arg1 (o).p), i1, i2)); -} - -static s7_pointer -vector_ref_pii_sss_unchecked (opt_info* o) { - s7_pointer vec= slot_value (q_arg1 (o).p); - return (vector_element ( - vec, ((integer (slot_value (q_arg2 (o).p)) * vector_offset (vec, 0)) + - integer (slot_value (q_arg3 (o).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 arg1_slot= s7_slot (sc, cadr (expr)); - if (!is_slot (arg1_slot)) return_false (sc, expr); - obj= slot_value (arg1_slot); - if ((has_methods (obj)) || (is_immutable (obj))) return_false (sc, expr); - if ((is_t_vector (obj)) && (vector_rank (obj) == 2)) { - s7_pointer ind2_slot, indexp1= cddr (expr), indexp2= cdddr (expr); - q_arg1 (opc).p = arg1_slot; - q_func (opc).p_pii_f= vector_ref_p_pii; - ind2_slot = opt_integer_symbol (sc, car (indexp2)); - if (ind2_slot) { - s7_pointer ind1_slot; - q_arg3 (opc).p= ind2_slot; - ind1_slot = opt_integer_symbol (sc, car (indexp1)); - if (ind1_slot) { - q_arg2 (opc).p = ind1_slot; - q_call (opc).fp= opt_p_pii_sss; - /* normal vector rank 2 (see above) */ - if ((loop_end_fits ( - q_arg2 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 0))) && - (loop_end_fits ( - q_arg3 (opc).p, - vector_dimension (slot_value (q_arg1 (opc).p), 1)))) - q_call (opc).fp= vector_ref_pii_sss_unchecked; - return_true (sc, expr); - } - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp1)) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, indexp2)) { - q_call (opc).fp = opt_p_pii_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi= q_func3_arg (opc).q_call (o1).fi; - return_true (sc, expr); - } - } +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); } - } - return_false (sc, expr); -} + 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) -/* -------- p_ppi -------- */ -static s7_pointer -opt_p_ppi_psf (opt_info* o) { - return (q_func (o).p_ppi_f (o->sc, q_arg1 (o).p, slot_value (q_arg2 (o).p), - q_i_func1_call (o))); -} -static s7_pointer -opt_p_ppi_psf_cpos (opt_info* o) { - return (char_position_p_ppi (o->sc, q_arg1 (o).p, slot_value (q_arg2 (o).p), - q_i_func1_call (o))); -} - -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); - q_func (opc).p_ppi_f= ifunc; - if ((is_character (cadr (expr))) && (is_symbol (caddr (expr))) && - (int_optimize (sc, cdddr (expr)))) { - const s7_pointer arg2_slot= opt_simple_symbol (sc, caddr (expr)); - if (arg2_slot) { - q_arg1 (opc).p= cadr (expr); - q_arg2 (opc).p= arg2_slot; - q_call (opc).fp= - (ifunc == char_position_p_ppi) ? opt_p_ppi_psf_cpos : opt_p_ppi_psf; - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fi = q_call (sc->opts[start]).fi; - return_true (sc, expr); +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); } - } - sc->pc= start; - return_false (sc, expr); + /* 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); } -/* -------- p_ppp -------- */ +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 s7_pointer -opt_p_ppp_ssf (opt_info* o) { - return (q_func (o).p_ppp_f (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), q_p_func1_call (o))); -} -static s7_pointer -opt_p_ppp_hash_table_increment (opt_info* o) { - return (fx_hash_table_increment_1 (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), q_arg3 (o).p)); -} -static s7_pointer -opt_p_ppp_sfs (opt_info* o) { - return (q_func (o).p_ppp_f (o->sc, slot_value (q_arg1 (o).p), - q_p_func1_call (o), slot_value (q_arg2 (o).p))); -} -static s7_pointer -opt_p_ppp_scs (opt_info* o) { - return (q_func (o).p_ppp_f (o->sc, slot_value (q_arg1 (o).p), q_arg2 (o).p, - slot_value (q_arg3 (o).p))); -} -static s7_pointer -opt_p_ppp_sss (opt_info* o) { - return (q_func (o).p_ppp_f (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), - slot_value (q_arg3 (o).p))); -} -static s7_pointer -opt_p_ppp_sss_mul (opt_info* o) { - return (multiply_p_ppp (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), - slot_value (q_arg3 (o).p))); -} -static s7_pointer -opt_p_ppp_sss_hset (opt_info* o) { - return (s7_hash_table_set (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), - slot_value (q_arg3 (o).p))); -} -static s7_pointer -opt_p_ppp_ssc (opt_info* o) { - return (q_func (o).p_ppp_f (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), q_arg3 (o).p)); -} -static s7_pointer -opt_list_3c (opt_info* o) { - s7_scheme* sc= o->sc; - return (list_3 (sc, q_arg1 (o).p, q_arg2 (o).p, q_arg3 (o).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 (q_p_func2_call (o)), - T_Ext (q_p_func3_call (o))); - result= q_func (o).p_ppp_f (o->sc, slot_value (q_arg1 (o).p), - gc_protected1 (sc), gc_protected2 (sc)); - unstack_gc_protect (sc); - return (result); +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 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 (q_p_func2_call (o)), - T_Ext (q_p_func3_call (o))); - result= q_func (o).p_ppp_f (sc, gc_protected1 (sc), gc_protected2 (sc), - q_p_func1_call (o)); - unstack_gc_protect (sc); - return (result); -} - -static s7_pointer -opt_p_ppc_slot_set (opt_info* o) { - slot_set_value (q_arg2 (o).p, q_arg3 (o).p); - return (q_arg3 (o).p); -} -static s7_pointer -opt_p_pps_slot_set (opt_info* o) { - slot_set_value (q_arg2 (o).p, slot_value (q_arg3 (o).p)); - return (slot_value (q_arg3 (o).p)); -} -static s7_pointer -opt_p_ppf_slot_set (opt_info* o) { - slot_set_value (q_arg2 (o).p, q_p_func1_call (o)); - return (slot_value (q_arg2 (o).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))) { - q_arg2 (opc).p = slot; - q_arg3 (opc).p = value; - q_call (opc).fp= opt_p_ppc_slot_set; - return (true); - } - return (false); +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 -use_pps_slot_set (s7_scheme* sc, opt_info* opc, s7_pointer let, - s7_pointer symbol, s7_pointer val_slot) /* timp tref */ +static bool complex_vector_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) { - s7_pointer slot= lookup_slot_with_let (sc, symbol, let); - if ((is_slot (slot)) && (!is_immutable (slot))) { - q_arg2 (opc).p = slot; - q_arg3 (opc).p = val_slot; - q_call (opc).fp= opt_p_pps_slot_set; - return (true); - } - return (false); + 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 -use_ppf_slot_set (s7_scheme* sc, opt_info* opc, s7_pointer let, - s7_pointer symbol) /* timp */ +static bool vector_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) { - s7_pointer slot= lookup_slot_with_let (sc, symbol, let); - if ((is_slot (slot)) && (!is_immutable (slot))) { - q_arg2 (opc).p = slot; - q_call (opc).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); - q_func (opc).p_ppp_f= func; - if (is_symbol (arg1)) { - s7_pointer obj; - opt_info* o1; - s7_pointer arg1_slot= s7_slot (sc, arg1); - if ((!is_slot (arg1_slot)) || (has_methods (slot_value (arg1_slot)))) - return_false (sc, expr); - - obj= slot_value (arg1_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); - - q_arg1 (opc).p= arg1_slot; - - if ((func == hash_table_set_p_ppp) && (is_hash_table (obj))) - q_func (opc).p_ppp_f= s7_hash_table_set; - - if (is_symbol (arg2)) { - s7_pointer arg2_slot; - if ((is_keyword (arg2)) && (is_symbol (arg3)) && (is_let (obj)) && - (q_func (opc).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); - } - arg2_slot= opt_simple_symbol (sc, arg2); - if (arg2_slot) { - const s7_pointer arg2_val= slot_value (arg2_slot); - q_arg2 (opc).p = arg2_slot; - if (is_symbol (arg3)) { - s7_pointer arg3_slot; - arg3_slot= opt_simple_symbol (sc, arg3); - if (arg3_slot) { - s7_p_ppp_t func1= q_func (opc).p_ppp_f; - q_arg3 (opc).p = arg3_slot; /* some other caller depends on this? - op_simple_do_1[86577]: not a slot */ - q_call (opc).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))) { - q_arg3 (opc).p = (is_pair (arg3)) ? cadr (arg3) : arg3; - q_call (opc).fp= opt_p_ppp_ssc; - if ((is_let (obj)) && (q_func (opc).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, - q_arg3 (opc).p); - return_true (sc, expr); - } - if (optimize_op (expr) == HOP_HASH_TABLE_INCREMENT) { - q_call (opc).fp= opt_p_ppp_hash_table_increment; - q_arg3 (opc).p = expr; - return_true (sc, expr); - } - if (cell_optimize (sc, cdddr (expr))) { - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fp = q_func1_arg (opc).q_call (o1).fp; - q_call (opc).fp = opt_p_ppp_ssf; - if ((is_let (obj)) && (is_symbol_and_keyword (arg2_val)) && - (q_func (opc).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 (q_func1_arg (opc).q_func (o1).p_pp_f == - complex_p_pp) /* same as below but (complex d d)?? d float */ - q_func1_arg (opc).q_func (o1).p_pp_f= complex_p_pp_wrapped; - else if (q_func1_arg (opc).q_func (o1).p_dd_f == - complex_p_dd) /* same below but (complex d 1.0), d float - stepper */ - q_func1_arg (opc).q_func (o1).p_dd_f= complex_p_dd_wrapped; - else if (q_func1_arg (opc).q_func (o1).p_ii_f == - complex_p_ii) /* (complex-vector-set! cv1 i (complex i i)) - */ - q_func1_arg (opc).q_func (o1).p_ii_f= complex_p_ii_wrapped; - } - 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) { - q_arg2 (opc).p = cadr (arg2); - q_arg3 (opc).p = val_slot; - q_call (opc).fp= opt_p_ppp_scs; - if ((is_let (obj)) && (q_func (opc).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) { - q_arg2 (opc).p= val_slot; - q_call (opc).fp= - opt_p_ppp_sfs; /* hset case goes through the case below */ - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - return_true (sc, expr); - } - } - if ((!is_pair (arg3)) && (is_let (obj)) && - (is_quoted_symbol (sc, arg2)) && - (q_func (opc).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 (sc, arg2)) && - (q_func (opc).p_ppp_f == - let_set_2) && /* (let-set! L3 'x (+ (L3 'x) 1)) */ - (use_ppf_slot_set (sc, opc, obj, cadr (arg2)))) { - q_func1_arg (opc).o1= o2; - q_func1 (opc).fp = q_func1_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - q_call (opc).fp = opt_p_ppp_sff; - q_func2_arg (opc).o1= o1; - q_func2 (opc).fp = q_call (o1).fp; - q_func3_arg (opc).o1= o2; - q_func3 (opc).fp = q_call (o2).fp; - return_true (sc, expr); - } + /* if this is split like vector_equal above, remember it is called by iterator_equal_1 below */ + s7_int len; + if (x == y) + return(true); + if (!is_any_vector(y)) + { + check_equivalent_method(sc, y, x); + return(false); } - } - else /* arg1 not symbol */ + 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)); { - q_func2_arg (opc).o1= sc->opts[start]; - if (cell_optimize (sc, cdr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_func1_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cdddr (expr))) { - q_call (opc).fp = opt_p_ppp_fff; - q_func2 (opc).fp= q_func2_arg (opc).q_call (o1).fp; - q_func3 (opc).fp= q_func3_arg (opc).q_call (o1).fp; - q_func1 (opc).fp= q_func1_arg (opc).q_call (o1).fp; - if ((q_func (opc).p_ppp_f == list_p_ppp) && - (q_func1 (opc).fp == opt_p_c) && (q_func3 (opc).fp == opt_p_c) && - (q_func2 (opc).fp == opt_p_c)) { - q_call (opc).fp= opt_list_3c; - q_arg1 (opc).p = q_func2_arg (opc).q_arg1 (o1).p; - q_arg2 (opc).p = q_func3_arg (opc).q_arg1 (o1).p; - q_arg3 (opc).p = q_func1_arg (opc).q_arg1 (o1).p; - } - return_true (sc, expr); - } + shared_info_t *nci = ci; + 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); } - sc->pc= start; - return_false (sc, expr); + return(true); } -/* -------- p_call_ppp -------- */ -static s7_pointer -opt_p_call_sss (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_3 (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), - slot_value (q_arg3 (o).p)))); -} +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; -static s7_pointer -opt_p_call_ccs (opt_info* o) { - return ( - q_func (o).call (o->sc, set_plist_3 (o->sc, q_arg1 (o).p, q_arg2 (o).p, - slot_value (q_arg3 (o).p)))); -} + if (x == y) return(true); + if (!is_iterator(y)) return(false); + x_seq = iterator_sequence(x); + y_seq = iterator_sequence(y); -static s7_pointer -opt_p_call_scs (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_3 (o->sc, slot_value (q_arg1 (o).p), - q_arg2 (o).p, - slot_value (q_arg3 (o).p)))); -} + 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))? */ -static s7_pointer -opt_p_call_css (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_3 (o->sc, q_arg1 (o).p, - slot_value (q_arg2 (o).p), - slot_value (q_arg3 (o).p)))); -} + 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); -static s7_pointer -opt_p_call_ssf (opt_info* o) { - return (q_func (o).call (o->sc, set_plist_3 (o->sc, slot_value (q_arg1 (o).p), - slot_value (q_arg2 (o).p), - q_p_func1_call (o)))); -} + 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); -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, q_p_func1_call (o), q_p_func3_call (o)); - result= q_p_func2_call (o); /* not combinable into next */ - result= q_func (o).call ( - sc, set_plist_3 (sc, gc_protected1 (sc), gc_protected2 (sc), result)); - if (stack_top_op (sc) == OP_GC_PROTECT) 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))) { - 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)) { - const s7_pointer arg1_slot= opt_simple_symbol (sc, arg1); - if (arg1_slot) { - q_arg1 (opc).p= arg1_slot; - if ((s_func == global_value (sc->vector_ref_symbol)) && - (is_t_vector (slot_value (arg1_slot))) && - (vector_rank (slot_value (arg1_slot)) != 2)) - return_false (sc, expr); - /* arg1 ok as symbol */ - if ((is_code_constant (sc, arg2)) && (is_normal_symbol (arg3))) { - const s7_pointer val_slot= opt_simple_symbol (sc, arg3); - if (val_slot) { - q_arg2 (opc).p = arg2; - q_arg3 (opc).p = val_slot; - q_func (opc).call= cf_call (sc, expr, s_func, 3); - if ((sc->do_body_p == expr) && (arg1 == sc->F) && - (car (expr) == sc->format_symbol)) - q_func (opc).call= g_format_nr; - q_call (opc).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) { - q_arg1 (opc).p = arg1; - q_arg2 (opc).p = (is_pair (arg2)) ? cadr (arg2) : arg2; - q_arg3 (opc).p = val_slot; - q_func (opc).call= cf_call (sc, expr, s_func, 3); - if ((sc->do_body_p == expr) && (arg1 == sc->F) && - (car (expr) == sc->format_symbol)) - q_func (opc).call= g_format_nr; - q_call (opc).fp= opt_p_call_ccs; - return_true (sc, expr); - } - } - q_arg1 (opc).p= arg1; - if (s_func == global_value (sc->vector_ref_symbol)) - return_false (sc, expr); - } - if (is_normal_symbol (arg2)) { - const s7_pointer arg2_slot= opt_simple_symbol (sc, arg2); - if (arg2_slot) { - q_arg2 (opc).p= arg2_slot; - if (is_normal_symbol (arg3)) { - const s7_pointer arg3_slot= opt_simple_symbol (sc, arg3); - if (arg3_slot) { - q_arg3 (opc).p = arg3_slot; - q_func (opc).call= cf_call (sc, expr, s_func, 3); - q_call (opc).fp= - (is_slot (q_arg1 (opc).p)) ? opt_p_call_sss : opt_p_call_css; - return_true (sc, expr); - } - } - else if (is_slot (q_arg1 (opc).p)) { - const int32_t start1= sc->pc; - if ((cf_call (sc, expr, s_func, 3) == g_substring_uncopied) && - (is_t_integer (slot_value (q_arg2 (opc).p))) && - (is_string (slot_value (q_arg1 (opc).p))) && - (int_optimize (sc, cdddr (expr)))) { - q_call (opc).fp = opt_p_substring_uncopied_ssf; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fi = q_call (o1).fi; - return_true (sc, expr); - } - sc->pc= start1; - if (cell_optimize (sc, cdddr (expr))) { - q_func (opc).call = cf_call (sc, expr, s_func, 3); - q_call (opc).fp = opt_p_call_ssf; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).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))) { - q_func (opc).call = cf_call (sc, expr, s_func, 3); - q_call (opc).fp = opt_p_call_ppp; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - q_func3_arg (opc).o1= o2; - q_func3 (opc).fp = q_call (o2).fp; - q_func2_arg (opc).o1= o3; - q_func2 (opc).fp = q_call (o3).fp; - return_true (sc, expr); - } + /* 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); is_not_slot_end(xs) && is_not_slot_end(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)); } - } - } - sc->pc= start; - return_false (sc, expr); -} + 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)); -/* -------- p_call_any -------- */ -#define p_call_o1 3 -#define q_p_call_f(o) o->v[2] -#define q_p_call_arg(o, i) o->v[i] + case T_CLOSURE: case T_CLOSURE_STAR: + return(x_seq == y_seq); /* or closure_equal/equivalent? */ -static s7_pointer -opt_p_call_any (opt_info* o) { - s7_scheme* sc = o->sc; - s7_pointer val= safe_list_if_possible (sc, q_arg1 (o).i); - s7_pointer arg= val; - if (in_heap (val)) gc_protect_via_stack_no_let (sc, val); - for (s7_int i= 0; i < q_arg1 (o).i; i++, arg= cdr (arg)) { - opt_info* o1= q_p_call_arg (o, i + p_call_o1).o1; - set_car (arg, q_call (o1).fp (o1)); - } - arg= q_p_call_f (o).call (sc, val); - if (in_heap (val)) unstack_gc_protect (sc); - else clear_safe_list_in_use (sc, val); - return (arg); -} - -static s7_pointer -opt_p_call_4g (opt_info* o) { - s7_scheme* sc= o->sc; - opt_info* o1= q_p_call_arg (o, 0 + p_call_o1).o1; - opt_info* o2= q_p_call_arg (o, 1 + p_call_o1).o1; - opt_info* o3= q_p_call_arg (o, 2 + p_call_o1).o1; - opt_info* o4= q_p_call_arg (o, 3 + p_call_o1).o1; - return (q_p_call_f (o).call ( - o->sc, set_plist_4 (sc, q_call (o1).fp (o1), q_call (o2).fp (o2), - q_call (o3).fp (o3), q_call (o4).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 */ - q_arg1 (opc).i= (len - 1); /* also ccff in cb.scm I think */ - for (int32_t pctr= p_call_o1; is_pair (p); pctr++, p= cdr (p)) { - q_p_call_arg (opc, pctr).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, p)) break; - if (is_pair (car (p))) safe= false; - } - if (is_null (p)) { - q_call (opc).fp= ((len == 5) && (safe)) ? opt_p_call_4g : opt_p_call_any; - q_p_call_f (opc).call= cf_call (sc, expr, s_func, len - 1); - return_true (sc, expr); + default: break; } - } - return_false (sc, expr); + return(false); } -/* -------- p_fx_any -------- */ +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));} -static s7_pointer -opt_p_fx_any (opt_info* o) { - return (q_func (o).call (o->sc, q_arg1 (o).p)); -} -static void fx_annotate_arg (s7_scheme* sc, s7_pointer arg, - s7_pointer let_or_list); -static bool -p_fx_any_ok (s7_scheme* sc, opt_info* opc, s7_pointer expr) { - s7_function func= ((is_pair (car (expr))) && (has_fx (car (expr)))) - ? fx_proc (car (expr)) - : NULL; -#if 0 - /* this is slower! -- fx choices are pessimal here */ - if ((!func) && (is_fxable(sc, car(expr)))) {fx_annotate_arg(sc, expr, sc->curlet); if (has_fx(expr)) func = fx_proc(expr);} -#endif - if (!func) return_false (sc, expr); - q_call (opc).fp = opt_p_fx_any; - q_func (opc).call= func; - q_arg1 (opc).p = car (expr); - return_true (sc, expr); +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)); + return(false); } -/* -------- p_implicit -------- */ +/* 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))); + return(false); +} -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); - q_arg1 (opc).p= s_slot; - start = sc->pc; - if (len == 2) { - switch (type (obj)) { - case T_PAIR: - q_func (opc).p_pi_f= list_ref_p_pi_unchecked; - break; - case T_HASH_TABLE: - q_func (opc).p_pp_f= s7_hash_table_ref; - break; - case T_LET: - q_func (opc).p_pp_f= let_ref; - break; - case T_STRING: - q_func (opc).p_pi_f= string_ref_p_pi_unchecked; - break; - case T_C_OBJECT: - return_false (sc, expr); /* no pi_ref because ref assumes pp */ +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)); + return(false); +} - case T_VECTOR: - if (vector_rank (obj) != 1) return_false (sc, expr); - q_func (opc).p_pi_f= t_vector_ref_p_pi_unchecked; - break; +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))); + return(false); +} - 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); - q_func (opc).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 arg1_slot= s7_slot ( - sc, arg1); /* not the desired slot if let+keyword, see below */ - if (is_slot (arg1_slot)) { - q_arg2 (opc).p= arg1_slot; - if ((!is_hash_table (obj)) && /* these because opt_int below */ - (!is_let (obj))) { - if (!is_t_integer (slot_value (arg1_slot))) - return_false (sc, expr); /* I think this reflects that a non-int - index is an error for list-ref et al */ - q_call (opc).fp= opt_p_pi_ss; /* TODO: this now uses 1/2 not 2/1 */ - if (has_loop_end (q_arg2 (opc).p)) - check_unchecked (sc, obj, q_arg2 (opc).p, opc, NULL); - fixup_p_pi_ss (opc); - return_true (sc, expr); - } - q_call (opc).fp= - ((is_hash_table (obj)) && - (q_func (opc).p_pp_f == s7_hash_table_ref)) - ? opt_p_pp_ss_href - : (((is_let (obj)) && (q_func (opc).p_pp_f == let_ref)) - ? opt_p_pp_ss_lref - : opt_p_pp_ss); - if ((q_call (opc).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 */ +static bool integer_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + switch (type(y)) { - if ((!is_hash_table (obj)) && (!is_let (obj))) { - opt_info* o1; - if (is_t_integer (arg1)) { - q_arg2 (opc).i = integer (arg1); - q_call (opc).fp= opt_p_pi_sc; - return_true (sc, expr); - } - o1= sc->opts[sc->pc]; - if (!int_optimize (sc, cdr (expr))) return_false (sc, expr); - q_call (opc).fp = opt_p_pi_sf; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fi = q_call (o1).fi; - return_true (sc, expr); - } - if ((!is_pair (arg1)) || (is_proper_quote (sc, arg1))) { - q_arg2 (opc).p = (!is_pair (arg1)) ? arg1 : cadr (arg1); - q_call (opc).fp= opt_p_pp_sc; - if ((is_pair (arg1)) && (is_symbol (q_arg2 (opc).p)) && - (is_let (obj)) && (q_func (opc).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) */ - q_call (opc).fp= - ((is_hash_table (obj)) && - (q_func (opc).p_pp_f == s7_hash_table_ref)) - ? opt_p_pp_sf_href - : (((is_let (obj)) && (q_func (opc).p_pp_f == let_ref)) - ? opt_p_pp_sf_lref - : opt_p_pp_sf); - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fp = q_call (sc->opts[start]).fp; - return_true (sc, expr); - } - } - } /* len==2 */ - else { /* len > 2 */ - if ((is_t_vector (obj)) && (len == 3) && (vector_rank (obj) == 2)) { - const s7_pointer arg2_slot= opt_integer_symbol (sc, caddr (expr)); - if (arg2_slot) { - s7_pointer arg1_slot; - q_arg3 (opc).p= arg2_slot; - arg1_slot = opt_integer_symbol (sc, arg1); - if (arg1_slot) { - q_arg2 (opc).p = arg1_slot; - q_func (opc).p_pii_f= vector_ref_p_pii; - q_call (opc).fp = opt_p_pii_sss; - if ((loop_end_fits (q_arg2 (opc).p, vector_dimension (obj, 0))) && - (loop_end_fits (q_arg3 (opc).p, vector_dimension (obj, 1)))) - q_call (opc).fp= vector_ref_pii_sss_unchecked; - return_true (sc, expr); - } - } - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (expr))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cddr (expr))) { - q_call (opc).fp = opt_p_pii_sff; - q_func2 (opc).fi = q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fi = q_func3_arg (opc).q_call (o1).fi; - q_func (opc).p_pii_f= vector_ref_p_pii_direct; - return_true (sc, expr); - } - } - sc->pc= start; + 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)))); } + return(false); +} -#define P_IMPLICIT_CALL_O1 4 - if (len < (num_vunions - P_IMPLICIT_CALL_O1)) /* mimic p_call_any_ok */ +static bool fraction_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + switch (type(y)) { - s7_pointer p = expr; - q_arg1 (opc).i= len; - for (int32_t pctr= (P_IMPLICIT_CALL_O1 - 1); is_pair (p); - pctr++, p= cdr (p)) { - q_p_call_arg (opc, 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 */ - q_call (opc).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: - q_p_call_f (opc).call= g_int_vector_ref; - break; - case T_BYTE_VECTOR: - q_p_call_f (opc).call= g_byte_vector_ref; - break; - case T_FLOAT_VECTOR: - q_p_call_f (opc).call= g_float_vector_ref; - break; - case T_COMPLEX_VECTOR: - q_p_call_f (opc).call= g_complex_vector_ref; - break; - case T_VECTOR: - q_p_call_f (opc).call= g_vector_ref; - break; - default: - return_false (sc, expr); - } - return_true (sc, expr); - } + 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)))); } - } - return_false (sc, expr); + return(false); } -/* -------- 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); - q_arg1 (opc).p = cadr (expr); - q_call (opc).fp= opt_p_c; - return_true (sc, expr); -} - -/* -------- cell_set -------- */ -static s7_pointer -opt_set_p_p_f (opt_info* o) { - s7_pointer val= q_p_func1_call (o); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_p_f_with_setter (opt_info* o) { - s7_pointer val= q_p_func1_call (o); - call_c_function_setter (o->sc, slot_setter (q_arg1 (o).p), - slot_symbol (q_arg1 (o).p), val); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_input_port_string_p_p_f (opt_info* o) { - s7_pointer val = q_p_func1_call (o); /* the string */ - s7_pointer port= slot_value (q_arg2 (o).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 = q_p_func1_call (o); /* the string */ - s7_pointer port= slot_value (q_arg2 (o).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 (q_arg2 (o).p); - if (is_mutable_integer (val)) val= make_integer (o->sc, integer (val)); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_i_f (opt_info* o) { - s7_pointer val= make_integer (o->sc, q_i_func1_call (o)); - slot_set_value (q_arg1 (o).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 (q_arg2 (o).p); - if (is_mutable_number (val)) val= make_real (o->sc, real (val)); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_d_f (opt_info* o) { - s7_pointer val= make_real (o->sc, q_d_func1_call (o)); - slot_set_value (q_arg1 (o).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 (q_func1_arg (o).o1)); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_d_fm_sf_add (opt_info* o) { - s7_double x1= opt_d_dd_sf_add (q_func1_arg (o).o1); - check_mutability (o->sc, o, __func__, __LINE__); - set_real (slot_value (q_arg1 (o).p), x1); - return (slot_value (q_arg1 (o).p)); -} - -static s7_pointer -opt_set_p_d_f_mm_add ( - opt_info* o) /* see set_p_d_f_combinable below, tfft for both */ -{ - s7_double x1= float_vector_ref_d_7pi (o->sc, slot_value (q_arg2 (o).p), - integer (slot_value (q_arg3 (o).p))) * - real (slot_value (q_arg1 (o).p)); - s7_double x2= - float_vector_ref_d_7pi (o->sc, slot_value (q_func2_arg (o).p), - integer (slot_value (q_func3_arg (o).p))) * - real (slot_value (q_arg4 (o).p)); - slot_set_value (q_arg1 (o).p, make_real (o->sc, x1 + x2)); - return (slot_value (q_arg1 (o).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 (q_arg2 (o).p), - integer (slot_value (q_arg3 (o).p))) * - real (slot_value (q_arg1 (o).p)); - s7_double x2= - float_vector_ref_d_7pi (o->sc, slot_value (q_func2_arg (o).p), - integer (slot_value (q_func3_arg (o).p))) * - real (slot_value (q_arg4 (o).p)); - slot_set_value (q_arg1 (o).p, make_real (o->sc, x1 - x2)); - return (slot_value (q_arg1 (o).p)); -} - -static s7_pointer -opt_set_p_c (opt_info* o) { - slot_set_value (q_arg1 (o).p, q_arg2 (o).p); - return (q_arg2 (o).p); -} - -static s7_pointer -opt_set_p_i_fo (opt_info* o) { - s7_int i = q_func (o).i_ii_f (integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p))); - s7_pointer val= make_integer (o->sc, i); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_i_fo_add (opt_info* o) { - s7_int i= - integer (slot_value (q_arg2 (o).p)) + integer (slot_value (q_arg3 (o).p)); - s7_pointer val= make_integer (o->sc, i); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_i_fo1 (opt_info* o) { - s7_int i= - q_func (o).i_ii_f (integer (slot_value (q_arg2 (o).p)), q_arg3 (o).i); - s7_pointer val= make_integer (o->sc, i); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static s7_pointer -opt_set_p_i_fo1_add (opt_info* o) { - s7_int i = integer (slot_value (q_arg2 (o).p)) + q_arg3 (o).i; - s7_pointer val= make_integer (o->sc, i); - slot_set_value (q_arg1 (o).p, val); - return (val); -} - -static bool -set_p_i_f_combinable (s7_scheme* sc, opt_info* opc) { - /* arg1 is set already */ - if ((sc->pc > 1) && (opc == sc->opts[sc->pc - 2])) { - opt_info* o1= sc->opts[sc->pc - 1]; - if ((q_call (o1).fi == opt_i_ii_ss) || - (q_call (o1).fi == opt_i_ii_ss_add)) { - q_func (opc).i_ii_f= q_func (o1).i_ii_f; - q_arg2 (opc).p = q_arg1 (o1).p; - q_arg3 (opc).p = q_arg2 (o1).p; - q_call (opc).fp= (q_call (o1).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 ((q_call (o1).fi == opt_i_ii_sc) || - (q_call (o1).fi == opt_i_ii_sc_add) || - (q_call (o1).fi == opt_i_ii_sc_sub)) { - q_func (opc).i_ii_f= q_func (o1).i_ii_f; - q_arg2 (opc).p = q_arg1 (o1).p; - q_arg3 (opc).i = q_arg2 (o1).i; - q_call (opc).fp= (q_call (o1).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 ((q_call (o1).fd == opt_d_mm_fff) && - ((q_func (o1).d_dd_f == add_d_dd) || - (q_func (o1).d_dd_f == subtract_d_dd))) { - opt_info* o2 = sc->opts[sc->pc - 2]; - q_call (opc).fp = (q_func (o1).d_dd_f == add_d_dd) - ? opt_set_p_d_f_mm_add - : opt_set_p_d_f_mm_subtract; - q_arg1 (opc).p = q_arg1 (o2).p; - q_arg2 (opc).p = q_arg2 (o2).p; - q_arg3 (opc).p = q_arg3 (o2).p; - o1 = sc->opts[sc->pc - 1]; - q_arg4 (opc).p = q_arg1 (o1).p; - q_func2_arg (opc).p= q_arg2 (o1).p; - q_func3_arg (opc).p= q_arg3 (o1).p; - sc->pc-= 3; - return_true (sc, NULL); +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)))); } - } - return_false (sc, NULL); + return(false); } -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))) { - /* fprintf(stderr, "%d: %s %s\n", __LINE__, display(expr), - * display(target)); */ - q_call (opc).fp = opt_set_p_p_f; - q_func1_arg (opc).o1= sc->opts[start_pc]; - q_func1 (opc).fp = q_call (sc->opts[start_pc]).fp; - return_true (sc, expr); - } +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)))); } - } - return_false (sc, expr); -} - -static s7_pointer -opt_starlet_set (opt_info* o) { - s7_pointer val= q_func (o).fp (q_arg2 (o).o1); - return (starlet_set_1 (o->sc, q_arg1 (o).p, val)); -} - -static s7_pointer -opt_starlet_set_i (opt_info* o) { - return (starlet_set_1 (o->sc, q_arg1 (o).p, q_arg2 (o).p)); -} - -static s7_pointer -list_increment_p_pip_unchecked (opt_info* o) { - s7_scheme* sc = o->sc; - s7_pointer num = slot_value (q_arg2 (o).p), lst, p; - s7_int index= integer (num); - if ((index < 0) || (index > sc->max_list_length)) - list_set_index_check_nr (sc, index); - lst= slot_value (q_arg1 (o).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); - } - { - s7_pointer value= g_add_xi (sc, car (p), integer (q_arg3 (o).p), index); - set_car (p, value); - return (value); - } + return(false); } -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; - q_arg1 (opc).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)))) { - q_call (opc).fp = opt_set_p_p_f_with_setter; - q_func1_arg (opc).o1= sc->opts[start_pc]; - q_func1 (opc).fp = q_call (sc->opts[start_pc]).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) { - q_arg2 (opc).p = val_slot; - q_call (opc).fp= opt_set_p_i_s; - return_true (sc, expr); - } - } - else { - q_func1_arg (opc).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)) { - q_call (opc).fp = opt_set_p_i_f; - q_func1 (opc).fi= q_func1_arg (opc).q_call (o1).fi; - } - return_true (sc, expr); - } - return_false (sc, expr); - } - if (stype == sc->is_float_symbol) { - if (is_t_real (value)) { - q_arg2 (opc).p = value; - q_call (opc).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) { - q_arg2 (opc).p = val_slot; - q_call (opc).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)) { - q_func1_arg (opc).o1= sc->opts[start_pc]; - q_func1 (opc).fd = q_call (sc->opts[start_pc]).fd; - q_call (opc).fp = (q_func1 (opc).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); - /* TODO: here if atype is float? or integer? or boolean? we should call - * the appropriate optimizer! */ - if (cell_optimize (sc, cddr (expr))) { - /* fprintf(stderr, "%d: %s %s %s %s\n", __LINE__, display(expr), - * display(target), display(atype), display(stype)); */ - q_call (opc).fp = opt_set_p_p_f; - q_func1_arg (opc).o1= sc->opts[start_pc]; - q_func1 (opc).fp = q_call (sc->opts[start_pc]).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 obj_slot= s7_slot (sc, car (target)); - if (!is_slot (obj_slot)) return_false (sc, expr); - obj = slot_value (obj_slot); - q_arg1 (opc).p= obj_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; - q_arg2 (opc).p = s7_t_slot (sc, index); - if ((is_slot (q_arg2 (opc).p)) && - (is_string_port (slot_value (q_arg2 (opc).p))) && - (cell_optimize (sc, cddr (expr)))) { - q_func1_arg (opc).o1= sc->opts[start_pc]; - q_func1 (opc).fp = q_call (sc->opts[start_pc]).fp; - q_call (opc).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 (sc, index))) { - s7_pointer sym= (is_quoted_symbol (sc, index)) - ? cadr (index) - : keyword_symbol (index); - if (starlet_symbol_id (sym) != sl_no_field) { - q_arg1 (opc).p= sym; - if (is_t_integer (caddr (expr))) { - q_call (opc).fp= opt_starlet_set_i; - q_arg2 (opc).p = caddr (expr); - return_true (sc, expr); - } - q_arg2 (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_call (opc).fp= opt_starlet_set; - q_func (opc).fp= - q_arg2 (opc).q_call (o1).fp; /* TODO: fix this! */ - 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); - q_func (opc).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); - q_func (opc).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); - q_func (opc).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; +static bool random_state_equal(s7_scheme *sc, s7_pointer x, s7_pointer y, shared_info_t *ci) +{ + return((x == y) || + ((is_random_state(y)) && + (random_seed(x) == random_seed(y)) && + (random_carry(x) == random_carry(y)))); +} - 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))) { - q_temp (opc).fd= q_call (opc).fd; - q_call (opc).fp= d_to_p; - return_true (sc, expr); - } - return_false (sc, expr); +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)));} - 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); - q_func (opc).p_pip_f= complex_vector_set_p_pip_unchecked; - } - else return_false (sc, expr); - break; +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; + 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; + 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));} - 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))) { - q_temp (opc).fi= q_call (opc).fi; - q_call (opc).fp= i_to_p; - return_true (sc, expr); - } - return_false (sc, expr); +/* g_is_equal and g_is_equivalent are now in s7_scheme_predicate.c */ +#define H_is_equal "(equal? obj1 obj2) returns #t if obj1 is equal to obj2" +#define Q_is_equal sc->pcl_bt +#define H_is_equivalent "(equivalent? obj1 obj2) returns #t if obj1 is close enough to obj2." +#define Q_is_equivalent sc->pcl_bt - 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); - q_func (opc).d_7pid_f= func; - q_func2_arg (opc).o1 = sc->opts[sc->pc]; - if (slot) { - if (float_optimize (sc, cddr (expr))) { - q_temp (opc).fd= opt_d_7pid_ssf; - q_call (opc).fp= - d_to_p; /* cell_optimize, so need to return s7_pointer */ - q_arg2 (opc).p = slot; - q_func2 (opc).fd= q_func2_arg (opc).q_call (o1).fd; - return_true (sc, expr); - } - } - else if (int_optimize (sc, cdr (target))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (float_optimize (sc, cddr (expr))) { - q_temp (opc).fd = opt_d_7pid_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fd= q_func3_arg (opc).q_call (o1).fd; - q_call (opc).fp = d_to_p; - return_true (sc, expr); - } - } - } - } - return_false (sc, expr); +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);} - 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); - q_func (opc).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)))) { - q_arg2 (opc).p = slot; - q_arg3 (opc).p = caddr (value); - q_call (opc).fp= list_increment_p_pip_unchecked; - return_true (sc, expr); - } - } - } - break; - case T_HASH_TABLE: - if (is_pair (cddr (target))) return_false (sc, expr); - q_func (opc).p_ppp_f= s7_hash_table_set; - break; +/* ---------------------------------------- length, copy, fill ---------------------------------------- */ +static s7_pointer s7_length(s7_scheme *sc, s7_pointer lst); /* why isn't this in s7.h? */ - 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 (sc, index)))) - q_func (opc).p_ppp_f= let_set_1; - else - q_func (opc).p_ppp_f= - let_set_p_ppp_2; /* (set! (L3 'x) (+ (L3 'x) 1)) */ - break; +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);} - default: - return_false (sc, expr); - } - if (is_symbol (index)) { - int32_t start = sc->pc; - const s7_pointer index_slot= opt_simple_symbol (sc, index); - if (index_slot) { - q_arg2 (opc).p= index_slot; - if ((is_t_integer (slot_value (index_slot))) && - (has_loop_end (q_arg2 (opc).p))) { - if (is_string (obj)) { - if (loop_end (q_arg2 (opc).p) <= string_length (obj)) - q_func (opc).p_pip_f= string_set_p_pip_direct; - } - else if (is_byte_vector (obj)) { - if (loop_end (q_arg2 (opc).p) <= byte_vector_length (obj)) - q_func (opc).p_pip_f= byte_vector_set_p_pip_direct; - } - else if ((is_complex_vector (obj)) && - (loop_end (q_arg2 (opc).p) <= vector_length (obj))) { - q_func (opc).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 (q_arg2 (opc).p) <= vector_length (obj))) { - if (is_typed_t_vector (obj)) - q_func (opc).p_pip_f= typed_t_vector_set_p_pip_direct; - else q_func (opc).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))) { - q_arg3 (opc).p = val_slot; - q_call (opc).fp= opt_p_pip_sss; - return_true (sc, expr); - } - if ((is_let (obj)) && (is_keyword (index)) && - (q_func (opc).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 = q_func (opc).p_ppp_f; - q_arg3 (opc).p= val_slot; - q_call (opc).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))) { - q_arg3 (opc).p= (!is_pair (value)) ? value : cadr (value); - if ((is_string (obj)) || (is_any_vector (obj)) || (is_pair (obj))) { - q_call (opc).fp= opt_p_pip_ssc; - return_true (sc, expr); - } - if ((is_let (obj)) && (is_keyword (index)) && - (q_func (opc).p_ppp_f == let_set_1) && /* (set! (L3 :x) 0) */ - (use_ppc_slot_set (sc, opc, obj, keyword_symbol (index), - q_arg3 (opc).p))) - return_true (sc, expr); - q_call (opc).fp= opt_p_ppp_ssc; - return_true (sc, expr); - } - if (cell_optimize (sc, cddr (expr))) { - q_func1_arg (opc).o1= sc->opts[start]; - q_func1 (opc).fp = q_call (sc->opts[start]).fp; - if ((is_string (obj)) || (is_any_vector (obj)) || (is_pair (obj))) { - if (p_pip_ssf_combinable (sc, opc, start)) return_true (sc, expr); - q_call (opc).fp= opt_p_pip_ssf; - return_true (sc, expr); - } - if ((is_let (obj)) && (is_keyword (index)) && - (q_func (opc).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); - q_call (opc).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))) { - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (int_optimize (sc, cdr (target))) { - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_call (opc).fp = opt_p_pip_sff; - q_func2 (opc).fi= q_func2_arg (opc).q_call (o1).fi; - q_func3 (opc).fp= q_func3_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - } - return_false (sc, expr); - } - if (is_quoted_symbol (sc, index)) { - if (is_symbol (value)) { - const s7_pointer val_slot= opt_simple_symbol (sc, value); - if (val_slot) { - q_arg2 (opc).p = cadr (index); - q_arg3 (opc).p = val_slot; - q_call (opc).fp= opt_p_ppp_scs; - if ((is_let (obj)) && (q_func (opc).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)) && - (q_func (opc).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) { - q_arg2 (opc).p = val_slot; - q_call (opc).fp = opt_p_ppp_sfs; - q_func1_arg (opc).o1= o1; - q_func1 (opc).fp = q_call (o1).fp; - return_true (sc, expr); - } - } - o2= sc->opts[sc->pc]; - if (cell_optimize (sc, cddr (expr))) { - q_call (opc).fp= opt_p_ppp_sff; - if ((is_let (obj)) && (is_quoted_symbol (sc, index)) && - (q_func (opc).p_ppp_f == - let_set_1) && /* (set! (L3 'x) (+ (L3 'x) 1)) */ - (use_ppf_slot_set (sc, opc, obj, cadr (index)))) { - q_func1_arg (opc).o1= o2; - q_func1 (opc).fp = q_func1_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - q_func2_arg (opc).o1= o1; - q_func2 (opc).fp = q_call (o1).fp; - q_func3_arg (opc).o1= o2; - q_func3 (opc).fp = q_call (o2).fp; - return_true (sc, expr); - } - } +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_false (sc, expr); + return(real_infinity); } -/* -------- cell_begin -------- */ -#define q_begin_arg(o, i) o->v[i + 2] - -static s7_pointer -opt_begin_p (opt_info* o) { - opt_info* o1; - s7_int i, len= q_arg1 (o).i; /* len = 1 if 2 exprs, etc */ - for (i= 0; i < len; i++) { - o1= q_begin_arg (o, i).o1; - q_call (o1).fp (o1); - } - o1= q_begin_arg (o, i).o1; - return (q_call (o1).fp (o1)); -} +static s7_pointer nil_length(s7_scheme *sc, s7_pointer lst) {return(int_zero);} +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 rs_length(s7_scheme *sc, s7_pointer rs) {return(int_two);} -static s7_pointer -opt_begin_p_1 (opt_info* o) { - q_func (o).fp (q_arg2 (o).o1); - return (q_p_func1_call (o)); +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 void -oo_idp_nr_fixup (opt_info* start) { - if (q_call (start).fp == d_to_p) { - q_call (start).fp= d_to_p_nr; - if (q_temp (start).fd == opt_d_7pid_ssf) - q_call (start).fp= opt_d_7pid_ssf_nr; - else if (q_temp (start).fd == opt_d_7pid_ssfo_fv) { - q_call (start).fp= opt_d_7pid_ssfo_fv_nr; - if (q_func2 (start).d_dd_f == add_d_dd) - q_call (start).fp= opt_d_7pid_ssfo_fv_add_nr; - else if (q_func2 (start).d_dd_f == subtract_d_dd) - q_call (start).fp= opt_d_7pid_ssfo_fv_sub_nr; - } - } - else if (q_call (start).fp == i_to_p) q_call (start).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= 0; 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); - q_begin_arg (opc, i).o1= start; - } - q_arg1 (opc).i= len - 2; - if (len == 3) { - q_call (opc).fp = opt_begin_p_1; - q_func1_arg (opc).o1= q_begin_arg (opc, 1).o1; - q_func1 (opc).fp = q_begin_arg (opc, 2).q_call (o1).fp; - q_func (opc).fp = q_begin_arg (opc, 0).q_call (o1).fp; - } - else q_call (opc).fp= opt_begin_p; - return_true (sc, expr); +static s7_pointer let_length_with_method(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))); } -/* -------- cell_when|unless -------- */ - -#define q_when_body_len(o) o->v[1] -#define q_when_test_arg(o) o->v[3] -#define q_when_test_func(o) o->v[4] -#define q_when_test_call(o) o->v[4].fb (o->v[3].o1) -#define q_when_body(o, i) o->v[i + 5] -#define q_when_p1_call(o) o->v[6].fp (o->v[5].o1) -#define q_when_p1_func(o) o->v[6] -#define q_when_p1_arg(o) o->v[5] -#define q_when_p2_call(o) o->v[8].fp (o->v[7].o1) -#define q_when_p2_func(o) o->v[8] -#define q_when_p2_arg(o) o->v[7] - -static s7_pointer -opt_when_p_2 (opt_info* o) { - if (q_when_test_call (o)) { - q_when_p1_call (o); - return (q_when_p2_call (o)); - } - return (o->sc->unspecified); +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 -opt_when_p (opt_info* o) { - if (q_when_test_call (o)) { - s7_int i, len= q_when_body_len (o).i - 1; - opt_info* o1; - for (i= 0; i < len; i++) { - o1= q_when_body (o, i).o1; - q_call (o1).fp (o1); +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)); } - o1= q_when_body (o, i).o1; - return (q_call (o1).fp (o1)); - } - return (o->sc->unspecified); -} - -static s7_pointer -opt_when_p_1 (opt_info* o) { - opt_info* o1; - if (!q_when_test_call (o)) return (o->sc->unspecified); - o1= q_when_body (o, 0).o1; - return (q_call (o1).fp (o1)); -} - -static s7_pointer -opt_unless_p (opt_info* o) { - opt_info* o1; - s7_int i, len; - if (q_when_test_call (o)) return (o->sc->unspecified); - len= q_when_body_len (o).i - 1; - for (i= 0; i < len; i++) { - o1= q_when_body (o, i).o1; - q_call (o1).fp (o1); - } - o1= q_when_body (o, i).o1; - return (q_call (o1).fp (o1)); +#endif + return(sc->F); } -static s7_pointer -opt_unless_p_1 (opt_info* o) { - opt_info* o1; - if (q_when_test_call (o)) return (o->sc->unspecified); - o1= q_when_body (o, 0).o1; - return (q_call (o1).fp (o1)); +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 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); - q_when_test_arg (opc).o1= sc->opts[sc->pc]; - if (!bool_optimize (sc, cdr (expr))) return_false (sc, expr); - for (k= 0, 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); - q_when_body (opc, k).o1= start; - } - q_when_test_func (opc).fb= q_when_test_arg (opc).q_call (o1).fb; - q_when_body_len (opc).i = len - 2; - if (car (expr) == sc->when_symbol) { - if (len == 3) /* 1 expr */ - q_call (opc).fp= opt_when_p_1; - else if (len == 4) /* 2 exprs */ - { - q_call (opc).fp = opt_when_p_2; - q_when_p2_arg (opc).o1= q_when_body (opc, 1).o1; /* make room... */ - q_when_p2_func (opc).fp= - q_when_p2_arg (opc).q_call (o1).fp; /* order matters */ - q_when_p1_func (opc).fp= - q_when_p1_arg (opc).q_call (o1).fp; /* also q_when_body(opc, 0) */ - } - else q_call (opc).fp= opt_when_p; - } - else q_call (opc).fp= (len == 3) ? opt_unless_p_1 : opt_unless_p; - return_true (sc, expr); +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] = let_length_with_method; + 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[type_unchecked(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[type_unchecked(car(args))])(sc, car(args))); } -/* -------- cell_cond -------- */ - -#define q_cond_o1 3 -#define q_cond_clause_o1 5 -#define q_cond_val1(o) o->v[6] -#define q_cond_val2(o) o->v[7] -#define q_cond_clause(o, i) o->v[i + q_cond_clause_o1] -#define q_cond(o, i) o->v[i + q_cond_o1] - -static s7_pointer -cond_value (opt_info* o) { - opt_info* o1; - s7_int i, len= q_arg1 (o).i - 1; - for (i= 0; i < len; i++) { - o1= q_cond_clause (o, i).o1; - q_call (o1).fp (o1); - } - o1= q_cond_clause (o, i).o1; - return (q_call (o1).fp (o1)); -} -static s7_pointer -opt_cond (opt_info* top) { - s7_int len= q_arg2 (top).i; - for (s7_int clause= 0; clause < len; clause++) { - opt_info* o1= q_cond (top, clause).o1; - opt_info* o2= q_func1_arg (o1).o1; - if (q_call (o2).fb (o2)) return (cond_value (o1)); - } - return (top->sc->unspecified); -} - -static s7_pointer -opt_cond_1 (opt_info* o) { - return ((q_b_func1_call (o)) ? cond_value (q_cond_val1 (o).o1) - : o->sc->unspecified); -} /* cond as when */ -static s7_pointer -opt_cond_1b (opt_info* o) { - return ((q_func1_arg (o).q_temp (o1).fp (q_func1_arg (o).o1) != o->sc->F) - ? cond_value (q_cond_val1 (o).o1) - : o->sc->unspecified); -} - -static s7_pointer -opt_cond_2 (opt_info* o) /* 2 branches, results 1 expr, else */ -{ - opt_info* o1= (q_b_func1_call (o)) ? q_cond_val1 (o).o1 : q_cond_val2 (o).o1; - return (q_call (o1).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 - q_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; - q_cond (top, branches).o1= sc->opts[sc->pc]; - opc = alloc_opt_info (sc); - q_func1_arg (opc).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 - q_cond_clause_o1) return_false (sc, cp); - q_cond_clause (opc, blen).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, cp)) return_false (sc, cp); - } - if (!is_null (cp)) return_false (sc, cp); - q_arg1 (opc).i= blen; - if (max_blen < blen) max_blen= blen; - q_call (opc).fp= opt_cond; /* a placeholder */ - } - if (branches == 1) { - opt_info* o1 = sc->opts[start_pc + 1]; - q_call (top).fp = (q_call (o1).fb == p_to_b) ? opt_cond_1b : opt_cond_1; - q_func1_arg (top).o1= o1; - q_func1 (top).fb = q_call (o1).fb; - q_cond_val1 (top).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; - q_cond_val1 (top).o1= q_cond (top, 0).q_cond_clause (o1, 0).o1; - q_cond_val2 (top).o1= q_cond (top, 1).q_cond_clause (o1, 0).o1; - o1 = sc->opts[start_pc + 1]; - q_func1_arg (top).o1= o1; - q_func1 (top).fb = q_call (o1).fb; - q_call (top).fp = opt_cond_2; - return_true (sc, expr); +/* -------------------------------- 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); } - } - q_arg2 (top).i = branches; - q_call (top).fp= opt_cond; - return_true (sc, expr); + set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not a character", 25)); /* cadr (caller) is set in s7_copy_1 */ + set_caddr(sc->elist_3, chr); + error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); + return(NULL); } -/* -------- cell_and|or -------- */ -#define q_or_clause(o, i) o->v[i + 3] - -static s7_pointer -opt_and_pp (opt_info* o) { - return ((q_p_func2_call (o) == o->sc->F) ? o->sc->F : q_p_func3_call (o)); +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 -opt_and_any_p (opt_info* o) { - s7_pointer val= o->sc->T; /* (and) -> #t */ - for (s7_int i= 0; i < q_arg1 (o).i; i++) { - opt_info* o1= q_or_clause (o, i).o1; - val = q_call (o1).fp (o1); - if (val == o->sc->F) return (o->sc->F); - } - return (val); +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(sc, cobj, wrap_mutable_integer(sc, loc), val))); /* was make_integer 14-Nov-23 */ } -static s7_pointer -opt_or_pp (opt_info* o) { - s7_pointer val= q_p_func2_call (o); - return ((val != o->sc->F) ? val : q_p_func3_call (o)); +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 -opt_or_any_p (opt_info* o) { - for (s7_int i= 0; i < q_arg1 (o).i; i++) { - opt_info* o1 = q_or_clause (o, i).o1; - s7_pointer val= q_call (o1).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) { - q_call (opc).fp= ((car (expr) == sc->or_symbol) ? opt_or_pp : opt_and_pp); - q_func2_arg (opc).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, cdr (expr))) return_false (sc, expr); - q_func2 (opc).fp = q_func2_arg (opc).q_call (o1).fp; - q_func3_arg (opc).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, cddr (expr))) return_false (sc, expr); - q_func3 (opc).fp= q_func3_arg (opc).q_call (o1).fp; - return_true (sc, expr); - } - if ((len > 1) && (len < (num_vunions - 4))) { - s7_pointer p = cdr (expr); - q_arg1 (opc).i= (len - 1); - q_call (opc).fp= - ((car (expr) == sc->or_symbol) ? opt_or_any_p : opt_and_any_p); - for (int32_t i= 0; is_pair (p); i++, p= cdr (p)) { - q_or_clause (opc, i).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, p)) return_false (sc, expr); - } - return_true (sc, expr); - } - return_false (sc, expr); +static s7_pointer let_setter(s7_scheme *sc, s7_pointer let, 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 let, its value is changed, otherwise a new slot is added to let + */ + 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, let, sym); + if (is_slot(slot)) + checked_slot_set_value(sc, slot, cdr(val)); + else add_slot_checked_with_id(sc, let, 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, table is the hash-table, val has to be of the form (cons key value) + * if key is already in table, its value is changed, otherwise a new slot is added to table, cadr(elist_3) is caller, set in s7_copy_1 + */ + if (!is_pair(val)) + { + set_car(sc->elist_3, wrap_string(sc, "~S: ~S is not (cons key value)", 30)); + set_caddr(sc->elist_3, val); + error_nr(sc, sc->wrong_type_arg_symbol, sc->elist_3); + } + return(s7_hash_table_set(sc, table, car(val), cdr(val))); } -/* -------- cell_if -------- */ -static s7_pointer -opt_if_bp (opt_info* o) { - return ((q_func (o).fb (q_arg2 (o).o1)) ? q_p_func1_call (o) - : o->sc->unspecified); -} -static s7_pointer -opt_if_b7p (opt_info* o) { - return ((opt_b_7p_f (q_arg2 (o).o1)) ? q_p_func1_call (o) - : o->sc->unspecified); -} /* expanded not faster */ -static s7_pointer -opt_if_nbp (opt_info* o) { - return ((q_b_func1_call (o)) ? o->sc->unspecified : q_p_func2_call (o)); -} -static s7_pointer -opt_if_bp_and (opt_info* o) { - return ((opt_and_bb (q_arg2 (o).o1)) ? q_p_func1_call (o) - : o->sc->unspecified); +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 -opt_if_bp_pb ( - opt_info* o) /* p_to_b at outer, p_to_b expanded and moved to o[3] */ +static s7_pointer copy_vector(s7_scheme *sc, s7_pointer source) { - return ((q_func (o).fp (q_arg2 (o).o1) != o->sc->F) ? q_p_func1_call (o) - : o->sc->unspecified); -} + 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_VECTOR: return(copy_vector(sc, source)); + case T_PAIR: return(copy_any_list(sc, source)); /* top level only, as in the other cases, checks for circles */ + case T_HASH_TABLE: return(copy_hash_table(sc, source)); /* this has to copy nearly everything */ + case T_C_OBJECT: return(copy_c_object(sc, args)); + case T_RANDOM_STATE: return(random_state_copy(sc, args)); + case T_ITERATOR: return(iterator_copy(sc, source)); -static s7_pointer -opt_if_bp_ii_fc (opt_info* o) { - return ((q_func (o).b_ii_f (q_i_func2_call (o), q_arg2 (o).i)) - ? q_p_func1_call (o) - : o->sc->unspecified); -} + case T_INT_VECTOR: case T_FLOAT_VECTOR: case T_BYTE_VECTOR: case T_COMPLEX_VECTOR: + return(s7_vector_copy(sc, source)); /* "shallow" copy */ -static s7_pointer -opt_if_nbp_s (opt_info* o) { - return ((q_func (o).b_p_f (slot_value (q_arg2 (o).p))) ? o->sc->unspecified - : q_p_func2_call (o)); -} + case T_STRING: + if (string_length(source) == 0) return(nil_string); + return(make_string_with_length(sc, string_value(source), string_length(source))); -static s7_pointer -opt_if_nbp_sc (opt_info* o) /* b_pp_sc */ -{ - return ((q_func (o).b_pp_f (slot_value (q_arg2 (o).p), q_arg3 (o).p)) - ? o->sc->unspecified - : q_p_func2_call (o)); -} + 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 */ -static s7_pointer -opt_if_nbp_7sc (opt_info* o) /* b_7pp_sc */ -{ - return ((q_func (o).b_7pp_f (o->sc, slot_value (q_arg2 (o).p), q_arg3 (o).p)) - ? o->sc->unspecified - : q_p_func2_call (o)); -} + 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)); -static s7_pointer -opt_if_nbp_ss (opt_info* o) /* b_ii_ss */ -{ - return ((q_func (o).b_ii_f (integer (slot_value (q_arg2 (o).p)), - integer (slot_value (q_arg3 (o).p)))) - ? o->sc->unspecified - : q_p_func2_call (o)); -} + 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); -static s7_pointer -opt_if_num_eq_ii_ss (opt_info* o) /* b_ii_ss */ -{ - return ((integer (slot_value (q_arg2 (o).p)) == - integer (slot_value (q_arg3 (o).p))) - ? o->sc->unspecified - : q_p_func2_call (o)); + 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); + /* default here it to return the source without comment */ + } + return(source); } -static s7_pointer -opt_if_nbp_fs (opt_info* o) /* b_pi_fs */ -{ - return ((q_func4 (o).b_pi_f (o->sc, q_p_func1_call (o), - integer (slot_value (q_arg1 (o).p)))) - ? o->sc->unspecified - : q_p_func2_call (o)); -} +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 -opt_if_nbp_sf (opt_info* o) /* b_pp_sf */ +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) { - return ((q_func (o).b_pp_f (slot_value (q_arg1 (o).p), q_p_func1_call (o))) - ? o->sc->unspecified - : q_p_func2_call (o)); + 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(sc, source, mi))); + set_integer(mj, j); + cset(sc, sc->t3_1); + }} + else + { + s7_pointer mi = make_mutable_integer(sc, 0); + const s7_int gc_loc1 = gc_protect_1(sc, mi); + s7_pointer mj = make_mutable_integer(sc, 0); + const 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(sc, 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 -opt_if_nbp_7sf (opt_info* o) /* b_7pp_sf */ +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) { - return ((q_func (o).b_7pp_f (o->sc, slot_value (q_arg1 (o).p), - q_p_func1_call (o))) - ? o->sc->unspecified - : q_p_func2_call (o)); -} - -static s7_pointer -opt_if_bpp (opt_info* o) { - return ((q_b_func1_call (o)) ? q_p_func3_call (o) : q_p_func2_call (o)); -} -static s7_pointer -opt_if_bpp_bit (opt_info* o) { - return ((opt_b_7ii_sc_bit (q_func1_arg (o).o1)) ? q_p_func3_call (o) - : q_p_func2_call (o)); -} + /* 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); + } -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))) { - q_func2_arg (opc).o1= top; - q_func2 (opc).fp = q_call (top).fp; - if (q_call (bop).fb == opt_b_p_s) { - q_func (opc).b_p_f= q_func (bop).b_p_f; - q_arg2 (opc).p = q_arg1 (bop).p; - q_call (opc).fp = opt_if_nbp_s; - return_true (sc, expr); - } - if ((q_call (bop).fb == opt_b_pi_fs) || - (q_call (bop).fb == opt_b_pi_fs_num_eq)) { - q_func4 (opc).b_pi_f= q_func4 (bop).b_pi_f; - q_arg1 (opc).p = q_arg1 (bop).p; - q_func1_arg (opc).o1= q_func2_arg (bop).o1; - q_func1 (opc).fp = q_func2 (bop).fp; - q_call (opc).fp = opt_if_nbp_fs; - return_true (sc, expr); - } - if ((q_call (bop).fb == opt_b_pp_sf) || - (q_call (bop).fb == opt_b_7pp_sf)) { - q_func1_arg (opc).o1= q_func2_arg (bop).o1; - q_func1 (opc).fp = q_func2 (bop).fp; - if (q_call (bop).fb == opt_b_pp_sf) { - q_func (opc).b_pp_f= q_func (bop).b_pp_f; - q_call (opc).fp = opt_if_nbp_sf; - } - else { - q_func (opc).b_7pp_f= q_func (bop).b_7pp_f; - q_call (opc).fp = opt_if_nbp_7sf; - } - q_arg1 (opc).p= q_arg1 (bop).p; - return_true (sc, expr); - } - if ((q_call (bop).fb == opt_b_pp_sc) || - (q_call (bop).fb == opt_b_7pp_sc)) { - if (q_call (bop).fb == opt_b_pp_sc) { - q_func (opc).b_pp_f= q_func (bop).b_pp_f; - q_call (opc).fp = opt_if_nbp_sc; - } - else { - q_func (opc).b_7pp_f= q_func (bop).b_7pp_f; - q_call (opc).fp = opt_if_nbp_7sc; - } - q_arg2 (opc).p= q_arg1 (bop).p; - q_arg3 (opc).p= q_arg2 (bop).p; - return_true (sc, expr); - } - if ((q_call (bop).fb == opt_b_ii_ss) || - (q_call (bop).fb == opt_b_ii_ss_eq) || - (q_call (bop).fb == opt_b_ii_ss_lt) || - (q_call (bop).fb == opt_b_ii_ss_gt) || - (q_call (bop).fb == opt_b_ii_ss_leq) || - (q_call (bop).fb == opt_b_ii_ss_geq)) { - q_func (opc).b_ii_f= q_func (bop).b_ii_f; - q_arg2 (opc).p = q_arg1 (bop).p; - q_arg3 (opc).p = q_arg2 (bop).p; - q_call (opc).fp = (q_func (opc).b_ii_f == num_eq_b_ii) - ? opt_if_num_eq_ii_ss - : opt_if_nbp_ss; - return_true (sc, expr); - } - q_func1_arg (opc).o1= bop; - q_func1 (opc).fb = q_call (bop).fb; - q_call (opc).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))) { - q_arg2 (opc).o1 = bop; - q_func1_arg (opc).o1= top; - q_func1 (opc).fp = q_call (top).fp; - if (q_call (bop).fb == p_to_b) { - q_call (opc).fp= opt_if_bp_pb; - q_func (opc).fp= q_temp (bop).fp; - return_true (sc, expr); - } - if (q_call (bop).fb == opt_b_ii_fc) { - q_arg2 (opc).i = q_arg2 (bop).i; - q_func (opc).b_ii_f = q_func (bop).b_ii_f; - q_func2 (opc).fi = q_func2 (bop).fi; - q_func2_arg (opc).o1= q_func2_arg (bop).o1; - q_call (opc).fp = opt_if_bp_ii_fc; - return_true (sc, expr); - } - q_call (opc).fp= - (q_call (bop).fb == opt_b_7p_f) - ? opt_if_b7p - : ((q_call (bop).fb == opt_and_bb) ? opt_if_bp_and : opt_if_bp); - q_func (opc).fb= q_call (bop).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]; - q_call (opc).fp= - (q_call (bop).fb == opt_b_7ii_sc_bit) ? opt_if_bpp_bit : opt_if_bpp; - if (cell_optimize (sc, cdddr (expr))) { - q_func1_arg (opc).o1= bop; - q_func1 (opc).fb = q_call (bop).fb; - q_func3_arg (opc).o1= top; - q_func3 (opc).fp = q_call (top).fp; - q_func2_arg (opc).o1= o3; - q_func2 (opc).fp = q_call (o3).fp; - return_true (sc, expr); - } - } - } - } - return_false (sc, expr); -} - -/* -------- cell_case -------- */ -#define q_case_start 3 -#define q_max_case_clauses (num_vunions - 4) -#define q_case_selector(o) o->v[2] -#define q_case_clause(o, i) o->v[i + 4] -#define q_case(o, i) o->v[i] -#define q_case_clause_keys(o) o->v[2] + 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); -static s7_pointer -case_value (opt_info* o) { - opt_info* o1; - int32_t i, len= q_arg1 (o).i - 1; /* int32_t here and below seems to be faster - than s7_int (tleft.scm) */ - for (i= 0; i < len; i++) { - o1= q_case_clause (o, i).o1; - q_call (o1).fp (o1); - } - o1= q_case_clause (o, i).o1; - return (q_call (o1).fp (o1)); -} + 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); -static s7_pointer -opt_case (opt_info* o) { - opt_info* o1 = q_case_selector (o).o1; - const int32_t lim = q_arg1 (o).i; - s7_scheme* sc = o->sc; - const s7_pointer selector= q_call (o1).fp (o1); + 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); - if (is_simple (selector)) { - for (int32_t ctr= q_case_start; ctr < lim; ctr++) { - s7_pointer p; - o1= q_case (o, ctr).o1; - for (p= q_case_clause_keys (o1).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= q_case_start; ctr < lim; ctr++) { - s7_pointer p; - o1= q_case (o, ctr).o1; - for (p= q_case_clause_keys (o1).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); -} + case T_RANDOM_STATE: + random_seed(dest) = random_seed(source); + random_carry(dest) = random_carry(source); + return(dest); -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); - q_case_selector (top).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, cdr (expr))) /* selector */ - return_false (sc, expr); - for (ctr= q_case_start, 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); - q_case (top, ctr).o1= opc; - if (car (clause) == sc->else_symbol) { - if (!is_null (cdr (p))) return_false (sc, clause); - q_case_clause_keys (opc).p= sc->else_symbol; - } - else { - if (!s7_is_proper_list (sc, car (clause))) return_false (sc, clause); - q_case_clause_keys (opc).p= car (clause); - } - - for (blen= 0, cp= cdr (clause); - (is_pair (cp)) && (blen < q_max_case_clauses); blen++, cp= cdr (cp)) { - q_case_clause (opc, blen).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, cp)) return_false (sc, cp); - } - if (!is_null (cp)) return_false (sc, cp); - q_arg1 (opc).i = blen; - q_call (opc).fp= opt_case; /* just a placeholder I hope */ - } - if (!is_null (p)) return_false (sc, p); - q_arg1 (top).i = ctr; - q_call (top).fp= opt_case; - return_true (sc, expr); -} + case T_C_OBJECT: + return(copy_c_object_to_same_type(sc, dest, source, dest_start, dest_end, source_start)); -/* -------- cell_let_temporarily -------- */ + case T_LET: + return(NULL); -#define q_let_temp_o1 5 -#define q_let_temp(o, i) o->v[i + q_let_temp_o1] -#define q_let_temp_old_value(o) o->v[3] -#define q_let_temp_new_value(o) o->v[4] + 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); + } -static s7_pointer -opt_let_temporarily (opt_info* o) { - opt_info* new_o1= q_let_temp_new_value (o).o1; - s7_int i, len; - s7_pointer result; - s7_scheme* sc= o->sc; - - if (is_immutable_slot (q_arg1 (o).p)) - immutable_object_error_nr (sc, set_elist_3 (sc, immutable_error_string, - sc->let_temporarily_symbol, - slot_symbol (q_arg1 (o).p))); - - q_let_temp_old_value (o).p= - slot_value (q_arg1 (o).p); /* save and protect old value */ - gc_protect_via_stack (sc, q_let_temp_old_value (o).p); - slot_set_value (q_arg1 (o).p, - q_call (new_o1).fp (new_o1)); /* set new value */ - len= q_arg2 (o).i - 1; - { - opt_info* o1; - for (i= 0; i < len; i++) { - o1= q_let_temp (o, i).o1; - q_call (o1).fp (o1); + default: + return(dest); } - o1 = q_let_temp (o, i).o1; - result= q_call (o1).fp (o1); - } - slot_set_value (q_arg1 (o).p, q_let_temp_old_value (o).p); /* restore old */ - unstack_gc_protect (sc); - return (result); + return(NULL); } -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 - q_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); - q_arg1 (opc).p= s7_t_slot (sc, caaadr (expr)); - if (!is_slot (q_arg1 (opc).p)) return_false (sc, expr); - q_let_temp_new_value (opc).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, cdaadr (expr))) return_false (sc, expr); - - p= cddr (expr); - for (int32_t i= 0; is_pair (p); i++, p= cdr (p)) { - q_let_temp (opc, i).o1= sc->opts[sc->pc]; - if (!cell_optimize (sc, p)) return_false (sc, expr); - } - q_arg2 (opc).i = len - 2; - q_call (opc).fp= opt_let_temporarily; - return_true (sc, expr); - } - return_false (sc, expr); +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); } -/* -------- cell_do -------- */ - -#define do_curlet(o) T_Let (q_arg2 (o).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 -#define do_stepper_opt(o) o->v[9].o1 -#define do_expr(o, i) o->v[i] - -static void -let_set_has_pending_value (s7_pointer let) { - for (s7_pointer slot= let_slots (let); is_not_slot_end (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 let) { - for (s7_pointer slot= let_slots (let); is_not_slot_end (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_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - /* init */ - slot= let_slots (sc->curlet); - for (int32_t k= 0; is_not_slot_end (slot); k++, slot= next_slot (slot)) { - o1= do_expr (inits, k).o1; - slot_set_value (slot, q_call (o1).fp (o1)); - } - let_set_has_pending_value (sc->curlet); - for (int32_t i= 0; i < len; i++) { - os[i]= do_expr (body, i).o1; - fp[i]= q_call (os[i]).fp; - } - while (true) { - /* end */ - if (q_call (ostart).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; is_not_slot_end (slot); k++, slot= next_slot (slot)) - if (has_stepper (slot)) { - o1= do_expr (steps, k).o1; - slot_simply_set_pending_value (slot, q_call (o1).fp (o1)); - } - for (s7_pointer slot1= let_slots (sc->curlet); is_not_slot_end (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 = do_expr (results, i).o1; - result= q_call (o1).fp (o1); - } - let_clear_has_pending_value (sc, sc->curlet); - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (result); +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 -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 = do_stepper_opt (o); - 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_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - slot= let_slots (sc->curlet); - for (int32_t k= 0; is_not_slot_end (slot); k++, slot= next_slot (slot)) { - o1= do_expr (inits, k).o1; - slot_set_value (slot, q_call (o1).fp (o1)); - if (has_stepper (slot)) stepper= slot; - } - while (!(q_call (ostart).fb (ostart))) { - q_call (body).fp (body); - slot_set_value (stepper, q_call (ostep).fp (ostep)); - } - o1 = do_any_results (o); - result= q_call (o1).fp (o1); - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (result); -} +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) -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 = do_stepper_opt (o); - const opt_info* inits = do_any_inits (o); - opt_info* body = do_any_body (o); - s7_pointer (*fp) (opt_info* o)= q_call (body).fp; - s7_pointer slot, result, stepper= NULL, si; - s7_scheme* sc= o->sc; - s7_int end, incr; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - slot= let_slots (sc->curlet); - for (int32_t k= 0; is_not_slot_end (slot); k++, slot= next_slot (slot)) { - o1= do_expr (inits, k).o1; - slot_set_value (slot, q_call (o1).fp (o1)); - if (has_stepper (slot)) stepper= slot; - } - end = integer (slot_value (q_arg2 (ostart).p)); - incr= q_arg2 (ostep).i; - si = make_mutable_integer (sc, integer (slot_value (q_arg1 (ostart).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 ( - q_arg1 (body).p, - make_mutable_real (sc, real (slot_value (q_arg1 (body).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 (q_arg1 (body).p)); - o1 = do_any_results (o); - result= q_call (o1).fp (o1); - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (result); -} + 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; -#define do_no_vars_test(o) o->v[6].o1 -#define do_no_vars_body(o) o->v[7].o1 + 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; -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)= q_call (ostart).fb; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - 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= do_expr (body, i).o1; - q_call (o1).fp (o1); - } - } - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); -} + 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; -#define do_stepper_init(o) o->v[11].o1 -#define do_stepper_safe(o) o->v[8].i + 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; -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 = do_stepper_opt (o); - opt_info* body = do_any_body (o); - s7_pointer slot = let_slots (do_curlet (o)); - s7_scheme* sc = o->sc; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - slot_set_value (slot, q_call (o1).fp (o1)); - if ((do_stepper_safe (o) == 1) && (is_t_integer (slot_value (slot)))) { - if ((q_call (ostep).fp == opt_p_ii_ss_add) || /* tmap */ - (q_call (ostep).fp == i_to_p)) { - s7_pointer step_val= - make_mutable_integer (sc, integer (slot_value (slot))); - slot_set_value (slot, step_val); - if (q_call (ostep).fp == opt_p_ii_ss_add) - while (!q_call (ostart).fb (ostart)) { - q_call (body).fp (body); - set_integer (step_val, opt_i_ii_ss_add (ostep)); - } - else - while (!q_call (ostart).fb (ostart)) { - q_call (body).fp (body); - set_integer (step_val, q_temp (ostep).fi (ostep)); - } - unstack_gc_protect (sc); - clear_mutable_integer (step_val); - set_curlet (sc, old_let); - return (sc->T); - } - do_stepper_safe (o)= 2; - } - while (!(q_call (ostart).fb (ostart))) /* s7test tref */ - { - q_call (body).fp (body); - slot_set_value (slot, q_call (ostep).fp (ostep)); - } - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); -} + case T_STRING: + get = string_getter; + end = string_length(source); + break; -#define do_n_body(o) o->v[7].o1 + case T_HASH_TABLE: + if (source == dest) return(dest); + end = hash_table_entries(source); + break; -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 = do_stepper_opt (o); - 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_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - slot_set_value (slot, q_call (o1).fp (o1)); - if (len == 2) /* tmac tshoot */ - { - opt_info *e1= q_call (body).o1, *e2= q_arg1 (body).o1; - while (!(q_call (ostart).fb (ostart))) { - q_call (e1).fp (e1); - q_call (e2).fp (e2); - slot_set_value (slot, q_call (ostep).fp (ostep)); - } - } - else { - opt_info* os[num_vunions]; - opt_info_fp fp[num_vunions]; - for (int32_t i= 0; i < len; i++) { - os[i]= do_expr (body, i).o1; - fp[i]= q_call (os[i]).fp; - } - if (len == 7) - while (!q_call (ostart).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, q_call (ostep).fp (ostep)); - } - else - while (!q_call (ostart).fb (ostart)) /* tfft teq */ - { - for (int32_t i= 0; i < len; i++) - fp[i](os[i]); - slot_set_value (slot, q_call (ostep).fp (ostep)); - } - } - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); -} + case T_RANDOM_STATE: + get = random_state_getter; + end = 2; + break; -#define do_times_end(o) o->v[6] + case T_C_OBJECT: + if (c_object_copy(sc, source)) + { + s7_pointer new_cobj = (*(c_object_copy(sc, source)))(sc, args); + if (new_cobj == 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; -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)))) - : do_times_end (o).i; - s7_pointer slot = let_dox1_value (do_curlet (o)); - s7_scheme* sc = o->sc; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - set_integer (slot, integer (q_call (o1).fp (o1))); - if (len == 2) /* tmac tmisc */ - { - opt_info *e1= q_call (body).o1, *e2= q_arg1 (body).o1; - while (integer (slot) < end) { - q_call (e1).fp (e1); - q_call (e2).fp (e2); - integer (slot)++; - } - } - else - while (integer (slot) < end) /* tbig sg */ - { - for (int32_t i= 0; i < len; i++) { - o1= do_expr (body, i).o1; - q_call (o1).fp (o1); - } - integer (slot)++; - } - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); -} + 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); is_not_slot_end(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); is_not_slot_end(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); is_not_slot_end(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; -#define do_end(o) o->v[3] + case T_NIL: + end = 0; + if (is_sequence(dest)) + break; -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_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - slot_set_value (slot, q_call (o1).fp (o1)); - o1= do_any_body (o); - fp= q_call (o1).fp; - if (fp == opt_if_bp) - while (is_pair (slot_value (slot))) { - if (do_end (o1).fb (q_arg2 (o1).o1)) q_p_func1_call (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))); + 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)); } - unstack_gc_protect (sc); - set_curlet (sc, old_let); - 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)))) - : do_end (o).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_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - set_integer (vp, integer (q_call (o1).fp (o1))); - o1= do_any_body (o); - f = q_call (o1).fp; - if (f == opt_p_pip_ssf) /* tref.scm */ - { - opt_info* o2= o1; - o1 = q_func1_arg (o2).o1; - if (q_func (o2).p_pip_f == t_vector_set_p_pip_direct) { - s7_pointer vec= slot_value (q_arg1 (o2).p); - while (integer (vp) < end) { - t_vector_set_p_pip_direct (o2->sc, vec, - integer (slot_value (q_arg2 (o2).p)), - q_call (o1).fp (o1)); - integer (vp)++; - } - } - else - while (integer (vp) < end) { - q_func (o2).p_pip_f (o2->sc, slot_value (q_arg1 (o2).p), - integer (slot_value (q_arg2 (o2).p)), - q_call (o1).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)) == q_arg2 (o1).p) && - (q_arg2 (o1).p == q_arg4 (o1).p)) { - s7_pointer (*setter) (s7_scheme* sc, s7_pointer p1, s7_int i1, - s7_pointer p2)= q_func (o1).p_pip_f; - s7_pointer (*getter) (s7_scheme* sc, s7_pointer p1, s7_int i1)= - q_func3 (o1).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 (q_arg1 (o1).p), - slot_value (q_arg3 (o1).p), integer (vp), end, - integer (vp)); /* TODO: q_arg1 and q_arg3 */ - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return (sc->T); - } - } - while (integer (vp) < end) { - q_func (o1).p_pip_f ( - o1->sc, slot_value (q_arg1 (o1).p), - integer (slot_value (q_arg2 (o1).p)), - q_func3 (o1).p_pi_f (o1->sc, slot_value (q_arg3 (o1).p), - integer (slot_value (q_arg4 (o1).p)))); - integer (vp)++; - } - } - else if ((f == opt_set_p_i_f) && /* tvect.scm */ - (is_t_integer (slot_value (q_arg1 (o1).p))) && - (q_arg1 (o1).p != let_dox_slot1 (do_curlet (o)))) { - opt_info* o2= q_func1_arg (o1).o1; /* set_p_i_f: x = make_integer(o->sc, - o-v[6].fi(o-v[5].o1)); */ - s7_int (*fi) (opt_info* o)= q_call (o2).fi; - s7_pointer ival= - make_mutable_integer (sc, integer (slot_value (q_arg1 (o1).p))); - slot_set_value (q_arg1 (o1).p, ival); - while (integer (vp) < end) { - set_integer (ival, fi (o2)); - integer (vp)++; - } - slot_set_value (q_arg1 (o1).p, - make_integer (sc, integer (slot_value (q_arg1 (o1).p)))); - clear_mutable_integer (ival); - } - else if ((f == opt_d_7pid_ssf_nr) && /* tref.scm */ - (q_func (o1).d_7pid_f == float_vector_set_d_7pid_direct)) { - s7_pointer ind = q_arg2 (o1).p; - opt_info* o2 = do_any_body (o1); - s7_double (*fd) (opt_info* o)= q_call (o2).fd; - s7_pointer fv = slot_value (q_arg1 (o1).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)++; - } + 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); } - 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_let); - return (sc->T); -} + if ((start == 0) && (source == dest)) + return(dest); -#define do_prepack_end(o) o->v[1].i -#define do_prepack_stepper(o) o->v[6].p -#define do_dpnr_func(o) o->v[7] - -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)))) - : do_end (o).i; - s7_pointer vp = let_dox1_value (do_curlet (o)); - s7_scheme* sc = o->sc; - const s7_pointer old_let= sc->curlet; - gc_protect_via_stack (sc, old_let); - set_curlet (sc, do_curlet (o)); - set_integer (vp, integer (q_call (o1).fp (o1))); - - do_prepack_stepper (o)= vp; - do_prepack_end (o) = end; - do_dpnr_func (o).fp (o); /* call opt_do_i|dpnr below */ - - unstack_gc_protect (sc); - set_curlet (sc, old_let); - 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)= q_temp (o1).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)= q_temp (o1).fi; - while (integer (vp) < end) { - f (o1); - integer (vp)++; - } - return (NULL); -} + 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); + } -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 (sc, p)) && (tree_has_setters (sc, p))) return (true); - tree= cdr (tree); - if (!is_pair (tree)) break; - } - return (is_setter (tree)); -} + switch (type(dest)) + { + case T_PAIR: + dest_len = source_len; + break; -#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 + 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; -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)); -} + case T_VECTOR: + set = (is_typed_vector(dest)) ? typed_vector_setter : vector_setter(dest); + dest_len = vector_length(dest); + break; -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); -} + 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; -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); -} + 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; -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_let = 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[num_vunions], *step_o[num_vunions], *body_o[num_vunions], - *return_o[num_vunions]; -#if S7_DEBUGGING - for (int32_t i= 0; i < num_vunions; i++) { - body_o[i] = NULL; - init_o[i] = NULL; - step_o[i] = NULL; - return_o[i]= NULL; - } -#endif + 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 new_cobj = (*(c_object_copy(sc, dest)))(sc, args); + if (new_cobj == dest) + return(dest); + } + set = c_object_setter; + dest_len = c_object_length_to_int(sc, dest); + break; - if (len < 3) return_false (sc, expr); - if (body_len > num_vunions) 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; - } + 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; - opc= alloc_opt_info (sc); - let= inline_make_let (sc, sc->curlet); - push_stack (sc, OP_GC_PROTECT, old_let, let); + case T_NIL: + return(sc->nil); - /* 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 (is_not_slot_end (let_slots (let))) - let_set_slots (let, reverse_slots (let_slots (let))); + case T_RANDOM_STATE: + set = random_state_setter; + dest_len = 2; + break; - /* inits */ - { - s7_pointer slot= let_slots (let); - init_pc = sc->pc; - { - s7_pointer p= vars; - for (int32_t k= 0; (is_pair (p)) && (k < num_vunions); - 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, q_call(init_o[k]).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_let); - return_false (sc, expr); - } - } + 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)); } - } - /* end test */ - end_test_pc= sc->pc; - if (!bool_optimize_nw (sc, endp)) { - unstack_gc_protect (sc); /* not pop_stack! */ - set_curlet (sc, old_let); - 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 (dest_len == 0) + return(dest); - 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); - } - } - } + /* end is source_len if not set explicitly */ + if (dest_len < source_len) + { + end = dest_len + start; + source_len = dest_len; } - } - /* body */ - body_index= sc->pc; - { - s7_pointer p= cdddr (expr); - for (int32_t k= 0; k < len - 3; - k++, p= cdr (p)) /* len (from p_syntax_ok)=form length (do - body...) */ - { - 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; */ /* why this? */ - 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_let); - return_false (sc, expr); + 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); } - } - /* 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_let); - return_false (sc, expr); - } - } - - /* result */ - if (!is_list (cdr (endp))) { - unstack_gc_protect (sc); - set_curlet (sc, old_let); - return_false (sc, expr); - } - { - s7_pointer p= cdr (endp); - for (return_exprs= 0; (is_pair (p)) && (return_exprs < num_vunions); - 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_let); - return_false (sc, expr); - } - } + 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); + } - do_curlet_unchecked (opc)= T_Let (let); - do_body_length (opc) = len - 3; - do_result_length (opc) = return_exprs; - do_stepper_opt (opc) = sc->opts[step_pc]; - set_curlet (sc, old_let); - - if ((var_len == 0) && (return_exprs == 0)) { - opt_info* body; - do_no_vars_test (opc)= sc->opts[end_test_pc]; - q_call (opc).fp = opt_do_no_vars; - if (body_len > 0) { - body= alloc_opt_info (sc); - for (int32_t k= 0; k < body_len; k++) - do_expr (body, k).o1= body_o[k]; - do_no_vars_body (opc)= body; - } - return_true (sc, expr); - } - do_stepper_safe (opc)= 0; - if (body_len == 1) { - const s7_pointer expr3= cadddr (expr); /* 1 expr in body */ - if ((is_pair (expr3)) && - ((is_c_function (car (expr3))) || /* (#_sqrt 2.0)?? */ - (is_safe_setter (car (expr3))) || /* (byte-vector-set! iv 1 0) */ - ((car (expr3) == sc->set_symbol) && /* (set! sum (+ sum 1)) */ - (cadr (expr3) != caar (vars))) || /* caadr: (stepper init ...) */ - ((car (expr3) == sc->vector_set_symbol) && - (is_null (cddddr (expr3))) && - (is_code_constant (sc, cadddr (expr3)))))) - do_stepper_safe (opc)= 1; /* checked in opt_do_1 */ - } - if ((var_len != 1) || (step_len != 1) || (return_exprs != 0)) { - opt_info* inits; - q_call (opc).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 ((q_call (opc).fp == opt_do_step_1) && - (q_call (do_stepper_opt (opc)).fp == i_to_p) && - (q_temp (do_stepper_opt (opc)).fi == opt_i_ii_sc_add) && - (q_call (do_any_test (opc)).fb == opt_b_ii_ss_eq)) - q_call (opc).fp= opt_do_step_i; - - inits= alloc_opt_info (sc); - for (int32_t k= 0; k < var_len; k++) - do_expr (inits, k).o1= init_o[k]; - do_any_inits (opc)= inits; - - if (q_call (opc).fp == opt_do_any) { - opt_info *result, *step; - opt_info* body= alloc_opt_info (sc); - - for (int32_t k= 0; k < body_len; k++) - do_expr (body, k).o1= body_o[k]; - do_any_body (opc)= body; - - result= alloc_opt_info (sc); - for (int32_t k= 0; k < return_exprs; k++) - do_expr (result, k).o1= return_o[k]; - do_any_results (opc)= result; - - step= alloc_opt_info (sc); - for (int32_t k= 0; k < var_len; k++) - do_expr (step, 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); - } + case T_LET: + if (source == sc->starlet) /* *s7* */ /* this could be more direct via starlet_make_iterator, but it hardly matters */ + { + const s7_pointer iter = s7_make_iterator(sc, sc->starlet); + const 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); is_not_slot_end(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); - q_call (opc).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++) - do_expr (body, 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); /* undefined_slot? */ - slot_set_value (slot, - make_mutable_integer (sc, integer (slot_value (slot)))); - /* do_body_start(opc).i = body_index; */ /* start point (sc->pc) for - body, apparently never used - */ - if (body_len == 1) /* opt_do_1 */ - { - const opt_info* o1= sc->opts[body_index]; - q_call (opc).fp = opt_do_very_simple; - if (is_t_integer (caddr (end))) do_end (opc).i= integer (caddr (end)); - if (q_call (o1).fp == - d_to_p_nr) /* snd-test: (do ((k 0 (+ k 1))) ((= k N)) - (float-vector-set! rl k (read-sample rd))) */ - { - q_call (opc).fp = opt_do_prepackaged; - do_dpnr_func (opc).fp= opt_do_dpnr; - } - else if (q_call (o1).fp == i_to_p_nr) { - q_call (opc).fp = opt_do_prepackaged; - do_dpnr_func (opc).fp= opt_do_ipnr; - } - } - else { - q_call (opc).fp= opt_do_times; - if (is_t_integer (caddr (end))) - do_times_end (opc).i= integer (caddr (end)); - } + 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); } - 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))) - q_call (opc).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 (!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 */ + 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; - 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 (!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))) + case T_COMPLEX_VECTOR: + if ((is_t_vector(dest)) && (!is_typed_vector(dest))) { - 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); -} + 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; -static bool -int_optimize (s7_scheme* sc, s7_pointer expr) { - return ((int_optimize_1 (sc, expr)) && (sc->pc < OPTS_SIZE)); -} + 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; -/* 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)) { - q_temp (opc).fd= q_call (opc).fd; - q_call (opc).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))) { - q_temp (opc).fi= q_call (opc).fi; - q_call (opc).fp= i_to_p; - if (q_temp (opc).fi == opt_i_ii_ss_add) q_call (opc).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 */ - q_temp (opc).fd= q_call (opc).fd; - q_call (opc).fp= d_to_p; - return_true (sc, expr); - } + 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; - 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))) { - q_temp (opc).fi= q_call (opc).fi; - q_call (opc).fp= i_to_p; - return_true (sc, expr); - } - sc->pc= pstart; + 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; - 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); + 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; + /* default (random_state, simple_block etc) is to let "set" handle it below */ } - } - 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))) { - q_temp (opc).fd= q_call (opc).fd; - q_call (opc).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))) { - q_temp (opc).fd= q_call (opc).fd; - q_call (opc).fp= d_to_p; - return_true (sc, expr); - } - if (i_7piii_ok (sc, opc, s_func, expr)) { - q_temp (opc).fi= q_call (opc).fi; - q_call (opc).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))) { - q_temp (opc).fd= q_call (opc).fd; - q_call (opc).fp= d_to_p; - return_true (sc, expr); - } - return_false (sc, expr); + + 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); } -#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 +s7_pointer s7_copy(s7_scheme *sc, s7_pointer args) {return(s7_copy_1(sc, sc->copy_symbol, args));} +#define g_copy s7_copy + +s7_pointer s7i_copy_1(s7_scheme *sc, s7_pointer caller, s7_pointer args) { - 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 (!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 (sc, 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 (sc, 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); + return(s7_copy_1(sc, caller, args)); } -#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, form, opt_arg_type (sc, cdr (expr))), form); - 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; - } +/* -------------------------------- reverse -------------------------------- */ +/* s7_reverse migrated to s7_liii_list.c */ - 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) q_func (opc).b_pp_f= bpf; - else q_func (opc).b_7pp_f= bpf7; - return (b_pp_ok (sc, opc, s_func, expr, arg1, arg2, bpf)); - } - } break; - default: - break; - } - } - return_false (sc, expr); -} +/* 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 bool -bool_optimize_nw (s7_scheme* sc, s7_pointer expr) { - return ((bool_optimize_nw_1 (sc, expr)) && (sc->pc < OPTS_SIZE)); +static s7_pointer string_reverse(s7_scheme *sc, s7_pointer str) +{ + const char *source = string_value(str); + const s7_int len = string_length(str); + const char *end = (char *)(source + len); + const s7_pointer new_str = make_empty_string(sc, len, '\0'); + char *dest = (char *)(string_value(new_str) + len); + while (source < end) *(--dest) = *source++; + return(new_str); } -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 (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 (q_temp (wrapper).fp) /* (when (+ i 1) ...) */ - return_false (sc, expr); - q_temp (wrapper).fp= q_call (wrapper).fp; - q_call (wrapper).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 (q_call (sc->opts[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 ((!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); +static s7_pointer byte_vector_reverse(s7_scheme *sc, s7_pointer bv) +{ + 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); + const s7_pointer new_bv = make_simple_byte_vector(sc, len); + uint8_t *dest = (uint8_t *)(byte_vector_bytes(new_bv) + len); + while (source < end) *(--dest) = *source++; + return(new_bv); } -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 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 = s7i_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 = s7i_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 = s7i_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 -g_optimize (s7_scheme* sc, s7_pointer args) /* s7-optimize in scheme */ +static s7_pointer c_object_reverse_1(s7_scheme *sc, s7_pointer obj) { - 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); + 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))); } -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); +static s7_pointer let_reverse(s7_scheme *sc, s7_pointer obj) +{ + 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)); +#ifdef __TINYC__ + return(NULL); /* won't happen but placate tcc */ +#endif } -/* ---------------- 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 (is_not_slot_end (slot2)) slot3= next_slot (slot2); - - more_vars= (is_not_slot_end (slot3)) && (is_not_slot_end (next_slot (slot3))); - fx_tree (sc, code, slot_symbol (slot1), - (is_not_slot_end (slot2)) ? slot_symbol (slot2) : NULL, - (is_not_slot_end (slot3)) ? slot_symbol (slot3) : NULL, more_vars); - - outer_e= let_outlet (sc->curlet); - if ((!more_vars) && (is_let (outer_e)) && (!is_funclet (outer_e)) && - (is_not_slot_end (let_slots (outer_e))) && - (slot_symbol (let_slots (outer_e)) != slot_symbol (slot1))) { - slot1= let_slots (outer_e); - slot2= next_slot (slot1); - slot3= (is_not_slot_end (slot2)) ? next_slot (slot2) : NULL; - fx_tree_outer (sc, code, slot_symbol (slot1), - (is_not_slot_end (slot2)) ? slot_symbol (slot2) : NULL, - (is_not_slot_end (slot3)) ? slot_symbol (slot3) : NULL, - (is_not_slot_end (slot3)) && - (is_not_slot_end (next_slot (slot3)))); - } +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: return(c_object_reverse_1(sc, obj)); + case T_LET: return(let_reverse(sc, obj)); + default: + return(method_or_bust_p(sc, obj, sc->reverse_symbol, a_sequence_string)); + } + return(sc->nil); } -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 (is_not_slot_end (slot2)) slot3= next_slot (slot2); - fx_tree_in (sc, code, slot_symbol (slot1), - (is_not_slot_end (slot2)) ? slot_symbol (slot2) : NULL, - (is_not_slot_end (slot3)) ? slot_symbol (slot3) : NULL, - (is_not_slot_end (slot3)) && - (is_not_slot_end (next_slot (slot3)))); -} +/* g_reverse is now defined in s7_scheme_predicate.c */ +#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) -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); -} +/* any_list_reverse_in_place migrated to s7_liii_list.c */ -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))) && (curlet_has_slots (sc))) - 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] */ +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 { - 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 */ + 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); } -/* 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 */ +static s7_pointer int_vector_reverse_in_place(s7_scheme *sc, s7_pointer vec) { - 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; + 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_pointer result= proper_list_reverse_in_place (sc, sc->z); - sc->z = sc->unused; - return (result); + 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 -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); +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); } -#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 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 -clear_for_each (s7_scheme* sc) { - sc->map_call_ctr--; - unstack_with (sc, OP_MAP_UNWIND); - return (sc->unspecified); +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_for_each_closure (s7_scheme* sc, s7_pointer clo, - s7_pointer seq) /* one sequence arg */ +static s7_pointer reverse_pair_in_place(s7_scheme *sc, s7_pointer obj, s7_pointer args) { - 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 */ + if (is_immutable_pair(obj)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->reverseb_symbol, obj)); { - s7_pfunc func = NULL; - const s7_pointer old_let= 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 */ + s7_pointer lst = any_list_reverse_in_place(sc, sc->nil, obj); + if (is_null(lst)) { - 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 (!s7_is_proper_list(sc, obj)) + type_error_nr(sc, sc->reverseb_symbol, 1, car(args), wrap_string(sc, "a proper list", 13)); + 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 + */ +} + +static s7_pointer reverse_in_place_via_method(s7_scheme *sc, s7_pointer obj) +{ + 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_type_error_nr(sc, sc->reverseb_symbol, obj, a_sequence_string); } + if ((is_simple_sequence(obj)) && + (!has_active_methods(sc, obj))) + sole_arg_type_error_nr(sc, sc->reverseb_symbol, obj, wrap_string(sc, "a vector, string, or list", 25)); + return(vector_method_or_bust_p(sc, obj, sc->reverseb_symbol, a_sequence_string)); +} - 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)= q_call (o).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]; - opt_info* o1 = q_when_body (o, 0).o1; - s7_pointer (*fp) (opt_info* o)= q_call (o).fp; - if (fp == opt_unless_p_1) - for (s7_int i= 0; i < len; i++) { - set_real (sv, vals[i]); - if (!(q_when_test_call (o))) q_call (o1).fp (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, q_call(sc->opts[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)= q_call (o).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)= q_call (o).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)= q_call (o).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)= q_call (o).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)= q_call (o).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 */ +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)) { - set_no_cell_opt (body); - set_curlet (sc, old_let); + case T_PAIR: return(reverse_pair_in_place(sc, obj, args)); + 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)); + case T_NIL: return(sc->nil); /* (reverse! ()) -> () */ + default: return(reverse_in_place_via_method(sc, obj)); } - } + return(obj); +} - /* 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))); - } - } - } -} +/* -------------------------------- 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; -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))); +#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); } - } -} - -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))); + 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); } -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); - } - } +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) - 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 */ + /* 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)) { - set_no_cell_opt (body); - set_curlet (sc, olde); - } - } + case T_STRING: return(g_string_fill(sc, 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)); - 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); + 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(s7i_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); } - } - return (got_nil); + wrong_type_error_nr(sc, sc->fill_symbol, 1, obj, a_sequence_string); /* (fill! 1 0) */ + return(NULL); } -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) +#define g_fill s7_fill - 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); +/* -------------------------------- 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]); + if (n < 0) + wrong_type_error_nr(sc, caller, i, seq, (is_pair(seq)) ? a_proper_list_string : a_sequence_string); + len += n; + } + return(len); +} + +s7_pointer s7i_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; - /* if function is safe c func, do the for-each locally */ - if (is_safe_c_function (clo)) { - 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); - } - } + 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) { - s7_function func= c_function_call ( - clo); /* presumably this is either display/write, or method call? */ - s7_pointer iters; - 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)); - } + 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); - /* 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); + 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 vec = car(p); + const s7_int n = sequence_length(sc, vec); + if (n > 0) + { + if ((typed) && (is_typed_t_vector(vec))) + { + if (!vtyper) + vtyper = typed_vector_typer(vec); + else + if (vtyper != typed_vector_typer(vec)) + typed = false; + } + else typed = false; + vector_length(new_vec) = n; + set_car(pargs, vec); + 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); } - } - 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); + unstack_gc_protect(sc); + return(new_vec); } -static Inline bool -inline_op_for_each_2 (s7_scheme* sc) /* called once in eval, lg set */ +static s7_pointer hash_table_append(s7_scheme *sc, s7_pointer args) { - const s7_pointer counter= sc->args; - const s7_pointer lst = counter_list (counter); - if (!is_pair ( - lst)) /* '(1 2 . 3) as arg? -- counter_list can be anything here */ - { - sc->value= sc->unspecified; - return (true); - } - counter_set_list (counter, cdr (lst)); - if (sc->cur_op == OP_FOR_EACH_3) { - counter_set_result (counter, cdr (counter_result (counter))); - if (counter_result (counter) == counter_list (counter)) { - 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 (counter) != 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 (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)); - set_curlet (sc, - update_let_with_slot (sc, counter_let (counter), 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_let= 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_let); - } - 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_let= 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_let); - if (result) return (result); - set_no_cell_opt (body); + 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); } - else /* not func */ + 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_no_cell_opt (body); - set_curlet (sc, old_let); + 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); +} - 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); +static s7_pointer let_append(s7_scheme *sc, s7_pointer args) +{ + s7_pointer new_let; + const s7_pointer let = car(args); + if_let_method_exists_return_value(sc, let, 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(s7i_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(s7i_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); +} - 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)); +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)));} - push_stack (sc, OP_MAP, inline_make_counter (sc, sc->z), clo); - sc->z= sc->unused; - return (sc->unspecified); +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? */ + sc->temp7 = b; /* GC protect b across the copy loop below (it is not otherwise protected here) */ + 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); + sc->temp7 = sc->unused; + 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_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? - */ - const s7_pointer clo = car (args); - s7_int len = 0; - bool got_nil= false; - for (s7_pointer 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; - 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))); - } - } +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); +} - { - s7_pointer val1, old_args, iter_list; - 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, vals= cdr (val1); is_pair (iters); - iters= cdr (iters), vals= cdr (vals)) { - set_car (vals, 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 */ - { - s7_pointer 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)) { - const 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); +/* -------------------------------- 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 bool -op_map_2 (s7_scheme* sc) /* possibly inline lg */ +static s7_pointer hash_table_to_list(s7_scheme *sc, s7_pointer obj) { - s7_pointer cur_args; - const s7_pointer counter= sc->args, code= sc->code; - { - const s7_pointer p= counter_list (counter); - if (!is_pair (p)) { - sc->value= proper_list_reverse_in_place (sc, counter_result (counter)); - return (true); + 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); } - cur_args= car (p); - counter_set_list (counter, 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 (counter)) { - sc->value= proper_list_reverse_in_place (sc, counter_result (counter)); - return (true); - } - push_stack_direct (sc, OP_MAP_GATHER_2); - } - else push_stack_direct (sc, OP_MAP_GATHER_3); - - if (counter_capture (counter) != 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 (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)); /* needed -- see comment under for-each above */ - set_curlet (sc, update_let_with_slot (sc, counter_let (counter), cur_args)); - } - sc->code= car (closure_body (code)); - return (false); + unstack_gc_protect(sc); + return_with_end_temp(sc->y); } -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 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 obj_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))); + + obj_len = c_object_length(sc, obj); + if (!s7_is_integer(obj_len)) return(sc->F); + len = s7_integer_clamped_if_gmp(sc, obj_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 Inline void -inline_op_map_gather (s7_scheme* sc) /* called thrice in eval, cb lg map */ +static s7_pointer object_to_list(s7_scheme *sc, s7_pointer obj) /* used only in format_to_port_1 and (map values ...) */ { - 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))); - } + 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); } -/* -------------------------------- 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, 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); +/* ---------------- 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 -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 random_state_to_let(s7_scheme *sc, s7_pointer rs) +{ + 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)))); } -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 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, "symtab-stats:empty|1|2|n|most", 29), /* "symtab-stats" to distinguish from hash-stats below */ + 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 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 */ +static void hash_table_checker_to_let(s7_scheme *sc, s7_pointer let, s7_pointer table) { - /* 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)); -} + 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); +} + +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); -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)); +#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 -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)); +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 - 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)); + if (is_pair(seq)) + s7_varlet(sc, let, sc->position_symbol, iterator_current(iter)); + unstack_gc_protect(sc); + return(let); } -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 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 -op_c_p_mv ( - s7_scheme* sc, - s7_pointer args) /* (values (values 1 2)) or (apply (values + '(2))) */ +static s7_pointer c_object_to_let(s7_scheme *sc, s7_pointer cobj) { - 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); + 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 -op_c_ap_mv (s7_scheme* sc, s7_pointer args) /* (values 2 (values 3 4)) or (apply - + (values 5 '(1 2))) */ +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) { - 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)); + /* 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 -op_safe_c_pp_6_mv (s7_scheme* sc, s7_pointer args) /* both args mv */ +static s7_pointer c_function_to_let(s7_scheme *sc, s7_pointer cfunc) { - 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)); + 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); } -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 (stack_top_op_unchecked ( - 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: { - s7_pointer func= 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, func), - 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)); +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: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_integer_symbol)); + case T_RATIO: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_rational_symbol)); + case T_REAL: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_real_symbol)); + case T_COMPLEX: return(internal_inlet(sc, 4, sc->value_symbol, obj, sc->type_symbol, sc->is_complex_symbol)); - 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 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 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 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 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 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 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 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 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) { - s7_int old_print_length= sc->print_length; - if (old_print_length > 40) sc->print_length= 40; - 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)); - sc->print_length= old_print_length; - } - 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; - } + 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)); - /* 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); + default: + return(sc->F); + } + return(sc->F); } -/* -------------------------------- 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)); -} +/* g_object_to_let is now defined in s7_scheme_predicate.c */ +#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) -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); +/* bridge functions for s7_scheme_predicate.c migration (round 2) */ +s7_pointer s7i_c_pointer_weak1_p_p(s7_scheme *sc, s7_pointer cptr) {return(c_pointer_weak1_p_p(sc, cptr));} +s7_pointer s7i_c_pointer_weak2_p_p(s7_scheme *sc, s7_pointer cptr) {return(c_pointer_weak2_p_p(sc, cptr));} +/* s7i_tree_leaves_p_p migrated to s7_liii_tree.c */ +s7_pointer s7i_cyclic_sequences_p_p(s7_scheme *sc, s7_pointer p) {return(cyclic_sequences_p_p(sc, p));} +s7_pointer s7i_object_to_let_p_p(s7_scheme *sc, s7_pointer p) {return(object_to_let_p_p(sc, p));} +s7_pointer s7i_pair_line_number_p_p(s7_scheme *sc, s7_pointer p) {return(pair_line_number_p_p(sc, p));} +s7_pointer s7i_reverse_p_p(s7_scheme *sc, s7_pointer p) {return(reverse_p_p(sc, p));} +s7_pointer s7i_port_line_number_p_p(s7_scheme *sc, s7_pointer p) {return(port_line_number_p_p(sc, p));} +/* s7i_tree_memq_b_7pp, s7i_tree_set_memq_b_7pp migrated to s7_liii_tree.c */ +s7_pointer s7i_unlet_disabled(s7_scheme *sc) {return(sc->unlet_disabled);} +s7_pointer s7i_curlet(s7_scheme *sc) {return(sc->curlet);} +void s7i_capture_let_counter_inc(s7_scheme *sc) {sc->capture_let_counter++;} +bool s7i_is_defined_in_rootlet(s7_scheme *sc, s7_pointer sym) {return((is_slot(global_slot(sym))) && (global_value(sym) != sc->undefined));} + + +/* ---------------- stacktrace ---------------- */ +static s7_pointer stacktrace_find_caller(s7_scheme *sc, s7_pointer let) +{ + if ((is_let(let)) && (let != sc->rootlet)) + return(((is_funclet(let)) || (is_maclet(let))) ? funclet_function(let) : stacktrace_find_caller(sc, let_outlet(let))); + return(sc->F); } -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); +static bool stacktrace_find_let(s7_scheme *sc, s7_int loc, s7_pointer let) +{ + return((loc > 0) && + ((stack_let(sc->stack, loc) == let) || + (stacktrace_find_let(sc, loc - 4, let)))); } -bool -s7_is_multiple_value (s7_pointer obj) { - return (is_multiple_value (obj)); +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); } -/* -------------------------------- 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 */ +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)); +} - 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) /* car_unchecked|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 (sc, car (args))) - ? copy_tree_with_type (sc, car (args)) - : car (args), - (is_unquoted_pair (sc, cdr (args))) - ? copy_tree_with_type (sc, cdr (args)) - : cdr (args)); +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)))); } - 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 (sc, 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 */ + return(false); } -/* (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 char *stacktrace_walker(s7_scheme *sc, s7_pointer code, s7_pointer let, 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, let); + add_symbol_to_small_symbol_set(sc, code); + if ((val) && + (val != sc->undefined) && + (!is_any_macro(val)) && + (type(val) < T_CONTINUATION)) + { + char *objstr; + 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); + } + { + char *str; + 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), let, notes, code_cols, total_cols, notes_start_col, as_comment, depth + 1); + return(stacktrace_walker(sc, cdr(code), let, notes, code_cols, total_cols, notes_start_col, as_comment, depth + 2)); + } + return(notes); } -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) */ +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; + block_t *newp; + if ((is_symbol(caller)) && + (caller != car(code))) { - 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); + 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); } - if (is_not_null (cddr (form))) - syntax_error_nr (sc, "unquote: too many arguments, ~S", 31, form); - return (cadr (form)); + 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); + { + block_t *b = mallocate(sc, newlen); + char *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); } +} - /* 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)); +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); - { - 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) */ + if (stacktrace_in_error_handler(sc, top)) { - 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); - } + 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 let = stack_let(sc->stack, true_loc); /* might not be let (gc stack protection etc) */ + const s7_pointer func = stacktrace_find_caller(sc, let); + if (!stacktrace_error_hook_function(sc, func)) + { + 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(let)) && (let != sc->rootlet)) + notes = stacktrace_walker(sc, code, let, NULL, code_cols, total_cols, notes_start_col, as_comment, 0); + newp = stacktrace_add_func(sc, func, 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(let)) && (let != 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_quasiquote (s7_scheme* sc, - s7_pointer args) /* this is for explicit quasiquote support, not - the backquote stuff in macros */ +static s7_pointer g_stacktrace(s7_scheme *sc, s7_pointer args) { - return (g_quasiquote_1 (sc, car (args), true)); + #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)); } -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); -} +/* -------- s7_history, s7_add_to_history, s7_history_enabled -------- */ -/* -------------------------------- 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 func= s7_make_safe_function (sc, name, f, required_args, - optional_args, rest_arg, NULL); - s7_function_set_class (sc, func, cls); - c_function_set_signature (func, c_function_signature (cls)); - return (func); -} - -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 func= s7_make_function (sc, name, f, required_args, optional_args, - rest_arg, NULL); - s7_function_set_class (sc, func, cls); - c_function_set_signature (func, c_function_signature (cls)); - return (func); -} - -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; +s7_pointer s7_add_to_history(s7_scheme *sc, s7_pointer entry) +{ +#if WITH_HISTORY + set_current_code(sc, entry); +#endif + return(entry); +} - /* + */ - 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); +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); +} - /* - */ - 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); +bool s7_history_enabled(s7_scheme *sc) +{ +#if WITH_HISTORY + return(sc->cur_code != sc->history_sink); +#else + return(false); +#endif +} - /* * */ - 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); +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 +} - /* / */ - 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); +#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); + set_cdr_unchecked(p, args); + return(p); +} +#else +#define history_cons(Sc, Code, Args) Code +#endif - /* = */ - 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, "s7-min", g_min_2, 2, 0, false); - sc->min_3= - make_function_with_class (sc, func, "s7-min", g_min_3, 3, 0, false); +/* -------------------------------- profile -------------------------------- */ +static void swap_stack(s7_scheme *sc, opcode_t new_op, s7_pointer new_code, s7_pointer new_args) +{ + s7_pointer code, args, let; + opcode_t op; + sc->stack_end -= 4; + code = stack_end_code(sc); + let = 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) = let; + stack_end_args(sc) = args; + stack_end_op(sc) = (s7_pointer)op; + sc->stack_end += 4; +} - /* max */ - func= set_function_chooser (sc->max_symbol, max_chooser); - sc->max_2= - make_function_with_class (sc, func, "s7-max", g_max_2, 2, 0, false); - sc->max_3= - make_function_with_class (sc, func, "s7-max", g_max_3, 3, 0, false); +static s7_pointer find_funclet(s7_scheme *sc, s7_pointer let) +{ + if ((let == sc->rootlet) || (!is_let(let))) return(sc->F); + if (!((is_funclet(let)) || (is_maclet(let)))) let = let_outlet(let); + if ((let == sc->rootlet) || (!is_let(let))) return(sc->F); + return(((is_funclet(let)) || (is_maclet(let))) ? let : sc->F); +} - /* < */ - 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); +#define PD_INITIAL_SIZE 16 +enum {pd_calls = 0, pd_recur, pd_start, pd_itotal, pd_etotal, pd_block_size}; - /* > */ - 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); +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); +} - /* <= */ - 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); +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) - /* >= */ - 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); + s7_pointer let; + const s7_int pos = integer(car(args)); + if (sc->profile == 0) return(sc-> F); - /* 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); + let = find_funclet(sc, cadr(args)); + if ((is_let(let)) && + (is_symbol(funclet_function(let)))) + { + const s7_pointer func_name = funclet_function(let); + s7_int *timing_data; + 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); - /* 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); + /* 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, let); + if (is_symbol(let_name)) pd->let_names[pos] = let_name; + } + if (has_let_file(let)) + { + pd->files[pos] = sc->file_names[let_file(let)]; + pd->lines[pos] = let_line(let); + }} + timing_data = (s7_int *)(sc->profile_data->timing_data + (pos * pd_block_size)); + timing_data[pd_calls]++; + if (timing_data[pd_recur] == 0) + { + timing_data[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; + } + timing_data[pd_recur]++; - /* 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); + /* 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); +} - /* 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); +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); +} - /* 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); - /* 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); +/* -------------------------------- dynamic-unwind -------------------------------- */ +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 */ +} - /* 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); +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) - /* 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); + 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)); /* ?? */ +} - /* 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, "charvalues_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; - /* read-char */ - func= set_function_chooser (sc->read_char_symbol, read_char_chooser); - sc->read_char_1= make_function_with_class (sc, func, "read-char", - g_read_char_1, 1, 0, false); + /* 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); +} - /* 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); +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); - /* 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); + 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); +} - /* 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)); +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); - /* 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); + /* 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) */ +} - /* stringstring_lt_symbol, string_less_chooser); - sc->string_less_2= make_function_with_class (sc, func, "stringvalue = fx_call(sc, sc->code); +} - /* string */ - func= set_function_chooser (sc->string_symbol, string_chooser); - sc->string_c1= - make_function_with_class (sc, func, "string", s7i_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); +/* -------------------------------- owlet -------------------------------- */ +/* error reporting info -- save filename and line number */ - /* 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_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); +static s7_pointer init_owlet(s7_scheme *sc) +{ + s7_pointer p; /* watch out for order below */ + const s7_pointer let = make_let(sc, sc->rootlet); + begin_temp(sc->x, let); + sc->error_type = add_slot_checked_with_id(sc, let, 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, let, 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, let, 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, let, 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, let, make_symbol(sc, "error-file", 10), sc->F); /* the file name of that code */ + sc->error_position = add_slot_unchecked_with_id(sc, let, 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, let, make_symbol(sc, "error-history", 13), sc->F); /* buffer of previous evaluations */ #endif + end_temp(sc->x); + return(let); +} - /* 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); +#if WITH_HISTORY +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(sc, 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 - /* 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); +/* g_owlet moved to s7_scheme_let.c */ +#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) - /* 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); +/* -------- catch handlers -------- (don't free the catcher) */ +static void load_catch_cstack(s7_scheme *sc, s7_pointer catcher) +{ + if (catch_cstack(catcher)) + sc->goto_start = catch_cstack(catcher); +} - /* 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? */ +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 cat = T_Cat(stack_code(sc->stack, catch_loc)); + if (SHOW_EVAL_OPS) fprintf(stderr, "catcher: %s\n", __func__); + if ((catch_tag(cat) == sc->T) || (catch_tag(cat) == type) || (type == sc->T)) + { + sc->op_stack_now = (s7_pointer *)(sc->op_stack + catch_op_loc(cat)); + sc->stack_end = (s7_pointer *)(sc->stack_start + catch_goto_loc(cat)); + sc->code = catch_handler(cat); + load_catch_cstack(sc, cat); + if (needs_copied_args(sc->code)) + sc->args = list_2(sc, type, info); + else sc->args = with_list_t2(sc, 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); +} - /* 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); +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); + const s7_pointer error_func = catch_handler(catcher); + const s7_uint loc = catch_goto_loc(catcher); + s7_pointer error_body, error_pars; + + 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) + */ - /* 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); + /* 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(sc, 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); +} - /* 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); +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); +} - /* 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); +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); +} - /* 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); +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); +} - /* 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); +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); +} - /* 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); +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); +} - /* 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); +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); +} - /* hash-table-set! */ - set_function_chooser (sc->hash_table_set_symbol, hash_table_set_chooser); +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); +} - /* 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); +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); +} - /* 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); +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); +} - /* 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); +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); +} - /* 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); +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); +} - /* 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); +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 = 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); +} - /* assoc */ - set_function_chooser (sc->assoc_symbol, assoc_chooser); +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); +} - /* member */ - set_function_chooser (sc->member_symbol, member_chooser); +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); - /* 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); + /* 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); +} - /* 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); +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))); - /* 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); + /* 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); +} - /* unlet */ - sc->unlet_disabled= - make_function_with_class (sc, global_value (sc->unlet_symbol), "unlet", - g_unlet_disabled, 0, 0, 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]; - /* 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); +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? */ +} - /* 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); +/* -------------------------------- 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) - /* 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); + 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 */ - /* 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); + 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); +} - /* 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); +/* -------------------------------- 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); + } +} - /* 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)"); +/* -------------------------------- 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); + } } -/* ---------------- *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); +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 */ } + +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 -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 */ - } -} + 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 */ -#define LEVEN_MIN_LEN 2 -#define LEVEN_MAX_LEN 23 -static int32_t** original_distance; + if (sc->current_safe_list > 0) + clear_safe_list_in_use(sc, 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 (type_unchecked(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 */ -static void -init_leven (void) { - int32_t i, j; - original_distance= - (int32_t**) malloc ((LEVEN_MAX_LEN + 1) * sizeof (int32_t*)); - for (i= 0; i <= LEVEN_MAX_LEN; i++) - original_distance[i]= - (int32_t*) calloc (LEVEN_MAX_LEN + 1, sizeof (int32_t)); - for (j= 0; j <= LEVEN_MAX_LEN; j++) - original_distance[0][j]= j; - for (i= 0; i <= LEVEN_MAX_LEN; i++) - original_distance[i][0]= i; -} - -static int32_t -levenshtein (s7_scheme* sc, const char* s1, int32_t len1, const char* s2, - int32_t len2) { - int32_t i, j; - int32_t mx= (len1 > len2) ? len1 : len2; - if ((mx > LEVEN_MAX_LEN) || (mx < LEVEN_MIN_LEN)) return (100); - for (i= 0; i <= mx; i++) - memcpy ((void*) (sc->current_distance[i]), (void*) (original_distance[i]), - mx * sizeof (int32_t)); /* TODO: (mx+1?) */ - for (i= 1; i <= len2; i++) - for (j= 1; j <= len1; j++) { - int32_t c1, c2, c3; - c1= sc->current_distance[i][j - 1] + 1; - c2= sc->current_distance[i - 1][j] + 1; - c3= sc->current_distance[i - 1][j - 1] + - ((s2[i - 1] == s1[j - 1]) ? 0 : 1); - if (c1 > c2) c1= c2; - if (c1 > c3) c1= c3; - sc->current_distance[i][j]= c1; - } - return (sc->current_distance[len2][len1]); -} - -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); - } + 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 type_unchecked 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 (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); */ - { - 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 */ - const char* sym_name= symbol_name (sym); - s7_pointer min_sym = NULL; - for (s7_pointer let= sc->curlet; let; let= let_outlet (let)) - for (s7_pointer slot= let_slots (let); is_not_slot_end (slot); - slot = next_slot (slot)) { - const s7_pointer cur_sym= slot_symbol (slot); - if (s7_int_abs (sym_len - symbol_name_length (cur_sym)) < 2) { - int32_t diff= - levenshtein (sc, 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; - } - } - } - /* fprintf(stderr, "min_sym: %s, err_code: %s\n", (min_sym) ? - * display(min_sym) : "none", display(err_code)); */ - if ((!min_sym) && (err_code) && (is_pair (err_code)) && - (sym == car (err_code)) && - (sym_len < 24)) /* 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 */ -#define MAIN_NAMES_SIZE 443 - static const char* main_names[MAIN_NAMES_SIZE]= { - "<=", - ">=", - "do", - "gc", - "if", - "or", - "pi", - "abs", - "and", - "ash", - "car", - "cdr", - "cos", - "eq?", - "exp", - "gcd", - "lcm", - "let", - "log", - "map", - "s7-max", - "s7-min", - "nan", - "not", - "sin", - "sym", - "tan", - "*s7*", - "acos", - "asin", - "assq", - "assv", - "atan", - "caar", - "cadr", - "case", - "cdar", - "cddr", - "cond", - "cons", - "copy", - "cosh", - "else", - "eqv?", - "eval", - "exit", - "expt", - "help", - "let*", - "let?", - "list", - "load", - "memq", - "memv", - "nan?", - "odd?", - "read", - "set!", - "sinh", - "sqrt", - "tanh", - "when", - "abort", - "acosh", - "angle", - "apply", - "arity", - "asinh", - "assoc", - "atanh", - "bacro", - "begin", - "byte?", - "caaar", - "caadr", - "cadar", - "caddr", - "catch", - "cdaar", - "cdadr", - "cddar", - "cdddr", - "char?", - "error", - "even?", - "fill!", - "floor", - "goto?", - "index", - "inlet", - "list?", - "macro", - "null?", - "owlet", - "pair?", - "quote", - "real?", - "s7-round", - "sort!", - "throw", - "unlet", - "write", - "zero?", - "append", - "bacro*", - "bignum", - "caaaar", - "caaadr", - "caadar", - "caaddr", - "cadaar", - "cadadr", - "caddar", - "cadddr", - "cdaaar", - "cdaadr", - "cdadar", - "cdaddr", - "cddaar", - "cddadr", - "cdddar", - "cddddr", - "char?", - "curlet", - "cutlet", - "define", - "equal?", - "exact?", - "float?", - "format", - "gensym", - "getenv", - "lambda", - "length", - "letrec", - "logand", - "logior", - "lognot", - "logxor", - "macro*", - "macro?", - "member", - "s7-modulo", - "outlet", - "random", - "setter", - "string", - "sublet", - "symbol", - "system", - "unless", - "values", - "varlet", - "vector", - "bignum?", - "call/cc", - "s7-ceiling", - "char<=?", - "char>=?", - "complex", - "define*", - "display", - "funclet", - "gensym?", - "iterate", - "lambda*", - "let-ref", - "letrec*", - "logbit?", - "newline", - "number?", - "openlet", - "provide", - "require", - "reverse", - "rootlet", - "string?", - "symbol?", - "syntax?", - "type-of", - "unquote", - "vector?", - "boolean?", - "complex?", - "coverlet", - "defined?", - "dilambda", - "for-each", - "funclet?", - "inexact?", - "integer?", - "keyword?", - "let-set!", - "list-ref", - "openlet?", - "quotient", - "reverse!", - "set-car!", - "set-cdr!", - "string?", - "s7-truncate", - "with-let", - "aritable?", - "c-object?", - "c-pointer", - "constant?", - "dilambda?", - "hash-code", - "imag-part", - "infinite?", - "iterator?", - "let->list", - "list-set!", - "list-tail", - "magnitude", - "make-hook", - "make-list", - "negative?", - "numerator", - "peek-char", - "port-file", - "positive?", - "provided?", - "rational?", - "read-byte", - "read-char", - "read-line", - "real-part", - "remainder", - "sequence?", - "signature", - "string<=?", - "string>=?", - "substring", - "subvector", - "*function*", - "c-pointer?", - "directory?", - "file-mtime", - "hash-table", - "immutable!", - "immutable?", - "int-vector", - "make-polar", - "procedure?", - "profile-in", - "quasiquote", - "stacktrace", - "string-ref", - "subvector?", - "tree-count", - "tree-memq?", - "undefined?", - "vector-ref", - "write-byte", - "write-char", - "byte-vector", - "char-ready?", - "char-upcase", - "cond-expand", - "delete-file", - "denominator", - "eof-object?", - "equivalent?", - "eval-string", - "hash-table?", - "input-port?", - "int-vector?", - "list-values", - "macroexpand", - "make-string", - "make-vector", - "nan-payload", - "object->let", - "port-string", - "rationalize", - "read-string", - "reader-cond", - "string-copy", - "string-set!", - "tree-leaves", - "vector-rank", - "vector-set!", - "with-baffle", - "apply-values", - "byte-vector?", - "c-object-let", - "define-bacro", - "define-macro", - "dynamic-wind", - "file-exists?", - "float-vector", - "list->string", - "list->vector", - "output-port?", - "port-closed?", - "proper-list?", - "random-state", - "string->list", - "string-fill!", - "symbol-table", - "tree-cyclic?", - "tree-member?", - "unspecified?", - "vector->list", - "vector-fill!", - "vector-typer", - "write-string", - "c-object-type", - "char->integer", - "char-downcase", - "char-numeric?", - "char-position", - "continuation?", - "define-bacro*", - "define-macro*", - "documentation", - "float-vector?", - "integer->char", - "make-iterator", - "pair-filename", - "port-filename", - "port-position", - "random-state?", - "string-append", - "string-length", - "symbol->value", - "tree-set-memq", - "vector-append", - "vector-length", - "c-pointer-info", - "c-pointer-type", - "call-with-exit", - "complex-vector", - "dynamic-unwind", - "emergency-exit", - "exact->inexact", - "hash-table-ref", - "hook-functions", - "inexact->exact", - "int-vector-ref", - "integer-length", - "number->string", - "object->string", - "string->number", - "string->symbol", - "symbol->string", - "byte-vector-ref", - "c-pointer->list", - "c-pointer-weak1", - "c-pointer-weak2", - "complex-vector?", - "define-constant", - "directory->list", - "int-vector-set!", - "keyword->symbol", - "let-temporarily", - "make-int-vector", - "open-input-file", - "string->keyword", - "string-position", - "symbol->keyword", - "weak-hash-table", - "byte-vector-set!", - "call-with-values", - "char-alphabetic?", - "char-upper-case?", - "char-whitespace?", - "close-input-port", - "cyclic-sequences", - "define-expansion", - "float-vector-ref", - "iterator-at-end?", - "make-byte-vector", - "make-rectangular", - "open-output-file", - "pair-line-number", - "port-line-number", - "procedure-source", - "subvector-vector", - "vector-dimension", - "weak-hash-table?", - "close-output-port", - "define-expansion*", - "float-vector-set!", - "flush-output-port", - "get-output-string", - "iterator-sequence", - "make-float-vector", - "open-input-string", - "procedure-arglist", - "vector-dimensions", - "complex-vector-ref", - "current-error-port", - "current-input-port", - "hash-table-entries", - "open-output-string", - "random-state->list", - "s7-hash-table-set!", - "s7-make-hash-table", - "substring-uncopied", - "subvector-position", - "byte-vector->string", - "complex-vector-set!", - "current-output-port", - "make-complex-vector", - "multiple-value-bind", - "open-input-function", - "string->byte-vector", - "with-output-to-file", - "call-with-input-file", - "hash-table-key-typer", - "integer-decode-float", - "make-weak-hash-table", - "open-output-function", - "symbol-initial-value", - "with-input-from-file", - "call-with-output-file", - "symbol->dynamic-value", - "with-output-to-string", - "call-with-input-string", - "hash-table-value-typer", - "set-current-error-port", - "set-current-input-port", - "with-input-from-string", - "call-with-output-string", - "set-current-output-port"}; - - static const int32_t main_names_index[LEVEN_MAX_LEN]= { - 0, 7, 27, 62, 103, 156, 184, 206, 243, 265, 296, 321, - 344, 361, 378, 397, 407, 417, 425, 432, 435, 440, 442}; /* 443==NULL, - 7858 - - 3576 - bytes */ - const int32_t start= main_names_index[sym_len - 2], - end = main_names_index[sym_len - 1]; -#if 0 - { /* if above list changed, this might help: */ - const char *starts[22] = {"<=", "cos", "acos", "error", "define", "letrec*", "quotient", "substring", - "int-vector", "object->let", "float-vector", "string-append", - "hook-functions", "c-pointer-weak2", "iterator-at-end?", "open-input-string", - "open-output-string", "string->byte-vector", "with-input-from-file", - "with-output-to-string", "set-current-error-port", "set-current-output-port"}; - fprintf(stderr, "starts[22] = {"); - for (int32_t i = 0; i < 22; i++) - for (int32_t j = 0; j < MAIN_NAMES_SIZE; j++) - if (strcmp(main_names[j], starts[i]) == 0) - { - fprintf(stderr, "%d, ", j); - break; - }} - for (int32_t i = 0; i < LEVEN_MAX_LEN; i++) fprintf(stderr, "%s\n", main_names[main_names_index[i]]); -#endif - for (int32_t i= start; i < end; i++) { - /* main_names has only 430 entries but main_names_index is sized - for 443, so the length-20..23 buckets run into trailing NULL - slots; skip NULLs to avoid dereferencing them in levenshtein. */ - if (main_names[i] == NULL) continue; - int32_t diff= - levenshtein (sc, 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 (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)); - } + 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? */ } - } - - 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)); + 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 (safe_strcmp (symbol_name (sym), "|#")) read_error_nr (sc, "unmatched |#"); + 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; - /* 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 (let) 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 let= loaded_library (sc, file); - if ((!let) || (!is_let (let))) { - if (hook_has_functions (sc->autoload_hook)) - s7_apply_function ( - sc, sc->autoload_hook, - set_plist_2 (sc, sym, s7_make_string (sc, file))); - let= 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) && (let) && (is_let (let))) { - /* 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, let, 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 let= 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)); - let= 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)); - let= 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) && (let) && - (is_let (let))) /* added 31-Mar-23 to match sc->autoload_names case - above */ - { - result= let_ref_p_pp (sc, let, 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); - } + /* 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; /* ?? */ } - 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); + LongJmp(*(sc->goto_start), error_jump); } -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); +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); } -#define choose_c_function(Sc, Expr, Func, Args) \ - set_class_and_fn_proc (Expr, c_function_chooser (Func) (Sc, Func, Args, Expr)) +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); -static void -fx_annotate_arg (s7_scheme* sc, s7_pointer arg, s7_pointer let_or_list) { -#if S7_DEBUGGING - s7_function fx; - if (has_fx (arg)) return; - fx= fx_choose (sc, arg, let_or_list, - (is_list (let_or_list)) ? 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(let_or_list)); */ -#else - if (has_fx (arg)) return; - set_fx (arg, fx_choose (sc, arg, let_or_list, - (is_list (let_or_list)) ? pair_symbol_is_safe - : let_symbol_is_safe)); -#endif -} + 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]; + } -static void -fx_annotate_args (s7_scheme* sc, s7_pointer args, s7_pointer let_or_list) { - for (s7_pointer p= args; is_pair (p); p= cdr (p)) -#if S7_DEBUGGING - fx_annotate_arg (sc, p, let_or_list); /* checks has_fx */ -#else - if (!has_fx (p)) - set_fx (p, fx_choose (sc, p, let_or_list, - (is_list (let_or_list)) ? pair_symbol_is_safe - : let_symbol_is_safe)); -#endif -} + 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 opt_t -optimize_thunk (s7_scheme* sc, s7_pointer expr, s7_pointer func, int32_t hop, - s7_pointer let_or_list) { - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: expr: %s, func: %s, hop: %d, let_or_list: %s\n", - __func__, __LINE__, display_truncated (expr), display (func), hop, - display_truncated (let_or_list)); - 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, let_or_list); - 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, let_or_list); - 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); -} +/* g_error is now implemented in s7_scheme_base.c */ +#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) -static int32_t -combine_ops (s7_scheme* sc, s7_pointer expr, combine_op_t cop, s7_pointer arg1, - s7_pointer arg2) /* 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 (arg1)) { - 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 (arg1)); - set_opt1_sym (cdr (expr), caddr (arg1)); - return (OP_SAFE_C_opSSq); - case OP_SAFE_C_opSq: - set_opt3_pair (expr, cadr (arg1)); - set_opt3_sym (cdr (expr), cadadr (arg1)); - return (OP_SAFE_C_op_opSqq); - case OP_SAFE_C_S_opSq: - set_opt3_pair (expr, caddr (arg1)); - return (OP_SAFE_C_op_S_opSqq); - case OP_SAFE_C_opSq_S: - set_opt3_pair (expr, cadr (arg1)); - 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 (arg2)) { - 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 (arg2)); - 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 (arg2)); - return (OP_SAFE_C_S_opCSq); - case OP_SAFE_C_SS: /* (* a (- b c)) */ - set_opt2_sym (cdr (expr), caddr (arg2)); - 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 (arg1)) { - case OP_SAFE_C_S: - set_opt1_sym (cdr (expr), cadr (arg1)); - set_opt3_sym (expr, arg2); - 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 (arg1)); - return (OP_SAFE_C_op_opSSqq_S); - } - return (OP_SAFE_C_PS); - - case combine_pc: - switch (op_no_hop (arg1)) { - case OP_SAFE_C_S: - set_opt1_sym (cdr (expr), cadr (arg1)); - set_opt2_con (cdr (expr), arg2); - 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 (arg2)) { - case OP_SAFE_C_S: - set_opt3_pair (expr, arg2); - return (OP_SAFE_C_C_opSq); - case OP_SAFE_C_SC: - set_opt1_sym (cdr (expr), cadr (arg2)); - set_opt2_con (cdr (expr), caddr (arg2)); - return (OP_SAFE_C_C_opSCq); - case OP_SAFE_C_SS: - set_opt1_sym (cdr (expr), cadr (arg2)); - return (OP_SAFE_C_C_opSSq); - } - return (OP_SAFE_C_CP); - - case combine_pp: - switch (op_no_hop (arg2)) { - case OP_SAFE_C_S: - if (is_safe_c_s (arg1)) return (OP_SAFE_C_opSq_opSq); - if (optimize_op_match (arg1, OP_SAFE_C_SS)) return (OP_SAFE_C_opSSq_opSq); - break; - case OP_SAFE_C_SS: - if (optimize_op_match (arg1, OP_SAFE_C_SS)) - return (OP_SAFE_C_opSSq_opSSq); - if (is_safe_c_s (arg1)) return (OP_SAFE_C_opSq_opSSq); - break; +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 (OP_SAFE_C_PP); + return(form); +} - default: - break; +static s7_pointer object_to_string_truncated(s7_scheme *sc, s7_pointer obj) +{ + 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, obj, 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); } - return (OP_UNOPT); } -static bool -arg_findable (s7_scheme* sc, s7_pointer arg1, s7_pointer let_or_list) { - if (pair_symbol_is_safe (sc, arg1, let_or_list)) - return (true); /* includes global_slot check */ - return ((!sc->in_with_let) && (is_bound_symbol (sc, arg1))); +static s7_pointer tree_descend(s7_scheme *sc, s7_pointer tree, uint32_t line) +{ + s7_pointer tp; + if (!is_pair(tree)) return(NULL); + if (has_location(tree)) + { + uint32_t cur_line = (uint32_t)pair_line_number(tree); + 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(tree); + }} + tp = tree_descend(sc, car(tree), line); + return((tp) ? tp : tree_descend(sc, cdr(tree), line)); } -static bool -symbol_is_safe (s7_scheme* sc, s7_pointer arg, s7_pointer let_or_list) { - 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, let_or_list)); - if (is_slot (global_slot (arg))) return (true); - if ((!symbol_is_in_big_symbol_set (sc, arg)) && - (!arg_findable (sc, arg, let_or_list))) - return (false); - } - return (true); -} +static no_return void missing_close_paren_error_nr(s7_scheme *sc) +{ + char *syntax_msg = NULL; + const s7_pointer port = current_input_port(sc); -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); + if (type_unchecked(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 opt_t -check_c_aa (s7_scheme* sc, s7_pointer expr, s7_pointer func, int32_t hop, - s7_pointer let_or_list) { - fx_annotate_args (sc, cdr (expr), let_or_list); - 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 let_or_list) { - 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, let_or_list)); - } - 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)))) { - const 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 symbols) { - if ((symbol_is_in_big_symbol_set (sc, symbol)) && - (direct_memq (symbol, - symbols))) /* it's probably a local variable reference */ - return (sc->nil); - /* ((!symbol_is_in_big_symbol_set(sc, symbol)) && (direct_memq(symbol, - * symbols))) 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 +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) */ - 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. + 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. */ - if ((has_keyword (symbol)) && - (symbol_is_in_big_symbol_set (sc, symbol_to_keyword (sc, symbol)))) - return (sc->nil); - { - s7_pointer let= sc->curlet; - s7_int id = symbol_id (symbol); - for (; let_id (let) > id; let= let_outlet (let)) - ; - for (; let; let= let_outlet (let)) { - if (let_id (let) == id) return (local_slot (symbol)); - for (s7_pointer slot= let_slots (let); is_not_slot_end (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) */ + 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); } -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); + +/* -------------------------------- hooks -------------------------------- */ +s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook) +{ + return(s7_symbol_local_value(sc, sc->body_symbol, closure_let(hook))); } -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)))); +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 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 let_or_list) { - 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), let_or_list); - 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); +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); +} - 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), let_or_list); - } - choose_c_function (sc, expr, func, 1); -#if 0 - /* works, not much impact? 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), let_or_list); - set_opt3_arglen (cdr (expr), 1); - choose_c_function (sc, expr, func, 1); - return (opt_bad); - } - } - else /* bad_pairs == 1 */ +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)); { - if (quotes == 1) { - fx_annotate_arg (sc, cdr (expr), let_or_list); - 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) { - const s7_pointer lambda_expr= arg1; - if ((is_ok_lambda (sc, lambda_expr)) && - (!direct_memq (car (lambda_expr), - let_or_list))) /* (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) { - const s7_pointer arg_func= cadr (expr); - set_unsafe_optimize_op (expr, OP_CALL_CC); - /* (call/cc (lambda (return) (do ((i 0 (+ i 1))) ((= i 10)) (if (= i - * 3) (return 32))))) */ - - /* 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. - */ - 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))); - */ - } - } - 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); - } + s7_pointer slot = lookup_slot_from(sc->body_symbol, closure_let(hook)); + if (is_slot(slot)) slot_set_value(slot, lst); } - return (true); + return(lst); } -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 let_or_list, int32_t hop) { - const s7_pointer body= closure_body (func); - fx_annotate_arg (sc, body, let_or_list); - /* we can't currently fx_annotate_arg(sc, cdr(expr), let_or_list) 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); + +/* -------------------------------- 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 -fxify_closure_a (s7_scheme* sc, s7_pointer func, bool one_form, bool safe_case, - int32_t hop, s7_pointer expr, s7_pointer let_or_list) { - 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, let_or_list); - 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 let_or_list) { - 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), let_or_list); - 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, let_or_list); - 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 let_or_list) { - 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), let_or_list); - 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, let_or_list); - 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 let_or_list) { - 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, let_or_list)); - if ((arit == -1) && (is_symbol (cdr (closure_pars (func))))) - return (optimize_closure_a_sym (sc, expr, func, hop, 1, let_or_list)); - return (opt_bad); - } - { - const s7_pointer arg1 = cadr (expr); - 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 (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, let_or_list, 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); - } +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_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), let_or_list); - set_opt3_arglen (cdr (expr), 1); - if (fxify_closure_a (sc, func, one_form, safe_case, hop, expr, - let_or_list)) - 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), let_or_list); + { + 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); } - } - return (opt_bad); /* don't check is_optimized here for opt_ok */ + 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); } -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 let_or_list) { - s7_pointer arg1= cadr (expr); - if (SHOW_EVAL_OPS) - fprintf (stderr, - " %s[%d]: expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, " - "quotes: %d, bad_pairs: %d, let_or_list: %s\n", - __func__, __LINE__, display_truncated (expr), display (func), hop, - pairs, symbols, quotes, bad_pairs, - display_truncated (let_or_list)); - /* 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, let_or_list)) return (opt_oops); - if ((bad_pairs == quotes) && (is_symbol (car (expr))) && - (is_constant_symbol (sc, car (expr)))) - hop= 1; - } - /* need in_with_let -> search only rootlet not lookup */ - if ((symbols == 1) && - ((!symbol_is_safe (sc, arg1, let_or_list)) || - (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, let_or_list)); - } - 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, let_or_list)); - - case T_CLOSURE: - return ( - optimize_closure_one_arg (sc, expr, func, hop, symbols, let_or_list)); - - 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), let_or_list); - 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), let_or_list); - 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), let_or_list); - 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) */ +/* -------------------------------- 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))) { - 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), let_or_list); - set_opt3_arglen (cdr (expr), 1); - return (opt_ok); - } - break; - - default: - break; - } - return ((is_optimized (expr)) ? opt_ok : opt_bad); + 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 bool -unsafe_is_safe (s7_scheme* sc, s7_pointer sym, s7_pointer symbols) { - s7_pointer slot; - if (!is_symbol (sym)) return (false); - slot= find_uncomplicated_symbol ( - sc, sym, symbols); /* 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 let_or_list, 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, let_or_list, - (is_list (let_or_list)) ? 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 let_or_list) { - if ((is_symbol (car (expr))) && - ((car (expr) == sc->member_symbol) || (car (expr) == sc->assoc_symbol))) - return (true); - return (unsafe_is_safe (sc, cadr (expr), let_or_list)); -} - -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 let_or_list, 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, let_or_list, - (is_list (let_or_list)) ? 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 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 int32_t check_lambda (s7_scheme* sc, s7_pointer form, bool optl); +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) -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 let_or_list) { - 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, let_or_list: %s\n", - __func__, __LINE__, display_truncated (expr), display (func), hop, - pairs, symbols, quotes, bad_pairs, - display_truncated (let_or_list)); - if (quotes > 0) { - if (direct_memq (sc->quote_symbol, let_or_list)) 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, let_or_list)) || - (!symbol_is_safe (sc, arg2, let_or_list))) { - /* 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 */ + /* 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))) { - fx_annotate_args (sc, arg1p, let_or_list); - return (wrap_bad_args (sc, func, expr, 2, hop, let_or_list)); + push_stack(sc, OP_APPLY, sc->nil, func); + return(sc->nil); } - return (opt_bad); - } - /* end of bad symbol wrappers */ + if (is_safe_procedure(func)) + { + s7_pointer arg, next_arg; + if (is_immutable(args)) /* (apply '(1) '(1)) where sc->t2_1 gets used in op_x_aa? */ + args = copy_proper_list(sc, args); + for (arg = args, next_arg = cdr(args); is_pair(cdr(next_arg)); arg = next_arg, next_arg = cdr(next_arg)); + /* 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(next_arg))) /* (apply + #f) etc, the cycle protection here is checked in s7test */ + apply_list_error_nr(sc, args); + set_cdr(arg, car(next_arg)); /* 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. + */ + if (needs_copied_args(sc->code)) sc->args = copy_proper_list(sc, sc->args); + push_stack_direct(sc, OP_APPLY); + return(sc->nil); +} - 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, let_or_list)))) { - /* 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, let_or_list); - 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, let_or_list)))) { - 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, let_or_list)); /* AA case */ - set_optimize_op (expr, hop + OP_SAFE_C_AP); - fx_annotate_arg (sc, arg1p, let_or_list); - 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), let_or_list); - 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); - } - } +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); +} - if ((bad_pairs == 0) && (pairs == 1)) { - if ((func_is_safe) || - ((is_maybe_safe (func)) && (two_args_ok (sc, expr, let_or_list)))) { - combine_op_t orig_op; - int32_t op; +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); +} - 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, let_or_list); - 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); - } - } +static s7_pointer apply_c_function_unopt(s7_scheme *sc, s7_pointer func, s7_pointer args); - if ((bad_pairs == 1) && (quotes == 1)) { - if ((func_is_safe) || - ((is_maybe_safe (func)) && (two_args_ok (sc, expr, let_or_list)))) { - 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, let_or_list)); - } - } - else if (pairs == 1) { - set_unsafe_optimize_op ( - expr, hop + ((is_semisafe (func)) ? OP_CL_AA : OP_C_AA)); - fx_annotate_args (sc, arg1p, let_or_list); - set_opt3_arglen (arg1p, 2); - choose_c_function (sc, expr, func, 2); - return (opt_bad); - } - } +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))); +} - 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); +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 + */ + switch (type(obj)) + { + case T_VECTOR: /* (#(#(1 2) #(3 4)) 1 1) -> 4 */ + return(s7i_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); } - fx_annotate_args (sc, arg1p, let_or_list); - 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, let_or_list))))) { - 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); + 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); } - if (symbols == 0) { - set_optimized (expr); - if ((is_fxable (sc, arg1)) && (is_fxable (sc, arg2))) - return (check_c_aa (sc, expr, func, hop, let_or_list)); - 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); + 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); } - } - - if ((pairs == 2) && - ((func_is_safe) || - ((is_maybe_safe (func)) && (two_args_ok (sc, expr, let_or_list))))) { - 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 (sc, 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); - } + 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 */ + { + s7_pointer 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); } - 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, let_or_list)); - set_optimize_op (expr, hop + OP_SAFE_C_AP); - opt_sp_1 (sc, c_function_call (func), expr); - fx_annotate_arg (sc, arg1p, let_or_list); - } - else if (is_fxable (sc, arg2)) { - set_optimize_op (expr, hop + OP_SAFE_C_PA); - fx_annotate_arg (sc, cddr (expr), let_or_list); - } - 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); + case T_HASH_TABLE: /* ((vector (hash-table '(a . 1) '(b . 2))) 0 'a) -> 1 */ + { + s7_pointer 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); } - if (quotes == 1) { - if (is_safe_quote (sc, 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); + case T_LET: + { + s7_pointer 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)); - if (func_is_safe) { - if (fx_count (sc, expr) == 2) - return (check_c_aa (sc, expr, func, hop, let_or_list)); - } - 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, let_or_list); - 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), - let_or_list))) /* 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, - let_or_list))) /* 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, let_or_list); - } - 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), let_or_list); - 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); - } + 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); } - return ( - set_any_c_np (sc, func, expr, let_or_list, 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, let_or_list)); - if ((arit == -1) && - (is_symbol (cdr (closure_pars (func))))) /* (define (f a . b) ...) */ - return (optimize_closure_a_sym (sc, expr, func, hop, 2, let_or_list)); - 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, let_or_list); - 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, let_or_list); */ - 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); +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); } - } +} - 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, let_or_list); - 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, let_or_list); - set_opt1_lambda_add (expr, func); - set_opt3_arglen (arg1p, 2); - return (opt_ok); - } - fx_annotate_args (sc, arg1p, let_or_list); - 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, let_or_list); - 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), let_or_list); - 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), let_or_list); - 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, let_or_list, 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); - } +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; + const int32_t n_args = c_function_max_args(func); /* not counting keywords, I think, "par" and "arg" are not used consistently here */ - 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, let_or_list); - set_opt1_lambda_add (expr, func); - return (opt_bad); + 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; + s7_pointer *par_names; + /* 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); + par_names = c_function_par_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 (par_names[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) + { + s7_pointer *par_defaults = 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, par_defaults[ki]); + } + else + for (ki = i, kpar = par; ki < n_args; ki++, kpar = cdr(kpar)) + if (!is_checked(kpar)) + { + s7_pointer defval = par_defaults[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); +} - 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, let_or_list); - set_opt3_arglen (arg1p, 2); - set_class_and_fn_proc (expr, func); - return (opt_ok); - } +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_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, let_or_list); - 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 let_or_list) { - 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); - } + 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); } - 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); - } - } + 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); +} - fx_annotate_args (sc, arg1p, let_or_list); - 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); +#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)) - 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 let_or_list) { - const s7_pointer arg1p= cdr (expr), arg1= cadr (expr), arg2= caddr (expr), - arg3= cadddr (expr); - if ((quotes > 0) && (direct_memq (sc->quote_symbol, let_or_list))) - return (opt_oops); - if ((!symbol_is_safe (sc, arg1, let_or_list)) || - (!symbol_is_safe (sc, arg2, let_or_list)) || - (!symbol_is_safe (sc, arg3, let_or_list))) { - /* 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, let_or_list); - 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, let_or_list)))) { - if (optimize_safe_c_func_three_args (sc, expr, func, hop, pairs, symbols, - quotes, let_or_list) == 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, let_or_list, 3, hop + OP_SAFE_C_3P)); - } - /* func is not safe */ - if (fx_count (sc, expr) == 3) { - set_optimized (expr); - fx_annotate_args (sc, arg1p, let_or_list); - 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 (sc, 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 (sc, 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 (sc, 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); - } - } - } +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); +} - 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), let_or_list); - 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); - } +/* -------------------------------- eval -------------------------------- */ +s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer let) +{ + 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, let)) + s7_warn(sc, 256, "the third argument to %s (the environment): %p, is not an s7 object\n", __func__, let); + } + 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(let)) ? let : sc->rootlet); + eval(sc, OP_EVAL); + } + restore_jump_info(sc); - if ((is_safe_procedure (func)) || - ((is_semisafe (func)) && (((car (expr) != sc->assoc_symbol) && - (car (expr) != sc->member_symbol)) || - (unsafe_is_safe (sc, arg3, let_or_list))))) - return ( - set_any_c_np (sc, func, expr, let_or_list, 3, hop + OP_SAFE_C_3P)); - return (set_any_c_np (sc, func, expr, let_or_list, 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, let_or_list)); - 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, let_or_list); - 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, let_or_list); - 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, let_or_list, 3, - hop + OP_ANY_CLOSURE_3P)); - } + if (is_multiple_value(sc->value)) + sc->value = splice_in_values(sc, multiple_value(sc->value)); + return(sc->value); +} - 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, let_or_list); - set_opt1_lambda_add (expr, func); - set_opt3_arglen (arg1p, 3); - return (opt_bad); +s7_pointer s7_eval_with_location(s7_scheme *sc, s7_pointer code, s7_pointer let, 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, (let == sc->nil) ? sc->rootlet : let); + if (caller) + { + sc->s7_call_name = NULL; + sc->s7_call_file = NULL; + sc->s7_call_line = -1; + } + return(result); +} - 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, let_or_list); - set_opt3_arglen (arg1p, 3); - set_class_and_fn_proc (expr, func); - return (opt_ok); - } - /* implicit_vector_3a doesn't happen */ +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 (bad_pairs > quotes) return (opt_bad); - return ((is_optimized (expr)) ? opt_ok : opt_bad); + if (is_pair(cdr(args))) + { + s7_pointer let = cadr(args); + if (!is_let(let)) + { + s7_pointer new_let = find_let(sc, let); + if (!is_let(new_let)) + find_let_error_nr(sc, sc->eval_symbol, let, new_let, 2, args); + let = new_let; + } + set_curlet(sc, let); + } + 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); } -static bool -symbols_are_safe (s7_scheme* sc, s7_pointer args, s7_pointer let_or_list) { - 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, let_or_list))) - 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 let_or_list) { - const s7_pointer arg1p= cdr (expr); - if (quotes > 0) { - if (direct_memq (sc->quote_symbol, let_or_list)) 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, let_or_list)) - 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, let_or_list); - } - 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, let_or_list); - 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 (sc, 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, let_or_list, 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, let_or_list); - 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, let_or_list, args, - hop + OP_ANY_C_NP)); /* was num_args=3! 2-Sep-20 */ - } +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) */ { - 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, let_or_list)); - return (opt_bad); + 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); } - 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, let_or_list); - set_opt3_arglen (arg1p, args); - set_opt1_lambda_add (expr, func); - - if ((symbols == args) && (symbols_are_safe (sc, arg1p, let_or_list))) { - 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); + else + { + if (sc->safety > no_safety) + check_list_validity(sc, __func__, args); + push_stack_direct(sc, OP_EVAL_DONE); /* this saves the current evaluation and will eventually finish this (possibly) nested call */ + sc->code = func; + sc->args = (needs_copied_args(func)) ? copy_proper_list(sc, args) : args; + eval(sc, OP_APPLY); } - if (args == 4) - return (set_any_closure_np (sc, func, expr, let_or_list, 4, - hop + OP_ANY_CLOSURE_4P)); - return (set_any_closure_np (sc, func, expr, let_or_list, 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, let_or_list); - 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, let_or_list); - 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)) { - const 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 let_or_list, bool export_ok); - -static bool -vars_opt_ok (s7_scheme* sc, s7_pointer vars, int32_t hop, - s7_pointer let_or_list) { - 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 ( - sc, - 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. vars_opt_ok needs to be smarter! */ - return (false); - } - if ((is_pair (init)) && (!is_checked (init)) && - (optimize_expression (sc, init, hop, let_or_list, false) == opt_oops)) - return (false); + 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); } - return (true); } -static void -cleanup_big_symbol_set (s7_scheme* sc, s7_pointer orig_e, s7_pointer var_list) { - for (s7_pointer p= var_list; ((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); +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); } -static opt_t -optimize_syntax (s7_scheme* sc, s7_pointer expr, s7_pointer func, int32_t hop, - s7_pointer let_or_list, bool export_ok) { - const opcode_t op = syntax_opcode (func); - s7_pointer body = cdr (expr), vars; - const s7_pointer init_let_or_list= let_or_list; - bool body_export_ok = true; - if (SHOW_EVAL_OPS) - fprintf (stderr, - " %s[%d]: expr: %s, func: %s, let_or_list: %s, op: %s, hop: %d, " - "export_ok: %d\n", - __func__, __LINE__, display_truncated (expr), display (func), - display (let_or_list), op_names[op], hop, export_ok); - sc->w= let_or_list; - switch (op) { - case OP_QUOTE: - case OP_MACROEXPAND: - if (is_proper_list_1 (sc, body)) { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - 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_let_or_list, let_or_list); - 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)) - let_or_list= - cons (sc, sc->nil, let_or_list); /* () in let_or_list = 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); +/* -------------------------------- 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 - if ((op == OP_LETREC) || (op == OP_LETREC_STAR)) { - let_or_list= collect_variables (sc, vars, let_or_list); - if (!vars_opt_ok (sc, vars, hop, let_or_list)) return (opt_oops); - } - else if (op == OP_LET) { - if (!vars_opt_ok (sc, vars, hop, let_or_list)) return (opt_oops); - let_or_list= collect_variables (sc, vars, let_or_list); - } - 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, let_or_list, false) == - opt_oops)) - return (opt_oops); - let_or_list= cons (sc, add_symbol_to_big_symbol_set (sc, car (var)), - let_or_list); - sc->w = let_or_list; - } - if (is_symbol (cadr (expr))) { - let_or_list= cons (sc, add_symbol_to_big_symbol_set (sc, cadr (expr)), - let_or_list); - sc->w = let_or_list; - } - 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, let_or_list, false) == - opt_oops)) - return (opt_oops); - } - /* let_or_list = cons(sc, sc->nil, let_or_list); */ /* !? 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)) let_or_list= cons (sc, sc->nil, let_or_list); - 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, let_or_list, false) == - opt_oops)) /* the init field -- locals are not defined yet */ - return (opt_oops); - } - let_or_list= collect_variables (sc, vars, let_or_list); - 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, let_or_list, 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: - let_or_list= cons (sc, sc->nil, let_or_list); - break; - - case OP_DEFINE_BACRO: - case OP_DEFINE_BACRO_STAR: - case OP_BACRO: - case OP_BACRO_STAR: - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - 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 (let_or_list), the added name is - * inserted into let_or_list 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 "let_or_list", but it needs to be - * marked for find_uncomplicated_symbol in a way that can be distinguished - * from members of "let_or_list". 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 (let_or_list)) && (car (let_or_list) != sc->if_keyword)) - set_cdr (let_or_list, - cons (sc, car (vars), cdr (let_or_list))); /* export it */ - else let_or_list= cons (sc, car (vars), let_or_list); - } - let_or_list = collect_parameters (sc, cdr (vars), let_or_list); - body_export_ok= export_ok; - } - else /* vars must be a symbol */ - { - if (!is_symbol (vars)) return (opt_oops); /* (define 1 2) */ +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_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)]);} - /* 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 (sc, 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= let_or_list; - 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, let_or_list, 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 (let_or_list)) && (car (let_or_list) != sc->if_keyword)) - set_cdr (let_or_list, - cons (sc, vars, cdr (let_or_list))); /* export it */ - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - } - 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)) let_or_list= cons (sc, sc->nil, let_or_list); - else if ((!is_pair (vars)) && (!is_symbol (vars))) return (opt_oops); - let_or_list= collect_parameters (sc, vars, let_or_list); - 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, let_or_list, - 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, let_or_list, - body_export_ok) == opt_oops)) - return (opt_oops); +/* g_type_of migrated to s7_scheme_predicate.c */ +#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) - if ((is_pair (cadr (expr))) && (caadr (expr) == sc->starlet_symbol)) { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_ok); - } - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - 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 = let_or_list; - 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_let_or_list, let_or_list); - 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, let_or_list, 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, let_or_list, false) == - opt_oops)) - return (opt_oops); - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - 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); - let_or_list= - cons (sc, sc->if_keyword, - let_or_list); /* 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, let_or_list, 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, let_or_list, 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_let_or_list, let_or_list); - 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), let_or_list, pair_symbol_is_safe)); - for (s7_pointer q= cdar (p); is_pair (q); q= cdr (q)) - set_fx_direct (q, fx_choose (sc, q, let_or_list, pair_symbol_is_safe)); - } - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - 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: - let_or_list= cons (sc, sc->if_keyword, let_or_list); - break; - - default: - break; - } +/* -------------------------------- 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); +} - sc->temp7= let_or_list; - 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, let_or_list, 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); - const s7_pointer b1 = cdr (test); - const s7_pointer b2 = cdr (b1); - s7_pointer p; - for (p= cdr (expr); is_pair (p); p= cdr (p)) - if (!is_fxable (sc, car (p))) { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - 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, let_or_list, pair_symbol_is_safe)); - - 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_let_or_list, let_or_list); - 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), let_or_list, - 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_let_or_list, let_or_list); - 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_let_or_list, let_or_list); - 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_let_or_list, let_or_list); - return (opt_ok); - } - else { - if ((op == OP_OR) || (op == OP_AND)) { - int32_t args= 0, pairs= 0; - bool c_s_is_ok= true; - { - s7_pointer p; - for (p= cdr (expr); is_pair (p); p= cdr (p)) - if (!is_fxable (sc, car (p))) { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); - } - if (!is_null (p)) return (opt_oops); - } - for (s7_pointer p1= cdr (expr), sym= NULL; 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; - } +#ifndef EXIT_SUCCESS + #define EXIT_SUCCESS 0 + #define EXIT_FAILURE 1 +#endif - 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_let_or_list, let_or_list); - return (opt_ok); - } +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) - for (s7_pointer p1= cdr (expr); is_pair (p1); p1= cdr (p1)) - set_fx_direct (p1, - fx_choose (sc, p1, let_or_list, 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_let_or_list, let_or_list); - 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_let_or_list, let_or_list); - return (opt_ok); - } - else if (op == OP_BEGIN) { - s7_pointer p; - if (!is_pair (cdr (expr))) { - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - 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_let_or_list, let_or_list); - 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, let_or_list, 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_let_or_list, let_or_list); - return (opt_ok); - } - } - } /* fully fxable lets don't happen much: even let-2a-a is scarcely used */ - cleanup_big_symbol_set (sc, init_let_or_list, let_or_list); - return (opt_bad); + 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 opt_t -optimize_funcs (s7_scheme* sc, s7_pointer expr, s7_pointer func, int32_t hop, - int32_t orig_hop, s7_pointer let_or_list) { - 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, let_or_list, 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, let_or_list)); - case 1: - return (optimize_func_one_arg (sc, expr, func, hop, pairs, symbols, - quotes, bad_pairs, let_or_list)); - case 2: - return (optimize_func_two_args (sc, expr, func, hop, pairs, symbols, - quotes, bad_pairs, let_or_list)); - case 3: - return (optimize_func_three_args (sc, expr, func, hop, pairs, symbols, - quotes, bad_pairs, let_or_list)); - default: - return (optimize_func_many_args (sc, expr, func, hop, args, pairs, - symbols, quotes, bad_pairs, - let_or_list)); +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 (opt_oops); /* was opt_bad, but this is always an error */ + return(gp); /* for s7_free */ } -static opt_t -optimize_expression (s7_scheme* sc, s7_pointer expr, int32_t hop, - s7_pointer let_or_list, 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, let_or_list: %s, hop: %d\n", __func__, - __LINE__, display_truncated (expr), display (let_or_list), 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, - let_or_list, export_ok)); - } - slot= find_uncomplicated_symbol ( - sc, head, let_or_list); /* 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, let_or_list, 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 */ +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) { - /* 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, let_or_list)); - } - } - else if ((sc->undefined_identifier_warnings) && - (slot == - sc->undefined) && /* head is not in let_or_list or global */ - (big_symbol_tag (head) == - 0)) /* and we haven't looked it up earlier */ + 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)))) { - 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 */ + 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); } - - /* head is a symbol but it's not a built-in procedure or a safe case = - * vector etc */ + if (hook_has_functions(sc->exit_hook)) { - /* 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, let_or_list, 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 ( - sc, - 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, let_or_list); /* 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 (sc, head)) && - (direct_memq (sc->quote_symbol, let_or_list))) - return (opt_oops); - if (is_fxable (sc, arg1)) { - set_opt3_arglen (args, 1); - fx_annotate_arg (sc, args, let_or_list); - 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, let_or_list); - 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, let_or_list, - export_ok)); - - if (is_c_function (head)) /* (#_abs x) etc */ - return (optimize_funcs ( - sc, expr, head, - /* (direct_memq(c_function_symbol(head), let_or_list)) ? 0 : */ 1, - orig_hop, let_or_list)); - - if (is_syntax (head)) /* (#_cond...) etc */ - { - if (!is_pair (args)) return (opt_oops); - return ( - optimize_syntax (sc, expr, head, orig_hop, let_or_list, 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, let_or_list, 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 - */ + s7_pointer exit_code; + if (is_null(args)) + exit_code = s7_make_integer(sc, EXIT_SUCCESS); + else + { + s7_pointer obj = car(args); + if (obj == sc->F) + exit_code = s7_make_integer(sc, EXIT_FAILURE); + else if ((obj == sc->T) || (!s7_is_integer(obj))) + exit_code = s7_make_integer(sc, EXIT_SUCCESS); + else + exit_code = obj; + } + s7_apply_function(sc, sc->exit_hook, set_plist_1(sc, exit_code)); + } + + 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 (opt_bad); +#if __TINYC__ + return(sc->F); /* never reached, but tcc complains */ +#endif } -static opt_t -optimize (s7_scheme* sc, s7_pointer code, int32_t hop, s7_pointer let_or_list) { - s7_pointer expr; - if (SHOW_EVAL_OPS) - fprintf (stderr, " %s[%d]: %s, let_or_list: %s, hop: %d\n", __func__, - __LINE__, display_truncated (code), display (let_or_list), 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, let_or_list, 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); - } +/* -------------------------------- 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 let, const char *func, s7_pointer expr, s7_pointer var) +{ + if (let_slots(let) != 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), + (is_not_slot_end(let_slots(let))) ? display(let_slots(let)) : "no slots", unbold_text); + if (sc->stop_at_error) abort(); + /* this usually signals a problem with enviroments (or arglists if optimize_lambda) */ } - 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 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 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* */ -{ - const s7_pointer top = args; - s7_pointer pars = args; - bool has_defaults= false; - - 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); - } +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)))); +} - begin_small_symbol_set (sc); - for (s7_pointer last_pars= args; is_pair (pars); - last_pars= 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 (last_pars, - sc->nil); /* last_pars is '( :allow-other-keys) so this - chops off the trailing keyword */ - } - 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)); +static void check_u_1(s7_scheme *sc, s7_pointer let, const char *func, s7_pointer expr, s7_pointer var) +{ + if (next_slot(let_slots(let)) != 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(let), + (is_not_slot_end(next_slot(let_slots(let)))) ? display(next_slot(let_slots(let))) : "no next slot", unbold_text); + if (sc->stop_at_error) abort(); } - } - 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; +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)))); } -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 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 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 */ +static void check_v_1(s7_scheme *sc, s7_pointer let, const char *func, s7_pointer expr, s7_pointer var) { - 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? - */ + if (next_slot(next_slot(let_slots(let))) != s7_t_slot(sc, var)) { - case OP_OR: - case OP_AND: - case OP_BEGIN: - case OP_WITH_BAFFLE: - return (body_is_safe (sc, func, cdr (form), at_end)); + fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, func, display(expr), display(var), display(let), + (is_not_slot_end(next_slot(next_slot(let_slots(let))))) ? display(next_slot(next_slot(let_slots(let)))) : "no next slot", unbold_text); + if (sc->stop_at_error) abort(); + } +} - case OP_MACROEXPAND: - return (unsafe_body); +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))))); +} - 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); +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)))))); +} - 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); +static void check_o_1(s7_scheme *sc, s7_pointer let, const char *func, s7_pointer expr, s7_pointer var) +{ + s7_pointer slot = s7_t_slot(sc, var); + if (lookup_slot_with_let(sc, var, let) != slot) + { + fprintf(stderr, "%s%s %s is out of date (%s in %s -> %s)%s\n", bold_text, func, display(expr), display(var), display(let), + (is_not_slot_end(slot)) ? display(slot) : "undefined", unbold_text); + if (sc->stop_at_error) abort(); } +} - 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); - } +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))); +} - 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) */ +#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 - 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 */ +#define s_lookup(Sc, Sym, Expr) lookup(Sc, Sym) +#define g_lookup(Sc, Sym, Expr) lookup_global(Sc, Sym) - 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 slow_vars= 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 (slow_vars != vars) { - if (follow) { - slow_vars= cdr (slow_vars); - if (vars == slow_vars) 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); +/* 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));} +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(sc, 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); + default: return(method_or_bust_pp(sc, val, sc->num_eq_symbol, val, cadr(args), a_number_string, 1)); } - } - else /* car(form) is not syntactic */ - { - if (expr == func) /* try to catch tail call, expr is car(form) */ - { - bool follow = false; - s7_pointer slow_form= 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); + return(sc->T); +} - if (follow) { - slow_form= cdr (slow_form); - if (p == slow_form) 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; +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))); +} - 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 */ +#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))); \ +} - f_slot= s7_slot (sc, expr); - if (!is_slot (f_slot)) return (unsafe_body); +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) - 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 slow_form= form, p= cdr (form); - for (; is_pair (p); p= cdr (p)) { - if (is_unquoted_pair (sc, 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); +#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)); \ + } - if (follow) { - slow_form= cdr (slow_form); - if (p == slow_form) return (unsafe_body); - } - follow= (!follow); - } - return ((is_null (p)) ? result : unsafe_body); - } - if ((is_safe_quote (sc, expr)) && (is_proper_list_1 (sc, cdr (form)))) - return (result); +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) - 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 */ +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))); +} - return (unsafe_body); /* not recur_body here if at_end -- possible defines - in body etc */ - } - return (result); + +static s7_pointer fx_random_i(s7_scheme *sc, s7_pointer arg) +{ + return(make_integer(sc, (s7_int)(integer(cadr(arg)) * next_random(sc->default_random_state)))); } -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 slow_body= 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) { - slow_body= cdr (slow_body); - if (forms == slow_body) return (unsafe_body); - } - follow= (!follow); - } - } - return ((is_null (forms)) ? result : unsafe_body); +static s7_pointer fx_random_i_wrapped(s7_scheme *sc, s7_pointer arg) +{ + return(wrap_integer(sc, (s7_int)(integer(cadr(arg)) * next_random(sc->default_random_state)))); } -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); - } +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! */ +} + +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));} +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 ((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) \ + { \ + const s7_pointer x = Lookup(sc, cadr(arg), arg); \ + if ((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 ((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 + */ - 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); - } - } +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) \ + { \ + const s7_pointer x = Lookup(sc, cadr(arg), arg); \ + if ((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) */ \ } - 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); - } - } - } +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) - 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); - } +#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) +{ + const s7_double n = real(cadr(arg)); + const 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))); + default: + return(method_or_bust_pp(sc, x, sc->subtract_symbol, cadr(arg), x, a_number_string, 2)); } - } /* if (is_fxable(sc, test)) at top */ - return (false); + return(x); } -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); - } +#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 */ \ } - 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; - /* following 9 lines are copied from check_recur_if 77378 - * (len=body length) -- combine? */ - 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); -} +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) -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); - } - } + +#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)))); \ } - return (false); + +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 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); - } +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))))); +} - 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); +#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))))); \ } - return (false); -} -/* tc lets can be let* or let+pars that don't refer to previous names, and there - * are more cond/if choices */ +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) -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); - } - } - } - } +#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))))); \ } - 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); - } - } - } +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) - 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); - } - } +#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))))); \ + } - 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); - } - } +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) - 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 var= letv; is_pair (var); var= cdr (var)) - if (!is_fxable (sc, cadar (var))) 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 var= letv; is_pair (var); var= cdr (var)) - fx_annotate_arg (sc, cdar (var), 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); - } - } - } - } +#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))))); \ } - /* 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)); +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) - /* 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 -- need 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 ((S7_DEBUGGING) && (s7_list_length (sc, body) == 0)) { - fprintf (stderr, "body: %s\n", display (body)); - abort (); - } - if (is_pair (car (body))) { - set_is_fx_treeable (body); - mark_fx_treeable (sc, car (body)); - } - mark_fx_treeable (sc, cdr (body)); +#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))))); \ } -} -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 (sc, 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 let) */ - 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; +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))))); \ } -} -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; +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) - 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); +#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))))); \ + } - body= cdr (code); - if (!is_pair (body)) /* (lambda #f) */ - syntax_error_nr (sc, "lambda: no body? ~A", 19, form); +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) - /* 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); +#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))))); \ } - 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); +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) - { - 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))) && (curlet_has_slots (sc))) - 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))) && (curlet_has_slots (sc))) - 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, ((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))) && (curlet_has_slots (sc))) - fx_curlet_tree_in (sc, code); - } - else - pair_set_syntax_op (form, ((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))) && (curlet_has_slots (sc))) - 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) || ((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))) && (curlet_has_slots (sc))) - 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); - } +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 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 s7_pointer fx_floor_sqrt_s(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p = lookup(sc, opt3_sym(arg)); + if (!negative_b_7p(sc, p)) + return(make_integer(sc, (s7_int)floor(sqrt(s7_number_to_real_with_location(sc, p, sc->sqrt_symbol))))); + return(floor_p_p(sc, sqrt_p_p(sc, p))); } -static inline s7_pointer -fx_case_a_i_s_a (s7_scheme* sc, - s7_pointer code) /* inline saves about 30 in tleft */ + +static s7_pointer fx_is_positive_u(s7_scheme *sc, s7_pointer arg) { - 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)))); + 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, positive_b_7p(sc, num))); } -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); +static s7_pointer fx_is_zero_u(s7_scheme *sc, s7_pointer arg) {return(make_boolean(sc, 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 x = Lookup(sc, cadr(arg), arg); \ + return((is_t_complex(x)) ? make_real(sc, real_part(x)) : real_part_p_p(sc, x)); \ } - 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); +fx_real_part_s_any(fx_real_part_s, s_lookup) +fx_real_part_s_any(fx_real_part_t, t_lookup) -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); +#define fx_imag_part_s_any(Name, Lookup) \ + static s7_pointer Name(s7_scheme *sc, s7_pointer arg) \ + { \ + s7_pointer x = Lookup(sc, cadr(arg), arg); \ + return((is_t_complex(x)) ? make_real(sc, imag_part(x)) : imag_part_p_p(sc, x)); \ } -ELSE_CASE_2: - if (is_null (cdr (sc->code))) { - sc->code = car (sc->code); - sc->cur_op= optimize_op (sc->code); - return (true); +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])); \ } - 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); +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 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 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 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 { - { - 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); +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))); -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; + 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 */ } - sc->code= opt3_any (cdr (sc->code)); + return(sc->F); } -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) */ +static s7_pointer fx_less_length_i(s7_scheme *sc, s7_pointer arg) { - 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)))); -} + const s7_int ilen = integer(opt3_con(arg)); /* caddr(arg) */ + const s7_pointer val = lookup(sc, opt3_sym(cdr(arg))); /* cadadr(arg) */ -/* -------------------------------- 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); - } -} + 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))));} +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);} +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(s7i_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(s7i_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(s7i_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(s7i_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(s7i_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(s7i_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))); -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); + 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)); } - 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); - } + 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)); } - } - 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 "let" = 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, sc->args); - sc->args= sc->nil; - } - return (code); + return(x); } -static s7_pointer -check_let (s7_scheme* sc) /* called only from op_let */ +static s7_pointer fx_sqr_wrapped(s7_scheme *sc, s7_pointer x) { - s7_pointer start; - const s7_pointer code= cdr (sc->code), form= sc->code; - bool named_let; + if (is_t_real(x)) return(wrap_real(sc, real(x) * real(x))); + 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)); +} - 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); - } +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)));} - 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); +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) */ +} - begin_small_symbol_set (sc); - { - s7_pointer vars; - int32_t num_vars; - 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 (sc, 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? */ +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 */ +} - 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)); - } - } - } - } - } +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)); +} - /* 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); - } - } +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)); +} - /* fx_tree inits */ - if ((is_pair (code)) && - (is_fx_treeable (code)) && /* was is_funclet(sc->curlet) 27-Sep-21, but - that seems too restrictive */ - (curlet_has_slots (sc))) { - s7_pointer slot1= let_slots (sc->curlet), slot2= next_slot (slot1), - slot3= NULL; - bool more_vars = false; - if (is_not_slot_end (slot2)) { - if (is_not_slot_end (next_slot (slot2))) { - slot3 = next_slot (slot2); - more_vars= is_not_slot_end (next_slot (slot3)); - slot3 = slot_symbol (slot3); - } - slot2= slot_symbol (slot2); - } - slot1= slot_symbol (slot1); - for (s7_pointer p= car (code); is_pair (p); p= cdr (p)) /* var list */ - { - s7_pointer init= cdar (p); - fx_tree (sc, init, slot1, slot2, slot3, 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), - car_unchecked (args)); - vars= cdr (vars); - args= cdr (args); - if (is_null (args)) break; - add_slot_checked_with_id (sc, sc->curlet, car (vars), car_unchecked (args)); +#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) */ \ } - 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), car_unchecked (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), - car_unchecked (vals)); /* not unchecked -- tlimit.scm */ - } + +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) */ \ } - 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 */ +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 */ { - /* 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; + const s7_pointer x1 = lookup_global(sc, cadr(arg)); + const s7_pointer x2 = lookup(sc, opt1_sym(cdr(arg))); /* caddr(arg) */ + const s7_pointer x3 = lookup_global(sc, opt2_sym(cdr(arg))); /* cadddr(arg) */ + if ((is_t_integer(x1)) && (is_t_integer(x2)) && (is_t_integer(x3))) + return(make_boolean(sc, ((integer(x1) < integer(x2)) && (integer(x2) < integer(x3))))); + if (!is_real(x3)) + wrong_type_error_nr(sc, sc->lt_symbol, 3, x3, sc->type_names[T_REAL]); /* else (< 2 1 1+i) returns #f */ + return(make_boolean(sc, (lt_b_7pp(sc, x1, x2)) && (lt_b_7pp(sc, x2, x3)))); +} + +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) */ +} - 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 */ +#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) */ \ } - sc->code= cdr (code); - return (op_let_1 (sc)); /* sc->args preset with code */ + +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 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 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 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 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 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 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) */ } -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); +#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) */ \ } - 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 () */ -} +fx_geq_si_any(fx_geq_si, s_lookup) +fx_geq_si_any(fx_geq_ti, t_lookup) -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 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))); } -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)); -} +#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))); \ + } -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); -} +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) -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)); -} +#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 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 */ +static s7_pointer fx_not_is_eq_ss(s7_scheme *sc, s7_pointer arg) { - 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))))); + 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 Inline void -inline_op_let_a_old (s7_scheme* sc) /* tset(2) fb(0) cb(4) left(2) */ +static s7_pointer fx_not_is_eq_sq(s7_scheme *sc, s7_pointer arg) { - 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); + 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 inline void -op_let_a_old (s7_scheme* sc) { - inline_op_let_a_old (sc); +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 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 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 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) */ +static s7_pointer fx_hash_table_ref_car(s7_scheme *sc, s7_pointer arg) { - inline_op_let_a_old (sc); - sc->value= fx_call (sc, cdr (sc->code)); + 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 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 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 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 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 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 */ +static s7_pointer fx_cdr_let_ref_s(s7_scheme *sc, s7_pointer arg) { - s7_pointer let; - 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), last_slot= NULL; is_pair (p); - p= cdr (p)) { - const s7_pointer arg= cdar (p); - sc->value = fx_call (sc, arg); - if (!last_slot) { - add_slot (sc, let, caar (p), sc->value); - last_slot= let_slots (let); - } - else - last_slot= - add_slot_at_end (sc, let_id (let), last_slot, 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)); - const s7_int id = ++sc->let_number; - sc->args = let; /* GC protection */ - let_set_id (let, id); - let_set_outlet (let, sc->curlet); - for (s7_pointer p= cadr (sc->code), slot= let_slots (let); is_pair (p); - p= cdr (p), slot= next_slot (slot)) { - 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) */ - check_stack_size (sc); /* added 15-Jul-25 for srfi-1 filter of huge list */ - 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); + s7_pointer sym; + s7_pointer let = s_lookup(sc, opt2_sym(arg), arg); /* (var-ref local-var) -> local-var, opt_sym2(arg) == cadr(arg) */ + if (!is_pair(let)) + 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), let)); + let = cdr(let); + if (!is_let(let)) wrong_type_error_nr(sc, sc->let_ref_symbol, 1, let, 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(let); is_not_slot_end(slot); slot = next_slot(slot)) + if (slot_symbol(slot) == sym) + return(slot_value(slot)); + return(let_ref_p_pp(sc, let_outlet(let), 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); } -/* -------------------------------- 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) ... */ - { - /* does (let* loop ((i 0) :allow-other-keys) i) make sense? - * - * (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 last_slot = NULL; - while (true) { - if (let_counter == sc->capture_let_counter) { - if (last_slot == NULL) { - add_slot_checked (sc, sc->curlet, caar (sc->code), sc->value); - last_slot= let_slots (sc->curlet); - } - else - last_slot= add_slot_checked_at_end (sc, let_id (sc->curlet), last_slot, - caar (sc->code), - sc->value); /* was unchecked */ - } - else { - set_curlet (sc, inline_make_let_with_slot (sc, sc->curlet, - caar (sc->code), sc->value)); - last_slot = let_slots (sc->curlet); - let_counter= sc->capture_let_counter; - } - 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_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_uint let_counter= S7_INT64_MAX; - sc->code = cdr (sc->code); - for (s7_pointer last_slot= NULL, 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 (!last_slot) { - add_slot_checked (sc, sc->curlet, car (binding), val); - last_slot= let_slots (sc->curlet); - } - else - last_slot= add_slot_at_end (sc, let_id (sc->curlet), last_slot, - car (binding), val); - } - else { - set_curlet ( - sc, inline_make_let_with_slot (sc, sc->curlet, car (binding), val)); - last_slot = 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_uint let_counter= S7_INT64_MAX; - sc->code = cdr (sc->code); - for (s7_pointer last_slot= NULL, 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 (!last_slot) { - add_slot_checked (sc, sc->curlet, car (binding), val); - last_slot= let_slots (sc->curlet); - } - else - last_slot= add_slot_at_end (sc, let_id (sc->curlet), last_slot, - car (binding), val); - } - else { - set_curlet ( - sc, inline_make_let_with_slot (sc, sc->curlet, car (binding), val)); - last_slot = let_slots (sc->curlet); - let_counter= sc->capture_let_counter; - } +static s7_pointer fx_c_cq(s7_scheme *sc, s7_pointer arg) {return(fn_proc(arg)(sc, with_list_t2(sc, 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)); \ } - 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); -} +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 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) */ - 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); is_not_slot_end (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); is_not_slot_end (slot); - slot = next_slot (slot)) - if (is_checked_slot (slot)) - slot_set_value (slot, slot_pending_value (slot)); - letrec_setup_closures (sc); +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 bool -op_letrec_unchecked (s7_scheme* sc) { - const 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); - is_not_slot_end (slot) && (has_fx (slot_expression (slot))); - slot= next_slot (slot)) - slot_set_pending_value (slot, fx_call (sc, slot_expression (slot))); - if (is_not_slot_end (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 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 bool -op_letrec1 (s7_scheme* sc) { - s7_pointer slot; - slot_set_pending_value (sc->args, sc->value); - for (slot= next_slot (sc->args); - is_not_slot_end (slot) && (has_fx (slot_expression (slot))); - slot= next_slot (slot)) - slot_set_pending_value (slot, fx_call (sc, slot_expression (slot))); - if (is_not_slot_end (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 s7_pointer fx_vset_sts(s7_scheme *sc, s7_pointer arg) +{ + return(vector_set_p_ppp(sc, lookup(sc, cadr(arg)), t_lookup(sc, opt1_sym(cdr(arg)), arg), lookup(sc, opt2_sym(cdr(arg))))); } -static 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); - is_not_slot_end (slot) && (has_fx (slot_expression (slot))); - slot= next_slot (slot)) - slot_set_value (slot, fx_call (sc, slot_expression (slot))); - if (is_not_slot_end (slot)) { - push_stack (sc, OP_LETREC_STAR1, slot, code); - sc->code= car (slot_expression (slot)); - return (true); - } +#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)); \ } - 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); - is_not_slot_end (slot) && (has_fx (slot_expression (slot))); - slot= next_slot (slot)) - slot_set_value (slot, fx_call (sc, slot_expression (slot))); - if (is_not_slot_end (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 (sc, 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 (sc, 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)) && (curlet_has_slots (sc))) { - 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); - } - } - } - } -} +fx_c_scs_any(fx_c_scs, s_lookup, s_lookup) +fx_c_scs_any(fx_c_tcs, t_lookup, s_lookup) -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); -} - -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); - /* fprintf(stderr, "args: %s\n", display(sc->args)); */ - sc->value= caar (p); - set_car (p, cdar (p)); - set_car (sc->args, cdar (sc->args)); - /* fprintf(stderr, " args: %s\n", display(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 (sc, 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); - /* fprintf(stderr, "sym: %s, val: %s, args: %s\n", display(sym), - * display(sc->value), display(sc->args)); */ - } - 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); - } +#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))); \ } - 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)); -} +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 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 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)); } -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); -} - -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; +#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)); \ } - else slot_set_value (slot, new_value); -} -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)); -} +fx_c_css_any(fx_c_css, s_lookup, s_lookup) +fx_c_css_any(fx_c_ctv, t_lookup, v_lookup) -static bool -op_let_temp_na ( - s7_scheme* sc) /* all entries are of the form (symbol fx-able-value) */ +static s7_pointer fx_c_csc(s7_scheme *sc, s7_pointer arg) { - 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 */ + 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 bool -op_let_temp_a (s7_scheme* sc) /* one entry */ +static s7_pointer fx_c_ccs(s7_scheme *sc, s7_pointer arg) { - s7_pointer var, settee, 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); - { - s7_pointer 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 */ + 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)); } -static s7_pointer -fx_let_temp_a_a (s7_scheme* sc, s7_pointer code) /* one entry, body is fx'd */ +#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) { - 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; - const s7_pointer let= 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, let); - 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)); + return(fn_proc(arg)(sc, with_list_t1(sc, fn_call(sc, cadr(arg))))); } -/* -------------------------------- 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); +#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(sc, Lookup(sc, cadr(arg1), arg1)))); \ + return(fn_proc(arg)(sc, sc->t1_1)); \ } - 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)); + +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)))); } -/* -------------------------------- 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); +#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)); \ } - 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)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, code); - set_current_code (sc, sc->code); - return (false); -} +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) -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); +#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)); \ } - 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); +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)))); \ } - sc->code= caddr (sc->code); - return (false); -} -static void -op_and_safe_p1 (s7_scheme* sc) /* sc->code: (and (func...) (fx...)...) */ +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) { - 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); + 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 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 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 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); +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)))); } -/* -------------------------------- 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); +#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); \ } - 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); +fx_not_opsq_any(fx_not_opsq, s_lookup) +fx_not_opsq_any(fx_not_optq, t_lookup) - if ((is_fx_treeable (code)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, code); - set_current_code (sc, sc->code); - return (false); +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); } -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); +#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(sc, fn_proc(cadr(arg))(sc, sc->t2_1)))); \ } - 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)) +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) -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); +#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)))); \ } - 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)) && (curlet_has_slots (sc))) - 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)) && (curlet_has_slots (sc))) - 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)) && (curlet_has_slots (sc))) - 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)) && (curlet_has_slots (sc))) - 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 (sc, 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)) && (curlet_has_slots (sc))) - 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)) && (curlet_has_slots (sc))) - 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)) && (curlet_has_slots (sc))) - fx_curlet_tree (sc, code); - set_opt1_pair (form, cdr (code)); - set_opt2_any (form, caddr (code)); - } - } - } -} +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) -/* (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); +#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); \ + } - 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); +fx_not_opssq_any(fx_not_opssq, s_lookup, s_lookup) +fx_not_opssq_any(fx_not_oputq, u_lookup, t_lookup) - 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 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 void -op_if_unchecked (s7_scheme* sc) { - push_stack_no_args (sc, OP_IF1, cddr (sc->code)); - sc->code= cadr (sc->code); +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, zero_b_7p(sc, remainder_p_pp(sc, u, t)))); } -static bool -op_if1 (s7_scheme* sc) { - sc->code= (is_true (sc, sc->value)) ? T_Pos (car (sc->code)) - : T_Pos (car_unchecked (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); +static s7_pointer fx_is_zero_remainder_o(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer x = o_lookup(sc, opt3_sym(arg), arg); + s7_pointer y = s_lookup(sc, opt1_sym(cdr(arg)), arg); + if ((is_t_integer(x)) && (is_t_integer(y))) + return(make_boolean(sc, remainder_i_7ii(sc, integer(x), integer(y)) == 0)); + return(make_boolean(sc, zero_b_7p(sc, remainder_p_pp(sc, x, y)))); } -/* -------------------------------- 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 (sc, 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); +#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(sc, fn_proc(arg1)(sc, sc->t2_1)))); \ } - 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); -} +fx_c_opscq_any(fx_c_opscq, s_lookup) +fx_c_opscq_any(fx_c_optcq, t_lookup) -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); +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, zero_b_7p(sc, remainder_p_pi(sc, t, u)))); } -/* -------------------------------- 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 (sc, 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 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 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 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(sc, fn_proc(arg1)(sc, sc->t2_1)))); } -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 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 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); +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)); } -/* -------------------------------- 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); +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)); } -/* -------------------------------- 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 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 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 or a non-nil list", - 65, 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) */ +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 { - 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 (sc, 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))); + 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 { - 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 or a non-nil list)", - 62, 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 ( - sc, 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); +#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 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 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)))); } -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_unchecked (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 (is_not_slot_end (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); +#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)); \ } - 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); +fx_add_sqr_s_any(fx_add_sqr_s, s_lookup) +fx_add_sqr_s_any(fx_add_sqr_T, T_lookup) - 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 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 inline void -define_funchecked (s7_scheme* sc) { - const s7_pointer code = cdr (sc->code); - const s7_pointer func_name= caar (code); - s7_pointer new_func; - - 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* */ +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)); +} - if (let_id (sc->curlet) < symbol_id (func_name)) - sc->let_number++; /* dummy let, force symbol lookup */ +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)); +} - /* see if func_name exists in curlet, reset its value if so */ - for (s7_pointer slot= let_slots (sc->curlet); is_not_slot_end (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)); +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)); +} - return (sc->code); +static s7_pointer fx_gt_vref_s(s7_scheme *sc, s7_pointer arg) +{ + return(gt_p_pp(sc, s7i_vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))), lookup(sc, caddr(arg)))); } -static void -op_macro (s7_scheme* sc) /* (macro (x) `(+ ,x 1)) */ +static s7_pointer fx_geq_s_vref(s7_scheme *sc, s7_pointer arg) { - 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); - } + return(geq_p_pp(sc, lookup(sc, cadr(arg)), s7i_vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))))); } -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 (sc, 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); +static s7_pointer fx_is_eq_s_vref(s7_scheme *sc, s7_pointer arg) +{ + return(make_boolean(sc, lookup(sc, cadr(arg)) == s7i_vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))))); +} - 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)? */ - } - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - return (fall_through); /* for the compiler */ +static s7_pointer fx_href_s_vref(s7_scheme *sc, s7_pointer arg) +{ + return(hash_table_ref_p_pp(sc, lookup(sc, cadr(arg)), s7i_vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))))); } -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 s7_pointer fx_lref_s_vref(s7_scheme *sc, s7_pointer arg) /* tbig */ +{ + return(let_ref(sc, lookup(sc, cadr(arg)), s7i_vector_ref_p_pp(sc, lookup(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))))); } -static goto_t -op_macroexpand_1 (s7_scheme* sc) { - sc->args= cdar (sc->code); - sc->code= sc->value; - return (macroexpand (sc)); +static s7_pointer fx_vref_s_add(s7_scheme *sc, s7_pointer arg) +{ + return(s7i_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 void -op_eval_macro (s7_scheme* sc) /* after (scheme-side) macroexpansion, evaluate - the resulting expression */ +static inline s7_pointer fx_vref_vref_3(s7_scheme *sc, s7_pointer vec, s7_pointer num1, s7_pointer num2) { - /* (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; + if ((is_t_integer(num1)) && (is_t_integer(num2)) && ((is_t_vector(vec)) && (vector_rank(vec) == 1))) + { + const s7_int index1 = integer(num1), index2 = integer(num2); + if ((index1 >= 0) && (index2 >= 0) && (index1 < vector_length(vec))) + { + s7_pointer vec_in_vec = vector_element(vec, index1); + if ((is_t_vector(vec_in_vec)) && (vector_rank(vec_in_vec) == 1) && (index2 < vector_length(vec_in_vec))) + return(vector_element(vec_in_vec, index2)); + }} + return(s7i_vector_ref_p_pp(sc, s7i_vector_ref_p_pp(sc, vec, num1), num2)); } -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); +#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))); \ } - push_stack (sc, OP_EVAL_MACRO_MV, cons (sc, sc->value, sc->args), - cdr (sc->code)); - sc->code= car (sc->code); - return (false); + +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 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); +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)); } -/* -------------------------------- with-let -------------------------------- */ -static s7_pointer -fx_with_let_s (s7_scheme* sc, s7_pointer arg) { - const s7_pointer code= cdr (arg); - s7_pointer let = lookup_checked (sc, car (code)); - const s7_pointer sym = cadr (code); - s7_pointer val; - if (!is_let (let)) { - let= find_let (sc, let); - 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->with_let_symbol, let, new_let, 1, - set_mlist_1 (sc, let)); - let= new_let; - } +#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)); \ } - /* let 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 (env 'value) sym) -> (env 'value) is a hash-table, so - * returns #f (missing-key-value?) if not in table we go directly to this - * function in check_with_let to avoid this ambiguity - */ - val= let_ref (sc, let, - sym); /* (with-let env s) -> (let-ref env 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, let))) /* check for explicit # value! */ - return (sc->undefined); - unbound_variable_error_nr (sc, sym); - } - return (val); + +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)))); } -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); +#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(sc, 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)); \ } - 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); + +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))); \ } - 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_let= - 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_let, 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_let, car (field), cdr (field)); + +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))); \ } - set_curlet (sc, new_let); - set_immutable_let (new_let); - unstack_gc_protect (sc); + +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))); } -static void -activate_with_let (s7_scheme* sc, s7_pointer let) { - if (!is_let (let)) /* (with-let . "hi") */ - { - const s7_pointer new_let= - find_let (sc, let); /* sc->nil/rootlet here means no let found */ - if (!is_let (new_let)) - 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), - let)); - let= new_let; +#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(sc, 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)); \ } - if (let == sc->rootlet) set_curlet (sc, let); /* (with-let (rootlet) ...) */ - else if (let == sc->starlet) activate_starlet (sc); - else { - set_with_let_let (let); - let_set_id (let, ++sc->let_number); - set_curlet (sc, let); - update_symbol_ids (sc, let); + +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(sc, 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)))); } -/* -------------------------------- 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)) && (curlet_has_slots (sc))) - 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 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 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 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 bool -op_cond_simple (s7_scheme* sc) /* no => */ +static s7_pointer fx_memq_car_s_2(s7_scheme *sc, s7_pointer arg) { - 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); + 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 bool -op_cond_simple_o (s7_scheme* sc) /* no =>, no null or multiform consequent */ +static s7_pointer fx_c_s_opssq(s7_scheme *sc, s7_pointer arg) { - 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); - } - } - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - 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); - } - } + s7_pointer arg2 = caddr(arg); + set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t2(sc, 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)); } -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); - } +#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)))); \ } -} -static bool -op_cond_na_np (s7_scheme* sc) /* all tests are fxable, results may be a mixture, - no =>, no missing results */ +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) { - for (s7_pointer p= cdr (sc->code); is_pair (p); p= cdr (p)) - if (is_true (sc, fx_call (sc, car (p)))) { - for (s7_pointer p1= T_Lst (cdar (p)); is_pair (p1); p1= cdr (p1)) - if (has_fx (T_Pair (p1))) sc->value= fx_call (sc, p1); - else { - if (is_pair (cdr (p1))) - push_stack_no_args (sc, OP_COND_NA_NP_1, cdr (p1)); - sc->code= car (p1); - return (false); - } - return (true); - } - sc->value= sc->unspecified; - return (true); + return(s7i_vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), + s7i_vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), lookup(sc, opt1_sym(opt3_pair(arg)))))); } -static bool -op_cond_na_np_1 (s7_scheme* sc) /* continuing to handle a multi-statement result - from cond_na_np */ +static s7_pointer fx_vref_g_vref_gt(s7_scheme *sc, s7_pointer arg) { - 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); + return(s7i_vector_ref_p_pp(sc, lookup_global(sc, cadr(arg)), + s7i_vector_ref_p_pp(sc, lookup_global(sc, car(opt3_pair(arg))), t_lookup(sc, opt1_sym(opt3_pair(arg)), arg)))); } -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 args= cdr (sc->code); is_pair (args); args= cdr (args)) - if (is_true (sc, fx_call (sc, car (args)))) { - s7_pointer p1= cdar (args); - if (has_fx (T_Pair (p1))) { - sc->value= fx_call (sc, p1); - return (true); - } - sc->code= car (p1); - return (false); - } - sc->value= sc->unspecified; - return (true); +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(sc, 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 inline bool -fx_cond_value (s7_scheme* sc, s7_pointer args) { - if (has_fx (args)) { - sc->value= fx_call (sc, args); - return (true); - } - sc->code= car (args); - return (false); +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 bool -op_cond_na_2e (s7_scheme* sc) { - s7_pointer args= cdr (sc->code); - return (fx_cond_value (sc, (is_true (sc, fx_call (sc, car (args)))) - ? cdar (args) - : cdadr (args))); +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 bool -op_cond_na_3e (s7_scheme* sc) { - s7_pointer args= cdr (sc->code); - if (is_true (sc, fx_call (sc, car (args)))) - return (fx_cond_value (sc, cdar (args))); - args= cdr (args); - return (fx_cond_value (sc, (is_true (sc, fx_call (sc, car (args)))) - ? cdar (args) - : cdadr (args))); +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))); } -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); +#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)); \ } - return (false); + +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 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 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 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 */ +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 ind = lookup(sc, opt3_sym(arg)); + s7_pointer vec = lookup(sc, cadr(arg)); + if ((is_t_integer(ind)) && (is_t_vector(vec)) && (vector_rank(vec) == 1)) + { + s7_int index = integer(ind) + 1; + if ((index >= 0) && (vector_length(vec) > index)) + return(vector_element(vec, index)); } - } - 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 */ + return(s7i_vector_ref_p_pp(sc, vec, g_add_xi(sc, ind, 1, 2))); } -/* -------------------------------- 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); +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))))))); +} - 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) */ +#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))))); \ } - 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); + +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(sc, 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 */ \ } - 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 (sc, 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; + +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)); \ } - 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 (sc, 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 (sc, cadr (value))) && - (car (value) == sc->cons_symbol)) { - pair_set_syntax_op (form, OP_SET_CONS); - set_opt2_sym (code, cadr (value)); - } - } - } - } - } + +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 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 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(sc, lookup(sc, cadr(args))))); + set_car(sc->t2_1, lookup(sc, cadr(outer))); + return(fn_proc(arg)(sc, with_list_t1(sc, fn_proc(outer)(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 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(sc, 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 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 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(sc, lookup(sc, cadr(args))))); + set_car(sc->t2_2, lookup(sc, caddr(outer))); + return(fn_proc(arg)(sc, with_list_t1(sc, fn_proc(outer)(sc, sc->t2_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 (sc, 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 (sc, obj, arg, value)); - break; - - case T_FLOAT_VECTOR: - sc->value= g_fv_set_3 (sc, with_list_t3 (sc, 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 (sc, obj, arg, value)); - break; - case T_BYTE_VECTOR: - sc->value= g_bv_set_3 (sc, with_list_t3 (sc, obj, arg, value)); - break; - case T_VECTOR: - if (vector_rank (obj) > 1) - sc->value= g_vector_set (sc, with_list_t3 (sc, obj, arg, value)); - else { - s7_int index; - if (!is_t_integer (arg)) - error_nr (sc, sc->type_error_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); - } - break; - - case T_STRING: { - 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; - } break; - - case T_PAIR: - sc->value= g_list_set (sc, with_list_t3 (sc, 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 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(sc, 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 bool -op_set_opsq_a (s7_scheme* sc) /* (set! (symbol) fxable) */ +static s7_pointer fx_c_c_opsq(s7_scheme *sc, s7_pointer arg) { - s7_pointer setf, value; - const s7_pointer code= cdr (sc->code), obj= lookup_checked (sc, caar (code)); + s7_pointer arg2 = opt3_pair(arg); /* caddr(arg) */ + set_car(sc->t2_2, fn_proc(arg2)(sc, with_list_t1(sc, lookup(sc, cadr(arg2))))); + set_car(sc->t2_1, cadr(arg)); + return(fn_proc(arg)(sc, sc->t2_1)); +} - 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)); +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)))))); +} - 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 (sc, value)); - return (false); - } - sc->code= setf; - sc->args= list_1 (sc, value); - return (true); +/* 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(sc, lookup(sc, cadar(argp))))); + argp = cadr(argp); + set_car(sc->t2_2, fn_proc(argp)(sc, with_list_t1(sc, 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 bool -op_set_opsaq_a (s7_scheme* sc) /* (set! (symbol fxable) fxable) */ +static s7_pointer fx_c_opsq_opsq_direct(s7_scheme *sc, s7_pointer arg) { - 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 (if false, continue) */ - } - } - 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. - */ + 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 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 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))); } -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 (sc, 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 (sc, 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 (sc, obj, index1)); - return (set_pair3 (sc, sc->value, index2, value)); - } - break; - - case T_PAIR: - sc->value= g_list_ref (sc, with_list_t2 (sc, 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 */ +#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)))); \ } - return (false); /* goto start */ + +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 bool -op_set_opsaaq_a (s7_scheme* sc) /* (set! (symbol fxable fxable) fxable) */ +static s7_pointer fx_is_eq_car_car_tu(s7_scheme *sc, s7_pointer arg) { - s7_pointer index1, 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); - } - } - value= fx_call (sc, cdr (code)); - gc_protect_via_stack (sc, value); - index1= fx_call (sc, cdar (code)); - set_gc_protected2 (sc, index1); - { - bool 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); - } + 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 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 arg1, settee; - const s7_pointer val= sc->value; - /* from the T_SYNTAX branch of op_set_pair: (set! (with-let arg1 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 'arg1 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)); - - arg1 = 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), - arg1, settee, val)); - if (is_symbol (arg1)) { - if (is_symbol (settee)) { - s7_pointer let= lookup_checked (sc, arg1); - if (!is_let (let)) - wrong_type_error_nr (sc, sc->let_set_symbol, 1, let, a_let_string); - sc->value= let_set_1 (sc, let, settee, val); - pop_stack (sc); - return (true); - } - sc->value= lookup_checked (sc, arg1); - 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= arg1; /* 'arg1 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 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(sc, 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 bool -op_set_with_let_2 (s7_scheme* sc) { - s7_pointer settee, val; - /* here sc->value = let, 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 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 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 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 Inline void -inline_op_increment_by_1 ( - s7_scheme* sc) /* ([set!] ctr (+ ctr 1)) -- why is this always inlined? - saves 22 in concordance */ +static s7_pointer fx_c_opssq_opsq(s7_scheme *sc, s7_pointer arg) { - 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); + 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(sc, 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) /* (- (* x1 x2) (* x3 x4)) */ +{ + s7_pointer p1 = opt3_pair(arg); /* cdaddr(arg) */ + s7_pointer x1 = lookup(sc, car(p1)); + s7_pointer x2 = lookup(sc, cadr(p1)); + s7_pointer p2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ /* here and elsewhere this should be GC safe -- opssq->* (no methods?) etc */ + s7_pointer x3 = lookup(sc, car(p2)); + s7_pointer x4 = lookup(sc, cadr(p2)); + if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3)) && (is_t_real(x4))) + return(make_real(sc, (real(x3) * real(x4)) - (real(x1) * real(x2)))); + sc->temp5 = multiply_p_pp_wrapped(sc, x1, x2); + return(subtract_p_pp(sc, multiply_p_pp_wrapped(sc, x3, x4), sc->temp5)); +} + +static s7_pointer fx_add_mul_mul(s7_scheme *sc, s7_pointer arg) /* (+ (* x1 x2) (* x3 x4)) */ +{ + s7_pointer p1 = opt3_pair(arg); /* cdaddr(arg) */ + s7_pointer x1 = lookup(sc, car(p1)); + s7_pointer x2 = lookup(sc, cadr(p1)); + s7_pointer p2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ + s7_pointer x3 = lookup(sc, car(p2)); + s7_pointer x4 = lookup(sc, cadr(p2)); + if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3)) && (is_t_real(x4))) + return(make_real(sc, (real(x3) * real(x4)) + (real(x1) * real(x2)))); + sc->temp5 = multiply_p_pp_wrapped(sc, x1, x2); + return(add_p_pp(sc, multiply_p_pp_wrapped(sc, x3, x4), sc->temp5)); +} + +static s7_pointer fx_mul_sub_sub(s7_scheme *sc, s7_pointer arg) /* (* (- x1 x2) (- x3 x4)) */ +{ + s7_pointer p1 = opt3_pair(arg); /* cdaddr(arg) */ + s7_pointer x1 = lookup(sc, car(p1)); + s7_pointer x2 = lookup(sc, cadr(p1)); + s7_pointer p2 = opt1_pair(cdr(arg)); /* cdadr(arg) */ + s7_pointer x3 = lookup(sc, car(p2)); + s7_pointer x4 = lookup(sc, cadr(p2)); + if ((is_t_real(x1)) && (is_t_real(x2)) && (is_t_real(x3)) && (is_t_real(x4))) + return(make_real(sc, (real(x3) - real(x4)) * (real(x1) - real(x2)))); + sc->temp5 = subtract_p_pp_wrapped(sc, x1, x2); + return(multiply_p_pp(sc, subtract_p_pp_wrapped(sc, x3, x4), sc->temp5)); +} + +static s7_pointer fx_lt_sub2(s7_scheme *sc, s7_pointer arg) +{ + s7_pointer p1 = opt3_pair(arg); /* cdaddr(arg) */ + sc->temp5 = subtract_p_pp_wrapped(sc, lookup(sc, car(p1)), lookup(sc, cadr(p1))); + p1 = opt1_pair(cdr(arg)); /* cdadr(arg) */ + return(lt_p_pp(sc, subtract_p_pp_wrapped(sc, lookup(sc, car(p1)), lookup(sc, cadr(p1))), sc->temp5)); } -static void -op_decrement_by_1 (s7_scheme* sc) /* ([set!] ctr (- ctr 1)) */ +static s7_pointer fx_sub_vref2(s7_scheme *sc, s7_pointer arg) { - 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; + 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))); } - slot_set_value (slot, sc->value); + return(subtract_p_pp(sc, s7i_vector_ref_p_pp(sc, vec, num1), s7i_vector_ref_p_pp(sc, vec, num2))); } -/* ---------------- 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= s7i_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 (s7i_vector_ref_1 (sc, vec, set_plist_1 (sc, ind))); +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(sc, 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 bool -op_implicit_vector_ref_aa ( - s7_scheme* sc) /* tnum/tmat, neither uses fx case if available (see tmp) */ +static s7_pointer fx_not_op_opsqq(s7_scheme *sc, s7_pointer code) { - 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= s7i_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->type_error_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 (sc, 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->type_error_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 */ + set_car(sc->t1_1, fn_proc(opt3_pair(code))(sc, with_list_t1(sc, lookup(sc, opt3_sym(cdr(code)))))); + return((fn_proc(cadr(code))(sc, sc->t1_1) == sc->F) ? sc->T : sc->F); +} - if ((!is_pair (inds)) || (!is_null (cdr (inds)))) { - push_op_stack (sc, sc->c_object_set_function); - if (is_null (inds)) { - push_stack_no_code (sc, OP_EVAL_ARGS1, list_1 (sc, c_obj)); - 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 (sc, 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 str= lookup_checked (sc, car (sc->code)); - const s7_pointer val= fx_call (sc, cdr (sc->code)); - if (!is_string (str)) { - sc->last_function= str; - return (false); - } - if (!s7_is_integer (val)) { - sc->value= string_ref_1 (sc, str, set_plist_1 (sc, val)); - return (true); - } - index= s7_integer_clamped_if_gmp (sc, val); - if ((index < string_length (str)) && (index >= 0)) { - sc->value= chars[((uint8_t*) string_value (str))[index]]; - return (true); - } - sc->value= string_ref_1 (sc, str, val); - return (true); +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 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; +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 */ +s7_pointer fx_c_a(s7_scheme *sc, s7_pointer arg) {return(fn_proc(arg)(sc, with_list_t1(sc, 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);} - 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 (sc, 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 (sc, 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 (sc, 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_no_code (sc, OP_EVAL_ARGS1, 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 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); } -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)); +#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));\ } - return (goto_top_no_pop); + +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 goto_t -set_implicit (s7_scheme* sc) /* sc->code incoming is (set! (...) ...) */ +static s7_pointer fx_c_ass(s7_scheme *sc, s7_pointer arg) { - 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)); + 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)); } -/* -------------------------------- 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 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 bool -tree_match (s7_pointer tree) { - if (is_symbol (tree)) return (is_matched_symbol (tree)); - return ((is_pair (tree)) && - ((tree_match (car (tree))) || (tree_match (cdr (tree))))); +static 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)); } -#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 +static s7_pointer fx_c_sca(s7_scheme *sc, s7_pointer arg) { - /* 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)) { - 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)) - do_return_false (expr); - if (is_pair (cddar (step))) - return (all_ints_here (sc, caar (step), caddar (step), step_vars)); - return (true); - } - { - s7_pointer 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)) 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)) do_return_false (expr); + 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)); +} - 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); +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)); } -#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 s7_pointer fx_c_csa(s7_scheme *sc, s7_pointer arg) { - /* 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 (sc, 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 var) { - if ((is_proper_list_3 (sc, var)) && (is_fxable (sc, cadr (var)))) { - const s7_pointer step_expr= caddr (var); - if ((is_optimized (step_expr)) && - (((optimize_op (step_expr) == HOP_SAFE_C_SC) && - (car (var) == cadr (step_expr))) || - ((is_h_safe_c_nc (step_expr)) && /* replace with is_fxable? */ - (is_pair (cdr (step_expr))) && /* ((v 0 (+))) */ - (car (var) == 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 (var) == 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); - const s7_pointer pre_var_list= cons (sc, sc->nil, sc->nil); - gc_protect_via_stack (sc, pre_var_list); - - /* clear_big_symbol_set(sc); */ /* an experiment -- slightly slower than - pre_var_list? */ - for (s7_pointer p= vars, var_list= NULL; 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 (!var_list) { - begin_temp (sc->y, sc->nil); - for (var_list= vars; is_pair (var_list); var_list= cdr (var_list)) - sc->y= cons (sc, caar (var_list), sc->y); - var_list= 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_var_list, - var_list); /* 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_var_list, caar (p)); /* caar(p) == current var, highly - likely it's in the step expr */ - optimize_expression (sc, car (expr), 0, pre_var_list, 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)); - } - if (DO_PRINT) - fprintf (stderr, " op: %s\n", op_names[optimize_op (sc->code)]); - return (code); + 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 bool -do_vector_has_definer (s7_pointer vec) { - s7_pointer* els= vector_elements (vec); - for (s7_int i= 0, len= vector_length (vec); 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 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)); } -#if CYCLE_DEBUGGING -static char *base= NULL, *min_char= NULL; -#endif - -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? +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. */ -#if CYCLE_DEBUGGING - char x; - if (!base) base= &x; - else { - if (&x > base) base= &x; - else { - if ((!min_char) || (&x < min_char)) { - min_char= &x; - if ((base - min_char) > 10000) { - fprintf (stderr, "infinite recursion? %s\n", display (tree)); - abort (); - } - } - } - } -#endif - 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); - } - return (false); + return(result); } -static void -check_do_for_obvious_errors (s7_scheme* sc, s7_pointer form) { - const s7_pointer code= cdr (form); +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)); +} - 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); +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)); +} - if (!is_pair (cdr (code))) /* (do () . 1) */ - syntax_error_nr (sc, "do body is messed up: ~A", 24, form); +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))));} - 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); +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)); +} - 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 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 -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)); - if (DO_PRINT) - fprintf (stderr, " %s[%d]: bad stepper %s\n", __func__, __LINE__, - display (code)); - 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)); - if (DO_PRINT) - fprintf (stderr, " %s[%d]: infinite loop %s\n", __func__, __LINE__, - 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))))) { - if (DO_PRINT) - fprintf (stderr, " %s[%d]: bad stepper %s\n", __func__, __LINE__, - display (code)); - return (code); - } - } - pair_set_syntax_op (form, OP_DO_NO_BODY_NA_VARS); - if (DO_PRINT) - fprintf (stderr, " %s[%d]: ok %s %s\n", __func__, __LINE__, - display (form), op_names[optimize_op (form)]); - return (sc->nil); - } - } - } - return (fxify_step_exprs (sc, code)); +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 -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)))) { - if (DO_PRINT) - fprintf (stderr, "%s[%d]: return do_end_bad for %s\n", __func__, __LINE__, - display (form)); - 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 (curlet_has_slots (sc)) /* outer vars */ - { - s7_pointer slot= let_slots (sc->curlet); - v1 = slot_symbol (slot); - slot = next_slot (slot); - if (is_not_slot_end (slot)) { - v2 = slot_symbol (slot); - slot= next_slot (slot); - if (is_not_slot_end (slot)) { - v3 = slot_symbol (slot); - more_vs= is_not_slot_end (next_slot (slot)); - } - } - } - if (v1) fx_tree_outer (sc, end, v1, v2, v3, more_vs); - } - } - if (DO_PRINT) - fprintf (stderr, "%s[%d]: optimizable %s\n", __func__, __LINE__, - display (form)); - return (sc->nil); - } +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))))); +} - if ((sc->safety > no_safety) && (tree_is_cyclic (sc, form))) { - if (DO_PRINT) - fprintf (stderr, "%s[%d]: bad: cyclic for %s\n", __func__, __LINE__, - display (form)); - return (form); - } - if (do_tree_has_definer ( - sc, form)) /* we don't want definers in body, vars, or end test */ - { - if (DO_PRINT) - fprintf (stderr, "%s[%d]: return fxify_step_exprs for %s\n", __func__, - __LINE__, display (form)); - return (fxify_step_exprs (sc, code)); +#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)); \ } - 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 var= car (vars); - s7_pointer step_expr; - - fx_tree (sc, end, car (var), NULL, NULL, false); - if (is_fx_treeable (body)) /* this is thwarted by gotos */ - fx_tree (sc, body, car (var), NULL, NULL, false); - - step_expr= simple_stepper (sc, var); - if (step_expr) { - const s7_pointer orig_end= end; - set_fx ( - cdr (var), - fx_choose (sc, cdr (var), 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 (var) == 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(var) == - cadr(step_expr)) and (car(var) == 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 (var), 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 (var), 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); - } - } - if (DO_PRINT) - fprintf (stderr, "%s[%d]: optimizable %s\n", __func__, __LINE__, - display (form)); - return (sc->nil); - } - } - } +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) - /* 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)); - if (DO_PRINT) - fprintf (stderr, "%s[%d]: return fxify_step_exprs for %s\n", __func__, - __LINE__, display (form)); - 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)); +#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)))); \ } - { - 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 { - if (DO_PRINT) - fprintf (stderr, "%s[%d]: return fxify_step_exprs for %s\n", - __func__, __LINE__, display (form)); - 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); is_not_slot_end (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 (sc, - 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 (curlet_has_slots (sc)) /* outer vars */ - { - s7_pointer slot= let_slots (sc->curlet); - var1 = slot_symbol (slot); - slot = next_slot (slot); - if (is_not_slot_end (slot)) { - var2= slot_symbol (slot); - slot= next_slot (slot); - if (is_not_slot_end (slot)) { - var3 = slot_symbol (slot); - more_vars= is_not_slot_end (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); - } +fx_c_sa_direct_any(fx_c_sa_direct, s_lookup) +fx_c_sa_direct_any(fx_c_ua_direct, u_lookup) - if ((is_pair (body)) && (is_null (cdr (body))) && - (is_fxable (sc, car (body)))) { - s7_pointer var_list; - 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); - var_list= sc->y; - end_temp (sc->y); - fx_annotate_arg (sc, body, var_list); - 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); - } - } - } - if (DO_PRINT) - fprintf (stderr, "%s[%d]: optimizable %s %s %s\n", __func__, __LINE__, - display (form), op_names[optimize_op (form)], - op_names[optimize_op (sc->code)]); - return (sc->nil); -} - -static bool -has_safe_steppers (s7_scheme* sc, s7_pointer let) { - for (s7_pointer slot= let_slots (let); is_not_slot_end (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 func= fx_proc (slot_expression (stepper)); /* e.g. fx_add_s1 */ - s7_pointer args= car (slot_expression (stepper)); - if ((func == fx_c_nc) || (func == fx_c_0c)) { - func= fn_proc (args); - args= cdr (args); - } - if (((func == fx_cdr_s) || (func == fx_cdr_t)) && - (cadr (args) == 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 (((func == fx_add_t1) || (func == 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)= q_call (o).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, func (sc, args)); - } while ((sc->value= endf (sc, endp)) == sc->F); - sc->code= cdr (end); - return (goto_do_end_clauses); - } - if ((steppers == 2) && (!is_not_slot_end (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 (is_not_slot_end (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; - const s7_pointer let= inline_make_let ( - sc, - sc->curlet); /* new let is not tied into the symbol lookup process yet */ - if (SHOW_EVAL_OPS) - fprintf (stderr, "%s[%d]: %s\n", __func__, __LINE__, display (form)); - 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) */ - new_cell_unchecked (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; is_not_slot_end (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))); - } - } +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))));} - 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? from eval call of - op_dox 96130 possibly from check_do */ - { - if (DO_PRINT) fprintf (stderr, "dox %d, no body\n", __LINE__); - return (op_dox_no_body_1 (sc, slots, end, steppers, stepper)); +#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)); \ } - 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)) && (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)= q_call (o).fp; - if (!((fp == opt_p_pip_sso) && (q_arg2 (o).p == q_arg4 (o).p) && - (((q_func (o).p_pip_f == string_set_p_pip_unchecked) && - (q_func3 (o).p_pi_f == string_ref_p_pi_unchecked)) || - ((q_func (o).p_pip_f == string_set_p_pip_direct) && - (q_func3 (o).p_pi_f == string_ref_p_pi_direct)) || - ((q_func (o).p_pip_f == vector_set_p_pip_unchecked) && - (q_func3 (o).p_pi_f == t_vector_ref_p_pi_unchecked)) || - ((q_func (o).p_pip_f == t_vector_set_p_pip_direct) && - (q_func3 (o).p_pi_f == t_vector_ref_p_pi_direct)) || - ((q_func (o).p_pip_f == list_set_p_pip_unchecked) && - (q_func3 (o).p_pi_f == list_ref_p_pi_unchecked))) && - (copy_if_end_ok (sc, slot_value (q_arg1 (o).p), - slot_value (q_arg3 (o).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) && - (q_call (o).fd == opt_d_7pid_ss_ss) && - (q_arg2 (o).p == q_arg4 (o).p) && - ((q_func (o).d_7pid_f == float_vector_set_d_7pid) || - (q_func (o).d_7pid_f == - float_vector_set_d_7pid_direct)) && - ((q_func1 (o).d_7pi_f == float_vector_ref_d_7pi) || - (q_func1 (o).d_7pi_f == - float_vector_ref_d_7pi_direct)) && - (copy_if_end_ok (sc, slot_value (q_arg1 (o).p), - slot_value (q_arg3 (o).p), i, endp, - stepper))) || - - ((bodyf == opt_int_any_nv) && - ((q_call (o).fi == opt_i_7pii_ssf) || - (q_call (o).fi == opt_i_7pii_ssf_vset)) && - (q_arg2 (o).p == q_func1_arg (o).q_arg2 (o1).p) && - (((q_func (o).i_7pii_f == int_vector_set_i_7pii) && - (q_func1_arg (o).q_func (o1).i_7pi_f == - int_vector_ref_i_7pi)) || - ((q_func (o).i_7pii_f == int_vector_set_i_7pii_direct) && - (q_func1_arg (o).q_func (o1).i_7pi_f == - int_vector_ref_i_pi_direct))) && - (copy_if_end_ok ( - sc, slot_value (q_arg1 (o).p), - slot_value (q_func1_arg (o).q_arg1 (o1).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); - } +fx_c_as_any(fx_c_as, s_lookup) +fx_c_as_any(fx_c_at, t_lookup) - if ((steppers == 2) && - (!is_not_slot_end (next_slot (next_slot (slots))))) { - const s7_pointer slot1= slots, slot2= next_slot (slots); - const s7_function f1= fx_proc (slot_expression (slot1)); - const s7_function f2= fx_proc (slot_expression (slot2)); - const s7_pointer p1= car (slot_expression (slot1)); - const s7_pointer p2= car (slot_expression (slot2)); - /* 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)= q_call (o).fp; - s7_pointer slot3 = NULL; - /* thash case -- this is dumb */ - if ((f2 == fx_add_u1) && (is_t_integer (slot_value (slot2))) && - (cadr (endp) == slot_symbol (slot2)) && - (!s7_tree_memq (sc, cadr (endp), body)) && - (((endf == fx_num_eq_ui) && (is_t_integer (caddr (endp)))) || - ((endf == fx_num_eq_us) && - (slot3= 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 (slot2)); - s7_int endi= (is_t_integer (caddr (endp))) - ? integer (caddr (endp)) - : integer (slot_value (slot3)); - do { - fp (o); - slot_set_value (slot1, f1 (sc, p1)); - i++; - } while (i < endi); - slot_set_value (slot2, 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 (slot1, f1 (sc, p1)); - slot_set_value (slot2, 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 (slot1, f1 (sc, p1)); - slot_set_value (slot2, 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)= q_call (o).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 (is_not_slot_end (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 (is_not_slot_end (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)) && (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++) - q_call (body[i]).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 (is_not_slot_end (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 (is_not_slot_end (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 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 void -op_dox_step (s7_scheme* sc) { - push_stack_no_args_direct (sc, OP_DOX_STEP); - sc->code= T_Pair (cddr (sc->code)); +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 void -op_dox_step_o (s7_scheme* sc) { - push_stack_no_args_direct (sc, OP_DOX_STEP_O); - sc->code= caddr (sc->code); +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 void -op_dox_no_body (s7_scheme* sc) { - s7_pointer slot, var, test, result; - s7_function testf; +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)); +} - sc->code= cdr (sc->code); - var = caar (sc->code); - testf = fx_proc (cadr (sc->code)); - test = caadr (sc->code); - result = cdadr (sc->code); +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)); +} - 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); - } +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 - 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) { - const s7_pointer t1= cadr (test); - const s7_pointer t2= caddr (test); - const s7_function f1= fx_proc (cdr (test)); - const 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) { - const s7_pointer f1_arg= cadr (test), p= opt3_pair (test); /* cdadr(p) */ - const s7_function f1 = fx_proc (cdr (test)); - const s7_pointer f2_arg= car (p); - const s7_pointer f3_arg= cadr (p); - const s7_function f2 = fx_proc (p); - const s7_function f3 = fx_proc (cdr (p)); - if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && - (is_t_integer (slot_value (slot)))) { - const 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); - } + 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 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) && (!is_not_slot_end (next_slot (next_slot (slots)))) && - (is_pair (cdr (test)))) { - const s7_pointer slot1= slots; - const s7_pointer expr1= slot_expression (slot1); - const s7_pointer slot2= next_slot (slot1); - const 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 (is_not_slot_end (slot)); - slot= slots; - do { - if (slot_has_expression (slot)) - slot_set_value (slot, slot_pending_value (slot)); - slot= next_slot (slot); - } while (is_not_slot_end (slot)); - } - sc->code= cdr (test); - let_clear_has_pending_value (sc, sc->curlet); +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 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) - q_call (body[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)= q_call (o0).fp; - s7_pointer (*fp1) (opt_info* o)= q_call (o1).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++) - q_call (body[k]).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 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 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 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 void -op_do_no_body_na_vars (s7_scheme* sc) /* vars fxable, end-test not */ +static s7_pointer fx_c_aaa(s7_scheme *sc, s7_pointer arg) { - 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); is_not_slot_end (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); - } - } + 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 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 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 bool -op_do_step ( - s7_scheme* sc) /* called only in eval OP_DO_STEP via op_do_end_false */ +static s7_pointer fx_c_opaq_s(s7_scheme *sc, s7_pointer arg) { - /* 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); + set_car(sc->t2_1, fn_proc(cadr(arg))(sc, with_list_t1(sc, fx_call(sc, cdadr(arg))))); + set_car(sc->t2_2, lookup_checked(sc, caddr(arg))); + return(fn_proc(arg)(sc, sc->t2_1)); } -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 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(sc, 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 bool -opt_do_copy (s7_scheme* sc, opt_info* o, s7_int start, s7_int stop) { - s7_pointer (*fp) (opt_info* o)= - q_call (o).fp; /* o-[6].p_pi_f (q_func3) is getter, o-v[5].p_pip_f - (q_func) is setter */ - if (start >= stop) return (true); - if ((fp == opt_p_pip_sso) && - (type (slot_value (q_arg1 (o).p)) == type (slot_value (q_arg3 (o).p))) && - (q_arg2 (o).p == q_arg4 (o).p)) { - s7_pointer caller= NULL; - const s7_pointer dest = slot_value (q_arg1 (o).p); - const s7_pointer source= slot_value (q_arg3 (o).p); - if ((is_t_vector (dest)) && - (((q_func (o).p_pip_f == vector_set_p_pip_unchecked) || - (q_func (o).p_pip_f == t_vector_set_p_pip_direct)) && - ((q_func3 (o).p_pi_f == t_vector_ref_p_pi_unchecked) || - (q_func3 (o).p_pi_f == vector_ref_p_pi_unchecked) || - (q_func3 (o).p_pi_f == t_vector_ref_p_pi_direct)))) - caller= sc->vector_set_symbol; - else if ((is_string (dest)) && - (((q_func (o).p_pip_f == string_set_p_pip_unchecked) || - (q_func (o).p_pip_f == string_set_p_pip_direct)) && - ((q_func3 (o).p_pi_f == string_ref_p_pi_unchecked) || - (q_func3 (o).p_pi_f == string_ref_p_pi_direct)))) - caller= sc->string_set_symbol; - else if ((is_pair (dest)) && - ((q_func (o).p_pip_f == list_set_p_pip_unchecked) && - (q_func3 (o).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 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(sc, fn_proc(arg1)(sc, sc->t1_1)))); } -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)= q_call (o).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= q_func (o).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 (q_arg1 (o).p), slot_value (q_arg2 (o).p), - slot_value (q_arg3 (o).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= q_func (o).p_ppp_f; - for (s7_int i= start; i < stop; i++) { - slot_set_value (ctr_slot, make_integer (sc, i)); - fpt (sc, slot_value (q_arg1 (o).p), q_p_func1_call (o), - slot_value (q_arg2 (o).p)); - } - } - else if ((fp == opt_p_pip_sss_vset) && (start >= 0) && - (stop <= vector_length (slot_value ( - q_arg1 (o).p)))) { /* (do ((i 0 (+ i 1))) ((= i 10) - v) (vector-set! v i i)) */ - s7_pointer* vels= vector_elements ( - slot_value (q_arg1 (o).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 (q_arg2 (o).p))]= slot_value (q_arg3 (o).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)= q_call (o).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)= q_call (o).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)= q_call (o).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)= - q_func1_arg (o).q_temp (o1).fp; /* see opt_cond_1b test expr */ - opt_info* test_o1= q_func1_arg (o).o1; - opt_info* o2 = q_cond_val1 (o).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) */ +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(sc, 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(sc, 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)); { - set_car (sc->t2_2, slot_value (ctr)); - set_car (sc->t2_1, cadr (step)); + s7_pointer result = fn_proc(code)(sc, with_list_t1(sc, fn_proc(arg1)(sc, sc->t3_1))); + unstack_gc_protect(sc); + return(result); } - 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 (sc, 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)= q_call (o).fd; - if ((fd == opt_d_id_sf) && /* by far the most common case in clm: - (outa i ...) etc */ - (is_slot (q_arg1 (o).p)) && - (stepper == - slot_value (q_arg1 (o).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 = q_func (o).d_id_f; - fd = q_call (o1).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 ((q_call (o).fd == opt_d_7pid_ss_ss) && - (q_func (o).d_7pid_f == float_vector_set_d_7pid_direct) && - ((q_func1 (o).d_7pi_f == float_vector_ref_d_7pi) || - (q_func1 (o).d_7pi_f == float_vector_ref_d_7pi_direct)) && - (q_arg2 (o).p == q_arg4 (o).p)) - copy_to_same_type (sc, slot_value (q_arg1 (o).p), - slot_value (q_arg3 (o).p), integer (stepper), - end, integer (stepper)); - else if ((q_call (o).fd == opt_d_7pid_ssc) && - (q_func (o).d_7pid_f == float_vector_set_d_7pid_direct) && - (stepper == slot_value (q_arg2 (o).p))) - s7_fill (sc, set_plist_4 ( - sc, slot_value (q_arg1 (o).p), - wrap_real (sc, q_arg3 (o).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)= q_call (o).fp; - if ((fp == opt_p_pip_ssc) && - (stepper == - slot_value (q_arg2 (o).p)) && /* i.e. index by do counter */ - ((q_func (o).p_pip_f == string_set_p_pip_direct) || - (q_func (o).p_pip_f == t_vector_set_p_pip_direct) || - (q_func (o).p_pip_f == list_set_p_pip_unchecked))) - s7_fill (sc, - set_plist_4 ( - sc, slot_value (q_arg1 (o).p), q_arg3 (o).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 (q_func (o).fb (q_arg2 (o).o1)) q_p_func1_call (o); - } - 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 (!(q_func4 (o).b_pi_f (sc, q_p_func1_call (o), - integer (slot_value (q_arg1 (o).p))))) - q_p_func2_call (o); - } - 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"))) */ - opt_info* o1= q_when_body (o, 0).o1; - for (; integer (stepper) < end; integer (stepper)++) - if (!(q_when_test_call (o))) q_call (o1).fp (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)= q_call (o).fi; - if ((fi == opt_i_7pii_ssc) && (stepper == slot_value (q_arg2 (o).p)) && - (q_func (o).i_7pii_f == int_vector_set_i_7pii_direct)) - s7_fill ( - sc, set_plist_4 (sc, slot_value (q_arg1 (o).p), - wrap_integer (sc, q_arg3 (o).i), stepper, - wrap_integer (sc, end))); /* wrapped 16-Nov-23 */ - else if ((q_func (o).i_7pii_f == int_vector_set_i_7pii_direct) && - (q_func1 (o).fi == opt_i_pi_ss_ivref) && - (q_arg2 (o).p == q_func1_arg (o).q_arg2 (o1).p)) - copy_to_same_type (sc, slot_value (q_arg1 (o).p), - slot_value (q_func1_arg (o).q_arg1 (o1).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-numeric? (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)= q_call (o).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 (q_when_test_call (o)) { - q_when_p1_call (o); - q_when_p2_call (o); - } - } - } - 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)= q_call (o).fi; - if ((fi == opt_set_i_i_f) || (fi == opt_set_i_i_fo)) { - slot_set_value ( - q_arg1 (o).p, - make_mutable_integer (sc, integer (slot_value (q_arg1 (o).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 (q_arg1 (o).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)= q_call (o).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 ( - q_arg1 (o).p, - make_mutable_real (sc, real (slot_value (q_arg1 (o).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 (q_arg1 (o).p)); - } - } - /* there aren't any other possibilities */ - sc->value = sc->T; - sc->code = cdadr (scc); - sc->do_body_p= NULL; - return_true (sc, code); +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); } +} - { /* 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); - const 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++) - q_call (body[i]).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)); - const 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++) - q_call (body[i]).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); - const 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 (q_call (body[i]).fp (body[i]); i++); - else if (body_len == 1) { - opt_info* o1= body[0]; - for (; integer (stepper) < end; integer (stepper)++) - q_call (o1).fp (o1); - } - else /* TODO: opt_unless_p_1_nr? */ - for (; integer (stepper) < end; integer (stepper)++) - for (int32_t i= 0; i < body_len; i++) - q_call (body[i]).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))) */ - 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)); - 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++) - q_call (body[i]).fp (body[i]); - } - } - sc->value= sc->T; - sc->code = cdadr (scc); - return_true (sc, code); - } - } - } - return_false (sc, code); +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 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_let, 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*)); +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)); +} - /* 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_let= sc->curlet; - set_curlet (sc, make_let (sc, sc->curlet)); +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)); +} - 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_let); - return (false); - } - if (let_star) - add_slot_checked (sc, sc->curlet, caar (p), make_mutable_real (sc, 1.5)); - } +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(sc, fn_proc(arg)(sc, sc->t2_1)))); + set_car(sc->t2_2, lookup(sc, caddr(code))); + return(fn_proc(code)(sc, sc->t2_1)); +} - 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)); +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)))); +} - { - 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_let); - return (false); - } - } - if (!is_null (p)) /* no hits in s7test or snd-test */ +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(sc, 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_curlet (sc, old_let); - 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) { - opt_info* o = body[0]; - s7_double (*f2) (opt_info* o)= q_call (o).fd; - if (var_len == 1) { - opt_info* first = sc->opts[0]; - const s7_pointer xp = t_lookup (sc, caar (let_vars), let_vars); - s7_double (*f1) (opt_info* o)= q_call (first).fd; - set_integer (ip, numerator (stepper)); - set_real (xp, f1 (first)); - f2 (o); - if ((f2 == opt_fmv) && (f1 == opt_d_dd_ff_o2) && - (q_func (first).d_dd_f == add_d_dd) && - (slot_symbol (step_slot) == slot_symbol (q_arg2 (o).p))) { - opt_info* o1 = q_arg3 (o).o1; /* opt_d_dd_ff_mul1 */ - opt_info* o2 = q_arg4 (o).o1; /* opt_d_vd_o1 */ - opt_info* o3 = q_arg5 (o).o1; /* opt_d_dd_ff_o3 */ - s7_d_vid_t vf7 = q_func (o).d_vid_f; /* locsig_d_vid */ - s7_d_v_t vf1 = q_func3 (first).d_v_f; /* mus_triangle_wave_dv */ - s7_d_v_t vf2 = q_func1 (first).d_v_f; /* mus_rand_interp_dv */ - s7_d_v_t vf3 = q_func3 (o1).d_v_f; /* mus_env_dv */ - s7_d_v_t vf4 = q_func3 (o3).d_v_f; /* mus_env_dv */ - s7_d_vd_t vf5 = q_func (o2).d_vd_f; /* mus_oscil_dvd */ - s7_d_vd_t vf6 = q_func2 (o3).d_vd_f; /* mus_polywave_dvd */ - void* obj1= q_arg1 (first).gen; - void* obj2= q_arg2 (first).gen; - void* obj3= q_arg1 (o1).gen; - void* obj4= q_arg1 (o3).gen; - void* obj5= q_arg1 (o).gen; - void* obj6= q_arg1 (o2).gen; - void* obj7= q_arg2 (o3).gen; - 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) { - const s7_pointer s1= let_slots (sc->curlet); - const s7_pointer s2= next_slot (s1); - opt_info * v0= vars[0], *v1= vars[1]; - for (s7_int k= numerator (stepper); k < end; k++) { - set_integer (ip, k); - set_real (slot_value (s1), q_call (v0).fd (v0)); - set_real (slot_value (s2), q_call (v1).fd (v1)); - f2 (o); - } - } /* 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; is_not_slot_end (slot); - n++, slot= next_slot (slot)) - set_real (slot_value (slot), q_call (vars[n]).fd (vars[n])); - f2 (o); /* q_call(body[0]).fd(body[0]) is possibly slightly faster */ - } - } - } /* end body_len == 1 */ - else if ((body_len == 2) && (var_len == 1)) { - const 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), q_call (vars[0]).fd (vars[0])); - q_call (body[0]).fd (body[0]); - q_call (body[1]).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); is_not_slot_end (slot); - i++, slot= next_slot (slot)) - set_real (slot_value (slot), q_call (vars[i]).fd (vars[i])); - for (int32_t i1= 0; i1 < body_len; i1++) - q_call (body[i1]).fd (body[i1]); - } - set_curlet (sc, old_let); - 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); - for (s7_pointer stepper= slot_value (sc->args); - 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); + set_car(p, opt2_con(args)); + args = cdr(args); + set_car(cdr(p), fx_call(sc, args)); } - } - 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. + result = fn_proc(code)(sc, lst); + if (in_heap(lst)) unstack_gc_protect(sc); + else clear_safe_list_in_use(sc, lst); + return(result); +} + +static s7_pointer fx_inlet_ca(s7_scheme *sc, s7_pointer code) +{ + s7_pointer new_let, last_slot = NULL; + s7_int id; + + new_cell(sc, new_let, T_LET | T_SAFE_PROCEDURE); + let_set_slots(new_let, slot_end); /* needed by add_slot_unchecked */ + let_set_outlet(new_let, sc->rootlet); + gc_protect_via_stack(sc, new_let); + + /* 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. */ - const s7_pointer form= sc->code; - s7_pointer end, init_val, end_val, code; + 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 (!last_slot) + last_slot = add_slot_unchecked_no_local_slot(sc, new_let, symbol, value); + else last_slot = add_slot_at_end_no_local(sc, last_slot, symbol, value); + } + id = ++sc->let_number; + let_set_id(new_let, id); + for (s7_pointer slot = let_slots(new_let); is_not_slot_end(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_let); +} + +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(sc, 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); +} - /* 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); - } +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); +} - 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); - } +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); +} - 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; - } +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))); +} - 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); - const s7_pointer val_slot= s7_t_slot (sc, cadr (body)); - s7_int step = integer (slot_value (step_slot)); - const 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); - } - } +#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))); \ } - 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_let; - 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_let= 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_let); - 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); + +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 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)) { - const s7_pointer slot= add_slot_unchecked_with_id ( - sc, sc->curlet, caar (vars), car_unchecked (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 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 bool -op_do_init (s7_scheme* sc) /* looping through inits via eval */ +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 (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)); + 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 void -op_do_unchecked (s7_scheme* sc) { - gc_protect_via_stack (sc, sc->code); - sc->code= cdr (sc->code); +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 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 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 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 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 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 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 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 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 -apply_c_function_unopt ( - s7_scheme* sc, s7_pointer func, - s7_pointer args) /* an experiment -- callgrind says this saves time */ +static s7_pointer fx_and_n(s7_scheme *sc, s7_pointer arg) { - 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)); + 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 void -apply_c_rst_no_req_function ( - s7_scheme* sc) /* -------- C-based function that can take any number of - arguments -------- */ +static s7_pointer fx_or_2a(s7_scheme *sc, s7_pointer arg) { - sc->value= c_function_call (sc->code) (sc, sc->args); + s7_pointer p = cdr(arg); + s7_pointer val = fx_call(sc, p); + return((val != sc->F) ? val : fx_call(sc, cdr(p))); } -static void -apply_c_macro (s7_scheme* sc) /* -------- C-based macro -------- */ +static s7_pointer fx_or_s_2(s7_scheme *sc, s7_pointer arg) { - check_c_macro_args (sc, sc->code, sc->args); - sc->code= c_macro_call (sc->code) (sc, sc->args); + /* 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(sc, lookup(sc, opt3_sym(cdr(arg))))); /* cadadr(arg) */ + return((val != sc->F) ? val : fn_proc(caddr(arg))(sc, sc->t1_1)); } -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 -------- */ +static s7_pointer fx_or_s_type_2(s7_scheme *sc, s7_pointer arg) { - /* 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)) { - const 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= s7i_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))) { - const 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)); + 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 bool -apply_pair (s7_scheme* sc) /* -------- list as applicable object -------- */ +static s7_pointer fx_not_symbol_or_keyword(s7_scheme *sc, s7_pointer arg) { - 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 - */ + s7_pointer val = lookup(sc, opt3_sym(arg)); + return(make_boolean(sc, (!is_symbol(val)) || (is_keyword(val)))); } -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 let= 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 (car_unchecked (args))); - symbol_set_local_slot (sym, id, slot); - if (is_not_slot_end (last_slot)) slot_set_next (last_slot, slot); - else let_set_slots (let, 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 { - const s7_pointer slot= make_slot (sc, T_Sym (pars), args); - symbol_set_local_slot (pars, id, slot); - if (is_not_slot_end (last_slot)) slot_set_next (last_slot, slot); - else let_set_slots (let, 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 let = 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, let, 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 (let), - cddr (sc->code)); /* not for gc-protection, but as implicit loop vars */ - push_stack (sc, OP_F_NP_1, let, 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, last_slot= slot; - for (p= sc->value; (is_pair (p)) && (is_not_slot_end (slot)); - p= cdr (p), last_slot= 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= last_slot; /* 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 ((!is_not_slot_end (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 (is_not_slot_end (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 let= sc->args; - let_set_id (let, ++sc->let_number); - set_curlet (sc, let); - update_symbol_ids (sc, let); - } - 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 */; - is_not_slot_end (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; is_not_slot_end (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 (sc, 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); is_not_slot_end (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); is_not_slot_end (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 (sc, 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 par1; - 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)); - par1= car (closure_pars (func)); - set_curlet (sc, make_let_with_slot (sc, closure_let (func), - (is_pair (par1)) ? car (par1) : par1, - 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) == type_unchecked (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); is_not_slot_end (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_unchecked (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) /* sc->code: (generate-leaves) */ +static s7_pointer fx_or_and_2a(s7_scheme *sc, s7_pointer arg) { - 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); + 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 void -op_thunk_o (s7_scheme* sc) /* sc->code: (h) */ +static s7_pointer fx_or_and_3a(s7_scheme *sc, s7_pointer arg) { - 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, sc->code: (fc) */ + 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) { - 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); + 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 -op_safe_thunk_a (s7_scheme* sc, s7_pointer code) /* sc->code: (get-ds) */ +static s7_pointer fx_or_n(s7_scheme *sc, s7_pointer arg) { - const s7_pointer func= opt1_lambda (code); - set_curlet (sc, closure_let (func)); - return (fx_call (sc, closure_body (func))); + 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 void -op_thunk_any (s7_scheme* sc) /* sc->code: (make-hook) */ +static s7_pointer fx_begin_aa(s7_scheme *sc, s7_pointer arg) { - 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); + fx_call(sc, cdr(arg)); + return(fx_call(sc, cddr(arg))); } -static void -op_safe_thunk_any (s7_scheme* sc) /* sc->code: (m3) */ +static s7_pointer fx_begin_na(s7_scheme *sc, s7_pointer arg) { - 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); + s7_pointer p; + for (p = cdr(arg); is_pair(cdr(p)); p = cdr(p)) + fx_call(sc, p); + return(fx_call(sc, p)); } -static void -op_closure_s (s7_scheme* sc) /* sc->code: (func hook) */ +static s7_pointer fx_safe_thunk_a(s7_scheme *sc, s7_pointer code) { - 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); + 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 inline void -op_closure_s_o (s7_scheme* sc) /* sc->code: (recompose-1 n) */ +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 (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)); + 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 void -op_safe_closure_s (s7_scheme* sc) /* sc->code: (close1 x) */ +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 (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); + 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 void -op_safe_closure_s_o (s7_scheme* sc) /* sc->code: (op2 lst) */ +static s7_pointer fx_safe_closure_t_a(s7_scheme *sc, s7_pointer code) { - 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)); + 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 void -op_safe_closure_p ( - s7_scheme* sc) /* sc->code: (close1 ((lambda () (cs11 x)))) */ +static s7_pointer fx_safe_closure_s_to_s(s7_scheme *sc, s7_pointer arg) { - check_stack_size (sc); - push_stack_no_args (sc, OP_SAFE_CLOSURE_P_1, opt1_lambda (sc->code)); - sc->code= cadr (sc->code); + return(fn_proc(car(closure_body(opt1_lambda(arg))))(sc, with_list_t1(sc, lookup(sc, opt2_sym(arg))))); } -static void -op_safe_closure_p_1 (s7_scheme* sc) /* sc->code: close1 */ +static s7_pointer fx_safe_closure_s_to_sc(s7_scheme *sc, s7_pointer arg) { - set_curlet (sc, update_let_with_slot (sc, closure_let (sc->code), sc->value)); - sc->code= T_Pair (closure_body (sc->code)); + 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 void -op_safe_closure_p_a (s7_scheme* sc) /* sc->code: (char->digit (str j)) */ +static s7_pointer fx_safe_closure_s_to_vref(s7_scheme *sc, s7_pointer arg) {return(s7i_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) { - check_stack_size (sc); - push_stack_no_args_direct (sc, OP_SAFE_CLOSURE_P_A_1); - sc->code= cadr (sc->code); + s7_pointer p = lookup(sc, opt2_sym(arg)); + if ((is_t_integer(p))) return(make_integer(sc, integer(p) - 1)); + return(minus_c1(sc, p)); } -static void -op_safe_closure_p_a_1 ( - s7_scheme* sc) /* sc->code: (identity (if (= state 0) (call/cc... */ +static s7_pointer fx_safe_closure_s_to_add1(s7_scheme *sc, s7_pointer arg) { - 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)); + s7_pointer p = lookup(sc, opt2_sym(arg)); + if ((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 Inline void -inline_op_closure_a ( - s7_scheme* sc) /* used twice in eval, sc->code: (recompose-1 (- n 1)) */ +static s7_pointer fx_c_ff(s7_scheme *sc, s7_pointer arg) { - 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)); + 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 void -op_safe_closure_3s (s7_scheme* sc) /* sc->code: (number-ok? otst result oexp) */ +static s7_pointer fx_safe_closure_a_to_sc(s7_scheme *sc, s7_pointer arg) { - 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); + 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 void -op_safe_closure_ssa (s7_scheme* sc) /* possibly inline b, sc->code: - (transparent-memq sym var (outlet e)) */ -{ /* 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 s7_pointer fx_safe_closure_a_to_vref(s7_scheme *sc, s7_pointer arg) {return(s7i_vector_ref_p_pp(sc, fx_call(sc, cdr(arg)), opt3_con(cdr(arg))));} -static void -op_safe_closure_saa (s7_scheme* sc) /* (not called in s7test) cb.scm: sc->code: - (loop a (+ b 1) parts) */ +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 (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, sc->code: (fx2 3 #t #t) */ + 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 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); + 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 void -op_closure_p (s7_scheme* sc) /* sc->code: (uncaller (hook 'code)) */ +static s7_pointer fx_safe_closure_a_a(s7_scheme *sc, s7_pointer code) { - check_stack_size (sc); - push_stack_no_args (sc, OP_CLOSURE_P_1, opt1_lambda (sc->code)); - sc->code= cadr (sc->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 void -op_closure_p_1 (s7_scheme* sc) /* sc->code: symbol->object */ +static s7_pointer op_safe_closure_a_a(s7_scheme *sc, s7_pointer code) { - 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)); + 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 void -op_safe_closure_a (s7_scheme* sc) /* sc->code: (loop (+ index 1)) */ -{ - 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 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 void -op_safe_closure_a_o ( - s7_scheme* sc) /* sc->code: (butlast (cdr (car (cdr (cdr old))))) */ +static s7_pointer fx_safe_closure_a_and_2a(s7_scheme *sc, s7_pointer code) { - 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)); + 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 void -op_closure_ap (s7_scheme* sc) /* sc->code: (ack1 (- m 1) (ack1 m (- n 1))) */ +static s7_pointer fx_safe_closure_ss_a(s7_scheme *sc, s7_pointer code) { - 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); + 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 void -op_closure_ap_1 (s7_scheme* sc) /* sc->code: 1 */ +static s7_pointer op_safe_closure_ss_a(s7_scheme *sc, s7_pointer code) { - /* 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)); + 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 void -op_closure_pa (s7_scheme* sc) /* sc->code: (f-1 (lambda (b) (+ b 1)) 2) */ +static s7_pointer fx_safe_closure_3s_a(s7_scheme *sc, s7_pointer code) { - 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); + 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 void -op_closure_pa_1 (s7_scheme* sc) /* sc->code: # */ +static s7_pointer op_safe_closure_3s_a(s7_scheme *sc, s7_pointer code) { - 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)); + 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 void -op_closure_pp (s7_scheme* sc) /* sc->code: (loop (xf) (yf)) */ +static s7_pointer fx_safe_closure_aa_a(s7_scheme *sc, s7_pointer code) { - 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) /* sc->code: as above */ + 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 */ { - push_stack (sc, OP_CLOSURE_AP_1, sc->args, sc->value); - sc->code= caddr (sc->code); + 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 void -op_safe_closure_ap ( - s7_scheme* sc) /* sc->code: (somefunc (call/cc (lambda (c1)... */ -{ - 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 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 void -op_safe_closure_ap_1 (s7_scheme* sc) /* sc->code: somefunc */ -{ - 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 s7_function *fx_function = NULL; -static void -op_safe_closure_pa (s7_scheme* sc) /* sc->code: (string-wi=? (object->string - (append...) :readable)) */ +static bool is_fxable(s7_scheme *sc, s7_pointer expr) { - 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); + 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 void -op_safe_closure_pa_1 (s7_scheme* sc) /* sc->code: string-wi=? */ +static int32_t fx_count(s7_scheme *sc, s7_pointer expr) { - 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)); + 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 void -op_safe_closure_pp ( - s7_scheme* sc) /* sc->code: (somefunc (call/cc (lambda (c1)... */ -{ - check_stack_size (sc); - push_stack (sc, OP_SAFE_CLOSURE_PP_1, opt1_lambda (sc->code), sc->code); - sc->code= cadr (sc->code); -} +static bool is_code_constant(s7_scheme *sc, s7_pointer p) {return((is_pair(p)) ? (is_quote(sc, car(p))) : (!is_normal_symbol(p)));} -static void -op_safe_closure_pp_1 (s7_scheme* sc) /* sc->code as above */ -{ - push_stack (sc, OP_SAFE_CLOSURE_AP_1, sc->value, sc->args); - sc->code= caddr (sc->code); -} +static inline s7_pointer check_quote(s7_scheme *sc, s7_pointer code); -static void -op_any_closure_3p ( - s7_scheme* sc) /* sc->code: (g-1 (lambda (b c) (+ b c)) 2 3) */ -{ - s7_pointer args= cdr (sc->code); /* sc->code: e.g. s7test (recompose 32 - (lambda (a) (cons 1 a)) ()) */ - if (has_fx (args)) { - sc->args= fx_call (sc, args); - args = cdr (args); - if (has_fx (args)) { - 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, args), - 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 (args); - } - else { - push_stack_direct (sc, OP_ANY_CLOSURE_3P_2); /* arg1 == stack[args] */ - sc->code= car (args); - } - } - else { - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_3P_1); - sc->code= car (args); - } -} +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); -static bool -closure_3p_end ( - s7_scheme* sc, - s7_pointer args) /* sc->code: (dpb (byte 4 5) (byte 6 7) (byte 8 9)) */ -{ - if (has_fx (args)) { - 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, args)); - 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 (args); - return (false); -} - -static bool -op_any_closure_3p_1 (s7_scheme* sc) /* sc->code: as above */ -{ - const s7_pointer args= cddr (sc->code); - sc->args= - sc->value; /* (arg1 of closure) sc->value can be clobbered by fx_call? */ - if (has_fx (args)) { - sc->value= fx_call (sc, args); - return (closure_3p_end (sc, cdr (args))); - } - push_stack_direct (sc, OP_ANY_CLOSURE_3P_2); - sc->code= car (args); - 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) /* sc->code: as above */ -{ - /* 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) /* sc->code: (lpb -1 1 (byte 4 5) 3) */ -{ - s7_pointer args= cdr (sc->code); - check_stack_size (sc); - if (has_fx (args)) { - gc_protect_via_stack (sc, fx_call (sc, args)); - args= cdr (args); - if (has_fx (args)) { - set_gc_protected2 (sc, fx_call (sc, args)); - args= cdr (args); - if (has_fx (args)) { - set_gc_protected3 (sc, fx_call (sc, args)); - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_4); - sc->code= cadr (args); - } - else { - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_3); - sc->code= car (args); - } - } - 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 (args); - } - } - else { - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_1); - sc->code= car (args); - } -} +#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 -closure_4p_end (s7_scheme* sc, s7_pointer args) /* sc->code: as above */ -{ - if (has_fx (args)) { - const s7_pointer func= opt1_lambda (sc->code); - sc->args = fx_call (sc, args); - 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 (args); - return (false); -} +static bool fx_matches(s7_pointer symbol, const s7_pointer target_symbol) {return((symbol == target_symbol) && (is_unchanged_global(symbol)));} -static bool -op_any_closure_4p_1 (s7_scheme* sc) /* sc->code: as above */ +typedef bool (safe_sym_t)(s7_scheme *sc, s7_pointer sym, s7_pointer var_list); + +/* #define fx_choose(Sc, Holder, Var_List, Checker) fx_choose_1(Sc, Holder, Var_List, Checker, __func__, __LINE__) */ +static s7_function fx_choose(s7_scheme *sc, const s7_pointer holder, const s7_pointer var_list, safe_sym_t *checker) /* , const char *func, int32_t line) */ { - s7_pointer args= cddr (sc->code); - gc_protect_via_stack (sc, sc->value); - if (has_fx (args)) { - set_gc_protected2 (sc, fx_call (sc, args)); - args= cdr (args); - if (has_fx (args)) { - set_gc_protected3 (sc, fx_call (sc, args)); - return (closure_4p_end (sc, cdr (args))); + const s7_pointer arg = car(holder); +#if S7_DEBUGGING + if ((!is_let(var_list)) && (!is_list(var_list))) fprintf(stderr, "%s[%d]: var_list: %s\n", __func__, __LINE__, display(var_list)); +#endif + 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(var_list)) {if (s7_symbol_local_value(sc, arg, var_list) == sc->else_symbol) return(fx_c);} + else if ((is_pair(var_list)) && (!direct_memq(arg, var_list))) return(fx_c); /* is_pair -> not () */ + } + return((is_defined_global(arg)) ? fx_g : ((checker(sc, arg, var_list)) ? fx_s : fx_unsafe_s)); + } + return(fx_c); } - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_3); - sc->code= car (args); - } - else { - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_2); - sc->code= car (args); - } - return (false); -} + 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 (fn_proc(arg) == g_add_i_random) return(fx_add_i_random); + 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), 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_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_p_pp_function(global_value(head))); + set_opt3_direct(cdr(arg), 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); -static bool -op_any_closure_4p_2 (s7_scheme* sc) /* sc->code: as above */ -{ - const s7_pointer args= cdddr (sc->code); - set_gc_protected2 (sc, sc->value); - if (has_fx (args)) { - set_gc_protected3 (sc, fx_call (sc, args)); - return (closure_4p_end (sc, cdr (args))); - } - push_stack_no_args_direct (sc, OP_ANY_CLOSURE_4P_3); - sc->code= car (args); - return (false); -} + 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_p_ppp_function(global_value(head))); + return(fx_c_sss_direct); + } + return(fx_c_sss); -static bool -op_any_closure_4p_3 (s7_scheme* sc) /* sc->code: as above */ -{ - set_gc_protected3 (sc, sc->value); - return (closure_4p_end (sc, cddddr (sc->code))); -} + case HOP_SAFE_C_SSA: + if (is_global_and_has_func(head, s7_p_ppp_function)) + { + set_opt2_direct(cdr(arg), s7_p_ppp_function(global_value(head))); + return(fx_c_ssa_direct); + } + return(fx_c_ssa); -static inline void -op_any_closure_4p_4 (s7_scheme* sc) /* sc->code: as above */ -{ - 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); -} + case HOP_SAFE_C_SCS: + if (is_global_and_has_func(head, s7_p_ppp_function)) + { + set_opt3_direct(cdr(arg), 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(sc, cadr(arg))) || (is_unquoted_pair(sc, caddr(arg))) || (is_unquoted_pair(sc, 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(sc, 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_p_pp_function(global_value(head))); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(car(s2)))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, 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_p_pp_function(global_value(head))); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(caar(arg1p)))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, 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); -static void -op_safe_closure_ss (s7_scheme* sc) /* sc->code: (g x y) */ -{ - 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); -} + 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_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_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_p_pp_function(global_value(head))); + set_opt3_direct(arg1p, 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), 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_p_pp_function(global_value(head))); + set_opt3_direct(cdr(arg), 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); -static void -op_safe_closure_ss_o (s7_scheme* sc) /* sc->code: (_f_aq p e) */ -{ - 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)); -} + 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_p_pp_function(global_value(head))); + set_opt3_direct(arg1p, 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_p_pp_function(global_value(head))); + set_opt3_direct(arg1p, 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, add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, 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_p_p_function(global_value(head))); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(caar(arg1p)))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, 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_p_pp_function(global_value(head))); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(caaddr(arg)))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, 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_p_pp_function(global_value(head))); + set_opt2_direct(arg1p, s7_p_p_function(global_value(car(arg1)))); + set_opt3_direct(arg1p, 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_p_pp_function(global_value(head))); + set_opt2_direct(arg1p, s7_p_p_function(global_value(car(arg1)))); + set_opt3_direct(arg1p, s7_p_pp_function(global_value(caadr(arg1)))); + if (opt3_direct(arg1p) == (s7_pointer)add_p_pp) + set_opt3_direct(arg1p, add_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)subtract_p_pp) + set_opt3_direct(arg1p, subtract_p_pp_wrapped); + else + if (opt3_direct(arg1p) == (s7_pointer)multiply_p_pp) + set_opt3_direct(arg1p, 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_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); -static inline void -op_closure_ss (s7_scheme* sc) /* sc->code: (A k B) */ -{ - 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); -} + 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_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, 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_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); -static inline void -op_closure_ss_o (s7_scheme* sc) /* sc->code: (c1 s i) */ -{ - 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) /* sc->code: (close3 x 2) */ -{ - 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) /* sc->code: (tree-member? c d) */ -{ - 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) /* sc->code: (read-in-radix str 32) */ -{ - 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) /* sc->code: (f-1 abs 2) */ -{ - 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) /* sc->code: (walk-rest caller form let) */ -{ - s7_pointer args = cdr (sc->code); - const s7_pointer arg1_val= lookup (sc, car (args)); - const s7_pointer func = opt1_lambda (sc->code); - args = cdr (args); - make_let_with_three_slots (sc, func, arg1_val, 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) /* sc->code: (pretty-print-1 obj port column) */ -{ - s7_pointer args = cdr (sc->code); - const s7_pointer arg1_val= lookup (sc, car (args)); - const s7_pointer func = opt1_lambda (sc->code); - args = cdr (args); - make_let_with_three_slots (sc, func, arg1_val, 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) /* sc->code: (Cholesky:add-element P L i j) */ -{ - s7_pointer args = cdr (sc->code); - const s7_pointer arg1_val= lookup (sc, car (args)), - arg2_val= lookup (sc, cadr (args)); - const s7_pointer func = opt1_lambda (sc->code); - args = cddr (args); - make_let_with_four_slots (sc, func, arg1_val, arg2_val, - 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) /* sc->code: (make-collector into oper tail head) */ -{ - s7_pointer args = cdr (sc->code); - const s7_pointer arg1_val= lookup (sc, car (args)), - arg2_val= lookup (sc, cadr (args)); - const s7_pointer func = opt1_lambda (sc->code); - args = cddr (args); - make_let_with_four_slots (sc, func, arg1_val, arg2_val, - 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, - sc->code: (key-parse-clause d mode args argn user) */ -{ - s7_pointer args = cdr (sc->code); - const s7_pointer arg1_val= lookup (sc, car (args)), - arg2_val= lookup (sc, cadr (args)); - const s7_pointer func = opt1_lambda (sc->code); - args = cddr (args); - make_let_with_five_slots (sc, func, arg1_val, arg2_val, - 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) /* sc->code: (close3 1 2) */ -{ - s7_pointer args= cdr (sc->code), body; - const s7_pointer func= opt1_lambda (sc->code); - sc->code = fx_call ( - sc, - cdr (args)); /* 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, args), sc->code)); - body= 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 (body))); - sc->code= car (body); -} - -static inline void -op_safe_closure_aa_o ( - s7_scheme* sc) /* sc->code: (tree-member? 1 '(2 3 (4 1) 5)) */ -{ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - sc->code = fx_call (sc, cdr (args)); - set_curlet (sc, update_let_with_two_slots (sc, closure_let (func), - fx_call (sc, args), 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) /* sc->code: (substring? "hiho" "test hih") */ -{ - s7_pointer args= cdr (sc->code), body; - const s7_pointer func= opt1_lambda (sc->code); - sc->code = fx_call (sc, cdr (args)); - sc->value = fx_call (sc, args); - 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)); - body= T_Pair (closure_body (func)); - check_stack_size (sc); - push_stack_no_args (sc, sc->begin_op, T_Pair (cdr (body))); - sc->code= car (body); -} - -static Inline void -inline_op_closure_aa_o (s7_scheme* sc) /* called once in eval, b cb left lg - list, sc->code: (ack1 m (- n 1)) */ -{ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - sc->code = fx_call (sc, cdr (args)); - sc->value = fx_call (sc, args); - 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, - sc->code: (f8 (lambda (x) (+ x 1)) 1) */ -{ - 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) /* sc->code: (slot var expr env expr-env) */ -{ - 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 args= cdr (sc->code), slot= let_slots (let); - is_not_slot_end (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); -} + case HOP_SAFE_C_CA: -static inline void -op_safe_closure_3a (s7_scheme* sc) /* sc->code: (f8 0 0 (list 1)) */ -{ - const s7_pointer args= cdr (sc->code); - const s7_pointer func= opt1_lambda (sc->code); - sc->code = fx_call ( - sc, - cdr (args)); /* fx_call can affect sc->value, but not sc->code, I think */ - sc->args= fx_call (sc, cddr (args)); /* is sc->args safe here? */ - set_curlet (sc, update_let_with_three_slots (sc, closure_let (func), - fx_call (sc, args), sc->code, - sc->args)); - sc->code= closure_body (func); - if_pair_set_up_begin_unchecked (sc); -} + if ((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); -static void -op_safe_closure_na (s7_scheme* sc) /* sc->code: (hi 1 2 3 4) */ -{ - 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; is_not_slot_end (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, sc->args); - set_curlet (sc, let); - sc->code= closure_body (sc->code); - if_pair_set_up_begin_unchecked (sc); + case HOP_SAFE_C_SA: + if ((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_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_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(sc, car(arg))) + { + check_quote(sc, arg); + return(fx_q); + } + return(NULL); } -static /* inline */ void -op_closure_ns (s7_scheme* sc) /* called once in eval, lg?, sc->code: (A k B x1 - x2 x3 x4 x5) */ +#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 { - /* 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 let = inline_make_let (sc, closure_let (func)); - const s7_int id = let_id (let); - begin_temp (sc->y, let); - add_slot_unchecked (sc, let, car (pars), lookup (sc, car (args)), id); - last_slot= let_slots (let); - 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, let); - 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, sc->code: (recompose 32 reverse x) */ -{ - 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, sc->code: - (recur-cond-a-a-a-a-opl3a-l3aq-23 (- x 1) (+ y 1) z) */ -{ - 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) /* sc->code: (f h1 b1 :a) */ -{ - 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) /* sc->code: (recompose 12 char-downcase #\A) */ -{ - 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) /* sc->code: (parse-clauses forms () ops) */ -{ - 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, sc->code: (func (- a 1) - (- b 1) (- c 1)) */ -{ - 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, sc->code: (reinvert 12 vector->list... */ -{ - 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) /* sc->code: (f1 0 "a" L1 V1 S1 H1 E1) */ -{ - 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 let = inline_make_let (sc, closure_let (func)); - s7_pointer slot, last_slot; - sc->z = let; - sc->value= fx_call (sc, exprs); - new_cell_unchecked (sc, last_slot, T_SLOT); - slot_set_symbol_and_value (last_slot, car (pars), sc->value); - slot_set_next (last_slot, let_slots (let)); /* i.e. slot_end */ - let_set_slots (let, 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, let); - sc->z= sc->unused; - let_set_id (let, ++sc->let_number); - for (s7_pointer slot1= let_slots (let); is_not_slot_end (slot1); - slot1 = next_slot (slot1)) { - symbol_set_local_slot (slot_symbol (slot1), let_id (let), 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) || - (local_value_unchecked (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); + set_fx_direct(p, f); + 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); +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));} - 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); +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_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)s7i_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), tree_set_memq_syms_direct); + else set_opt3_direct(cdr(p), 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_p_p_function(global_value(car(p)))); + set_opt3_direct(cdr(p), 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_p_pp_function(global_value(car(p)))); + set_opt3_direct(arg1p, 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_p_pp_function(global_value(car(p)))); + set_opt3_direct(arg1p, 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, memq_2_p_pp); + else set_opt3_direct(p, s7_p_pp_function(global_value(car(p)))); + set_opt3_direct(cdr(p), 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_p_ii_function(global_value(car(p)))); + set_opt3_direct(cdr(p), 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)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_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_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_p_pp_function(global_value(car(p)))); + set_opt2_direct(arg1p, s7_p_p_function(global_value(car(arg1)))); + set_opt3_direct(arg1p, 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);} /* mus_srate, mus_float_equal_fudge_factor clm2xen.c */ +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++]; + q_temp(o).fd = NULL; /* see bool_optimize -- this is a kludge */ +#if S7_DEBUGGING + for (int i = 0; i < num_vunions; i++) o->v[i].p = NULL; +#endif + 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) {opt_info *o = sc->opts[0]; return((q_call(o).fb(o)) ? sc->T : sc->F);} +static s7_pointer opt_float_any_nv(s7_scheme *sc) {opt_info *o = sc->opts[0]; q_call(o).fd(o); return(NULL);} +static s7_pointer opt_int_any_nv(s7_scheme *sc) {opt_info *o = sc->opts[0]; q_call(o).fi(o); return(NULL);} +static s7_pointer opt_bool_any_nv(s7_scheme *sc) {opt_info *o = sc->opts[0]; q_call(o).fb(o); return(NULL);} +static s7_pointer opt_cell_any_nv(s7_scheme *sc) {opt_info *o = sc->opts[0]; return(q_call(o).fp(o));} /* this is faster than returning null */ + +static s7_pointer opt_make_float(s7_scheme *sc) {opt_info *o = sc->opts[0]; return(make_real(sc, q_call(o).fd(o)));} +static s7_pointer opt_make_int(s7_scheme *sc) {opt_info *o = sc->opts[0]; return(make_integer(sc, q_call(o).fi(o)));} +static s7_pointer opt_wrap_cell(s7_scheme *sc) {opt_info *o = sc->opts[0]; return(q_call(o).fp(o));} +static s7_pointer opt_wrap_bool(s7_scheme *sc) {opt_info *o = sc->opts[0]; return((q_call(o).fb(o)) ? sc->T : sc->F);} + +static bool p_to_b(opt_info *o) {return(q_temp(o).fp(o) != o->sc->F);} +static s7_pointer d_to_p(opt_info *o) {return(make_real(o->sc, q_temp(o).fd(o)));} +static s7_pointer d_to_p_nr(opt_info *o) {q_temp(o).fd(o); return(NULL);} +static s7_pointer i_to_p(opt_info *o) {return(make_integer(o->sc, q_temp(o).fi(o)));} +static s7_pointer i_to_p_nr(opt_info *o) {q_temp(o).fi(o); return(NULL);} + +#define q_arg1(o) o->v[1] +#define q_arg2(o) o->v[2] +#define q_arg3(o) o->v[12] +#define q_arg4(o) o->v[13] +#define q_arg5(o) o->v[14] /* 14 shared with q_temp, q_sort maybe others */ +#define q_func(o) o->v[3] +#define q_func1(o) o->v[5] +#define q_func1_arg(o) o->v[4] +#define q_func2(o) o->v[11] +#define q_func2_arg(o) o->v[10] +#define q_func3(o) o->v[9] +#define q_func3_arg(o) o->v[8] +#define q_func4(o) o->v[7] +#define q_func4_arg(o) o->v[6] + +#define q_i_func1_call(o) q_func1(o).fi(q_func1_arg(o).o1) +#define q_d_func1_call(o) q_func1(o).fd(q_func1_arg(o).o1) +#define q_b_func1_call(o) q_func1(o).fb(q_func1_arg(o).o1) +#define q_p_func1_call(o) q_func1(o).fp(q_func1_arg(o).o1) + +#define q_i_func2_call(o) q_func2(o).fi(q_func2_arg(o).o1) +#define q_d_func2_call(o) q_func2(o).fd(q_func2_arg(o).o1) +#define q_b_func2_call(o) q_func2(o).fb(q_func2_arg(o).o1) +#define q_p_func2_call(o) q_func2(o).fp(q_func2_arg(o).o1) + +#define q_i_func3_call(o) q_func3(o).fi(q_func3_arg(o).o1) +#define q_d_func3_call(o) q_func3(o).fd(q_func3_arg(o).o1) +#define q_b_func3_call(o) q_func3(o).fb(q_func3_arg(o).o1) /* none?? */ +#define q_p_func3_call(o) q_func3(o).fp(q_func3_arg(o).o1) + +#define q_i_func4_call(o) q_func4(o).fi(q_func4_arg(o).o1) +#define q_d_func4_call(o) q_func4(o).fd(q_func4_arg(o).o1) +#define q_b_func4_call(o) q_func4(o).fb(q_func4_arg(o).o1) /* none?? */ +#define q_p_func4_call(o) q_func4(o).fp(q_func4_arg(o).o1) + +/* TODO: also q_func(o).call -> q_func_call(o) */ + + +/* -------------------------------- int opts -------------------------------- */ + +static s7_int opt_i_c(opt_info *o) {return(q_arg1(o).i);} +static s7_int opt_i_s(opt_info *o) {return(integer(slot_value(q_arg1(o).p)));} + +static bool opt_int_not_pair(s7_scheme *sc, s7_pointer expr) +{ + opt_info *opc; + if (is_t_integer(expr)) + { + opc = alloc_opt_info(sc); + q_arg1(opc).i = integer(expr); + q_call(opc).fi = opt_i_c; + return_true(sc, expr); + } + { + s7_pointer slot = opt_integer_symbol(sc, expr); + if (!slot) return_false(sc, expr); + opc = alloc_opt_info(sc); + q_arg1(opc).p = slot; + q_call(opc).fi = opt_i_s; + } + return_true(sc, expr); +} + +/* -------- i_i|d|p -------- */ + +static s7_int opt_i_i_c(opt_info *o) {return(q_func(o).i_i_f(q_arg1(o).i));} +static s7_int opt_i_i_s(opt_info *o) {return(q_func(o).i_i_f(integer(slot_value(q_arg1(o).p))));} +static s7_int opt_i_7i_c(opt_info *o) {return(q_func(o).i_7i_f(o->sc, q_arg1(o).i));} +static s7_int opt_i_7i_s(opt_info *o) {return(q_func(o).i_7i_f(o->sc, integer(slot_value(q_arg1(o).p))));} +static s7_int opt_i_7i_s_rand(opt_info *o) {return(random_i_7i(o->sc, integer(slot_value(q_arg1(o).p))));} +static s7_int opt_i_d_c(opt_info *o) {return(q_func(o).i_7d_f(o->sc, q_arg1(o).x));} +static s7_int opt_i_d_s(opt_info *o) {return(q_func(o).i_7d_f(o->sc, real(slot_value(q_arg1(o).p))));} + +static s7_int opt_i_i_f(opt_info *o) {return(q_func(o).i_i_f(q_i_func1_call(o)));} +static s7_int opt_i_7i_f(opt_info *o) {return(q_func(o).i_7i_f(o->sc, q_i_func1_call(o)));} +static s7_int opt_i_7d_f(opt_info *o) {return(q_func(o).i_7d_f(o->sc, q_d_func1_call(o)));} +static s7_int opt_i_7p_f(opt_info *o) {return(q_func(o).i_7p_f(o->sc, q_p_func1_call(o)));} +static s7_int opt_i_7p_f_cint(opt_info *o) {return(char_to_integer_i_7p(o->sc, q_p_func1_call(o)));} /* from opt_set_p_i_f */ + +static s7_int opt_i_i_s_abs(opt_info *o) {return(abs_i_i(integer(slot_value(q_arg1(o).p))));} +static s7_int opt_i_i_f_abs(opt_info *o) {return(abs_i_i(q_i_func1_call(o)));} + +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_pointer arg1_slot; + const s7_pointer arg1 = cadr(expr); + const int32_t start = sc->pc; + q_func1_arg(opc).o1 = sc->opts[start]; + if (!func) + func7 = s7_i_7i_function(s_func); + if ((func) || (func7)) + { + if (func) + q_func(opc).i_i_f = func; + else q_func(opc).i_7i_f = func7; + if (is_t_integer(arg1)) + { + if (q_func(opc).i_i_f == subtract_i_i) + { + q_arg1(opc).i = -integer(arg1); + q_call(opc).fi = opt_i_c; + } + else + { + q_arg1(opc).i = integer(arg1); + q_call(opc).fi = (func) ? opt_i_i_c : opt_i_7i_c; + } + return_true(sc, expr); + } + arg1_slot = opt_integer_symbol(sc, arg1); + if (arg1_slot) + { + q_arg1(opc).p = arg1_slot; + q_call(opc).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))) + { + q_func1(opc).fi = q_call(sc->opts[start]).fi; + q_call(opc).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) + { + q_func(opc).i_7d_f = idf; + if (is_small_real(arg1)) + { + q_arg1(opc).x = s7_number_to_real(sc, arg1); + q_call(opc).fi = opt_i_d_c; + return_true(sc, expr); + } + arg1_slot = opt_float_symbol(sc, arg1); + if (arg1_slot) + { + q_arg1(opc).p = arg1_slot; + q_call(opc).fi = opt_i_d_s; + return_true(sc, expr); + } + if (float_optimize(sc, cdr(expr))) + { + q_call(opc).fi = opt_i_7d_f; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + return_true(sc, expr); + } + sc->pc = start; + }} + { + s7_i_7p_t ipf = s7_i_7p_function(s_func); + if (ipf) + { + q_func(opc).i_7p_f = ipf; + if (cell_optimize(sc, cdr(expr))) + { + q_call(opc).fi = (ipf == char_to_integer_i_7p) ? opt_i_7p_f_cint : opt_i_7p_f; + q_func1(opc).fp = q_call(sc->opts[start]).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(q_func(o).i_7pi_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_pi_ss_ivref(opt_info *o) {return(int_vector(slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_pi_ss_bvref(opt_info *o) {return(byte_vector(slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_7pi_sf(opt_info *o) {return(q_func(o).i_7pi_f(o->sc, slot_value(q_arg1(o).p), q_i_func2_call(o)));} + +/* how can i_7pi_ss be hit? */ + +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)) + { + const 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 arg2_slot; + q_arg1(opc).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); + + q_func(opc).i_7pi_f = pfunc; + arg2_slot = opt_integer_symbol(sc, arg2); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + q_call(opc).fi = opt_i_7pi_ss; + if ((s_func == global_value(sc->int_vector_ref_symbol)) && + (loop_end_fits(q_arg2(opc).p, vector_length(slot_value(q_arg1(opc).p))))) + { + q_call(opc).fi = opt_i_pi_ss_ivref; + q_func(opc).i_7pi_f = int_vector_ref_i_pi_direct; + } + else + if ((s_func == global_value(sc->byte_vector_ref_symbol)) && + (loop_end_fits(q_arg2(opc).p, vector_length(slot_value(q_arg1(opc).p))))) + { + q_call(opc).fi = opt_i_pi_ss_bvref; + q_func(opc).i_7pi_f = byte_vector_ref_i_7pi_direct; + } + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_call(opc).fi = opt_i_7pi_sf; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; /* q_call(o1)? */ + return_true(sc, expr); + } + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- i_ii -------- */ + +static s7_int opt_i_ii_cc(opt_info *o) {return(q_func(o).i_ii_f(q_arg1(o).i, q_arg2(o).i));} +static s7_int opt_i_ii_cs(opt_info *o) {return(q_func(o).i_ii_f(q_arg1(o).i, integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_ii_cs_mul(opt_info *o) {return(q_arg1(o).i * integer(slot_value(q_arg2(o).p)));} +static s7_int opt_i_ii_sc(opt_info *o) {return(q_func(o).i_ii_f(integer(slot_value(q_arg1(o).p)), q_arg2(o).i));} +static s7_int opt_i_ii_sc_add(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) + q_arg2(o).i);} /* +1 is not faster */ +static s7_int opt_i_ii_sc_sub(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) - q_arg2(o).i);} /* -1 is not faster */ +static s7_int opt_i_ii_ss(opt_info *o) {return(q_func(o).i_ii_f(integer(slot_value(q_arg1(o).p)), integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_ii_ss_add(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) + integer(slot_value(q_arg2(o).p)));} +static s7_pointer opt_p_ii_ss_add(opt_info *o) {return(make_integer(o->sc, integer(slot_value(q_arg1(o).p)) + integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_ii_cf(opt_info *o) {return(q_func(o).i_ii_f(q_arg1(o).i, q_i_func2_call(o)));} +static s7_int opt_i_ii_cf_mul(opt_info *o) {return(q_arg1(o).i * q_i_func2_call(o));} +static s7_int opt_i_ii_sf(opt_info *o) {return(q_func(o).i_ii_f(integer(slot_value(q_arg1(o).p)), q_i_func2_call(o)));} +static s7_int opt_i_ii_sf_add(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) + q_i_func2_call(o));} +static s7_int opt_i_ii_fc(opt_info *o) {return(q_func(o).i_ii_f(q_i_func1_call(o), q_arg2(o).i));} +static s7_int opt_i_ii_fc_add(opt_info *o) {return(q_i_func1_call(o) + q_arg2(o).i);} +static s7_int opt_i_ii_fc_mul(opt_info *o) {return(q_i_func1_call(o) * q_arg2(o).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_ii_ff(opt_info *o) {return(q_func(o).i_ii_f(q_i_func1_call(o), q_i_func2_call(o)));} +static s7_int opt_i_7ii_ff_quo(opt_info *o) {return(quotient_i_7ii(o->sc, q_i_func1_call(o), q_i_func2_call(o)));} +static s7_int opt_i_7ii_fc(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, q_i_func1_call(o), q_arg2(o).i));} + +static s7_int opt_i_ii_fco(opt_info *o) +{ + return(q_func(o).i_ii_f(q_func1(o).i_7pi_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))), q_arg3(o).i)); +} + +static s7_int opt_i_ii_fco_ivref_add(opt_info *o) +{ + return(int_vector_ref_i_pi_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))) + q_arg3(o).i); +} /* tref */ + +static s7_int opt_i_7ii_fco(opt_info *o) +{ + return(q_func(o).i_7ii_f(o->sc, q_func1(o).i_7pi_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))), q_arg3(o).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 ((q_call(o1).fi == opt_i_7pi_ss) || (q_call(o1).fi == opt_i_pi_ss_ivref)) + { + q_arg3(opc).i = q_arg2(opc).i; + q_func1(opc).i_7pi_f = q_func(o1).i_7pi_f; + q_arg1(opc).p = q_arg1(o1).p; + q_arg2(opc).p = q_arg2(o1).p; + if (func) + q_call(opc).fi = ((q_func(opc).i_ii_f == add_i_ii) && + (q_func1(opc).i_7pi_f == int_vector_ref_i_pi_direct)) ? opt_i_ii_fco_ivref_add : opt_i_ii_fco; + else q_call(opc).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(q_func(o).i_7ii_f(o->sc, q_arg1(o).i, q_arg2(o).i));} +static s7_int opt_i_7ii_cs(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, q_arg1(o).i, integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_7ii_sc(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, integer(slot_value(q_arg1(o).p)), q_arg2(o).i));} +static s7_int opt_i_7ii_ss(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, integer(slot_value(q_arg1(o).p)), integer(slot_value(q_arg2(o).p))));} +static s7_int opt_i_7ii_cf(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, q_arg1(o).i, q_i_func2_call(o)));} +static s7_int opt_i_7ii_sf(opt_info *o) {return(q_func(o).i_7ii_f(o->sc, integer(slot_value(q_arg1(o).p)), q_i_func2_call(o)));} + +static s7_int opt_i_7ii_ff(opt_info *o) +{ + s7_int i1 = q_i_func1_call(o); + s7_int i2 = q_i_func2_call(o); + return(q_func(o).i_7ii_f(o->sc, i1, i2)); +} + +static s7_int opt_add_i_random_i(opt_info *o) {return(q_arg1(o).i + (s7_int)(q_arg2(o).i * next_random(o->sc->default_random_state)));} +static s7_int opt_subtract_random_i_i(opt_info *o) {return((s7_int)(q_arg1(o).i * next_random(o->sc->default_random_state)) - q_arg2(o).i);} + +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 arg1_slot, arg2_slot; + if (ifunc) + q_func(opc).i_ii_f = ifunc; + else q_func(opc).i_7ii_f = ifunc7; + + if (is_t_integer(arg1)) + { + q_arg1(opc).i = integer(arg1); + if (is_t_integer(arg2)) + { + if (q_func(opc).i_ii_f == add_i_ii) + { + q_arg1(opc).i = integer(arg1) + integer(arg2); /* no overflow check for sc_add case above */ + q_call(opc).fi = opt_i_c; + } + else + { + q_arg2(opc).i = integer(arg2); + q_call(opc).fi = (ifunc) ? opt_i_ii_cc : opt_i_7ii_cc; + } + return_true(sc, expr); + } + arg2_slot = opt_integer_symbol(sc, arg2); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + if (ifunc) + q_call(opc).fi = (q_func(opc).i_ii_f == multiply_i_ii) ? opt_i_ii_cs_mul : opt_i_ii_cs; + else q_call(opc).fi = opt_i_7ii_cs; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + if (ifunc) + { + q_call(opc).fi = opt_i_ii_cf; /* caller(sc->opts[start]).fi -> opt_i_7i_c -> func(same_opt).i_7i_f = random_i_7i tmap */ + if ((ifunc == add_i_ii) && (opc == sc->opts[sc->pc - 2]) && + (q_call(sc->opts[start]).fi == opt_i_7i_c) && + (q_func(sc->opts[start]).i_7i_f == random_i_7i)) + { + q_call(opc).fi = opt_add_i_random_i; + q_arg2(opc).i = q_arg1(sc->opts[start]).i; + backup_pc(sc); + } + else if (ifunc == multiply_i_ii) q_call(opc).fi = opt_i_ii_cf_mul; + } + else q_call(opc).fi = opt_i_7ii_cf; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + return_true(sc, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + /* arg1 not integer */ + arg1_slot = opt_integer_symbol(sc, arg1); + if (arg1_slot) + { + q_arg1(opc).p = arg1_slot; + if (is_t_integer(arg2)) + { + q_arg2(opc).i = integer(arg2); + if (ifunc) + { + if (q_func(opc).i_ii_f == add_i_ii) + q_call(opc).fi = opt_i_ii_sc_add; + else q_call(opc).fi = (q_func(opc).i_ii_f == subtract_i_ii) ? opt_i_ii_sc_sub : opt_i_ii_sc; /* add1/sub1 are not faster */ + } + else q_call(opc).fi = opt_i_7ii_sc; + if ((car(expr) == sc->modulo_symbol) && + (integer(arg2) > 1)) + q_func(opc).i_ii_f = modulo_i_ii_unchecked; + else + { + if (car(expr) == sc->ash_symbol) + { + if (q_arg2(opc).i < 0) + { + q_func(opc).i_ii_f = (q_arg2(opc).i == -1) ? rsh_i_i2_direct : rsh_i_ii_unchecked; + q_call(opc).fi = opt_i_ii_sc; + } + else + if (q_arg2(opc).i < S7_INT_BITS) + { + q_func(opc).i_ii_f = lsh_i_ii_unchecked; + q_call(opc).fi = opt_i_ii_sc; + }} + else + if (q_arg2(opc).i > 0) + { + /* these assume vunion is a union, not a struct; i_7ii_f otherwise might be leftover from a previous use */ + if (q_func(opc).i_7ii_f == quotient_i_7ii) + { + q_func(opc).i_ii_f = quotient_i_ii_unchecked; + q_call(opc).fi = opt_i_ii_sc; + } + else + if ((q_arg2(opc).i > 1) && (q_func(opc).i_7ii_f == remainder_i_7ii)) + { + q_func(opc).i_ii_f = remainder_i_ii_unchecked; + q_call(opc).fi = opt_i_ii_sc; + }}} + return_true(sc, expr); + } + + /* arg2 not integer, arg1 is int symbol */ + arg2_slot = opt_integer_symbol(sc, arg2); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + if (ifunc) + q_call(opc).fi = (q_func(opc).i_ii_f == add_i_ii) ? opt_i_ii_ss_add : opt_i_ii_ss; + else q_call(opc).fi = opt_i_7ii_ss; + return_true(sc, expr); + } + if (int_optimize(sc, cddr(expr))) + { + q_func2_arg(opc).o1 = sc->opts[start]; + q_func2(opc).fi = q_call(sc->opts[start]).fi; + if (ifunc) + q_call(opc).fi = (q_func(opc).i_ii_f == add_i_ii) ? opt_i_ii_sf_add : opt_i_ii_sf; + else q_call(opc).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)) + { + q_arg2(opc).i = integer(arg2); + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + if (!i_ii_fc_combinable(sc, opc, ifunc)) + { + if (ifunc) + { + if (q_func(opc).i_ii_f == add_i_ii) {q_call(opc).fi = opt_i_ii_fc_add; return_true(sc, expr);} + if (q_func(opc).i_ii_f == multiply_i_ii) {q_call(opc).fi = opt_i_ii_fc_mul; return_true(sc, expr);} + q_call(opc).fi = opt_i_ii_fc; + + if ((q_func(opc).i_ii_f == subtract_i_ii) && (opc == sc->opts[sc->pc - 2]) && + (q_call(sc->opts[start]).fi == opt_i_7i_c) && + (q_func(sc->opts[start]).i_7i_f == random_i_7i)) + { + q_call(opc).fi = opt_subtract_random_i_i; + q_arg1(opc).i = q_arg1(sc->opts[start]).i; + backup_pc(sc); + }} + else q_call(opc).fi = opt_i_7ii_fc; + if (q_arg2(opc).i > 0) + { + if (q_func(opc).i_7ii_f == quotient_i_7ii) + { + q_func(opc).i_ii_f = quotient_i_ii_unchecked; + q_call(opc).fi = opt_i_ii_fc; + } + else + if ((q_arg2(opc).i > 1) && (q_func(opc).i_7ii_f == remainder_i_7ii)) + { + q_func(opc).i_ii_f = remainder_i_ii_unchecked; + q_call(opc).fi = opt_i_ii_fc; + }}} + return_true(sc, expr); + } + sc->pc = start; + return_false(sc, expr); + } + + /* arg1 not integer or symbol, arg2 not integer */ + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_call(opc).fi = (ifunc) ? opt_i_ii_ff : ((q_func(opc).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 = q_i_func1_call(o); + s7_int i2 = q_i_func2_call(o); + s7_int i3 = q_i_func3_call(o); + return(q_func(o).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); + q_func1_arg(opc).o1 = sc->opts[start]; + if (int_optimize(sc, cdr(expr))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(expr))) + { + q_func(opc).i_iii_f = ifunc; + q_call(opc).fi = opt_i_iii_fff; + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).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(q_func(o).i_7pii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_i_func1_call(o))); +} + +static s7_int opt_i_7pii_ssf_vset(opt_info *o) +{ + return(int_vector_set_i_7pii_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_i_func1_call(o))); +} + +static s7_int opt_i_7pii_ssc(opt_info *o) +{ + return(q_func(o).i_7pii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_arg3(o).i)); +} + +static s7_int opt_i_7pii_sss(opt_info *o) +{ + return(q_func(o).i_7pii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)))); +} + +static s7_int opt_i_pii_sss_ivref_unchecked(opt_info *o) +{ + s7_pointer vec = slot_value(q_arg1(o).p); + return(int_vector(vec, ((integer(slot_value(q_arg2(o).p)) * vector_offset(vec, 0)) + integer(slot_value(q_arg3(o).p))))); +} + +static s7_int opt_i_7pii_sif(opt_info *o) +{ + return(q_func(o).i_7pii_f(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i, q_i_func3_call(o))); +} + +static s7_int opt_i_7pii_sff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + s7_int i2 = q_i_func3_call(o); + return(q_func(o).i_7pii_f(o->sc, slot_value(q_arg1(o).p), i1, i2)); +} + +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 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); + +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, arg2_slot; + const int32_t start = sc->pc; + q_arg1(opc).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); + arg2_slot = opt_integer_symbol(sc, arg2); + if (arg2_slot) + { + s7_pointer arg3_slot; + q_arg2(opc).p = arg2_slot; + arg3_slot = opt_integer_symbol(sc, cadddr(expr)); + if (arg3_slot) + { + q_arg3(opc).p = arg3_slot; + q_func(opc).i_7pii_f = pfunc; + q_call(opc).fi = opt_i_7pii_sss; + if ((pfunc == int_vector_ref_i_7pii) && + (loop_end_fits(q_arg2(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 1)))) + q_call(opc).fi = opt_i_pii_sss_ivref_unchecked; + return_true(sc, expr); + } + if (int_optimize(sc, cdddr(expr))) + { + q_func(opc).i_7pii_f = pfunc; + q_call(opc).fi = opt_i_7pii_ssf; + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fi = q_call(sc->opts[start]).fi; + return_true(sc, expr); + } + return_false(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(expr))) + { + q_func(opc).i_7pii_f = pfunc; + q_call(opc).fi = opt_i_7pii_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + return_true(sc, expr); + }} + sc->pc = start; + }} + return_false(sc, expr); +} + +/* -------- i_7piii -------- */ + +static s7_int opt_i_7piii_sssf(opt_info *o) +{ + return(q_func(o).i_7piii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), + integer(slot_value(q_arg3(o).p)), q_i_func3_call(o))); +} + +static s7_int opt_i_piii_sssf_ivset_unchecked(opt_info *o) +{ + s7_pointer vec = slot_value(q_arg1(o).p); + s7_int val = q_i_func3_call(o); + int_vector(vec, ((integer(slot_value(q_arg2(o).p)) * vector_offset(vec, 0)) + integer(slot_value(q_arg3(o).p)))) = val; + return(val); +} + +static s7_int opt_i_7piii_sssc(opt_info *o) +{ + return(q_func(o).i_7piii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), + integer(slot_value(q_arg3(o).p)), q_arg4(o).i)); +} + +static s7_int opt_i_7piii_ssss(opt_info *o) +{ + return(q_func(o).i_7piii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), + integer(slot_value(q_arg3(o).p)), integer(slot_value(q_arg4(o).p)))); +} + +static s7_int opt_i_7piii_sfff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + s7_int i2 = q_i_func3_call(o); + s7_int i3 = q_i_func4_call(o); + return(q_func(o).i_7piii_f(o->sc, slot_value(q_arg1(o).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->[5] is the called function (int-vector-set! etc) */ + s7_pointer slot2 = opt_integer_symbol(sc, car(indexp2)); + if (slot2) + { + s7_pointer slot1; + q_arg3(opc).p = slot2; + slot1 = opt_integer_symbol(sc, car(indexp1)); + if (slot1) + { + s7_pointer slot3; + q_arg2(opc).p = slot1; + if (is_t_integer(car(valp))) + { + q_call(opc).fi = opt_i_7piii_sssc; + q_arg4(opc).i = integer(car(valp)); + return_true(sc, NULL); + } + slot3 = opt_integer_symbol(sc, car(valp)); + if (slot3) + { + q_arg4(opc).p = slot3; + q_call(opc).fi = opt_i_7piii_ssss; + return_true(sc, NULL); + } + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, valp)) + { + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + q_call(opc).fi = opt_i_7piii_sssf; + if ((q_func(opc).i_7piii_f == int_vector_set_i_7piii) && + (loop_end_fits(q_arg2(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 1)))) + q_call(opc).fi = opt_i_piii_sssf_ivset_unchecked; + return_true(sc, NULL); + }} + return_false(sc, valp); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) + { + q_func4_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, valp)) + { + q_call(opc).fi = opt_i_7piii_sfff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + q_func4(opc).fi = q_func4_arg(opc).q_call(o1).fi; + 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)))) + { + const s7_pointer vect = slot_value(settee); + const bool int_case = (is_int_vector(vect)); + q_arg1(opc).p = settee; /* either ipii or ipiii arg1 */ + 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)) /* q_ipii case */ + { + s7_pointer slot; + q_func(opc).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; + q_arg2(opc).p = slot; + if (loop_end_fits(q_arg2(opc).p, vector_length(vect))) + q_func(opc).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)))) + { + q_arg3(opc).i = integer(car(valp)); + q_call(opc).fi = opt_i_7pii_ssc; + return_true(sc, NULL); + } + if (!int_optimize(sc, valp)) + return_false(sc, valp); + q_call(opc).fi = (q_func(opc).i_7pii_f == int_vector_set_i_7pii_direct) ? opt_i_7pii_ssf_vset : opt_i_7pii_ssf; + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fi = q_call(sc->opts[start]).fi; + return_true(sc, NULL); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, valp)) + { + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + if (q_func2(opc).fi == opt_i_c) /* (int-vector-set! v 0 (floor (sqrt i))) */ + { + q_call(opc).fi = opt_i_7pii_sif; + q_arg2(opc).i = q_func2_arg(opc).q_arg1(o1).i; + } + else q_call(opc).fi = opt_i_7pii_sff; + return_true(sc, NULL); + }} + return_false(sc, valp); + } + if ((indexp2) && + (vector_rank(vect) == 2)) /* q_ipiii case */ + { + q_func(opc).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 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) && /* ipi case */ + (vector_rank(obj) == 1)) + { + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + slot = opt_integer_symbol(sc, cadr(expr)); + if (slot) + { + q_call(opc).fi = opt_i_7pi_ss; + q_func(opc).i_7pi_f = (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; + q_arg2(opc).p = slot; + if (loop_end_fits(q_arg2(opc).p, vector_length(obj))) + q_func(opc).i_7pi_f = (int_case) ? int_vector_ref_i_pi_direct : byte_vector_ref_i_7pi_direct; + /* not q_call(opc).fi = opt_i_pi_ss_ivref -- this causes a huge slowdown in dup.scm?? */ + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(expr))) + return_false(sc, expr); + q_call(opc).fi = opt_i_7pi_sf; + q_func(opc).i_7pi_f = (int_case) ? int_vector_ref_i_7pi : byte_vector_ref_i_7pi; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + return_true(sc, expr); + } + if ((len == 3) && /* ipii case */ + (vector_rank(obj) == 2)) + { + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + slot = opt_integer_symbol(sc, cadr(expr)); + if (slot) + { + q_arg2(opc).p = slot; + slot = opt_integer_symbol(sc, caddr(expr)); + if (!slot) + return_false(sc, expr); + q_func(opc).i_7pii_f = (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; + q_arg3(opc).p = slot; + q_call(opc).fi = opt_i_7pii_sss; + if ((int_case) && + (loop_end_fits(q_arg2(opc).p, vector_dimension(obj, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(obj, 1)))) + q_call(opc).fi = opt_i_pii_sss_ivref_unchecked; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func(opc).i_7pii_f = (int_case) ? int_vector_ref_i_7pii : byte_vector_ref_i_7pii; + q_call(opc).fi = opt_i_7pii_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + return_true(sc, expr); + }}}} + 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 func = s7_i_7piii_function(s_func); + if ((func) && (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)) + { + q_func(opc).i_7piii_f = func; + q_arg1(opc).p = settee; + return(opt_i_7piii_args(sc, opc, cddr(expr), cdddr(expr), cddddr(expr))); + }}} + return_false(sc, expr); +} + +/* -------- i_add|multiply_any -------- */ + +#define q_i_am_args(o) o->v[1] +#define q_i_am_arg(o, i) o->v[i + 2] +#define q_i_am_func(o, i) o->v[i + 6] /* the following are for the special cases (2-4 args), not i_add_any_f */ +#define q_i_am_func1_arg(o) o->v[2] +#define q_i_am_func1(o) o->v[6] +#define q_i_am_func2_arg(o) o->v[3] +#define q_i_am_func2(o) o->v[7] +#define q_i_am_func3_arg(o) o->v[4] +#define q_i_am_func3(o) o->v[8] +#define q_i_am_func4_arg(o) o->v[5] +#define q_i_am_func4(o) o->v[9] + +#define q_i_am_func1_call(o) q_i_am_func1(o).fi(q_i_am_func1_arg(o).o1) +#define q_i_am_func2_call(o) q_i_am_func2(o).fi(q_i_am_func2_arg(o).o1) +#define q_i_am_func3_call(o) q_i_am_func3(o).fi(q_i_am_func3_arg(o).o1) +#define q_i_am_func4_call(o) q_i_am_func4(o).fi(q_i_am_func4_arg(o).o1) + +static s7_int opt_i_add_any_f(opt_info *o) +{ + s7_int sum = 0; + for (s7_int i = 0; i < q_i_am_args(o).i; i++) + { + opt_info *o1 = q_i_am_arg(o, i).o1; +#if WITH_WARNINGS && HAVE_OVERFLOW_CHECKS + s7_int new_val, val = q_call(o1).fi(o1); /* this is not worth all this bother */ + if (add_overflow(sum, val, &new_val)) + { + s7_warn(o->sc, 128, "integer add overflow: (+ %" ld64 " %" ld64 ")\n", sum, val); + return(sum); + } + sum = new_val; +#else + sum += q_call(o1).fi(o1); +#endif + } + return(sum); +} + +static s7_int opt_i_add2(opt_info *o) +{ + s7_int sum = q_i_am_func1_call(o); + return(sum + q_i_am_func2_call(o)); +} + +static s7_int opt_i_mul2(opt_info *o) +{ + s7_int sum = q_i_am_func1_call(o); + return(sum * q_i_am_func2_call(o)); +} + +static s7_int opt_i_add3(opt_info *o) +{ + s7_int sum = q_i_am_func1_call(o); + sum += q_i_am_func2_call(o); + return(sum + q_i_am_func3_call(o)); +} + +static s7_int opt_i_mul3(opt_info *o) +{ + s7_int sum = q_i_am_func1_call(o); + sum *= q_i_am_func2_call(o); + return(sum * q_i_am_func3_call(o)); +} + +static s7_int opt_i_add4(opt_info *o) +{ + s7_int sum = q_i_am_func1_call(o); + sum += q_i_am_func2_call(o); + sum += q_i_am_func3_call(o); + return(sum + q_i_am_func4_call(o)); +} + +static s7_int opt_i_mul4(opt_info *o) +{ + s7_int sum = q_i_am_func1_call(o); + sum *= q_i_am_func2_call(o); + sum *= q_i_am_func3_call(o); + return(sum * q_i_am_func4_call(o)); +} + +static s7_int opt_i_mul_any_f(opt_info *o) +{ + s7_int sum = 1; + for (s7_int i = 0; i < q_i_am_args(o).i; i++) + { + opt_info *o1 = q_i_am_arg(o, i).o1; + sum *= q_call(o1).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 < (num_vunions - 2)); p = cdr(p), cur_len++) + { + q_i_am_arg(opc, cur_len).o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, p)) + break; + } + if (is_null(p)) + { + q_i_am_args(opc).i = cur_len; + if (cur_len <= 4) + for (int32_t i = 0; i < cur_len; i++) + q_i_am_func(opc, i).fi = q_i_am_arg(opc, i).q_call(o1).fi; + if (cur_len == 2) + q_call(opc).fi = (head == sc->add_symbol) ? opt_i_add2 : opt_i_mul2; + else + if (cur_len == 3) + q_call(opc).fi = (head == sc->add_symbol) ? opt_i_add3 : opt_i_mul3; + else + if (cur_len == 4) + q_call(opc).fi = (head == sc->add_symbol) ? opt_i_add4 : opt_i_mul4; + else q_call(opc).fi = (head == sc->add_symbol) ? opt_i_add_any_f : opt_i_mul_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 = q_func(o).fi(q_arg2(o).o1); + slot_set_value(q_arg1(o).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(q_arg1(o).p))) + { + fprintf(stderr, "%s[%d]: %s value is not mutable", func, line, display(q_arg1(o).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 = q_func(o).fi(q_arg2(o).o1); + check_mutability(o->sc, o, __func__, __LINE__); + set_integer(slot_value(q_arg1(o).p), x); + return(x); +} + +static s7_int opt_set_i_i_fo(opt_info *o) +{ + s7_int x = integer(slot_value(q_arg3(o).p)) + q_arg2(o).i; + slot_set_value(q_arg1(o).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(q_arg3(o).p)) + q_arg2(o).i; + check_mutability(o->sc, o, __func__, __LINE__); + set_integer(slot_value(q_arg1(o).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 (q_call(o1).fi == opt_i_ii_sc_add) + { + q_arg3(opc).p = q_arg1(o1).p; /* i_iii, arg1(o) set earlier */ + q_arg2(opc).i = q_arg2(o1).i; /* i_iii */ + q_call(opc).fi = opt_set_i_i_fo; + backup_pc(sc); + return_true(sc, NULL); + }} + 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]; + q_arg1(opc).p = settee; + if (int_optimize(sc, cddr(expr))) + { + if (set_i_i_f_combinable(sc, opc)) + return_true(sc, expr); + q_call(opc).fi = (is_mutable_integer(slot_value(q_arg1(opc).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 */ + q_arg2(opc).o1 = o1; + q_func(opc).fi = q_call(o1).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); +} + + +/* ------------------------------------- float opts ------------------------------------------- */ +static s7_double opt_d_c(opt_info *o) {return(q_arg1(o).x);} +static s7_double opt_d_s(opt_info *o) {return(real(slot_value(q_arg1(o).p)));} + +static s7_double opt_D_s(opt_info *o) +{ + s7_pointer x = slot_value(q_arg1(o).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 slot; + if (is_small_real(expr)) + { + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).x = s7_number_to_real(sc, expr); + q_call(opc).fd = opt_d_c; + return_true(sc, expr); + } + slot = opt_real_symbol(sc, expr); + if (slot) + { + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = slot; + q_call(opc).fd = (is_t_real(slot_value(slot))) ? 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(q_func(o).d_f());} + +static bool d_ok(s7_scheme *sc, opt_info *opc, s7_pointer s_func) /* (f): (mus-srate), ignore damned ccpcheck! */ +{ + const s7_d_t func = s7_d_function(s_func); + if (!func) return_false(sc, NULL); + q_call(opc).fd = opt_d_f; + q_func(opc).d_f = func; + return_true(sc, NULL); +} + +/* -------- d_d -------- */ + +static s7_double opt_d_d_c(opt_info *o) {return(q_func(o).d_d_f(q_arg1(o).x));} +static s7_double opt_d_d_s(opt_info *o) {return(q_func(o).d_d_f(real(slot_value(q_arg1(o).p))));} +static s7_double opt_d_d_s_abs(opt_info *o) {return(abs_d_d(real(slot_value(q_arg1(o).p))));} +static s7_double opt_d_7d_c(opt_info *o) {return(q_func(o).d_7d_f(o->sc, q_arg1(o).x));} +static s7_double opt_d_7d_s(opt_info *o) {return(q_func(o).d_7d_f(o->sc, real(slot_value(q_arg1(o).p))));} + +static s7_double opt_d_d_f(opt_info *o) {return(q_func(o).d_d_f(q_d_func1_call(o)));} +static s7_double opt_d_d_f_abs(opt_info *o) {return(abs_d_d(q_d_func1_call(o)));} +static s7_double opt_d_d_f_sin(opt_info *o) {return(sin_d_d(q_d_func1_call(o)));} +static s7_double opt_d_d_f_cos(opt_info *o) {return(cos_d_d(q_d_func1_call(o)));} +static s7_double opt_d_7d_f(opt_info *o) {return(q_func(o).d_7d_f(o->sc, q_d_func1_call(o)));} +static s7_double opt_d_7d_f_divide(opt_info *o) {return(divide_d_7d(o->sc, q_d_func1_call(o)));} + +static s7_double opt_abs_d_ss_fvref(opt_info *o); +static s7_double opt_d_7pi_ss_fvref_direct(opt_info *o); + +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 arg1_slot; + const s7_pointer arg1 = cadr(expr); + if (func) + q_func(opc).d_d_f = func; + else q_func(opc).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); + q_arg1(opc).x = s7_number_to_real(sc, arg1); + q_call(opc).fd = (func) ? opt_d_d_c : opt_d_7d_c; + return_true(sc, expr); + } + arg1_slot = opt_float_symbol(sc, arg1); + if ((arg1_slot) && + (!has_methods(slot_value(arg1_slot)))) + { + q_arg1(opc).p = arg1_slot; + q_call(opc).fd = (func) ? ((func == abs_d_d) ? opt_d_d_s_abs : opt_d_d_s) : opt_d_7d_s; + return_true(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + q_call(opc).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 (q_call(opc).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) */ + q_func1(opc).fd = q_func1_arg(opc).q_call(o1).fd; + if ((func == abs_d_d) && (q_func1(opc).fd == opt_d_7pi_ss_fvref_direct)) + q_call(opc).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(q_func(o).d_v_f(q_arg1(o).gen));} + +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) or (next-sample reader) */ + { + s7_pointer slot = opt_types_match(sc, cadr(sig), cadr(expr)); + if (slot) + { + q_arg1(opc).gen = (void *)c_object_value(slot_value(slot)); + q_func(opc).d_v_f = flt_func; + q_call(opc).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(q_func(o).d_p_f(slot_value(q_arg1(o).p)));} +static s7_double opt_d_p_f(opt_info *o) {return(q_func(o).d_p_f(q_p_func1_call(o)));} +static s7_double opt_d_7p_s(opt_info *o) {return(q_func(o).d_7p_f(o->sc, slot_value(q_arg1(o).p)));} +static s7_double opt_d_7p_f(opt_info *o) {return(q_func(o).d_7p_f(o->sc, q_p_func1_call(o)));} + +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 like one_pole (none built-in in s7) */ + s7_d_7p_t d7pf; + if (!dpf) d7pf = s7_d_7p_function(s_func); + if ((!dpf) && (!d7pf)) + return_false(sc, expr); + if (dpf) q_func(opc).d_p_f = dpf; else q_func(opc).d_7p_f = d7pf; + if (is_symbol(cadr(expr))) + { + s7_pointer slot = opt_simple_symbol(sc, cadr(expr)); + if (!slot) + return_false(sc, expr); + q_arg1(opc).p = slot; + q_call(opc).fd = (dpf) ? opt_d_p_s : opt_d_7p_s; + return_true(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + q_call(opc).fd = (dpf) ? opt_d_p_f : opt_d_7p_f; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).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(q_func(o).d_7pi_f(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i));} +static s7_double opt_d_7pi_ss(opt_info *o) {return(q_func(o).d_7pi_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_double opt_d_7pi_sf(opt_info *o) {return(q_func(o).d_7pi_f(o->sc, slot_value(q_arg1(o).p), q_i_func2_call(o)));} +static s7_double opt_d_7pi_ss_fvref(opt_info *o) {return(float_vector_ref_d_7pi(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_double opt_d_7pi_ss_fvref_direct(opt_info *o) {return(float_vector(slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} + +static s7_double opt_abs_d_ss_fvref(opt_info *o) +{ + opt_info *o1 = q_func1_arg(o).o1; + return(abs_d_d(float_vector(slot_value(q_arg1(o1).p), integer(slot_value(q_arg2(o1).p))))); +} + +static s7_double opt_d_7pi_ff(opt_info *o) /* hit only in tbig (not even s7test) */ +{ + s7_pointer seq = q_p_func1_call(o); + return(q_func(o).d_7pi_f(o->sc, seq, q_i_func2_call(o))); +} + +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); + } + q_func(opc).d_7pi_f = ifunc; + if (is_symbol(cadr(expr))) /* (float-vector-ref v i) */ + { + s7_pointer arg2, arg2_slot, obj; + q_arg1(opc).p = s7_slot(sc, cadr(expr)); + if (!is_slot(q_arg1(opc).p)) return_false(sc, expr); + + obj = slot_value(q_arg1(opc).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)) + { + q_arg2(opc).i = integer(arg2); + q_call(opc).fd = opt_d_7pi_sc; + return_true(sc, expr); + } + arg2_slot = opt_integer_symbol(sc, arg2); + if (!arg2_slot) + return_false(sc, expr); + q_arg2(opc).p = arg2_slot; + q_call(opc).fd = opt_d_7pi_ss; + if (is_target_or_its_alias(car(expr), s_func, sc->float_vector_ref_symbol)) + { + q_call(opc).fd = (loop_end_fits(q_arg2(opc).p, vector_length(obj))) ? opt_d_7pi_ss_fvref_direct : opt_d_7pi_ss_fvref; + if (q_call(opc).fd == opt_d_7pi_ss_fvref_direct) q_func(opc).d_7pi_f = float_vector_ref_d_7pi_direct; + } + return_true(sc, expr); + } + if (int_optimize(sc, cddr(expr))) + { + q_call(opc).fd = opt_d_7pi_sf; + q_func2_arg(opc).o1 = sc->opts[start]; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).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))) + { + q_call(opc).fd = opt_d_7pi_ff; + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fp = q_call(sc->opts[start]).fp; + q_func2_arg(opc).o1 = o2; + q_func2(opc).fi = q_call(o2).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(q_func(o).d_ip_f(integer(slot_value(q_arg1(o).p)), slot_value(q_arg2(o).p)));} + +static bool d_ip_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) /* ina/inb clm2xen, ffitest, tgen etc */ +{ + const s7_d_ip_t pfunc = s7_d_ip_function(s_func); + if ((pfunc) && (is_symbol(caddr(expr)))) + { + s7_pointer arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + q_func(opc).d_ip_f = pfunc; + q_arg1(opc).p = arg1_slot; + q_arg2(opc).p = s7_t_slot(sc, caddr(expr)); + if (is_slot(q_arg2(opc).p)) /* (with-sound (:reverb jc-reverb) (fm-violin 0 .1 440 .4 :reverb-amount .5)) */ + { + q_call(opc).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(q_func(o).d_pd_f(slot_value(q_arg1(o).p), q_d_func2_call(o)));} +static s7_double opt_d_pd_ss(opt_info *o) {return(q_func(o).d_pd_f(slot_value(q_arg1(o).p), real(slot_value(q_arg2(o).p))));} + +static bool d_pd_ok(s7_scheme *sc, opt_info *opc, const s7_pointer s_func, const s7_pointer expr) /* none built-in, many in clm2xen but they're almost never called */ +{ + if (is_symbol(cadr(expr))) + { + const s7_d_pd_t func = s7_d_pd_function(s_func); + if (func) + { + s7_pointer arg2_slot; + const s7_pointer arg2 = caddr(expr); + const int32_t start = sc->pc; + q_func(opc).d_pd_f = func; + q_arg1(opc).p = s7_t_slot(sc, cadr(expr)); + if (!is_slot(q_arg1(opc).p)) return_false(sc, expr); + arg2_slot = opt_float_symbol(sc, arg2); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + q_call(opc).fd = opt_d_pd_ss; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_call(opc).fd = opt_d_pd_sf; + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).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(q_func(o).d_vd_f(q_arg1(o).gen, q_arg2(o).x));} +static s7_double opt_d_vd_s(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, real(slot_value(q_arg2(o).p))));} +static s7_double opt_d_vd_f(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, q_d_func3_call(o)));} +static s7_double opt_d_vd_o(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, q_func3(o).d_v_f(q_func2_arg(o).gen)));} +static s7_double opt_d_vd_o1_mul(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, real(slot_value(q_arg2(o).p)) * q_d_func2_call(o)));} +static s7_double opt_d_vd_o3(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, q_func3(o).d_dd_f(q_func2_arg(o).x, real(slot_value(q_arg2(o).p)))));} +static s7_double opt_d_vd_ff(opt_info *o) {return(q_func(o).d_vd_f(q_arg1(o).gen, q_func3(o).d_vd_f(q_func3_arg(o).gen, q_d_func2_call(o))));} + +static s7_double opt_d_vd_o1(opt_info *o) +{ + return(q_func(o).d_vd_f(q_arg1(o).gen, q_func3(o).d_dd_f(real(slot_value(q_arg2(o).p)), q_d_func2_call(o)))); +} + +static s7_double opt_d_vd_o2(opt_info *o) +{ + return(q_func3(o).d_vd_f(q_arg3(o).gen, q_func1(o).d_vd_f(q_arg2(o).gen, real(slot_value(q_arg4(o).p))))); +} + +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 (q_call(o1).fd == opt_d_v) + { + q_func2_arg(opc).gen = q_arg1(o1).gen; + q_func3(opc).d_v_f = q_func(o1).d_v_f; + q_call(opc).fd = opt_d_vd_o; + backup_pc(sc); + return_true(sc, NULL); + } + if (q_call(o1).fd == opt_d_vd_s) + { + q_func3(opc).d_vd_f = q_func(opc).d_vd_f; /* [4] <- opc[3] */ + q_arg3(opc).gen = q_arg1(opc).gen; /* [12] <- opc[5] */ + q_func1(opc).d_vd_f = q_func(o1).d_vd_f; /* [5] <- o1[3] */ + q_arg2(opc).gen = q_arg1(o1).gen; /* [2] <- o1[5] */ + q_arg4(opc).p = q_arg2(o1).p; /* [13] <- o1[2] */ + q_call(opc).fd = opt_d_vd_o2; + backup_pc(sc); + return_true(sc, NULL); + } + if (q_call(o1).fd == opt_d_dd_cs) + { + q_func3(opc).d_dd_f = q_func(o1).d_dd_f; + q_func2_arg(opc).x = q_arg1(o1).x; + /* fprintf(stderr, "arg1: %f, arg2: %s\n", q_arg1(o1).x, display(q_arg2(o1).p)); */ + q_arg2(opc).p = T_Slt(q_arg2(o1).p); + q_call(opc).fd = opt_d_vd_o3; + backup_pc(sc); + return_true(sc, NULL); + } + if ((q_call(o1).fd == opt_d_dd_sf_mul) || (q_call(o1).fd == opt_d_dd_sf) || (q_call(o1).fd == opt_d_dd_sf_add)) + { + q_arg2(opc).p = q_arg1(o1).p; + q_func3(opc).d_dd_f = q_func(o1).d_dd_f; /* unused in opt_d_vd_o1_mul (=> mul) */ + q_call(opc).fd = (q_call(o1).fd == opt_d_dd_sf_mul) ? opt_d_vd_o1_mul : opt_d_vd_o1; + q_func2(opc).fd = q_func1(o1).fd; + q_func2_arg(opc).o1 = q_func1_arg(o1).o1; + return_true(sc, NULL); + } + if (q_call(o1).fd == opt_d_vd_f) + { + q_func3(opc).d_vd_f = q_func(o1).d_vd_f; + q_func3_arg(opc).gen = q_arg1(o1).gen; + q_call(opc).fd = opt_d_vd_ff; + q_func2(opc).fd = q_func3(o1).fd; + q_func2_arg(opc).o1 = q_func3_arg(o1).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; + q_func(opc).d_vd_f = vfunc; + if (!is_pair(arg2)) + { + q_arg1(opc).p = slot; + q_arg1(opc).gen = (void *)c_object_value(slot_value(slot)); + if (is_small_real(arg2)) + { + q_arg2(opc).x = s7_number_to_real(sc, arg2); + q_call(opc).fd = opt_d_vd_c; + return_true(sc, expr); + } + q_arg2( opc).p = s7_t_slot(sc, arg2); + if (is_slot(q_arg2(opc).p)) + { + if (is_t_real(slot_value(q_arg2(opc).p))) + { + q_call(opc).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); + q_call(opc).fd = opt_d_vd_f; + q_func3_arg(opc).o1 = sc->opts[start]; + q_func3(opc).fd = q_call(sc->opts[start]).fd; + return_true(sc, expr); + }} + else /* is pair arg2 */ + { + if (float_optimize(sc, cddr(expr))) + { + q_arg1(opc).gen = (void *)c_object_value(slot_value(slot)); + if (d_vd_f_combinable(sc, start)) + return_true(sc, expr); + q_call(opc).fd = opt_d_vd_f; + q_func3_arg(opc).o1 = sc->opts[start]; + q_func3(opc).fd = q_call(sc->opts[start]).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(q_func(o).d_id_f(integer(slot_value(q_arg1(o).p)), real(slot_value(q_arg2(o).p))));} +static s7_double opt_d_i2_mul(opt_info *o) {s7_int p = integer(slot_value(q_arg1(o).p)); return(p * p);} +static s7_double opt_d_id_sf(opt_info *o) {return(q_func(o).d_id_f(integer(slot_value(q_arg1(o).p)), q_d_func1_call(o)));} +static s7_double opt_d_id_sc(opt_info *o) {return(q_func(o).d_id_f(integer(slot_value(q_arg1(o).p)), q_arg2(o).x));} +static s7_double opt_d_id_cf(opt_info *o) {return(q_func(o).d_id_f(q_arg1(o).i, q_d_func1_call(o)));} +static s7_double opt_d_id_sfo1(opt_info *o) {return(q_func(o).d_id_f(integer(slot_value(q_arg1(o).p)), q_func1(o).d_v_f(q_arg2(o).gen)));} + +static s7_double opt_d_id_sfo(opt_info *o) +{ + return(q_func(o).d_id_f(integer(slot_value(q_arg1(o).p)), q_func1(o).d_vd_f(q_arg3(o).gen, real(slot_value(q_arg2(o).p))))); +} + +static s7_double opt_d_id_ff(opt_info *o) +{ + s7_int x1 = q_i_func1_call(o); + return(q_func(o).d_id_f(x1, q_d_func2_call(o))); +} + +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 (q_call(o1).fd == opt_d_vd_s) + { + q_arg3(opc).gen = q_arg1(o1).gen; + q_func1(opc).d_vd_f = q_func(o1).d_vd_f; + q_arg2(opc).p = q_arg2(o1).p; + q_call(opc).fd = opt_d_id_sfo; /* not in s7test (see tgen) */ + backup_pc(sc); + return_true(sc, NULL); + } + if (q_call(o1).fd == opt_d_v) + { + q_arg2(opc).gen = q_arg1(o1).gen; + q_func1(opc).d_v_f = q_func(o1).d_v_f; + q_call(opc).fd = opt_d_id_sfo1; /* not in s7test (tgen) */ + 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 arg1_slot; + 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); + q_func(opc).d_id_f = flt_func; + arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + const s7_pointer arg2 = caddr(expr); + s7_pointer arg2_slot; + q_arg1(opc).p = arg1_slot; + if (is_t_real(arg2)) + { + q_call(opc).fd = opt_d_id_sc; + q_arg2(opc).x = real(arg2); + return_true(sc, expr); + } + if ((cadr(expr) == arg2) && (flt_func == multiply_d_id)) /* cadr(expr)==arg2 if both are symbols */ + { /* (do... (set! sum 0.0) (do ((k 1 (+ k 1))) ((> k 10)) (set! sum (+ sum (/ (* k k)))))) tnum */ + q_call(opc).fd = opt_d_i2_mul; + return_true(sc, expr); + } + arg2_slot = opt_float_symbol(sc, arg2); + if (arg2_slot) + { + q_call(opc).fd = opt_d_id_ss; + q_arg2(opc).p = arg2_slot; + return_true(sc, expr); + } + if (float_optimize(sc, cddr(expr))) + { + if (d_id_sf_combinable(sc, opc)) + return_true(sc, expr); + q_call(opc).fd = opt_d_id_sf; + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + return_true(sc, expr); + } + sc->pc = start; + } + if (is_t_integer(cadr(expr))) + { + if (float_optimize(sc, cddr(expr))) + { + q_call(opc).fd = opt_d_id_cf; + q_arg1(opc).i = integer(cadr(expr)); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + return_true(sc, expr); + } + sc->pc = start; + } + if (!expr_case) return_false(sc, expr); + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_call(opc).fd = opt_d_id_ff; /* not in s7test? (once in tgsl! from opt_d_7pid_sff_fvset (float-vector-set! v 0 (jn (+ i 1) 1.0))) */ + 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(q_func(o).d_dd_f(q_arg1(o).x, q_arg2(o).x));} +static s7_double opt_d_dd_cs(opt_info *o) {return(q_func(o).d_dd_f(q_arg1(o).x, real(slot_value(q_arg2(o).p))));} +static s7_double opt_d_dd_sc(opt_info *o) {return(q_func(o).d_dd_f(real(slot_value(q_arg1(o).p)), q_arg2(o).x));} +static s7_double opt_d_dd_sc_sub(opt_info *o) {return(real(slot_value(q_arg1(o).p)) - q_arg2(o).x);} +static s7_double opt_d_dd_ss(opt_info *o) {return(q_func(o).d_dd_f(real(slot_value(q_arg1(o).p)), real(slot_value(q_arg2(o).p))));} +static s7_double opt_d_dd_ss_add(opt_info *o) {return(real(slot_value(q_arg1(o).p)) + real(slot_value(q_arg2(o).p)));} +static s7_double opt_d_dd_ss_mul(opt_info *o) {return(real(slot_value(q_arg1(o).p)) * real(slot_value(q_arg2(o).p)));} + +static s7_double opt_d_dd_cf(opt_info *o) {return(q_func(o).d_dd_f(q_arg1(o).x, q_d_func1_call(o)));} +static s7_double opt_d_dd_1f_subtract(opt_info *o) {return(1.0 - q_d_func1_call(o));} +static s7_double opt_d_dd_fc(opt_info *o) {return(q_func(o).d_dd_f(q_d_func1_call(o), q_arg2(o).x));} + +static s7_double opt_subtract_random_f_f(opt_info *o) +{ + return(q_arg1(o).x * next_random(o->sc->default_random_state) - q_arg2(o).x); +} + +static s7_double opt_d_dd_fc_add(opt_info *o) {return(q_d_func1_call(o) + q_arg2(o).x);} +static s7_double opt_d_dd_fc_fvref_add(opt_info *o) {return(q_arg2(o).x + float_vector(slot_value(q_arg3(o).p), integer(slot_value(q_arg4(o).p))));} +static s7_double opt_d_dd_fc_subtract(opt_info *o) {return(q_d_func1_call(o) - q_arg2(o).x);} +static s7_double opt_d_dd_sf(opt_info *o) {return(q_func(o).d_dd_f(real(slot_value(q_arg1(o).p)), q_d_func1_call(o)));} +static s7_double opt_d_dd_sf_mul(opt_info *o) {return(real(slot_value(q_arg1(o).p)) * q_d_func1_call(o));} +static s7_double opt_d_dd_sf_add(opt_info *o) {return(real(slot_value(q_arg1(o).p)) + q_d_func1_call(o));} +static s7_double opt_d_dd_sf_sub(opt_info *o) {return(real(slot_value(q_arg1(o).p)) - q_d_func1_call(o));} + +static s7_double opt_d_7dd_cc(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, q_arg1(o).x, q_arg2(o).x));} +static s7_double opt_d_7dd_cs(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, q_arg1(o).x, real(slot_value(q_arg2(o).p))));} +static s7_double opt_d_7dd_sc(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, real(slot_value(q_arg1(o).p)), q_arg2(o).x));} +static s7_double opt_d_7dd_ss(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, real(slot_value(q_arg1(o).p)), real(slot_value(q_arg2(o).p))));} +static s7_double opt_d_7dd_cf(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, q_arg1(o).x, q_d_func1_call(o)));} +static s7_double opt_d_7dd_fc(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, q_d_func1_call(o), q_arg2(o).x));} +static s7_double opt_d_7dd_sf(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, real(slot_value(q_arg1(o).p)), q_d_func1_call(o)));} + +/* arg3 is index slot from opt_d_7pii_scs, also below */ +static s7_double opt_d_dd_sf_mul_fvref(opt_info *o) +{ + opt_info *o1 = q_func1_arg(o).o1; + return(real(slot_value(q_arg1(o).p)) * float_vector_ref_d_7pii(o1->sc, slot_value(q_arg1(o1).p), q_arg2(o1).i, integer(slot_value(q_arg3(o1).p)))); +} + +static s7_double opt_d_dd_sfo(opt_info *o) +{ + return(q_func(o).d_dd_f(real(slot_value(q_arg1(o).p)), q_func1(o).d_7pi_f(o->sc, slot_value(q_arg2(o).p), integer(slot_value(q_arg3(o).p))))); +} + +static s7_double opt_d_7dd_sfo(opt_info *o) +{ + return(q_func(o).d_7dd_f(o->sc, real(slot_value(q_arg1(o).p)), q_func1(o).d_7pi_f(o->sc, slot_value(q_arg2(o).p), integer(slot_value(q_arg3(o).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 ((q_call(o1).fd == opt_d_7pi_ss) || (q_call(o1).fd == opt_d_7pi_ss_fvref) || (q_call(o1).fd == opt_d_7pi_ss_fvref_direct)) + { + if (func) + { + q_func(opc).d_dd_f = q_func(opc).d_dd_f; /* need room for 3 symbols */ + q_call(opc).fd = opt_d_dd_sfo; + } + else + { + q_func(opc).d_7dd_f = q_func(opc).d_7dd_f; /* need room for 3 symbols */ + q_call(opc).fd = opt_d_7dd_sfo; + } + q_arg2(opc).p = q_arg1(o1).p; + q_arg3(opc).p = q_arg2(o1).p; + q_func1(opc).d_7pi_f = q_func(o1).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(q_func(o).d_dd_f(q_d_func1_call(o), real(slot_value(q_arg1(o).p))));} +static s7_double opt_d_dd_fs_mul(opt_info *o) {return(q_d_func1_call(o) * real(slot_value(q_arg1(o).p)));} +static s7_double opt_d_dd_fs_add(opt_info *o) {return(q_d_func1_call(o) + real(slot_value(q_arg1(o).p)));} +static s7_double opt_d_dd_fs_sub(opt_info *o) {return(q_d_func1_call(o) - real(slot_value(q_arg1(o).p)));} +static s7_double opt_d_7dd_fs(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, q_d_func1_call(o), real(slot_value(q_arg1(o).p))));} + +static s7_double opt_d_dd_fs_add_fvref(opt_info *o) +{ + opt_info *o1 = q_func1_arg(o).o1; + return(real(slot_value(q_arg1(o).p)) + float_vector_ref_d_7pii(o1->sc, slot_value(q_arg1(o1).p), q_arg2(o1).i, integer(slot_value(q_arg3(o1).p)))); +} + +static s7_double opt_d_dd_fso(opt_info *o) +{ + return(q_func(o).d_dd_f(q_func1(o).d_7pi_f(o->sc, slot_value(q_arg2(o).p), integer(slot_value(q_arg3(o).p))), real(slot_value(q_arg1(o).p)))); +} + +static s7_double opt_d_7dd_fso(opt_info *o) +{ + return(q_func(o).d_7dd_f(o->sc, q_func1(o).d_7pi_f(o->sc, slot_value(q_arg2(o).p), integer(slot_value(q_arg3(o).p))), real(slot_value(q_arg1(o).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 ((q_call(o1).fd == opt_d_7pi_ss) || (q_call(o1).fd == opt_d_7pi_ss_fvref) || (q_call(o1).fd == opt_d_7pi_ss_fvref_direct)) + { + if (func) + { + q_func(opc).d_dd_f = q_func(opc).d_dd_f; /* need room for 3 symbols */ + q_call(opc).fd = opt_d_dd_fso; + } + else + { + q_func(opc).d_7dd_f = q_func(opc).d_7dd_f; + q_call(opc).fd = opt_d_7dd_fso; + } + q_arg2(opc).p = q_arg1(o1).p; + q_arg3(opc).p = q_arg2(o1).p; + q_func1(opc).d_7pi_f = q_func(o1).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 = q_d_func3_call(o); + return(q_func(o).d_dd_f(x1, q_d_func2_call(o))); +} + +static s7_double opt_d_dd_ff_mul(opt_info *o) +{ + s7_double x1 = q_d_func3_call(o); + return(x1 * q_d_func2_call(o)); +} + +static s7_double opt_d_dd_ff_square(opt_info *o) +{ + s7_double x1 = q_d_func3_call(o); + return(x1 * x1); +} + +static s7_double opt_d_dd_ff_add(opt_info *o) +{ + s7_double x1 = q_d_func1_call(o); + return(x1 + q_d_func2_call(o)); +} + +static s7_double opt_d_dd_ff_add_mul(opt_info *o) +{ + s7_double x1 = q_d_func1_call(o); + s7_double x2 = q_d_func3_call(o); + return(x1 + (x2 * q_d_func2_call(o))); +} + +static s7_double opt_d_dd_ff_add_fv_ref(opt_info *o) +{ + s7_double x1 = q_d_func1_call(o); + return(x1 + float_vector_ref_d_7pi(o->sc, slot_value(q_arg1(o).p), q_i_func3_call(o))); +} + +static s7_double opt_d_dd_ff_sub(opt_info *o) +{ + s7_double x1 = q_d_func1_call(o); + return(x1 - q_d_func2_call(o)); +} + +static s7_double opt_d_7dd_ff(opt_info *o) +{ + s7_double x1 = q_d_func3_call(o); + return(q_func(o).d_7dd_f(o->sc, x1, q_d_func2_call(o))); +} + +static s7_double opt_d_7dd_ff_add_div(opt_info *o) +{ + s7_double x1 = opt_d_7pi_ss_fvref_direct(q_arg1(o).o1); + s7_double x2 = opt_d_7pi_ss_fvref_direct(q_arg2(o).o1); + return(x1 + divide_d_7dd(o->sc, x2, opt_d_id_sf(q_arg3(o).o1))); +} + +static s7_double opt_d_dd_ff_mul1(opt_info *o) {return(q_func3(o).d_v_f(q_arg1(o).gen) * q_d_func2_call(o));} + +static s7_double opt_d_dd_ff_mul2(opt_info *o) {return(q_func3(o).d_v_f(q_arg1(o).gen) * q_func1(o).d_v_f(q_arg2(o).gen));} + +static s7_double opt_d_dd_ff_mul4(opt_info *o) {return(q_func3(o).d_v_f(q_arg1(o).gen) * q_func2(o).d_vd_f(q_arg2(o).gen, q_func1(o).d_v_f(q_arg3(o).gen)));} + +static s7_double opt_d_dd_ff_o1(opt_info *o) +{ + s7_double x1 = q_func3(o).d_v_f(q_arg1(o).gen); + return(q_func(o).d_dd_f(x1, q_d_func2_call(o))); +} + +static s7_double opt_d_dd_ff_o2(opt_info *o) +{ + s7_double x1 = q_func3(o).d_v_f(q_arg1(o).gen); + return(q_func(o).d_dd_f(x1, q_func1(o).d_v_f(q_arg2(o).gen))); +} + +static s7_double opt_d_dd_ff_o3(opt_info *o) +{ + s7_double x1 = q_func3(o).d_v_f(q_arg1(o).gen); + return(q_func1(o).d_dd_f(x1, q_func2(o).d_vd_f(q_arg2(o).gen, real(slot_value(q_arg3(o).p))))); +} + +static s7_double opt_d_dd_ff_o4(opt_info *o) +{ + s7_double x1 = q_func3(o).d_v_f(q_arg1(o).gen); + return(q_func(o).d_dd_f(x1, q_func2(o).d_vd_f(q_arg2(o).gen, q_func1(o).d_v_f(q_arg3(o).gen)))); +} + +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(q_func(o).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(q_func(o).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(q_func(o).d_dd_f(x1, x2)); +} + +static s7_double opt_d_dd_ff_mul_sss_unchecked(opt_info *o) +{ + opt_info *o1 = q_func3_arg(o).o1; + s7_pointer vec = slot_value(q_arg1(o1).p); + s7_int i1 = integer(slot_value(q_arg2(o1).p)); + s7_int i2 = integer(slot_value(q_arg3(o1).p)); + s7_double x1 = float_vector(vec, (i1 * vector_offset(vec, 0)) + i2); + o1 = q_func2_arg(o).o1; + vec = slot_value(q_arg1(o1).p); + i1 = integer(slot_value(q_arg2(o1).p)); /* in (* (A i j) (B j k)) we could reuse i2->i1 (flipping args below) */ + i2 = integer(slot_value(q_arg3(o1).p)); + return(x1 * float_vector(vec, (i1 * vector_offset(vec, 0)) + i2)); +} + +static bool finish_dd_fso(opt_info *opc, opt_info *o1, opt_info *o2) +{ + opc->v[3+1].p = q_arg1(o1).p; + opc->v[3+2].p = q_arg2(o1).p; + opc->v[3+3].p = q_arg3(o1).p; + opc->v[3+4].d_dd_f = q_func(o1).d_dd_f; + opc->v[3+5].d_7pi_f = q_func1(o1).d_7pi_f; + opc->v[8+1].p = q_arg1(o2).p; + opc->v[8+2].p = q_arg2(o2).p; + opc->v[8+3].p = q_arg3(o2).p; + opc->v[8+4].d_dd_f = q_func(o2).d_dd_f; + opc->v[8+5].d_7pi_f = q_func1(o2).d_7pi_f; + return(true); +} + +static bool d_dd_ff_combinable(s7_scheme *sc, opt_info *opc, int32_t start) +{ + opt_info *o1 = q_func3_arg(opc).o1, *o2 = q_func2_arg(opc).o1; + if (q_call(o1).fd == opt_d_v) + { + /* q_func(opc) is in use */ + q_arg1(opc).gen = q_arg1(o1).gen; + q_func3(opc).d_v_f = q_func(o1).d_v_f; + if ((q_call(o2).fd == opt_d_v) && + (sc->pc == start + 2)) + { + q_arg2(opc).gen = q_arg1(o2).gen; + q_func1(opc).d_v_f = q_func(o2).d_v_f; + q_call(opc).fd = (q_func(opc).d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul2 : opt_d_dd_ff_o2; + sc->pc -= 2; + return_true(sc, NULL); + } + if ((q_call(o2).fd == opt_d_vd_s) && + (sc->pc == start + 2)) + { + q_arg2(opc).gen = q_arg1(o2).gen; + q_func1(opc).d_dd_f = q_func(opc).d_dd_f; + q_func2(opc).d_vd_f = q_func(o2).d_vd_f; + q_arg3(opc).p = q_arg2(o2).p; + q_call(opc).fd = opt_d_dd_ff_o3; + sc->pc -= 2; + return_true(sc, NULL); + } + if ((q_call(o2).fd == opt_d_vd_o) && + (sc->pc == start + 2)) + { + q_func3(opc).d_v_f = q_func(o1).d_v_f; + q_func2(opc).d_vd_f = q_func(o2).d_vd_f; + q_func1(opc).d_v_f = q_func3(o2).d_v_f; + q_arg2(opc).gen = q_arg1(o2).gen; + q_arg3(opc).gen = q_func2_arg(o2).gen; + q_call(opc).fd = (q_func(opc).d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul4 : opt_d_dd_ff_o4; + sc->pc -= 2; + return_true(sc, NULL); + } + q_call(opc).fd = (q_func(opc).d_dd_f == multiply_d_dd) ? opt_d_dd_ff_mul1 : opt_d_dd_ff_o1; + return_true(sc, NULL); + } + if (((q_call(o1).fd == opt_d_dd_fso) && (q_call(o2).fd == opt_d_dd_fso)) || + ((q_call(o1).fd == opt_d_dd_sfo) && (q_call(o2).fd == opt_d_dd_sfo))) + { + if ((q_func(o1).d_dd_f == multiply_d_dd) && + (q_func(o2).d_dd_f == multiply_d_dd) && + ((q_func1(o1).d_7pi_f == float_vector_ref_d_7pi) || (q_func1(o1).d_7pi_f == float_vector_ref_d_7pi_direct)) && + ((q_func1(o2).d_7pi_f == float_vector_ref_d_7pi) || (q_func1(o2).d_7pi_f == float_vector_ref_d_7pi_direct))) + q_call(opc).fd = opt_d_mm_fff; /* a placeholder (never called), see p_d_f_combinable */ + else q_call(opc).fd = (q_call(o1).fd == opt_d_dd_fso) ? opt_d_dd_fff : 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(q_func(o).d_dd_f(q_arg1(o).x, q_func1(o).d_v_f(q_arg2(o).gen)));} +static s7_double opt_d_7dd_cfo(opt_info *o) {return(q_func(o).d_7dd_f(o->sc, q_arg1(o).x, q_func1(o).d_v_f(q_arg2(o).gen)));} + +static s7_double opt_d_dd_cfo1(opt_info *o) {return(q_func(o).d_dd_f(q_arg1(o).x, q_func1(o).d_vd_f(q_arg3(o).gen, real(slot_value(q_arg2(o).p)))));} +static s7_double opt_d_7dd_cfo1(opt_info *o){return(q_func(o).d_7dd_f(o->sc, q_arg1(o).x, q_func1(o).d_vd_f(q_arg3(o).gen, real(slot_value(q_arg2(o).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 (q_call(o1).fd == opt_d_v) + { + q_arg2(opc).gen = q_arg1(o1).gen; + q_func1(opc).d_v_f = q_func(o1).d_v_f; + q_call(opc).fd = (func) ? opt_d_dd_cfo : opt_d_7dd_cfo; + backup_pc(sc); + return_true(sc, NULL); + } + if (q_call(o1).fd == opt_d_vd_s) + { + q_arg3(opc).gen = q_arg1(o1).gen; + q_arg2(opc).p = q_arg2(o1).p; + q_func1(opc).d_vd_f = q_func(o1).d_vd_f; + q_call(opc).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) + q_func(opc).d_dd_f = func; + else q_func(opc).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); + q_arg1(opc).x = s7_number_to_real(sc, arg1); + q_arg2(opc).x = s7_number_to_real(sc, arg2); + q_call(opc).fd = (func) ? opt_d_dd_cc : opt_d_7dd_cc; + return_true(sc, expr); + } + slot = opt_float_symbol(sc, arg2); + if (slot) + { + q_arg1(opc).x = s7_number_to_real(sc, arg1); + q_arg2(opc).p = slot; + q_call(opc).fd = (func) ? opt_d_dd_cs : opt_d_7dd_cs; /* see opt_d_vd_o3 above which uses this */ + return_true(sc, expr); + } + if (float_optimize(sc, cddr(expr))) + { + q_arg1(opc).x = s7_number_to_real(sc, arg1); + if (d_dd_call_combinable(sc, opc, func)) + return_true(sc, expr); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + q_call(opc).fd = (func) ? opt_d_dd_cf : opt_d_7dd_cf; + if ((q_arg1(opc).x == 1.0) && (func == subtract_d_dd)) q_call(opc).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) + { + q_arg1(opc).p = slot; + if (is_small_real(arg2)) + { + q_arg2(opc).x = s7_number_to_real(sc, arg2); + if (func) + q_call(opc).fd = (func == subtract_d_dd) ? opt_d_dd_sc_sub : opt_d_dd_sc; + else q_call(opc).fd = opt_d_7dd_sc; + return_true(sc, expr); + } + slot = opt_float_symbol(sc, arg2); + if (slot) + { + q_arg2(opc).p = slot; + if (func) + { + if (func == multiply_d_dd) + q_call(opc).fd = opt_d_dd_ss_mul; + else q_call(opc).fd = (func == add_d_dd) ? opt_d_dd_ss_add : opt_d_dd_ss; + } + else q_call(opc).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); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + if (func) + { + q_call(opc).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) && (q_func1(opc).fd == opt_d_7pii_scs)) + q_call(opc).fd = opt_d_dd_sf_mul_fvref; + } + else q_call(opc).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)) + { + q_arg2(opc).x = s7_number_to_real(sc, arg2); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + if (func) + { + if (func == add_d_dd) + { + if (q_func1(opc).fd == opt_d_7pi_ss_fvref_direct) + { + q_call(opc).fd = opt_d_dd_fc_fvref_add; + q_arg3(opc).p = q_func1_arg(opc).q_arg1(o1).p; + q_arg4(opc).p = q_func1_arg(opc).q_arg2(o1).p; + } + else q_call(opc).fd = opt_d_dd_fc_add; + return_true(sc, expr); + } + if (func == subtract_d_dd) + { + q_call(opc).fd = opt_d_dd_fc_subtract; + /* if q_call(o1).fd = opt_d_7d_c and its q_func(o).d_7d_f = random_d_7d it's (- (random f1) f2) */ + if ((opc == sc->opts[sc->pc - 2]) && + (q_call(sc->opts[start]).fd == opt_d_7d_c) && + (q_func(sc->opts[start]).d_7d_f == random_d_7d)) + { + q_call(opc).fd = opt_subtract_random_f_f; + q_arg1(opc).x = q_arg1(sc->opts[start]).x; /* random arg */ + backup_pc(sc); + }} + else q_call(opc).fd = opt_d_dd_fc; + } + else q_call(opc).fd = opt_d_7dd_fc; + return_true(sc, expr); + } + slot = opt_float_symbol(sc, arg2); + if (slot) + { + q_arg1(opc).p = slot; + if (d_dd_fs_combinable(sc, opc, func)) + return_true(sc, expr); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fd = q_call(sc->opts[start]).fd; + if (func) + { + q_call(opc).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) && (q_func1(opc).fd == opt_d_7pii_scs)) + q_call(opc).fd = opt_d_dd_fs_add_fvref; + } + else q_call(opc).fd = opt_d_7dd_fs; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + opt_info *o2; + q_func3_arg(opc).o1 = o1; + q_func3(opc).fd = q_call(o1).fd; + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + if (func) + { + if (d_dd_ff_combinable(sc, opc, start)) + return_true(sc, expr); + q_call(opc).fd = opt_d_dd_ff; + if (func == multiply_d_dd) + { + if (arg1 == arg2) + q_call(opc).fd = opt_d_dd_ff_square; + else + if ((q_func3(opc).fd == opt_d_7pii_sss_unchecked) && (q_func2(opc).fd == opt_d_7pii_sss_unchecked) && + (q_func1(o1).d_7pii_f == float_vector_ref_d_7pii)) + q_call(opc).fd = opt_d_dd_ff_mul_sss_unchecked; + else q_call(opc).fd = opt_d_dd_ff_mul; + return_true(sc, expr); + } + o2 = sc->opts[start2]; /* this is q_func2_arg(opc).o1, v[10] */ + if (func == add_d_dd) + { + if (q_call(o2).fd == opt_d_dd_ff_mul) + { + q_call(opc).fd = opt_d_dd_ff_add_mul; + q_func1_arg(opc).o1 = o1; /* add first arg */ + q_func1(opc).fd = q_call(o1).fd; + q_func3_arg(opc).o1 = q_func3_arg(o2).o1; /* mul first arg */ + q_func3(opc).fd = q_func3(o2).fd; + q_func2_arg(opc).o1 = q_func2_arg(o2).o1; /* mul second arg */ + q_func2(opc).fd = q_func2(o2).fd; + return_true(sc, expr); + } + if ((q_call(o2).fd == opt_d_7pi_sf) && + ((q_func(o2).d_7pi_f == float_vector_ref_d_7pi) || (q_func(o2).d_7pi_f == float_vector_ref_d_7pi_direct))) + { + q_call(opc).fd = opt_d_dd_ff_add_fv_ref; + q_arg1(opc).p = q_arg1(o2).p; + q_func3_arg(opc).o1 = q_func2_arg(o2).o1; /* sc->opts[start2 + 1]; */ + q_func3(opc).fi = q_func2(o2).fi; /* sc->opts[start2 + 1]-v[0].fi; */ + } + else + { + q_call(opc).fd = opt_d_dd_ff_add; + q_func2_arg(opc).o1 = o2; + q_func2(opc).fd = q_call(o2).fd; + if ((q_call(o1).fd == opt_d_7pi_ss_fvref_direct) && (q_func2(opc).fd == opt_d_7dd_ff)) + { + opt_info *ov = q_func2_arg(opc).o1; + if ((q_func(ov).d_7dd_f == divide_d_7dd) && (q_func2(ov).fd == opt_d_id_sf) && (q_func3(ov).fd == opt_d_7pi_ss_fvref_direct)) + { + q_arg1(opc).o1 = o1; + q_arg3(opc).o1 = q_func2_arg(ov).o1; + q_arg2(opc).o1 = q_func3_arg(ov).o1; + q_call(opc).fd = opt_d_7dd_ff_add_div; + }}} + q_func1_arg(opc).o1 = o1; /* sc->opts[start]; */ + q_func1(opc).fd = q_call(o1).fd; /* q_call(sc->opts[start]).fd; */ + return_true(sc, expr); + } + if (func == subtract_d_dd) + { + q_call(opc).fd = opt_d_dd_ff_sub; + q_func1_arg(opc).o1 = o1; /* sc->opts[start]; */ + q_func1(opc).fd = q_call(o1).fd; /* q_call(sc->opts[start]).fd; */ + q_func2_arg(opc).o1 = o2; + q_func2(opc).fd = q_call(o2).fd; + return_true(sc, expr); + }} + else q_call(opc).fd = opt_d_7dd_ff; + return_true(sc, expr); + }} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- d_ddd -------- */ + +static s7_double opt_d_ddd_sss(opt_info *o) {return(q_func(o).d_ddd_f(real(slot_value(q_arg1(o).p)), real(slot_value(q_arg2(o).p)), real(slot_value(q_arg3(o).p))));} +static s7_double opt_d_ddd_ssf(opt_info *o) +{ + return(q_func(o).d_ddd_f(real(slot_value(q_arg1(o).p)), real(slot_value(q_arg2(o).p)), q_d_func2_call(o))); +} + +static s7_double opt_d_ddd_sff(opt_info *o) +{ + s7_double x1 = q_d_func2_call(o); + s7_double x2 = q_d_func3_call(o); + return(q_func(o).d_ddd_f(real(slot_value(q_arg1(o).p)), x1, x2)); +} + +static s7_double opt_d_ddd_fff(opt_info *o) +{ + s7_double x1 = q_d_func2_call(o); + s7_double x2 = q_d_func3_call(o); + s7_double x3 = q_d_func1_call(o); + return(q_func(o).d_ddd_f(x1, x2, x3)); +} + +static s7_double opt_d_ddd_fff1(opt_info *o) +{ + s7_double x1 = q_func1(o).d_v_f(q_func1_arg(o).gen); + s7_double x2 = q_func2(o).d_v_f(q_func2_arg(o).gen); + s7_double x3 = q_func3(o).d_v_f(q_func3_arg(o).gen); + return(q_func(o).d_ddd_f(x1, x2, x3)); +} + +static s7_double opt_d_ddd_fff2(opt_info *o) +{ + s7_double x1 = q_func2(o).d_v_f(q_func2_arg(o).gen); + s7_double x2 = q_d_func3_call(o); + s7_double x3 = q_d_func1_call(o); + return(q_func(o).d_ddd_f(x1, x2, x3)); +} + +static s7_double opt_d_ddd_fff_mul(opt_info *o) +{ + s7_double x1 = opt_D_s(q_func2_arg(o).o1); + s7_double x2 = opt_D_s(q_func3_arg(o).o1); + s7_double x3 = opt_d_s(q_func1_arg(o).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 (q_call(sc->opts[start]).fd != opt_d_v) + return_false(sc, NULL); + o1 = sc->opts[start]; + q_func2(opc).d_v_f = q_func(o1).d_v_f; + q_func2_arg(opc).gen = q_arg1(o1).gen; + if ((q_call(sc->opts[start + 1]).fd == opt_d_v) && + (q_call(sc->opts[start + 2]).fd == opt_d_v)) + { + opt_info *o2 = sc->opts[start + 2]; + o1 = sc->opts[start + 1]; + q_call(opc).fd = opt_d_ddd_fff1; + q_func1(opc).d_v_f = q_func2(opc).d_v_f; + q_func1_arg(opc).gen = q_func2_arg(opc).gen; + q_func2(opc).d_v_f = q_func(o1).d_v_f; + q_func2_arg(opc).gen = q_arg1(o1).gen; + q_func3(opc).d_v_f = q_func(o2).d_v_f; + q_func3_arg(opc).gen = q_arg1(o2).gen; + sc->pc -= 3; + return_true(sc, NULL); + } + q_call(opc).fd = opt_d_ddd_fff2; /* (* (d-v-func b) (d-v-func b) x) */ + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + q_func1(opc).fd = q_func1_arg(opc).q_call(o1).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 arg1_slot; + const s7_pointer arg1 = cadr(expr), arg2 = caddr(expr); + const s7_d_ddd_t func = s7_d_ddd_function(s_func); + if (!func) return_false(sc, expr); + q_func(opc).d_ddd_f = func; + arg1_slot = opt_float_symbol(sc, arg1); + q_func2_arg(opc).o1 = sc->opts[start]; + if (arg1_slot) + { + s7_pointer arg2_slot; + q_arg1(opc).p = arg1_slot; + arg2_slot = opt_float_symbol(sc, arg2); + if (arg2_slot) + { + const s7_pointer arg3 = cadddr(expr); + s7_pointer arg3_slot; + q_arg2(opc).p = arg2_slot; + arg3_slot = opt_float_symbol(sc, arg3); + if (arg3_slot) + { + q_arg3(opc).p = arg3_slot; + q_call(opc).fd = opt_d_ddd_sss; + return_true(sc, expr); + } + if (float_optimize(sc, cdddr(expr))) + { + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_call(opc).fd = opt_d_ddd_ssf; + return_true(sc, expr); + } + sc->pc = start; + } + if (float_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + q_call(opc).fd = opt_d_ddd_sff; + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + return_true(sc, expr); + }} + sc->pc = start; + } + if (float_optimize(sc, cdr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + if (d_ddd_fff_combinable(sc, opc, start)) + return_true(sc, expr); + q_call(opc).fd = opt_d_ddd_fff; /* tfft: (+ (* xout xin iw) (* yout yin ih) (* zout zin id)) */ + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + q_func1(opc).fd = q_func1_arg(opc).q_call(o1).fd; + if ((func == multiply_d_ddd) && (q_func2(opc).fd == opt_D_s) && (q_func3(opc).fd == opt_D_s) && (q_func1(opc).fd == opt_d_s)) + q_call(opc).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(q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_d_func2_call(o))); +} + +static s7_pointer opt_d_7pid_ssf_nr(opt_info *o) +{ + q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_d_func2_call(o)); + return(NULL); +} + +static s7_double opt_d_7pid_sss(opt_info *o) +{ + return(q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), real(slot_value(q_arg3(o).p)))); +} + +static s7_double opt_d_7pid_ssc(opt_info *o) +{ + return(q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_arg3(o).x)); +} + +static s7_double opt_d_7pid_sff(opt_info *o) +{ + s7_int pos = q_i_func2_call(o); + return(q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), pos, q_d_func3_call(o))); +} + +static s7_double opt_d_7pid_sff_fvset(opt_info *o) +{ + s7_int pos = q_i_func2_call(o); + return(float_vector_set_d_7pid(o->sc, slot_value(q_arg1(o).p), pos, q_d_func3_call(o))); +} + +static s7_double opt_d_7pid_sso(opt_info *o) +{ + return(q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_func1(o).d_v_f(q_func1_arg(o).gen))); +} + +static s7_double opt_d_7pid_ss_ss(opt_info *o) +{ + return(q_func(o).d_7pid_f(o->sc, slot_value(q_arg1(o).p), + integer(slot_value(q_arg2(o).p)), + q_func1(o).d_7pi_f(o->sc, slot_value(q_arg3(o).p), integer(slot_value(q_arg4(o).p))))); +} + +static s7_double opt_d_7pid_ssfo(opt_info *o) +{ + s7_pointer fv = slot_value(q_arg1(o).p); + return(q_func(o).d_7pid_f(o->sc, fv, integer(slot_value(q_arg2(o).p)), + q_func2(o).d_dd_f(q_func1(o).d_7pi_f(o->sc, fv, integer(slot_value(q_arg3(o).p))), real(slot_value(q_arg4(o).p))))); +} + +static s7_double opt_d_7pid_ssfo_fv(opt_info *o) +{ + s7_double *els = float_vector_floats(slot_value(q_arg1(o).p)); + s7_double val = q_func2(o).d_dd_f(els[integer(slot_value(q_arg3(o).p))], real(slot_value(q_arg4(o).p))); + els[integer(slot_value(q_arg2(o).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(q_arg1(o).p)); + els[integer(slot_value(q_arg2(o).p))] = q_func2(o).d_dd_f(els[integer(slot_value(q_arg3(o).p))], real(slot_value(q_arg4(o).p))); + return(NULL); +} + +static s7_pointer opt_d_7pid_ssfo_fv_add_nr(opt_info *o) +{ + s7_double *els = float_vector_floats(slot_value(q_arg1(o).p)); + els[integer(slot_value(q_arg2(o).p))] = els[integer(slot_value(q_arg3(o).p))] + real(slot_value(q_arg4(o).p)); + return(NULL); +} + +static s7_pointer opt_d_7pid_ssfo_fv_sub_nr(opt_info *o) +{ + s7_double *els = float_vector_floats(slot_value(q_arg1(o).p)); + els[integer(slot_value(q_arg2(o).p))] = els[integer(slot_value(q_arg3(o).p))] - real(slot_value(q_arg4(o).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 (q_call(o1).fd == opt_d_v) + { + q_func1_arg(opc).gen = q_arg1(o1).gen; + q_func1(opc).d_v_f = q_func(o1).d_v_f; + q_call(opc).fd = opt_d_7pid_sso; + backup_pc(sc); + return_true(sc, NULL); + } + if ((q_call(o1).fd == opt_d_7pi_ss) || (q_call(o1).fd == opt_d_7pi_ss_fvref) || (q_call(o1).fd == opt_d_7pi_ss_fvref_direct)) + { + q_func1(opc).d_7pi_f = q_func(o1).d_7pi_f; + q_arg3(opc).p = q_arg1(o1).p; + q_arg4(opc).p = q_arg2(o1).p; + q_call(opc).fd = opt_d_7pid_ss_ss; + backup_pc(sc); + return_true(sc, NULL); + } + if ((q_call(o1).fd == opt_d_dd_fso) && + (q_arg1(opc).p == q_arg2(o1).p)) + { + q_func2(opc).d_dd_f = q_func(o1).d_dd_f; + q_func1(opc).d_7pi_f = q_func1(o1).d_7pi_f; + q_arg3(opc).p = q_arg3(o1).p; + q_arg4(opc).p = q_arg1(o1).p; + q_call(opc).fd = opt_d_7pid_ssfo; + if (((q_func1(opc).d_7pi_f == float_vector_ref_d_7pi) || (q_func1(opc).d_7pi_f == float_vector_ref_d_7pi_direct)) && + ((q_func(opc).d_7pid_f == float_vector_set_d_7pid_direct) || (q_func(opc).d_7pid_f == float_vector_set_d_7pid))) + q_call(opc).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 func = s7_d_7pid_function(s_func); + if ((func) && (is_symbol(cadr(expr)))) + { + const s7_pointer head = car(expr); + const int32_t start = sc->pc; + q_func(opc).d_7pid_f = func; + + 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))); + + q_arg1(opc).p = s7_slot(sc, cadr(expr)); + if (!is_slot(q_arg1(opc).p)) return_false(sc, expr); + q_func2_arg(opc).o1 = sc->opts[start]; + if (is_slot(q_arg1(opc).p)) + { + s7_pointer arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + s7_pointer arg3_slot; + q_arg2(opc).p = arg2_slot; + arg3_slot = opt_float_symbol(sc, cadddr(expr)); + if (arg3_slot) + { + q_arg3(opc).p = arg3_slot; + q_call(opc).fd = opt_d_7pid_sss; + return_true(sc, expr); + } + if (float_optimize(sc, cdddr(expr))) + { + q_func2(opc).fd = q_call(sc->opts[start]).fd; + if (d_7pid_ssf_combinable(sc, opc)) + return_true(sc, expr); + q_call(opc).fd = opt_d_7pid_ssf; + return_true(sc, expr); + } + sc->pc = start; + } + if (int_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + q_call(opc).fd = opt_d_7pid_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).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) +{ + return(float_vector_ref_d_7pii(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)))); +} + +static s7_double opt_d_7pii_sss_unchecked(opt_info *o) +{ + s7_pointer vec = slot_value(q_arg1(o).p); + return(float_vector(vec, ((integer(slot_value(q_arg2(o).p)) * vector_offset(vec, 0)) + integer(slot_value(q_arg3(o).p))))); +} + +static s7_double opt_d_7pii_scs(opt_info *o) +{ + return(float_vector_ref_d_7pii(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i, integer(slot_value(q_arg3(o).p)))); +} + +static s7_double opt_d_7pii_sff(opt_info *o) +{ + return(float_vector_ref_d_7pii(o->sc, slot_value(q_arg1(o).p), q_i_func2_call(o), q_i_func3_call(o))); +} + +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 arg3_slot; + const int32_t start = sc->pc; + q_arg1(opc).p = s7_slot(sc, cadr(expr)); + if ((!is_slot(q_arg1(opc).p)) || + (!is_float_vector(slot_value(q_arg1(opc).p))) || + (vector_rank(slot_value(q_arg1(opc).p)) != 2)) + return_false(sc, expr); + + arg3_slot = opt_integer_symbol(sc, cadddr(expr)); + if (arg3_slot) + { + s7_pointer arg2_slot; + q_arg3(opc).p = arg3_slot; + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + q_call(opc).fd = opt_d_7pii_sss; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 0))) && /* see also d_implicit_ok */ + (loop_end_fits(q_arg3(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 1)))) + q_call(opc).fd = opt_d_7pii_sss_unchecked; + return_true(sc, expr); + } + if (is_t_integer(caddr(expr))) + { + q_arg2(opc).i = integer(caddr(expr)); + q_call(opc).fd = opt_d_7pii_scs; + return_true(sc, expr); + }} + q_func2_arg(opc).o1 = sc->opts[start]; + if (int_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdddr(expr))) + { + q_call(opc).fd = opt_d_7pii_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).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) +{ + return(float_vector_set_d_7piid(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)), q_d_func3_call(o))); +} + +static s7_double opt_d_7piid_sssc(opt_info *o) +{ + return(float_vector_set_d_7piid(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)), q_arg4(o).x)); +} + +static s7_double opt_d_7piid_scsf(opt_info *o) +{ + return(float_vector_set_d_7piid(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i, integer(slot_value(q_arg3(o).p)), q_d_func2_call(o))); +} + +static s7_double opt_d_7piid_sfff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + s7_int i2 = q_i_func3_call(o); + s7_double val = q_d_func4_call(o); + return(float_vector_set_d_7piid(o->sc, slot_value(q_arg1(o).p), i1, i2, val)); +} + +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(q_arg2(o).p)), i2 = integer(slot_value(q_arg3(o).p)); + s7_pointer vect = slot_value(q_arg1(o).p); + s7_double val = q_d_func3_call(o); + 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)))) + { + 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(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), + integer(slot_value(q_arg3(o).p)), integer(slot_value(q_arg4(o).p)))); +} + +static s7_double opt_d_7piii_ssss_unchecked(opt_info *o) +/* not in s7test (tvect: ((do ((i 0...))) ((= i ...)) (do ((n 0 ...)) ((= n ...)) (set! sum (+ sum (float-vector-ref v k i n)))))) */ +{ + s7_pointer vec = slot_value(q_arg1(o).p); + s7_int i1 = integer(slot_value(q_arg2(o).p)) * vector_offset(vec, 0); + s7_int i2 = integer(slot_value(q_arg3(o).p)) * vector_offset(vec, 1); /* offsets accumulate */ + return(float_vector(vec, (i1 + i2 + integer(slot_value(q_arg4(o).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 arg4_slot; + q_arg1(opc).p = s7_slot(sc, cadr(expr)); + if ((!is_slot(q_arg1(opc).p)) || + (!is_float_vector(slot_value(q_arg1(opc).p))) || + (vector_rank(slot_value(q_arg1(opc).p)) != 3)) + return_false(sc, expr); + arg4_slot = opt_integer_symbol(sc, car(cddddr(expr))); + if (arg4_slot) + { + s7_pointer arg3_slot; + q_arg4(opc).p = arg4_slot; + arg3_slot = opt_integer_symbol(sc, cadddr(expr)); + if (arg3_slot) + { + s7_pointer arg2_slot; + q_arg3(opc).p = arg3_slot; + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + const s7_pointer vect = slot_value(q_arg1(opc).p); + q_arg2(opc).p = arg2_slot; + q_call(opc).fd = opt_d_7piii_ssss; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(vect, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(vect, 1))) && + (loop_end_fits(q_arg4(opc).p, vector_dimension(vect, 2)))) + q_call(opc).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(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), + integer(slot_value(q_arg3(o).p)), integer(slot_value(q_arg4(o).p)), q_d_func2_call(o))); +} + +static s7_double opt_d_7piiid_ssssf_unchecked(opt_info *o) +{ + s7_pointer vect = slot_value(q_arg1(o).p); + s7_int i1 = integer(slot_value(q_arg2(o).p)) * vector_offset(vect, 0); + s7_int i2 = integer(slot_value(q_arg3(o).p)) * vector_offset(vect, 1); + s7_int i3 = integer(slot_value(q_arg4(o).p)); + s7_double val = q_d_func2_call(o); + 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)))) + { + const s7_pointer vect = slot_value(settee); + const int32_t start = sc->pc; + q_arg1(opc).p = settee; + if (!is_float_vector(vect)) return_false(sc, vect); + q_func2_arg(opc).o1 = sc->opts[start]; + if ((!indexp2) && + (vector_rank(vect) == 1)) + { + s7_pointer ind1_slot; + q_func(opc).d_7pid_f = float_vector_set_d_7pid; + ind1_slot = opt_integer_symbol(sc, car(indexp1)); + if (ind1_slot) + { + s7_pointer val_slot; + q_arg2(opc).p = ind1_slot; + if (loop_end_fits(q_arg2(opc).p, vector_length(vect))) + q_func(opc).d_7pid_f = float_vector_set_d_7pid_direct; + val_slot = opt_float_symbol(sc, car(valp)); + if (val_slot) + { + q_arg3(opc).p = val_slot; + q_call(opc).fd = opt_d_7pid_sss; + return_true(sc, NULL); + } + if (is_small_real(car(valp))) + { + q_arg3(opc).x = s7_real(car(valp)); + q_call(opc).fd = opt_d_7pid_ssc; + return_true(sc, NULL); + } + if (float_optimize(sc, valp)) + { + q_func2(opc).fd = q_call(sc->opts[start]).fd; + if (d_7pid_ssf_combinable(sc, opc)) + return_true(sc, NULL); + q_call(opc).fd = opt_d_7pid_ssf; + return_true(sc, NULL); + } + sc->pc = start; + } + if (int_optimize(sc, indexp1)) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, valp)) + { + q_call(opc).fd = (q_func(opc).d_7pid_f == float_vector_set_d_7pid) ? opt_d_7pid_sff_fvset : opt_d_7pid_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + return_true(sc, NULL); + }} + return_false(sc, indexp1); + } + if ((indexp2) && (!indexp3) && + (vector_rank(vect) == 2)) + { + s7_pointer ind2_slot; + q_func1(opc).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 q_call(opc).fd = fvset_unchecked_d_7piid or whatever + */ + ind2_slot = opt_integer_symbol(sc, car(indexp2)); + if (ind2_slot) + { + s7_pointer ind1_slot; + q_arg3(opc).p = ind2_slot; + if (is_t_integer(car(indexp1))) + { + if (!float_optimize(sc, valp)) + return_false(sc, valp); + q_call(opc).fd = opt_d_7piid_scsf; + q_arg2(opc).i = integer(car(indexp1)); + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + return_true(sc, NULL); + } + ind1_slot = opt_integer_symbol(sc, car(indexp1)); + if (ind1_slot) + { + q_arg2(opc).p = ind1_slot; + if (is_small_real(car(valp))) + { + q_call(opc).fd = opt_d_7piid_sssc; + q_arg4(opc).x = s7_real(car(valp)); + return_true(sc, NULL); + } + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, valp)) + { + q_call(opc).fd = opt_d_7piid_sssf; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(vect, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(vect, 1)))) + q_call(opc).fd = opt_d_7piid_sssf_unchecked; + return_true(sc, NULL); + } + sc->pc = start; + }} + if (int_optimize(sc, indexp1)) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) + { + q_func4_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, valp)) + { + q_call(opc).fd = opt_d_7piid_sfff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + q_func4(opc).fd = q_func4_arg(opc).q_call(o1).fd; + return_true(sc, NULL); + }}} + return_false(sc, indexp1); + } + if ((indexp3) && + (vector_rank(vect) == 3)) + { + s7_pointer ind3_slot; + ind3_slot = opt_integer_symbol(sc, car(indexp3)); + if (ind3_slot) + { + s7_pointer ind2_slot; + q_arg4(opc).p = ind3_slot; + ind2_slot = opt_integer_symbol(sc, car(indexp2)); + if (ind2_slot) + { + s7_pointer ind1_slot; + q_arg3(opc).p = ind2_slot; + ind1_slot = opt_integer_symbol(sc, car(indexp1)); + if (ind1_slot) + { + q_arg2(opc).p = ind1_slot; + if (float_optimize(sc, valp)) + { + q_call(opc).fd = opt_d_7piiid_ssssf; + q_func2(opc).fd = q_call(sc->opts[start]).fd; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(vect, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(vect, 1))) && + (loop_end_fits(q_arg4(opc).p, vector_dimension(vect, 2)))) + q_call(opc).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(q_func(o).d_vid_f(q_arg1(o).gen, integer(slot_value(q_arg2(o).p)), q_d_func2_call(o)));} + +static inline s7_double opt_fmv(opt_info *o) +{ + opt_info *o1 = q_arg3(o).o1; /* opt_d_dd_ff_mul1 */ + opt_info *o2 = q_arg4(o).o1; /* opt_d_vd_o1 */ + opt_info *o3 = q_arg5(o).o1; /* opt_d_dd_ff_o3 */ + s7_double amp_env = q_func3(o1).d_v_f(q_arg1(o1).gen); + s7_double vib = real(slot_value(q_arg2(o2).p)); + s7_double index_env = q_func3(o3).d_v_f(q_arg1(o3).gen); + return(q_func(o).d_vid_f(q_arg1(o).gen, + integer(slot_value(q_arg2(o).p)), + amp_env * q_func(o2).d_vd_f(q_arg1(o2).gen, + vib + (index_env * q_func2(o3).d_vd_f(q_arg2(o3).gen, 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); + q_func(opc).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 arg2_slot; + q_call(opc).fd = opt_d_vid_ssf; + q_arg1(opc).p = vslot; + q_func2_arg(opc).o1 = sc->opts[start]; + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if ((arg2_slot) && + (float_optimize(sc, cdddr(expr)))) + { + opt_info *o2; + q_arg2(opc).p = arg2_slot; + q_arg1(opc).gen = (void *)c_object_value(slot_value(vslot)); + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + o2 = sc->opts[start]; + if (q_call(o2).fd == opt_d_dd_ff_mul1) + { + opt_info *o3 = sc->opts[start + 2]; + if (q_call(o3).fd == opt_d_vd_o1) + { + opt_info *o1 = sc->opts[start + 4]; + if ((q_call(o1).fd == opt_d_dd_ff_o3) && + (q_func1(o1).d_dd_f == multiply_d_dd) && + (q_func3(o3).d_dd_f == add_d_dd)) + { + q_call(opc).fd = opt_fmv; /* expr: (locsig locs i (* (env ampf) (oscil carrier (+ vib (* (env indf1) (polywave fmosc1 vib)))))) */ + q_arg3(opc).o1 = o2; /* opt_d_dd_ff_mul1 */ + q_arg4(opc).o1 = o3; /* opt_d_vd_o1 */ + q_arg5(opc).o1 = o1; /* opt_d_dd_ff_o3 */ + }}} + 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 = q_d_func2_call(o); + s7_double x2 = q_d_func3_call(o); + return(q_func(o).d_vdd_f(q_arg1(o).gen, 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); + q_func(opc).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; + q_func2_arg(opc).o1 = sc->opts[start]; + if (float_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + q_arg1(opc).gen = (void *)c_object_value(slot_value(slot)); + q_call(opc).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 = q_d_func1_call(o); + s7_double x2 = q_d_func2_call(o); + s7_double x3 = q_d_func3_call(o); + s7_double x4 = q_d_func4_call(o); + return(q_func(o).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 func = s7_d_dddd_function(s_func); + if (!func) return_false(sc, expr); + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdddr(expr))) + { + q_func4_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddddr(expr))) + { + q_func(opc).d_dddd_f = func; + q_call(opc).fd = opt_d_dddd_ffff; + q_func1(opc).fd = q_func1_arg(opc).q_call(o1).fd; + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + q_func4(opc).fd = q_func4_arg(opc).q_call(o1).fd; + return_true(sc, expr); + }}}} + return_false(sc, expr); +} + +/* -------- d_add|multiply|subtract_any ------- */ +#define q_d_am_arg(o, i) o->v[i + 2] + +static s7_double opt_d_add_any_f(opt_info *o) +{ + s7_double sum = 0.0; + for (s7_int i = 0; i < q_arg1(o).i; i++) + { + opt_info *o1 = q_d_am_arg(o, i).o1; + sum += q_call(o1).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 < q_arg1(o).i; i++) + { + opt_info *o1 = q_d_am_arg(o, i).o1; + sum *= q_call(o1).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++) + { + q_d_am_arg(opc, cur_len).o1 = sc->opts[sc->pc]; + if (!float_optimize(sc, p)) + break; + } + if (is_null(p)) + { + q_arg1(opc).i = cur_len; + q_call(opc).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 = q_func(o).fd(q_arg2(o).o1); + slot_set_value(q_arg1(o).p, make_real(o->sc, x)); + return(x); +} + +static s7_double opt_set_d_d_fm(opt_info *o) +{ + s7_double x = q_func(o).fd(q_arg2(o).o1); + check_mutability(o->sc, o, __func__, __LINE__); + set_real(slot_value(q_arg1(o).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]; + q_arg1(opc).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 + */ + q_call(opc).fd = (is_mutable_number(slot_value(q_arg1(opc).p))) ? opt_set_d_d_fm : opt_set_d_d_f; + q_arg2(opc).o1 = o1; + q_func(opc).fd = q_call(o1).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) +{ + const s7_pointer obj = slot_value(s_slot); + if (is_float_vector(obj)) + { + /* implicit float-vector-ref */ + if ((len == 2) && + (vector_rank(obj) == 1)) + { + s7_pointer arg1_slot; + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + q_func(opc).d_7pi_f = float_vector_ref_d_7pi; + arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + q_arg2(opc).p = arg1_slot; + if (loop_end_fits(q_arg2(opc).p, vector_length(obj))) + q_call(opc).fd = opt_d_7pi_ss_fvref_direct; + else q_call(opc).fd = opt_d_7pi_ss_fvref; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(expr))) + return_false(sc, expr); + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_call(opc).fd = opt_d_7pi_sf; + return_true(sc, expr); + } + if ((len == 3) && + (vector_rank(obj) == 2)) + { + s7_pointer arg1_slot; + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + q_func1(opc).d_7pii_f = float_vector_ref_d_7pii; /* not used in opt_d_7pii_sss_unchecked or opt_d_7pii_sff, but d_dd_ok checks it */ + arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + s7_pointer arg2_slot; + q_arg2(opc).p = arg1_slot; + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + q_arg3(opc).p = arg2_slot; + q_call(opc).fd = opt_d_7pii_sss; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(obj, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(obj, 1)))) + q_call(opc).fd = opt_d_7pii_sss_unchecked; + return_true(sc, expr); + }} + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_call(opc).fd = opt_d_7pii_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + return_true(sc, expr); + }}} + if ((len == 4) && + (vector_rank(obj) == 3)) + { + s7_pointer arg1_slot; + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + s7_pointer arg2_slot; + q_arg2(opc).p = arg1_slot; + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + s7_pointer arg3_slot; + q_arg3(opc).p = arg2_slot; + arg3_slot = opt_integer_symbol(sc, cadddr(expr)); + if (arg3_slot) + { + q_arg4(opc).p = arg3_slot; + q_call(opc).fd = opt_d_7piii_ssss; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(obj, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(obj, 1))) && + (loop_end_fits(q_arg4(opc).p, vector_dimension(obj, 2)))) + q_call(opc).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) + { + s7_pointer arg1_slot; + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = s_slot; + /* opc-v[4].gen = (void *)c_object_value(obj); */ + q_func(opc).d_7pi_f = func; + arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + q_call(opc).fd = opt_d_7pi_ss; + q_arg2(opc).p = arg1_slot; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_call(opc).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(q_arg1(o).p) != o->sc->F);} + +static bool opt_bool_not_pair(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer slot; + if (!is_symbol(expr)) return_false(sc, expr); /* i.e. use cell_optimize */ + slot = opt_simple_symbol(sc, expr); + if ((slot) && + (is_boolean(slot_value(slot)))) + { + opt_info *opc = alloc_opt_info(sc); + q_arg1(opc).p = slot; + q_call(opc).fb = opt_b_s; + return_true(sc, expr); + } + return_false(sc, expr); +} + +/* -------- b_idp -------- */ +static bool opt_b_i_s(opt_info *o) {return(q_func(o).b_i_f(integer(slot_value(q_arg1(o).p))));} +static bool opt_b_i_f(opt_info *o) {return(q_func(o).b_i_f(q_i_func1_call(o)));} +static bool opt_b_d_s(opt_info *o) {return(q_func(o).b_d_f(s7_real(slot_value(q_arg1(o).p))));} /* not s7test tmap */ +static bool opt_b_d_f(opt_info *o) {return(q_func(o).b_d_f(q_d_func1_call(o)));} +static bool opt_b_p_s(opt_info *o) {return(q_func(o).b_p_f(slot_value(q_arg1(o).p)));} +static bool opt_b_p_f(opt_info *o) {return(q_func(o).b_p_f(q_p_func1_call(o)));} /* used in opt_if_nbp_s */ +static bool opt_b_7p_s(opt_info *o) {return(q_func(o).b_7p_f(o->sc, slot_value(q_arg1(o).p)));} +static bool opt_b_7p_s_not(opt_info *o) {return(slot_value(q_arg1(o).p) == o->sc->F);} /* not s7test *shoot */ +static bool opt_b_7p_f(opt_info *o) {return(q_func(o).b_7p_f(o->sc, q_p_func1_call(o)));} +static bool opt_b_d_s_is_positive(opt_info *o) {return(real(slot_value(q_arg1(o).p)) > 0.0);} +static bool opt_b_p_s_is_integer(opt_info *o) {return(s7_is_integer(slot_value(q_arg1(o).p)));} /* not s7test tmap */ +static bool opt_b_p_s_is_pair(opt_info *o) {return(is_pair(slot_value(q_arg1(o).p)));} +static bool opt_b_p_f_is_string(opt_info *o) {return(s7_is_string(q_p_func1_call(o)));} +static bool opt_b_7p_s_iter_at_end(opt_info *o) {return(iterator_is_at_end(slot_value(q_arg1(o).p)));} +static bool opt_b_7p_f_not(opt_info *o) {return((q_p_func1_call(o)) == o->sc->F);} + +static bool opt_zero_mod(opt_info *o) +{ + s7_int x = integer(slot_value(q_arg1(o).p)); + return((x % q_arg2(o).i) == 0); +} + +static bool just_ints(s7_scheme *sc, s7_pointer form) +{ + if (is_pair(form)) + return((just_ints(sc, car(form))) && + (just_ints(sc, cdr(form)))); + return((!is_number(form)) || (is_t_integer(form))); +} + +static bool just_floats(s7_scheme *sc, s7_pointer form) +{ + if (is_pair(form)) + return((just_floats(sc, car(form))) && + (just_floats(sc, cdr(form)))); + return((!is_number(form)) || (is_t_real(form))); +} + +static bool b_idp_ok(s7_scheme *sc, const s7_pointer s_func, const s7_pointer form, const s7_pointer arg_type) +{ + opt_info *opc = alloc_opt_info(sc); + const int32_t cur_index = sc->pc; + s7_pointer expr = car(form); + + if (((arg_type == sc->is_integer_symbol) || (arg_type == sc->is_byte_symbol)) && + (just_ints(sc, form))) + { + const s7_b_i_t bif = s7_b_i_function(s_func); + if (bif) + { + q_func(opc).b_i_f = bif; + if (is_symbol(cadr(expr))) + { + q_arg1(opc).p = s7_t_slot(sc, cadr(expr)); + q_call(opc).fb = opt_b_i_s; + return_true(sc, expr); + } + q_func1_arg(opc).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) && + (q_call(o1).fi == opt_i_ii_sc) && + (q_func(o1).i_ii_f == modulo_i_ii_unchecked)) + { + q_call(opc).fb = opt_zero_mod; + q_arg1(opc).p = q_arg1(o1).p; + q_arg2(opc).i = q_arg2(o1).i; + backup_pc(sc); + return_true(sc, expr); + } + q_call(opc).fb = opt_b_i_f; + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + return_true(sc, expr); + }}} + else + if ((arg_type == sc->is_float_symbol) && + (just_floats(sc, form))) + { + const s7_b_d_t bdf = s7_b_d_function(s_func); + if (bdf) + { + q_func(opc).b_d_f = bdf; + if (is_symbol(cadr(expr))) + { + q_arg1(opc).p = s7_t_slot(sc, cadr(expr)); + q_call(opc).fb = (bdf == positive_d) ? opt_b_d_s_is_positive : opt_b_d_s; + return_true(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + q_call(opc).fb = opt_b_d_f; + q_func1(opc).fd = q_func1_arg(opc).q_call(o1).fd; + return_true(sc, expr); + }}} + sc->pc = cur_index; + { + s7_b_p_t bpf = s7_b_p_function(s_func); + s7_b_7p_t bpf7 = NULL; + if (!bpf) bpf7 = s7_b_7p_function(s_func); + if ((bpf) || (bpf7)) + { + if (bpf) + q_func(opc).b_p_f = bpf; + else q_func(opc).b_7p_f = bpf7; + if (is_symbol(cadr(expr))) + { + const s7_pointer slot = opt_simple_symbol(sc, cadr(expr)); + if (!slot) return_false(sc, expr); + q_arg1(opc).p = slot; + q_call(opc).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(slot)))) ? opt_b_7p_s_iter_at_end : + ((bpf7 == not_b_7p) ? opt_b_7p_s_not : opt_b_7p_s)); + return_true(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + q_call(opc).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; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + return_true(sc, expr); + }}} + return_false(sc, expr); +} + +/* -------- b_pp -------- */ +static s7_pointer opt_arg_type(s7_scheme *sc, s7_pointer argp) +{ + 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(sc, car(arg))) && (is_pair(cdr(arg)))) + return(s7_type_of(sc, cadr(arg))); + } + { + s7_pointer arg_slot = s7_slot(sc, car(arg)); + if ((is_slot(arg_slot)) && + (is_sequence(slot_value(arg_slot)))) + { + s7_pointer sig = s7_signature(sc, slot_value(arg_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)) + { + s7_pointer arg_slot = opt_simple_symbol(sc, arg); + if (!arg_slot) return(sc->T); + return(s7_type_of(sc, slot_value(arg_slot))); + } + return(s7_type_of(sc, arg)); +} + +static bool opt_b_pp_sf(opt_info *o) {return(q_func(o).b_pp_f(slot_value(q_arg1(o).p), q_p_func2_call(o)));} +static bool opt_b_pp_fs(opt_info *o) {return(q_func(o).b_pp_f(q_p_func2_call(o), slot_value(q_arg2(o).p)));} +static bool opt_b_pp_ss(opt_info *o) {return(q_func(o).b_pp_f(slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static bool opt_b_pp_sc(opt_info *o) {return(q_func(o).b_pp_f(slot_value(q_arg1(o).p), q_arg2(o).p));} +static bool opt_b_pp_sfo(opt_info *o) {return(q_func(o).b_pp_f(slot_value(q_arg1(o).p), q_func1(o).p_p_f(o->sc, slot_value(q_arg2(o).p))));} +static bool opt_b_7pp_sf(opt_info *o) {return(q_func(o).b_7pp_f(o->sc, slot_value(q_arg1(o).p), q_p_func2_call(o)));} +static bool opt_b_7pp_fs(opt_info *o) {return(q_func(o).b_7pp_f(o->sc, q_p_func2_call(o), slot_value(q_arg2(o).p)));} +static bool opt_b_7pp_ss(opt_info *o) {return(q_func(o).b_7pp_f(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static bool opt_b_7pp_ss_lt(opt_info *o) {return(lt_b_7pp(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static bool opt_b_7pp_ss_gt(opt_info *o) {return(gt_b_7pp(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static bool opt_b_7pp_ss_char_lt(opt_info *o) {return(char_lt_b_7pp(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static bool opt_b_7pp_sc(opt_info *o) {return(q_func(o).b_7pp_f(o->sc, slot_value(q_arg1(o).p), q_arg2(o).p));} +static bool opt_b_7pp_sfo(opt_info *o) {return(q_func(o).b_7pp_f(o->sc, slot_value(q_arg1(o).p), q_func1(o).p_p_f(o->sc, slot_value(q_arg2(o).p))));} +static bool opt_is_equal_sfo(opt_info *o) {return(s7_is_equal(o->sc, slot_value(q_arg1(o).p), q_func1(o).p_p_f(o->sc, slot_value(q_arg2(o).p))));} +static bool opt_is_equivalent_sfo(opt_info *o) {return(is_equivalent_1(o->sc, slot_value(q_arg1(o).p), q_func1(o).p_p_f(o->sc, slot_value(q_arg2(o).p)), NULL));} +static bool opt_b_pp_sf_char_eq(opt_info *o) {return(slot_value(q_arg1(o).p) == q_p_func2_call(o));} /* lt above checks for char args */ +static bool opt_b_7pp_ff(opt_info *o) {s7_pointer p = q_p_func3_call(o); return(q_func(o).b_7pp_f(o->sc, p, q_p_func2_call(o)));} +static bool opt_b_pp_ff(opt_info *o) {s7_pointer p = q_p_func3_call(o); return(q_func(o).b_pp_f(p, q_p_func2_call(o)));} +static bool opt_b_pp_ff_char_eq(opt_info *o) {return(q_p_func3_call(o) == q_p_func2_call(o));} +static bool opt_b_pp_fc_char_eq(opt_info *o) {return(q_p_func3_call(o) == q_arg1(o).p);} +static bool opt_b_pp_fc(opt_info *o) {return(q_func(o).b_pp_f(q_p_func3_call(o), q_arg1(o).p));} +static bool opt_b_7pp_fc(opt_info *o) {return(q_func(o).b_7pp_f(o->sc, q_p_func3_call(o), q_arg1(o).p));} + +static bool opt_car_equal_sf(opt_info *o) +{ + s7_pointer p = slot_value(q_arg2(o).p); + return(s7_is_equal(o->sc, slot_value(q_arg1(o).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(q_arg2(o).p); + return(is_equivalent_1(o->sc, slot_value(q_arg1(o).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(q_arg2(o).p); + return(q_func(o).b_7pp_f(o->sc, slot_value(q_arg1(o).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(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_i_func1_call(o))); +} + +static bool opt_substring_equal_sf(opt_info *o) {return(scheme_strings_are_equal(slot_value(q_arg1(o).p), opt_p_substring_uncopied_ssf(q_func2_arg(o).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 (q_call(o1).fp == opt_p_p_s) + { + q_arg2(opc).p = q_arg1(o1).p; + q_func1(opc).p_p_f = q_func1(o1).p_p_f; + if (bpf_case) + q_call(opc).fb = opt_b_pp_sfo; + else + if (q_func1(opc).p_p_f == car_p_p) + q_call(opc).fb = ((q_func(opc).b_7pp_f == s7_is_equal) ? opt_car_equal_sf : + ((q_func(opc).b_7pp_f == s7_is_equivalent) ? opt_car_equivalent_sf : opt_b_7pp_car_sf)); + else q_call(opc).fb = ((q_func(opc).b_7pp_f == s7_is_equal) ? opt_is_equal_sfo : + ((q_func(opc).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 = q_func1(o).p_p_f(o->sc, slot_value(q_arg1(o).p)); + return(q_func(o).b_pp_f(b1, q_func2(o).p_p_f(o->sc, slot_value(q_arg2(o).p)))); +} + +static bool opt_b_pp_ffo_is_eq(opt_info *o) +{ + s7_pointer b1 = q_func1(o).p_p_f(o->sc, slot_value(q_arg1(o).p)); + s7_pointer b2 = q_func2(o).p_p_f(o->sc, slot_value(q_arg2(o).p)); + return((b1 == b2) || ((is_unspecified(b1)) && (is_unspecified(b2)))); +} + +static bool opt_b_7pp_ffo(opt_info *o) +{ + s7_pointer b1 = q_func1(o).p_p_f(o->sc, slot_value(q_arg1(o).p)); + return(q_func(o).b_7pp_f(o->sc, b1, q_func2(o).p_p_f(o->sc, slot_value(q_arg2(o).p)))); +} + +static bool opt_b_cadr_cadr(opt_info *o) +{ + s7_pointer p1 = slot_value(q_arg1(o).p); + s7_pointer p2 = slot_value(q_arg2(o).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(q_func(o).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 ((q_call(o1).fp == opt_p_p_s) && (q_call(o2).fp == opt_p_p_s)) + { + q_arg1(opc).p = q_arg1(o1).p; + q_func1(opc).p_p_f = q_func1(o1).p_p_f; + q_arg2(opc).p = q_arg1(o2).p; + q_func2(opc).p_p_f = q_func1(o2).p_p_f; + q_call(opc).fb = (bpf_case) ? ((q_func(opc).b_pp_f == s7_is_eq) ? opt_b_pp_ffo_is_eq : opt_b_pp_ffo) : + (((q_func2(opc).p_p_f == cadr_p_p) && (q_func1(opc).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)) + { + q_call(opc).fb = fb; + q_func(opc).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))) + { + q_arg1(opc).p = opt_simple_symbol(sc, arg1); + q_arg2(opc).p = opt_simple_symbol(sc, arg2); + if ((q_arg1(opc).p) && (q_arg2(opc).p)) + { + const s7_b_7pp_t b7f = (bpf_case) ? NULL : q_func(opc).b_7pp_f; + q_call(opc).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)) + { + q_arg1(opc).p = opt_simple_symbol(sc, arg1); + if (!q_arg1(opc).p) + return_false(sc, expr); + if ((!is_symbol(arg2)) && (!is_pair(arg2))) + { + q_arg2(opc).p = arg2; + q_call(opc).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)) + { + q_func2_arg(opc).o1 = sc->opts[cur_index]; + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + q_call(opc).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 ((q_func2(opc).fp == opt_p_substring_uncopied_ssf) && (q_func(opc).b_pp_f == string_eq_b_unchecked)) + q_call(opc).fb = opt_substring_equal_sf; /*concordance.scm */ + else if (q_func(opc).b_pp_f == char_eq_b_unchecked) q_call(opc).fb = opt_b_pp_sf_char_eq; + } + return_true(sc, expr); + } + sc->pc = cur_index; + } + else + if ((is_symbol(arg2)) && + (is_pair(arg1))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + q_arg2(opc).p = s7_slot(sc, arg2); /* can be # */ + if ((!is_slot(q_arg2(opc).p)) || + (has_methods(slot_value(q_arg2(opc).p)))) + return_false(sc, expr); + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + q_call(opc).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->[8].o1 etc */ + if (cell_optimize(sc, cdr(expr))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + if (b_pp_ff_combinable(sc, opc, bpf_case)) + return_true(sc, expr); + q_call(opc).fb = (bpf_case) ? opt_b_pp_ff : opt_b_7pp_ff; + q_func3_arg(opc).o1 = o1; + q_func3(opc).fp = q_call(o1).fp; + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + check_b_types(sc, opc, s_func, expr, opt_b_pp_ff); + if (q_func(opc).b_pp_f == char_eq_b_unchecked) + { + if (q_func2(opc).fp == opt_p_c) /* q_func2(opc).fp can be opt_p_c where q_func2_arg(opc).q_arg1(o1).p is the char */ + { + q_call(opc).fb = opt_b_pp_fc_char_eq; + q_arg1(opc).p = q_func2_arg(opc).q_arg1(o1).p; + } + else q_call(opc).fb = opt_b_pp_ff_char_eq; + } + else + if (q_func2(opc).fp == opt_p_c) + { + q_call(opc).fb = (q_call(opc).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 */ + q_arg1(opc).p = q_func2_arg(opc).q_arg1(o1).p; + } + return_true(sc, expr); + }} + return_false(sc, expr); +} + +/* -------- b_pi -------- */ + +static bool opt_b_pi_fs(opt_info *o) {return(q_func4(o).b_pi_f(o->sc, q_p_func2_call(o), integer(slot_value(q_arg1(o).p))));} +static bool opt_b_pi_fs_num_eq(opt_info *o) {return(num_eq_b_pi(o->sc, q_p_func2_call(o), integer(slot_value(q_arg1(o).p))));} +static bool opt_b_pi_fc(opt_info *o) {return(q_func4(o).b_pi_f(o->sc, q_p_func2_call(o), q_arg1(o).i));} +static bool opt_b_pi_ff(opt_info *o) {s7_pointer p = q_p_func2_call(o); return(q_func4(o).b_pi_f(o->sc, p, q_i_func3_call(o)));} + +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) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + opt_info *o1 = sc->opts[sc->pc]; + q_func4(opc).b_pi_f = bpif; + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + if (is_symbol(arg2)) + { + q_arg1(opc).p = s7_t_slot(sc, arg2); /* slot checked in opt_arg_type */ + q_call(opc).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)) + { + q_arg1(opc).i = integer(arg2); + q_call(opc).fb = opt_b_pi_fc; + return_true(sc, expr); + } + if (int_optimize(sc, cddr(expr))) + { + q_call(opc).fb = opt_b_pi_ff; + q_func3_arg(opc).o1 = o1; + q_func3(opc).fp = q_call(o1).fp; + return_true(sc, expr); + }}} + return_false(sc, expr); +} + +/* -------- b_dd -------- */ +static bool opt_b_dd_ss(opt_info *o) {return(q_func(o).b_dd_f(real(slot_value(q_arg1(o).p)), real(slot_value(q_arg2(o).p))));} +static bool opt_b_dd_ss_lt(opt_info *o) {return(real(slot_value(q_arg1(o).p)) < real(slot_value(q_arg2(o).p)));} +static bool opt_b_dd_ss_gt(opt_info *o) {return(real(slot_value(q_arg1(o).p)) > real(slot_value(q_arg2(o).p)));} + +static bool opt_b_dd_sc(opt_info *o) {return(q_func(o).b_dd_f(real(slot_value(q_arg1(o).p)), q_arg2(o).x));} +static bool opt_b_dd_sc_lt(opt_info *o) {return(real(slot_value(q_arg1(o).p)) < q_arg2(o).x);} +static bool opt_b_dd_sc_geq(opt_info *o) {return(real(slot_value(q_arg1(o).p)) >= q_arg2(o).x);} +static bool opt_b_dd_sc_eq(opt_info *o) {return(real(slot_value(q_arg1(o).p)) == q_arg2(o).x);} + +static bool opt_b_dd_sf(opt_info *o) {return(q_func(o).b_dd_f(real(slot_value(q_arg1(o).p)), q_d_func2_call(o)));} +static bool opt_b_dd_fs(opt_info *o) {return(q_func(o).b_dd_f(q_d_func2_call(o), real(slot_value(q_arg2(o).p))));} +static bool opt_b_dd_fs_gt(opt_info *o) {return(q_d_func2_call(o) > real(slot_value(q_arg2(o).p)));} +static bool opt_b_dd_fc(opt_info *o) {return(q_func(o).b_dd_f(q_d_func2_call(o), q_arg2(o).x));} +static bool opt_b_dd_fc_gt(opt_info *o) {return(q_d_func2_call(o) > q_arg2(o).x);} + +static bool opt_b_dd_ff(opt_info *o) +{ + s7_double x1 = q_d_func2_call(o); + s7_double x2 = q_d_func3_call(o); + return(q_func(o).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); + q_func(opc).b_dd_f = bif; + if (is_symbol(arg1)) + { + q_arg1(opc).p = s7_t_slot(sc, arg1); + if (is_symbol(arg2)) + { + q_arg2(opc).p = s7_t_slot(sc, arg2); + q_call(opc).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)) + { + q_arg2(opc).x = s7_number_to_real(sc, arg2); + q_call(opc).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); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + q_call(opc).fb = opt_b_dd_sf; + return_true(sc, expr); + }} + sc->pc = cur_index; + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cdr(expr))) + { + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + if (is_symbol(arg2)) + { + q_arg2(opc).p = s7_t_slot(sc, arg2); + q_call(opc).fb = (bif == gt_b_dd) ? opt_b_dd_fs_gt : opt_b_dd_fs; + return_true(sc, expr); + } + if (is_small_real(arg2)) + { + q_arg2(opc).x = s7_number_to_real(sc, arg2); + q_call(opc).fb = (bif == gt_b_dd) ? opt_b_dd_fc_gt : opt_b_dd_fc; + return_true(sc, expr); + } + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + q_call(opc).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(q_func(o).b_ii_f(integer(slot_value(q_arg1(o).p)), integer(slot_value(q_arg2(o).p))));} +static bool opt_b_ii_ss_lt(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) < integer(slot_value(q_arg2(o).p)));} +static bool opt_b_ii_ss_gt(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) > integer(slot_value(q_arg2(o).p)));} +static bool opt_b_ii_ss_leq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) <= integer(slot_value(q_arg2(o).p)));} +static bool opt_b_ii_ss_geq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) >= integer(slot_value(q_arg2(o).p)));} +static bool opt_b_ii_ss_eq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) == integer(slot_value(q_arg2(o).p)));} +static bool opt_b_ii_sc(opt_info *o) {return(q_func(o).b_ii_f(integer(slot_value(q_arg1(o).p)), q_arg2(o).i));} +static bool opt_b_ii_sc_lt(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) < q_arg2(o).i);} +static bool opt_b_ii_sc_leq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) <= q_arg2(o).i);} +static bool opt_b_ii_sc_gt(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) > q_arg2(o).i);} +static bool opt_b_ii_sc_geq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) >= q_arg2(o).i);} +static bool opt_b_ii_sc_eq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) == q_arg2(o).i);} +static bool opt_b_ii_sc_lt_2(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) < 2);} +static bool opt_b_ii_sc_lt_1(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) < 1);} +static bool opt_b_ii_sc_lt_0(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) < 0);} +static bool opt_b_ii_sc_leq_0(opt_info *o){return(integer(slot_value(q_arg1(o).p)) <= 0);} +static bool opt_b_ii_sc_gt_0(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) > 0);} +static bool opt_b_ii_sc_geq_0(opt_info *o){return(integer(slot_value(q_arg1(o).p)) >= 0);} +static bool opt_b_ii_sc_eq_0(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) == 0);} +static bool opt_b_ii_sc_eq_1(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) == 1);} + +static bool opt_b_7ii_ss(opt_info *o) {return(q_func(o).b_7ii_f(o->sc, integer(slot_value(q_arg1(o).p)), integer(slot_value(q_arg2(o).p))));} +static bool opt_b_7ii_sc(opt_info *o) {return(q_func(o).b_7ii_f(o->sc, integer(slot_value(q_arg1(o).p)), q_arg2(o).i));} +static bool opt_b_7ii_sc_bit(opt_info *o) {return((integer(slot_value(q_arg1(o).p)) & ((s7_int)(1LL << q_arg2(o).i))) != 0);} + +static bool opt_b_ii_ff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + s7_int i2 = q_i_func3_call(o); + return(q_func(o).b_ii_f(i1, i2)); +} + +static bool opt_b_ii_fs(opt_info *o) {return(q_func(o).b_ii_f(q_i_func2_call(o), integer(slot_value(q_arg2(o).p))));} +static bool opt_b_ii_sf(opt_info *o) {return(q_func(o).b_ii_f(integer(slot_value(q_arg1(o).p)), q_i_func2_call(o)));} +static bool opt_b_ii_sf_eq(opt_info *o) {return(integer(slot_value(q_arg1(o).p)) == q_i_func2_call(o));} +static bool opt_b_ii_fc(opt_info *o) {return(q_func(o).b_ii_f(q_i_func2_call(o), q_arg2(o).i));} +static bool opt_b_ii_fc_eq(opt_info *o) {return(q_i_func2_call(o) == q_arg2(o).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) q_func(opc).b_ii_f = bif; else q_func(opc).b_7ii_f = b7if; + if (is_symbol(arg1)) + { + q_arg1(opc).p = s7_t_slot(sc, arg1); + if (is_symbol(arg2)) + { + q_arg2(opc).p = s7_t_slot(sc, arg2); + q_call(opc).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); + q_arg2(opc).i = i2; + q_call(opc).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); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if ((bif) && (int_optimize(sc, cddr(expr)))) + { + q_call(opc).fb = (bif == num_eq_b_ii) ? opt_b_ii_sf_eq : opt_b_ii_sf; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + return_true(sc, expr); + } + return_false(sc, expr); + } + if (!bif) return_false(sc, expr); + + if (is_symbol(arg2)) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(expr))) + return_false(sc, expr); + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_arg2(opc).p = s7_t_slot(sc, arg2); + q_call(opc).fb = opt_b_ii_fs; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + if (is_t_integer(arg2)) + { + q_arg2(opc).i = integer(arg2); + q_call(opc).fb = (bif == num_eq_b_ii) ? opt_b_ii_fc_eq : opt_b_ii_fc; + return_true(sc, expr); + } + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + q_call(opc).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((q_func(o).fb(q_arg1(o).o1)) && (q_b_func2_call(o)));} + +#define q_bool_call(o, i) o->v[i + 3] + +static bool opt_and_any_b(opt_info *o) +{ + for (s7_int i = 0; i < q_arg1(o).i; i++) + { + opt_info *o1 = q_bool_call(o, i).o1; + if (!q_call(o1).fb(o1)) + return(false); + } + return(true); +} + +static bool opt_or_bb(opt_info *o) {return((q_func(o).fb(q_arg1(o).o1)) || (q_b_func2_call(o)));} + +static bool opt_or_any_b(opt_info *o) +{ + for (s7_int i = 0; i < q_arg1(o).i; i++) + { + opt_info *o1 = q_bool_call(o, i).o1; + if (q_call(o1).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))) + { + q_func2_arg(opc).o1 = o2; + q_func2(opc).fb = q_call(o2).fb; + q_call(opc).fb = (is_and) ? opt_and_bb : opt_or_bb; + q_arg1(opc).o1 = o1; + q_func(opc).fb = q_call(o1).fb; + return_true(sc, expr); + }} + return_false(sc, expr); + } + q_arg1(opc).i = (len - 1); + for (int32_t i = 0; (is_pair(p)) && (i < 12); i++, p = cdr(p)) + { + q_bool_call(opc, i).o1 = sc->opts[sc->pc]; + if (!bool_optimize_nw(sc, p)) + break; + } + if (!is_null(p)) + return_false(sc, expr); + q_call(opc).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(q_arg1(o).p);} +static s7_pointer opt_p_s(opt_info *o) {return(slot_value(q_arg1(o).p));} + +static bool opt_cell_not_pair(s7_scheme *sc, s7_pointer expr) +{ + s7_pointer slot; + opt_info *opc; + if (!is_symbol(expr)) + { + opc = alloc_opt_info(sc); + q_arg1(opc).p = expr; + q_call(opc).fp = opt_p_c; + return_true(sc, expr); + } + slot = opt_simple_symbol(sc, expr); + if (!slot) + return_false(sc, expr); + opc = alloc_opt_info(sc); + q_arg1(opc).p = slot; + q_call(opc).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(q_func(o).p_f(o->sc));} +static s7_pointer opt_p_call(opt_info *o) {return(q_func(o).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) + { + q_func(opc).p_f = func; + q_call(opc).fp = opt_p_f; + return_true(sc, expr); + } + if ((is_safe_procedure(s_func)) && + (c_function_min_args(s_func) == 0)) + { + q_func(opc).call = cf_call(sc, expr, s_func, 0); + q_call(opc).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(q_func1(o).p_p_f(o->sc, q_arg1(o).p));} +static s7_pointer opt_p_i_c(opt_info *o) {return(make_integer(o->sc, q_func(o).i_i_f(q_arg1(o).i)));} +static s7_pointer opt_p_7i_c(opt_info *o) {return(make_integer(o->sc, q_func(o).i_7i_f(o->sc, q_arg1(o).i)));} +static s7_pointer opt_p_d_c(opt_info *o) {return(make_real(o->sc, q_func(o).d_d_f(q_arg1(o).x)));} +static s7_pointer opt_p_7d_c(opt_info *o) {return(make_real(o->sc, q_func(o).d_7d_f(o->sc, q_arg1(o).x)));} +static s7_pointer opt_p_p_s(opt_info *o) {return(q_func1(o).p_p_f(o->sc, slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_p_s_abs(opt_info *o) {return(abs_p_p(o->sc, slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_p_s_random(opt_info *o) {return(random_p_p(o->sc, slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_p_s_random_wrapped(opt_info *o) {return(random_p_p_wrapped(o->sc, slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_p_s_cdr(opt_info *o) {s7_pointer p = slot_value(q_arg1(o).p); return((is_pair(p)) ? cdr(p) : cdr_p_p(o->sc, p));} +static s7_pointer opt_p_p_f(opt_info *o) {return(q_func1(o).p_p_f(o->sc, q_p_func2_call(o)));} +static s7_pointer opt_p_p_f1(opt_info *o) {return(q_func1(o).p_p_f(o->sc, q_func(o).p_p_f(o->sc, slot_value(q_arg1(o).p))));} +static s7_pointer opt_p_p_f_exp(opt_info *o) {return(exp_p_p(o->sc, q_p_func2_call(o)));} +static s7_pointer opt_p_7d_c_random(opt_info *o) {return(make_real(o->sc, random_d_7d(o->sc, q_arg1(o).x)));} +static s7_pointer opt_p_p_s_iterate(opt_info *o) {return(iterate_p_p(o->sc, slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_p_f_iterate(opt_info *o) {return(iterate_p_p(o->sc, q_p_func2_call(o)));} +static s7_pointer opt_p_z_f_magnitude(opt_info *o) {return(magnitude_p_z(o->sc, q_p_func2_call(o)));} +static s7_pointer opt_p_p_f_string_to_number(opt_info *o) {return(string_to_number_p_p(o->sc, q_p_func2_call(o)));} +static s7_pointer opt_p_p_s_iterate_unchecked(opt_info *o) {s7_pointer iter = slot_value(q_arg1(o).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(q_func1(o).p_p_f(o->sc, opt_p_pi_ss_fvref_direct_wrapped(q_func2_arg(o).o1)));} /* unwrap to fvref is not faster */ +static s7_pointer opt_p_p_ivref(opt_info *o) {return(q_func1(o).p_p_f(o->sc, opt_p_pi_ss_ivref_direct_wrapped(q_func2_arg(o).o1)));} /* unwrap to ivref is not faster */ +static s7_pointer opt_p_p_vref(opt_info *o) {return(q_func1(o).p_p_f(o->sc, opt_p_pi_ss_vref_direct(q_func2_arg(o).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 (q_call(o1).fp == opt_p_p_s) + { + q_func(opc).p_p_f = q_func1(o1).p_p_f; + q_arg1(opc).p = q_arg1(o1).p; + q_call(opc).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(q_func(o).call(o->sc, set_plist_1(o->sc, q_p_func1_call(o))));} +static s7_pointer opt_p_call_s(opt_info *o) {return(q_func(o).call(o->sc, set_plist_1(o->sc, slot_value(q_arg1(o).p))));} +static s7_pointer opt_p_call_c(opt_info *o) {return(q_func(o).call(o->sc, set_plist_1(o->sc, q_arg1(o).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; + q_arg1(opc).i = integer(arg1); + if (iif) + { + q_func(opc).i_i_f = iif; + q_call(opc).fp = opt_p_i_c; + return_true(sc, expr); + } + i7if = s7_i_7i_function(s_func); + if (i7if) + { + q_func(opc).i_7i_f = i7if; + q_call(opc).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; + q_arg1(opc).x = real(arg1); + if (ddf) + { + q_func(opc).d_d_f = ddf; + q_call(opc).fp = opt_p_d_c; + return_true(sc, expr); + } + d7df = s7_d_7d_function(s_func); + if (d7df) + { + q_func(opc).d_7d_f = d7df; + q_call(opc).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; + q_func1(opc).p_p_f = ppf; /* TODO: func! */ + if ((ppf == symbol_to_string_p_p) && + (is_optimized(expr)) && + (fn_proc(expr) == g_symbol_to_string_uncopied)) + q_func1(opc).p_p_f = symbol_to_string_uncopied_p; + + if (is_symbol(arg1)) + { + q_arg1(opc).p = opt_simple_symbol(sc, arg1); + if (!q_arg1(opc).p) + return_false(sc, expr); + q_call(opc).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(q_arg1(opc).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 (q_func1(opc).p_p_f == s7_length) + { + q_arg1(opc).p = s7_length(sc, arg1); + q_call(opc).fp = opt_p_c; + } + else + { + q_arg1(opc).p = arg1; + q_call(opc).fp = opt_p_p_c; /* see p_pip_ssf_combinable */ + } + 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) && + ((q_call(o1).fp == opt_p_pi_ss) || (q_call(o1).fp == opt_p_pi_sf)) && + (q_func(o1).p_pi_f == complex_vector_ref_p_pi)) + { + q_func(o1).p_pi_f = complex_vector_ref_p_pi_wrapped; + q_call(opc).fp = opt_p_z_f_magnitude; + } + else + q_call(opc).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)); + q_func2_arg(opc).o1 = o1; + fp = q_call(o1).fp; + q_func2(opc).fp = fp; + if (fp == opt_p_pi_ss_fvref_direct) q_call(opc).fp = opt_p_p_fvref; + else if (fp == opt_p_pi_ss_vref_direct) q_call(opc).fp = opt_p_p_vref; + else if (fp == opt_p_pi_ss_ivref_direct) q_call(opc).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))) + { + q_func(opc).call = cf_call(sc, expr, s_func, 1); + if (is_symbol(arg1)) + { + const s7_pointer slot = opt_simple_symbol(sc, arg1); + if (slot) + { + q_arg1(opc).p = slot; + q_call(opc).fp = opt_p_call_s; + return_true(sc, expr); + }} + else + { + opt_info *o1; + if (!is_pair(arg1)) + { + q_arg1(opc).p = arg1; + q_call(opc).fp = opt_p_call_c; + return_true(sc, expr); + } + o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + q_call(opc).fp = opt_p_call_f; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + if (q_func1(opc).fp == opt_p_pi_ss_fvref_direct) q_func1(opc).fp = opt_p_pi_ss_fvref_direct_wrapped; + else if (q_func1(opc).fp == opt_p_pi_ss_ivref_direct) q_func1(opc).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(q_func(o).p_i_f(o->sc, integer(slot_value(q_arg1(o).p))));} /* number_to_string_p_i expanded here doesn't gain much */ +static s7_pointer opt_p_i_f(opt_info *o) {return(q_func(o).p_i_f(o->sc, q_i_func1_call(o)));} +static s7_pointer opt_p_i_f_intc(opt_info *o) {return(integer_to_char_p_i(o->sc, q_i_func1_call(o)));} + +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 slot; + const s7_p_i_t ifunc = s7_p_i_function(s_func); + if (!ifunc) return_false(sc, expr); + q_func(opc).p_i_f = ifunc; + slot = opt_integer_symbol(sc, cadr(expr)); + if (slot) + { + q_arg1(opc).p = slot; + q_call(opc).fp = opt_p_i_s; + return_true(sc, expr); + } + if (int_optimize(sc, cdr(expr))) + { + q_call(opc).fp = (ifunc == integer_to_char_p_i) ? opt_p_i_f_intc : opt_p_i_f; + q_func1_arg(opc).o1 = sc->opts[pstart]; + q_func1(opc).fi = q_call(sc->opts[pstart]).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(q_func(o).p_ii_f(o->sc, integer(slot_value(q_arg1(o).p)), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_ii_fs(opt_info *o) {return(q_func(o).p_ii_f(o->sc, q_i_func1_call(o), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_ii_ff_divide(opt_info *o) +{ + return(make_ratio_with_div_check(o->sc, o->sc->divide_symbol, q_i_func1_call(o), q_i_func2_call(o))); +} + +static s7_pointer opt_p_ii_ff(opt_info *o) +{ + s7_int i1 = q_i_func1_call(o); + return(q_func(o).p_ii_f(o->sc, i1, q_i_func2_call(o))); +} + +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 arg2_slot; + const s7_p_ii_t ifunc = s7_p_ii_function(s_func); + if (!ifunc) return_false(sc, expr); + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + const s7_pointer arg1_slot = opt_integer_symbol(sc, cadr(expr)); + if (arg1_slot) + { + q_arg1(opc).p = arg1_slot; + q_arg2(opc).p = arg2_slot; + q_func(opc).p_ii_f = ifunc; + q_call(opc).fp = opt_p_ii_ss; + return_true(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + q_arg2(opc).p = arg2_slot; + q_func(opc).p_ii_f = ifunc; + q_call(opc).fp = opt_p_ii_fs; + return_true(sc, expr); + } + sc->pc = pstart; + return_false(sc, expr); + } + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func(opc).p_ii_f = ifunc; + q_call(opc).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(q_func(o).p_d_f(o->sc, real_to_double(o->sc, slot_value(q_arg2(o).p), __func__)));} +static s7_pointer opt_p_d_f(opt_info *o) {return(q_func(o).p_d_f(o->sc, q_d_func1_call(o)));} + +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 arg1_slot; + opt_info *o1; + const s7_p_d_t ifunc = s7_p_d_function(s_func); + if (!ifunc) return_false(sc, expr); + arg1_slot = opt_float_symbol(sc, cadr(expr)); + if (arg1_slot) + { + q_arg2(opc).p = arg1_slot; + q_func(opc).p_d_f = ifunc; + q_call(opc).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))) + { + q_func(opc).p_d_f = ifunc; + q_call(opc).fp = opt_p_d_f; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fd = q_call(o1).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(q_func(o).p_dd_f(o->sc, real_to_double(o->sc, slot_value(q_arg1(o).p), __func__), q_arg2(o).x));} +static s7_pointer opt_p_dd_cs(opt_info *o) {return(q_func(o).p_dd_f(o->sc, q_arg1(o).x, real_to_double(o->sc, slot_value(q_arg2(o).p), __func__)));} +static s7_pointer opt_p_dd_cc(opt_info *o) {return(q_func(o).p_dd_f(o->sc, q_arg1(o).x, q_arg2(o).x));} + +static bool p_dd_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_dd_t ifunc = s7_p_dd_function(s_func); + if (!ifunc) return_false(sc, expr); + q_func(opc).p_dd_f = ifunc; + if (is_t_real(arg2)) + { + s7_pointer arg1_slot; + q_arg2(opc).x = real(arg2); + if (is_t_real(arg1)) + { + q_arg1(opc).x = real(arg1); + q_call(opc).fp = opt_p_dd_cc; + return_true(sc, expr); + } + arg1_slot = opt_real_symbol(sc, arg1); + if (arg1_slot) + { + q_arg1(opc).p = arg1_slot; + q_call(opc).fp = opt_p_dd_sc; + return_true(sc, expr); + }} + if (is_t_real(arg1)) + { + s7_pointer arg2_slot; + arg2_slot = opt_real_symbol(sc, arg2); + if (arg2_slot) + { + q_arg1(opc).x = real(arg1); + q_arg2(opc).p = arg2_slot; + q_call(opc).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(q_func(o).p_pi_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_sref(opt_info *o) {return(string_ref_p_pi_unchecked(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_sref_direct(opt_info *o) {return(string_ref_p_pi_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_vref(opt_info *o) {return(t_vector_ref_p_pi_unchecked(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_vref_direct(opt_info *o) {return(t_vector_ref_p_pi_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_fvref_direct(opt_info *o) {return(float_vector_ref_p_pi_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_cvref_direct(opt_info *o) {return(complex_vector_ref_p_pi_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_ivref_direct(opt_info *o) {return(int_vector_ref_p_pi_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).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(q_arg1(o).p), integer(slot_value(q_arg2(o).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(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_ss_pref(opt_info *o) {return(list_ref_p_pi_unchecked(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p))));} +static s7_pointer opt_p_pi_sc(opt_info *o) {return(q_func(o).p_pi_f(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i));} +static s7_pointer opt_p_pi_sc_pref(opt_info *o) {return(list_ref_p_pi_unchecked(o->sc, slot_value(q_arg1(o).p), q_arg2(o).i));} +static s7_pointer opt_p_pi_sf(opt_info *o) {return(q_func(o).p_pi_f(o->sc, slot_value(q_arg1(o).p), q_i_func1_call(o)));} +static s7_pointer opt_p_pi_sf_sref(opt_info *o) {return(string_ref_p_pi_unchecked(o->sc, slot_value(q_arg1(o).p), q_i_func1_call(o)));} +static s7_pointer opt_p_pi_sf_sref_direct(opt_info *o) {return(string_ref_p_pi_direct(o->sc, slot_value(q_arg1(o).p), q_i_func1_call(o)));} +static s7_pointer opt_p_pi_fc(opt_info *o) {return(q_func(o).p_pi_f(o->sc, q_p_func1_call(o), q_arg2(o).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 = type_unchecked(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 (q_func(o).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))) + q_func(opc).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))) + q_func(opc).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))) + q_func(opc).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))) + q_func(opc).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))) + q_func(opc).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))) + q_func(opc).p_pi_f = int_vector_ref_p_pi_direct; + break; + } +} + +static void fixup_p_pi_ss(opt_info *opc) +{ + q_call(opc).fp = (q_func(opc).p_pi_f == string_ref_p_pi_unchecked) ? opt_p_pi_ss_sref : + ((q_func(opc).p_pi_f == string_ref_p_pi_direct) ? opt_p_pi_ss_sref_direct : + ((q_func(opc).p_pi_f == t_vector_ref_p_pi_unchecked) ? opt_p_pi_ss_vref : + ((q_func(opc).p_pi_f == float_vector_ref_p_pi_direct) ? opt_p_pi_ss_fvref_direct : + ((q_func(opc).p_pi_f == complex_vector_ref_p_pi_direct) ? opt_p_pi_ss_cvref_direct : + ((q_func(opc).p_pi_f == int_vector_ref_p_pi_direct) ? opt_p_pi_ss_ivref_direct : + ((q_func(opc).p_pi_f == t_vector_ref_p_pi_direct) ? opt_p_pi_ss_vref_direct : + ((q_func(opc).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, arg1_slot, arg2_slot, 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 */ + arg1_slot = opt_simple_symbol(sc, cadr(expr)); + if (!arg1_slot) + return_false(sc, expr); + if ((is_any_vector(slot_value(arg1_slot))) && + (vector_rank(slot_value(arg1_slot)) > 1)) + return_false(sc, expr); + + q_func(opc).p_pi_f = func; + q_arg1(opc).p = arg1_slot; + + if (is_symbol(cadr(sig))) + checker = cadr(sig); + + obj = slot_value(q_arg1(opc).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))) + q_func(opc).p_pi_f = (is_t_vector(obj)) ? t_vector_ref_p_pi_unchecked : s7_p_pi_unchecked_function(s_func); + }} + arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + if ((obj) && /* this depends above on s7_p_pi_unchecked_function, but none of the typed vectors have one?? */ + (has_loop_end(arg2_slot))) + check_unchecked(sc, obj, arg2_slot, opc, expr); + fixup_p_pi_ss(opc); + return_true(sc, expr); + } + if (is_t_integer(caddr(expr))) + { + q_arg2(opc).i = integer(caddr(expr)); + q_call(opc).fp = (q_func(opc).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))) + { + q_call(opc).fp = (q_func(opc).p_pi_f == string_ref_p_pi_unchecked) ? opt_p_pi_sf_sref : + ((q_func(opc).p_pi_f == string_ref_p_pi_direct) ? opt_p_pi_sf_sref_direct : opt_p_pi_sf); + q_func1_arg(opc).o1 = o1; + q_func1(opc).fi = q_call(o1).fi; + return_true(sc, expr); + } + return_false(sc, expr); +} + +static s7_pointer opt_p_pi_fco(opt_info *o) {return(q_func(o).p_pi_f(o->sc, q_func1(o).p_p_f(o->sc, slot_value(q_arg1(o).p)), q_arg2(o).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 (q_call(o1).fp == opt_p_p_s) + { + q_func1(opc).p_p_f = q_func1(o1).p_p_f; + q_arg1(opc).p = q_arg1(o1).p; + q_call(opc).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(q_func(o).p_pp_f(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static s7_pointer opt_p_pp_sc(opt_info *o) {return(q_func(o).p_pp_f(o->sc, slot_value(q_arg1(o).p), q_arg2(o).p));} +static s7_pointer opt_p_pp_slot_ref(opt_info *o) {return(slot_value(q_arg1(o).p));} /* not in s7test timp (set! sum (+ sum (* i (L2 'a)))) */ +static s7_pointer opt_p_pp_cs(opt_info *o) {return(q_func(o).p_pp_f(o->sc, q_arg1(o).p, slot_value(q_arg2(o).p)));} +static s7_pointer opt_p_pp_sf(opt_info *o) {return(q_func(o).p_pp_f(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_fs(opt_info *o) {return(q_func(o).p_pp_f(o->sc, q_p_func1_call(o), slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_pp_fc(opt_info *o) {return(q_func(o).p_pp_f(o->sc, q_p_func1_call(o), q_arg2(o).p));} +static s7_pointer opt_p_pp_cc(opt_info *o) {return(q_func(o).p_pp_f(o->sc, q_arg1(o).p, q_arg2(o).p));} +static s7_pointer opt_p_pp_cc_make_list(opt_info *o) {return(make_list(o->sc, q_arg1(o).i, q_arg2(o).p));} +static s7_pointer opt_set_car_pp_ss(opt_info *o) {return(inline_set_car(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static s7_pointer opt_p_pp_ss_href(opt_info *o) {return(s7_hash_table_ref(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p)));} +static s7_pointer opt_p_pp_sf_add(opt_info *o) {return(add_p_pp(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_sf_sub(opt_info *o) {return(subtract_p_pp(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_sf_mul(opt_info *o) {return(multiply_p_pp(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_sf_set_car(opt_info *o) {return(inline_set_car(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_sf_set_cdr(opt_info *o) {return(inline_set_cdr(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_sf_href(opt_info *o) {return(s7_hash_table_ref(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_pp_fs_vref(opt_info *o) {return(s7i_vector_ref_p_pp(o->sc, q_p_func1_call(o), slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_pp_fs_cons(opt_info *o) {return(cons(o->sc, q_p_func1_call(o), slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_pp_fs_add(opt_info *o) {return(add_p_pp(o->sc, q_p_func1_call(o), slot_value(q_arg1(o).p)));} +static s7_pointer opt_p_pp_fs_sub(opt_info *o) {return(subtract_p_pp(o->sc, q_p_func1_call(o), slot_value(q_arg1(o).p)));} + +static s7_pointer opt_p_pp_ss_lref(opt_info *o) +{ + s7_pointer sym = slot_value(q_arg2(o).p); + if (is_symbol(sym)) + return(let_ref_p_pp(o->sc, slot_value(q_arg1(o).p), (is_keyword(sym)) ? keyword_symbol(sym) : sym)); + return(let_ref(o->sc, slot_value(q_arg1(o).p), sym)); +} + +static s7_pointer opt_p_pp_sf_lref(opt_info *o) +{ + s7_pointer sym = q_p_func1_call(o); + if (is_symbol(sym)) + return(let_ref_p_pp(o->sc, slot_value(q_arg1(o).p), (is_keyword(sym)) ? keyword_symbol(sym) : sym)); + return(let_ref(o->sc, slot_value(q_arg1(o).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, q_p_func2_call(o), q_p_func3_call(o)); /* we do need to protect both */ + result = q_func(o).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) /* (+|- (* x1 x2) (* x3 x4)) */ +{ + opt_info *o1 = q_func2_arg(o).o1, *o2 = q_func3_arg(o).o1; + s7_pointer x4; + s7_scheme *sc = o->sc; + const s7_pointer x1 = slot_value(q_arg1(o1).p); + s7_pointer x3 = slot_value(q_arg1(o2).p); + const s7_pointer x2 = q_func1(o1).fp(q_func1_arg(o1).o1); + if ((is_t_real(x2)) && (is_t_real(x1)) && (is_t_real(x3))) + { + s7_double r2 = real(x2); + x4 = q_func1(o2).fp(q_func1_arg(o2).o1); + if (is_t_real(x4)) + return(make_real(sc, (add_case) ? ((real(x1) * r2) + (real(x3) * real(x4))) : ((real(x1) * r2) - (real(x3) * real(x4))))); + gc_protect_via_stack_no_let(sc, x2); + } + else + { + gc_protect_via_stack_no_let(sc, x2); + x4 = q_func1(o2).fp(q_func1_arg(o2).o1); + } + set_gc_protected2(sc, x4); + set_gc_protected2(sc, multiply_p_pp_wrapped(sc, x3, x4)); + set_gc_protected1(sc, multiply_p_pp_wrapped(sc, x1, x2)); + x3 = (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(x3); +} + +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 (q_func3(opc).fp == opt_p_pi_ss_ivref_direct) q_func3(opc).fp = opt_p_pi_ss_ivref_direct_wrapped; + if (q_func3(opc).fp == opt_p_pi_ss_fvref_direct) q_func3(opc).fp = opt_p_pi_ss_fvref_direct_wrapped; + if (q_func2(opc).fp == opt_p_pi_ss_ivref_direct) q_func2(opc).fp = opt_p_pi_ss_ivref_direct_wrapped; + if (q_func2(opc).fp == opt_p_pi_ss_fvref_direct) q_func2(opc).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)) + { + q_arg1(opc).p = slot; + q_call(opc).fp = opt_p_pp_slot_ref; + } +} + +static s7_pointer opt_p_unlet_ref(opt_info *o) {return(q_arg1(o).p);} +static s7_pointer opt_p_rootlet_ref(opt_info *o) {return(global_value(q_arg1(o).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))) + { + q_call(opc).fp = opt_p_c; + q_arg1(opc).p = sc->undefined; + return_true(sc, expr); + }} + q_call(opc).fp = (car(arg1) == sc->rootlet_symbol) ? opt_p_rootlet_ref : opt_p_unlet_ref; + q_arg1(opc).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); + q_func(opc).p_pp_f = func; + if (is_symbol(arg1)) + { + s7_pointer obj; + const s7_pointer arg1_slot = opt_simple_symbol(sc, arg1); + if (!arg1_slot) + { + sc->pc = pstart; + return_false(sc, expr); + } + obj = slot_value(arg1_slot); + if ((is_any_vector(obj)) && (vector_rank(obj) > 1)) + { + sc->pc = pstart; + return_false(sc, expr); + } + q_arg1(opc).p = arg1_slot; + + if ((func == hash_table_ref_p_pp) && (is_hash_table(obj))) + q_func(opc).p_pp_f = s7_hash_table_ref; + + if (is_symbol(arg2)) + { + q_arg2(opc).p = opt_simple_symbol(sc, arg2); + if (q_arg2(opc).p) + { + q_call(opc).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 ((q_call(opc).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))) + { + q_arg2(opc).p = (!is_pair(arg2)) ? arg2 : cadr(arg2); + q_call(opc).fp = opt_p_pp_sc; + if ((is_pair(arg2)) && (is_symbol(q_arg2(opc).p)) && (is_let(obj)) && (q_func(opc).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))) + { + q_call(opc).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)) && (q_func(opc).p_pp_f == s7_hash_table_ref)) ? opt_p_pp_sf_href : + (((is_let(obj)) && (q_func(opc).p_pp_f == let_ref)) ? opt_p_pp_sf_lref : opt_p_pp_sf)))))); + q_func1_arg(opc).o1 = sc->opts[pstart]; + q_func1(opc).fp = q_call(sc->opts[pstart]).fp; + if (q_func1(opc).fp == opt_p_pi_ss_ivref_direct) q_func1(opc).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))) + { + q_arg1(opc).p = (!is_pair(arg1)) ? arg1 : cadr(arg1); + if ((!is_symbol(arg2)) && + ((!is_pair(arg2)) || + (is_proper_quote(sc, arg2)))) + { + q_arg2(opc).p = (!is_pair(arg2)) ? arg2 : cadr(arg2); + if ((q_func(opc).p_pp_f == make_list_p_pp) && + (is_t_integer(q_arg1(opc).p)) && (integer(q_arg1(opc).p) >= 0) && (integer(q_arg1(opc).p) < sc->max_list_length)) + { + q_call(opc).fp = opt_p_pp_cc_make_list; + q_arg1(opc).i = integer(q_arg1(opc).p); + } + else q_call(opc).fp = opt_p_pp_cc; + return_true(sc, expr); + } + if (is_symbol(arg2)) + { + q_arg2(opc).p = opt_simple_symbol(sc, arg2); + if (q_arg2(opc).p) + { + q_call(opc).fp = opt_p_pp_cs; + if (is_pair(slot_value(q_arg2(opc).p))) + { + if (func == assq_p_pp) q_func(opc).p_pp_f = s7_assq; + else + if (func == memq_p_pp) q_func(opc).p_pp_f = s7_memq; + else + if ((func == member_p_pp) && (is_simple(q_arg1(opc).p))) q_func(opc).p_pp_f = s7_memq; + else + if (func == assoc_p_pp) + { + if (is_simple(q_arg1(opc).p)) q_func(opc).p_pp_f = s7_assq; + else if (is_pair(car(slot_value(q_arg2(opc).p)))) q_func(opc).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(sc, 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)) + { + q_arg1(opc).p = opt_simple_symbol(sc, arg2); + if (q_arg1(opc).p) + { + q_call(opc).fp = (func == add_p_pp) ? opt_p_pp_fs_add : ((func == subtract_p_pp) ? opt_p_pp_fs_sub : + ((func == s7i_vector_ref_p_pp) ? opt_p_pp_fs_vref : ((func == cons_p_pp) ? opt_p_pp_fs_cons : opt_p_pp_fs))); + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + if (q_func1(opc).fp == opt_p_p_s_random) q_func1(opc).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) + { + q_arg2(opc).i = integer(arg2); + q_func(opc).p_pi_f = ifunc; + if (!p_pi_fc_combinable(sc, opc)) + { + q_call(opc).fp = opt_p_pi_fc; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + } + return_true(sc, expr); + }} + q_arg2(opc).p = (!is_pair(arg2)) ? arg2 : cadr(arg2); + q_call(opc).fp = opt_p_pp_fc; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + return_true(sc, expr); + } + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_func2_arg(opc).o1 = o1; + q_func2(opc).fp = q_call(o1).fp; + q_func3(opc).fp = q_func3_arg(opc).q_call(o1).fp; + q_call(opc).fp = opt_p_pp_ff; + if ((q_func3(opc).fp == opt_p_pp_sf_mul) && (q_func2(opc).fp == opt_p_pp_sf_mul)) + { + if (func == add_p_pp) q_call(opc).fp = opt_p_pp_ff_add_mul_mul; + else if (func == subtract_p_pp) q_call(opc).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, q_p_func1_call(o)); + po2 = q_p_func2_call(o); + po2 = q_func(o).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 = q_p_func1_call(o); + return(q_func(o).call(o->sc, set_plist_2(o->sc, po1, slot_value(q_arg1(o).p)))); +} + +static s7_pointer opt_p_call_sf(opt_info *o) +{ + s7_pointer po1 = q_p_func1_call(o); + return(q_func(o).call(o->sc, set_plist_2(o->sc, slot_value(q_arg1(o).p), po1))); +} + +static s7_pointer opt_p_call_fc(opt_info *o) +{ + s7_pointer po1 = q_p_func1_call(o); + return(q_func(o).call(o->sc, set_plist_2(o->sc, po1, q_arg2(o).p))); +} + +static s7_pointer opt_p_call_cc(opt_info *o) {return(q_func(o).call(o->sc, set_plist_2(o->sc, q_arg1(o).p, q_arg2(o).p)));} +static s7_pointer opt_p_call_sc(opt_info *o) {return(q_func(o).call(o->sc, set_plist_2(o->sc, slot_value(q_arg1(o).p), q_arg2(o).p)));} +static s7_pointer opt_p_call_ss(opt_info *o) {return(q_func(o).call(o->sc, set_plist_2(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p))));} + +static void check_opc_vector_wraps_1(opt_info *opc) +{ + if (q_func1(opc).fp == opt_p_pi_ss_ivref_direct) q_func1(opc).fp = opt_p_pi_ss_ivref_direct_wrapped; + if (q_func1(opc).fp == opt_p_pi_ss_fvref_direct) q_func1(opc).fp = opt_p_pi_ss_fvref_direct_wrapped; + if (q_func2(opc).fp == opt_p_pi_ss_ivref_direct) q_func2(opc).fp = opt_p_pi_ss_ivref_direct_wrapped; + if (q_func2(opc).fp == opt_p_pi_ss_fvref_direct) q_func2(opc).fp = opt_p_pi_ss_fvref_direct_wrapped; +} + +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); + q_func(opc).call = cf_call(sc, expr, s_func, 2); + if ((is_code_constant(sc, arg1)) && (is_code_constant(sc, arg2))) + { + q_call(opc).fp = opt_p_call_cc; + q_arg1(opc).p = (is_pair(arg1)) ? cadr(arg1) : arg1; + q_arg2(opc).p = (is_pair(arg2)) ? cadr(arg2) : arg2; + return_true(sc, expr); + } + if (is_symbol(arg1)) + { + q_arg1(opc).p = s7_slot(sc, arg1); /* can be # */ + if ((is_slot(q_arg1(opc).p)) && + (!has_methods(slot_value(q_arg1(opc).p)))) + { + if (is_symbol(arg2)) + { + q_arg2(opc).p = opt_simple_symbol(sc, arg2); + if (q_arg2(opc).p) + { + q_call(opc).fp = opt_p_call_ss; + return_true(sc, expr); + } + sc->pc = pstart; + return_false(sc, expr); + } + if (!is_pair(arg2)) + { + q_arg2(opc).p = arg2; + q_call(opc).fp = opt_p_call_sc; + return_true(sc, expr); + } + if (cell_optimize(sc, cddr(expr))) + { + q_func1_arg(opc).o1 = sc->opts[pstart]; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + q_call(opc).fp = opt_p_call_sf; + return_true(sc, expr); + }} + else + { + sc->pc = pstart; + return_false(sc, expr); + }} + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdr(expr))) + { + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + if (is_symbol(arg2)) + { + q_arg1(opc).p = opt_simple_symbol(sc, arg2); + if (q_arg1(opc).p) + { + q_call(opc).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-ciopts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + q_call(opc).fp = opt_p_call_ff; + check_opc_vector_wraps_1(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(q_func(o).p_pip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_p_func1_call(o))); +} + +static s7_pointer opt_p_pip_ssf_sset(opt_info *o) +{ + return(string_set_p_pip_direct(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_p_func1_call(o))); +} + +static s7_pointer opt_p_pip_ssf_vset(opt_info *o) +{ + return(vector_set_p_pip_unchecked(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_p_func1_call(o))); +} + +static s7_pointer opt_p_pip_sss(opt_info *o) +{ + return(q_func(o).p_pip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), slot_value(q_arg3(o).p))); +} + +static s7_pointer opt_p_pip_sss_vset(opt_info *o) +{ + return(vector_set_p_pip_unchecked(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), slot_value(q_arg3(o).p))); +} + +static s7_pointer opt_p_pip_ssc(opt_info *o) +{ + return(q_func(o).p_pip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_arg3(o).p)); +} + +static s7_pointer opt_p_pip_sff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + return(q_func(o).p_pip_f(o->sc, slot_value(q_arg1(o).p), i1, q_p_func3_call(o))); +} + +static s7_pointer opt_p_pip_sff_lset(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + return(list_set_p_pip_unchecked(o->sc, slot_value(q_arg1(o).p), i1, q_p_func3_call(o))); +} + +static s7_pointer opt_p_pip_sso(opt_info *o) +{ + return(q_func(o).p_pip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), + q_func3(o).p_pi_f(o->sc, slot_value(q_arg3(o).p), integer(slot_value(q_arg4(o).p))))); +} + +static s7_pointer opt_p_pip_ssf1(opt_info *o) +{ + return(q_func(o).p_pip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), q_func1(o).p_p_f(o->sc, q_p_func2_call(o)))); +} + +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 ((q_call(o1).fp == opt_p_pi_ss) || (q_call(o1).fp == opt_p_pi_ss_sref) || (q_call(o1).fp == opt_p_pi_ss_vref) || + (q_call(o1).fp == opt_p_pi_ss_sref_direct) || (q_call(o1).fp == opt_p_pi_ss_vref_direct) || (q_call(o1).fp == opt_p_pi_ss_fvref_direct) || + (q_call(o1).fp == opt_p_pi_ss_ivref_direct) || (q_call(o1).fp == opt_p_pi_ss_pref)) + { + q_func(opc).p_pip_f = q_func(opc).p_pip_f; + q_func3(opc).p_pi_f = q_func(o1).p_pi_f; + q_arg3(opc).p = q_arg1(o1).p; + q_arg4(opc).p = q_arg2(o1).p; + q_call(opc).fp = opt_p_pip_sso; + backup_pc(sc); + return_true(sc, NULL); + }} + o1 = sc->opts[start]; + if (q_call(o1).fp != opt_p_p_f) + return_false(sc, NULL); + q_func1(opc).p_p_f = q_func1(o1).p_p_f; + q_func2_arg(opc).o1 = sc->opts[start + 1]; + q_func2(opc).fp = q_call(sc->opts[start + 1]).fp; + q_call(opc).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, arg1_slot, 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 */ + arg1_slot = s7_slot(sc, cadr(expr)); + if (!is_slot(arg1_slot)) return_false(sc, expr); + obj1 = slot_value(arg1_slot); + 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)); + q_arg1(opc).p = arg1_slot; + obj = slot_value(q_arg1(opc).p); + q_func(opc).p_pip_f = func; + if ((s7_p_pip_unchecked_function(s_func)) && + (checker)) + { + if ((is_t_vector(obj)) && (checker == sc->is_vector_symbol)) + q_func(opc).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? */ + q_func(opc).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)))) + q_func(opc).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 arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + if (has_loop_end(arg2_slot)) + switch (type(obj)) + { + case T_VECTOR: + if (loop_end(arg2_slot) <= vector_length(obj)) + q_func(opc).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(arg2_slot) <= vector_length(obj)) + q_func(opc).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(arg2_slot) <= vector_length(obj)) + q_func(opc).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(arg2_slot) <= vector_length(obj)) + q_func(opc).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(arg2_slot) <= vector_length(obj)) + q_func(opc).p_pip_f = complex_vector_set_p_pip_direct; + break; + case T_STRING: + if (loop_end(arg2_slot) <= string_length(obj)) + q_func(opc).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); + /* 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) + { + q_arg3(opc).p = val_slot; + q_call(opc).fp = (q_func(opc).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))) + { + q_arg3(opc).p = (is_pair(arg3)) ? cadr(arg3) : arg3; + q_call(opc).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); + q_call(opc).fp = (q_func(opc).p_pip_f == string_set_p_pip_direct) ? opt_p_pip_ssf_sset : + ((q_func(opc).p_pip_f == vector_set_p_pip_unchecked) ? opt_p_pip_ssf_vset : opt_p_pip_ssf); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fp = q_call(sc->opts[start]).fp; + return_true(sc, expr); + }}} + else /* not symbol caddr */ + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(expr))) + { + q_call(opc).fp = (q_func(opc).p_pip_f == list_set_p_pip_unchecked) ? opt_p_pip_sff_lset : opt_p_pip_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fp = q_func3_arg(opc).q_call(o1).fp; + return_true(sc, expr); + }}} + return_false(sc, expr); +} + +/* -------- p_piip -------- */ + +static s7_pointer opt_p_piip_sssf(opt_info *o) +{ + return(q_func(o).p_piip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)), q_p_func2_call(o))); +} + +static s7_pointer vector_set_piip_sssf_unchecked(opt_info *o) +{ + s7_pointer vec = slot_value(q_arg1(o).p); + s7_pointer val = q_p_func2_call(o); + vector_element(vec, ((integer(slot_value(q_arg2(o).p)) * vector_offset(vec, 0)) + integer(slot_value(q_arg3(o).p)))) = val; + return(val); +} + +static s7_pointer opt_p_piip_sssc(opt_info *o) +{ + return(q_func(o).p_piip_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)), q_arg4(o).p)); +} + +static s7_pointer opt_p_piip_sfff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + s7_int i2 = q_i_func3_call(o); + return(q_func(o).p_piip_f(o->sc, slot_value(q_arg1(o).p), i1, i2, q_p_func1_call(o))); +} + +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 ind1_slot; + s7_pointer ind2_slot = opt_integer_symbol(sc, car(indexp2)); + if (!ind2_slot) return_false(sc, indexp1); /* normally expr, indexp1 has more context than indexp2 */ + q_arg3(opc).p = ind2_slot; + ind1_slot = opt_integer_symbol(sc, car(indexp1)); + if (ind1_slot) + { + q_arg2(opc).p = ind1_slot; + if ((is_symbol(car(valp))) || + (is_unquoted_pair(sc, car(valp)))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, valp)) + return_false(sc, indexp1); + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + q_call(opc).fp = opt_p_piip_sssf; + if ((is_t_vector(obj)) && + (loop_end_fits(q_arg2(opc).p, vector_dimension(obj, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(obj, 1)))) + q_call(opc).fp = vector_set_piip_sssf_unchecked; + return_true(sc, NULL); + } + q_call(opc).fp = opt_p_piip_sssc; + q_arg4(opc).p = (is_pair(car(valp))) ? cadar(valp) : car(valp); + return_true(sc, NULL); + } + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) + { + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, valp)) + { + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + q_call(opc).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 arg1_slot = s7_slot(sc, cadr(expr)); + if (!is_slot(arg1_slot)) + return_false(sc, expr); + obj = slot_value(arg1_slot); + 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)) + { + q_arg1(opc).p = arg1_slot; + q_func(opc).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(q_func(o).p_pii_f(o->sc, slot_value(q_arg1(o).p), integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)))); +} + +static s7_pointer opt_p_pii_sff(opt_info *o) +{ + s7_int i1 = q_i_func2_call(o); + s7_int i2 = q_i_func3_call(o); + return(q_func(o).p_pii_f(o->sc, slot_value(q_arg1(o).p), i1, i2)); +} + +static s7_pointer vector_ref_pii_sss_unchecked(opt_info *o) +{ + s7_pointer vec = slot_value(q_arg1(o).p); + return(vector_element(vec, ((integer(slot_value(q_arg2(o).p)) * vector_offset(vec, 0)) + integer(slot_value(q_arg3(o).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 arg1_slot = s7_slot(sc, cadr(expr)); + if (!is_slot(arg1_slot)) return_false(sc, expr); + obj = slot_value(arg1_slot); + if ((has_methods(obj)) || (is_immutable(obj))) return_false(sc, expr); + if ((is_t_vector(obj)) && + (vector_rank(obj) == 2)) + { + s7_pointer ind2_slot, indexp1 = cddr(expr), indexp2 = cdddr(expr); + q_arg1(opc).p = arg1_slot; + q_func(opc).p_pii_f = vector_ref_p_pii; + ind2_slot = opt_integer_symbol(sc, car(indexp2)); + if (ind2_slot) + { + s7_pointer ind1_slot; + q_arg3(opc).p = ind2_slot; + ind1_slot = opt_integer_symbol(sc, car(indexp1)); + if (ind1_slot) + { + q_arg2(opc).p = ind1_slot; + q_call(opc).fp = opt_p_pii_sss; + /* normal vector rank 2 (see above) */ + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(slot_value(q_arg1(opc).p), 1)))) + q_call(opc).fp = vector_ref_pii_sss_unchecked; + return_true(sc, expr); + }} + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp1)) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, indexp2)) + { + q_call(opc).fp = opt_p_pii_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + return_true(sc, expr); + }}}} + return_false(sc, expr); +} + +/* -------- p_ppi -------- */ +static s7_pointer opt_p_ppi_psf(opt_info *o) {return(q_func(o).p_ppi_f(o->sc, q_arg1(o).p, slot_value(q_arg2(o).p), q_i_func1_call(o)));} +static s7_pointer opt_p_ppi_psf_cpos(opt_info *o) {return(char_position_p_ppi(o->sc, q_arg1(o).p, slot_value(q_arg2(o).p), q_i_func1_call(o)));} + +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); + q_func(opc).p_ppi_f = ifunc; + if ((is_character(cadr(expr))) && + (is_symbol(caddr(expr))) && + (int_optimize(sc, cdddr(expr)))) + { + const s7_pointer arg2_slot = opt_simple_symbol(sc, caddr(expr)); + if (arg2_slot) + { + q_arg1(opc).p = cadr(expr); + q_arg2(opc).p = arg2_slot; + q_call(opc).fp = (ifunc == char_position_p_ppi) ? opt_p_ppi_psf_cpos : opt_p_ppi_psf; + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fi = q_call(sc->opts[start]).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(q_func(o).p_ppp_f(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), q_p_func1_call(o)));} +static s7_pointer opt_p_ppp_hash_table_increment(opt_info *o) {return(fx_hash_table_increment_1(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), q_arg3(o).p));} +static s7_pointer opt_p_ppp_sfs(opt_info *o) {return(q_func(o).p_ppp_f(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o), slot_value(q_arg2(o).p)));} +static s7_pointer opt_p_ppp_scs(opt_info *o) {return(q_func(o).p_ppp_f(o->sc, slot_value(q_arg1(o).p), q_arg2(o).p, slot_value(q_arg3(o).p)));} +static s7_pointer opt_p_ppp_sss(opt_info *o) {return(q_func(o).p_ppp_f(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), slot_value(q_arg3(o).p)));} +static s7_pointer opt_p_ppp_sss_mul(opt_info *o) {return(multiply_p_ppp(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), slot_value(q_arg3(o).p)));} +static s7_pointer opt_p_ppp_sss_hset(opt_info *o) {return(s7_hash_table_set(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), slot_value(q_arg3(o).p)));} +static s7_pointer opt_p_ppp_ssc(opt_info *o) {return(q_func(o).p_ppp_f(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), q_arg3(o).p));} +static s7_pointer opt_list_3c(opt_info *o) {s7_scheme *sc = o->sc; return(list_3(sc, q_arg1(o).p, q_arg2(o).p, q_arg3(o).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(q_p_func2_call(o)), T_Ext(q_p_func3_call(o))); + result = q_func(o).p_ppp_f(o->sc, slot_value(q_arg1(o).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(q_p_func2_call(o)), T_Ext(q_p_func3_call(o))); + result = q_func(o).p_ppp_f(sc, gc_protected1(sc), gc_protected2(sc), q_p_func1_call(o)); + unstack_gc_protect(sc); + return(result); +} + +static s7_pointer opt_p_ppc_slot_set(opt_info *o) {slot_set_value(q_arg2(o).p, q_arg3(o).p); return(q_arg3(o).p);} +static s7_pointer opt_p_pps_slot_set(opt_info *o) {slot_set_value(q_arg2(o).p, slot_value(q_arg3(o).p)); return(slot_value(q_arg3(o).p));} +static s7_pointer opt_p_ppf_slot_set(opt_info *o) {slot_set_value(q_arg2(o).p, q_p_func1_call(o)); return(slot_value(q_arg2(o).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))) + { + q_arg2(opc).p = slot; + q_arg3(opc).p = value; + q_call(opc).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))) + { + q_arg2(opc).p = slot; + q_arg3(opc).p = val_slot; + q_call(opc).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))) + { + q_arg2(opc).p = slot; + q_call(opc).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); + q_func(opc).p_ppp_f = func; + if (is_symbol(arg1)) + { + s7_pointer obj; + opt_info *o1; + s7_pointer arg1_slot = s7_slot(sc, arg1); + if ((!is_slot(arg1_slot)) || + (has_methods(slot_value(arg1_slot)))) + return_false(sc, expr); + + obj = slot_value(arg1_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); + + q_arg1(opc).p = arg1_slot; + + if ((func == hash_table_set_p_ppp) && (is_hash_table(obj))) + q_func(opc).p_ppp_f = s7_hash_table_set; + + if (is_symbol(arg2)) + { + s7_pointer arg2_slot; + if ((is_keyword(arg2)) && (is_symbol(arg3)) && (is_let(obj)) && (q_func(opc).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); + } + arg2_slot = opt_simple_symbol(sc, arg2); + if (arg2_slot) + { + const s7_pointer arg2_val = slot_value(arg2_slot); + q_arg2(opc).p = arg2_slot; + if (is_symbol(arg3)) + { + s7_pointer arg3_slot; + arg3_slot = opt_simple_symbol(sc, arg3); + if (arg3_slot) + { + s7_p_ppp_t func1 = q_func(opc).p_ppp_f; + q_arg3(opc).p = arg3_slot; /* some other caller depends on this? op_simple_do_1[86577]: not a slot */ + q_call(opc).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))) + { + q_arg3(opc).p = (is_pair(arg3)) ? cadr(arg3) : arg3; + q_call(opc).fp = opt_p_ppp_ssc; + if ((is_let(obj)) && (q_func(opc).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, q_arg3(opc).p); + return_true(sc, expr); + } + if (optimize_op(expr) == HOP_HASH_TABLE_INCREMENT) + { + q_call(opc).fp = opt_p_ppp_hash_table_increment; + q_arg3(opc).p = expr; + return_true(sc, expr); + } + if (cell_optimize(sc, cdddr(expr))) + { + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + q_call(opc).fp = opt_p_ppp_ssf; + if ((is_let(obj)) && (is_symbol_and_keyword(arg2_val)) && (q_func(opc).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 (q_func1_arg(opc).q_func(o1).p_pp_f == complex_p_pp) /* same as below but (complex d d)?? d float */ + q_func1_arg(opc).q_func(o1).p_pp_f = complex_p_pp_wrapped; + else + if (q_func1_arg(opc).q_func(o1).p_dd_f == complex_p_dd) /* same below but (complex d 1.0), d float stepper */ + q_func1_arg(opc).q_func(o1).p_dd_f = complex_p_dd_wrapped; + else + if (q_func1_arg(opc).q_func(o1).p_ii_f == complex_p_ii) /* (complex-vector-set! cv1 i (complex i i)) */ + q_func1_arg(opc).q_func(o1).p_ii_f = complex_p_ii_wrapped; + } + 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) + { + q_arg2(opc).p = cadr(arg2); + q_arg3(opc).p = val_slot; + q_call(opc).fp = opt_p_ppp_scs; + if ((is_let(obj)) && (q_func(opc).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) + { + q_arg2(opc).p = val_slot; + q_call(opc).fp = opt_p_ppp_sfs; /* hset case goes through the case below */ + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + return_true(sc, expr); + }} + if ((!is_pair(arg3)) && (is_let(obj)) && (is_quoted_symbol(sc, arg2)) && + (q_func(opc).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(sc, arg2)) && (q_func(opc).p_ppp_f == let_set_2) && /* (let-set! L3 'x (+ (L3 'x) 1)) */ + (use_ppf_slot_set(sc, opc, obj, cadr(arg2)))) + { + q_func1_arg(opc).o1 = o2; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + return_true(sc, expr); + } + q_call(opc).fp = opt_p_ppp_sff; + q_func2_arg(opc).o1 = o1; + q_func2(opc).fp = q_call(o1).fp; + q_func3_arg(opc).o1 = o2; + q_func3(opc).fp = q_call(o2).fp; + return_true(sc, expr); + }}} + else /* arg1 not symbol */ + { + q_func2_arg(opc).o1 = sc->opts[start]; + if (cell_optimize(sc, cdr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_func1_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cdddr(expr))) + { + q_call(opc).fp = opt_p_ppp_fff; + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + q_func3(opc).fp = q_func3_arg(opc).q_call(o1).fp; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + if ((q_func(opc).p_ppp_f == list_p_ppp) && + (q_func1(opc).fp == opt_p_c) && (q_func3(opc).fp == opt_p_c) && (q_func2(opc).fp == opt_p_c)) + { + q_call(opc).fp = opt_list_3c; + q_arg1(opc).p = q_func2_arg(opc).q_arg1(o1).p; + q_arg2(opc).p = q_func3_arg(opc).q_arg1(o1).p; + q_arg3(opc).p = q_func1_arg(opc).q_arg1(o1).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(q_func(o).call(o->sc, set_plist_3(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), slot_value(q_arg3(o).p)))); +} + +static s7_pointer opt_p_call_ccs(opt_info *o) +{ + return(q_func(o).call(o->sc, set_plist_3(o->sc, q_arg1(o).p, q_arg2(o).p, slot_value(q_arg3(o).p)))); +} + +static s7_pointer opt_p_call_scs(opt_info *o) +{ + return(q_func(o).call(o->sc, set_plist_3(o->sc, slot_value(q_arg1(o).p), q_arg2(o).p, slot_value(q_arg3(o).p)))); +} + +static s7_pointer opt_p_call_css(opt_info *o) +{ + return(q_func(o).call(o->sc, set_plist_3(o->sc, q_arg1(o).p, slot_value(q_arg2(o).p), slot_value(q_arg3(o).p)))); +} + +static s7_pointer opt_p_call_ssf(opt_info *o) +{ + return(q_func(o).call(o->sc, set_plist_3(o->sc, slot_value(q_arg1(o).p), slot_value(q_arg2(o).p), q_p_func1_call(o)))); +} + +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, q_p_func1_call(o), q_p_func3_call(o)); + result = q_p_func2_call(o); /* not combinable into next */ + result = q_func(o).call(sc, set_plist_3(sc, gc_protected1(sc), gc_protected2(sc), result)); + if (stack_top_op(sc) == OP_GC_PROTECT) 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))) + { + 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)) + { + const s7_pointer arg1_slot = opt_simple_symbol(sc, arg1); + if (arg1_slot) + { + q_arg1(opc).p = arg1_slot; + if ((s_func == global_value(sc->vector_ref_symbol)) && + (is_t_vector(slot_value(arg1_slot))) && (vector_rank(slot_value(arg1_slot)) != 2)) + return_false(sc, expr); + /* arg1 ok as symbol */ + if ((is_code_constant(sc, arg2)) && (is_normal_symbol(arg3))) + { + const s7_pointer val_slot = opt_simple_symbol(sc, arg3); + if (val_slot) + { + q_arg2(opc).p = arg2; + q_arg3(opc).p = val_slot; + q_func(opc).call = cf_call(sc, expr, s_func, 3); + if ((sc->do_body_p == expr) && (arg1 == sc->F) && (car(expr) == sc->format_symbol)) + q_func(opc).call = g_format_nr; + q_call(opc).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) + { + q_arg1(opc).p = arg1; + q_arg2(opc).p = (is_pair(arg2)) ? cadr(arg2) : arg2; + q_arg3(opc).p = val_slot; + q_func(opc).call = cf_call(sc, expr, s_func, 3); + if ((sc->do_body_p == expr) && (arg1 == sc->F) && (car(expr) == sc->format_symbol)) + q_func(opc).call = g_format_nr; + q_call(opc).fp = opt_p_call_ccs; + return_true(sc, expr); + }} + q_arg1(opc).p = arg1; + if (s_func == global_value(sc->vector_ref_symbol)) + return_false(sc, expr); + } + if (is_normal_symbol(arg2)) + { + const s7_pointer arg2_slot = opt_simple_symbol(sc, arg2); + if (arg2_slot) + { + q_arg2(opc).p = arg2_slot; + if (is_normal_symbol(arg3)) + { + const s7_pointer arg3_slot = opt_simple_symbol(sc, arg3); + if (arg3_slot) + { + q_arg3(opc).p = arg3_slot; + q_func(opc).call = cf_call(sc, expr, s_func, 3); + q_call(opc).fp = (is_slot(q_arg1(opc).p)) ? opt_p_call_sss : opt_p_call_css; + return_true(sc, expr); + }} + else + if (is_slot(q_arg1(opc).p)) + { + const int32_t start1 = sc->pc; + if ((cf_call(sc, expr, s_func, 3) == g_substring_uncopied) && + (is_t_integer(slot_value(q_arg2(opc).p))) && + (is_string(slot_value(q_arg1(opc).p))) && + (int_optimize(sc, cdddr(expr)))) + { + q_call(opc).fp = opt_p_substring_uncopied_ssf; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fi = q_call(o1).fi; + return_true(sc, expr); + } + sc->pc = start1; + if (cell_optimize(sc, cdddr(expr))) + { + q_func(opc).call = cf_call(sc, expr, s_func, 3); + q_call(opc).fp = opt_p_call_ssf; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).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))) + { + q_func(opc).call = cf_call(sc, expr, s_func, 3); + q_call(opc).fp = opt_p_call_ppp; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + q_func3_arg(opc).o1 = o2; + q_func3(opc).fp = q_call(o2).fp; + q_func2_arg(opc).o1 = o3; + q_func2(opc).fp = q_call(o3).fp; + return_true(sc, expr); + }}}} + sc->pc = start; + return_false(sc, expr); +} + +/* -------- p_call_any -------- */ +#define p_call_o1 3 +#define q_p_call_f(o) o->v[2] +#define q_p_call_arg(o, i) o->v[i] + +static s7_pointer opt_p_call_any(opt_info *o) +{ + s7_scheme *sc = o->sc; + s7_pointer val = safe_list_if_possible(sc, q_arg1(o).i); + s7_pointer arg = val; + if (in_heap(val)) gc_protect_via_stack_no_let(sc, val); + for (s7_int i = 0; i < q_arg1(o).i; i++, arg = cdr(arg)) + { + opt_info *o1 = q_p_call_arg(o, i + p_call_o1).o1; + set_car(arg, q_call(o1).fp(o1)); + } + arg = q_p_call_f(o).call(sc, val); + if (in_heap(val)) unstack_gc_protect(sc); + else clear_safe_list_in_use(sc, val); + return(arg); +} + +static s7_pointer opt_p_call_4g(opt_info *o) +{ + s7_scheme *sc = o->sc; + opt_info *o1 = q_p_call_arg(o, 0 + p_call_o1).o1; + opt_info *o2 = q_p_call_arg(o, 1 + p_call_o1).o1; + opt_info *o3 = q_p_call_arg(o, 2 + p_call_o1).o1; + opt_info *o4 = q_p_call_arg(o, 3 + p_call_o1).o1; + return(q_p_call_f(o).call(o->sc, set_plist_4(sc, q_call(o1).fp(o1), q_call(o2).fp(o2), q_call(o3).fp(o3), q_call(o4).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 */ + q_arg1(opc).i = (len - 1); /* also ccff in cb.scm I think */ + for (int32_t pctr = p_call_o1; is_pair(p); pctr++, p = cdr(p)) + { + q_p_call_arg(opc, pctr).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) break; + if (is_pair(car(p))) safe = false; + } + if (is_null(p)) + { + q_call(opc).fp = ((len == 5) && (safe)) ? opt_p_call_4g : opt_p_call_any; + q_p_call_f(opc).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(q_func(o).call(o->sc, q_arg1(o).p));} +static void fx_annotate_arg(s7_scheme *sc, s7_pointer arg, s7_pointer let_or_list); + +static bool p_fx_any_ok(s7_scheme *sc, opt_info *opc, s7_pointer expr) +{ + s7_function func = ((is_pair(car(expr))) && (has_fx(car(expr)))) ? fx_proc(car(expr)) : NULL; +#if 0 + /* this is slower! -- fx choices are pessimal here */ + if ((!func) && (is_fxable(sc, car(expr)))) {fx_annotate_arg(sc, expr, sc->curlet); if (has_fx(expr)) func = fx_proc(expr);} +#endif + if (!func) return_false(sc, expr); + q_call(opc).fp = opt_p_fx_any; + q_func(opc).call = func; + q_arg1(opc).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); + q_arg1(opc).p = s_slot; + start = sc->pc; + if (len == 2) + { + switch (type(obj)) + { + case T_PAIR: q_func(opc).p_pi_f = list_ref_p_pi_unchecked; break; + case T_HASH_TABLE: q_func(opc).p_pp_f = s7_hash_table_ref; break; + case T_LET: q_func(opc).p_pp_f = let_ref; break; + case T_STRING: q_func(opc).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); + q_func(opc).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); + q_func(opc).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 arg1_slot = s7_slot(sc, arg1); /* not the desired slot if let+keyword, see below */ + if (is_slot(arg1_slot)) + { + q_arg2(opc).p = arg1_slot; + if ((!is_hash_table(obj)) && /* these because opt_int below */ + (!is_let(obj))) + { + if (!is_t_integer(slot_value(arg1_slot))) + return_false(sc, expr); /* I think this reflects that a non-int index is an error for list-ref et al */ + q_call(opc).fp = opt_p_pi_ss; /* TODO: this now uses 1/2 not 2/1 */ + if (has_loop_end(q_arg2(opc).p)) + check_unchecked(sc, obj, q_arg2(opc).p, opc, NULL); + fixup_p_pi_ss(opc); + return_true(sc, expr); + } + q_call(opc).fp = ((is_hash_table(obj)) && (q_func(opc).p_pp_f == s7_hash_table_ref)) ? opt_p_pp_ss_href : + (((is_let(obj)) && (q_func(opc).p_pp_f == let_ref)) ? opt_p_pp_ss_lref : opt_p_pp_ss); + if ((q_call(opc).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)) + { + q_arg2(opc).i = integer(arg1); + q_call(opc).fp = opt_p_pi_sc; + return_true(sc, expr); + } + o1 = sc->opts[sc->pc]; + if (!int_optimize(sc, cdr(expr))) + return_false(sc, expr); + q_call(opc).fp = opt_p_pi_sf; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fi = q_call(o1).fi; + return_true(sc, expr); + } + if ((!is_pair(arg1)) || + (is_proper_quote(sc, arg1))) + { + q_arg2(opc).p = (!is_pair(arg1)) ? arg1 : cadr(arg1); + q_call(opc).fp = opt_p_pp_sc; + if ((is_pair(arg1)) && (is_symbol(q_arg2(opc).p)) && (is_let(obj)) && (q_func(opc).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) */ + q_call(opc).fp = ((is_hash_table(obj)) && (q_func(opc).p_pp_f == s7_hash_table_ref)) ? opt_p_pp_sf_href : + (((is_let(obj)) && (q_func(opc).p_pp_f == let_ref)) ? opt_p_pp_sf_lref : opt_p_pp_sf); + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fp = q_call(sc->opts[start]).fp; + return_true(sc, expr); + }}} /* len==2 */ + else + { /* len > 2 */ + if ((is_t_vector(obj)) && (len == 3) && (vector_rank(obj) == 2)) + { + const s7_pointer arg2_slot = opt_integer_symbol(sc, caddr(expr)); + if (arg2_slot) + { + s7_pointer arg1_slot; + q_arg3(opc).p = arg2_slot; + arg1_slot = opt_integer_symbol(sc, arg1); + if (arg1_slot) + { + q_arg2(opc).p = arg1_slot; + q_func(opc).p_pii_f = vector_ref_p_pii; + q_call(opc).fp = opt_p_pii_sss; + if ((loop_end_fits(q_arg2(opc).p, vector_dimension(obj, 0))) && + (loop_end_fits(q_arg3(opc).p, vector_dimension(obj, 1)))) + q_call(opc).fp = vector_ref_pii_sss_unchecked; + return_true(sc, expr); + }} + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(expr))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cddr(expr))) + { + q_call(opc).fp = opt_p_pii_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fi = q_func3_arg(opc).q_call(o1).fi; + q_func(opc).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; + q_arg1(opc).i = len; + for (int32_t pctr = (P_IMPLICIT_CALL_O1 - 1); is_pair(p); pctr++, p = cdr(p)) + { + q_p_call_arg(opc, 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 */ + q_call(opc).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: q_p_call_f(opc).call = g_int_vector_ref; break; + case T_BYTE_VECTOR: q_p_call_f(opc).call = g_byte_vector_ref; break; + case T_FLOAT_VECTOR: q_p_call_f(opc).call = g_float_vector_ref; break; + case T_COMPLEX_VECTOR: q_p_call_f(opc).call = g_complex_vector_ref; break; + case T_VECTOR: q_p_call_f(opc).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); + q_arg1(opc).p = cadr(expr); + q_call(opc).fp = opt_p_c; + return_true(sc, expr); +} + +/* -------- cell_set -------- */ +static s7_pointer opt_set_p_p_f(opt_info *o) +{ + s7_pointer val = q_p_func1_call(o); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_p_f_with_setter(opt_info *o) +{ + s7_pointer val = q_p_func1_call(o); + call_c_function_setter(o->sc, slot_setter(q_arg1(o).p), slot_symbol(q_arg1(o).p), val); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_input_port_string_p_p_f(opt_info *o) +{ + s7_pointer val = q_p_func1_call(o); /* the string */ + s7_pointer port = slot_value(q_arg2(o).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 = q_p_func1_call(o); /* the string */ + s7_pointer port = slot_value(q_arg2(o).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(q_arg2(o).p); + if (is_mutable_integer(val)) + val = make_integer(o->sc, integer(val)); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_i_f(opt_info *o) +{ + s7_pointer val = make_integer(o->sc, q_i_func1_call(o)); + slot_set_value(q_arg1(o).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(q_arg2(o).p); + if (is_mutable_number(val)) + val = make_real(o->sc, real(val)); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_d_f(opt_info *o) +{ + s7_pointer val = make_real(o->sc, q_d_func1_call(o)); + slot_set_value(q_arg1(o).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(q_func1_arg(o).o1)); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_d_fm_sf_add(opt_info *o) +{ + s7_double x1 = opt_d_dd_sf_add(q_func1_arg(o).o1); + check_mutability(o->sc, o, __func__, __LINE__); + set_real(slot_value(q_arg1(o).p), x1); + return(slot_value(q_arg1(o).p)); +} + +static s7_pointer opt_set_p_d_f_mm_add(opt_info *o) /* see set_p_d_f_combinable below, tfft for both */ +{ + s7_double x1 = float_vector_ref_d_7pi(o->sc, slot_value(q_arg2(o).p), integer(slot_value(q_arg3(o).p))) * real(slot_value(q_arg1(o).p)); + s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(q_func2_arg(o).p), integer(slot_value(q_func3_arg(o).p))) * real(slot_value(q_arg4(o).p)); + slot_set_value(q_arg1(o).p, make_real(o->sc, x1 + x2)); + return(slot_value(q_arg1(o).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(q_arg2(o).p), integer(slot_value(q_arg3(o).p))) * real(slot_value(q_arg1(o).p)); + s7_double x2 = float_vector_ref_d_7pi(o->sc, slot_value(q_func2_arg(o).p), integer(slot_value(q_func3_arg(o).p))) * real(slot_value(q_arg4(o).p)); + slot_set_value(q_arg1(o).p, make_real(o->sc, x1 - x2)); + return(slot_value(q_arg1(o).p)); +} + +static s7_pointer opt_set_p_c(opt_info *o) +{ + slot_set_value(q_arg1(o).p, q_arg2(o).p); + return(q_arg2(o).p); +} + +static s7_pointer opt_set_p_i_fo(opt_info *o) +{ + s7_int i = q_func(o).i_ii_f(integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p))); + s7_pointer val = make_integer(o->sc, i); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_i_fo_add(opt_info *o) +{ + s7_int i = integer(slot_value(q_arg2(o).p)) + integer(slot_value(q_arg3(o).p)); + s7_pointer val = make_integer(o->sc, i); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_i_fo1(opt_info *o) +{ + s7_int i = q_func(o).i_ii_f(integer(slot_value(q_arg2(o).p)), q_arg3(o).i); + s7_pointer val = make_integer(o->sc, i); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static s7_pointer opt_set_p_i_fo1_add(opt_info *o) +{ + s7_int i = integer(slot_value(q_arg2(o).p)) + q_arg3(o).i; + s7_pointer val = make_integer(o->sc, i); + slot_set_value(q_arg1(o).p, val); + return(val); +} + +static bool set_p_i_f_combinable(s7_scheme *sc, opt_info *opc) +{ + /* arg1 is set already */ + if ((sc->pc > 1) && + (opc == sc->opts[sc->pc - 2])) + { + opt_info *o1 = sc->opts[sc->pc - 1]; + if ((q_call(o1).fi == opt_i_ii_ss) || + (q_call(o1).fi == opt_i_ii_ss_add)) + { + q_func(opc).i_ii_f = q_func(o1).i_ii_f; + q_arg2(opc).p = q_arg1(o1).p; + q_arg3(opc).p = q_arg2(o1).p; + q_call(opc).fp = (q_call(o1).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 ((q_call(o1).fi == opt_i_ii_sc) || (q_call(o1).fi == opt_i_ii_sc_add) || (q_call(o1).fi == opt_i_ii_sc_sub)) + { + q_func(opc).i_ii_f = q_func(o1).i_ii_f; + q_arg2(opc).p = q_arg1(o1).p; + q_arg3(opc).i = q_arg2(o1).i; + q_call(opc).fp = (q_call(o1).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 ((q_call(o1).fd == opt_d_mm_fff) && + ((q_func(o1).d_dd_f == add_d_dd) || (q_func(o1).d_dd_f == subtract_d_dd))) + { + opt_info *o2 = sc->opts[sc->pc - 2]; + q_call(opc).fp = (q_func(o1).d_dd_f == add_d_dd) ? opt_set_p_d_f_mm_add : opt_set_p_d_f_mm_subtract; + q_arg1(opc).p = q_arg1(o2).p; + q_arg2(opc).p = q_arg2(o2).p; + q_arg3(opc).p = q_arg3(o2).p; + o1 = sc->opts[sc->pc - 1]; + q_arg4(opc).p = q_arg1(o1).p; + q_func2_arg(opc).p = q_arg2(o1).p; + q_func3_arg(opc).p = q_arg3(o1).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))) + { + /* fprintf(stderr, "%d: %s %s\n", __LINE__, display(expr), display(target)); */ + q_call(opc).fp = opt_set_p_p_f; + q_func1_arg(opc).o1 = sc->opts[start_pc]; + q_func1(opc).fp = q_call(sc->opts[start_pc]).fp; + return_true(sc, expr); + }}} + return_false(sc, expr); +} + +static s7_pointer opt_starlet_set(opt_info *o) +{ + s7_pointer val = q_func(o).fp(q_arg2(o).o1); + return(starlet_set_1(o->sc, q_arg1(o).p, val)); +} + +static s7_pointer opt_starlet_set_i(opt_info *o) +{ + return(starlet_set_1(o->sc, q_arg1(o).p, q_arg2(o).p)); +} + +static s7_pointer list_increment_p_pip_unchecked(opt_info *o) +{ + s7_scheme *sc = o->sc; + s7_pointer num = slot_value(q_arg2(o).p), lst, p; + s7_int index = integer(num); + if ((index < 0) || (index > sc->max_list_length)) list_set_index_check_nr(sc, index); + lst = slot_value(q_arg1(o).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); + } + { + s7_pointer value = g_add_xi(sc, car(p), integer(q_arg3(o).p), index); + set_car(p, value); + return(value); + } +} + +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; + q_arg1(opc).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)))) + { + q_call(opc).fp = opt_set_p_p_f_with_setter; + q_func1_arg(opc).o1 = sc->opts[start_pc]; + q_func1(opc).fp = q_call(sc->opts[start_pc]).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) + { + q_arg2(opc).p = val_slot; + q_call(opc).fp = opt_set_p_i_s; + return_true(sc, expr); + }} + else + { + q_func1_arg(opc).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)) + { + q_call(opc).fp = opt_set_p_i_f; + q_func1(opc).fi = q_func1_arg(opc).q_call(o1).fi; + } + return_true(sc, expr); + } + return_false(sc, expr); + } + if (stype == sc->is_float_symbol) + { + if (is_t_real(value)) + { + q_arg2(opc).p = value; + q_call(opc).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) + { + q_arg2(opc).p = val_slot; + q_call(opc).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)) + { + q_func1_arg(opc).o1 = sc->opts[start_pc]; + q_func1(opc).fd = q_call(sc->opts[start_pc]).fd; + q_call(opc).fp = (q_func1(opc).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); + /* TODO: here if atype is float? or integer? or boolean? we should call the appropriate optimizer! */ + if (cell_optimize(sc, cddr(expr))) + { + /* fprintf(stderr, "%d: %s %s %s %s\n", __LINE__, display(expr), display(target), display(atype), display(stype)); */ + q_call(opc).fp = opt_set_p_p_f; + q_func1_arg(opc).o1 = sc->opts[start_pc]; + q_func1(opc).fp = q_call(sc->opts[start_pc]).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 obj_slot = s7_slot(sc, car(target)); + if (!is_slot(obj_slot)) return_false(sc, expr); + obj = slot_value(obj_slot); + q_arg1(opc).p = obj_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; + q_arg2(opc).p = s7_t_slot(sc, index); + if ((is_slot(q_arg2(opc).p)) && (is_string_port(slot_value(q_arg2(opc).p))) && (cell_optimize(sc, cddr(expr)))) + { + q_func1_arg(opc).o1 = sc->opts[start_pc]; + q_func1(opc).fp = q_call(sc->opts[start_pc]).fp; + q_call(opc).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(sc, index))) + { + s7_pointer sym = (is_quoted_symbol(sc, index)) ? cadr(index) : keyword_symbol(index); + if (starlet_symbol_id(sym) != sl_no_field) + { + q_arg1(opc).p = sym; + if (is_t_integer(caddr(expr))) + { + q_call(opc).fp = opt_starlet_set_i; + q_arg2(opc).p = caddr(expr); + return_true(sc, expr); + } + q_arg2(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_call(opc).fp = opt_starlet_set; + q_func(opc).fp = q_arg2(opc).q_call(o1).fp; /* TODO: fix this! */ + 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); + q_func(opc).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); + q_func(opc).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); + q_func(opc).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))) + { + q_temp(opc).fd = q_call(opc).fd; + q_call(opc).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); + q_func(opc).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))) + { + q_temp(opc).fi = q_call(opc).fi; + q_call(opc).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); + q_func(opc).d_7pid_f = func; + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (slot) + { + if (float_optimize(sc, cddr(expr))) + { + q_temp(opc).fd = opt_d_7pid_ssf; + q_call(opc).fp = d_to_p; /* cell_optimize, so need to return s7_pointer */ + q_arg2(opc).p = slot; + q_func2(opc).fd = q_func2_arg(opc).q_call(o1).fd; + return_true(sc, expr); + }} + else + if (int_optimize(sc, cdr(target))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (float_optimize(sc, cddr(expr))) + { + q_temp(opc).fd = opt_d_7pid_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fd = q_func3_arg(opc).q_call(o1).fd; + q_call(opc).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); + q_func(opc).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)))) + { + q_arg2(opc).p = slot; + q_arg3(opc).p = caddr(value); + q_call(opc).fp = list_increment_p_pip_unchecked; + return_true(sc, expr); + }}} + break; + + case T_HASH_TABLE: + if (is_pair(cddr(target))) return_false(sc, expr); + q_func(opc).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(sc, index)))) + q_func(opc).p_ppp_f = let_set_1; + else q_func(opc).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 index_slot = opt_simple_symbol(sc, index); + if (index_slot) + { + q_arg2(opc).p = index_slot; + if ((is_t_integer(slot_value(index_slot))) && + (has_loop_end(q_arg2(opc).p))) + { + if (is_string(obj)) + { + if (loop_end(q_arg2(opc).p) <= string_length(obj)) + q_func(opc).p_pip_f = string_set_p_pip_direct; + } + else + if (is_byte_vector(obj)) + { + if (loop_end(q_arg2(opc).p) <= byte_vector_length(obj)) + q_func(opc).p_pip_f = byte_vector_set_p_pip_direct; + } + else + if ((is_complex_vector(obj)) && + (loop_end(q_arg2(opc).p) <= vector_length(obj))) + { + q_func(opc).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(q_arg2(opc).p) <= vector_length(obj))) + { + if (is_typed_t_vector(obj)) + q_func(opc).p_pip_f = typed_t_vector_set_p_pip_direct; + else q_func(opc).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))) + { + q_arg3(opc).p = val_slot; + q_call(opc).fp = opt_p_pip_sss; + return_true(sc, expr); + } + if ((is_let(obj)) && (is_keyword(index)) && (q_func(opc).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 = q_func(opc).p_ppp_f; + q_arg3(opc).p = val_slot; + q_call(opc).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))) + { + q_arg3(opc).p = (!is_pair(value)) ? value : cadr(value); + if ((is_string(obj)) || + (is_any_vector(obj)) || + (is_pair(obj))) + { + q_call(opc).fp = opt_p_pip_ssc; + return_true(sc, expr); + } + if ((is_let(obj)) && (is_keyword(index)) && (q_func(opc).p_ppp_f == let_set_1) && /* (set! (L3 :x) 0) */ + (use_ppc_slot_set(sc, opc, obj, keyword_symbol(index), q_arg3(opc).p))) + return_true(sc, expr); + q_call(opc).fp = opt_p_ppp_ssc; + return_true(sc, expr); + } + if (cell_optimize(sc, cddr(expr))) + { + q_func1_arg(opc).o1 = sc->opts[start]; + q_func1(opc).fp = q_call(sc->opts[start]).fp; + if ((is_string(obj)) || + (is_any_vector(obj)) || + (is_pair(obj))) + { + if (p_pip_ssf_combinable(sc, opc, start)) + return_true(sc, expr); + q_call(opc).fp = opt_p_pip_ssf; + return_true(sc, expr); + } + if ((is_let(obj)) && (is_keyword(index)) && (q_func(opc).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); + q_call(opc).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))) + { + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (int_optimize(sc, cdr(target))) + { + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_call(opc).fp = opt_p_pip_sff; + q_func2(opc).fi = q_func2_arg(opc).q_call(o1).fi; + q_func3(opc).fp = q_func3_arg(opc).q_call(o1).fp; + return_true(sc, expr); + }} + return_false(sc, expr); + } + if (is_quoted_symbol(sc, index)) + { + if (is_symbol(value)) + { + const s7_pointer val_slot = opt_simple_symbol(sc, value); + if (val_slot) + { + q_arg2(opc).p = cadr(index); + q_arg3(opc).p = val_slot; + q_call(opc).fp = opt_p_ppp_scs; + if ((is_let(obj)) && (q_func(opc).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)) && (q_func(opc).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) + { + q_arg2(opc).p = val_slot; + q_call(opc).fp = opt_p_ppp_sfs; + q_func1_arg(opc).o1 = o1; + q_func1(opc).fp = q_call(o1).fp; + return_true(sc, expr); + }} + o2 = sc->opts[sc->pc]; + if (cell_optimize(sc, cddr(expr))) + { + q_call(opc).fp = opt_p_ppp_sff; + if ((is_let(obj)) && (is_quoted_symbol(sc, index)) && (q_func(opc).p_ppp_f == let_set_1) && /* (set! (L3 'x) (+ (L3 'x) 1)) */ + (use_ppf_slot_set(sc, opc, obj, cadr(index)))) + { + q_func1_arg(opc).o1 = o2; + q_func1(opc).fp = q_func1_arg(opc).q_call(o1).fp; + return_true(sc, expr); + } + q_func2_arg(opc).o1 = o1; + q_func2(opc).fp = q_call(o1).fp; + q_func3_arg(opc).o1 = o2; + q_func3(opc).fp = q_call(o2).fp; + return_true(sc, expr); + }}}} + return_false(sc, expr); +} + + +/* -------- cell_begin -------- */ +#define q_begin_arg(o, i) o->v[i + 2] + +static s7_pointer opt_begin_p(opt_info *o) +{ + opt_info *o1; + s7_int i, len = q_arg1(o).i; /* len = 1 if 2 exprs, etc */ + for (i = 0; i < len; i++) + { + o1 = q_begin_arg(o, i).o1; + q_call(o1).fp(o1); + } + o1 = q_begin_arg(o, i).o1; + return(q_call(o1).fp(o1)); +} + +static s7_pointer opt_begin_p_1(opt_info *o) +{ + q_func(o).fp(q_arg2(o).o1); + return(q_p_func1_call(o)); +} + +static void oo_idp_nr_fixup(opt_info *start) +{ + if (q_call(start).fp == d_to_p) + { + q_call(start).fp = d_to_p_nr; + if (q_temp(start).fd == opt_d_7pid_ssf) + q_call(start).fp = opt_d_7pid_ssf_nr; + else + if (q_temp(start).fd == opt_d_7pid_ssfo_fv) + { + q_call(start).fp = opt_d_7pid_ssfo_fv_nr; + if (q_func2(start).d_dd_f == add_d_dd) + q_call(start).fp = opt_d_7pid_ssfo_fv_add_nr; + else + if (q_func2(start).d_dd_f == subtract_d_dd) + q_call(start).fp = opt_d_7pid_ssfo_fv_sub_nr; + }} + else + if (q_call(start).fp == i_to_p) + q_call(start).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 = 0; 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); + q_begin_arg(opc, i).o1 = start; + } + q_arg1(opc).i = len - 2; + if (len == 3) + { + q_call(opc).fp = opt_begin_p_1; + q_func1_arg(opc).o1 = q_begin_arg(opc, 1).o1; + q_func1(opc).fp = q_begin_arg(opc, 2).q_call(o1).fp; + q_func(opc).fp = q_begin_arg(opc, 0).q_call(o1).fp; + } + else q_call(opc).fp = opt_begin_p; + return_true(sc, expr); +} + +/* -------- cell_when|unless -------- */ + +#define q_when_body_len(o) o->v[1] +#define q_when_test_arg(o) o->v[3] +#define q_when_test_func(o) o->v[4] +#define q_when_test_call(o) o->v[4].fb(o->v[3].o1) +#define q_when_body(o, i) o->v[i + 5] +#define q_when_p1_call(o) o->v[6].fp(o->v[5].o1) +#define q_when_p1_func(o) o->v[6] +#define q_when_p1_arg(o) o->v[5] +#define q_when_p2_call(o) o->v[8].fp(o->v[7].o1) +#define q_when_p2_func(o) o->v[8] +#define q_when_p2_arg(o) o->v[7] + +static s7_pointer opt_when_p_2(opt_info *o) +{ + if (q_when_test_call(o)) + { + q_when_p1_call(o); + return(q_when_p2_call(o)); + } + return(o->sc->unspecified); +} + +static s7_pointer opt_when_p(opt_info *o) +{ + if (q_when_test_call(o)) + { + s7_int i, len = q_when_body_len(o).i - 1; + opt_info *o1; + for (i = 0; i < len; i++) + { + o1 = q_when_body(o, i).o1; + q_call(o1).fp(o1); + } + o1 = q_when_body(o, i).o1; + return(q_call(o1).fp(o1)); + } + return(o->sc->unspecified); +} + +static s7_pointer opt_when_p_1(opt_info *o) +{ + opt_info *o1; + if (!q_when_test_call(o)) + return(o->sc->unspecified); + o1 = q_when_body(o, 0).o1; + return(q_call(o1).fp(o1)); +} + +static s7_pointer opt_unless_p(opt_info *o) +{ + opt_info *o1; + s7_int i, len; + if (q_when_test_call(o)) + return(o->sc->unspecified); + len = q_when_body_len(o).i - 1; + for (i = 0; i < len; i++) + { + o1 = q_when_body(o, i).o1; + q_call(o1).fp(o1); + } + o1 = q_when_body(o, i).o1; + return(q_call(o1).fp(o1)); +} + +static s7_pointer opt_unless_p_1(opt_info *o) +{ + opt_info *o1; + if (q_when_test_call(o)) + return(o->sc->unspecified); + o1 = q_when_body(o, 0).o1; + return(q_call(o1).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); + q_when_test_arg(opc).o1 = sc->opts[sc->pc]; + if (!bool_optimize(sc, cdr(expr))) + return_false(sc, expr); + for (k = 0, 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); + q_when_body(opc, k).o1 = start; + } + q_when_test_func(opc).fb = q_when_test_arg(opc).q_call(o1).fb; + q_when_body_len(opc).i = len - 2; + if (car(expr) == sc->when_symbol) + { + if (len == 3) /* 1 expr */ + q_call(opc).fp = opt_when_p_1; + else + if (len == 4) /* 2 exprs */ + { + q_call(opc).fp = opt_when_p_2; + q_when_p2_arg(opc).o1 = q_when_body(opc, 1).o1; /* make room... */ + q_when_p2_func(opc).fp = q_when_p2_arg(opc).q_call(o1).fp; /* order matters */ + q_when_p1_func(opc).fp = q_when_p1_arg(opc).q_call(o1).fp; /* also q_when_body(opc, 0) */ + } + else q_call(opc).fp = opt_when_p; + } + else q_call(opc).fp = (len == 3) ? opt_unless_p_1 : opt_unless_p; + return_true(sc, expr); +} + + +/* -------- cell_cond -------- */ + +#define q_cond_o1 3 +#define q_cond_clause_o1 5 +#define q_cond_val1(o) o->v[6] +#define q_cond_val2(o) o->v[7] +#define q_cond_clause(o, i) o->v[i + q_cond_clause_o1] +#define q_cond(o, i) o->v[i + q_cond_o1] + +static s7_pointer cond_value(opt_info *o) +{ + opt_info *o1; + s7_int i, len = q_arg1(o).i - 1; + for (i = 0; i < len; i++) + { + o1 = q_cond_clause(o, i).o1; + q_call(o1).fp(o1); + } + o1 = q_cond_clause(o, i).o1; + return(q_call(o1).fp(o1)); +} + +static s7_pointer opt_cond(opt_info *top) +{ + s7_int len = q_arg2(top).i; + for (s7_int clause = 0; clause < len; clause++) + { + opt_info *o1 = q_cond(top, clause).o1; + opt_info *o2 = q_func1_arg(o1).o1; + if (q_call(o2).fb(o2)) + return(cond_value(o1)); + } + return(top->sc->unspecified); +} + +static s7_pointer opt_cond_1(opt_info *o) {return((q_b_func1_call(o)) ? cond_value(q_cond_val1(o).o1) : o->sc->unspecified);} /* cond as when */ +static s7_pointer opt_cond_1b(opt_info *o) {return((q_func1_arg(o).q_temp(o1).fp(q_func1_arg(o).o1) != o->sc->F) ? cond_value(q_cond_val1(o).o1) : o->sc->unspecified);} + +static s7_pointer opt_cond_2(opt_info *o) /* 2 branches, results 1 expr, else */ +{ + opt_info *o1 = (q_b_func1_call(o)) ? q_cond_val1(o).o1 : q_cond_val2(o).o1; + return(q_call(o1).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 - q_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; + q_cond(top, branches).o1 = sc->opts[sc->pc]; + opc = alloc_opt_info(sc); + q_func1_arg(opc).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 - q_cond_clause_o1) + return_false(sc, cp); + q_cond_clause(opc, blen).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cp)) + return_false(sc, cp); + } + if (!is_null(cp)) + return_false(sc, cp); + q_arg1(opc).i = blen; + if (max_blen < blen) max_blen = blen; + q_call(opc).fp = opt_cond; /* a placeholder */ + } + if (branches == 1) + { + opt_info *o1 = sc->opts[start_pc + 1]; + q_call(top).fp = (q_call(o1).fb == p_to_b) ? opt_cond_1b : opt_cond_1; + q_func1_arg(top).o1 = o1; + q_func1(top).fb = q_call(o1).fb; + q_cond_val1(top).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; + q_cond_val1(top).o1 = q_cond(top, 0).q_cond_clause(o1, 0).o1; + q_cond_val2(top).o1 = q_cond(top, 1).q_cond_clause(o1, 0).o1; + o1 = sc->opts[start_pc + 1]; + q_func1_arg(top).o1 = o1; + q_func1(top).fb = q_call(o1).fb; + q_call(top).fp = opt_cond_2; + return_true(sc, expr); + }} + q_arg2(top).i = branches; + q_call(top).fp = opt_cond; + return_true(sc, expr); +} + +/* -------- cell_and|or -------- */ +#define q_or_clause(o, i) o->v[i + 3] + +static s7_pointer opt_and_pp(opt_info *o) {return((q_p_func2_call(o) == o->sc->F) ? o->sc->F : q_p_func3_call(o));} + +static s7_pointer opt_and_any_p(opt_info *o) +{ + s7_pointer val = o->sc->T; /* (and) -> #t */ + for (s7_int i = 0; i < q_arg1(o).i; i++) + { + opt_info *o1 = q_or_clause(o, i).o1; + val = q_call(o1).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 = q_p_func2_call(o); + return((val != o->sc->F) ? val : q_p_func3_call(o)); +} + +static s7_pointer opt_or_any_p(opt_info *o) +{ + for (s7_int i = 0; i < q_arg1(o).i; i++) + { + opt_info *o1 = q_or_clause(o, i).o1; + s7_pointer val = q_call(o1).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) + { + q_call(opc).fp = ((car(expr) == sc->or_symbol) ? opt_or_pp : opt_and_pp); + q_func2_arg(opc).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdr(expr))) + return_false(sc, expr); + q_func2(opc).fp = q_func2_arg(opc).q_call(o1).fp; + q_func3_arg(opc).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cddr(expr))) + return_false(sc, expr); + q_func3(opc).fp = q_func3_arg(opc).q_call(o1).fp; + return_true(sc, expr); + } + if ((len > 1) && (len < (num_vunions - 4))) + { + s7_pointer p = cdr(expr); + q_arg1(opc).i = (len - 1); + q_call(opc).fp = ((car(expr) == sc->or_symbol) ? opt_or_any_p : opt_and_any_p); + for (int32_t i = 0; is_pair(p); i++, p = cdr(p)) + { + q_or_clause(opc, 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((q_func(o).fb(q_arg2(o).o1)) ? q_p_func1_call(o) : o->sc->unspecified);} +static s7_pointer opt_if_b7p(opt_info *o) {return((opt_b_7p_f(q_arg2(o).o1)) ? q_p_func1_call(o) : o->sc->unspecified);} /* expanded not faster */ +static s7_pointer opt_if_nbp(opt_info *o) {return((q_b_func1_call(o)) ? o->sc->unspecified : q_p_func2_call(o));} +static s7_pointer opt_if_bp_and(opt_info *o) {return((opt_and_bb(q_arg2(o).o1)) ? q_p_func1_call(o) : 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((q_func(o).fp(q_arg2(o).o1) != o->sc->F) ? q_p_func1_call(o) : o->sc->unspecified); +} + +static s7_pointer opt_if_bp_ii_fc(opt_info *o) +{ + return((q_func(o).b_ii_f(q_i_func2_call(o), q_arg2(o).i)) ? q_p_func1_call(o) : o->sc->unspecified); +} + +static s7_pointer opt_if_nbp_s(opt_info *o) +{ + return((q_func(o).b_p_f(slot_value(q_arg2(o).p))) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_nbp_sc(opt_info *o) /* b_pp_sc */ +{ + return((q_func(o).b_pp_f(slot_value(q_arg2(o).p), q_arg3(o).p)) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_nbp_7sc(opt_info *o) /* b_7pp_sc */ +{ + return((q_func(o).b_7pp_f(o->sc, slot_value(q_arg2(o).p), q_arg3(o).p)) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_nbp_ss(opt_info *o) /* b_ii_ss */ +{ + return((q_func(o).b_ii_f(integer(slot_value(q_arg2(o).p)), integer(slot_value(q_arg3(o).p)))) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_num_eq_ii_ss(opt_info *o) /* b_ii_ss */ +{ + return((integer(slot_value(q_arg2(o).p)) == integer(slot_value(q_arg3(o).p))) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_nbp_fs(opt_info *o) /* b_pi_fs */ +{ + return((q_func4(o).b_pi_f(o->sc, q_p_func1_call(o), integer(slot_value(q_arg1(o).p)))) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_nbp_sf(opt_info *o) /* b_pp_sf */ +{ + return((q_func(o).b_pp_f(slot_value(q_arg1(o).p), q_p_func1_call(o))) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_nbp_7sf(opt_info *o) /* b_7pp_sf */ +{ + return((q_func(o).b_7pp_f(o->sc, slot_value(q_arg1(o).p), q_p_func1_call(o))) ? o->sc->unspecified : q_p_func2_call(o)); +} + +static s7_pointer opt_if_bpp(opt_info *o) {return((q_b_func1_call(o)) ? q_p_func3_call(o) : q_p_func2_call(o));} +static s7_pointer opt_if_bpp_bit(opt_info *o) {return((opt_b_7ii_sc_bit(q_func1_arg(o).o1)) ? q_p_func3_call(o) : q_p_func2_call(o));} + +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))) + { + q_func2_arg(opc).o1 = top; + q_func2(opc).fp = q_call(top).fp; + if (q_call(bop).fb == opt_b_p_s) + { + q_func(opc).b_p_f = q_func(bop).b_p_f; + q_arg2(opc).p = q_arg1(bop).p; + q_call(opc).fp = opt_if_nbp_s; + return_true(sc, expr); + } + if ((q_call(bop).fb == opt_b_pi_fs) || (q_call(bop).fb == opt_b_pi_fs_num_eq)) + { + q_func4(opc).b_pi_f = q_func4(bop).b_pi_f; + q_arg1(opc).p = q_arg1(bop).p; + q_func1_arg(opc).o1 = q_func2_arg(bop).o1; + q_func1(opc).fp = q_func2(bop).fp; + q_call(opc).fp = opt_if_nbp_fs; + return_true(sc, expr); + } + if ((q_call(bop).fb == opt_b_pp_sf) || + (q_call(bop).fb == opt_b_7pp_sf)) + { + q_func1_arg(opc).o1 = q_func2_arg(bop).o1; + q_func1(opc).fp = q_func2(bop).fp; + if (q_call(bop).fb == opt_b_pp_sf) + { + q_func(opc).b_pp_f = q_func(bop).b_pp_f; + q_call(opc).fp = opt_if_nbp_sf; + } + else + { + q_func(opc).b_7pp_f = q_func(bop).b_7pp_f; + q_call(opc).fp = opt_if_nbp_7sf; + } + q_arg1(opc).p = q_arg1(bop).p; + return_true(sc, expr); + } + if ((q_call(bop).fb == opt_b_pp_sc) || + (q_call(bop).fb == opt_b_7pp_sc)) + { + if (q_call(bop).fb == opt_b_pp_sc) + { + q_func(opc).b_pp_f = q_func(bop).b_pp_f; + q_call(opc).fp = opt_if_nbp_sc; + } + else + { + q_func(opc).b_7pp_f = q_func(bop).b_7pp_f; + q_call(opc).fp = opt_if_nbp_7sc; + } + q_arg2(opc).p = q_arg1(bop).p; + q_arg3(opc).p = q_arg2(bop).p; + return_true(sc, expr); + } + if ((q_call(bop).fb == opt_b_ii_ss) || (q_call(bop).fb == opt_b_ii_ss_eq) || + (q_call(bop).fb == opt_b_ii_ss_lt) || (q_call(bop).fb == opt_b_ii_ss_gt) || + (q_call(bop).fb == opt_b_ii_ss_leq) || (q_call(bop).fb == opt_b_ii_ss_geq)) + { + q_func(opc).b_ii_f = q_func(bop).b_ii_f; + q_arg2(opc).p = q_arg1(bop).p; + q_arg3(opc).p = q_arg2(bop).p; + q_call(opc).fp = (q_func(opc).b_ii_f == num_eq_b_ii) ? opt_if_num_eq_ii_ss : opt_if_nbp_ss; + return_true(sc, expr); + } + q_func1_arg(opc).o1 = bop; + q_func1(opc).fb = q_call(bop).fb; + q_call(opc).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))) + { + q_arg2(opc).o1 = bop; + q_func1_arg(opc).o1 = top; + q_func1(opc).fp = q_call(top).fp; + if (q_call(bop).fb == p_to_b) + { + q_call(opc).fp = opt_if_bp_pb; + q_func(opc).fp = q_temp(bop).fp; + return_true(sc, expr); + } + if (q_call(bop).fb == opt_b_ii_fc) + { + q_arg2(opc).i = q_arg2(bop).i; + q_func(opc).b_ii_f = q_func(bop).b_ii_f; + q_func2(opc).fi = q_func2(bop).fi; + q_func2_arg(opc).o1 = q_func2_arg(bop).o1; + q_call(opc).fp = opt_if_bp_ii_fc; + return_true(sc, expr); + } + q_call(opc).fp = (q_call(bop).fb == opt_b_7p_f) ? opt_if_b7p : ((q_call(bop).fb == opt_and_bb) ? opt_if_bp_and : opt_if_bp); + q_func(opc).fb = q_call(bop).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]; + q_call(opc).fp = (q_call(bop).fb == opt_b_7ii_sc_bit) ? opt_if_bpp_bit : opt_if_bpp; + if (cell_optimize(sc, cdddr(expr))) + { + q_func1_arg(opc).o1 = bop; + q_func1(opc).fb = q_call(bop).fb; + q_func3_arg(opc).o1 = top; + q_func3(opc).fp = q_call(top).fp; + q_func2_arg(opc).o1 = o3; + q_func2(opc).fp = q_call(o3).fp; + return_true(sc, expr); + }}}} + return_false(sc, expr); +} + +/* -------- cell_case -------- */ +#define q_case_start 3 +#define q_max_case_clauses (num_vunions - 4) +#define q_case_selector(o) o->v[2] +#define q_case_clause(o, i) o->v[i + 4] +#define q_case(o, i) o->v[i] +#define q_case_clause_keys(o) o->v[2] + +static s7_pointer case_value(opt_info *o) +{ + opt_info *o1; + int32_t i, len = q_arg1(o).i - 1; /* int32_t here and below seems to be faster than s7_int (tleft.scm) */ + for (i = 0; i < len; i++) + { + o1 = q_case_clause(o, i).o1; + q_call(o1).fp(o1); + } + o1 = q_case_clause(o, i).o1; + return(q_call(o1).fp(o1)); +} + +static s7_pointer opt_case(opt_info *o) +{ + opt_info *o1 = q_case_selector(o).o1; + const int32_t lim = q_arg1(o).i; + s7_scheme *sc = o->sc; + const s7_pointer selector = q_call(o1).fp(o1); + + if (is_simple(selector)) + { + for (int32_t ctr = q_case_start; ctr < lim; ctr++) + { + s7_pointer p; + o1 = q_case(o, ctr).o1; + for (p = q_case_clause_keys(o1).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 = q_case_start; ctr < lim; ctr++) + { + s7_pointer p; + o1 = q_case(o, ctr).o1; + for (p = q_case_clause_keys(o1).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); + q_case_selector(top).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdr(expr))) /* selector */ + return_false(sc, expr); + for (ctr = q_case_start, 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); + q_case(top, ctr).o1 = opc; + if (car(clause) == sc->else_symbol) + { + if (!is_null(cdr(p))) + return_false(sc, clause); + q_case_clause_keys(opc).p = sc->else_symbol; + } + else + { + if (!s7_is_proper_list(sc, car(clause))) + return_false(sc, clause); + q_case_clause_keys(opc).p = car(clause); + } + + for (blen = 0, cp = cdr(clause); (is_pair(cp)) && (blen < q_max_case_clauses); blen++, cp = cdr(cp)) + { + q_case_clause(opc, blen).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cp)) + return_false(sc, cp); + } + if (!is_null(cp)) + return_false(sc, cp); + q_arg1(opc).i = blen; + q_call(opc).fp = opt_case; /* just a placeholder I hope */ + } + if (!is_null(p)) + return_false(sc, p); + q_arg1(top).i = ctr; + q_call(top).fp = opt_case; + return_true(sc, expr); +} + +/* -------- cell_let_temporarily -------- */ + +#define q_let_temp_o1 5 +#define q_let_temp(o, i) o->v[i + q_let_temp_o1] +#define q_let_temp_old_value(o) o->v[3] +#define q_let_temp_new_value(o) o->v[4] + +static s7_pointer opt_let_temporarily(opt_info *o) +{ + opt_info *new_o1 = q_let_temp_new_value(o).o1; + s7_int i, len; + s7_pointer result; + s7_scheme *sc = o->sc; + + if (is_immutable_slot(q_arg1(o).p)) + immutable_object_error_nr(sc, set_elist_3(sc, immutable_error_string, sc->let_temporarily_symbol, slot_symbol(q_arg1(o).p))); + + q_let_temp_old_value(o).p = slot_value(q_arg1(o).p); /* save and protect old value */ + gc_protect_via_stack(sc, q_let_temp_old_value(o).p); + slot_set_value(q_arg1(o).p, q_call(new_o1).fp(new_o1)); /* set new value */ + len = q_arg2(o).i - 1; + { + opt_info *o1; + for (i = 0; i < len; i++) + { + o1 = q_let_temp(o, i).o1; + q_call(o1).fp(o1); + } + o1 = q_let_temp(o, i).o1; + result = q_call(o1).fp(o1); + } + slot_set_value(q_arg1(o).p, q_let_temp_old_value(o).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 - q_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); + q_arg1(opc).p = s7_t_slot(sc, caaadr(expr)); + if (!is_slot(q_arg1(opc).p)) return_false(sc, expr); + q_let_temp_new_value(opc).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, cdaadr(expr))) + return_false(sc, expr); + + p = cddr(expr); + for (int32_t i = 0; is_pair(p); i++, p = cdr(p)) + { + q_let_temp(opc, i).o1 = sc->opts[sc->pc]; + if (!cell_optimize(sc, p)) + return_false(sc, expr); + } + q_arg2(opc).i = len - 2; + q_call(opc).fp = opt_let_temporarily; + return_true(sc, expr); + } + return_false(sc, expr); +} + +/* -------- cell_do -------- */ + +#define do_curlet(o) T_Let(q_arg2(o).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 +#define do_stepper_opt(o) o->v[9].o1 +#define do_expr(o, i) o->v[i] + +static void let_set_has_pending_value(s7_pointer let) +{ + for (s7_pointer slot = let_slots(let); is_not_slot_end(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 let) +{ + for (s7_pointer slot = let_slots(let); is_not_slot_end(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_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + /* init */ + slot = let_slots(sc->curlet); + for (int32_t k = 0; is_not_slot_end(slot); k++, slot = next_slot(slot)) + { + o1 = do_expr(inits, k).o1; + slot_set_value(slot, q_call(o1).fp(o1)); + } + let_set_has_pending_value(sc->curlet); + for (int32_t i = 0; i < len; i++) + { + os[i] = do_expr(body, i).o1; + fp[i] = q_call(os[i]).fp; + } + while (true) + { + /* end */ + if (q_call(ostart).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; is_not_slot_end(slot); k++, slot = next_slot(slot)) + if (has_stepper(slot)) + { + o1 = do_expr(steps, k).o1; + slot_simply_set_pending_value(slot, q_call(o1).fp(o1)); + } + for (s7_pointer slot1 = let_slots(sc->curlet); is_not_slot_end(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 = do_expr(results, i).o1; + result = q_call(o1).fp(o1); + } + let_clear_has_pending_value(sc, sc->curlet); + unstack_gc_protect(sc); + set_curlet(sc, old_let); + 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 = do_stepper_opt(o); + 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_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + slot = let_slots(sc->curlet); + for (int32_t k = 0; is_not_slot_end(slot); k++, slot = next_slot(slot)) + { + o1 = do_expr(inits, k).o1; + slot_set_value(slot, q_call(o1).fp(o1)); + if (has_stepper(slot)) stepper = slot; + } + while (!(q_call(ostart).fb(ostart))) + { + q_call(body).fp(body); + slot_set_value(stepper, q_call(ostep).fp(ostep)); + } + o1 = do_any_results(o); + result = q_call(o1).fp(o1); + unstack_gc_protect(sc); + set_curlet(sc, old_let); + 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 = do_stepper_opt(o); + const opt_info *inits = do_any_inits(o); + opt_info *body = do_any_body(o); + s7_pointer (*fp)(opt_info *o) = q_call(body).fp; + s7_pointer slot, result, stepper = NULL, si; + s7_scheme *sc = o->sc; + s7_int end, incr; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + slot = let_slots(sc->curlet); + for (int32_t k = 0; is_not_slot_end(slot); k++, slot = next_slot(slot)) + { + o1 = do_expr(inits, k).o1; + slot_set_value(slot, q_call(o1).fp(o1)); + if (has_stepper(slot)) stepper = slot; + } + end = integer(slot_value(q_arg2(ostart).p)); + incr = q_arg2(ostep).i; + si = make_mutable_integer(sc, integer(slot_value(q_arg1(ostart).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(q_arg1(body).p, make_mutable_real(sc, real(slot_value(q_arg1(body).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(q_arg1(body).p)); + o1 = do_any_results(o); + result = q_call(o1).fp(o1); + unstack_gc_protect(sc); + set_curlet(sc, old_let); + 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) = q_call(ostart).fb; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + 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 = do_expr(body, i).o1; + q_call(o1).fp(o1); + }} + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return(sc->T); +} + +#define do_stepper_init(o) o->v[11].o1 +#define do_stepper_safe(o) o->v[8].i + +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 = do_stepper_opt(o); + opt_info *body = do_any_body(o); + s7_pointer slot = let_slots(do_curlet(o)); + s7_scheme *sc = o->sc; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + slot_set_value(slot, q_call(o1).fp(o1)); + if ((do_stepper_safe(o) == 1) && + (is_t_integer(slot_value(slot)))) + { + if ((q_call(ostep).fp == opt_p_ii_ss_add) || /* tmap */ + (q_call(ostep).fp == i_to_p)) + { + s7_pointer step_val = make_mutable_integer(sc, integer(slot_value(slot))); + slot_set_value(slot, step_val); + if (q_call(ostep).fp == opt_p_ii_ss_add) + while (!q_call(ostart).fb(ostart)) + { + q_call(body).fp(body); + set_integer(step_val, opt_i_ii_ss_add(ostep)); + } + else + while (!q_call(ostart).fb(ostart)) + { + q_call(body).fp(body); + set_integer(step_val, q_temp(ostep).fi(ostep)); + } + unstack_gc_protect(sc); + clear_mutable_integer(step_val); + set_curlet(sc, old_let); + return(sc->T); + } + do_stepper_safe(o) = 2; + } + while (!(q_call(ostart).fb(ostart))) /* s7test tref */ + { + q_call(body).fp(body); + slot_set_value(slot, q_call(ostep).fp(ostep)); + } + unstack_gc_protect(sc); + set_curlet(sc, old_let); + 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 = do_stepper_opt(o); + 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_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + slot_set_value(slot, q_call(o1).fp(o1)); + if (len == 2) /* tmac tshoot */ + { + opt_info *e1 = q_call(body).o1, *e2 = q_arg1(body).o1; + while (!(q_call(ostart).fb(ostart))) + { + q_call(e1).fp(e1); + q_call(e2).fp(e2); + slot_set_value(slot, q_call(ostep).fp(ostep)); + }} + else + { + opt_info *os[num_vunions]; + opt_info_fp fp[num_vunions]; + for (int32_t i = 0; i < len; i++) + { + os[i] = do_expr(body, i).o1; + fp[i] = q_call(os[i]).fp; + } + if (len == 7) + while (!q_call(ostart).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, q_call(ostep).fp(ostep)); + } + else + while (!q_call(ostart).fb(ostart)) /* tfft teq */ + { + for (int32_t i = 0; i < len; i++) fp[i](os[i]); + slot_set_value(slot, q_call(ostep).fp(ostep)); + }} + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return(sc->T); +} + +#define do_times_end(o) o->v[6] + +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)))) : do_times_end(o).i; + s7_pointer slot = let_dox1_value(do_curlet(o)); + s7_scheme *sc = o->sc; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + set_integer(slot, integer(q_call(o1).fp(o1))); + if (len == 2) /* tmac tmisc */ + { + opt_info *e1 = q_call(body).o1, *e2 = q_arg1(body).o1; + while (integer(slot) < end) + { + q_call(e1).fp(e1); + q_call(e2).fp(e2); + integer(slot)++; + }} + else + while (integer(slot) < end) /* tbig sg */ + { + for (int32_t i = 0; i < len; i++) + { + o1 = do_expr(body, i).o1; + q_call(o1).fp(o1); + } + integer(slot)++; + } + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return(sc->T); +} + +#define do_end(o) o->v[3] + +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_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + slot_set_value(slot, q_call(o1).fp(o1)); + o1 = do_any_body(o); + fp = q_call(o1).fp; + if (fp == opt_if_bp) + while (is_pair(slot_value(slot))) + { + if (do_end(o1).fb(q_arg2(o1).o1)) + q_p_func1_call(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_let); + 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)))) : do_end(o).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_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + set_integer(vp, integer(q_call(o1).fp(o1))); + o1 = do_any_body(o); + f = q_call(o1).fp; + if (f == opt_p_pip_ssf) /* tref.scm */ + { + opt_info *o2 = o1; + o1 = q_func1_arg(o2).o1; + if (q_func(o2).p_pip_f == t_vector_set_p_pip_direct) + { + s7_pointer vec = slot_value(q_arg1(o2).p); + while (integer(vp) < end) + { + t_vector_set_p_pip_direct(o2->sc, vec, integer(slot_value(q_arg2(o2).p)), q_call(o1).fp(o1)); + integer(vp)++; + }} + else + while (integer(vp) < end) + { + q_func(o2).p_pip_f(o2->sc, slot_value(q_arg1(o2).p), integer(slot_value(q_arg2(o2).p)), q_call(o1).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)) == q_arg2(o1).p) && (q_arg2(o1).p == q_arg4(o1).p)) + { + s7_pointer (*setter)(s7_scheme *sc, s7_pointer p1, s7_int i1, s7_pointer p2) = q_func(o1).p_pip_f; + s7_pointer (*getter)(s7_scheme *sc, s7_pointer p1, s7_int i1) = q_func3(o1).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(q_arg1(o1).p), slot_value(q_arg3(o1).p), integer(vp), end, integer(vp)); /* TODO: q_arg1 and q_arg3 */ + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return(sc->T); + }} + while (integer(vp) < end) + { + q_func(o1).p_pip_f(o1->sc, slot_value(q_arg1(o1).p), integer(slot_value(q_arg2(o1).p)), + q_func3(o1).p_pi_f(o1->sc, slot_value(q_arg3(o1).p), integer(slot_value(q_arg4(o1).p)))); + integer(vp)++; + }} + else + if ((f == opt_set_p_i_f) && /* tvect.scm */ + (is_t_integer(slot_value(q_arg1(o1).p))) && + (q_arg1(o1).p != let_dox_slot1(do_curlet(o)))) + { + opt_info *o2 = q_func1_arg(o1).o1; /* set_p_i_f: x = make_integer(o->sc, o-v[6].fi(o-v[5].o1)); */ + s7_int (*fi)(opt_info *o) = q_call(o2).fi; + s7_pointer ival = make_mutable_integer(sc, integer(slot_value(q_arg1(o1).p))); + slot_set_value(q_arg1(o1).p, ival); + while (integer(vp) < end) + { + set_integer(ival, fi(o2)); + integer(vp)++; + } + slot_set_value(q_arg1(o1).p, make_integer(sc, integer(slot_value(q_arg1(o1).p)))); + clear_mutable_integer(ival); + } + else + if ((f == opt_d_7pid_ssf_nr) && /* tref.scm */ + (q_func(o1).d_7pid_f == float_vector_set_d_7pid_direct)) + { + s7_pointer ind = q_arg2(o1).p; + opt_info *o2 = do_any_body(o1); + s7_double (*fd)(opt_info *o) = q_call(o2).fd; + s7_pointer fv = slot_value(q_arg1(o1).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_let); + return(sc->T); +} + +#define do_prepack_end(o) o->v[1].i +#define do_prepack_stepper(o) o->v[6].p +#define do_dpnr_func(o) o->v[7] + +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)))) : do_end(o).i; + s7_pointer vp = let_dox1_value(do_curlet(o)); + s7_scheme *sc = o->sc; + const s7_pointer old_let = sc->curlet; + gc_protect_via_stack(sc, old_let); + set_curlet(sc, do_curlet(o)); + set_integer(vp, integer(q_call(o1).fp(o1))); + + do_prepack_stepper(o) = vp; + do_prepack_end(o) = end; + do_dpnr_func(o).fp(o); /* call opt_do_i|dpnr below */ + + unstack_gc_protect(sc); + set_curlet(sc, old_let); + 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) = q_temp(o1).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) = q_temp(o1).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(sc, 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)); +} + +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_let = 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[num_vunions], *step_o[num_vunions], *body_o[num_vunions], *return_o[num_vunions]; +#if S7_DEBUGGING + for (int32_t i = 0; i < num_vunions; i++) + { + body_o[i] = NULL; + init_o[i] = NULL; + step_o[i] = NULL; + return_o[i] = NULL; + } +#endif + + if (len < 3) return_false(sc, expr); + if (body_len > num_vunions) 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_let, 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 (is_not_slot_end(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 < num_vunions); 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, q_call(init_o[k]).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_let); + 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_let); + 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 k = 0; k < len - 3; k++, p = cdr(p)) /* len (from p_syntax_ok)=form length (do body...) */ + { + 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; *//* why this? */ + 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_let); + 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_let); + return_false(sc, expr); + }} + + /* result */ + if (!is_list(cdr(endp))) + { + unstack_gc_protect(sc); + set_curlet(sc, old_let); + return_false(sc, expr); + } + { + s7_pointer p = cdr(endp); + for (return_exprs = 0; (is_pair(p)) && (return_exprs < num_vunions); 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_let); + return_false(sc, expr); + }} + + do_curlet_unchecked(opc) = T_Let(let); + do_body_length(opc) = len - 3; + do_result_length(opc) = return_exprs; + do_stepper_opt(opc) = sc->opts[step_pc]; + set_curlet(sc, old_let); + + if ((var_len == 0) && (return_exprs == 0)) + { + opt_info *body; + do_no_vars_test(opc) = sc->opts[end_test_pc]; + q_call(opc).fp = opt_do_no_vars; + if (body_len > 0) + { + body = alloc_opt_info(sc); + for (int32_t k = 0; k < body_len; k++) + do_expr(body, k).o1 = body_o[k]; + do_no_vars_body(opc) = body; + } + return_true(sc, expr); + } + do_stepper_safe(opc) = 0; + if (body_len == 1) + { + const s7_pointer expr3 = cadddr(expr); /* 1 expr in body */ + if ((is_pair(expr3)) && + ((is_c_function(car(expr3))) || /* (#_sqrt 2.0)?? */ + (is_safe_setter(car(expr3))) || /* (byte-vector-set! iv 1 0) */ + ((car(expr3) == sc->set_symbol) && /* (set! sum (+ sum 1)) */ + (cadr(expr3) != caar(vars))) || /* caadr: (stepper init ...) */ + ((car(expr3) == sc->vector_set_symbol) && + (is_null(cddddr(expr3))) && + (is_code_constant(sc, cadddr(expr3)))))) + do_stepper_safe(opc) = 1; /* checked in opt_do_1 */ + } + if ((var_len != 1) || (step_len != 1) || (return_exprs != 0)) + { + opt_info *inits; + q_call(opc).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 ((q_call(opc).fp == opt_do_step_1) && + (q_call(do_stepper_opt(opc)).fp == i_to_p) && + (q_temp(do_stepper_opt(opc)).fi == opt_i_ii_sc_add) && + (q_call(do_any_test(opc)).fb == opt_b_ii_ss_eq)) + q_call(opc).fp = opt_do_step_i; + + inits = alloc_opt_info(sc); + for (int32_t k = 0; k < var_len; k++) + do_expr(inits, k).o1 = init_o[k]; + do_any_inits(opc) = inits; + + if (q_call(opc).fp == opt_do_any) + { + opt_info *result, *step; + opt_info *body = alloc_opt_info(sc); + + for (int32_t k = 0; k < body_len; k++) + do_expr(body, k).o1 = body_o[k]; + do_any_body(opc) = body; + + result = alloc_opt_info(sc); + for (int32_t k = 0; k < return_exprs; k++) + do_expr(result, k).o1 = return_o[k]; + do_any_results(opc) = result; + + step = alloc_opt_info(sc); + for (int32_t k = 0; k < var_len; k++) + do_expr(step, 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); + } + + q_call(opc).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++) + do_expr(body, 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); /* undefined_slot? */ + slot_set_value(slot, make_mutable_integer(sc, integer(slot_value(slot)))); + /* do_body_start(opc).i = body_index; */ /* start point (sc->pc) for body, apparently never used */ + if (body_len == 1) /* opt_do_1 */ + { + const opt_info *o1 = sc->opts[body_index]; + q_call(opc).fp = opt_do_very_simple; + if (is_t_integer(caddr(end))) + do_end(opc).i = integer(caddr(end)); + if (q_call(o1).fp == d_to_p_nr) /* snd-test: (do ((k 0 (+ k 1))) ((= k N)) (float-vector-set! rl k (read-sample rd))) */ + { + q_call(opc).fp = opt_do_prepackaged; + do_dpnr_func(opc).fp = opt_do_dpnr; + } + else + if (q_call(o1).fp == i_to_p_nr) + { + q_call(opc).fp = opt_do_prepackaged; + do_dpnr_func(opc).fp = opt_do_ipnr; + }} + else + { + q_call(opc).fp = opt_do_times; + if (is_t_integer(caddr(end))) + do_times_end(opc).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))) + q_call(opc).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 (!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 (!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)) + { + q_temp(opc).fd = q_call(opc).fd; + q_call(opc).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))) + { + q_temp(opc).fi = q_call(opc).fi; + q_call(opc).fp = i_to_p; + if (q_temp(opc).fi == opt_i_ii_ss_add) + q_call(opc).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 */ + q_temp(opc).fd = q_call(opc).fd; + q_call(opc).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))) + { + q_temp(opc).fi = q_call(opc).fi; + q_call(opc).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))) + { + q_temp(opc).fd = q_call(opc).fd; + q_call(opc).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))) + { + q_temp(opc).fd = q_call(opc).fd; + q_call(opc).fp = d_to_p; + return_true(sc, expr); + } + if (i_7piii_ok(sc, opc, s_func, expr)) + { + q_temp(opc).fi = q_call(opc).fi; + q_call(opc).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))) + { + q_temp(opc).fd = q_call(opc).fd; + q_call(opc).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 (!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(sc, 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(sc, 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, form, opt_arg_type(sc, cdr(expr))), form); + 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) + q_func(opc).b_pp_f = bpf; + else q_func(opc).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 (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 (q_temp(wrapper).fp) /* (when (+ i 1) ...) */ + return_false(sc, expr); + q_temp(wrapper).fp = q_call(wrapper).fp; + q_call(wrapper).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(q_call(sc->opts[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 ((!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 (is_not_slot_end(slot2)) slot3 = next_slot(slot2); + + more_vars = (is_not_slot_end(slot3)) && (is_not_slot_end(next_slot(slot3))); + fx_tree(sc, code, + slot_symbol(slot1), + (is_not_slot_end(slot2)) ? slot_symbol(slot2) : NULL, + (is_not_slot_end(slot3)) ? slot_symbol(slot3) : NULL, + more_vars); + + outer_e = let_outlet(sc->curlet); + if ((!more_vars) && + (is_let(outer_e)) && + (!is_funclet(outer_e)) && + (is_not_slot_end(let_slots(outer_e))) && + (slot_symbol(let_slots(outer_e)) != slot_symbol(slot1))) + { + slot1 = let_slots(outer_e); + slot2 = next_slot(slot1); + slot3 = (is_not_slot_end(slot2)) ? next_slot(slot2) : NULL; + fx_tree_outer(sc, code, + slot_symbol(slot1), + (is_not_slot_end(slot2)) ? slot_symbol(slot2) : NULL, + (is_not_slot_end(slot3)) ? slot_symbol(slot3) : NULL, + (is_not_slot_end(slot3)) && (is_not_slot_end(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 (is_not_slot_end(slot2)) slot3 = next_slot(slot2); + fx_tree_in(sc, code, + slot_symbol(slot1), + (is_not_slot_end(slot2)) ? slot_symbol(slot2) : NULL, + (is_not_slot_end(slot3)) ? slot_symbol(slot3) : NULL, + (is_not_slot_end(slot3)) && (is_not_slot_end(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))) && (curlet_has_slots(sc))) 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; + { + s7_pointer result = proper_list_reverse_in_place(sc, sc->z); + sc->z = sc->unused; + return(result); + } +} + +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_let = 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) = q_call(o).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]; + opt_info *o1 = q_when_body(o, 0).o1; + s7_pointer (*fp)(opt_info *o) = q_call(o).fp; + if (fp == opt_unless_p_1) + for (s7_int i = 0; i < len; i++) + { + set_real(sv, vals[i]); + if (!(q_when_test_call(o))) q_call(o1).fp(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, q_call(sc->opts[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) = q_call(o).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) = q_call(o).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) = q_call(o).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) = q_call(o).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) = q_call(o).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_let); + }} + + /* 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)) + { + 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); + }} + { + s7_function func = c_function_call(clo); /* presumably this is either display/write, or method call? */ + s7_pointer iters; + 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 counter = sc->args; + const s7_pointer lst = counter_list(counter); + if (!is_pair(lst)) /* '(1 2 . 3) as arg? -- counter_list can be anything here */ + { + sc->value = sc->unspecified; + return(true); + } + counter_set_list(counter, cdr(lst)); + if (sc->cur_op == OP_FOR_EACH_3) + { + counter_set_result(counter, cdr(counter_result(counter))); + if (counter_result(counter) == counter_list(counter)) + { + 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(counter) != 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(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)); + set_curlet(sc, update_let_with_slot(sc, counter_let(counter), 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_let = 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_let); + } + 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_let = 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_let); + if (result) return(result); + set_no_cell_opt(body); + } + else /* not func */ + { + set_no_cell_opt(body); + set_curlet(sc, old_let); + }} + + 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? + */ + const s7_pointer clo = car(args); + s7_int len = 0; + bool got_nil = false; + + for (s7_pointer 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; + 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))); + }} + + { + s7_pointer val1, old_args, iter_list; + 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, vals = cdr(val1); is_pair(iters); iters = cdr(iters), vals = cdr(vals)) + { + set_car(vals, 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 */ + { + s7_pointer 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)) + { + const 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 counter = sc->args, code = sc->code; + { + const s7_pointer p = counter_list(counter); + if (!is_pair(p)) + { + sc->value = proper_list_reverse_in_place(sc, counter_result(counter)); + return(true); + } + cur_args = car(p); + counter_set_list(counter, 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(counter)) + { + sc->value = proper_list_reverse_in_place(sc, counter_result(counter)); + return(true); + } + push_stack_direct(sc, OP_MAP_GATHER_2); + } + else push_stack_direct(sc, OP_MAP_GATHER_3); + + if (counter_capture(counter) != 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(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)); /* needed -- see comment under for-each above */ + set_curlet(sc, update_let_with_slot(sc, counter_let(counter), 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, 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)); +} + +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 (stack_top_op_unchecked(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: + { + s7_pointer func = 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, func), 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) + { + s7_int old_print_length = sc->print_length; + if (old_print_length > 40) sc->print_length = 40; + 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)); + sc->print_length = old_print_length; + } + 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) /* car_unchecked|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(sc, car(args))) ? copy_tree_with_type(sc, car(args)) : car(args), + (is_unquoted_pair(sc, 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(sc, 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 func = s7_make_safe_function(sc, name, f, required_args, optional_args, rest_arg, NULL); + s7_function_set_class(sc, func, cls); + c_function_set_signature(func, c_function_signature(cls)); + return(func); +} + +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 func = s7_make_function(sc, name, f, required_args, optional_args, rest_arg, NULL); + s7_function_set_class(sc, func, cls); + c_function_set_signature(func, c_function_signature(cls)); + return(func); +} + +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, "s7-min", g_min_2, 2, 0, false); + sc->min_3 = make_function_with_class(sc, func, "s7-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, "s7-max", g_max_2, 2, 0, false); + sc->max_3 = make_function_with_class(sc, func, "s7-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); + + /* 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); + + /* 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", s7i_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_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); +#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); + + /* 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 LEVEN_MIN_LEN 2 +#define LEVEN_MAX_LEN 23 +static int32_t **original_distance; + +static void init_leven(void) +{ + int32_t i, j; + original_distance = (int32_t **)malloc((LEVEN_MAX_LEN + 1) * sizeof(int32_t *)); + for (i = 0; i <= LEVEN_MAX_LEN; i++) original_distance[i] = (int32_t *)calloc(LEVEN_MAX_LEN + 1, sizeof(int32_t)); + for (j = 0; j <= LEVEN_MAX_LEN; j++) original_distance[0][j] = j; + for (i = 0; i <= LEVEN_MAX_LEN; i++) original_distance[i][0] = i; +} + +static int32_t levenshtein(s7_scheme *sc, const char *s1, int32_t len1, const char *s2, int32_t len2) +{ + int32_t i, j; + int32_t mx = (len1 > len2) ? len1 : len2; + if ((mx > LEVEN_MAX_LEN) || (mx < LEVEN_MIN_LEN)) return(100); + for (i = 0; i <= mx; i++) + memcpy((void *)(sc->current_distance[i]), (void *)(original_distance[i]), mx * sizeof(int32_t)); /* TODO: (mx+1?) */ + for (i = 1; i <= len2; i++) + for (j = 1; j <= len1; j++) + { + int32_t c1, c2, c3; + c1 = sc->current_distance[i][j - 1] + 1; + c2 = sc->current_distance[i - 1][j] + 1; + c3 = sc->current_distance[i - 1][j - 1] + ((s2[i - 1] == s1[j - 1]) ? 0 : 1); + if (c1 > c2) c1 = c2; + if (c1 > c3) c1 = c3; + sc->current_distance[i][j] = c1; + } + return(sc->current_distance[len2][len1]); +} + +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); */ + { + 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 */ + const char *sym_name = symbol_name(sym); + s7_pointer min_sym = NULL; + for (s7_pointer let = sc->curlet; let; let = let_outlet(let)) + for (s7_pointer slot = let_slots(let); is_not_slot_end(slot); slot = next_slot(slot)) + { + const s7_pointer cur_sym = slot_symbol(slot); + if (s7_int_abs(sym_len - symbol_name_length(cur_sym)) < 2) + { + int32_t diff = levenshtein(sc, 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; + }}} + /* fprintf(stderr, "min_sym: %s, err_code: %s\n", (min_sym) ? display(min_sym) : "none", display(err_code)); */ + if ((!min_sym) && (err_code) && (is_pair(err_code)) && + (sym == car(err_code)) && (sym_len < 24)) /* 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 */ + #define MAIN_NAMES_SIZE 443 + static const char *main_names[MAIN_NAMES_SIZE] = { + "<=", ">=", "do", "gc", "if", "or", "pi", "abs", "and", "ash", "car", "cdr", "cos", "eq?", "exp", "gcd", + "lcm", "let", "log", "map", "s7-max", "s7-min", "nan", "not", "sin", "sym", "tan", "*s7*", "acos", "asin", + "assq", "assv", "atan", "caar", "cadr", "case", "cdar", "cddr", "cond", "cons", "copy", "cosh", "else", + "eqv?", "eval", "exit", "expt", "help", "let*", "let?", "list", "load", "memq", "memv", "nan?", "odd?", + "read", "set!", "sinh", "sqrt", "tanh", "when", "abort", "acosh", "angle", "apply", "arity", "asinh", + "assoc", "atanh", "bacro", "begin", "byte?", "caaar", "caadr", "cadar", "caddr", "catch", "cdaar", + "cdadr", "cddar", "cdddr", "char?", "error", "even?", "fill!", "floor", "goto?", "index", "inlet", + "list?", "macro", "null?", "owlet", "pair?", "quote", "real?", "s7-round", "sort!", "throw", "unlet", + "write", "zero?", "append", "bacro*", "bignum", "caaaar", "caaadr", "caadar", "caaddr", "cadaar", + "cadadr", "caddar", "cadddr", "cdaaar", "cdaadr", "cdadar", "cdaddr", "cddaar", "cddadr", "cdddar", + "cddddr", "char?", "curlet", "cutlet", "define", "equal?", "exact?", "float?", + "format", "gensym", "getenv", "lambda", "length", "letrec", "logand", "logior", "lognot", "logxor", + "macro*", "macro?", "member", "s7-modulo", "outlet", "random", "setter", "string", "sublet", "symbol", + "system", "unless", "values", "varlet", "vector", "bignum?", "call/cc", "s7-ceiling", "char<=?", + "char>=?", "complex", "define*", "display", "funclet", "gensym?", "iterate", "lambda*", "let-ref", + "letrec*", "logbit?", "newline", "number?", "openlet", "provide", "require", "reverse", "rootlet", + "string?", "symbol?", "syntax?", "type-of", "unquote", "vector?", "boolean?", "complex?", "coverlet", + "defined?", "dilambda", "for-each", "funclet?", "inexact?", "integer?", "keyword?", "let-set!", + "list-ref", "openlet?", "quotient", "reverse!", "set-car!", "set-cdr!", "string?", "s7-truncate", "with-let", "aritable?", "c-object?", "c-pointer", "constant?", "dilambda?", + "hash-code", "imag-part", "infinite?", "iterator?", "let->list", + "list-set!", "list-tail", "magnitude", "make-hook", "make-list", "negative?", "numerator", "peek-char", + "port-file", "positive?", "provided?", "rational?", "read-byte", "read-char", "read-line", "real-part", + "remainder", "sequence?", "signature", "string<=?", "string>=?", "substring", "subvector", + "*function*", "c-pointer?", "directory?", "file-mtime", "hash-table", + "immutable!", "immutable?", "int-vector", "make-polar", "procedure?", "profile-in", "quasiquote", + "stacktrace", "string-ref", "subvector?", "tree-count", "tree-memq?", "undefined?", "vector-ref", "write-byte", + "write-char", "byte-vector", "char-ready?", "char-upcase", "cond-expand", "delete-file", "denominator", + "eof-object?", "equivalent?", "eval-string", "hash-table?", "input-port?", "int-vector?", + "list-values", "macroexpand", "make-string", "make-vector", "nan-payload", "object->let", + "port-string", "rationalize", "read-string", "reader-cond", "string-copy", "string-set!", + "tree-leaves", "vector-rank", "vector-set!", + "with-baffle", "apply-values", "byte-vector?", "c-object-let", "define-bacro", "define-macro", + "dynamic-wind", "file-exists?", "float-vector", "list->string", "list->vector", "output-port?", + "port-closed?", "proper-list?", "random-state", "string->list", + "string-fill!", "symbol-table", "tree-cyclic?", "tree-member?", "unspecified?", "vector->list", "vector-fill!", + "vector-typer", "write-string", "c-object-type", "char->integer", "char-downcase", "char-numeric?", + "char-position", "continuation?", "define-bacro*", "define-macro*", "documentation", "float-vector?", + "integer->char", "make-iterator", "pair-filename", "port-filename", "port-position", "random-state?", + "string-append", "string-length", "symbol->value", "tree-set-memq", "vector-append", + "vector-length", "c-pointer-info", "c-pointer-type", "call-with-exit", "complex-vector", + "dynamic-unwind", "emergency-exit", "exact->inexact", "hash-table-ref", "hook-functions", + "inexact->exact", "int-vector-ref", "integer-length", "number->string", "object->string", + "string->number", "string->symbol", "symbol->string", "byte-vector-ref", "c-pointer->list", + "c-pointer-weak1", "c-pointer-weak2", "complex-vector?", "define-constant", "directory->list", + "int-vector-set!", "keyword->symbol", "let-temporarily", "make-int-vector", "open-input-file", + "string->keyword", "string-position", "symbol->keyword", "weak-hash-table", + "byte-vector-set!", "call-with-values", "char-alphabetic?", "char-upper-case?", "char-whitespace?", + "close-input-port", "cyclic-sequences", "define-expansion", "float-vector-ref", "iterator-at-end?", + "make-byte-vector", "make-rectangular", "open-output-file", "pair-line-number", "port-line-number", + "procedure-source", "subvector-vector", "vector-dimension", "weak-hash-table?", "close-output-port", + "define-expansion*", "float-vector-set!", "flush-output-port", "get-output-string", + "iterator-sequence", "make-float-vector", "open-input-string", "procedure-arglist", + "vector-dimensions", "complex-vector-ref", "current-error-port", "current-input-port", + "hash-table-entries", "open-output-string", "random-state->list", "s7-hash-table-set!", + "s7-make-hash-table", "substring-uncopied", "subvector-position", "byte-vector->string", + "complex-vector-set!", "current-output-port", "make-complex-vector", "multiple-value-bind", + "open-input-function", "string->byte-vector", "with-output-to-file", "call-with-input-file", + "hash-table-key-typer", "integer-decode-float", "make-weak-hash-table", "open-output-function", + "symbol-initial-value", "with-input-from-file", "call-with-output-file", "symbol->dynamic-value", + "with-output-to-string", "call-with-input-string", "hash-table-value-typer", "set-current-error-port", + "set-current-input-port", "with-input-from-string", "call-with-output-string", + "set-current-output-port" + }; + + static const int32_t main_names_index[LEVEN_MAX_LEN] = {0, 7, 27, 62, 103, 156, 184, 206, 243, 265, 296, 321, 344, 361, + 378, 397, 407, 417, 425, 432, 435, 440, 442}; /* 443==NULL, 7858 - 3576 bytes */ + const int32_t start = main_names_index[sym_len - 2], end = main_names_index[sym_len - 1]; +#if 0 + { /* if above list changed, this might help: */ + const char *starts[22] = {"<=", "cos", "acos", "error", "define", "letrec*", "quotient", "substring", + "int-vector", "object->let", "float-vector", "string-append", + "hook-functions", "c-pointer-weak2", "iterator-at-end?", "open-input-string", + "open-output-string", "string->byte-vector", "with-input-from-file", + "with-output-to-string", "set-current-error-port", "set-current-output-port"}; + fprintf(stderr, "starts[22] = {"); + for (int32_t i = 0; i < 22; i++) + for (int32_t j = 0; j < MAIN_NAMES_SIZE; j++) + if (strcmp(main_names[j], starts[i]) == 0) + { + fprintf(stderr, "%d, ", j); + break; + }} + for (int32_t i = 0; i < LEVEN_MAX_LEN; i++) fprintf(stderr, "%s\n", main_names[main_names_index[i]]); +#endif + for (int32_t i = start; i < end; i++) + { + /* main_names has only 430 entries but main_names_index is sized + for 443, so the length-20..23 buckets run into trailing NULL + slots; skip NULLs to avoid dereferencing them in levenshtein. */ + if (main_names[i] == NULL) continue; + int32_t diff = levenshtein(sc, 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 (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)); + }}} + + 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 (let) 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 let = loaded_library(sc, file); + if ((!let) || (!is_let(let))) + { + if (hook_has_functions(sc->autoload_hook)) + s7_apply_function(sc, sc->autoload_hook, set_plist_2(sc, sym, s7_make_string(sc, file))); + let = 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) && (let) && (is_let(let))) + { + /* 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, let, 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 let = 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)); + let = 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)); + let = 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) && (let) && (is_let(let))) /* added 31-Mar-23 to match sc->autoload_names case above */ + { + result = let_ref_p_pp(sc, let, 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); +} + +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 let_or_list) +{ +#if S7_DEBUGGING + s7_function fx; + if (has_fx(arg)) return; + fx = fx_choose(sc, arg, let_or_list, (is_list(let_or_list)) ? 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(let_or_list)); */ +#else + if (has_fx(arg)) return; + set_fx(arg, fx_choose(sc, arg, let_or_list, (is_list(let_or_list)) ? pair_symbol_is_safe : let_symbol_is_safe)); +#endif +} + +static void fx_annotate_args(s7_scheme *sc, s7_pointer args, s7_pointer let_or_list) +{ + for (s7_pointer p = args; is_pair(p); p = cdr(p)) +#if S7_DEBUGGING + fx_annotate_arg(sc, p, let_or_list); /* checks has_fx */ +#else + if (!has_fx(p)) + set_fx(p, fx_choose(sc, p, let_or_list, (is_list(let_or_list)) ? 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 let_or_list) +{ + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, let_or_list: %s\n", + __func__, __LINE__, display_truncated(expr), display(func), hop, display_truncated(let_or_list)); + 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, let_or_list); + 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, let_or_list); + 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 arg1, s7_pointer arg2) /* 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(arg1)) + { + 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(arg1)); + set_opt1_sym(cdr(expr), caddr(arg1)); + return(OP_SAFE_C_opSSq); + case OP_SAFE_C_opSq: + set_opt3_pair(expr, cadr(arg1)); + set_opt3_sym(cdr(expr), cadadr(arg1)); + return(OP_SAFE_C_op_opSqq); + case OP_SAFE_C_S_opSq: + set_opt3_pair(expr, caddr(arg1)); + return(OP_SAFE_C_op_S_opSqq); + case OP_SAFE_C_opSq_S: + set_opt3_pair(expr, cadr(arg1)); + 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(arg2)) + { + 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(arg2)); + 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(arg2)); + return(OP_SAFE_C_S_opCSq); + case OP_SAFE_C_SS: /* (* a (- b c)) */ + set_opt2_sym(cdr(expr), caddr(arg2)); + 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(arg1)) + { + case OP_SAFE_C_S: + set_opt1_sym(cdr(expr), cadr(arg1)); + set_opt3_sym(expr, arg2); + 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(arg1)); + return(OP_SAFE_C_op_opSSqq_S); + } + return(OP_SAFE_C_PS); + + case combine_pc: + switch (op_no_hop(arg1)) + { + case OP_SAFE_C_S: + set_opt1_sym(cdr(expr), cadr(arg1)); + set_opt2_con(cdr(expr), arg2); + 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(arg2)) + { + case OP_SAFE_C_S: + set_opt3_pair(expr, arg2); + return(OP_SAFE_C_C_opSq); + case OP_SAFE_C_SC: + set_opt1_sym(cdr(expr), cadr(arg2)); + set_opt2_con(cdr(expr), caddr(arg2)); + return(OP_SAFE_C_C_opSCq); + case OP_SAFE_C_SS: + set_opt1_sym(cdr(expr), cadr(arg2)); + return(OP_SAFE_C_C_opSSq); + } + return(OP_SAFE_C_CP); + + case combine_pp: + switch (op_no_hop(arg2)) + { + case OP_SAFE_C_S: + if (is_safe_c_s(arg1)) return(OP_SAFE_C_opSq_opSq); + if (optimize_op_match(arg1, OP_SAFE_C_SS)) return(OP_SAFE_C_opSSq_opSq); + break; + case OP_SAFE_C_SS: + if (optimize_op_match(arg1, OP_SAFE_C_SS)) return(OP_SAFE_C_opSSq_opSSq); + if (is_safe_c_s(arg1)) 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 let_or_list) +{ + if (pair_symbol_is_safe(sc, arg1, let_or_list)) return(true); /* includes global_slot check */ + return((!sc->in_with_let) && + (is_bound_symbol(sc, arg1))); +} + +static bool symbol_is_safe(s7_scheme *sc, s7_pointer arg, s7_pointer let_or_list) +{ + 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, let_or_list)); + if (is_slot(global_slot(arg))) return(true); + if ((!symbol_is_in_big_symbol_set(sc, arg)) && + (!arg_findable(sc, arg, let_or_list))) + 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 let_or_list) +{ + fx_annotate_args(sc, cdr(expr), let_or_list); + 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 let_or_list) +{ + 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, let_or_list)); + } + 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)))) + { + const 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 symbols) +{ + if ((symbol_is_in_big_symbol_set(sc, symbol)) && + (direct_memq(symbol, symbols))) /* it's probably a local variable reference */ + return(sc->nil); + /* ((!symbol_is_in_big_symbol_set(sc, symbol)) && (direct_memq(symbol, symbols))) 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); + { + s7_pointer let = sc->curlet; + s7_int id = symbol_id(symbol); + for (; let_id(let) > id; let = let_outlet(let)); + for (; let; let = let_outlet(let)) + { + if (let_id(let) == id) return(local_slot(symbol)); + for (s7_pointer slot = let_slots(let); is_not_slot_end(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 let_or_list) +{ + 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), let_or_list); + 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), let_or_list); + } + choose_c_function(sc, expr, func, 1); +#if 0 + /* works, not much impact? 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), let_or_list); + 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), let_or_list); + 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) + { + const s7_pointer lambda_expr = arg1; + if ((is_ok_lambda(sc, lambda_expr)) && + (!direct_memq(car(lambda_expr), let_or_list))) /* (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) + { + const s7_pointer arg_func = cadr(expr); + set_unsafe_optimize_op(expr, OP_CALL_CC); + /* (call/cc (lambda (return) (do ((i 0 (+ i 1))) ((= i 10)) (if (= i 3) (return 32))))) */ + + /* 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. + */ + 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))); */ + }} + 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 let_or_list, int32_t hop) +{ + const s7_pointer body = closure_body(func); + fx_annotate_arg(sc, body, let_or_list); + /* we can't currently fx_annotate_arg(sc, cdr(expr), let_or_list) 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 let_or_list) +{ + 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, let_or_list); + 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 let_or_list) +{ + 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), let_or_list); + 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, let_or_list); + 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 let_or_list) +{ + 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), let_or_list); + 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, let_or_list); + 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 let_or_list) +{ + 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, let_or_list)); + if ((arit == -1) && (is_symbol(cdr(closure_pars(func))))) + return(optimize_closure_a_sym(sc, expr, func, hop, 1, let_or_list)); + return(opt_bad); + } + { + const s7_pointer arg1 = cadr(expr); + 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 (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, let_or_list, 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), let_or_list); + set_opt3_arglen(cdr(expr), 1); + if (fxify_closure_a(sc, func, one_form, safe_case, hop, expr, let_or_list)) 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), let_or_list); + }} + 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 let_or_list) +{ + s7_pointer arg1 = cadr(expr); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, hop: %d, pairs: %d, symbols: %d, quotes: %d, bad_pairs: %d, let_or_list: %s\n", + __func__, __LINE__, display_truncated(expr), display(func), hop, pairs, symbols, quotes, bad_pairs, display_truncated(let_or_list)); + /* 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, let_or_list)) + return(opt_oops); + if ((bad_pairs == quotes) && + (is_symbol(car(expr))) && + (is_constant_symbol(sc, car(expr)))) + hop = 1; + } + /* need in_with_let -> search only rootlet not lookup */ + if ((symbols == 1) && + ((!symbol_is_safe(sc, arg1, let_or_list)) || (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, let_or_list)); + } + 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, let_or_list)); + + case T_CLOSURE: + return(optimize_closure_one_arg(sc, expr, func, hop, symbols, let_or_list)); + + 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), let_or_list); + 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), let_or_list); + 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), let_or_list); + 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), let_or_list); + 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 symbols) +{ + s7_pointer slot; + if (!is_symbol(sym)) return(false); + slot = find_uncomplicated_symbol(sc, sym, symbols); /* 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 let_or_list, 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, let_or_list, (is_list(let_or_list)) ? 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 let_or_list) +{ + if ((is_symbol(car(expr))) && ((car(expr) == sc->member_symbol) || (car(expr) == sc->assoc_symbol))) return(true); + return(unsafe_is_safe(sc, cadr(expr), let_or_list)); +} + +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 let_or_list, 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, let_or_list, (is_list(let_or_list)) ? 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 let_or_list) +{ + 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, let_or_list: %s\n", + __func__, __LINE__, display_truncated(expr), display(func), hop, pairs, symbols, quotes, bad_pairs, display_truncated(let_or_list)); + if (quotes > 0) + { + if (direct_memq(sc->quote_symbol, let_or_list)) + 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, let_or_list)) || + (!symbol_is_safe(sc, arg2, let_or_list))) + { + /* 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, let_or_list); + return(wrap_bad_args(sc, func, expr, 2, hop, let_or_list)); + } + 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, let_or_list)))) + { + /* 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, let_or_list); + 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, let_or_list)))) + { + 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, let_or_list)); /* AA case */ + set_optimize_op(expr, hop + OP_SAFE_C_AP); + fx_annotate_arg(sc, arg1p, let_or_list); + 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), let_or_list); + 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, let_or_list)))) + { + 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, let_or_list); + 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, let_or_list)))) + { + 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, let_or_list)); + }} + else + if (pairs == 1) + { + set_unsafe_optimize_op(expr, hop + ((is_semisafe(func)) ? OP_CL_AA : OP_C_AA)); + fx_annotate_args(sc, arg1p, let_or_list); + 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, let_or_list); + 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, let_or_list))))) + { + 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, let_or_list)); + 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, let_or_list))))) + { + 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(sc, 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, let_or_list)); + set_optimize_op(expr, hop + OP_SAFE_C_AP); + opt_sp_1(sc, c_function_call(func), expr); + fx_annotate_arg(sc, arg1p, let_or_list); + } + else + if (is_fxable(sc, arg2)) + { + set_optimize_op(expr, hop + OP_SAFE_C_PA); + fx_annotate_arg(sc, cddr(expr), let_or_list); + } + 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(sc, 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, let_or_list)); + } + 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, let_or_list); + 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), let_or_list))) /* 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, let_or_list))) /* 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, let_or_list); + } + 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), let_or_list); + 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, let_or_list, 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, let_or_list)); + if ((arit == -1) && (is_symbol(cdr(closure_pars(func))))) /* (define (f a . b) ...) */ + return(optimize_closure_a_sym(sc, expr, func, hop, 2, let_or_list)); + 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, let_or_list); + 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, let_or_list); */ + 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, let_or_list); + 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, let_or_list); + set_opt1_lambda_add(expr, func); + set_opt3_arglen(arg1p, 2); + return(opt_ok); + } + fx_annotate_args(sc, arg1p, let_or_list); + 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, let_or_list); + 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), let_or_list); + 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), let_or_list); + 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, let_or_list, 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, let_or_list); + 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, let_or_list); + 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, let_or_list); + 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 let_or_list) +{ + 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, let_or_list); + 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 let_or_list) +{ + const s7_pointer arg1p = cdr(expr), arg1 = cadr(expr), arg2 = caddr(expr), arg3 = cadddr(expr); + if ((quotes > 0) && + (direct_memq(sc->quote_symbol, let_or_list))) + return(opt_oops); + if ((!symbol_is_safe(sc, arg1, let_or_list)) || + (!symbol_is_safe(sc, arg2, let_or_list)) || + (!symbol_is_safe(sc, arg3, let_or_list))) + { + /* 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, let_or_list); + 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, let_or_list)))) + { + if (optimize_safe_c_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, let_or_list) == 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, let_or_list, 3, hop + OP_SAFE_C_3P)); + } + /* func is not safe */ + if (fx_count(sc, expr) == 3) + { + set_optimized(expr); + fx_annotate_args(sc, arg1p, let_or_list); + 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(sc, 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(sc, 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(sc, 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), let_or_list); + 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, let_or_list))))) + return(set_any_c_np(sc, func, expr, let_or_list, 3, hop + OP_SAFE_C_3P)); + return(set_any_c_np(sc, func, expr, let_or_list, 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, let_or_list)); + 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, let_or_list); + 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, let_or_list); + 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, let_or_list, 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, let_or_list); + 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, let_or_list); + 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 let_or_list) +{ + 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, let_or_list))) + 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 let_or_list) +{ + const s7_pointer arg1p = cdr(expr); + if (quotes > 0) + { + if (direct_memq(sc->quote_symbol, let_or_list)) + 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, let_or_list)) + 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, let_or_list); + } + 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, let_or_list); + 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(sc, 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, let_or_list, 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, let_or_list); + 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, let_or_list, 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, let_or_list)); + 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, let_or_list); + set_opt3_arglen(arg1p, args); + set_opt1_lambda_add(expr, func); + + if ((symbols == args) && + (symbols_are_safe(sc, arg1p, let_or_list))) + { + 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, let_or_list, 4, hop + OP_ANY_CLOSURE_4P)); + return(set_any_closure_np(sc, func, expr, let_or_list, 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, let_or_list); + 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, let_or_list); + 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)) + { + const 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 let_or_list, bool export_ok); + +static bool vars_opt_ok(s7_scheme *sc, s7_pointer vars, int32_t hop, s7_pointer let_or_list) +{ + 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(sc, 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. vars_opt_ok needs to be smarter! */ + return(false); + } + if ((is_pair(init)) && + (!is_checked(init)) && + (optimize_expression(sc, init, hop, let_or_list, false) == opt_oops)) + return(false); + } + return(true); +} + +static void cleanup_big_symbol_set(s7_scheme *sc, s7_pointer orig_e, s7_pointer var_list) +{ + for (s7_pointer p = var_list; ((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 let_or_list, bool export_ok) +{ + const opcode_t op = syntax_opcode(func); + s7_pointer body = cdr(expr), vars; + const s7_pointer init_let_or_list = let_or_list; + bool body_export_ok = true; + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: expr: %s, func: %s, let_or_list: %s, op: %s, hop: %d, export_ok: %d\n", __func__, __LINE__, + display_truncated(expr), display(func), display(let_or_list), op_names[op], hop, export_ok); + sc->w = let_or_list; + switch (op) + { + case OP_QUOTE: + case OP_MACROEXPAND: + if (is_proper_list_1(sc, body)) + { + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + 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_let_or_list, let_or_list); + 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)) + let_or_list = cons(sc, sc->nil, let_or_list); /* () in let_or_list = 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)) + { + let_or_list = collect_variables(sc, vars, let_or_list); + if (!vars_opt_ok(sc, vars, hop, let_or_list)) + return(opt_oops); + } + else + if (op == OP_LET) + { + if (!vars_opt_ok(sc, vars, hop, let_or_list)) + return(opt_oops); + let_or_list = collect_variables(sc, vars, let_or_list); + } + 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, let_or_list, false) == opt_oops)) + return(opt_oops); + let_or_list = cons(sc, add_symbol_to_big_symbol_set(sc, car(var)), let_or_list); + sc->w = let_or_list; + } + if (is_symbol(cadr(expr))) + { + let_or_list = cons(sc, add_symbol_to_big_symbol_set(sc, cadr(expr)), let_or_list); + sc->w = let_or_list; + } + 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, let_or_list, false) == opt_oops)) + return(opt_oops); + } + /* let_or_list = cons(sc, sc->nil, let_or_list); */ /* !? 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)) + let_or_list = cons(sc, sc->nil, let_or_list); + 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, let_or_list, false) == opt_oops)) /* the init field -- locals are not defined yet */ + return(opt_oops); + } + let_or_list = collect_variables(sc, vars, let_or_list); + 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, let_or_list, 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: + let_or_list = cons(sc, sc->nil, let_or_list); + break; + + case OP_DEFINE_BACRO: case OP_DEFINE_BACRO_STAR: + case OP_BACRO: case OP_BACRO_STAR: + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + 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 (let_or_list), the added name is inserted into let_or_list 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 "let_or_list", but it needs to be marked for find_uncomplicated_symbol in a way + * that can be distinguished from members of "let_or_list". 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(let_or_list)) && (car(let_or_list) != sc->if_keyword)) + set_cdr(let_or_list, cons(sc, car(vars), cdr(let_or_list))); /* export it */ + else let_or_list = cons(sc, car(vars), let_or_list); + } + let_or_list = collect_parameters(sc, cdr(vars), let_or_list); + 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(sc, 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 = let_or_list; + 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, let_or_list, 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(let_or_list)) && (car(let_or_list) != sc->if_keyword)) + set_cdr(let_or_list, cons(sc, vars, cdr(let_or_list))); /* export it */ + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + } + 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)) + let_or_list = cons(sc, sc->nil, let_or_list); + else + if ((!is_pair(vars)) && (!is_symbol(vars))) + return(opt_oops); + let_or_list = collect_parameters(sc, vars, let_or_list); + 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, let_or_list, 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, let_or_list, body_export_ok) == opt_oops)) + return(opt_oops); + + if ((is_pair(cadr(expr))) && (caadr(expr) == sc->starlet_symbol)) + { + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_ok); + } + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + 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 = let_or_list; + 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_let_or_list, let_or_list); + 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, let_or_list, 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, let_or_list, false) == opt_oops)) + return(opt_oops); + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + 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); + let_or_list = cons(sc, sc->if_keyword, let_or_list); /* 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, let_or_list, 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, let_or_list, 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_let_or_list, let_or_list); 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), let_or_list, pair_symbol_is_safe)); + for (s7_pointer q = cdar(p); is_pair(q); q = cdr(q)) + set_fx_direct(q, fx_choose(sc, q, let_or_list, pair_symbol_is_safe)); + } + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + 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: + let_or_list = cons(sc, sc->if_keyword, let_or_list); + break; + + default: break; + } + + sc->temp7 = let_or_list; + 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, let_or_list, 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); + const s7_pointer b1 = cdr(test); + const s7_pointer b2 = cdr(b1); + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + { + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + 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, let_or_list, pair_symbol_is_safe)); + + 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_let_or_list, let_or_list); + 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), let_or_list, 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_let_or_list, let_or_list); + 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_let_or_list, let_or_list); + 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_let_or_list, let_or_list); + return(opt_ok); + } + else + { + if ((op == OP_OR) || (op == OP_AND)) + { + int32_t args = 0, pairs = 0; + bool c_s_is_ok = true; + { + s7_pointer p; + for (p = cdr(expr); is_pair(p); p = cdr(p)) + if (!is_fxable(sc, car(p))) + { + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + return(opt_bad); + } + if (!is_null(p)) return(opt_oops); + } + for (s7_pointer p1 = cdr(expr), sym = NULL; 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_let_or_list, let_or_list); + return(opt_ok); + } + + for (s7_pointer p1 = cdr(expr); is_pair(p1); p1 = cdr(p1)) + set_fx_direct(p1, fx_choose(sc, p1, let_or_list, 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_let_or_list, let_or_list); + 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_let_or_list, let_or_list); + return(opt_ok); + } + else + if (op == OP_BEGIN) + { + s7_pointer p; + if (!is_pair(cdr(expr))) {cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); 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_let_or_list, let_or_list); + 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, let_or_list, 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_let_or_list, let_or_list); + return(opt_ok); + }}} /* fully fxable lets don't happen much: even let-2a-a is scarcely used */ + cleanup_big_symbol_set(sc, init_let_or_list, let_or_list); + 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 let_or_list) +{ + 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, let_or_list, 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, let_or_list)); + case 1: return(optimize_func_one_arg(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, let_or_list)); + case 2: return(optimize_func_two_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, let_or_list)); + case 3: return(optimize_func_three_args(sc, expr, func, hop, pairs, symbols, quotes, bad_pairs, let_or_list)); + default: return(optimize_func_many_args(sc, expr, func, hop, args, pairs, symbols, quotes, bad_pairs, let_or_list)); + }} + 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 let_or_list, 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, let_or_list: %s, hop: %d\n", __func__, __LINE__, display_truncated(expr), display(let_or_list), 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, let_or_list, export_ok)); + } + slot = find_uncomplicated_symbol(sc, head, let_or_list); /* 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, let_or_list, 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, let_or_list)); + }} + else + if ((sc->undefined_identifier_warnings) && + (slot == sc->undefined) && /* head is not in let_or_list 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, let_or_list, 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(sc, 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, let_or_list); /* 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(sc, head)) && + (direct_memq(sc->quote_symbol, let_or_list))) + return(opt_oops); + if (is_fxable(sc, arg1)) + { + set_opt3_arglen(args, 1); + fx_annotate_arg(sc, args, let_or_list); + 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, let_or_list); + 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, let_or_list, export_ok)); + + if (is_c_function(head)) /* (#_abs x) etc */ + return(optimize_funcs(sc, expr, head, /* (direct_memq(c_function_symbol(head), let_or_list)) ? 0 : */ 1, orig_hop, let_or_list)); + + if (is_syntax(head)) /* (#_cond...) etc */ + { + if (!is_pair(args)) + return(opt_oops); + return(optimize_syntax(sc, expr, head, orig_hop, let_or_list, 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, let_or_list, 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 let_or_list) +{ + s7_pointer expr; + if (SHOW_EVAL_OPS) fprintf(stderr, " %s[%d]: %s, let_or_list: %s, hop: %d\n", __func__, __LINE__, display_truncated(code), display(let_or_list), 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, let_or_list, 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* */ +{ + const s7_pointer top = args; + s7_pointer pars = args; + bool has_defaults = false; + + 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); + } + + begin_small_symbol_set(sc); + for (s7_pointer last_pars = args; is_pair(pars); last_pars = 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(last_pars, sc->nil); /* last_pars is '( :allow-other-keys) so this chops off the trailing keyword */ + } + 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 slow_vars = 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 (slow_vars != vars) + { + if (follow) {slow_vars = cdr(slow_vars); if (vars == slow_vars) 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 slow_form = 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) {slow_form = cdr(slow_form); if (p == slow_form) 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 slow_form = form, p = cdr(form); + for (; is_pair(p); p = cdr(p)) + { + if (is_unquoted_pair(sc, 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) {slow_form = cdr(slow_form); if (p == slow_form) return(unsafe_body);} + follow = (!follow); + } + return((is_null(p)) ? result : unsafe_body); + } + if ((is_safe_quote(sc, 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 slow_body = 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) {slow_body = cdr(slow_body); if (forms == slow_body) 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; + /* following 9 lines are copied from check_recur_if 77378 (len=body length) -- combine? */ + 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 var = letv; is_pair(var); var = cdr(var)) + if (!is_fxable(sc, cadar(var))) + 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 var = letv; is_pair(var); var = cdr(var)) + fx_annotate_arg(sc, cdar(var), 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 -- need 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 ((S7_DEBUGGING) && (s7_list_length(sc, body) == 0)) {fprintf(stderr, "body: %s\n", display(body)); abort();} + 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(sc, 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 let) */ + 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))) && (curlet_has_slots(sc))) 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))) && (curlet_has_slots(sc))) 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, ((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))) && (curlet_has_slots(sc))) fx_curlet_tree_in(sc, code); + } + else pair_set_syntax_op(form, ((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))) && (curlet_has_slots(sc))) 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) || ((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))) && (curlet_has_slots(sc))) 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); + } +} + +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)))); +} + +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 + { + { + 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 "let" = 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, sc->args); + sc->args = sc->nil; + } + return(code); +} + +static s7_pointer check_let(s7_scheme *sc) /* called only from op_let */ +{ + s7_pointer start; + const s7_pointer code = cdr(sc->code), form = sc->code; + bool named_let; + + if (!is_pair(code)) /* (let . 1) */ + { + if (is_null(code)) /* (let) */ + syntax_error_nr(sc, "let has no variables or body: ~A", 32, form); + syntax_error_nr(sc, "let 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); + { + s7_pointer vars; + int32_t num_vars; + 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(sc, 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 */ + (curlet_has_slots(sc))) + { + s7_pointer slot1 = let_slots(sc->curlet), slot2 = next_slot(slot1), slot3 = NULL; + bool more_vars = false; + if (is_not_slot_end(slot2)) + { + if (is_not_slot_end(next_slot(slot2))) + { + slot3 = next_slot(slot2); + more_vars = is_not_slot_end(next_slot(slot3)); + slot3 = slot_symbol(slot3); + } + slot2 = slot_symbol(slot2); + } + slot1 = slot_symbol(slot1); + for (s7_pointer p = car(code); is_pair(p); p = cdr(p)) /* var list */ + { + s7_pointer init = cdar(p); + fx_tree(sc, init, slot1, slot2, slot3, 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), car_unchecked(args)); + vars = cdr(vars); args = cdr(args); + if (is_null(args)) break; + add_slot_checked_with_id(sc, sc->curlet, car(vars), car_unchecked(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), car_unchecked(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), car_unchecked(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) {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; + 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), last_slot = NULL; is_pair(p); p = cdr(p)) + { + const s7_pointer arg = cdar(p); + sc->value = fx_call(sc, arg); + if (!last_slot) + { + add_slot(sc, let, caar(p), sc->value); + last_slot = let_slots(let); + } + else last_slot = add_slot_at_end(sc, let_id(let), last_slot, 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)); + const s7_int id = ++sc->let_number; + sc->args = let; /* GC protection */ + let_set_id(let, id); + let_set_outlet(let, sc->curlet); + for (s7_pointer p = cadr(sc->code), slot = let_slots(let); is_pair(p); p = cdr(p), slot = next_slot(slot)) + { + 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) */ + check_stack_size(sc); /* added 15-Jul-25 for srfi-1 filter of huge list */ + 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) ... */ + { + /* does (let* loop ((i 0) :allow-other-keys) i) make sense? + * + * (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 last_slot = NULL; + while (true) + { + if (let_counter == sc->capture_let_counter) + { + if (last_slot == NULL) + { + add_slot_checked(sc, sc->curlet, caar(sc->code), sc->value); + last_slot = let_slots(sc->curlet); + } + else last_slot = add_slot_checked_at_end(sc, let_id(sc->curlet), last_slot, caar(sc->code), sc->value); /* was unchecked */ + } + else + { + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, caar(sc->code), sc->value)); + last_slot = let_slots(sc->curlet); + let_counter = sc->capture_let_counter; + } + 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_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_uint let_counter = S7_INT64_MAX; + sc->code = cdr(sc->code); + for (s7_pointer last_slot = NULL, 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 (!last_slot) + { + add_slot_checked(sc, sc->curlet, car(binding), val); + last_slot = let_slots(sc->curlet); + } + else last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(binding), val); + } + else + { + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(binding), val)); + last_slot = 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_uint let_counter = S7_INT64_MAX; + sc->code = cdr(sc->code); + for (s7_pointer last_slot = NULL, 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 (!last_slot) + { + add_slot_checked(sc, sc->curlet, car(binding), val); + last_slot = let_slots(sc->curlet); + } + else last_slot = add_slot_at_end(sc, let_id(sc->curlet), last_slot, car(binding), val); + } + else + { + set_curlet(sc, inline_make_let_with_slot(sc, sc->curlet, car(binding), val)); + last_slot = 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) */ + 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); is_not_slot_end(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); is_not_slot_end(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) +{ + const 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); is_not_slot_end(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) + slot_set_pending_value(slot, fx_call(sc, slot_expression(slot))); + if (is_not_slot_end(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); is_not_slot_end(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) + slot_set_pending_value(slot, fx_call(sc, slot_expression(slot))); + if (is_not_slot_end(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); is_not_slot_end(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + if (is_not_slot_end(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); is_not_slot_end(slot) && (has_fx(slot_expression(slot))); slot = next_slot(slot)) + slot_set_value(slot, fx_call(sc, slot_expression(slot))); + if (is_not_slot_end(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(sc, 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(sc, 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)) && (curlet_has_slots(sc))) + { + 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); +} + +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); + /* fprintf(stderr, "args: %s\n", display(sc->args)); */ + sc->value = caar(p); + set_car(p, cdar(p)); + set_car(sc->args, cdar(sc->args)); + /* fprintf(stderr, " args: %s\n", display(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(sc, 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); + /* fprintf(stderr, "sym: %s, val: %s, args: %s\n", display(sym), display(sc->value), display(sc->args)); */ + } + 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)); +} + +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); +} + +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); +} + +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, 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); + { + s7_pointer 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; + const s7_pointer let = 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, let); + 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)) && (curlet_has_slots(sc))) 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)) && (curlet_has_slots(sc))) 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)) && (curlet_has_slots(sc))) 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)) && (curlet_has_slots(sc))) 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)) && (curlet_has_slots(sc))) 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)) && (curlet_has_slots(sc))) + 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(sc, 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)) && (curlet_has_slots(sc))) 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)) && (curlet_has_slots(sc))) 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)) && (curlet_has_slots(sc))) 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(car_unchecked(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(sc, 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(sc, 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 or a non-nil list", 65, 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(sc, 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 or a non-nil list)", 62, 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(sc, 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_unchecked(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 (is_not_slot_end(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) +{ + const s7_pointer code = cdr(sc->code); + const s7_pointer func_name = caar(code); + s7_pointer new_func; + + 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); is_not_slot_end(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(sc, 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)? */ + } + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + 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 let = lookup_checked(sc, car(code)); + const s7_pointer sym = cadr(code); + s7_pointer val; + if (!is_let(let)) + { + let = find_let(sc, let); + 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->with_let_symbol, let, new_let, 1, set_mlist_1(sc, let)); + let = new_let; + }} + /* let 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 (env 'value) sym) -> (env 'value) is a hash-table, so returns #f (missing-key-value?) if not in table + * we go directly to this function in check_with_let to avoid this ambiguity + */ + val = let_ref(sc, let, sym); /* (with-let env s) -> (let-ref env 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, let))) /* 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_let = 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_let, 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_let, car(field), cdr(field)); + } + set_curlet(sc, new_let); + set_immutable_let(new_let); + unstack_gc_protect(sc); +} + +static void activate_with_let(s7_scheme *sc, s7_pointer let) +{ + if (!is_let(let)) /* (with-let . "hi") */ + { + const s7_pointer new_let = find_let(sc, let); /* sc->nil/rootlet here means no let found */ + if (!is_let(new_let)) + 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), let)); + let = new_let; + } + if (let == sc->rootlet) + set_curlet(sc, let); /* (with-let (rootlet) ...) */ + else + if (let == sc->starlet) + activate_starlet(sc); + else + { + set_with_let_let(let); + let_set_id(let, ++sc->let_number); + set_curlet(sc, let); + update_symbol_ids(sc, let); + } +} + + +/* -------------------------------- 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)) && (curlet_has_slots(sc))) 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); + }} + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + 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 (s7_pointer p1 = T_Lst(cdar(p)); is_pair(p1); p1 = cdr(p1)) + if (has_fx(T_Pair(p1))) + sc->value = fx_call(sc, p1); + else + { + if (is_pair(cdr(p1))) + push_stack_no_args(sc, OP_COND_NA_NP_1, cdr(p1)); + sc->code = car(p1); + 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 args = cdr(sc->code); is_pair(args); args = cdr(args)) + if (is_true(sc, fx_call(sc, car(args)))) + { + s7_pointer p1 = cdar(args); + if (has_fx(T_Pair(p1))) + { + sc->value = fx_call(sc, p1); + return(true); + } + sc->code = car(p1); + return(false); + } + sc->value = sc->unspecified; + return(true); +} + +static inline bool fx_cond_value(s7_scheme *sc, s7_pointer args) +{ + if (has_fx(args)) + { + sc->value = fx_call(sc, args); + return(true); + } + sc->code = car(args); + return(false); +} + +static bool op_cond_na_2e(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + return(fx_cond_value(sc, (is_true(sc, fx_call(sc, car(args)))) ? cdar(args) : cdadr(args))); +} + +static bool op_cond_na_3e(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + if (is_true(sc, fx_call(sc, car(args)))) + return(fx_cond_value(sc, cdar(args))); + args = cdr(args); + return(fx_cond_value(sc, (is_true(sc, fx_call(sc, car(args)))) ? cdar(args) : cdadr(args))); +} + +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(sc, 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(sc, 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(sc, 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(sc, 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(sc, obj, arg, value)); + break; + + case T_FLOAT_VECTOR: + sc->value = g_fv_set_3(sc, with_list_t3(sc, 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(sc, obj, arg, value)); + break; + case T_BYTE_VECTOR: + sc->value = g_bv_set_3(sc, with_list_t3(sc, obj, arg, value)); + break; + case T_VECTOR: + if (vector_rank(obj) > 1) + sc->value = g_vector_set(sc, with_list_t3(sc, obj, arg, value)); + else + { + s7_int index; + if (!is_t_integer(arg)) + error_nr(sc, sc->type_error_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); + } + break; + + case T_STRING: + { + 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; + } + break; + + case T_PAIR: + sc->value = g_list_set(sc, with_list_t3(sc, 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(sc, 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 (if false, continue) */ + }} + 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(sc, 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(sc, 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(sc, obj, index1)); + return(set_pair3(sc, sc->value, index2, value)); + } + break; + + case T_PAIR: + sc->value = g_list_ref(sc, with_list_t2(sc, 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)); + 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); + { + bool 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 arg1, settee; + const s7_pointer val = sc->value; + /* from the T_SYNTAX branch of op_set_pair: (set! (with-let arg1 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 'arg1 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)); + + arg1 = 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), arg1, settee, val)); + if (is_symbol(arg1)) + { + if (is_symbol(settee)) + { + s7_pointer let = lookup_checked(sc, arg1); + if (!is_let(let)) + wrong_type_error_nr(sc, sc->let_set_symbol, 1, let, a_let_string); + sc->value = let_set_1(sc, let, settee, val); + pop_stack(sc); + return(true); + } + sc->value = lookup_checked(sc, arg1); + 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 = arg1; /* 'arg1 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, 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 = s7i_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(s7i_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 = s7i_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->type_error_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(sc, 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->type_error_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_no_code(sc, OP_EVAL_ARGS1, list_1(sc, c_obj)); + 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(sc, 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 str = lookup_checked(sc, car(sc->code)); + const s7_pointer val = fx_call(sc, cdr(sc->code)); + if (!is_string(str)) + { + sc->last_function = str; + return(false); + } + if (!s7_is_integer(val)) + { + sc->value = string_ref_1(sc, str, set_plist_1(sc, val)); + return(true); + } + index = s7_integer_clamped_if_gmp(sc, val); + if ((index < string_length(str)) && (index >= 0)) + { + sc->value = chars[((uint8_t *)string_value(str))[index]]; + return(true); + } + sc->value = string_ref_1(sc, str, 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(sc, 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(sc, 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(sc, 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_no_code(sc, OP_EVAL_ARGS1, 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)) + { + 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)) + do_return_false(expr); + if (is_pair(cddar(step))) + return(all_ints_here(sc, caar(step), caddar(step), step_vars)); + return(true); + } + { + s7_pointer 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)) + 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)) + 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(sc, 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 var) +{ + if ((is_proper_list_3(sc, var)) && + (is_fxable(sc, cadr(var)))) + { + const s7_pointer step_expr = caddr(var); + if ((is_optimized(step_expr)) && + (((optimize_op(step_expr) == HOP_SAFE_C_SC) && (car(var) == cadr(step_expr))) || + ((is_h_safe_c_nc(step_expr)) && /* replace with is_fxable? */ + (is_pair(cdr(step_expr))) && /* ((v 0 (+))) */ + (car(var) == 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(var) == 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); + const s7_pointer pre_var_list = cons(sc, sc->nil, sc->nil); + gc_protect_via_stack(sc, pre_var_list); + + /* clear_big_symbol_set(sc); */ /* an experiment -- slightly slower than pre_var_list? */ + for (s7_pointer p = vars, var_list = NULL; 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 (!var_list) + { + begin_temp(sc->y, sc->nil); + for (var_list = vars; is_pair(var_list); var_list = cdr(var_list)) sc->y = cons(sc, caar(var_list), sc->y); + var_list = 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_var_list, var_list); /* 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_var_list, caar(p)); /* caar(p) == current var, highly likely it's in the step expr */ + optimize_expression(sc, car(expr), 0, pre_var_list, 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)); + } + if (DO_PRINT) fprintf(stderr, " op: %s\n", op_names[optimize_op(sc->code)]); + return(code); +} + +static bool do_vector_has_definer(s7_pointer vec) +{ + s7_pointer *els = vector_elements(vec); + for (s7_int i = 0, len = vector_length(vec); 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); +} + +#if CYCLE_DEBUGGING + static char *base = NULL, *min_char = NULL; +#endif + +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? + */ +#if CYCLE_DEBUGGING + char x; + if (!base) base = &x; + else + { + if (&x > base) base = &x; + else + { + if ((!min_char) || (&x < min_char)) + { + min_char = &x; + if ((base - min_char) > 10000) + { + fprintf(stderr, "infinite recursion? %s\n", display(tree)); + abort(); + }}}} +#endif + 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); + } + 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)); + if (DO_PRINT) fprintf(stderr, " %s[%d]: bad stepper %s\n", __func__, __LINE__, display(code)); + 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)); + if (DO_PRINT) fprintf(stderr, " %s[%d]: infinite loop %s\n", __func__, __LINE__, 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))))) + { + if (DO_PRINT) fprintf(stderr, " %s[%d]: bad stepper %s\n", __func__, __LINE__, display(code)); + return(code); + }} + pair_set_syntax_op(form, OP_DO_NO_BODY_NA_VARS); + if (DO_PRINT) fprintf(stderr, " %s[%d]: ok %s %s\n", __func__, __LINE__, display(form), op_names[optimize_op(form)]); + 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)))) + { + if (DO_PRINT) fprintf(stderr, "%s[%d]: return do_end_bad for %s\n", __func__, __LINE__, display(form)); + 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 (curlet_has_slots(sc)) /* outer vars */ + { + s7_pointer slot = let_slots(sc->curlet); + v1 = slot_symbol(slot); + slot = next_slot(slot); + if (is_not_slot_end(slot)) + { + v2 = slot_symbol(slot); + slot = next_slot(slot); + if (is_not_slot_end(slot)) + { + v3 = slot_symbol(slot); + more_vs = is_not_slot_end(next_slot(slot)); + }}} + if (v1) fx_tree_outer(sc, end, v1, v2, v3, more_vs); + }} + if (DO_PRINT) fprintf(stderr, "%s[%d]: optimizable %s\n", __func__, __LINE__, display(form)); + return(sc->nil); + } + + if ((sc->safety > no_safety) && (tree_is_cyclic(sc, form))) + { + if (DO_PRINT) fprintf(stderr, "%s[%d]: bad: cyclic for %s\n", __func__, __LINE__, display(form)); + return(form); + } + if (do_tree_has_definer(sc, form)) /* we don't want definers in body, vars, or end test */ + { + if (DO_PRINT) fprintf(stderr, "%s[%d]: return fxify_step_exprs for %s\n", __func__, __LINE__, display(form)); + 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 var = car(vars); + s7_pointer step_expr; + + fx_tree(sc, end, car(var), NULL, NULL, false); + if (is_fx_treeable(body)) /* this is thwarted by gotos */ + fx_tree(sc, body, car(var), NULL, NULL, false); + + step_expr = simple_stepper(sc, var); + if (step_expr) + { + const s7_pointer orig_end = end; + set_fx(cdr(var), fx_choose(sc, cdr(var), 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(var) == 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(var) == cadr(step_expr)) and (car(var) == 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(var), 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(var), 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); + }} + if (DO_PRINT) fprintf(stderr, "%s[%d]: optimizable %s\n", __func__, __LINE__, display(form)); + 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)); + if (DO_PRINT) fprintf(stderr, "%s[%d]: return fxify_step_exprs for %s\n", __func__, __LINE__, display(form)); + 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 + { + if (DO_PRINT) fprintf(stderr, "%s[%d]: return fxify_step_exprs for %s\n", __func__, __LINE__, display(form)); + 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); is_not_slot_end(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(sc, 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 (curlet_has_slots(sc)) /* outer vars */ + { + s7_pointer slot = let_slots(sc->curlet); + var1 = slot_symbol(slot); + slot = next_slot(slot); + if (is_not_slot_end(slot)) + { + var2 = slot_symbol(slot); + slot = next_slot(slot); + if (is_not_slot_end(slot)) + { + var3 = slot_symbol(slot); + more_vars = is_not_slot_end(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 var_list; + 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); + var_list = sc->y; + end_temp(sc->y); + fx_annotate_arg(sc, body, var_list); + 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); + }}} + if (DO_PRINT) fprintf(stderr, "%s[%d]: optimizable %s %s %s\n", __func__, __LINE__, display(form), op_names[optimize_op(form)], op_names[optimize_op(sc->code)]); + return(sc->nil); +} + +static bool has_safe_steppers(s7_scheme *sc, s7_pointer let) +{ + for (s7_pointer slot = let_slots(let); is_not_slot_end(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 func = fx_proc(slot_expression(stepper)); /* e.g. fx_add_s1 */ + s7_pointer args = car(slot_expression(stepper)); + if ((func == fx_c_nc) || (func == fx_c_0c)) + { + func = fn_proc(args); + args = cdr(args); + } + if (((func == fx_cdr_s) || (func == fx_cdr_t)) && + (cadr(args) == 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 (((func == fx_add_t1) || (func == 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) = q_call(o).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, func(sc, args));} while ((sc->value = endf(sc, endp)) == sc->F); + sc->code = cdr(end); + return(goto_do_end_clauses); + } + if ((steppers == 2) && + (!is_not_slot_end(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 (is_not_slot_end(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; + const s7_pointer let = inline_make_let(sc, sc->curlet); /* new let is not tied into the symbol lookup process yet */ + if (SHOW_EVAL_OPS) fprintf(stderr, "%s[%d]: %s\n", __func__, __LINE__, display(form)); + 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) */ + new_cell_unchecked(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; is_not_slot_end(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? from eval call of op_dox 96130 possibly from check_do */ + { + if (DO_PRINT) fprintf(stderr, "dox %d, no body\n", __LINE__); + 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)) && + (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) = q_call(o).fp; + if (!((fp == opt_p_pip_sso) && (q_arg2(o).p == q_arg4(o).p) && + (((q_func(o).p_pip_f == string_set_p_pip_unchecked) && (q_func3(o).p_pi_f == string_ref_p_pi_unchecked)) || + ((q_func(o).p_pip_f == string_set_p_pip_direct) && (q_func3(o).p_pi_f == string_ref_p_pi_direct)) || + ((q_func(o).p_pip_f == vector_set_p_pip_unchecked) && (q_func3(o).p_pi_f == t_vector_ref_p_pi_unchecked)) || + ((q_func(o).p_pip_f == t_vector_set_p_pip_direct) && (q_func3(o).p_pi_f == t_vector_ref_p_pi_direct)) || + ((q_func(o).p_pip_f == list_set_p_pip_unchecked) && (q_func3(o).p_pi_f == list_ref_p_pi_unchecked))) && + (copy_if_end_ok(sc, slot_value(q_arg1(o).p), slot_value(q_arg3(o).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) && (q_call(o).fd == opt_d_7pid_ss_ss) && + (q_arg2(o).p == q_arg4(o).p) && + ((q_func(o).d_7pid_f == float_vector_set_d_7pid) || (q_func(o).d_7pid_f == float_vector_set_d_7pid_direct)) && + ((q_func1(o).d_7pi_f == float_vector_ref_d_7pi) || (q_func1(o).d_7pi_f == float_vector_ref_d_7pi_direct)) && + (copy_if_end_ok(sc, slot_value(q_arg1(o).p), slot_value(q_arg3(o).p), i, endp, stepper))) || + + ((bodyf == opt_int_any_nv) && ((q_call(o).fi == opt_i_7pii_ssf) || (q_call(o).fi == opt_i_7pii_ssf_vset)) && + (q_arg2(o).p == q_func1_arg(o).q_arg2(o1).p) && + (((q_func(o).i_7pii_f == int_vector_set_i_7pii) && (q_func1_arg(o).q_func(o1).i_7pi_f == int_vector_ref_i_7pi)) || + ((q_func(o).i_7pii_f == int_vector_set_i_7pii_direct) && (q_func1_arg(o).q_func(o1).i_7pi_f == int_vector_ref_i_pi_direct))) && + (copy_if_end_ok(sc, slot_value(q_arg1(o).p), slot_value(q_func1_arg(o).q_arg1(o1).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) && + (!is_not_slot_end(next_slot(next_slot(slots))))) + { + const s7_pointer slot1 = slots, slot2 = next_slot(slots); + const s7_function f1 = fx_proc(slot_expression(slot1)); + const s7_function f2 = fx_proc(slot_expression(slot2)); + const s7_pointer p1 = car(slot_expression(slot1)); + const s7_pointer p2 = car(slot_expression(slot2)); + /* 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) = q_call(o).fp; + s7_pointer slot3 = NULL; + /* thash case -- this is dumb */ + if ((f2 == fx_add_u1) && (is_t_integer(slot_value(slot2))) && (cadr(endp) == slot_symbol(slot2)) && (!s7_tree_memq(sc, cadr(endp), body)) && + (((endf == fx_num_eq_ui) && (is_t_integer(caddr(endp)))) || + ((endf == fx_num_eq_us) && (slot3 = 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(slot2)); + s7_int endi = (is_t_integer(caddr(endp))) ? integer(caddr(endp)) : integer(slot_value(slot3)); + do { + fp(o); + slot_set_value(slot1, f1(sc, p1)); + i++; + } while (i < endi); + slot_set_value(slot2, 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(slot1, f1(sc, p1)); + slot_set_value(slot2, 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(slot1, f1(sc, p1)); + slot_set_value(slot2, 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) = q_call(o).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 (is_not_slot_end(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 (is_not_slot_end(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)) && + (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++) + q_call(body[i]).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 (is_not_slot_end(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 (is_not_slot_end(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) + { + const s7_pointer t1 = cadr(test); + const s7_pointer t2 = caddr(test); + const s7_function f1 = fx_proc(cdr(test)); + const 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) + { + const s7_pointer f1_arg = cadr(test), p = opt3_pair(test); /* cdadr(p) */ + const s7_function f1 = fx_proc(cdr(test)); + const s7_pointer f2_arg = car(p); + const s7_pointer f3_arg = cadr(p); + const s7_function f2 = fx_proc(p); + const s7_function f3 = fx_proc(cdr(p)); + if (((stepf == fx_add_t1) || (stepf == fx_add_u1)) && (is_t_integer(slot_value(slot)))) + { + const 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) && + (!is_not_slot_end(next_slot(next_slot(slots)))) && + (is_pair(cdr(test)))) + { + const s7_pointer slot1 = slots; + const s7_pointer expr1 = slot_expression(slot1); + const s7_pointer slot2 = next_slot(slot1); + const 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 (is_not_slot_end(slot)); + slot = slots; + do { + if (slot_has_expression(slot)) + slot_set_value(slot, slot_pending_value(slot)); + slot = next_slot(slot); + } while (is_not_slot_end(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) q_call(body[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) = q_call(o0).fp; + s7_pointer (*fp1)(opt_info *o) = q_call(o1).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++) + q_call(body[k]).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); is_not_slot_end(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) = q_call(o).fp; /* o-[6].p_pi_f (q_func3) is getter, o-v[5].p_pip_f (q_func) is setter */ + if (start >= stop) return(true); + if ((fp == opt_p_pip_sso) && + (type(slot_value(q_arg1(o).p)) == type(slot_value(q_arg3(o).p))) && + (q_arg2(o).p == q_arg4(o).p)) + { + s7_pointer caller = NULL; + const s7_pointer dest = slot_value(q_arg1(o).p); + const s7_pointer source = slot_value(q_arg3(o).p); + if ((is_t_vector(dest)) && + (((q_func(o).p_pip_f == vector_set_p_pip_unchecked) || (q_func(o).p_pip_f == t_vector_set_p_pip_direct)) && + ((q_func3(o).p_pi_f == t_vector_ref_p_pi_unchecked) || (q_func3(o).p_pi_f == vector_ref_p_pi_unchecked) || + (q_func3(o).p_pi_f == t_vector_ref_p_pi_direct)))) + caller = sc->vector_set_symbol; + else + if ((is_string(dest)) && + (((q_func(o).p_pip_f == string_set_p_pip_unchecked) || (q_func(o).p_pip_f == string_set_p_pip_direct)) && + ((q_func3(o).p_pi_f == string_ref_p_pi_unchecked) || (q_func3(o).p_pi_f == string_ref_p_pi_direct)))) + caller = sc->string_set_symbol; + else + if ((is_pair(dest)) && + ((q_func(o).p_pip_f == list_set_p_pip_unchecked) && (q_func3(o).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) = q_call(o).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 = q_func(o).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(q_arg1(o).p), slot_value(q_arg2(o).p), slot_value(q_arg3(o).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 = q_func(o).p_ppp_f; + for (s7_int i = start; i < stop; i++) + { + slot_set_value(ctr_slot, make_integer(sc, i)); + fpt(sc, slot_value(q_arg1(o).p), q_p_func1_call(o), slot_value(q_arg2(o).p)); + }} + else + if ((fp == opt_p_pip_sss_vset) && (start >= 0) && (stop <= vector_length(slot_value(q_arg1(o).p)))) + { /* (do ((i 0 (+ i 1))) ((= i 10) v) (vector-set! v i i)) */ + s7_pointer *vels = vector_elements(slot_value(q_arg1(o).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(q_arg2(o).p))] = slot_value(q_arg3(o).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) = q_call(o).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) = q_call(o).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) = q_call(o).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) = q_func1_arg(o).q_temp(o1).fp; /* see opt_cond_1b test expr */ + opt_info *test_o1 = q_func1_arg(o).o1; + opt_info *o2 = q_cond_val1(o).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(sc, 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) = q_call(o).fd; + if ((fd == opt_d_id_sf) && /* by far the most common case in clm: (outa i ...) etc */ + (is_slot(q_arg1(o).p)) && + (stepper == slot_value(q_arg1(o).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 = q_func(o).d_id_f; + fd = q_call(o1).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 ((q_call(o).fd == opt_d_7pid_ss_ss) && (q_func(o).d_7pid_f == float_vector_set_d_7pid_direct) && + ((q_func1(o).d_7pi_f == float_vector_ref_d_7pi) || (q_func1(o).d_7pi_f == float_vector_ref_d_7pi_direct)) && + (q_arg2(o).p == q_arg4(o).p)) + copy_to_same_type(sc, slot_value(q_arg1(o).p), slot_value(q_arg3(o).p), integer(stepper), end, integer(stepper)); + else + if ((q_call(o).fd == opt_d_7pid_ssc) && + (q_func(o).d_7pid_f == float_vector_set_d_7pid_direct) && + (stepper == slot_value(q_arg2(o).p))) + s7_fill(sc, set_plist_4(sc, slot_value(q_arg1(o).p), wrap_real(sc, q_arg3(o).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) = q_call(o).fp; + if ((fp == opt_p_pip_ssc) && + (stepper == slot_value(q_arg2(o).p)) && /* i.e. index by do counter */ + ((q_func(o).p_pip_f == string_set_p_pip_direct) || + (q_func(o).p_pip_f == t_vector_set_p_pip_direct) || + (q_func(o).p_pip_f == list_set_p_pip_unchecked))) + s7_fill(sc, set_plist_4(sc, slot_value(q_arg1(o).p), q_arg3(o).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 (q_func(o).fb(q_arg2(o).o1)) q_p_func1_call(o); + } + 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 (!(q_func4(o).b_pi_f(sc, q_p_func1_call(o), integer(slot_value(q_arg1(o).p))))) q_p_func2_call(o); + } + 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"))) */ + opt_info *o1 = q_when_body(o, 0).o1; + for (; integer(stepper) < end; integer(stepper)++) + if (!(q_when_test_call(o))) q_call(o1).fp(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) = q_call(o).fi; + if ((fi == opt_i_7pii_ssc) && (stepper == slot_value(q_arg2(o).p)) && (q_func(o).i_7pii_f == int_vector_set_i_7pii_direct)) + s7_fill(sc, set_plist_4(sc, slot_value(q_arg1(o).p), wrap_integer(sc, q_arg3(o).i), stepper, wrap_integer(sc, end))); /* wrapped 16-Nov-23 */ + else + if ((q_func(o).i_7pii_f == int_vector_set_i_7pii_direct) && (q_func1(o).fi == opt_i_pi_ss_ivref) && (q_arg2(o).p == q_func1_arg(o).q_arg2(o1).p)) + copy_to_same_type(sc, slot_value(q_arg1(o).p), slot_value(q_func1_arg(o).q_arg1(o1).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-numeric? (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) = q_call(o).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 (q_when_test_call(o)) + { + q_when_p1_call(o); + q_when_p2_call(o); + }}} + 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) = q_call(o).fi; + if ((fi == opt_set_i_i_f) || (fi == opt_set_i_i_fo)) + { + slot_set_value(q_arg1(o).p, make_mutable_integer(sc, integer(slot_value(q_arg1(o).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(q_arg1(o).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) = q_call(o).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(q_arg1(o).p, make_mutable_real(sc, real(slot_value(q_arg1(o).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(q_arg1(o).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); + const 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++) q_call(body[i]).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)); + const 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++) q_call(body[i]).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); + const 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(q_call(body[i]).fp(body[i]); i++); + else + if (body_len == 1) + { + opt_info *o1 = body[0]; + for (; integer(stepper) < end; integer(stepper)++) + q_call(o1).fp(o1); + } + else + /* TODO: opt_unless_p_1_nr? */ + for (; integer(stepper) < end; integer(stepper)++) + for (int32_t i = 0; i < body_len; i++) q_call(body[i]).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))) */ + 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)); + 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++) q_call(body[i]).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_let, 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_let = 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_let); + 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_let); + return(false); + }} + if (!is_null(p)) /* no hits in s7test or snd-test */ + { + set_curlet(sc, old_let); + 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) + { + opt_info *o = body[0]; + s7_double (*f2)(opt_info *o) = q_call(o).fd; + if (var_len == 1) + { + opt_info *first = sc->opts[0]; + const s7_pointer xp = t_lookup(sc, caar(let_vars), let_vars); + s7_double (*f1)(opt_info *o) = q_call(first).fd; + set_integer(ip, numerator(stepper)); + set_real(xp, f1(first)); + f2(o); + if ((f2 == opt_fmv) && + (f1 == opt_d_dd_ff_o2) && + (q_func(first).d_dd_f == add_d_dd) && + (slot_symbol(step_slot) == slot_symbol(q_arg2(o).p))) + { + opt_info *o1 = q_arg3(o).o1; /* opt_d_dd_ff_mul1 */ + opt_info *o2 = q_arg4(o).o1; /* opt_d_vd_o1 */ + opt_info *o3 = q_arg5(o).o1; /* opt_d_dd_ff_o3 */ + s7_d_vid_t vf7 = q_func(o).d_vid_f; /* locsig_d_vid */ + s7_d_v_t vf1 = q_func3(first).d_v_f; /* mus_triangle_wave_dv */ + s7_d_v_t vf2 = q_func1(first).d_v_f; /* mus_rand_interp_dv */ + s7_d_v_t vf3 = q_func3(o1).d_v_f; /* mus_env_dv */ + s7_d_v_t vf4 = q_func3(o3).d_v_f; /* mus_env_dv */ + s7_d_vd_t vf5 = q_func(o2).d_vd_f; /* mus_oscil_dvd */ + s7_d_vd_t vf6 = q_func2(o3).d_vd_f; /* mus_polywave_dvd */ + void *obj1 = q_arg1(first).gen; + void *obj2 = q_arg2(first).gen; + void *obj3 = q_arg1(o1).gen; + void *obj4 = q_arg1(o3).gen; + void *obj5 = q_arg1(o).gen; + void *obj6 = q_arg1(o2).gen; + void *obj7 = q_arg2(o3).gen; + 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) + { + const s7_pointer s1 = let_slots(sc->curlet); + const s7_pointer s2 = next_slot(s1); + opt_info *v0 = vars[0], *v1 = vars[1]; + for (s7_int k = numerator(stepper); k < end; k++) + { + set_integer(ip, k); + set_real(slot_value(s1), q_call(v0).fd(v0)); + set_real(slot_value(s2), q_call(v1).fd(v1)); + f2(o); + }} /* 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; is_not_slot_end(slot); n++, slot = next_slot(slot)) + set_real(slot_value(slot), q_call(vars[n]).fd(vars[n])); + f2(o); /* q_call(body[0]).fd(body[0]) is possibly slightly faster */ + }}} /* end body_len == 1 */ + else + if ((body_len == 2) && (var_len == 1)) + { + const 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), q_call(vars[0]).fd(vars[0])); + q_call(body[0]).fd(body[0]); + q_call(body[1]).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); is_not_slot_end(slot); i++, slot = next_slot(slot)) + set_real(slot_value(slot), q_call(vars[i]).fd(vars[i])); + for (int32_t i1 = 0; i1 < body_len; i1++) q_call(body[i1]).fd(body[i1]); + } + set_curlet(sc, old_let); + 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); + for (s7_pointer stepper = slot_value(sc->args); 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); + const s7_pointer val_slot = s7_t_slot(sc, cadr(body)); + s7_int step = integer(slot_value(step_slot)); + const 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_let; + 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_let = 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_let); + 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)) + { + const s7_pointer slot = add_slot_unchecked_with_id(sc, sc->curlet, caar(vars), car_unchecked(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 -------- */ +{ + 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)) + { + const 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 = s7i_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))) + { + const 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 let = 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(car_unchecked(args))); + symbol_set_local_slot(sym, id, slot); + if (is_not_slot_end(last_slot)) + slot_set_next(last_slot, slot); + else let_set_slots(let, 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 + { + const s7_pointer slot = make_slot(sc, T_Sym(pars), args); + symbol_set_local_slot(pars, id, slot); + if (is_not_slot_end(last_slot)) + slot_set_next(last_slot, slot); + else let_set_slots(let, 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 let = 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, let, 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(let), cddr(sc->code)); /* not for gc-protection, but as implicit loop vars */ + push_stack(sc, OP_F_NP_1, let, 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, last_slot = slot; + for (p = sc->value; (is_pair(p)) && (is_not_slot_end(slot)); p = cdr(p), last_slot = 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 = last_slot; /* 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 ((!is_not_slot_end(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 (is_not_slot_end(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 let = sc->args; + let_set_id(let, ++sc->let_number); + set_curlet(sc, let); + update_symbol_ids(sc, let); + } + 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 */; is_not_slot_end(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; is_not_slot_end(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(sc, 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); is_not_slot_end(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); is_not_slot_end(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(sc, 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 par1; + 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)); + par1 = car(closure_pars(func)); + set_curlet(sc, make_let_with_slot(sc, closure_let(func), (is_pair(par1)) ? car(par1) : par1, 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) == type_unchecked(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); is_not_slot_end(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_unchecked(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) /* sc->code: (generate-leaves) */ +{ + 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) /* sc->code: (h) */ +{ + 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, sc->code: (fc) */ +{ + 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) /* sc->code: (get-ds) */ +{ + 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) /* sc->code: (make-hook) */ +{ + 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) /* sc->code: (m3) */ +{ + 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) /* sc->code: (func hook) */ +{ + 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) /* sc->code: (recompose-1 n) */ +{ + 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) /* sc->code: (close1 x) */ +{ + 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) /* sc->code: (op2 lst) */ +{ + 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) /* sc->code: (close1 ((lambda () (cs11 x)))) */ +{ + 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) /* sc->code: close1 */ +{ + 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) /* sc->code: (char->digit (str j)) */ +{ + 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) /* sc->code: (identity (if (= state 0) (call/cc... */ +{ + 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) /* used twice in eval, sc->code: (recompose-1 (- n 1)) */ +{ + 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) /* sc->code: (number-ok? otst result oexp) */ +{ + 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, sc->code: (transparent-memq sym var (outlet e)) */ +{ /* 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) /* (not called in s7test) cb.scm: sc->code: (loop a (+ b 1) parts) */ +{ + 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, sc->code: (fx2 3 #t #t) */ +{ + 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) /* sc->code: (uncaller (hook 'code)) */ +{ + 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) /* sc->code: symbol->object */ +{ + 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) /* sc->code: (loop (+ index 1)) */ +{ + 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) /* sc->code: (butlast (cdr (car (cdr (cdr old))))) */ +{ + 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) /* sc->code: (ack1 (- m 1) (ack1 m (- n 1))) */ +{ + 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->code: 1 */ +{ + /* 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) /* sc->code: (f-1 (lambda (b) (+ b 1)) 2) */ +{ + 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) /* sc->code: # */ +{ + 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) /* sc->code: (loop (xf) (yf)) */ +{ + 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) /* sc->code: as above */ +{ + 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) /* sc->code: (somefunc (call/cc (lambda (c1)... */ +{ + 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) /* sc->code: somefunc */ +{ + 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) /* sc->code: (string-wi=? (object->string (append...) :readable)) */ +{ + 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) /* sc->code: string-wi=? */ +{ + 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) /* sc->code: (somefunc (call/cc (lambda (c1)... */ +{ + 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) /* sc->code as above */ +{ + 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) /* sc->code: (g-1 (lambda (b c) (+ b c)) 2 3) */ +{ + s7_pointer args = cdr(sc->code); /* sc->code: e.g. s7test (recompose 32 (lambda (a) (cons 1 a)) ()) */ + if (has_fx(args)) + { + sc->args = fx_call(sc, args); + args = cdr(args); + if (has_fx(args)) + { + 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, args), 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(args); + } + else + { + push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); /* arg1 == stack[args] */ + sc->code = car(args); + }} + else + { + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_3P_1); + sc->code = car(args); + } +} + +static bool closure_3p_end(s7_scheme *sc, s7_pointer args) /* sc->code: (dpb (byte 4 5) (byte 6 7) (byte 8 9)) */ +{ + if (has_fx(args)) + { + 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, args)); + 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(args); + return(false); +} + +static bool op_any_closure_3p_1(s7_scheme *sc) /* sc->code: as above */ +{ + const s7_pointer args = cddr(sc->code); + sc->args = sc->value; /* (arg1 of closure) sc->value can be clobbered by fx_call? */ + if (has_fx(args)) + { + sc->value = fx_call(sc, args); + return(closure_3p_end(sc, cdr(args))); + } + push_stack_direct(sc, OP_ANY_CLOSURE_3P_2); + sc->code = car(args); + 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) /* sc->code: as above */ +{ + /* 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) /* sc->code: (lpb -1 1 (byte 4 5) 3) */ +{ + s7_pointer args = cdr(sc->code); + check_stack_size(sc); + if (has_fx(args)) + { + gc_protect_via_stack(sc, fx_call(sc, args)); + args = cdr(args); + if (has_fx(args)) + { + set_gc_protected2(sc, fx_call(sc, args)); + args = cdr(args); + if (has_fx(args)) + { + set_gc_protected3(sc, fx_call(sc, args)); + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_4); + sc->code = cadr(args); + } + else + { + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); + sc->code = car(args); + }} + 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(args); + }} + else + { + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_1); + sc->code = car(args); + } +} + +static bool closure_4p_end(s7_scheme *sc, s7_pointer args) /* sc->code: as above */ +{ + if (has_fx(args)) + { + const s7_pointer func = opt1_lambda(sc->code); + sc->args = fx_call(sc, args); + 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(args); + return(false); +} + +static bool op_any_closure_4p_1(s7_scheme *sc) /* sc->code: as above */ +{ + s7_pointer args = cddr(sc->code); + gc_protect_via_stack(sc, sc->value); + if (has_fx(args)) + { + set_gc_protected2(sc, fx_call(sc, args)); + args = cdr(args); + if (has_fx(args)) + { + set_gc_protected3(sc, fx_call(sc, args)); + return(closure_4p_end(sc, cdr(args))); + } + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); + sc->code = car(args); + } + else + { + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_2); + sc->code = car(args); + } + return(false); +} + +static bool op_any_closure_4p_2(s7_scheme *sc) /* sc->code: as above */ +{ + const s7_pointer args = cdddr(sc->code); + set_gc_protected2(sc, sc->value); + if (has_fx(args)) + { + set_gc_protected3(sc, fx_call(sc, args)); + return(closure_4p_end(sc, cdr(args))); + } + push_stack_no_args_direct(sc, OP_ANY_CLOSURE_4P_3); + sc->code = car(args); + return(false); +} + +static bool op_any_closure_4p_3(s7_scheme *sc) /* sc->code: as above */ +{ + 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) /* sc->code: as above */ +{ + 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) /* sc->code: (g x y) */ +{ + 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) /* sc->code: (_f_aq p e) */ +{ + 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) /* sc->code: (A k B) */ +{ + 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) /* sc->code: (c1 s i) */ +{ + 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) /* sc->code: (close3 x 2) */ +{ + 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) /* sc->code: (tree-member? c d) */ +{ + 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) /* sc->code: (read-in-radix str 32) */ +{ + 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) /* sc->code: (f-1 abs 2) */ +{ + 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) /* sc->code: (walk-rest caller form let) */ +{ + s7_pointer args = cdr(sc->code); + const s7_pointer arg1_val = lookup(sc, car(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cdr(args); + make_let_with_three_slots(sc, func, arg1_val, 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) /* sc->code: (pretty-print-1 obj port column) */ +{ + s7_pointer args = cdr(sc->code); + const s7_pointer arg1_val = lookup(sc, car(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cdr(args); + make_let_with_three_slots(sc, func, arg1_val, 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) /* sc->code: (Cholesky:add-element P L i j) */ +{ + s7_pointer args = cdr(sc->code); + const s7_pointer arg1_val = lookup(sc, car(args)), arg2_val = lookup(sc, cadr(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cddr(args); + make_let_with_four_slots(sc, func, arg1_val, arg2_val, 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) /* sc->code: (make-collector into oper tail head) */ +{ + s7_pointer args = cdr(sc->code); + const s7_pointer arg1_val = lookup(sc, car(args)), arg2_val = lookup(sc, cadr(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cddr(args); + make_let_with_four_slots(sc, func, arg1_val, arg2_val, 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, sc->code: (key-parse-clause d mode args argn user) */ +{ + s7_pointer args = cdr(sc->code); + const s7_pointer arg1_val = lookup(sc, car(args)), arg2_val = lookup(sc, cadr(args)); + const s7_pointer func = opt1_lambda(sc->code); + args = cddr(args); + make_let_with_five_slots(sc, func, arg1_val, arg2_val, 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) /* sc->code: (close3 1 2) */ +{ + s7_pointer args = cdr(sc->code), body; + const s7_pointer func = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(args)); /* 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, args), sc->code)); + body = 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(body))); + sc->code = car(body); +} + +static inline void op_safe_closure_aa_o(s7_scheme *sc) /* sc->code: (tree-member? 1 '(2 3 (4 1) 5)) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(args)); + set_curlet(sc, update_let_with_two_slots(sc, closure_let(func), fx_call(sc, args), 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) /* sc->code: (substring? "hiho" "test hih") */ +{ + s7_pointer args = cdr(sc->code), body; + const s7_pointer func = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(args)); + sc->value = fx_call(sc, args); + 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)); + body = T_Pair(closure_body(func)); + check_stack_size(sc); + push_stack_no_args(sc, sc->begin_op, T_Pair(cdr(body))); + sc->code = car(body); +} + +static Inline void inline_op_closure_aa_o(s7_scheme *sc) /* called once in eval, b cb left lg list, sc->code: (ack1 m (- n 1)) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(args)); + sc->value = fx_call(sc, args); + 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, sc->code: (f8 (lambda (x) (+ x 1)) 1) */ +{ + 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) /* sc->code: (slot var expr env expr-env) */ +{ + 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 args = cdr(sc->code), slot = let_slots(let); is_not_slot_end(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) /* sc->code: (f8 0 0 (list 1)) */ +{ + const s7_pointer args = cdr(sc->code); + const s7_pointer func = opt1_lambda(sc->code); + sc->code = fx_call(sc, cdr(args)); /* fx_call can affect sc->value, but not sc->code, I think */ + sc->args = fx_call(sc, cddr(args)); /* is sc->args safe here? */ + set_curlet(sc, update_let_with_three_slots(sc, closure_let(func), fx_call(sc, args), 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) /* sc->code: (hi 1 2 3 4) */ +{ + 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; is_not_slot_end(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, 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?, sc->code: (A k B x1 x2 x3 x4 x5) */ +{ + /* 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 let = inline_make_let(sc, closure_let(func)); + const s7_int id = let_id(let); + begin_temp(sc->y, let); + add_slot_unchecked(sc, let, car(pars), lookup(sc, car(args)), id); + last_slot = let_slots(let); + 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, let); + 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, sc->code: (recompose 32 reverse x) */ +{ + 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, sc->code: (recur-cond-a-a-a-a-opl3a-l3aq-23 (- x 1) (+ y 1) z) */ +{ + 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) /* sc->code: (f h1 b1 :a) */ +{ + 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) /* sc->code: (recompose 12 char-downcase #\A) */ +{ + 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) /* sc->code: (parse-clauses forms () ops) */ +{ + 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, sc->code: (func (- a 1) (- b 1) (- c 1)) */ +{ + 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, sc->code: (reinvert 12 vector->list... */ +{ + 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) /* sc->code: (f1 0 "a" L1 V1 S1 H1 E1) */ +{ + 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 let = inline_make_let(sc, closure_let(func)); + s7_pointer slot, last_slot; + sc->z = let; + sc->value = fx_call(sc, exprs); + new_cell_unchecked(sc, last_slot, T_SLOT); + slot_set_symbol_and_value(last_slot, car(pars), sc->value); + slot_set_next(last_slot, let_slots(let)); /* i.e. slot_end */ + let_set_slots(let, 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, let); + sc->z = sc->unused; + let_set_id(let, ++sc->let_number); + for (s7_pointer slot1 = let_slots(let); is_not_slot_end(slot1); slot1 = next_slot(slot1)) + { + symbol_set_local_slot(slot_symbol(slot1), let_id(let), 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) || + (local_value_unchecked(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) +{ + const bool when_case = (!true_is_done(code)); + const s7_pointer if_test = cadr(code), body = cddr(code), la_slot = let_slots(sc->curlet); + const s7_function tf = fx_proc(cdr(code)); + const s7_pointer la_call = opt3_pair(code); + const 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) +{ + const bool when_case = (!true_is_done(code)); + const s7_pointer if_test = cadr(code), body = cddr(code), la_slot = let_slots(sc->curlet); + const s7_function tf = fx_proc(cdr(code)); + const s7_pointer la_call = opt3_pair(code); + const s7_pointer la = cdar(la_call); + const s7_pointer l2a = cdr(la); + const 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) +{ + const bool when_case = (!true_is_done(code)); + const s7_pointer if_test = cadr(code), body = cddr(code), la_slot = let_slots(sc->curlet); + const s7_function tf = fx_proc(cdr(code)); + const s7_pointer la_call = opt3_pair(code); + const s7_pointer la = cdar(la_call); + const s7_pointer l2a = cdr(la); + const s7_pointer l3a = cdr(l2a); + const s7_pointer l2a_slot = next_slot(la_slot); + const 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) +{ + const bool true_quits = true_is_done(code); + const s7_pointer la_slot = let_slots(sc->curlet); + const 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); + 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 (q_call(o).fb(o) != true_quits) {set_integer(val, q_call(o1).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 (!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) = q_call(o1).fi; + s7_int (*fi2)(opt_info *o) = q_call(o2).fi; + bool (*fb)(opt_info *o) = q_call(o).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 = q_arg2(o).i, m = q_arg2(o1).i; + s7_pointer slot1 = q_arg1(o).p, slot2 = q_arg1(o1).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) = q_call(o1).fd; + s7_double (*fd2)(opt_info *o) = q_call(o2).fd; + bool (*fb)(opt_info *o) = q_call(o).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 = q_arg2(o).x; + s7_double m = q_arg2(o1).x; + s7_pointer slot1 = q_arg1(o).p; + s7_pointer slot2 = q_arg1(o1).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); + } + 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) +{ + const bool true_quits = true_is_done(code); + const s7_pointer la_slot = let_slots(sc->curlet); + 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 l3a = cdr(l2a); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer l3a_slot = next_slot(l2a_slot); + const 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) +{ + const s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_or = cdadr(fx_and); + const 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) +{ + const s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_and = cdadr(fx_or); + const s7_pointer fx_la = cdadr(fx_and); + tick_tc(sc, OP_TC_OR_A_AND_A_LA); + while (true) + { + s7_pointer result = fx_call(sc, fx_or); + if (result != sc->F) return(result); + 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) +{ + const s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_or1 = cdadr(fx_and); + const s7_pointer fx_or2 = cdr(fx_or1); + const 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) +{ + const s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_and1 = cdadr(fx_or); + const s7_pointer fx_and2 = cdr(fx_and1); + const s7_pointer fx_la = cdadr(fx_and2); + tick_tc(sc, OP_TC_OR_A_AND_A_A_LA); + while (true) + { + s7_pointer result = fx_call(sc, fx_or); + if (result != sc->F) return(result); + 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) +{ + const s7_pointer fx_or1 = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_or2 = cdr(fx_or1); + const s7_pointer fx_and1 = cdadr(fx_or2); + const s7_pointer fx_and2 = cdr(fx_and1); + const s7_pointer fx_la = cdadr(fx_and2); + tick_tc(sc, OP_TC_OR_A_A_AND_A_A_LA); + while (true) + { + s7_pointer result = fx_call(sc, fx_or1); + if (result != sc->F) return(result); + result = fx_call(sc, fx_or2); + if (result != sc->F) return(result); + 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) +{ + const s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_or = cdadr(fx_and); + const s7_pointer fx_la = cdadr(fx_or); + const s7_pointer fx_l2a = cdr(fx_la); + const 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) +{ + const s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_and = cdadr(fx_or); + const s7_pointer fx_la = cdadr(fx_and); + const s7_pointer fx_l2a = cdr(fx_la); + const s7_pointer l2a_slot = next_slot(la_slot); + tick_tc(sc, OP_TC_OR_A_AND_A_L2A); + while (true) + { + s7_pointer result = fx_call(sc, fx_or); + if (result != sc->F) return(result); + 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) +{ + const s7_pointer fx_and = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_or = cdadr(fx_and); + const s7_pointer fx_la = cdadr(fx_or); + const s7_pointer fx_l2a = cdr(fx_la); + const s7_pointer fx_l3a = cdr(fx_l2a); + const s7_pointer l2a_slot = next_slot(la_slot); + const 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) +{ + const s7_pointer fx_or = cdr(code), la_slot = let_slots(sc->curlet); + const s7_pointer fx_and = cdadr(fx_or); + const s7_pointer fx_la = cdadr(fx_and); + const s7_pointer fx_l2a = cdr(fx_la); + const s7_pointer fx_l3a = cdr(fx_l2a); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer l3a_slot = next_slot(l2a_slot); + tick_tc(sc, OP_TC_OR_A_AND_A_L3A); + while (true) + { + s7_pointer result = fx_call(sc, fx_or); + if (result != sc->F) return(result); + 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) +{ + const 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); + const s7_pointer fx_la = cdadr(fx_and2); + const s7_pointer fx_l2a = cdr(fx_la); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer fx_l3a = cdr(fx_l2a); + const 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 result = fx_call(sc, fx_or); + if (result != sc->F) return(result); + 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 result = fx_call(sc, fx_or); + if (result != sc->F) return(result); + 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 (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 (!q_call(o).fb(o)) {sc->value = sc->F; return(true);} + if (q_call(o1).fb(o1) == z_first) {endp = if2_z; break;} + set_integer(val, q_call(o2).fi(o2)); + } + else + while (true) + { + if (q_call(o).fb(o)) {endp = if1_true; break;} + if (q_call(o1).fb(o1) == z_first) {endp = if2_z; break;} + set_integer(val, q_call(o2).fi(o2)); + } + return(op_tc_z(sc, endp)); + }}}} + 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; + 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); + 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) +{ + const s7_pointer if1_test = cdr(code); + s7_pointer endp; + const s7_pointer la_slot = let_slots(sc->curlet); + const s7_pointer if1_true = cdr(if1_test); + const s7_pointer if1_false = cadr(if1_true); + const s7_pointer if2_test = cdr(if1_false); + const s7_pointer if2_true = cdr(if2_test); + const s7_pointer if2_false = cdr(if2_true); + const s7_pointer la1 = cdar(if2_true); + const s7_pointer la2 = cdar(if2_false); + const s7_pointer l2a1 = cdr(la1); + const s7_pointer l2a2 = cdr(la2); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer l3a1 = cdr(l2a1); + const s7_pointer l3a2 = cdr(l2a2); + const 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 */ +{ + const s7_pointer if1_test = cdr(code); + s7_pointer endp; + const s7_pointer la_slot = let_slots(sc->curlet); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer l3a_slot = next_slot(l2a_slot); + const s7_pointer if1_true = cdr(if1_test); + const s7_pointer if1_false = cadr(if1_true); + const s7_pointer if2_test = cdr(if1_false); + const s7_pointer if2_true = cdr(if2_test); + const s7_pointer if2_false = cdr(if2_true); + const s7_pointer zendp = (zfirst) ? if2_true : if2_false; + const s7_pointer la2 = (zfirst) ? cdar(if2_false) : cdar(if2_true); + const s7_pointer l2a2 = cdr(la2); + const 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) +{ + const s7_pointer body = caddr(code); + const s7_pointer outer_let = sc->curlet; + const s7_pointer la_slot = let_slots(outer_let); + const s7_pointer if_test = cdr(body); + const s7_pointer if_true = cddr(body); + const bool wrappable = has_fx(if_true); + const s7_pointer if_false = cadddr(body); + const s7_pointer la = cdr(if_false); + s7_pointer let_var = caadr(code); + const 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))); + const 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) +{ + const s7_pointer body = caddr(code); + const s7_pointer outer_let = sc->curlet; + const s7_pointer la_slot = let_slots(outer_let); + const s7_pointer l2a_slot = next_slot(la_slot); + const s7_pointer if_test = cdr(body); + const s7_pointer if_true = cddr(body); + const bool wrappable = has_fx(if_true); + const s7_pointer if_false = cadddr(body); + const s7_pointer la = cdr(if_false); + const 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))); + const 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 (!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 (!(q_call(o).fb(o))) + { + s7_int i1 = q_call(o1).fi(o1); + set_integer(val2, q_call(o2).fi(o2)); + set_integer(val1, i1); + set_integer(val3, q_call(o3).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); + } + 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 endp, slot; + const s7_pointer if1_test = cdr(code), outer_let = sc->curlet, la_slot = let_slots(sc->curlet); + const s7_pointer if1_true = cdr(if1_test); /* cddr(code) */ + const s7_pointer let_expr = cadr(if1_true); /* cadddr(code) */ + const s7_pointer let_vars = cadr(let_expr); + const s7_pointer if2 = caddr(let_expr); + const s7_pointer if2_test = cdr(if2); + const s7_pointer if2_true = cdr(if2_test); /* cddr(if2) */ + const s7_pointer la = cdadr(if2_true); /* cdr(cadddr(if2)) */ + const s7_pointer l2a = cdr(la); + const s7_pointer l2a_slot = next_slot(la_slot); + const 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) +{ + 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); + { + bool 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; is_not_slot_end(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; is_not_slot_end(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 *old_b, *new_b; + 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; + old_b = vector_block(stack); + new_b = reallocate(sc, old_b, vector_length(stack) * sizeof(s7_pointer)); + block_info(new_b) = NULL; + vector_block(stack) = new_b; + vector_elements(stack) = (s7_pointer *)block_data(new_b); /* 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); + + 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 = q_call(sc->rec_test_o).fb; + sc->rec_fi1 = q_call(sc->rec_result_o).fi; + sc->rec_fi2 = q_call(sc->rec_a1_o).fi; + sc->rec_fi3 = q_call(sc->rec_a2_o).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); + }}}}}}}} + 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 (q_call(sc->rec_test_o).fb(sc->rec_test_o)) /* if_(A) */ + return(q_call(sc->rec_result_o).fi(sc->rec_result_o)); /* if_a_(A) */ + i1 = q_call(sc->rec_a1_o).fi(sc->rec_a1_o); /* save a1 */ + set_integer(sc->rec_val1, q_call(sc->rec_a2_o).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 (q_call(sc->rec_test_o).fb(sc->rec_test_o)) return(q_call(sc->rec_result_o).fd(sc->rec_result_o)); + x1 = q_call(sc->rec_a1_o).fd(sc->rec_a1_o); + set_real(sc->rec_val1, q_call(sc->rec_a2_o).fd(sc->rec_a2_o)); + if (q_call(sc->rec_test_o).fb(sc->rec_test_o)) + x2 = q_call(sc->rec_result_o).fd(sc->rec_result_o); + else + { + s7_double x3; + x2 = q_call(sc->rec_a1_o).fd(sc->rec_a1_o); + set_real(sc->rec_val1, q_call(sc->rec_a2_o).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 (!(q_call(sc->rec_test_o).fb(sc->rec_test_o))) return(q_call(sc->rec_result_o).fi(sc->rec_result_o)); + i1 = q_call(sc->rec_a1_o).fi(sc->rec_a1_o); + set_integer(sc->rec_val1, q_call(sc->rec_a2_o).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 (!(q_call(sc->rec_test_o).fb(sc->rec_test_o))) return(q_call(sc->rec_result_o).fd(sc->rec_result_o)); + x1 = q_call(sc->rec_a1_o).fd(sc->rec_a1_o); + set_real(sc->rec_val1, q_call(sc->rec_a2_o).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); + 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); + }}}}}}} + /* 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 (q_call(sc->rec_test_o).fb(sc->rec_test_o)) return(q_call(sc->rec_result_o).fi(sc->rec_result_o)); + i1 = q_call(sc->rec_a1_o).fi(sc->rec_a1_o); + set_integer(sc->rec_val1, q_call(sc->rec_a2_o).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 (!q_call(sc->rec_test_o).fb(sc->rec_test_o)) return(q_call(sc->rec_result_o).fi(sc->rec_result_o)); + i1 = q_call(sc->rec_a1_o).fi(sc->rec_a1_o); + set_integer(sc->rec_val1, q_call(sc->rec_a2_o).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 ((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 = q_call(sc->rec_test_o).fb; + sc->rec_fb2 = q_call(sc->rec_a1_o).fb; + sc->rec_fi1 = q_call(sc->rec_result_o).fi; + sc->rec_fi2 = q_call(sc->rec_a2_o).fi; + sc->rec_fi3 = q_call(sc->rec_a3_o).fi; + sc->rec_fi4 = q_call(sc->rec_a4_o).fi; + sc->rec_fi5 = q_call(sc->rec_a5_o).fi; + sc->rec_fi6 = q_call(sc->rec_a6_o).fi; + return(opt_int_0); + }}}}}}}}} + 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)); } - 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->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 (q_call(sc->rec_test_o).fb(sc->rec_test_o)) return(q_call(sc->rec_result_o).fi(sc->rec_result_o)); + if (q_call(sc->rec_a1_o).fb(sc->rec_a1_o)) + { + i1 = q_call(sc->rec_a2_o).fi(sc->rec_a2_o); + set_integer(sc->rec_val2, q_call(sc->rec_a3_o).fi(sc->rec_a3_o)); + set_integer(sc->rec_val1, i1); + return(oprec_i_cond_a_a_a_l2a_lopa_l2aq(sc)); + } + i1 = q_call(sc->rec_a4_o).fi(sc->rec_a4_o); + i2 = q_call(sc->rec_a5_o).fi(sc->rec_a5_o); + set_integer(sc->rec_val2, q_call(sc->rec_a6_o).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 result; + if (sc->rec_testf(sc, sc->rec_testp) == sc->F) return(sc->F); + result = sc->rec_resf(sc, sc->rec_resp); + if (result != sc->F) return(result); + 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)); + result = oprec_and_a_or_a_l2a_l2a(sc); + if (result != sc->F) + { + sc->rec_loc -= 2; + return(result); + } + 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, 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(sc, (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(sc, 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(sc, 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, 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, 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, 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(sc, 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(sc, 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(sc, 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(sc, 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(sc, 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 args = cdr(sc->code); is_pair(args); args = cdr(args)) + if (has_fx(args)) + sc->args = cons(sc, sc->value = fx_call(sc, args), 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(args))) ? OP_ANY_C_NP_1 : OP_ANY_C_NP_2)), sc->args, cdr(args)); + sc->code = T_Pair(car(args)); + 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 args = 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(args)) + { + sc->args = fx_call(sc, args); + sc->args = list_1(sc, sc->args); + for (args = cdr(args); (is_pair(args)) && (has_fx(args)); args = cdr(args)) + sc->args = cons_unchecked(sc, fx_call(sc, args), sc->args); + } + else sc->args = sc->nil; + push_stack(sc, ((intptr_t)((is_pair(cdr(args))) ? OP_ANY_CLOSURE_NP_1 : OP_ANY_CLOSURE_NP_2)), sc->args, cdr(args)); + sc->code = T_Pair(car(args)); +} + +static void op_any_closure_np_end(s7_scheme *sc) +{ + s7_pointer args, func; + 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; + const s7_int 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; is_not_slot_end(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 (is_not_slot_end(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 let = inline_make_let(sc, closure_let(func)); + const s7_int id = let_id(let); + + begin_temp(sc->y, let); + last_slot = make_slot(sc, car(pars), car(sc->args)); + slot_set_next(last_slot, slot_end); + let_set_slots(let, 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, let); + end_temp(sc->y); +#if S7_DEBUGGING + if ((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)); +#endif + } + 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 void 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); +} + +static void 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); +} + +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 args = cdr(sc->code); + sc->args = fx_call(sc, cdr(args)); + 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(args)); + if (needs_copied_args(sc->code)) + sc->args = copy_proper_list(sc, sc->args); +} + +static void op_apply_sl(s7_scheme *sc) +{ + s7_pointer args = cdr(sc->code); + sc->args = fx_call(sc, cdr(args)); + sc->code = lookup_global(sc, car(args)); +} + +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_args1(s7_scheme *sc) +{ + /* implicit_iterator and implicit_c_object, sc->code is ignored, so we can skip to apply in eval */ + sc->code = pop_op_stack(sc); + sc->args = cons(sc, sc->value, sc->args); + sc->args = proper_list_reverse_in_place(sc, sc->args); +} + +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)); + /* there's only one push of eval_args2; we could check sc->args==sc->nil there and push eval_args6, timp mv misc ? but we have to check somewhere */ +} + +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, 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 |# + */ + 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)); + } + { + const char *orig_str = (const char *)(port_data(port) + port_position(port)); + const char *pend = (const char *)(port_data(port) + port_data_size(port)); + const char *str = orig_str; + const char *p; + 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) + */ + /* 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) */ + { + int32_t c; + char last_char = ' '; + 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))); } - sc->code= T_Pair (closure_body (func)); + 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 chr = inchar(port); + if (chr == 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)chr; + if (chr == '(') + { + 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 void -op_any_closure_a_sym (s7_scheme* sc) /* for (lambda (a . b) ...) */ +static token_t read_dot(s7_scheme *sc, s7_pointer port) { - 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); + 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; /* sc->strbuf index */ + 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 */ + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + 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); /* for easier break from switch */ +} + +static bool unknown_unknown(s7_scheme *sc, s7_pointer code, opcode_t op) +{ + if ((is_symbol(car(code))) && + (!is_bound_symbol(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 let = sc->curlet; let; let = let_outlet(let)) + if ((is_funclet(let)) && (funclet_function(let) != 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_bound_symbol(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_bound_symbol(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))); - 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)); + 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)); } -/* ---------------- tc/rec ---------------- */ +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)); -#if S7_DEBUGGING -#define TC_REC_SIZE NUM_OPS -#define TC_REC_LOW_OP OP_TC_AND_A_OR_A_LA + 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; -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); -} + case T_CLOSURE_STAR: + if (fxify_closure_star_g(sc, func, code)) return(true); + break; -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); -} + 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)); -static void -tick_tc (s7_scheme* sc, int32_t op) { - sc->tc_rec_calls[op]++; -} -#else -#define tick_tc(Sc, Op) -#endif + 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))); -/* 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))); + case T_LET: + { + const s7_pointer arg1 = cadr(code); + if ((is_quoted_symbol(sc, 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 */ } - else break; + + default: 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) */ + if ((is_symbol(car(code))) && + (!is_bound_symbol(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 s7_pointer -fx_tc_case_la (s7_scheme* sc, s7_pointer arg) { - op_tc_case_la (sc, arg, 1); - return (sc->value); -} +static bool op_unknown_gg(s7_scheme *sc) /* we assume in eval that this always returns true */ +{ + 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_bound_symbol(sc, cadr(code)))) + return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); + s2 = is_normal_symbol(caddr(code)); + if ((s2) && + (!is_bound_symbol(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)); -static s7_pointer -fx_tc_case_l2a (s7_scheme* sc, s7_pointer arg) { - op_tc_case_la (sc, arg, 2); - return (sc->value); -} + 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; -static s7_pointer -fx_tc_case_l3a (s7_scheme* sc, s7_pointer arg) { - op_tc_case_la (sc, arg, 3); - return (sc->value); -} + 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; -/* op_tc_when_la|l2a|l3a */ -static s7_pointer -op_tc_when_la (s7_scheme* sc, s7_pointer code) { - const bool when_case= (!true_is_done (code)); - const s7_pointer if_test= cadr (code), body= cddr (code), - la_slot = let_slots (sc->curlet); - const s7_function tf = fx_proc (cdr (code)); - const s7_pointer la_call= opt3_pair (code); - const 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) { - const bool when_case= (!true_is_done (code)); - const s7_pointer if_test= cadr (code), body= cddr (code), - la_slot = let_slots (sc->curlet); - const s7_function tf = fx_proc (cdr (code)); - const s7_pointer la_call = opt3_pair (code); - const s7_pointer la = cdar (la_call); - const s7_pointer l2a = cdr (la); - const 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) { - const bool when_case= (!true_is_done (code)); - const s7_pointer if_test= cadr (code), body= cddr (code), - la_slot = let_slots (sc->curlet); - const s7_function tf = fx_proc (cdr (code)); - const s7_pointer la_call = opt3_pair (code); - const s7_pointer la = cdar (la_call); - const s7_pointer l2a = cdr (la); - const s7_pointer l3a = cdr (l2a); - const s7_pointer l2a_slot= next_slot (la_slot); - const 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); -} + 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)); -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); -} + 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)); -/* tc_if_a_z_la|la2|la3 */ -static bool -op_tc_if_a_z_la (s7_scheme* sc, s7_pointer code) { - const bool true_quits= true_is_done (code); - const s7_pointer la_slot = let_slots (sc->curlet); - const 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); - 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 (q_call (o).fb (o) != true_quits) { - set_integer (val, q_call (o1).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 (!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)= q_call (o1).fi; - s7_int (*fi2) (opt_info* o)= q_call (o2).fi; - bool (*fb) (opt_info* o) = q_call (o).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= q_arg2 (o).i, m= q_arg2 (o1).i; - s7_pointer slot1= q_arg1 (o).p, slot2= q_arg1 (o1).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)); - } - } - } + 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))); - 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)= q_call (o1).fd; - s7_double (*fd2) (opt_info* o)= q_call (o2).fd; - bool (*fb) (opt_info* o) = q_call (o).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 = q_arg2 (o).x; - s7_double m = q_arg2 (o1).x; - s7_pointer slot1= q_arg1 (o).p; - s7_pointer slot2= q_arg1 (o1).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); - } - 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)); - } + default: break; } - 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) { - const bool true_quits= true_is_done (code); - const s7_pointer la_slot = let_slots (sc->curlet); - 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 l3a = cdr (l2a); - const s7_pointer l2a_slot = next_slot (la_slot); - const s7_pointer l3a_slot = next_slot (l2a_slot); - const 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)); + 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 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 bool op_unknown_ns(s7_scheme *sc) /* we assume in eval that this always returns true */ +{ + const s7_pointer code = sc->code, func = sc->last_function; + const int32_t num_args = opt3_arglen(cdr(code)); -static s7_pointer -op_tc_and_a_or_a_la (s7_scheme* sc, s7_pointer code) { - const s7_pointer fx_and= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_or= cdadr (fx_and); - const 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) { - const s7_pointer fx_or= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_and= cdadr (fx_or); - const s7_pointer fx_la = cdadr (fx_and); - tick_tc (sc, OP_TC_OR_A_AND_A_LA); - while (true) { - s7_pointer result= fx_call (sc, fx_or); - if (result != sc->F) return (result); - if (fx_call (sc, fx_and) == sc->F) return (sc->F); - slot_set_value (la_slot, fx_call (sc, fx_la)); - } - return (sc->F); -} + if (!func) unbound_variable_error_nr(sc, car(sc->code)); + if (SHOW_EVAL_OPS) fprintf(stderr, " %s %s\n", __func__, display_truncated(func)); -static s7_pointer -op_tc_and_a_or_a_a_la (s7_scheme* sc, s7_pointer code) { - const s7_pointer fx_and= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_or1= cdadr (fx_and); - const s7_pointer fx_or2= cdr (fx_or1); - const 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) { - const s7_pointer fx_or= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_and1= cdadr (fx_or); - const s7_pointer fx_and2= cdr (fx_and1); - const s7_pointer fx_la = cdadr (fx_and2); - tick_tc (sc, OP_TC_OR_A_AND_A_A_LA); - while (true) { - s7_pointer result= fx_call (sc, fx_or); - if (result != sc->F) return (result); - 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) { - const s7_pointer fx_or1= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_or2 = cdr (fx_or1); - const s7_pointer fx_and1= cdadr (fx_or2); - const s7_pointer fx_and2= cdr (fx_and1); - const s7_pointer fx_la = cdadr (fx_and2); - tick_tc (sc, OP_TC_OR_A_A_AND_A_A_LA); - while (true) { - s7_pointer result= fx_call (sc, fx_or1); - if (result != sc->F) return (result); - result= fx_call (sc, fx_or2); - if (result != sc->F) return (result); - 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) { - const s7_pointer fx_and= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_or = cdadr (fx_and); - const s7_pointer fx_la = cdadr (fx_or); - const s7_pointer fx_l2a = cdr (fx_la); - const 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) { - const s7_pointer fx_or= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_and = cdadr (fx_or); - const s7_pointer fx_la = cdadr (fx_and); - const s7_pointer fx_l2a = cdr (fx_la); - const s7_pointer l2a_slot= next_slot (la_slot); - tick_tc (sc, OP_TC_OR_A_AND_A_L2A); - while (true) { - s7_pointer result= fx_call (sc, fx_or); - if (result != sc->F) return (result); - 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) { - const s7_pointer fx_and= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_or = cdadr (fx_and); - const s7_pointer fx_la = cdadr (fx_or); - const s7_pointer fx_l2a = cdr (fx_la); - const s7_pointer fx_l3a = cdr (fx_l2a); - const s7_pointer l2a_slot= next_slot (la_slot); - const 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) { - const s7_pointer fx_or= cdr (code), la_slot= let_slots (sc->curlet); - const s7_pointer fx_and = cdadr (fx_or); - const s7_pointer fx_la = cdadr (fx_and); - const s7_pointer fx_l2a = cdr (fx_la); - const s7_pointer fx_l3a = cdr (fx_l2a); - const s7_pointer l2a_slot= next_slot (la_slot); - const s7_pointer l3a_slot= next_slot (l2a_slot); - tick_tc (sc, OP_TC_OR_A_AND_A_L3A); - while (true) { - s7_pointer result= fx_call (sc, fx_or); - if (result != sc->F) return (result); - 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) { - const 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); - const s7_pointer fx_la = cdadr (fx_and2); - const s7_pointer fx_l2a = cdr (fx_la); - const s7_pointer l2a_slot= next_slot (la_slot); - const s7_pointer fx_l3a = cdr (fx_l2a); - const 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 result= fx_call (sc, fx_or); - if (result != sc->F) return (result); - 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 result= fx_call (sc, fx_or); - if (result != sc->F) return (result); - 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); -} + for (s7_pointer arg = cdr(code); is_pair(arg); arg = cdr(arg)) + if (!is_bound_symbol(sc, car(arg))) + unbound_variable_error_nr(sc, car(arg)); -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 (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 (!q_call (o).fb (o)) { - sc->value= sc->F; - return (true); - } - if (q_call (o1).fb (o1) == z_first) { - endp= if2_z; - break; - } - set_integer (val, q_call (o2).fi (o2)); - } - else - while (true) { - if (q_call (o).fb (o)) { - endp= if1_true; - break; - } - if (q_call (o1).fb (o1) == z_first) { - endp= if2_z; - break; - } - set_integer (val, q_call (o2).fi (o2)); - } - return (op_tc_z (sc, endp)); - } - } - } - } - 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; - 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); - 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) { - const s7_pointer if1_test= cdr (code); - s7_pointer endp; - const s7_pointer la_slot = let_slots (sc->curlet); - const s7_pointer if1_true = cdr (if1_test); - const s7_pointer if1_false= cadr (if1_true); - const s7_pointer if2_test = cdr (if1_false); - const s7_pointer if2_true = cdr (if2_test); - const s7_pointer if2_false= cdr (if2_true); - const s7_pointer la1 = cdar (if2_true); - const s7_pointer la2 = cdar (if2_false); - const s7_pointer l2a1 = cdr (la1); - const s7_pointer l2a2 = cdr (la2); - const s7_pointer l2a_slot = next_slot (la_slot); - const s7_pointer l3a1 = cdr (l2a1); - const s7_pointer l3a2 = cdr (l2a2); - const 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 */ -{ - const s7_pointer if1_test= cdr (code); - s7_pointer endp; - const s7_pointer la_slot = let_slots (sc->curlet); - const s7_pointer l2a_slot = next_slot (la_slot); - const s7_pointer l3a_slot = next_slot (l2a_slot); - const s7_pointer if1_true = cdr (if1_test); - const s7_pointer if1_false= cadr (if1_true); - const s7_pointer if2_test = cdr (if1_false); - const s7_pointer if2_true = cdr (if2_test); - const s7_pointer if2_false= cdr (if2_true); - const s7_pointer zendp = (zfirst) ? if2_true : if2_false; - const s7_pointer la2 = (zfirst) ? cdar (if2_false) : cdar (if2_true); - const s7_pointer l2a2 = cdr (la2); - const 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; + 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; - } - if ((fx_call (sc, if2_test) != sc->F) == zfirst) { - endp= zendp; + + 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; } - 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) { - const s7_pointer body = caddr (code); - const s7_pointer outer_let= sc->curlet; - const s7_pointer la_slot = let_slots (outer_let); - const s7_pointer if_test = cdr (body); - const s7_pointer if_true = cddr (body); - const bool wrappable= has_fx (if_true); - const s7_pointer if_false = cadddr (body); - const s7_pointer la = cdr (if_false); - s7_pointer let_var = caadr (code); - const 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))); - const 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) { - const s7_pointer body = caddr (code); - const s7_pointer outer_let= sc->curlet; - const s7_pointer la_slot = let_slots (outer_let); - const s7_pointer l2a_slot = next_slot (la_slot); - const s7_pointer if_test = cdr (body); - const s7_pointer if_true = cddr (body); - const bool wrappable= has_fx (if_true); - const s7_pointer if_false = cadddr (body); - const s7_pointer la = cdr (if_false); - const 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))); - const 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 (!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 (!(q_call (o).fb (o))) { - s7_int i1= q_call (o1).fi (o1); - set_integer (val2, q_call (o2).fi (o2)); - set_integer (val1, i1); - set_integer (val3, q_call (o3).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); - } - 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 endp, slot; - const s7_pointer if1_test= cdr (code), outer_let= sc->curlet, - la_slot = let_slots (sc->curlet); - const s7_pointer if1_true = cdr (if1_test); /* cddr(code) */ - const s7_pointer let_expr = cadr (if1_true); /* cadddr(code) */ - const s7_pointer let_vars = cadr (let_expr); - const s7_pointer if2 = caddr (let_expr); - const s7_pointer if2_test = cdr (if2); - const s7_pointer if2_true = cdr (if2_test); /* cddr(if2) */ - const s7_pointer la = cdadr (if2_true); /* cdr(cadddr(if2)) */ - const s7_pointer l2a = cdr (la); - const s7_pointer l2a_slot = next_slot (la_slot); - const 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; + return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); +} + +static bool op_unknown_aa(s7_scheme *sc) /* we assume in eval that this always returns true */ +{ + 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))) && (curlet_has_slots(sc))) 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; } - 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 ((is_symbol(head)) && + (!is_bound_symbol(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_bound_symbol(sc, sym)) unbound_variable_error_nr(sc, sym); + return(true); +} + +static bool op_unknown_na(s7_scheme *sc) /* we assume in eval that this always returns true */ +{ + 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 (fx_call (sc, if2_test) != sc->F) { - endp= if2_true; + 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))) && (curlet_has_slots(sc))) 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; - } - 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) { - 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); - { - bool 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; is_not_slot_end (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); + 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))) && (curlet_has_slots(sc))) 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; } - 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)); + /* 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) /* we assume in eval that this always returns true */ +{ + 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))); } - slot_set_value (la_slot, sc->rec_p1); - } - return (op_tc_z (sc, c1)); + return(unknown_unknown(sc, sc->code, OP_CLEAR_OPTS)); } -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 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)); } -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; is_not_slot_end (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); +/* ---------------- eval type checkers ---------------- */ -TC_COND_N_DONE: - if (has_fx (result)) { - sc->value= fx_call (sc, result); - return (true); - } - sc->code= car (result); - return (false); +#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 s7_pointer -fx_tc_cond_n (s7_scheme* sc, s7_pointer arg) { - op_tc_cond_n (sc, arg); - return (sc->value); +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) */ } -/* -------- rec -------- */ +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) */ +} -#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 +/* 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 void -recur_resize (s7_scheme* sc) { - const s7_pointer stack= sc->rec_stack; - block_t * old_b, *new_b; - 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; - old_b = vector_block (stack); - new_b= reallocate (sc, old_b, vector_length (stack) * sizeof (s7_pointer)); - block_info (new_b) = NULL; - vector_block (stack) = new_b; - vector_elements (stack)= (s7_pointer*) block_data ( - new_b); /* 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 */ 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 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 /* 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 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 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); } -static s7_pointer -recur_pop2 (s7_scheme* sc) { - sc->rec_loc-= 2; - return (sc->rec_els[sc->rec_loc + 1]); -} +/* 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 + */ -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); -} +#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 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 /* 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 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 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 void -rec_set_f8 (s7_scheme* sc, s7_pointer p) { - sc->rec_f8f= fx_proc (p); - sc->rec_f8p= car (p); + +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); } -typedef enum { opt_ptr, opt_int, opt_dbl, opt_int_0 } opt_pid_t; +/* closure_is_fine: */ +#define FINE_UNSAFE_CLOSURE (T_CLOSURE) +#define FINE_SAFE_CLOSURE (T_CLOSURE | T_SAFE_CLOSURE) -/* -------- if_a_a_opla_laq and if_a_opla_laq_a -------- */ +/* closure_star_is_fine: */ +#define FINE_UNSAFE_CLOSURE_STAR (T_CLOSURE_STAR) +#define FINE_SAFE_CLOSURE_STAR (T_CLOSURE_STAR | T_SAFE_CLOSURE) -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); - - 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= q_call (sc->rec_test_o).fb; - sc->rec_fi1= q_call (sc->rec_result_o).fi; - sc->rec_fi2= q_call (sc->rec_a1_o).fi; - sc->rec_fi3= q_call (sc->rec_a2_o).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); - } - } - } - } - } - } - } - } - 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 (q_call (sc->rec_test_o).fb (sc->rec_test_o)) /* if_(A) */ - return (q_call (sc->rec_result_o).fi (sc->rec_result_o)); /* if_a_(A) */ - i1= q_call (sc->rec_a1_o).fi (sc->rec_a1_o); /* save a1 */ - set_integer (sc->rec_val1, - q_call (sc->rec_a2_o).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)); +/* 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))); } -static s7_double -oprec_d_if_a_a_opla_laq (s7_scheme* sc) { - s7_double x1, x2; - if (q_call (sc->rec_test_o).fb (sc->rec_test_o)) - return (q_call (sc->rec_result_o).fd (sc->rec_result_o)); - x1= q_call (sc->rec_a1_o).fd (sc->rec_a1_o); - set_real (sc->rec_val1, q_call (sc->rec_a2_o).fd (sc->rec_a2_o)); - if (q_call (sc->rec_test_o).fb (sc->rec_test_o)) - x2= q_call (sc->rec_result_o).fd (sc->rec_result_o); - else { - s7_double x3; - x2= q_call (sc->rec_a1_o).fd (sc->rec_a1_o); - set_real (sc->rec_val1, q_call (sc->rec_a2_o).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)); -} +/* ---------------- 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 %s %s\n", + __LINE__, bold_text, op_names[first_op], unbold_text, display_truncated(sc->code), display_truncated(sc->args))); + sc->cur_op = first_op; + goto TOP_NO_POP; -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)); -} + while (true) /* "continue" in this procedure refers to this loop */ + { + pop_stack(sc); + goto TOP_NO_POP; -static s7_int -oprec_i_if_a_opla_laq_a (s7_scheme* sc) { - s7_int i1, i2; - if (!(q_call (sc->rec_test_o).fb (sc->rec_test_o))) - return (q_call (sc->rec_result_o).fi (sc->rec_result_o)); - i1= q_call (sc->rec_a1_o).fi (sc->rec_a1_o); - set_integer (sc->rec_val1, q_call (sc->rec_a2_o).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)); -} + 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%s%s (%d), code: %s\n", + bold_text, op_names[sc->cur_op], unbold_text, (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 */ -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)); -} + 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; -static s7_double -oprec_d_if_a_opla_laq_a (s7_scheme* sc) { - s7_double x1, x2; - if (!(q_call (sc->rec_test_o).fb (sc->rec_test_o))) - return (q_call (sc->rec_result_o).fd (sc->rec_result_o)); - x1= q_call (sc->rec_a1_o).fd (sc->rec_a1_o); - set_real (sc->rec_val1, q_call (sc->rec_a2_o).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))); -} + 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; -/* -------- if_a_a_opl2a_l2aq -------- */ + 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; -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)); -} + 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; -/* -------- if_a_a_opl3a_l3aq -------- */ + 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; -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)); -} + 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; -/* -------- 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)); -} + case OP_SAFE_C_FF: if (!c_function_is_ok(sc, sc->code)) {op_unknown_np(sc); goto EVAL;} + case HOP_SAFE_C_FF: sc->value = fx_c_ff(sc, sc->code); continue; -/* -------- 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)); -} + 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; -/* -------- 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)); -} + case OP_ANY_C_NP: if (!c_function_is_ok(sc, sc->code)) {op_unknown_np(sc); goto EVAL;} + 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; -/* -------- 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); - 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); - } - } - } - } - } - } - } - /* 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 (q_call (sc->rec_test_o).fb (sc->rec_test_o)) - return (q_call (sc->rec_result_o).fi (sc->rec_result_o)); - i1= q_call (sc->rec_a1_o).fi (sc->rec_a1_o); - set_integer (sc->rec_val1, q_call (sc->rec_a2_o).fi (sc->rec_a2_o)); - return (sc->rec_i_ii_f (i1, oprec_i_if_a_a_opa_laq (sc))); -} + 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; -static s7_int -oprec_i_if_a_opa_laq_a (s7_scheme* sc) { - s7_int i1; - if (!q_call (sc->rec_test_o).fb (sc->rec_test_o)) - return (q_call (sc->rec_result_o).fi (sc->rec_result_o)); - i1= q_call (sc->rec_a1_o).fi (sc->rec_a1_o); - set_integer (sc->rec_val1, q_call (sc->rec_a2_o).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)); -} + 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; -/* -------- 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; - } -} + 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; -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)); -} + 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; -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)); -} + 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; -/* -------- 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; - } -} + 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; -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)); -} + 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; -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)); -} + 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; -/* -------- 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)); -} + case OP_SAFE_C_AA: if (!c_function_is_ok(sc, sc->code)) {op_unknown_aa(sc); goto EVAL;} /* op_unknown_aa always returns true */ + case HOP_SAFE_C_AA: sc->value = fx_c_aa(sc, sc->code); continue; -/* -------- 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)); -} + case OP_SAFE_C_SA: if (!c_function_is_ok(sc, sc->code)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_C_SA: sc->value = fx_c_sa(sc, sc->code); continue; -/* -------- 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)); -} + case OP_SAFE_C_AS: if (!c_function_is_ok(sc, sc->code)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_C_AS: sc->value = fx_c_as(sc, sc->code); continue; -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)); -} + case OP_SAFE_C_CA: if (!c_function_is_ok(sc, sc->code)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_C_CA: sc->value = fx_c_ca(sc, sc->code); continue; -/* -------- 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)); -} + case OP_SAFE_C_AC: if (!c_function_is_ok(sc, sc->code)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_C_AC: sc->value = fx_c_ac(sc, sc->code); continue; -/* -------- 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)); -} + 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; -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)); -} + 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; -/* -------- cond_a_a_a_l2a_lopa_l2aq -------- */ + 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 */ -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 ((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= q_call (sc->rec_test_o).fb; - sc->rec_fb2= q_call (sc->rec_a1_o).fb; - sc->rec_fi1= q_call (sc->rec_result_o).fi; - sc->rec_fi2= q_call (sc->rec_a2_o).fi; - sc->rec_fi3= q_call (sc->rec_a3_o).fi; - sc->rec_fi4= q_call (sc->rec_a4_o).fi; - sc->rec_fi5= q_call (sc->rec_a5_o).fi; - sc->rec_fi6= q_call (sc->rec_a6_o).fi; - return (opt_int_0); - } - } - } - } - } - } - } - } - } - 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); -} + 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; -static s7_int -oprec_i_cond_a_a_a_l2a_lopa_l2aq (s7_scheme* sc) { - s7_int i1, i2; - if (q_call (sc->rec_test_o).fb (sc->rec_test_o)) - return (q_call (sc->rec_result_o).fi (sc->rec_result_o)); - if (q_call (sc->rec_a1_o).fb (sc->rec_a1_o)) { - i1= q_call (sc->rec_a2_o).fi (sc->rec_a2_o); - set_integer (sc->rec_val2, q_call (sc->rec_a3_o).fi (sc->rec_a3_o)); - set_integer (sc->rec_val1, i1); - return (oprec_i_cond_a_a_a_l2a_lopa_l2aq (sc)); - } - i1= q_call (sc->rec_a4_o).fi (sc->rec_a4_o); - i2= q_call (sc->rec_a5_o).fi (sc->rec_a5_o); - set_integer (sc->rec_val2, q_call (sc->rec_a6_o).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)); -} + 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; -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)); -} + 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; -/* -------- 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 result; - if (sc->rec_testf (sc, sc->rec_testp) == sc->F) return (sc->F); - result= sc->rec_resf (sc, sc->rec_resp); - if (result != sc->F) return (result); - 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)); - result= oprec_and_a_or_a_l2a_l2a (sc); - if (result != sc->F) { - sc->rec_loc-= 2; - return (result); - } - 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)); -} + 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; -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)); -} + 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; -/* -------------------------------- */ -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, 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 (sc, (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); -} + 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; -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 (sc, 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 */ -} + 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; -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 (sc, 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 */ -} + 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; -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, 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); -} + 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; -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); -} + 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; -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); -} + 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; -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); -} + 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; -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); -} + 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; -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, sc->args, sc->value)); -} + 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; + + 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; + 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; -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); -} + 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; -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); -} + 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; -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); -} + 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; -static void -op_safe_c_pc_1 (s7_scheme* sc) { - sc->value= fn_proc (sc->code) (sc, with_list_t2 (sc, sc->value, sc->args)); -} + 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; -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); -} + 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; -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 (sc, 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) - */ + 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; -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 (sc, 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 (sc, 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 (sc, 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; - } -} + 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; -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; - } -} + 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; -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 (sc, 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); -} + 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; -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); -} + 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; -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); -} + /* 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; -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 args= cdr (sc->code); is_pair (args); args= cdr (args)) - if (has_fx (args)) - sc->args= cons (sc, sc->value= fx_call (sc, args), - 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 (args))) ? OP_ANY_C_NP_1 : OP_ANY_C_NP_2)), - sc->args, cdr (args)); - sc->code= T_Pair (car (args)); - 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 */ -} + 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 */ -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 args= 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 (args)) { - sc->args= fx_call (sc, args); - sc->args= list_1 (sc, sc->args); - for (args= cdr (args); (is_pair (args)) && (has_fx (args)); - args= cdr (args)) - sc->args= cons_unchecked (sc, fx_call (sc, args), sc->args); - } - else sc->args= sc->nil; - push_stack (sc, - ((intptr_t) ((is_pair (cdr (args))) ? OP_ANY_CLOSURE_NP_1 - : OP_ANY_CLOSURE_NP_2)), - sc->args, cdr (args)); - sc->code= T_Pair (car (args)); -} + 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; -static void -op_any_closure_np_end (s7_scheme* sc) { - s7_pointer args, func; - 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; - const s7_int 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; is_not_slot_end (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 (is_not_slot_end (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 let = inline_make_let (sc, closure_let (func)); - const s7_int id = let_id (let); - - begin_temp (sc->y, let); - last_slot= make_slot (sc, car (pars), car (sc->args)); - slot_set_next (last_slot, slot_end); - let_set_slots (let, 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, let); - end_temp (sc->y); -#if S7_DEBUGGING - if ((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)); -#endif - } - 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 void -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); -} - -static void -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); -} - -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)); - } -} + case OP_CL_AA: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_AA: op_cl_aa(sc); continue; -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 args= cdr (sc->code); - sc->args = fx_call (sc, cdr (args)); - 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 (args)); - if (needs_copied_args (sc->code)) sc->args= copy_proper_list (sc, sc->args); -} - -static void -op_apply_sl (s7_scheme* sc) { - s7_pointer args= cdr (sc->code); - sc->args = fx_call (sc, cdr (args)); - sc->code = lookup_global (sc, car (args)); -} - -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); -} + case OP_CL_SAS: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_SAS: op_cl_sas(sc); continue; -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_args1 (s7_scheme* sc) { - /* implicit_iterator and implicit_c_object, sc->code is ignored, so we can - * skip to apply in eval */ - sc->code= pop_op_stack (sc); - sc->args= cons (sc, sc->value, sc->args); - sc->args= proper_list_reverse_in_place (sc, sc->args); -} - -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)); - /* there's only one push of eval_args2; we could check sc->args==sc->nil there - * and push eval_args6, timp mv misc ? but we have to check somewhere */ -} - -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); -} + case OP_CL_NA: if (!cl_function_is_ok(sc, sc->code)) break; + case HOP_CL_NA: op_cl_na(sc); continue; -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); -} + 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 */ -static inline void -eval_last_arg (s7_scheme* sc, s7_pointer head) /* one call, eval 91557 */ -{ - /* here we've reached the last arg, 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); -} + /* 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; -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); -} + 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; -static bool -eval_car_pair (s7_scheme* sc) { - const s7_pointer code= sc->code, head= car (sc->code); + 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; - /* 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); + 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; - 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); -} + 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; -/* ---------------- 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); -} + case OP_C_SS: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_SS: op_c_ss(sc); continue; -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 |# - */ - 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)); - } - { - const char* orig_str= - (const char*) (port_data (port) + port_position (port)); - const char* pend= (const char*) (port_data (port) + port_data_size (port)); - const char* str = orig_str; - const char* p; - 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)); -} + case OP_C_SC: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_SC: op_c_sc(sc); continue; -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) - */ - /* 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) */ - { - int32_t c; - char last_char= ' '; - 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 chr= inchar (port); - if (chr == 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) chr; - if (chr == '(') { - 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; + 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; -#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 OP_C_AA: if (!c_function_is_ok(sc, sc->code)) break; + case HOP_C_AA: op_c_aa(sc); continue; - case '!': /* I don't think #! is special anymore -- maybe remove this code? - */ - return (read_excl_comment (sc, port)); + 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 '|': - return (read_block_comment (sc, port)); - } - sc->strbuf[0]= (unsigned char) c; - return (token_sharp_const); /* next stage notices any errors */ -} + 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; -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); -} + 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; -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); - } -} + 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; -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); -} + 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; -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; /* sc->strbuf index */ - 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 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 EOF: - sc->strbuf[(i > 8) ? 8 : i]= '\0'; - return (sc->F); + 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 '"': - return (make_string_with_length (sc, sc->strbuf, i)); + 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 '\\': - 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; + 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; - default: - sc->strbuf[i++]= (unsigned char) c; - break; - } - if (i >= sc->strbuf_size) resize_strbuf (sc, i); - } -} + 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; -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 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 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 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 token_complex_vector: - push_stack_no_let_no_code (sc, OP_READ_COMPLEX_VECTOR, sc->read_dims); - sc->tok= token_left_paren; - break; + 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 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 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 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 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 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 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 token_back_quote: - sc->tok= token (sc); - push_stack_no_let_no_code (sc, OP_READ_QUASIQUOTE, sc->nil); - break; + 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 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 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 token_at_mark: - push_stack_no_let_no_code (sc, OP_READ_APPLY_VALUES, sc->nil); - sc->tok= token (sc); - break; + 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 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 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 token_double_quote: - read_double_quote (sc); - return (sc->value); + 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 token_sharp_const: - return (port_read_sharp (current_input_port (sc)) ( - sc, current_input_port (sc))); + 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 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 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 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 */ - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - return (sc->nil); -} + 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; -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); -} + 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; -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 */ -} + case OP_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 1)) {op_unknown_np(sc); goto EVAL;} + case HOP_CLOSURE_P: op_closure_p(sc); goto EVAL; + case OP_CLOSURE_P_1: op_closure_p_1(sc); goto BEGIN; -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; - } -} + case OP_SAFE_CLOSURE_P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {op_unknown_np(sc); goto EVAL;} + 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; -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 */ -} + case OP_SAFE_CLOSURE_P_A: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 1)) {op_unknown_np(sc); goto EVAL;} + 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; -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)); - } - } -} + 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; -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); -} + 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; -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); -} + 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; -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); -} + 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; -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); -} + 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; -/* 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] - */ -} + case OP_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {op_unknown_np(sc); goto EVAL;} + case HOP_CLOSURE_AP: op_closure_ap(sc); goto EVAL; + case OP_CLOSURE_AP_1: op_closure_ap_1(sc); goto BEGIN; -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); -} + case OP_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {op_unknown_np(sc); goto EVAL;} + case HOP_CLOSURE_PA: op_closure_pa(sc); goto EVAL; + case OP_CLOSURE_PA_1: op_closure_pa_1(sc); goto BEGIN; -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); -} + case OP_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 2)) {op_unknown_np(sc); goto EVAL;} + case HOP_CLOSURE_PP: op_closure_pp(sc); goto EVAL; + case OP_CLOSURE_PP_1: op_closure_pp_1(sc); goto EVAL; -/* ---------------- 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); /* for easier break from switch */ -} - -static bool -unknown_unknown (s7_scheme* sc, s7_pointer code, opcode_t op) { - if ((is_symbol (car (code))) && (!is_bound_symbol (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 let= sc->curlet; let; let= let_outlet (let)) - if ((is_funclet (let)) && (funclet_function (let) != 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_bound_symbol (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); -} + case OP_SAFE_CLOSURE_AP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {op_unknown_np(sc); goto EVAL;} + 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; -static bool -op_unknown_s (s7_scheme* sc) { - const s7_pointer code= sc->code, func= sc->last_function; + case OP_SAFE_CLOSURE_PA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {op_unknown_np(sc); goto EVAL;} + 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; - 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_bound_symbol (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)); -} + case OP_SAFE_CLOSURE_PP: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 2)) {op_unknown_np(sc); goto EVAL;} + 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; -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 (sc, 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 */ - } + case OP_ANY_CLOSURE_3P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {op_unknown_np(sc); goto EVAL;} + 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; - default: - break; - } - if ((is_symbol (car (code))) && (!is_bound_symbol (sc, car (code)))) - unbound_variable_error_nr (sc, car (code)); - return ( - fixup_unknown_op (sc, code, func, OP_S_A)); /* closure with methods etc */ -} + case OP_ANY_CLOSURE_4P: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 4)) {op_unknown_np(sc); goto EVAL;} + 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; -static bool -op_unknown_gg ( - s7_scheme* sc) /* we assume in eval that this always returns true */ -{ - 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_bound_symbol (sc, cadr (code)))) - return (unknown_unknown (sc, sc->code, OP_CLEAR_OPTS)); - s2= is_normal_symbol (caddr (code)); - if ((s2) && (!is_bound_symbol (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)); -} + 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; -static bool -op_unknown_ns ( - s7_scheme* sc) /* we assume in eval that this always returns true */ -{ - const s7_pointer code= sc->code, func= sc->last_function; - const int32_t num_args= opt3_arglen (cdr (code)); + case OP_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {op_unknown_gg(sc); goto EVAL;} /* op_unknown_gg always returns true */ + case HOP_CLOSURE_SS: op_closure_ss(sc); goto EVAL; - 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_bound_symbol (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)); -} + case OP_CLOSURE_SS_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_CLOSURE_SS_O: op_closure_ss_o(sc); goto EVAL; -static bool -op_unknown_aa ( - s7_scheme* sc) /* we assume in eval that this always returns true */ -{ - const s7_pointer code= sc->code, func= sc->last_function, - head= car (sc->code); + case OP_SAFE_CLOSURE_SS: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_SS: op_safe_closure_ss(sc); goto EVAL; - 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))) && (curlet_has_slots (sc))) - 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_bound_symbol (sc, head))) - unbound_variable_error_nr (sc, head); - return (fixup_unknown_op (sc, code, func, OP_S_AA)); -} + case OP_SAFE_CLOSURE_SS_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_SS_O: op_safe_closure_ss_o(sc); goto EVAL; -static bool -is_normal_happy_symbol (s7_scheme* sc, s7_pointer sym) { - if (!is_normal_symbol (sym)) return (false); - if (!is_bound_symbol (sc, sym)) unbound_variable_error_nr (sc, sym); - return (true); -} + case OP_SAFE_CLOSURE_SS_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_SS_A: sc->value = op_safe_closure_ss_a(sc, sc->code); continue; -static bool -op_unknown_na ( - s7_scheme* sc) /* we assume in eval that this always returns true */ -{ - const s7_pointer code= sc->code, func= sc->last_function; - const int32_t num_args= (is_pair (cdr (code))) ? opt3_arglen (cdr (code)) : 0; + case OP_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_ns(sc); goto EVAL;} + case HOP_CLOSURE_3S: op_closure_3s(sc); goto EVAL; /* "fine" here means changing func (as arg) does not constantly call op_unknown_ns */ - 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))) && (curlet_has_slots (sc))) - 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))) && (curlet_has_slots (sc))) - 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)); -} + case OP_CLOSURE_3S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 3)) {op_unknown_ns(sc); goto EVAL;} + case HOP_CLOSURE_3S_O: op_closure_3s_o(sc); goto EVAL; -static bool -op_unknown_np ( - s7_scheme* sc) /* we assume in eval that this always returns true */ -{ - 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; + case OP_CLOSURE_4S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {op_unknown_ns(sc); goto EVAL;} + case HOP_CLOSURE_4S: op_closure_4s(sc); goto EVAL; - 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)); -} + case OP_CLOSURE_4S_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 4)) {op_unknown_ns(sc); goto EVAL;} + case HOP_CLOSURE_4S_O: op_closure_4s_o(sc); goto EVAL; -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)); -} + case OP_CLOSURE_5S: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 5)) {op_unknown_ns(sc); goto EVAL;} + case HOP_CLOSURE_5S: op_closure_5s(sc); goto EVAL; -/* ---------------- eval type checkers ---------------- */ + case OP_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_CLOSURE_SC: op_closure_sc(sc); goto EVAL; -#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 + case OP_CLOSURE_SC_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_CLOSURE_SC_O: op_closure_sc_o(sc); goto EVAL; -#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)))) + case OP_SAFE_CLOSURE_SC: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_SC: op_safe_closure_sc(sc); goto EVAL; -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)))); -} + case OP_SAFE_CLOSURE_SC_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {op_unknown_gg(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_SC_O: op_safe_closure_sc_o(sc); goto EVAL; -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) */ -} + case OP_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_M, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_CLOSURE_AA: op_closure_aa(sc); goto EVAL; -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) */ -} + case OP_CLOSURE_AA_O: if (!closure_is_ok(sc, sc->code, OK_UNSAFE_CLOSURE_P, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_CLOSURE_AA_O: inline_op_closure_aa_o(sc); goto EVAL; -/* 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 - */ + case OP_SAFE_CLOSURE_AA: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_M, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_AA: op_safe_closure_aa(sc); goto EVAL; -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); -} + case OP_SAFE_CLOSURE_AA_O: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_P, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_AA_O: op_safe_closure_aa_o(sc); goto EVAL; -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); -} + case OP_SAFE_CLOSURE_AA_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_AA_A: sc->value = fx_safe_closure_aa_a(sc, sc->code); continue; -/* 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 - */ + case OP_SAFE_CLOSURE_SSA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} /* op_unknown_na always return true */ + case HOP_SAFE_CLOSURE_SSA: op_safe_closure_ssa(sc); goto EVAL; -#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); -} + case OP_SAFE_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_SAA: op_safe_closure_saa(sc); goto EVAL; -/* closure_is_fine: */ -#define FINE_UNSAFE_CLOSURE (T_CLOSURE) -#define FINE_SAFE_CLOSURE (T_CLOSURE | T_SAFE_CLOSURE) + case OP_SAFE_CLOSURE_AGG: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_AGG: op_safe_closure_agg(sc); goto EVAL; -/* closure_star_is_fine: */ -#define FINE_UNSAFE_CLOSURE_STAR (T_CLOSURE_STAR) -#define FINE_SAFE_CLOSURE_STAR (T_CLOSURE_STAR | T_SAFE_CLOSURE) + case OP_SAFE_CLOSURE_3A: if (!closure_is_ok(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_3A: op_safe_closure_3a(sc); goto EVAL; -/* 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))); -} + case OP_SAFE_CLOSURE_NS: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {op_unknown_ns(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_NS: op_safe_closure_ns(sc); goto EVAL; -/* ---------------- 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 %s %s\n", __LINE__, - bold_text, op_names[first_op], unbold_text, - display_truncated (sc->code), - display_truncated (sc->args))); - sc->cur_op= first_op; - goto TOP_NO_POP; + case OP_SAFE_CLOSURE_NA: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {op_unknown_na(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_NA: op_safe_closure_na(sc); goto EVAL; - 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%s%s (%d), code: %s\n", bold_text, - op_names[sc->cur_op], unbold_text, - (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_CLOSURE_3S: if (!closure_is_fine(sc, sc->code, FINE_SAFE_CLOSURE, 3)) {op_unknown_ns(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_3S: op_safe_closure_3s(sc); goto EVAL; - 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_CLOSURE_3S_A: if (!closure_is_ok(sc, sc->code, OK_SAFE_CLOSURE_A, 3)) {op_unknown_ns(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_3S_A: sc->value = op_safe_closure_3s_a(sc, sc->code); continue; - case OP_SAFE_C_NS: - if (!c_function_is_ok (sc, sc->code)) break; - case HOP_SAFE_C_NS: - sc->value= fx_c_ns (sc, sc->code); - continue; + case OP_CLOSURE_NS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {op_unknown_ns(sc); goto EVAL;} + case HOP_CLOSURE_NS: op_closure_ns(sc); goto EVAL; - 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_CLOSURE_ASS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_ASS: op_closure_ass(sc); goto EVAL; - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } /* op_unknown_aa always returns true */ - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - case HOP_SAFE_C_SA: - sc->value= fx_c_sa (sc, sc->code); - continue; + case OP_CLOSURE_AAS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_AAS: op_closure_aas(sc); goto EVAL; - case OP_SAFE_C_AS: - if (!c_function_is_ok (sc, sc->code)) { - op_unknown_aa (sc); - goto EVAL; - } - case HOP_SAFE_C_AS: - sc->value= fx_c_as (sc, sc->code); - continue; + case OP_CLOSURE_SAA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_SAA: op_closure_saa(sc); goto EVAL; - case OP_SAFE_C_CA: - if (!c_function_is_ok (sc, sc->code)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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_CLOSURE_ASA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_ASA: op_closure_asa(sc); goto EVAL; - 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_CLOSURE_SAS: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_SAS: op_closure_sas(sc); goto EVAL; - 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_CLOSURE_3A: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_3A: op_closure_3a(sc); goto EVAL; - 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_CLOSURE_4A: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, 4)) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_4A: op_closure_4a(sc); goto EVAL; - 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; - - 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; - 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_CLOSURE_NA: if (!closure_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE, opt3_arglen(cdr(sc->code)))) {op_unknown_na(sc); goto EVAL;} + case HOP_CLOSURE_NA: op_closure_na(sc); goto EVAL; - 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_ANY_CLOSURE_NP: if (!closure_np_is_ok(sc, sc->code)) {op_unknown_np(sc); goto EVAL;} + 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_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_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_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_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_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_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_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_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_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_CLOSURE_STAR_AA: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_STAR_AA: op_safe_closure_star_aa(sc, sc->code); goto BEGIN; - 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_CLOSURE_STAR_AA_O: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {op_unknown_aa(sc); goto EVAL;} + 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_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_CLOSURE_STAR_3A: if (!closure_star_is_fine(sc, sc->code, FINE_UNSAFE_CLOSURE_STAR, 3)) {op_unknown_na(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_STAR_3A: if (op_safe_closure_star_3a(sc, sc->code)) goto EVAL; goto BEGIN; - 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_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)) + {op_unknown_na(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_STAR_NA: if (op_safe_closure_star_na(sc, sc->code)) goto EVAL; goto BEGIN; - 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_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_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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } /* op_unknown_gg always returns true */ - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_ns (sc); - goto EVAL; - } - 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)) { - op_unknown_ns (sc); - goto EVAL; - } - 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)) { - op_unknown_ns (sc); - goto EVAL; - } - 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)) { - op_unknown_ns (sc); - goto EVAL; - } - 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)) { - op_unknown_ns (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_gg (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } /* op_unknown_na always return true */ - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)))) { - op_unknown_ns (sc); - goto EVAL; - } - 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)))) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_ns (sc); - goto EVAL; - } - 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)) { - op_unknown_ns (sc); - goto EVAL; - } - 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)))) { - op_unknown_ns (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)))) { - op_unknown_na (sc); - goto EVAL; - } - case HOP_CLOSURE_NA: - op_closure_na (sc); - goto EVAL; - - case OP_ANY_CLOSURE_NP: - if (!closure_np_is_ok (sc, sc->code)) { - op_unknown_np (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_aa (sc); - goto EVAL; - } - 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)) { - op_unknown_na (sc); - goto EVAL; - } - 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)) { - 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)) { - 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)); - op_unknown_ns (sc); - goto EVAL; - 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)); - op_unknown_gg (sc); - goto EVAL; - 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)); - op_unknown_aa (sc); - goto EVAL; - case OP_UNKNOWN_NA: - sc->last_function= lookup_checked (sc, car (sc->code)); - op_unknown_na (sc); - goto EVAL; - case OP_UNKNOWN_NP: - sc->last_function= lookup_checked (sc, car (sc->code)); - op_unknown_np (sc); - goto EVAL; - - 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_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_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_SAFE_CLOSURE_STAR_NA_2: if (!closure_star_is_fine(sc, sc->code, FINE_SAFE_CLOSURE_STAR, 2)) {op_unknown_aa(sc); goto EVAL;} + case HOP_SAFE_CLOSURE_STAR_NA_2: if (op_safe_closure_star_na_2(sc, sc->code)) goto EVAL; goto BEGIN; - case OP_EVAL_ARGS1: - op_eval_args1 (sc); - goto APPLY; - 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]: %sop_apply%s %s (%s) to %s\n", __func__, - __LINE__, bold_text, unbold_text, 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_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)) {op_unknown_aa(sc); goto EVAL;} + 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)) + {op_unknown_na(sc); goto EVAL;} + 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)) {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)) {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)); op_unknown_ns(sc); goto EVAL; + 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)); op_unknown_gg(sc); goto EVAL; + 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)); op_unknown_aa(sc); goto EVAL; + case OP_UNKNOWN_NA: sc->last_function = lookup_checked(sc, car(sc->code)); op_unknown_na(sc); goto EVAL; + case OP_UNKNOWN_NP: sc->last_function = lookup_checked(sc, car(sc->code)); op_unknown_np(sc); goto EVAL; + + + 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: op_eval_args1(sc); goto APPLY; + 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]: %sop_apply%s %s (%s) to %s\n", __func__, __LINE__, + bold_text, unbold_text, 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 */ - 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; - } + 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; - HEAPSORT: - if (op_heapsort (sc)) continue; - if (sc->value != sc->F) goto APPLY; - case OP_SORT1: - op_sort1 (sc); - goto APPLY; - case OP_SORT2: - if (op_sort2 (sc)) continue; - goto HEAPSORT; - case OP_SORT: - if (!op_sort (sc)) goto HEAPSORT; - case OP_SORT3: - if (op_sort3 (sc)) continue; - goto HEAPSORT; - case OP_SORT_PAIR_END: - sc->value= vector_into_list (sc, sc->value, car (sc->args)); - continue; - case OP_SORT_VECTOR_END: - sc->value= vector_into_fi_vector (sc->value, car (sc->args)); - continue; - case OP_SORT_STRING_END: - sc->value= vector_into_string (sc->value, car (sc->args)); - continue; + case OP_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; + 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_MAP_GATHER: inline_op_map_gather(sc); + case OP_MAP: if (op_map(sc)) continue; goto APPLY; - 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_MAP_GATHER_1: inline_op_map_gather(sc); + case OP_MAP_1: if (op_map_1(sc)) continue; 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_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_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; - } + 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; - 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_FOR_EACH_2: + case OP_FOR_EACH_3: if (inline_op_for_each_2(sc)) continue; goto EVAL; - case OP_DO: - if (is_null (check_do (sc))) switch (optimize_op (sc->code)) { - case OP_DOX: - goto DOX; - case OP_SAFE_DOTIMES: - goto SAFE_DOTIMES; - case OP_DOTIMES_P: - goto DOTIMES_P; - case OP_SAFE_DO: - goto SAFE_DO; - case OP_DO_NO_BODY_NA_VARS: - goto DO_NO_BODY; - case OP_DO_NO_VARS: - if (op_do_no_vars (sc)) goto DO_END_CLAUSES; - goto BEGIN; - case OP_DOX_NO_BODY: - op_dox_no_body (sc); - continue; - case OP_DOX_PENDING_NO_BODY: - op_dox_pending_no_body (sc); - goto DO_END_CLAUSES; - default: - if (op_simple_do (sc)) goto DO_END_CLAUSES; - goto BEGIN; - } + case OP_MEMBER_IF: + case OP_MEMBER_IF1: if (op_member_if(sc)) continue; goto APPLY; - 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_ASSOC_IF: + case OP_ASSOC_IF1: if (op_assoc_if(sc)) continue; goto APPLY; - 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_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_BEGIN_UNCHECKED: - set_current_code (sc, sc->code); - sc->code= T_Pair (cdr (sc->code)); - 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_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_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_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_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_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_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; - 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; + 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_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: - check_stack_size (sc); - 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_BEGIN_UNCHECKED: + set_current_code(sc, sc->code); + sc->code = T_Pair(cdr(sc->code)); + goto BEGIN; - 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_BEGIN: + if (op_begin(sc, sc->code)) continue; + sc->code = T_Pair(cdr(sc->code)); - 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_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_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_BEGIN_2_UNCHECKED: + push_stack_no_args(sc, OP_EVAL, caddr(sc->code)); + sc->code = cadr(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_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_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; - 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; - case OP_CASE_A_G_S: - sc->value= fx_call (sc, cdr (sc->code)); /* this almost never happens? */ - case OP_CASE_G_S: - op_case_g_s (sc); - goto EVAL; - - case OP_CASE_A_E_G: - sc->value= fx_call (sc, cdr (sc->code)); - case OP_CASE_E_G: - if (op_case_e_g_1 (sc, sc->value, is_simple (sc->value))) goto TOP_NO_POP; - goto FEED_TO; - case OP_CASE_A_S_G: /* splitting this case out matters in lint */ - sc->value= fx_call (sc, cdr (sc->code)); - if (op_case_e_g_1 (sc, sc->value, is_case_key (sc->value))) - goto TOP_NO_POP; - else goto FEED_TO; - - case OP_CASE_P_G_G: - push_stack_no_args_direct (sc, OP_CASE_G_G); - sc->code= cadr (sc->code); - goto EVAL; - case OP_CASE_P_E_S: - push_stack_no_args_direct (sc, OP_CASE_E_S); - sc->code= cadr (sc->code); - goto EVAL; - case OP_CASE_P_G_S: - push_stack_no_args_direct (sc, OP_CASE_G_S); - sc->code= cadr (sc->code); - goto EVAL; - case OP_CASE_P_E_G: - push_stack_no_args_direct (sc, OP_CASE_E_G); - sc->code= cadr (sc->code); - goto EVAL; - case OP_CASE_A_I_S_A: - sc->value= fx_case_a_i_s_a (sc, sc->code); - continue; - 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_EVAL: goto EVAL; + case OP_EVAL_STRING: op_eval_string(sc); goto EVAL; - 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_QUOTE: sc->value = check_quote(sc, sc->code); continue; + case OP_QUOTE_UNCHECKED: sc->value = cadr(sc->code); continue; - 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); + case OP_DEFINE_FUNCHECKED: define_funchecked(sc); continue; + case OP_DEFINE_CONSTANT1: op_define_constant1(sc); continue; - default: - sc->strbuf[0]= (unsigned char) c; - sc->value = port_read_name (port) (sc, port); - goto READ_LIST; - } - } + case OP_DEFINE_CONSTANT_UNCHECKED: + push_stack_no_args(sc, OP_DEFINE_CONSTANT1, cadr(sc->code)); + goto DEFCONS; - 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: - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, - __LINE__); - 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, " %d: unopt trailers %s\n", __LINE__, - 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 */ + case OP_DEFINE_CONSTANT: + if (op_define_constant(sc)) continue; - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - 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); + 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: check_stack_size(sc); 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; + 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; + case OP_CASE_A_G_S: sc->value = fx_call(sc, cdr(sc->code)); /* this almost never happens? */ + case OP_CASE_G_S: op_case_g_s(sc); goto EVAL; + + case OP_CASE_A_E_G: sc->value = fx_call(sc, cdr(sc->code)); + case OP_CASE_E_G: if (op_case_e_g_1(sc, sc->value, is_simple(sc->value))) goto TOP_NO_POP; goto FEED_TO; + case OP_CASE_A_S_G: /* splitting this case out matters in lint */ + sc->value = fx_call(sc, cdr(sc->code)); + if (op_case_e_g_1(sc, sc->value, is_case_key(sc->value))) goto TOP_NO_POP; else goto FEED_TO; + + case OP_CASE_P_G_G: push_stack_no_args_direct(sc, OP_CASE_G_G); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_E_S: push_stack_no_args_direct(sc, OP_CASE_E_S); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_G_S: push_stack_no_args_direct(sc, OP_CASE_G_S); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_P_E_G: push_stack_no_args_direct(sc, OP_CASE_E_G); sc->code = cadr(sc->code); goto EVAL; + case OP_CASE_A_I_S_A: sc->value = fx_case_a_i_s_a(sc, sc->code); continue; + 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: + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + 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, " %d: unopt trailers %s\n", __LINE__, 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 */ + + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + 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); +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 - * -------------------------------- */ + +/* -------------------------------- s7_heap_scan -------------------------------- */ #if S7_DEBUGGING -static void -mark_holdee (s7_pointer holder, s7_pointer holdee, const char* root) { +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"); - } - } + if (holder) holdee->holder = holder; + if (root) holdee->root = root; } -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 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 -save_holder_data (s7_scheme* sc, s7_pointer p) { - switch (type_unchecked (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++) /* this apparently can be a stack as a vector? */ - if (s7_is_in_heap (sc, 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); is_not_slot_end (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 */ - } +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 (type_unchecked(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++) /* this apparently can be a stack as a vector? */ + if (s7_is_in_heap(sc, 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); is_not_slot_end(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) { +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; - } + 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]); + 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"); + 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"); + 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 (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_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->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->setters_loc; i++) + mark_holdee(NULL, cdr(sc->setters[i]), "setter"); - for (s7_int i= 0; i <= sc->format_depth; i++) + 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"); + 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 *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"); - } + 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"); + 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; is_not_slot_end (slot); - slot = next_slot (slot)) - mark_holdee (slot, slot_value (slot), symbol_name (slot_symbol (slot))); + 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; is_not_slot_end(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; - } + 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"); + 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 (type_unchecked (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[type_unchecked (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); +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 (type_unchecked(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[type_unchecked(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); } /* g_heap_analyze migrated to s7_scheme_predicate.c */ #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) +#define Q_heap_analyze s7_make_signature(sc, 1, sc->not_symbol) /* bridge for g_heap_analyze migration */ -void -s7i_heap_analyze (s7_scheme* sc) { - s7_heap_analyze (sc); +void s7i_heap_analyze(s7_scheme *sc) +{ + s7_heap_analyze(sc); } /* g_heap_holder migrated to s7_scheme_predicate.c */ #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) +#define Q_heap_holder s7_make_signature(sc, 2, sc->T, sc->T) /* bridge for g_heap_holder migration */ -s7_pointer -s7i_heap_holder_p_p (s7_scheme* sc, s7_pointer obj) { - if ((obj->holders == 0) || ((!(obj->holder)) && (!(obj->root)))) - return (sc->F); - return ((obj->holder) ? obj->holder : s7_make_string (sc, obj->root)); +s7_pointer s7i_heap_holder_p_p(s7_scheme *sc, s7_pointer obj) +{ + if ((obj->holders == 0) || ((!(obj->holder)) && (!(obj->root)))) return(sc->F); + return((obj->holder) ? obj->holder : s7_make_string(sc, obj->root)); } /* g_heap_holders migrated to s7_scheme_predicate.c */ -#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) +#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) /* bridge for g_heap_holders migration */ -s7_int -s7i_heap_holders (s7_pointer obj) { - return (obj->holders); +s7_int s7i_heap_holders(s7_pointer obj) +{ + return(obj->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); +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"); +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"); } /* g_show_op_stack migrated to s7_scheme_predicate.c */ #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) +#define Q_show_op_stack s7_make_signature(sc, 1, sc->not_symbol) /* bridge for g_show_op_stack migration */ -void -s7i_show_op_stack (s7_scheme* sc) { - s7_show_op_stack (sc); +void s7i_show_op_stack(s7_scheme *sc) +{ + s7_show_op_stack(sc); } /* g_is_op_stack migrated to s7_scheme_predicate.c */ -#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) +#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) /* bridge for g_is_op_stack migration */ -bool -s7i_is_op_stack_active (s7_scheme* sc) { - return (sc->op_stack < sc->op_stack_now); +bool s7i_is_op_stack_active(s7_scheme *sc) +{ + return(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 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) { +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; + 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); + len = snprintf((char *)block_data(b), 128, "%" ld64, bytes); 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))); + 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. +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 + #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]; +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 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); + 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); + check_free_heap_size(sc, 2048); #if !_WIN32 /* (!MS_WINDOWS) */ - getrusage (RUSAGE_SELF, &info); + 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)); + 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)); + 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))); + 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)))); + 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_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)); + 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; - } - } + 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); + 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))); + 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) */ + /* 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[type_unchecked (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); + 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[type_unchecked(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))); + 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))))); + 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))); + 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))); + 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))); + 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))); + 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; + 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)))); + 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))))); + 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]); + 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)))); + 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)); + 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) */ + 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) */ /* 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; + 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); + 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); + 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); + } + 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))))); + 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)))); + 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); + 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); /* sc->opts: OPTS_SIZE * sizeof(opt_info) == 32768 currently */ - return (mu_let); + 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_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_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) { - return (val); +static s7_pointer sl_int_fixup(s7_scheme *sc, s7_pointer val) +{ + return(val); } -static s7_pointer -sl_history_to_list (s7_scheme* sc) { +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)); + return(sanitize_history(sc, (sc->cur_code == sc->history_sink) ? sc->old_cur_code : sc->cur_code)); #else - return (sc->cur_code); + 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; +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), let = stack_let(stack, i); + const opcode_t op = stack_op(stack, i); + s7_pointer entry = sc->nil; + if (s7_is_valid(sc, let)) entry = cons(sc, let, 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; } - 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), - let= stack_let (stack, i); - const opcode_t op = stack_op (stack, i); - s7_pointer entry= sc->nil; - if (s7_is_valid (sc, let)) entry= cons (sc, let, 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); -} - -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_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_scheme_version: - return (sc->scheme_version); - 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)); - } - if ((S7_DEBUGGING) && (choice != 0)) - fprintf (stderr, "%s[%d]: choice %" ld64 "\n", __func__, __LINE__, choice); - return (sc->undefined); /* (*s7* 'anything-else) */ + end_temp(sc->y); + return(reverse_in_place_unchecked(sc, sc->nil, lst)); } -s7_pointer -s7_starlet_ref (s7_scheme* sc, s7_pointer sym) /* s7.h, not used here */ +static s7_pointer sl_gc_protected_objects_to_list(s7_scheme *sc) { - 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); + 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); } -s7_pointer -s7_let_field_ref (s7_scheme* sc, s7_pointer sym) { - return (s7_starlet_ref (sc, sym)); +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_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_scheme_version: return(sc->scheme_version); + 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)); + } + if ((S7_DEBUGGING) && (choice != 0)) fprintf(stderr, "%s[%d]: choice %" ld64 "\n", __func__, __LINE__, choice); + return(sc->undefined); /* (*s7* 'anything-else) */ +} + +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); } -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))); +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) { +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 carrier= iterator_carrier (iterator); - set_car (carrier, symbol); - set_cdr (carrier, value); - return (carrier); - } - 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) { + 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 carrier = iterator_carrier(iterator); + set_car(carrier, symbol); + set_cdr(carrier, value); + return(carrier); + } + 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) { + 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 (!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); - set_cdr_unchecked (sc->eval_history1, - semipermanent_list (sc, iv - sc->true_history_size)); - set_cdr_unchecked (sc->eval_history2, - semipermanent_list (sc, iv - sc->true_history_size)); - set_cdr_unchecked (sc->history_pairs, - semipermanent_list (sc, iv - sc->true_history_size)); - for (p3= cdr (sc->history_pairs); is_pair (cdr (p3)); p3= cdr (p3)) - set_car (p3, semipermanent_list (sc, 1)); - set_car (p3, semipermanent_list (sc, 1)); - set_cdr_unchecked (p3, next3); - for (p1= sc->eval_history1, p2= sc->eval_history2; is_pair (cdr (p1)); - p1= cdr (p1), p2= cdr (p2)) - ; - set_cdr_unchecked (p1, next1); - set_cdr_unchecked (p2, next2); - sc->true_history_size= iv; - } - sc->history_size= iv; + 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); + set_cdr_unchecked(sc->eval_history1, semipermanent_list(sc, iv - sc->true_history_size)); + set_cdr_unchecked(sc->eval_history2, semipermanent_list(sc, iv - sc->true_history_size)); + set_cdr_unchecked(sc->history_pairs, semipermanent_list(sc, iv - sc->true_history_size)); + for (p3 = cdr(sc->history_pairs); is_pair(cdr(p3)); p3 = cdr(p3)) set_car(p3, semipermanent_list(sc, 1)); + set_car(p3, semipermanent_list(sc, 1)); + set_cdr_unchecked(p3, next3); + for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2)); + set_cdr_unchecked(p1, next1); + set_cdr_unchecked(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; - } + 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)); + sc->history_size = s7_integer_clamped_if_gmp(sc, sl_integer_geq_0(sc, sym, val)); #endif - return (val); -} - -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) { + return(val); +} + + +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); + 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)); + 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 (!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); + 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)); - } - } + 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); + 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)); + 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)); + 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); + 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); + 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); +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); + { + 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 */ +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)); - } + { + sc->gc_total_time = 0; + sc->gc_calls = 0; + } 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); + 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_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)); +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_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))); + (!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_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 << 32)) - 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 << 32))); - 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)); + 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 << 32))); + 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)); + 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)); + 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))); + 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))); if (iv > (1LL << 32)) /* sc->max_stack_size is uint32_t */ - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_2 (sc, - wrap_string (sc, - "(set! (*s7* 'max-stack-size) ~S): new value " - "must be less than (ash 1 32) == 4294967296", - 86), - val)); - 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]); - random_seed (sc->default_random_state) = random_seed (val); - random_carry (sc->default_random_state)= random_carry (val); - 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)); + error_nr(sc, sc->out_of_range_symbol, + set_elist_2(sc, wrap_string(sc, "(set! (*s7* 'max-stack-size) ~S): new value must be less than (ash 1 32) == 4294967296", 86), val)); + 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]); + random_seed(sc->default_random_state) = random_seed(val); + random_carry(sc->default_random_state) = random_carry(val); + 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_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_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_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_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 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)))); } #if WITH_R7RS -void -r7rs_init (s7_scheme* sc) { - sc->r7rs_inited= true; -} - -static void -change_scheme_version (s7_scheme* sc, s7_pointer val) { - if (val == sc->r7rs_symbol) { - s7_pointer args= sc->args; /* TODO: gc protect? */ - /* need to check old and new curlet and whether we're coming from s7 or r5rs - * if envs match, and if either is rootlet, more headaches */ - /* if ((!sc->r7rs_inited) || (sc->curlet != sc->rootlet)) */ /* TODO: check - multiple - threads - here, also - if not - rootlet - before and - not == now, - call - r7rs_init - again (or - don't set - flag if - local?) */ - r7rs_init (sc); - sc->args= args; - } - if ((val == sc->r7rs_symbol) || (val == sc->r5rs_symbol)) { - /* s7_eval_c_string(sc, "(begin (define eq? eqv?) (define memq memv) (define - * assq assv))"); */ /* this changes sc->args which confuses others */ - s7_define (sc, sc->curlet, sc->is_eq_symbol, - global_value (sc->is_eqv_symbol)); - s7_define (sc, sc->curlet, sc->memq_symbol, global_value (sc->memv_symbol)); - s7_define (sc, sc->curlet, sc->assq_symbol, global_value (sc->assv_symbol)); - if (sc->curlet == sc->rootlet) { - set_initial_value (sc->is_eq_symbol, initial_value (sc->is_eqv_symbol)); - set_initial_value (sc->memq_symbol, initial_value (sc->memv_symbol)); - set_initial_value (sc->assq_symbol, initial_value (sc->assv_symbol)); - } - } - if (val == sc->s7_symbol) { - if (sc->curlet == sc->rootlet) { - set_global_value (sc->is_eq_symbol, sc->global_is_eq); - set_global_value (sc->memq_symbol, sc->global_memq); - set_global_value (sc->assq_symbol, sc->global_assq); - set_initial_value (sc->is_eq_symbol, sc->initial_is_eq); - set_initial_value (sc->memq_symbol, sc->initial_memq); - set_initial_value (sc->assq_symbol, sc->initial_assq); - /* and set all r7rs to undefined if curlet == rootlet */ - } - else { - s7_define (sc, sc->curlet, sc->is_eq_symbol, sc->global_is_eq); - s7_define (sc, sc->curlet, sc->memq_symbol, sc->global_memq); - s7_define (sc, sc->curlet, sc->assq_symbol, sc->global_assq); - /* and local reference to #_eq? ?? */ +void r7rs_init(s7_scheme *sc) +{ + sc->r7rs_inited = true; +} + +static void change_scheme_version(s7_scheme *sc, s7_pointer val) +{ + if (val == sc->r7rs_symbol) + { + s7_pointer args = sc->args; /* TODO: gc protect? */ + /* need to check old and new curlet and whether we're coming from s7 or r5rs if envs match, and if either is rootlet, more headaches */ + /* if ((!sc->r7rs_inited) || (sc->curlet != sc->rootlet)) */ /* TODO: check multiple threads here, also if not rootlet before and not == now, call r7rs_init again (or don't set flag if local?) */ + r7rs_init(sc); + sc->args = args; } - } + if ((val == sc->r7rs_symbol) || (val == sc->r5rs_symbol)) + { + /* s7_eval_c_string(sc, "(begin (define eq? eqv?) (define memq memv) (define assq assv))"); */ /* this changes sc->args which confuses others */ + s7_define(sc, sc->curlet, sc->is_eq_symbol, global_value(sc->is_eqv_symbol)); + s7_define(sc, sc->curlet, sc->memq_symbol, global_value(sc->memv_symbol)); + s7_define(sc, sc->curlet, sc->assq_symbol, global_value(sc->assv_symbol)); + if (sc->curlet == sc->rootlet) + { + set_initial_value(sc->is_eq_symbol, initial_value(sc->is_eqv_symbol)); + set_initial_value(sc->memq_symbol, initial_value(sc->memv_symbol)); + set_initial_value(sc->assq_symbol, initial_value(sc->assv_symbol)); + }} + if (val == sc->s7_symbol) + { + if (sc->curlet == sc->rootlet) + { + set_global_value(sc->is_eq_symbol, sc->global_is_eq); + set_global_value(sc->memq_symbol, sc->global_memq); + set_global_value(sc->assq_symbol, sc->global_assq); + set_initial_value(sc->is_eq_symbol, sc->initial_is_eq); + set_initial_value(sc->memq_symbol, sc->initial_memq); + set_initial_value(sc->assq_symbol, sc->initial_assq); + /* and set all r7rs to undefined if curlet == rootlet */ + } + else + { + s7_define(sc, sc->curlet, sc->is_eq_symbol, sc->global_is_eq); + s7_define(sc, sc->curlet, sc->memq_symbol, sc->global_memq); + s7_define(sc, sc->curlet, sc->assq_symbol, sc->global_assq); + /* and local reference to #_eq? ?? */ + }} } #endif -static s7_pointer -sl_set_scheme_version (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(sym), - * display(val)); */ +static s7_pointer sl_set_scheme_version(s7_scheme *sc, s7_pointer sym, s7_pointer val) +{ + /* fprintf(stderr, "%s[%d]: %s %s\n", __func__, __LINE__, display(sym), display(val)); */ #if 0 /* this also needs to check curlet old and new */ s7_pointer old_version = sc->scheme_version; if (old_version == val) return(val); #endif - if (!is_symbol (val)) - starlet_wrong_type_error_nr (sc, sym, val, sc->type_names[T_SYMBOL]); - if (is_keyword (val)) val= keyword_symbol (val); - if ((val == sc->s7_symbol) || (val == sc->r5rs_symbol) || - (val == sc->r7rs_symbol)) - sc->scheme_version= val; - else - error_nr ( - sc, sc->out_of_range_symbol, - set_elist_2 ( - sc, - wrap_string ( - sc, "(set! (*s7* 'scheme-version) '~S): unknown scheme version", - 57), - val)); + if (!is_symbol(val)) starlet_wrong_type_error_nr(sc, sym, val, sc->type_names[T_SYMBOL]); + if (is_keyword(val)) val = keyword_symbol(val); + if ((val == sc->s7_symbol) || (val == sc->r5rs_symbol) || (val == sc->r7rs_symbol)) + sc->scheme_version = val; + else error_nr(sc, sc->out_of_range_symbol, set_elist_2(sc, wrap_string(sc, "(set! (*s7* 'scheme-version) '~S): unknown scheme version", 57), val)); #if WITH_R7RS - change_scheme_version (sc, val); + change_scheme_version(sc, val); #endif - return (val); + return(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 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)); } -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 (); +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();} } - 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_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_scheme_version: return(sl_set_scheme_version(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: + if (S7_DEBUGGING) fprintf(stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); + 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)); */ } - } - 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_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_scheme_version: - return (sl_set_scheme_version (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: - if (S7_DEBUGGING) - fprintf (stderr, "%s[%d]: we should not be here\n", __func__, __LINE__); - 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); + 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_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)); -} +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 */ +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 @@ -96308,2486 +78228,1767 @@ init_starlet_immutable_field (void) { #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 ("s7->value"); - if (p == sc->args) return ("s7->args"); - if (p == sc->code) return ("s7->code"); - if (p == sc->cur_code) return ("s7->cur_code"); - if (p == sc->curlet) return ("s7->curlet"); - if (p == sc->nil) return ("()"); - if (p == sc->T) return ("#t"); - if (p == sc->F) return ("#f"); - if (p == eof_object) return ("#"); - if (p == sc->undefined) return ("#"); - if (p == sc->unspecified) return ("#"); +static const char *decoded_name(s7_scheme *sc, const s7_pointer p) +{ + if (p == sc->value) return("s7->value"); + if (p == sc->args) return("s7->args"); + if (p == sc->code) return("s7->code"); + if (p == sc->cur_code) return("s7->cur_code"); + if (p == sc->curlet) return("s7->curlet"); + if (p == sc->nil) return("()"); + if (p == sc->T) return("#t"); + if (p == sc->F) return("#f"); + if (p == eof_object) return("#"); + if (p == sc->undefined) return("#"); + if (p == sc->unspecified) return("#"); #if S7_DEBUGGING - if (p == sc->no_value) return ("no_value"); + if (p == sc->no_value) return("no_value"); #endif - if (p == sc->unused) return ("#"); - if (p == sc->symbol_table) return ("s7->symbol_table"); - if (p == sc->rootlet) return ("rootlet"); - if (p == sc->starlet) return ("*s7*"); /* this is the function */ - if (p == sc->owlet) return ("owlet"); /* is this possible? */ - 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"); + if (p == sc->unused) return("#"); + if (p == sc->symbol_table) return("s7->symbol_table"); + if (p == sc->rootlet) return("rootlet"); + if (p == sc->starlet) return("*s7*"); /* this is the function */ + if (p == sc->owlet) return("owlet"); /* is this possible? */ + 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"); + 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); + return((p == sc->stack) ? "stack" : NULL); } -static bool -is_decodable (s7_scheme* sc, const s7_pointer ptr) { +static bool is_decodable(s7_scheme *sc, const s7_pointer ptr) +{ /* 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); + 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 */ - s7_pointer* tp = sc->heap; - const s7_pointer* heap_top= (s7_pointer*) (sc->heap + sc->heap_size); + s7_pointer *tp = sc->heap; + const s7_pointer *heap_top = (s7_pointer *)(sc->heap + sc->heap_size); 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'))))) { - s7_pointer vp; - const int32_t vals= - sscanf ((const char*) (bt + i + 1), "%p", (void**) (&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 char* dname= decoded_name (sc, vp); - if (dname) { - if (bt[i + 1] == ' ') fputc (' ', stdout); - fprintf (stdout, "%s[%s]%s", bold_text, dname, unbold_text); - } - if ((dname) || (is_decodable (sc, vp))) { - if (bt[i + 1] == ' ') fputc (' ', stdout); - i= k - 1; - if (s7_is_valid (sc, vp)) { - const s7_pointer strp= object_to_string_truncated (sc, vp); - if (dname) fprintf (stdout, " "); - fprintf (stdout, "%s%s%s", bold_text, string_value (strp), - unbold_text); - if ((is_pair (vp)) && (has_location (vp))) { - uint32_t line= pair_line_number (vp), - file= pair_file_number (vp); - 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; + if (ptr == (*tp++)) + return(true); } - return (""); + 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'))))) + { + s7_pointer vp; + const int32_t vals = sscanf((const char *)(bt + i + 1), "%p", (void **)(&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 char *dname = decoded_name(sc, vp); + if (dname) + { + if (bt[i + 1] == ' ') fputc(' ', stdout); + fprintf(stdout, "%s[%s]%s", bold_text, dname, unbold_text); + } + if ((dname) || (is_decodable(sc, vp))) + { + if (bt[i + 1] == ' ') fputc(' ', stdout); + i = k - 1; + if (s7_is_valid(sc, vp)) + { + const s7_pointer strp = object_to_string_truncated(sc, vp); + if (dname) fprintf(stdout, " "); + fprintf(stdout, "%s%s%s", bold_text, string_value(strp), unbold_text); + if ((is_pair(vp)) && + (has_location(vp))) + { + uint32_t line = pair_line_number(vp), file = pair_file_number(vp); + 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; + +/* -------------------------------- 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_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_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_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_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_SAFE_C_S_opAAq] = fx_c_s_opaaq; - fx_function[HOP_HASH_TABLE_INCREMENT]= fx_hash_table_increment; + 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_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; - fx_function[OP_CASE_A_I_S_A] = fx_case_a_i_s_a; - 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[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; + fx_function[OP_CASE_A_I_S_A] = fx_case_a_i_s_a; + 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) { + 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_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), exact_b_7p); - s7_set_b_7p_function (sc, global_value (sc->is_inexact_symbol), 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); + 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), exact_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_inexact_symbol), 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), - s7i_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_d_function (sc, global_value (sc->asin_symbol), asin_p_d); - s7_set_p_p_function (sc, global_value (sc->asin_symbol), asin_p_p); - s7_set_p_d_function (sc, global_value (sc->acos_symbol), acos_p_d); - 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->asin_symbol), asin_d_d); - s7_set_d_d_function (sc, global_value (sc->acos_symbol), acos_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); - s7_set_p_pp_function (sc, global_value (sc->expt_symbol), expt_p_pp); - /* same problem affects - * 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); - 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), even_p_p); - s7_set_p_p_function (sc, global_value (sc->is_odd_symbol), 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); - 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); - - 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_size_symbol), - hash_table_size_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), even_b_7p); - s7_set_b_7p_function (sc, global_value (sc->is_odd_symbol), 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), - s7_is_infinite); - 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_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), zero_b_7p); - s7_set_b_7p_function (sc, global_value (sc->is_negative_symbol), - negative_b_7p); - s7_set_b_7p_function (sc, global_value (sc->is_positive_symbol), - 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->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); - - s7_set_b_i_function (sc, global_value (sc->is_even_symbol), even_i); - s7_set_b_i_function (sc, global_value (sc->is_odd_symbol), odd_i); - s7_set_b_i_function (sc, global_value (sc->is_zero_symbol), zero_i); - s7_set_b_d_function (sc, global_value (sc->is_zero_symbol), zero_d); - s7_set_p_p_function (sc, global_value (sc->is_zero_symbol), zero_p_p); - s7_set_p_p_function (sc, global_value (sc->is_positive_symbol), positive_p_p); - s7_set_p_p_function (sc, global_value (sc->is_negative_symbol), 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), positive_i); - s7_set_b_d_function (sc, global_value (sc->is_positive_symbol), positive_d); - s7_set_b_i_function (sc, global_value (sc->is_negative_symbol), negative_i); - s7_set_b_d_function (sc, global_value (sc->is_negative_symbol), 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); + 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), s7i_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_d_function(sc, global_value(sc->asin_symbol), asin_p_d); + s7_set_p_p_function(sc, global_value(sc->asin_symbol), asin_p_p); + s7_set_p_d_function(sc, global_value(sc->acos_symbol), acos_p_d); + 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->asin_symbol), asin_d_d); + s7_set_d_d_function(sc, global_value(sc->acos_symbol), acos_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); + s7_set_p_pp_function(sc, global_value(sc->expt_symbol), expt_p_pp); + /* same problem affects 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); + 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), even_p_p); + s7_set_p_p_function(sc, global_value(sc->is_odd_symbol), 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); + 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); + + 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_size_symbol), hash_table_size_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), even_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_odd_symbol), 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), s7_is_infinite); + 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_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), zero_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_negative_symbol), negative_b_7p); + s7_set_b_7p_function(sc, global_value(sc->is_positive_symbol), 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->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); + + + s7_set_b_i_function(sc, global_value(sc->is_even_symbol), even_i); + s7_set_b_i_function(sc, global_value(sc->is_odd_symbol), odd_i); + s7_set_b_i_function(sc, global_value(sc->is_zero_symbol), zero_i); + s7_set_b_d_function(sc, global_value(sc->is_zero_symbol), zero_d); + s7_set_p_p_function(sc, global_value(sc->is_zero_symbol), zero_p_p); + s7_set_p_p_function(sc, global_value(sc->is_positive_symbol), positive_p_p); + s7_set_p_p_function(sc, global_value(sc->is_negative_symbol), 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), positive_i); + s7_set_b_d_function(sc, global_value(sc->is_positive_symbol), positive_d); + s7_set_b_i_function(sc, global_value(sc->is_negative_symbol), negative_i); + s7_set_b_d_function(sc, global_value(sc->is_negative_symbol), 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 */ + 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"); + s7_provide(sc, "complex-numbers"); #endif - s7_provide (sc, "ieee-float"); /* why would anyone care? -- this is for r7rs - -- why singular this time? */ + s7_provide(sc, "ieee-float"); /* why would anyone care? -- this is for r7rs -- why singular this time? */ #if WITH_PURE_S7 - s7_provide (sc, "pure-s7"); + s7_provide(sc, "pure-s7"); #endif #if WITH_R7RS - s7_provide (sc, "r7rs"); + s7_provide(sc, "r7rs"); #endif #if WITH_EXTRA_EXPONENT_MARKERS - s7_provide (sc, "dfls-exponents"); + s7_provide(sc, "dfls-exponents"); #endif #if HAVE_OVERFLOW_CHECKS - s7_provide (sc, "overflow-checks"); + s7_provide(sc, "overflow-checks"); #endif #if WITH_SYSTEM_EXTRAS - s7_provide (sc, "system-extras"); + s7_provide(sc, "system-extras"); #endif #if WITH_IMMUTABLE_UNQUOTE - s7_provide (sc, "immutable-unquote"); + s7_provide(sc, "immutable-unquote"); #endif #if S7_DEBUGGING - s7_provide (sc, "debugging"); + s7_provide(sc, "debugging"); #endif #if WITH_NUMBER_SEPARATOR - s7_provide (sc, "number-separator"); + s7_provide(sc, "number-separator"); #endif #if WITH_HISTORY - s7_provide (sc, "history"); + s7_provide(sc, "history"); #endif #if WITH_C_LOADER - s7_provide (sc, "dlopen"); + s7_provide(sc, "dlopen"); #endif #if !DISABLE_AUTOLOAD - s7_provide (sc, "autoload"); + s7_provide(sc, "autoload"); #endif #if !DISABLE_DEPRECATED - s7_provide (sc, "deprecated"); + s7_provide(sc, "deprecated"); #endif #if S7_ALIGNED - s7_provide (sc, "aligned"); + s7_provide(sc, "aligned"); #endif #if POINTER_32 - s7_provide (sc, "32-bit"); + s7_provide(sc, "32-bit"); #endif #if WITH_WARNINGS - s7_provide (sc, "warnings"); + s7_provide(sc, "warnings"); #endif #ifdef __APPLE__ - s7_provide (sc, "osx"); + s7_provide(sc, "osx"); #endif #ifdef __linux__ - s7_provide (sc, "linux"); + s7_provide(sc, "linux"); #endif #ifdef __OpenBSD__ - s7_provide (sc, "openbsd"); + s7_provide(sc, "openbsd"); #endif #ifdef __NetBSD__ - s7_provide (sc, "netbsd"); + s7_provide(sc, "netbsd"); #endif #ifdef __FreeBSD__ - s7_provide (sc, "freebsd"); + s7_provide(sc, "freebsd"); #endif #if MS_WINDOWS - s7_provide (sc, "windows"); + s7_provide(sc, "windows"); #endif #ifdef __bfin__ - s7_provide (sc, "blackfin"); + s7_provide(sc, "blackfin"); #endif #ifdef __ANDROID__ - s7_provide (sc, "android"); + s7_provide(sc, "android"); #endif #ifdef __MSYS__ - s7_provide (sc, "msys2"); /* from chai xiaoxiang */ + s7_provide(sc, "msys2"); /* from chai xiaoxiang */ #endif -#ifdef __MINGW32__ /* this is also defined in mingw64 */ - s7_provide (sc, "mingw"); +#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 */ + s7_provide(sc, "cygwin"); /* this is also defined in msys2 */ #endif #ifdef __hpux - s7_provide (sc, "hpux"); + s7_provide(sc, "hpux"); #endif #if defined(__sun) && defined(__SVR4) - s7_provide (sc, "solaris"); + s7_provide(sc, "solaris"); #endif #ifdef __clang__ /* this defines __GNUC__ */ - s7_provide (sc, "clang"); -#if __cplusplus - s7_provide (sc, "clang++"); /* doesn't work yet */ -#endif + s7_provide(sc, "clang"); + #if __cplusplus + s7_provide(sc, "clang++"); /* doesn't work yet */ + #endif #else -#ifdef __GNUC__ - s7_provide (sc, "gcc"); -#if __cplusplus - s7_provide (sc, "g++"); -#endif -#endif + #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) and no complex number support */ + s7_provide(sc, "tcc"); /* appears to be 3-4 times slower than gcc (compilation is at least 10 times faster however) and no complex number support */ #endif #ifdef __EMSCRIPTEN__ - s7_provide (sc, "emscripten"); + s7_provide(sc, "emscripten"); #endif #ifdef _MSC_VER - s7_provide (sc, "msvc"); + s7_provide(sc, "msvc"); #endif } -static void -init_wrappers (s7_scheme* sc) { +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; + 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_UNHEAP; + 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_UNHEAP; #if S7_DEBUGGING - p->carrier_line= __LINE__; + p->carrier_line = __LINE__; #endif - set_integer (p, 0); - set_car (cp, p); - } - set_cdr_unchecked (qp, sc->integer_wrappers); + set_integer(p, 0); + set_car(cp, p); + } + set_cdr_unchecked(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_UNHEAP; + 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_UNHEAP; #if S7_DEBUGGING - p->carrier_line= __LINE__; + p->carrier_line = __LINE__; #endif - set_real (p, 0.0); - set_car (cp, p); - } - set_cdr_unchecked (qp, sc->real_wrappers); + set_real(p, 0.0); + set_car(cp, p); + } + set_cdr_unchecked(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_UNHEAP; + 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_UNHEAP; #if S7_DEBUGGING - p->carrier_line= __LINE__; + p->carrier_line = __LINE__; #endif - set_real_part (p, 0.0); - set_imag_part (p, 0.0); - set_car (cp, p); - } - set_cdr_unchecked (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_SAFE_PROCEDURE | T_UNHEAP; - string_block (p) = NULL; - string_value (p) = NULL; - string_length (p)= 0; - string_hash (p) = 0; - set_car (cp, p); - } - set_cdr_unchecked (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_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); - } - set_cdr_unchecked (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); - } - set_cdr_unchecked (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); - } - set_cdr_unchecked (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 syn = global_value (symbol); - full_type (syn)|= T_COPY_ARGS; - return (symbol); -} - -static s7_pointer -make_unique (s7_scheme* sc, const char* name, s7_uint typ) { - const s7_pointer uniq= alloc_pointer (sc); - set_full_type (uniq, typ | T_IMMUTABLE | T_UNHEAP); - if (typ != T_UNUSED) set_optimize_op (uniq, OP_CONSTANT); - if (typ == T_UNDEFINED) /* sc->undefined here to avoid the - undefined_constant_warning */ - { - undefined_set_name_length (uniq, safe_strlen (name)); - undefined_name (uniq)= - copy_string_with_length (name, undefined_name_length (uniq)); - } - else { - unique_name_length (uniq)= safe_strlen (name); - unique_name (uniq)= - copy_string_with_length (name, unique_name_length (uniq)); - add_saved_pointer (sc, (void*) unique_name (uniq)); - } - return (uniq); + set_real_part(p, 0.0); + set_imag_part(p, 0.0); + set_car(cp, p); + } + set_cdr_unchecked(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_SAFE_PROCEDURE | T_UNHEAP; + string_block(p) = NULL; + string_value(p) = NULL; + string_length(p) = 0; + string_hash(p) = 0; + set_car(cp, p); + } + set_cdr_unchecked(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_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); + } + set_cdr_unchecked(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); + } + set_cdr_unchecked(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); + } + set_cdr_unchecked(qp, sc->slot_wrappers); } -static s7_pointer -symbol_set_1 (s7_scheme* sc, s7_pointer sym, s7_pointer val) { - const 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 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 syn = global_value(symbol); + full_type(syn) |= T_COPY_ARGS; + return(symbol); +} + +static s7_pointer make_unique(s7_scheme *sc, const char *name, s7_uint typ) +{ + const s7_pointer uniq = alloc_pointer(sc); + set_full_type(uniq, typ | T_IMMUTABLE | T_UNHEAP); + if (typ != T_UNUSED) set_optimize_op(uniq, OP_CONSTANT); + if (typ == T_UNDEFINED) /* sc->undefined here to avoid the undefined_constant_warning */ + { + undefined_set_name_length(uniq, safe_strlen(name)); + undefined_name(uniq) = copy_string_with_length(name, undefined_name_length(uniq)); + } + else + { + unique_name_length(uniq) = safe_strlen(name); + unique_name(uniq) = copy_string_with_length(name, unique_name_length(uniq)); + add_saved_pointer(sc, (void *)unique_name(uniq)); + } + return(uniq); } -static s7_pointer -g_symbol_set (s7_scheme* sc, s7_pointer args) /* (set! (symbol ) ) */ +static s7_pointer symbol_set_1(s7_scheme *sc, s7_pointer sym, s7_pointer val) { - s7_int len; + const 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; - 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); + 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)); + 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)); } { - s7_pointer 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 (sc, lst); - return (val); + s7_pointer 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(sc, 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); +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->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->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->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); + 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); + 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")); + 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)); + 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". + 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, \ + 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,\ + #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, \ + #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 \ + #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, \ + #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) \ + #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. \ + #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 \ + #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, \ + #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 \ + #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, \ + #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->type_error_symbol = make_symbol (sc, "type-error", 10); - sc->wrong_type_arg_symbol = sc->type_error_symbol; - sc->value_error_symbol = make_symbol (sc, "value-error", 11); - 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. + 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->type_error_symbol = make_symbol(sc, "type-error", 10); + sc->wrong_type_arg_symbol = sc->type_error_symbol; + sc->value_error_symbol = make_symbol(sc, "value-error", 11); + 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); + init_syntax(sc); - sc->owlet= init_owlet (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->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->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->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->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; + 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 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 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 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) + #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, 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= define_bool_function ( - sc, "char?", g_is_char, 0, "(char? obj) returns #t if obj is a character", - sc->pl_bt, T_CHARACTER, just_mark_vector, true, b_is_char_setter); - 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); -#define H_is_vector "(vector? obj) returns #t if obj is a vector" -#define Q_is_vector sc->pl_bt - sc->is_vector_symbol= - bool_defun ("vector?", is_vector, 0, T_FREE, mark_vector_1, false); -#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 - sc->is_float_vector_symbol= - bool_defun ("float-vector?", is_float_vector, 0, T_FLOAT_VECTOR, - mark_simple_vector, true); -#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 - sc->is_complex_vector_symbol= - bool_defun ("complex-vector?", is_complex_vector, 0, T_COMPLEX_VECTOR, - mark_simple_vector, true); -#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 - sc->is_int_vector_symbol= bool_defun ("int-vector?", is_int_vector, 0, - T_INT_VECTOR, mark_simple_vector, true); -#define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector" -#define Q_is_byte_vector sc->pl_bt - sc->is_byte_vector_symbol= - bool_defun ("byte-vector?", is_byte_vector, 0, T_BYTE_VECTOR, - mark_simple_vector, true); - -#define H_is_hash_table "(hash-table? obj) returns #t if obj is a hash-table" -#define Q_is_hash_table sc->pl_bt - 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); -#define H_is_subvector "(subvector? obj) returns #t if obj is a subvector" -#define Q_is_subvector sc->pl_bt - sc->is_subvector_symbol= - bool_defun ("subvector?", is_subvector, 0, T_FREE, mark_vector_1, false); - sc->is_weak_hash_table_symbol= bool_defun ( - "weak-hash-table?", is_weak_hash_table, 0, T_FREE, mark_vector_1, false); - sc->is_goto_symbol= - bool_defun ("goto?", is_goto, 0, T_GOTO, mark_vector_1, true); + sc->is_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, 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 = define_bool_function(sc, "char?", g_is_char, 0, + "(char? obj) returns #t if obj is a character", + sc->pl_bt, T_CHARACTER, just_mark_vector, true, b_is_char_setter); + 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); + #define H_is_vector "(vector? obj) returns #t if obj is a vector" + #define Q_is_vector sc->pl_bt + sc->is_vector_symbol = bool_defun("vector?", is_vector, 0, T_FREE, mark_vector_1, false); + #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 + sc->is_float_vector_symbol = bool_defun("float-vector?", is_float_vector, 0, T_FLOAT_VECTOR, mark_simple_vector, true); + #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 + sc->is_complex_vector_symbol = bool_defun("complex-vector?", is_complex_vector, 0, T_COMPLEX_VECTOR, mark_simple_vector, true); + #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 + sc->is_int_vector_symbol = bool_defun("int-vector?", is_int_vector, 0, T_INT_VECTOR, mark_simple_vector, true); + #define H_is_byte_vector "(byte-vector? obj) returns #t if obj is a byte-vector" + #define Q_is_byte_vector sc->pl_bt + sc->is_byte_vector_symbol = bool_defun("byte-vector?", is_byte_vector, 0, T_BYTE_VECTOR, mark_simple_vector, true); + + #define H_is_hash_table "(hash-table? obj) returns #t if obj is a hash-table" + #define Q_is_hash_table sc->pl_bt + 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); + #define H_is_subvector "(subvector? obj) returns #t if obj is a subvector" + #define Q_is_subvector sc->pl_bt + 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->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); - 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); + 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->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); 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 */ + 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= s7_define_typed_function ( - sc, "newline", g_newline, 0, 1, false, - "(newline (port (current-output-port))) writes a carriage return to the " - "port", - s7_make_signature (sc, 2, sc->is_char_symbol, - s7_make_signature (sc, 2, sc->is_output_port_symbol, - sc->not_symbol))); - sc->write_symbol= s7_define_typed_function ( - sc, "write", g_write, 1, 1, false, - "(write obj (port (current-output-port))) writes (object->string obj) to " - "the output port", - s7_make_signature (sc, 3, sc->T, sc->T, - s7_make_signature (sc, 2, sc->is_output_port_symbol, - sc->not_symbol))); - set_is_translucent (sc->write_symbol); - sc->display_symbol= s7_define_typed_function ( - sc, "display", g_display, 1, 1, false, - "(display obj (port (current-output-port))) prints obj", - s7_make_signature (sc, 3, sc->T, sc->T, - s7_make_signature (sc, 2, sc->is_output_port_symbol, - sc->not_symbol))); - 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= s7_define_typed_function ( - sc, "write-char", g_write_char, 1, 1, false, - "(write-char char (port (current-output-port))) writes char to the " - "output port", - 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))); - sc->write_string_symbol= s7_define_typed_function ( - sc, "write-string", g_write_string, 1, 3, false, - "(write-string str port start end) writes str to port.", - 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)); - sc->read_byte_symbol = defun ("read-byte", read_byte, 0, 1, false); - sc->write_byte_symbol= s7_define_typed_function ( - sc, "write-byte", g_write_byte, 1, 1, false, - "(write-byte byte (port (current-output-port))): writes byte to the " - "output port", - 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))); - 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. + 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 = s7_define_typed_function(sc, "newline", g_newline, 0, 1, false, "(newline (port (current-output-port))) writes a carriage return to the port", s7_make_signature(sc, 2, sc->is_char_symbol, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))); + sc->write_symbol = s7_define_typed_function(sc, "write", g_write, 1, 1, false, "(write obj (port (current-output-port))) writes (object->string obj) to the output port", s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))); set_is_translucent(sc->write_symbol); + sc->display_symbol = s7_define_typed_function(sc, "display", g_display, 1, 1, false, "(display obj (port (current-output-port))) prints obj", s7_make_signature(sc, 3, sc->T, sc->T, s7_make_signature(sc, 2, sc->is_output_port_symbol, sc->not_symbol))); 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 = s7_define_typed_function(sc, "write-char", g_write_char, 1, 1, false, "(write-char char (port (current-output-port))) writes char to the output port", 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))); + sc->write_string_symbol = s7_define_typed_function(sc, "write-string", g_write_string, 1, 3, false, "(write-string str port start end) writes str to port.", 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)); + sc->read_byte_symbol = defun("read-byte", read_byte, 0, 1, false); + sc->write_byte_symbol = s7_define_typed_function(sc, "write-byte", g_write_byte, 1, 1, false, "(write-byte byte (port (current-output-port))): writes byte to the output port", 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))); + 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); - - sc->real_part_symbol= s7_define_typed_function ( - sc, "real-part", g_real_part, 1, 0, false, - "(real-part num) returns the real part of num", - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_number_symbol)); - sc->imag_part_symbol= s7_define_typed_function ( - sc, "imag-part", g_imag_part, 1, 0, false, - "(imag-part num) returns the imaginary part of num", - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_number_symbol)); - sc->numerator_symbol = defun ("numerator", numerator, 1, 0, false); - sc->denominator_symbol= defun ("denominator", denominator, 1, 0, false); - sc->is_even_symbol = s7_define_typed_function ( - sc, "even?", g_even, 1, 0, false, - "(even? int) returns #t if the integer int32_t is even", - s7_make_signature (sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)); - sc->is_odd_symbol= s7_define_typed_function ( - sc, "odd?", g_odd, 1, 0, false, - "(odd? int) returns #t if the integer int32_t is odd", - s7_make_signature (sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)); - sc->is_zero_symbol= s7_define_typed_function ( - sc, "zero?", g_zero, 1, 0, false, - "(zero? num) returns #t if the number num is zero", sc->pl_bn); - sc->is_positive_symbol= s7_define_typed_function ( - sc, "positive?", g_positive, 1, 0, false, - "(positive? num) returns #t if the real number num is positive (greater " - "than 0)", - s7_make_signature (sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)); - sc->is_negative_symbol= s7_define_typed_function ( - sc, "negative?", g_negative, 1, 0, false, - "(negative? num) returns #t if the real number num is negative (less " - "than 0)", - s7_make_signature (sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)); - sc->is_infinite_symbol= - s7_define_typed_function (sc, "infinite?", g_is_infinite, 1, 0, false, - "(infinite? obj) returns #t if obj has an " - "infinite real or imaginary part", - sc->pl_bt); - sc->is_nan_symbol= s7_define_typed_function ( - sc, "nan?", g_is_nan, 1, 0, false, - "(nan? obj) returns #t if obj is a NaN", sc->pl_bt); - sc->complex_symbol= s7_define_typed_function ( - sc, "complex", g_complex, 2, 0, false, - "(complex x1 x2) returns a complex number with real-part x1 and " - "imaginary-part x2", - s7_make_signature (sc, 3, sc->is_number_symbol, sc->is_real_symbol, - sc->is_real_symbol)); - - 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= s7_define_typed_function ( - sc, "s7-min", g_min, 1, 0, true, - "(min ...) returns the minimum of its arguments", sc->pcl_r); - set_all_integer_and_float (sc->min_symbol); - sc->max_symbol= s7_define_typed_function ( - sc, "s7-max", g_max, 1, 0, true, - "(max ...) returns the maximum of its arguments", sc->pcl_r); - 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 ("s7-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 = s7_define_typed_function ( - sc, "gcd", g_gcd, 0, 0, true, - "(gcd ...) returns the greatest common divisor of its rational arguments", - sc->pcl_f); - sc->lcm_symbol= s7_define_typed_function ( - sc, "s7-lcm", g_lcm, 0, 0, true, - "(lcm ...) returns the least common multiple of its rational arguments", - sc->pcl_f); - sc->rationalize_symbol= s7_define_typed_function ( - sc, "rationalize", g_rationalize, 1, 1, false, - "(rationalize x err) returns the ratio with smallest denominator within " - "err of x", - s7_make_signature (sc, 3, sc->is_rational_symbol, sc->is_real_symbol, - sc->is_real_symbol)); - 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, 2, false); - sc->expt_symbol = s7_define_typed_function ( - sc, "expt", g_expt, 2, 0, false, "(expt z1 z2) returns z1^z2", sc->pcl_n); - sc->log_symbol= s7_define_typed_function ( - sc, "log", g_log, 1, 1, false, - "(log z1 (z2 e)) returns log(z1) / log(z2) where z2 (the base) defaults " - "to e: (log 8 2) = 3", - sc->pcl_n); - sc->ash_symbol= s7_define_typed_function ( - sc, "ash", g_ash, 2, 0, false, - "(ash i1 i2) returns i1 shifted right or left i2 times, i1 << i2, (ash 1 " - "3) -> 8, (ash 8 -3) -> 1", - sc->pcl_i); - sc->exp_symbol= s7_define_typed_function ( - sc, "exp", g_exp, 1, 0, false, - "(exp z) returns e^z, (exp 1) is 2.718281828459", sc->pl_nn); - set_all_float (sc->exp_symbol); - sc->abs_symbol= s7_define_typed_function ( - sc, "abs", g_abs, 1, 0, false, - "(abs x) returns the absolute value of the real number x", - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_real_symbol)); - set_is_translucent (sc->abs_symbol); - sc->magnitude_symbol= s7_define_typed_function ( - sc, "magnitude", g_magnitude, 1, 0, false, - "(magnitude z) returns the magnitude of z", - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_number_symbol)); - set_all_integer_and_float (sc->magnitude_symbol); - sc->angle_symbol= s7_define_typed_function ( - sc, "angle", g_angle, 1, 0, false, "(angle z) returns the angle of z", - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_number_symbol)); - sc->sin_symbol= s7_define_typed_function ( - sc, "sin", g_sin, 1, 0, false, "(sin z) returns sin(z)", sc->pl_nn); - set_all_float (sc->sin_symbol); - sc->cos_symbol= s7_define_typed_function ( - sc, "cos", g_cos, 1, 0, false, "(cos z) returns cos(z)", sc->pl_nn); - set_all_float (sc->cos_symbol); - sc->tan_symbol= s7_define_typed_function ( - sc, "tan", g_tan, 1, 0, false, "(tan z) returns tan(z)", sc->pl_nn); - set_all_float (sc->tan_symbol); - sc->sinh_symbol= s7_define_typed_function ( - sc, "sinh", g_sinh, 1, 0, false, "(sinh z) returns sinh(z)", sc->pl_nn); - set_all_float (sc->sinh_symbol); - sc->cosh_symbol= s7_define_typed_function ( - sc, "cosh", g_cosh, 1, 0, false, "(cosh z) returns cosh(z)", sc->pl_nn); - set_all_float (sc->cosh_symbol); - sc->tanh_symbol= s7_define_typed_function ( - sc, "tanh", g_tanh, 1, 0, false, "(tanh z) returns tanh(z)", sc->pl_nn); - set_all_float (sc->tanh_symbol); - sc->asin_symbol= s7_define_typed_function ( - sc, "asin", g_asin, 1, 0, false, - "(asin z) returns asin(z); (sin (asin x)) = x", sc->pl_nn); - sc->acos_symbol= s7_define_typed_function ( - sc, "acos", g_acos, 1, 0, false, - "(acos z) returns acos(z); (cos (acos 1)) = 1", sc->pl_nn); - sc->atan_symbol= s7_define_typed_function ( - sc, "atan", g_atan, 1, 1, false, - "(atan z) returns atan(z), (atan y x) returns atan(y/x)", - s7_make_signature (sc, 3, sc->is_number_symbol, sc->is_number_symbol, - sc->is_real_symbol)); - sc->asinh_symbol= - s7_define_typed_function (sc, "asinh", g_asinh, 1, 0, false, - "(asinh z) returns asinh(z)", sc->pl_nn); - sc->acosh_symbol= - s7_define_typed_function (sc, "acosh", g_acosh, 1, 0, false, - "(acosh z) returns acosh(z)", sc->pl_nn); - sc->atanh_symbol= - s7_define_typed_function (sc, "atanh", g_atanh, 1, 0, false, - "(atanh z) returns atanh(z)", sc->pl_nn); - sc->sqrt_symbol= s7_define_typed_function ( - sc, "sqrt", g_sqrt, 1, 0, false, "(sqrt z) returns the square root of z", - sc->pl_nn); - sc->floor_symbol= s7_define_typed_function ( - sc, "s7-floor", g_floor, 1, 0, false, - "(s7-floor x) returns the integer closest to x toward -inf", - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); - set_is_translucent (sc->floor_symbol); - sc->ceiling_symbol= s7_define_typed_function ( - sc, "s7-ceiling", g_ceiling, 1, 0, false, - "(s7-ceiling x) returns the integer closest to x toward inf", - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); - set_is_translucent (sc->ceiling_symbol); - sc->truncate_symbol= s7_define_typed_function ( - sc, "s7-truncate", g_truncate, 1, 0, false, - "(truncate x) returns the integer closest to x toward 0", - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); - set_is_translucent (sc->truncate_symbol); - sc->round_symbol= s7_define_typed_function ( - sc, "s7-round", g_round, 1, 0, false, - "(round x) returns the integer closest to x", - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); - set_is_translucent (sc->round_symbol); - sc->logand_symbol= s7_define_typed_function ( - sc, "logand", g_logand, 0, 0, true, - "(logand int32_t ...) returns the AND of its integer arguments (the bits " - "that are on in every argument)", - sc->pcl_i); - sc->logior_symbol= s7_define_typed_function ( - sc, "logior", g_logior, 0, 0, true, - "(logior int32_t ...) returns the OR of its integer arguments (the bits " - "that are on in any of the arguments)", - sc->pcl_i); - sc->logxor_symbol= s7_define_typed_function ( - sc, "logxor", g_logxor, 0, 0, true, - "(logxor int32_t ...) returns the XOR of its integer arguments (the bits " - "that are on in an odd number of the arguments)", - sc->pcl_i); - sc->lognot_symbol= s7_define_typed_function ( - sc, "lognot", g_lognot, 1, 0, false, - "(lognot num) returns the negation of num (its complement, the bits that " - "are not on): (lognot 0) -> -1", - sc->pcl_i); - sc->logbit_symbol= s7_define_typed_function ( - sc, "logbit?", g_logbit, 2, 0, false, - "(logbit? int index) returns #t if the index-th bit is on in int, " - "otherwise #f.", - s7_make_circular_signature (sc, 1, 2, sc->is_boolean_symbol, - sc->is_integer_symbol)); - 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); + 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); + + + sc->real_part_symbol = s7_define_typed_function(sc, "real-part", g_real_part, 1, 0, false, "(real-part num) returns the real part of num", s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)); + sc->imag_part_symbol = s7_define_typed_function(sc, "imag-part", g_imag_part, 1, 0, false, "(imag-part num) returns the imaginary part of num", s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)); + sc->numerator_symbol = defun("numerator", numerator, 1, 0, false); + sc->denominator_symbol = defun("denominator", denominator, 1, 0, false); + sc->is_even_symbol = s7_define_typed_function(sc, "even?", g_even, 1, 0, false, "(even? int) returns #t if the integer int32_t is even", s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)); + sc->is_odd_symbol = s7_define_typed_function(sc, "odd?", g_odd, 1, 0, false, "(odd? int) returns #t if the integer int32_t is odd", s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_integer_symbol)); + sc->is_zero_symbol = s7_define_typed_function(sc, "zero?", g_zero, 1, 0, false, "(zero? num) returns #t if the number num is zero", sc->pl_bn); + sc->is_positive_symbol = s7_define_typed_function(sc, "positive?", g_positive, 1, 0, false, "(positive? num) returns #t if the real number num is positive (greater than 0)", s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)); + sc->is_negative_symbol = s7_define_typed_function(sc, "negative?", g_negative, 1, 0, false, "(negative? num) returns #t if the real number num is negative (less than 0)", s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_real_symbol)); + sc->is_infinite_symbol = s7_define_typed_function(sc, "infinite?", g_is_infinite, 1, 0, false, "(infinite? obj) returns #t if obj has an infinite real or imaginary part", sc->pl_bt); + sc->is_nan_symbol = s7_define_typed_function(sc, "nan?", g_is_nan, 1, 0, false, "(nan? obj) returns #t if obj is a NaN", sc->pl_bt); + sc->complex_symbol = s7_define_typed_function(sc, "complex", g_complex, 2, 0, false, "(complex x1 x2) returns a complex number with real-part x1 and imaginary-part x2", s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)); + + 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 = s7_define_typed_function(sc, "s7-min", g_min, 1, 0, true, "(min ...) returns the minimum of its arguments", sc->pcl_r); set_all_integer_and_float(sc->min_symbol); + sc->max_symbol = s7_define_typed_function(sc, "s7-max", g_max, 1, 0, true, "(max ...) returns the maximum of its arguments", sc->pcl_r); 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("s7-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 = s7_define_typed_function(sc, "gcd", g_gcd, 0, 0, true, "(gcd ...) returns the greatest common divisor of its rational arguments", sc->pcl_f); + sc->lcm_symbol = s7_define_typed_function(sc, "s7-lcm", g_lcm, 0, 0, true, "(lcm ...) returns the least common multiple of its rational arguments", sc->pcl_f); + sc->rationalize_symbol = s7_define_typed_function(sc, "rationalize", g_rationalize, 1, 1, false, "(rationalize x err) returns the ratio with smallest denominator within err of x", s7_make_signature(sc, 3, sc->is_rational_symbol, sc->is_real_symbol, sc->is_real_symbol)); + 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, 2, false); + sc->expt_symbol = s7_define_typed_function(sc, "expt", g_expt, 2, 0, false, "(expt z1 z2) returns z1^z2", sc->pcl_n); + sc->log_symbol = s7_define_typed_function(sc, "log", g_log, 1, 1, false, "(log z1 (z2 e)) returns log(z1) / log(z2) where z2 (the base) defaults to e: (log 8 2) = 3", sc->pcl_n); + sc->ash_symbol = s7_define_typed_function(sc, "ash", g_ash, 2, 0, false, "(ash i1 i2) returns i1 shifted right or left i2 times, i1 << i2, (ash 1 3) -> 8, (ash 8 -3) -> 1", sc->pcl_i); + sc->exp_symbol = s7_define_typed_function(sc, "exp", g_exp, 1, 0, false, "(exp z) returns e^z, (exp 1) is 2.718281828459", sc->pl_nn); set_all_float(sc->exp_symbol); + sc->abs_symbol = s7_define_typed_function(sc, "abs", g_abs, 1, 0, false, "(abs x) returns the absolute value of the real number x", s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)); set_is_translucent(sc->abs_symbol); + sc->magnitude_symbol = s7_define_typed_function(sc, "magnitude", g_magnitude, 1, 0, false, "(magnitude z) returns the magnitude of z", s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)); set_all_integer_and_float(sc->magnitude_symbol); + sc->angle_symbol = s7_define_typed_function(sc, "angle", g_angle, 1, 0, false, "(angle z) returns the angle of z", s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_number_symbol)); + sc->sin_symbol = s7_define_typed_function(sc, "sin", g_sin, 1, 0, false, "(sin z) returns sin(z)", sc->pl_nn); set_all_float(sc->sin_symbol); + sc->cos_symbol = s7_define_typed_function(sc, "cos", g_cos, 1, 0, false, "(cos z) returns cos(z)", sc->pl_nn); set_all_float(sc->cos_symbol); + sc->tan_symbol = s7_define_typed_function(sc, "tan", g_tan, 1, 0, false, "(tan z) returns tan(z)", sc->pl_nn); set_all_float(sc->tan_symbol); + sc->sinh_symbol = s7_define_typed_function(sc, "sinh", g_sinh, 1, 0, false, "(sinh z) returns sinh(z)", sc->pl_nn); set_all_float(sc->sinh_symbol); + sc->cosh_symbol = s7_define_typed_function(sc, "cosh", g_cosh, 1, 0, false, "(cosh z) returns cosh(z)", sc->pl_nn); set_all_float(sc->cosh_symbol); + sc->tanh_symbol = s7_define_typed_function(sc, "tanh", g_tanh, 1, 0, false, "(tanh z) returns tanh(z)", sc->pl_nn); set_all_float(sc->tanh_symbol); + sc->asin_symbol = s7_define_typed_function(sc, "asin", g_asin, 1, 0, false, "(asin z) returns asin(z); (sin (asin x)) = x", sc->pl_nn); + sc->acos_symbol = s7_define_typed_function(sc, "acos", g_acos, 1, 0, false, "(acos z) returns acos(z); (cos (acos 1)) = 1", sc->pl_nn); + sc->atan_symbol = s7_define_typed_function(sc, "atan", g_atan, 1, 1, false, "(atan z) returns atan(z), (atan y x) returns atan(y/x)", s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_number_symbol, sc->is_real_symbol)); + sc->asinh_symbol = s7_define_typed_function(sc, "asinh", g_asinh, 1, 0, false, "(asinh z) returns asinh(z)", sc->pl_nn); + sc->acosh_symbol = s7_define_typed_function(sc, "acosh", g_acosh, 1, 0, false, "(acosh z) returns acosh(z)", sc->pl_nn); + sc->atanh_symbol = s7_define_typed_function(sc, "atanh", g_atanh, 1, 0, false, "(atanh z) returns atanh(z)", sc->pl_nn); + sc->sqrt_symbol = s7_define_typed_function(sc, "sqrt", g_sqrt, 1, 0, false, "(sqrt z) returns the square root of z", sc->pl_nn); + sc->floor_symbol = s7_define_typed_function(sc, "s7-floor", g_floor, 1, 0, false, "(s7-floor x) returns the integer closest to x toward -inf", s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); set_is_translucent(sc->floor_symbol); + sc->ceiling_symbol = s7_define_typed_function(sc, "s7-ceiling", g_ceiling, 1, 0, false, "(s7-ceiling x) returns the integer closest to x toward inf", s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); set_is_translucent(sc->ceiling_symbol); + sc->truncate_symbol = s7_define_typed_function(sc, "s7-truncate", g_truncate, 1, 0, false, "(truncate x) returns the integer closest to x toward 0", s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); set_is_translucent(sc->truncate_symbol); + sc->round_symbol = s7_define_typed_function(sc, "s7-round", g_round, 1, 0, false, "(round x) returns the integer closest to x", s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_real_symbol)); set_is_translucent(sc->round_symbol); + sc->logand_symbol = s7_define_typed_function(sc, "logand", g_logand, 0, 0, true, "(logand int32_t ...) returns the AND of its integer arguments (the bits that are on in every argument)", sc->pcl_i); + sc->logior_symbol = s7_define_typed_function(sc, "logior", g_logior, 0, 0, true, "(logior int32_t ...) returns the OR of its integer arguments (the bits that are on in any of the arguments)", sc->pcl_i); + sc->logxor_symbol = s7_define_typed_function(sc, "logxor", g_logxor, 0, 0, true, "(logxor int32_t ...) returns the XOR of its integer arguments (the bits that are on in an odd number of the arguments)", sc->pcl_i); + sc->lognot_symbol = s7_define_typed_function(sc, "lognot", g_lognot, 1, 0, false, "(lognot num) returns the negation of num (its complement, the bits that are not on): (lognot 0) -> -1", sc->pcl_i); + sc->logbit_symbol = s7_define_typed_function(sc, "logbit?", g_logbit, 2, 0, false, "(logbit? int index) returns #t if the index-th bit is on in int, otherwise #f.", s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_integer_symbol)); + 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= s7_define_typed_function ( - sc, "inexact->exact", g_inexact_to_exact, 1, 0, false, - "(inexact->exact num) converts num to an exact number; (inexact->exact " - "1.5) = 3/2", - s7_make_signature (sc, 2, sc->is_real_symbol, sc->is_real_symbol)); - sc->exact_to_inexact_symbol= s7_define_typed_function ( - sc, "exact->inexact", g_exact_to_inexact, 1, 0, false, - "(exact->inexact num) converts num to an inexact number; (exact->inexact " - "3/2) = 1.5", - s7_make_signature (sc, 2, sc->is_number_symbol, sc->is_number_symbol)); - sc->is_exact_symbol= s7_define_typed_function ( - sc, "exact?", g_exact, 1, 0, false, - "(exact? num) returns #t if num is exact (an integer or a ratio)", - sc->pl_bn); - sc->is_inexact_symbol= - s7_define_typed_function (sc, "inexact?", g_inexact, 1, 0, false, - "(inexact? num) returns #t if num is inexact " - "(neither an integer nor a ratio)", - sc->pl_bn); - sc->make_polar_symbol= s7_define_typed_function ( - sc, "make-polar", g_make_polar, 2, 0, false, - "(make-polar magnitude angle) returns (complex (* magnitude (cos angle)) " - "(* magnitude (sin angle)))", - s7_make_signature (sc, 3, sc->is_number_symbol, sc->is_real_symbol, - sc->is_real_symbol)); + sc->integer_length_symbol = defun("integer-length", integer_length, 1, 0, false); + sc->inexact_to_exact_symbol = s7_define_typed_function(sc, "inexact->exact", g_inexact_to_exact, 1, 0, false, "(inexact->exact num) converts num to an exact number; (inexact->exact 1.5) = 3/2", s7_make_signature(sc, 2, sc->is_real_symbol, sc->is_real_symbol)); + sc->exact_to_inexact_symbol = s7_define_typed_function(sc, "exact->inexact", g_exact_to_inexact, 1, 0, false, "(exact->inexact num) converts num to an inexact number; (exact->inexact 3/2) = 1.5", s7_make_signature(sc, 2, sc->is_number_symbol, sc->is_number_symbol)); + sc->is_exact_symbol = s7_define_typed_function(sc, "exact?", g_exact, 1, 0, false, "(exact? num) returns #t if num is exact (an integer or a ratio)", sc->pl_bn); + sc->is_inexact_symbol = s7_define_typed_function(sc, "inexact?", g_inexact, 1, 0, false, "(inexact? num) returns #t if num is inexact (neither an integer nor a ratio)", sc->pl_bn); + sc->make_polar_symbol = s7_define_typed_function(sc, "make-polar", g_make_polar, 2, 0, false, "(make-polar magnitude angle) returns (complex (* magnitude (cos angle)) (* magnitude (sin angle)))", s7_make_signature(sc, 3, sc->is_number_symbol, sc->is_real_symbol, sc->is_real_symbol)); #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_to_integer_symbol= s7_define_typed_function ( - sc, "char->integer", g_char_to_integer, 1, 0, false, - "(char->integer c) converts the character c to an integer", - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_char_symbol)); - sc->integer_to_char_symbol= s7_define_typed_function ( - sc, "integer->char", g_integer_to_char, 1, 0, false, - "(integer->char i) converts the non-negative integer i to a character", - s7_make_signature (sc, 2, sc->is_char_symbol, sc->is_integer_symbol)); - - sc->char_eq_symbol= s7_define_typed_function ( - sc, "char=?", g_chars_are_equal, 2, 0, true, - "(char=? char ...) returns #t if all the character arguments are equal", - sc->pcl_bc); - sc->char_lt_symbol= - s7_define_typed_function (sc, "charpcl_bc); - sc->char_gt_symbol= - s7_define_typed_function (sc, "char>?", g_chars_are_greater, 2, 0, true, - "(char>? char ...) returns #t if all the " - "character arguments are decreasing", - sc->pcl_bc); - sc->char_leq_symbol= - s7_define_typed_function (sc, "char<=?", g_chars_are_leq, 2, 0, true, - "(char<=? char ...) returns #t if all the " - "character arguments are equal or increasing", - sc->pcl_bc); - sc->char_geq_symbol= - s7_define_typed_function (sc, "char>=?", g_chars_are_geq, 2, 0, true, - "(char>=? char ...) returns #t if all the " - "character arguments are equal or decreasing", - sc->pcl_bc); - sc->char_position_symbol= s7_define_typed_function ( - sc, "char-position", g_char_position, 2, 1, false, - "(char-position char-or-str str (start 0)) returns the position of the " - "first occurrence of char in str, or #f", - 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)); - 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 = s7_define_typed_function ( - sc, "string-ref", g_string_ref, 2, 0, false, - "(string-ref str index) returns the character at the index-th element of " - "the string str", - s7_make_signature (sc, 3, sc->is_char_symbol, sc->is_string_symbol, - sc->is_integer_symbol)); - sc->string_set_symbol= s7_define_typed_function ( - sc, "string-set!", g_string_set, 3, 0, false, - "(string-set! str index chr) sets the index-th element of the string str " - "to the character chr", - s7_make_signature (sc, 4, sc->is_char_symbol, sc->is_string_symbol, - sc->is_integer_symbol, sc->is_char_symbol)); - - 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); + 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_to_integer_symbol = s7_define_typed_function(sc, "char->integer", g_char_to_integer, 1, 0, false, + "(char->integer c) converts the character c to an integer", + s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_char_symbol)); + sc->integer_to_char_symbol = s7_define_typed_function(sc, "integer->char", g_integer_to_char, 1, 0, false, + "(integer->char i) converts the non-negative integer i to a character", + s7_make_signature(sc, 2, sc->is_char_symbol, sc->is_integer_symbol)); + + + sc->char_eq_symbol = s7_define_typed_function(sc, "char=?", g_chars_are_equal, 2, 0, true, + "(char=? char ...) returns #t if all the character arguments are equal", sc->pcl_bc); + sc->char_lt_symbol = s7_define_typed_function(sc, "charpcl_bc); + sc->char_gt_symbol = s7_define_typed_function(sc, "char>?", g_chars_are_greater, 2, 0, true, + "(char>? char ...) returns #t if all the character arguments are decreasing", sc->pcl_bc); + sc->char_leq_symbol = s7_define_typed_function(sc, "char<=?", g_chars_are_leq, 2, 0, true, + "(char<=? char ...) returns #t if all the character arguments are equal or increasing", sc->pcl_bc); + sc->char_geq_symbol = s7_define_typed_function(sc, "char>=?", g_chars_are_geq, 2, 0, true, + "(char>=? char ...) returns #t if all the character arguments are equal or decreasing", sc->pcl_bc); + sc->char_position_symbol = s7_define_typed_function(sc, "char-position", g_char_position, 2, 1, false, + "(char-position char-or-str str (start 0)) returns the position of the first occurrence of char in str, or #f", + 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)); + 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 = s7_define_typed_function(sc, "string-ref", g_string_ref, 2, 0, false, + "(string-ref str index) returns the character at the index-th element of the string str", + s7_make_signature(sc, 3, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol)); + sc->string_set_symbol = s7_define_typed_function(sc, "string-set!", g_string_set, 3, 0, false, + "(string-set! str index chr) sets the index-th element of the string str to the character chr", + s7_make_signature(sc, 4, sc->is_char_symbol, sc->is_string_symbol, sc->is_integer_symbol, sc->is_char_symbol)); + + 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->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= s7_define_typed_function ( - sc, "string-length", g_string_length, 1, 0, false, - "(string-length str) returns the length of str.", - s7_make_signature (sc, 2, sc->is_integer_symbol, sc->is_string_symbol)); - sc->string_to_list_symbol= - defun ("string->list", string_to_list, 1, 2, false); + 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 = s7_define_typed_function(sc, "string-length", g_string_length, 1, 0, false, "(string-length str) returns the length of str.", s7_make_signature(sc, 2, sc->is_integer_symbol, sc->is_string_symbol)); + 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_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); - -#define H_format \ - "(format [out] str . args) substitutes args into str sending the result to out. Most of \ + sc->string_copy_symbol = defun("string-copy", string_copy, 1, 3, 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); + + #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, \ @@ -98806,1165 +80007,877 @@ spacing (and spacing character) and precision. ~{ starts an embedded format dir 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, 4, sc->is_output_port_symbol, \ - sc->is_boolean_symbol, sc->is_null_symbol, \ - sc->is_string_symbol), \ - sc->T) - - sc->format_symbol = defun ("format", format, 1, 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); - -#define H_filter \ - "(g_filter pred lst) returns a list of the elements of lst for which (pred " \ - "element) is not #f" -#define Q_filter \ - s7_make_signature (sc, 3, sc->is_list_symbol, sc->is_procedure_symbol, \ - sc->is_list_symbol) - s7_define_semisafe_typed_function (sc, "g_filter", g_filter, 2, 0, false, - H_filter, Q_filter); - -#define H_find \ - "(g_find pred lst) returns the first element of lst for which (pred " \ - "element) is not #f, or #f if there is no such element" -#define Q_find \ - s7_make_signature (sc, 3, sc->T, sc->is_procedure_symbol, sc->is_list_symbol) - s7_define_semisafe_typed_function (sc, "g_find", g_find, 2, 0, false, H_find, - Q_find); - -#define H_any \ - "(g_any pred lst) returns #t if (pred element) is not #f for some element " \ - "of lst, otherwise #f" -#define Q_any \ - s7_make_signature (sc, 3, sc->is_boolean_symbol, sc->is_procedure_symbol, \ - sc->is_list_symbol) - s7_define_semisafe_typed_function (sc, "g_any", g_any, 2, 0, false, H_any, - Q_any); - -#define H_every \ - "(g_every pred lst) returns #t if (pred element) is not #f for every " \ - "element of lst, otherwise #f" -#define Q_every \ - s7_make_signature (sc, 3, sc->is_boolean_symbol, sc->is_procedure_symbol, \ - sc->is_list_symbol) - s7_define_semisafe_typed_function (sc, "g_every", g_every, 2, 0, false, - H_every, Q_every); - -#define H_count \ - "(g_count pred clist1 clist2 ...) returns the number of element tuples for " \ - "which (pred elem1 elem2 ...) is not #f, stopping at the end of the " \ - "shortest list" -#define Q_count \ - s7_make_circular_signature (sc, 2, 3, sc->is_integer_symbol, \ - sc->is_procedure_symbol, sc->is_list_symbol) - s7_define_semisafe_typed_function (sc, "g_count", g_count, 2, 0, true, - H_count, Q_count); - -#define H_list_index \ - "(g_list_index pred clist1 clist2 ...) returns the index of the first " \ - "element tuple for which (pred elem1 elem2 ...) is not #f, or #f if there " \ - "is none, stopping at the end of the shortest list" -#define Q_list_index \ - s7_make_circular_signature (sc, 2, 3, sc->T, sc->is_procedure_symbol, \ - sc->is_list_symbol) - s7_define_semisafe_typed_function (sc, "g_list_index", g_list_index, 2, 0, - true, H_list_index, Q_list_index); - -#define H_fold \ - "(g_fold f init lst) folds f over the elements of lst: (f elem acc)" -#define Q_fold \ - s7_make_signature (sc, 4, sc->T, sc->is_procedure_symbol, sc->T, \ - sc->is_list_symbol) - s7_define_semisafe_typed_function (sc, "g_fold", g_fold, 3, 0, false, H_fold, - Q_fold); - -#define H_fold_right \ - "(g_fold_right f init lst) folds f from the right over the elements of " \ - "lst: (f elem acc)" -#define Q_fold_right \ - s7_make_signature (sc, 4, sc->T, sc->is_procedure_symbol, sc->T, \ - sc->is_list_symbol) - s7_define_semisafe_typed_function (sc, "g_fold_right", g_fold_right, 3, 0, - false, H_fold_right, Q_fold_right); - -#define H_take "(g_take lst k) returns a list of the first k elements of lst" -#define Q_take \ - s7_make_signature (sc, 3, sc->is_list_symbol, sc->is_list_symbol, \ - sc->is_integer_symbol) - s7_define_semisafe_typed_function (sc, "g_take", g_take, 2, 0, false, H_take, - Q_take); - -/* take-right can return the non-pair tail of a dotted list, hence the #t return - * signature */ -#define H_take_right "(g_take_right lst k) returns the last k elements of lst" -#define Q_take_right \ - s7_make_signature (sc, 3, sc->T, sc->is_list_symbol, sc->is_integer_symbol) - s7_define_semisafe_typed_function (sc, "g_take_right", g_take_right, 2, 0, - false, H_take_right, Q_take_right); - -#define H_drop_right \ - "(g_drop_right lst k) returns a list of all but the last k elements of lst" -#define Q_drop_right \ - s7_make_signature (sc, 3, sc->is_list_symbol, sc->is_list_symbol, \ - sc->is_integer_symbol) - s7_define_semisafe_typed_function (sc, "g_drop_right", g_drop_right, 2, 0, - false, H_drop_right, Q_drop_right); - -#define H_vector_filter \ - "(g_vector_filter pred vec) returns a vector of the elements of vec for " \ - "which (pred element) is not #f" -#define Q_vector_filter \ - s7_make_signature (sc, 3, sc->is_vector_symbol, sc->is_procedure_symbol, \ - sc->is_vector_symbol) - s7_define_semisafe_typed_function (sc, "g_vector_filter", g_vector_filter, 2, - 0, false, H_vector_filter, - Q_vector_filter); - - 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); + #define Q_format s7_make_circular_signature(sc, 2, 3, \ + sc->is_string_symbol, s7_make_signature(sc, 4, sc->is_output_port_symbol, sc->is_boolean_symbol, sc->is_null_symbol, sc->is_string_symbol), sc->T) + + sc->format_symbol = defun("format", format, 1, 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); + + #define H_filter "(g_filter pred lst) returns a list of the elements of lst for which (pred element) is not #f" + #define Q_filter s7_make_signature(sc, 3, sc->is_list_symbol, sc->is_procedure_symbol, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_filter", g_filter, 2, 0, false, H_filter, Q_filter); + + #define H_find "(g_find pred lst) returns the first element of lst for which (pred element) is not #f, or #f if there is no such element" + #define Q_find s7_make_signature(sc, 3, sc->T, sc->is_procedure_symbol, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_find", g_find, 2, 0, false, H_find, Q_find); + + #define H_any "(g_any pred lst) returns #t if (pred element) is not #f for some element of lst, otherwise #f" + #define Q_any s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->is_procedure_symbol, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_any", g_any, 2, 0, false, H_any, Q_any); + + #define H_every "(g_every pred lst) returns #t if (pred element) is not #f for every element of lst, otherwise #f" + #define Q_every s7_make_signature(sc, 3, sc->is_boolean_symbol, sc->is_procedure_symbol, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_every", g_every, 2, 0, false, H_every, Q_every); + + #define H_count "(g_count pred clist1 clist2 ...) returns the number of element tuples for which (pred elem1 elem2 ...) is not #f, stopping at the end of the shortest list" + #define Q_count s7_make_circular_signature(sc, 2, 3, sc->is_integer_symbol, sc->is_procedure_symbol, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_count", g_count, 2, 0, true, H_count, Q_count); + + #define H_list_index "(g_list_index pred clist1 clist2 ...) returns the index of the first element tuple for which (pred elem1 elem2 ...) is not #f, or #f if there is none, stopping at the end of the shortest list" + #define Q_list_index s7_make_circular_signature(sc, 2, 3, sc->T, sc->is_procedure_symbol, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_list_index", g_list_index, 2, 0, true, H_list_index, Q_list_index); + + #define H_fold "(g_fold f init lst) folds f over the elements of lst: (f elem acc)" + #define Q_fold s7_make_signature(sc, 4, sc->T, sc->is_procedure_symbol, sc->T, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_fold", g_fold, 3, 0, false, H_fold, Q_fold); + + #define H_fold_right "(g_fold_right f init lst) folds f from the right over the elements of lst: (f elem acc)" + #define Q_fold_right s7_make_signature(sc, 4, sc->T, sc->is_procedure_symbol, sc->T, sc->is_list_symbol) + s7_define_semisafe_typed_function(sc, "g_fold_right", g_fold_right, 3, 0, false, H_fold_right, Q_fold_right); + + #define H_take "(g_take lst k) returns a list of the first k elements of lst" + #define Q_take s7_make_signature(sc, 3, sc->is_list_symbol, sc->is_list_symbol, sc->is_integer_symbol) + s7_define_semisafe_typed_function(sc, "g_take", g_take, 2, 0, false, H_take, Q_take); + + /* take-right can return the non-pair tail of a dotted list, hence the #t return signature */ + #define H_take_right "(g_take_right lst k) returns the last k elements of lst" + #define Q_take_right s7_make_signature(sc, 3, sc->T, sc->is_list_symbol, sc->is_integer_symbol) + s7_define_semisafe_typed_function(sc, "g_take_right", g_take_right, 2, 0, false, H_take_right, Q_take_right); + + #define H_drop_right "(g_drop_right lst k) returns a list of all but the last k elements of lst" + #define Q_drop_right s7_make_signature(sc, 3, sc->is_list_symbol, sc->is_list_symbol, sc->is_integer_symbol) + s7_define_semisafe_typed_function(sc, "g_drop_right", g_drop_right, 2, 0, false, H_drop_right, Q_drop_right); + + #define H_vector_filter "(g_vector_filter pred vec) returns a vector of the elements of vec for which (pred element) is not #f" + #define Q_vector_filter s7_make_signature(sc, 3, sc->is_vector_symbol, sc->is_procedure_symbol, sc->is_vector_symbol) + s7_define_semisafe_typed_function(sc, "g_vector_filter", g_vector_filter, 2, 0, false, H_vector_filter, Q_vector_filter); + + 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); -#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) - 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); -#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) - sc->vector_length_symbol= defun ("vector-length", vector_length, 1, 0, false); - sc->vector_to_list_symbol= - defun ("vector->list", vector_to_list, 1, 2, false); + sc->vector_append_symbol = defun("vector-append", vector_append, 0, 0, true); + #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) + 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); + #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) + 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; + sc->vector_append_symbol = sc->append_symbol; + sc->vector_fill_symbol = sc->fill_symbol; + sc->string_fill_symbol = sc->fill_symbol; #endif -#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) - sc->vector_ref_symbol= defun ("vector-ref", vector_ref, 2, 0, true); - sc->vector_set_symbol= defun ("vector-set!", vector_set, 3, 0, true); -#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) - sc->vector_dimension_symbol= - defun ("vector-dimension", vector_dimension, 2, 0, false); -#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) - sc->vector_dimensions_symbol= - defun ("vector-dimensions", vector_dimensions, 1, 0, false); -#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) - 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); -#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) - sc->vector_symbol= defun ("vector", vector, 0, 0, true); - set_is_saver (sc->vector_symbol); -#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) - 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); -#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) - sc->subvector_position_symbol= - defun ("subvector-position", subvector_position, 1, 0, false); -#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) - sc->subvector_vector_symbol= - defun ("subvector-vector", subvector_vector, 1, 0, false); - -#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) - 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); - -#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) - 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); - -#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) - 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); - -#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) - 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); -#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) - sc->string_to_byte_vector_symbol= - defun ("string->byte-vector", string_to_byte_vector, 1, 0, false); -#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) - 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 ("s7-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 ("s7-hash-table-set!", hash_table_set, 3, 0, false); - sc->hash_table_size_symbol= - defun ("hash-table-size", hash_table_size, 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); -#define H_autoload \ - "(autoload symbol file-or-function) adds the symbol to its table of autoloadable symbols. \ + #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) + sc->vector_ref_symbol = defun("vector-ref", vector_ref, 2, 0, true); + sc->vector_set_symbol = defun("vector-set!", vector_set, 3, 0, true); + #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) + sc->vector_dimension_symbol = defun("vector-dimension", vector_dimension, 2, 0, false); + #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) + sc->vector_dimensions_symbol = defun("vector-dimensions", vector_dimensions, 1, 0, false); + #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) + 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); + #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) + sc->vector_symbol = defun("vector", vector, 0, 0, true); set_is_saver(sc->vector_symbol); + #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) + 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); + #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) + sc->subvector_position_symbol = defun("subvector-position", subvector_position, 1, 0, false); + #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) + sc->subvector_vector_symbol = defun("subvector-vector", subvector_vector, 1, 0, false); + + #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) + 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); + + #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) + 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); + + #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) + 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); + + #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) + 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); + #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) + sc->string_to_byte_vector_symbol = defun("string->byte-vector", string_to_byte_vector, 1, 0, false); + #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) + 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("s7-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("s7-hash-table-set!", hash_table_set, 3, 0, false); + sc->hash_table_size_symbol = defun("hash-table-size", hash_table_size, 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); + #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) - 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 + #define Q_autoload s7_make_signature(sc, 3, sc->T, sc->is_symbol_symbol, sc->T) + 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 - */ + 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); + sc->unquote_symbol = make_symbol(sc, "", 9); set_immutable(sc->unquote_symbol); #else - sc->unquote_symbol= make_symbol (sc, "unquote", 7); + 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); + 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); + 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)); + get_func = s7_typed_dilambda(sc, "setter", g_setter, 1, 1, g_set_setter, 2, 1, H_setter, Q_setter, NULL); + set_immutable(c_function_setter(get_func)); } - sc->arity_symbol = defun ("arity", arity, 1, 0, false); - sc->is_aritable_symbol= defun ("aritable?", is_aritable, 2, 0, false); + sc->arity_symbol = defun("arity", arity, 1, 0, false); + sc->is_aritable_symbol = defun("aritable?", is_aritable, 2, 0, false); - sc->is_eq_symbol = defun ("eq?", is_eq, 2, 0, false); - sc->is_eqv_symbol = defun ("eqv?", is_eqv, 2, 0, false); - sc->is_equal_symbol = defun ("equal?", is_equal, 2, 0, false); - sc->is_equivalent_symbol= defun ("equivalent?", is_equivalent, 2, 0, false); - sc->type_of_symbol = defun ("type-of", type_of, 1, 0, false); + sc->is_eq_symbol = defun("eq?", is_eq, 2, 0, false); + sc->is_eqv_symbol = defun("eqv?", is_eqv, 2, 0, false); + sc->is_equal_symbol = defun("equal?", is_equal, 2, 0, false); + sc->is_equivalent_symbol = defun("equivalent?", is_equivalent, 2, 0, false); + sc->type_of_symbol = defun("type-of", type_of, 1, 0, false); - sc->gc_symbol= semisafe_defun ("gc", gc, 0, 1, false); - defun ("emergency-exit", emergency_exit, 0, 1, false); - sc->exit_symbol= defun ("exit", exit, 0, 2, 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"); + 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); + 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_member_symbol = defun ("tree-member?", tree_member, 2, 1, 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); + 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_member_symbol = defun("tree-member?", tree_member, 2, 1, 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); #if !WITH_PURE_S7 - sc->cond_expand_symbol= s7_define_expansion (sc, "cond-expand", g_cond_expand, - 1, 0, true, H_cond_expand); + sc->cond_expand_symbol = s7_define_expansion(sc, "cond-expand", g_cond_expand, 1, 0, true, H_cond_expand); #endif #if WITH_R7RS - sc->r7rs_inited= false; - sc->global_is_eq= - global_value (sc->is_eq_symbol); /* for later restore ('r7rs -> 's7) */ - sc->global_memq = global_value (sc->memq_symbol); - sc->global_assq = global_value (sc->assq_symbol); - sc->initial_is_eq= initial_value (sc->is_eq_symbol); - sc->initial_memq = initial_value (sc->memq_symbol); - sc->initial_assq = initial_value (sc->assq_symbol); + sc->r7rs_inited = false; + sc->global_is_eq = global_value(sc->is_eq_symbol); /* for later restore ('r7rs -> 's7) */ + sc->global_memq = global_value(sc->memq_symbol); + sc->global_assq = global_value(sc->assq_symbol); + sc->initial_is_eq = initial_value(sc->is_eq_symbol); + sc->initial_memq = initial_value(sc->memq_symbol); + sc->initial_assq = initial_value(sc->assq_symbol); #endif - sc->profile_in_symbol= unsafe_defun ("profile-in", profile_in, 2, 0, - false); /* calls dynamic-unwind */ - sc->profile_out = NULL; + sc->profile_in_symbol = unsafe_defun("profile-in", profile_in, 2, 0, false); /* calls dynamic-unwind */ + sc->profile_out = NULL; /* -------- *features* -------- */ - sc->features_symbol= s7_define_variable_with_documentation ( - sc, "*features*", sc->nil, - "list of currently available features ('complex-numbers, etc)"); - s7_set_setter (sc, sc->features_symbol, - sc->features_setter= s7_make_safe_function ( - sc, "#", g_features_set, 2, 0, false, - "*features* setter")); + 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")); + 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); + 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); + 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 */ -#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) - 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); + 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 */ + #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) + 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")); + 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); + 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); + init_features(sc); + init_setters(sc); } #if !MS_WINDOWS -static pthread_mutex_t init_lock= PTHREAD_MUTEX_INITIALIZER; +static pthread_mutex_t init_lock = PTHREAD_MUTEX_INITIALIZER; #endif -s7_scheme* -s7_init (void) { - s7_scheme* sc; - static bool already_inited= false; +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); + 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_scheme_char_tables (); - init_chars (); - init_strings (); - init_fx_function (); - init_catchers (); - init_starlet_immutable_field (); - init_leven (); - already_inited= true; - } + 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_scheme_char_tables(); + init_chars(); + init_strings(); + init_fx_function(); + init_catchers(); + init_starlet_immutable_field(); + init_leven(); + already_inited = true; + } #if S7_DEBUGGING - init_never_unheaped (); + init_never_unheaped(); #endif #if !MS_WINDOWS - pthread_mutex_unlock (&init_lock); + pthread_mutex_unlock(&init_lock); #endif - sc= (s7_scheme*) Calloc (1, sizeof (s7_scheme)); /* not malloc! */ + 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; + 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->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->current_distance= - (int32_t**) malloc ((LEVEN_MAX_LEN + 1) * sizeof (int32_t*)); - for (int32_t i= 0; i <= LEVEN_MAX_LEN; i++) - sc->current_distance[i]= - (int32_t*) malloc ((LEVEN_MAX_LEN + 1) * sizeof (int32_t)); - - 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; + 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->current_distance = (int32_t **)malloc((LEVEN_MAX_LEN + 1) * sizeof(int32_t *)); + for (int32_t i = 0; i <= LEVEN_MAX_LEN; i++) + sc->current_distance[i] = (int32_t *)malloc((LEVEN_MAX_LEN + 1) * sizeof(int32_t)); + + 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); + 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->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; + 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); - set_cdr_unchecked (sc->history_sink, sc->history_sink); + 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); + set_cdr_unchecked(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)); - set_cdr_unchecked (p3, sc->history_pairs); - for (p1= sc->eval_history1, p2= sc->eval_history2; is_pair (cdr (p1)); - p1= cdr (p1), p2= cdr (p2)) - ; - set_cdr_unchecked (p1, sc->eval_history1); - set_cdr_unchecked (p2, sc->eval_history2); - sc->cur_code = sc->eval_history1; - sc->using_history1= true; - sc->old_cur_code = sc->cur_code; + 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)); + set_cdr_unchecked(p3, sc->history_pairs); + for (p1 = sc->eval_history1, p2 = sc->eval_history2; is_pair(cdr(p1)); p1 = cdr(p1), p2 = cdr(p2)); + set_cdr_unchecked(p1, sc->eval_history1); + set_cdr_unchecked(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; + 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; + 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; + sc->is_autoloading = false; #else - sc->is_autoloading= true; + sc->is_autoloading = true; #endif - sc->max_show_stack_frames= 20; + sc->max_show_stack_frames = 20; - sc->heap_size= (INITIAL_HEAP_SIZE > 0) ? INITIAL_HEAP_SIZE : 64000; + 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; + 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]; + 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; + 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]; + 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; + 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 lenheap[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; + 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; + 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); + 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->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; - } - } + 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)); + 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; + 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); + 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->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->scheme_version = make_symbol (sc, "s7", 2); - 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; + 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->scheme_version = make_symbol(sc, "s7", 2); + 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->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->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->s7_symbol = make_symbol (sc, "s7", 2); - sc->r5rs_symbol= make_symbol (sc, "r5rs", 4); - sc->r7rs_symbol= make_symbol (sc, "r7rs", 4); - - 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->objstr_max_len = S7_INT64_MAX; + sc->temp_error_hook = sc->nil; + sc->anon_symbol = make_symbol(sc, "anonymous-lambda", 16); + + sc->s7_symbol = make_symbol(sc, "s7", 2); + sc->r5rs_symbol = make_symbol(sc, "r5rs", 4); + sc->r7rs_symbol = make_symbol(sc, "r7rs", 4); + + 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); + 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; - 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; - } - - sc->pi_symbol= s7_define_constant (sc, "pi", real_pi); - - 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); + 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; + 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; + } + + sc->pi_symbol = s7_define_constant(sc, "pi", real_pi); + + 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); + 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\ + 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\ @@ -99973,116 +80886,79 @@ s7_init (void) { (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%) + /* (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)."); + 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"); + 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)."); + 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)"); + 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))"); + 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)."); + 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->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)."); /* -------- *exit-hook* -------- */ - sc->exit_hook= s7_eval_c_string (sc, "(make-hook 'code)"); - s7_define_constant_with_documentation ( - sc, "*exit-hook*", sc->exit_hook, - "*exit-hook* functions are called when exit is invoked, passed the exit " - "code as (hook 'code)."); + sc->exit_hook = s7_eval_c_string(sc, "(make-hook 'code)"); + s7_define_constant_with_documentation(sc, "*exit-hook*", sc->exit_hook, + "*exit-hook* functions are called when exit is invoked, passed the exit code as (hook 'code)."); - 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? */ + 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_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 (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))"); + 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?) or set it anyway, and assume user won't set! the global - * value causing the initial-value to be GC'd + /* 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?) + * or set it anyway, and assume user won't set! the global value causing the initial-value to be GC'd */ #endif #if S7_DEBUGGING - s7_define_function (sc, "report-missed-calls", g_report_missed_calls, 0, 0, - false, NULL); /* tc/recur tests in s7test.scm */ - if (strcmp (op_names[HOP_SAFE_C_PP], "h_safe_c_pp") != 0) - fprintf (stderr, "c op_name: %s\n", op_names[HOP_SAFE_C_PP]); - if (strcmp (op_names[OP_SET_WITH_LET_2], "set_with_let_2") != 0) - fprintf (stderr, "set op_name: %s\n", op_names[OP_SET_WITH_LET_2]); - if (NUM_OPS != 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)); + 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 */ - if (!s7_type_names[0]) { - fprintf (stderr, "no type_names\n"); - gdb_break (); - } /* squelch very stupid warnings! */ - if (POINTER_32) fprintf (stderr, "pointer 32!?\n"); + if (!s7_type_names[0]) {fprintf(stderr, "no type_names\n"); gdb_break();} /* squelch very stupid warnings! */ + if (POINTER_32) fprintf(stderr, "pointer 32!?\n"); #endif #if 0 /* 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 48/120, s7 11440/12280, opt_info 128 */ @@ -100091,279 +80967,252 @@ s7_init (void) { (int)sizeof(block_t), (int)sizeof(port_functions_t), (int)sizeof(s7_cell), (int)sizeof(s7_scheme), (int)sizeof(opt_info)); #endif - return (sc); + return(sc); } + /* -------------------------------- s7_free -------------------------------- */ -static void -gc_list_free (gc_list_t* g) { - free (g->list); - free (g); +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; - } +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 +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; + 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 (vector_block_unchecked (gp->list[i])) == TOP_BLOCK_LIST) - free (block_data (vector_block_unchecked (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 (string_block_unchecked (gp->list[i])) == TOP_BLOCK_LIST) - free (block_data (string_block_unchecked (gp->list[i]))); - gc_list_free (gp); - - gp= sc->output_ports; - for (s7_int i= 0; i < gp->loc; i++) { - if ((port_data_block_unchecked (gp->list[i])) && - (block_index (port_data_block_unchecked (gp->list[i])) == - TOP_BLOCK_LIST)) - free (block_data (port_data_block_unchecked ( - 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 ((port_data_block_unchecked (gp->list[i])) && - (block_index (port_data_block_unchecked (gp->list[i])) == - TOP_BLOCK_LIST)) - free (block_data (port_data_block_unchecked ( - 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 (hash_table_block_unchecked (gp->list[i])) == - TOP_BLOCK_LIST) - free (block_data (hash_table_block_unchecked (gp->list[i]))); - gc_list_free (gp); - - 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); + /* 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(vector_block_unchecked(gp->list[i])) == TOP_BLOCK_LIST) + free(block_data(vector_block_unchecked(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(string_block_unchecked(gp->list[i])) == TOP_BLOCK_LIST) + free(block_data(string_block_unchecked(gp->list[i]))); + gc_list_free(gp); + + gp = sc->output_ports; + for (s7_int i = 0; i < gp->loc; i++) + { + if ((port_data_block_unchecked(gp->list[i])) && + (block_index(port_data_block_unchecked(gp->list[i])) == TOP_BLOCK_LIST)) + free(block_data(port_data_block_unchecked(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); - 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 <= LEVEN_MAX_LEN; i++) - free (sc->current_distance[i]); - free (sc->current_distance); - - 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; + gp = sc->input_ports; + for (s7_int i = 0; i < gp->loc; i++) + if ((port_data_block_unchecked(gp->list[i])) && + (block_index(port_data_block_unchecked(gp->list[i])) == TOP_BLOCK_LIST)) + free(block_data(port_data_block_unchecked(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(hash_table_block_unchecked(gp->list[i])) == TOP_BLOCK_LIST) + free(block_data(hash_table_block_unchecked(gp->list[i]))); + gc_list_free(gp); + + + 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 <= LEVEN_MAX_LEN; i++) free(sc->current_distance[i]); + free(sc->current_distance); + + 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 (c_type); + 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); } - free (sc->c_object_types); - } #if S7_DEBUGGING || ((DISABLE_FILE_OUTPUT || POINTER_32) && (!WITH_GCC)) - if (sc == cur_sc) cur_sc= original_cur_sc; + if (sc == cur_sc) cur_sc = original_cur_sc; #endif - free (sc); + free(sc); } + /* -------------------------------- repl -------------------------------- */ #ifndef USE_SND -#define USE_SND 0 + #define USE_SND 0 #endif #ifndef WITH_MAIN -#define WITH_MAIN 0 + #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 */ + #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"); +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) { +void s7_repl(s7_scheme *sc) +{ #if !WITH_C_LOADER - dumb_repl (sc); + dumb_repl(sc); #else #if WITH_NOTCURSES - s7_load (sc, "nrepl.scm"); + 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 + * 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; + bool repl_loaded = false; #endif - const s7_pointer let= - 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, let); - const s7_pointer old_let= - s7_set_curlet (sc, let); /* let 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", let); - 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), - let); - slot_set_value ( - libs, - cons (sc, cons (sc, s7_make_semipermanent_string (sc, "libc.scm"), let), - slot_value (libs))); - } - s7_set_curlet (sc, old_let); /* restore incoming (curlet) */ - s7_gc_unprotect_at (sc, gc_loc); + const s7_pointer let = 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, let); + const s7_pointer old_let = s7_set_curlet(sc, let); /* let 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", let); + 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), let); + slot_set_value(libs, cons(sc, cons(sc, s7_make_semipermanent_string(sc, "libc.scm"), let), slot_value(libs))); + } + s7_set_curlet(sc, old_let); /* restore incoming (curlet) */ + s7_gc_unprotect_at(sc, gc_loc); #if !WITH_SYSTEM_EXTRAS - dumb_repl (sc); /* repl.scm uses file-exists? et al */ + 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 { + 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")); + 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))"); - } + 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 */ @@ -100372,91 +81221,83 @@ s7_repl (s7_scheme* sc) { #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. +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 (!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); + 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); +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); + 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 - char* dir= realdir (argv[0]); - if (dir) { - s7_add_to_load_path (sc, dir); - free (dir); - } -#endif - s7_repl (sc); + #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 for nrepl: gcc s7.c -o repl - * -DWITH_MAIN -DWITH_NOTCURSES -I. -O2 -g -lnotcurses-core -ldl -lm - * -Wl,-export-dynamic according to callgrind, clang is noticeably slower than - * gcc + } + 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 + * for nrepl: gcc s7.c -o repl -DWITH_MAIN -DWITH_NOTCURSES -I. -O2 -g -lnotcurses-core -ldl -lm -Wl,-export-dynamic + * according to callgrind, clang is noticeably slower than gcc * * (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 + * musl works, but there is some problem in libgsl.scm with gsl/gsl_blas.h I think * - * g++ s7.c -c -I. -g -O2 -Wall -Wextra -Wno-unused-parameter - * -Wno-implicit-fallthrough 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 + * g++ s7.c -c -I. -g -O2 -Wall -Wextra -Wno-unused-parameter -Wno-implicit-fallthrough + * 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 @@ -100499,10 +81340,12 @@ main (int argc, char** argv) { * tnum 6013 5396 5402 5394 * concordance 10.0 6095 5165 5345 5422 * tlist 9219 7546 6240 5770 5793 - * tari 14.3 12.5 6662 6292 5997 6085 [gc opt_if_b7p - * opt_p_pi_ss_fvref_direct] trec 19.6 6980 6656 6015 6074 tgsl - * 7802 6282 6208 6221 tset 6260 6278 6284 tleft - * 12.2 9753 7331 6393 6419 tmisc 7614 7130 7131 + * tari 14.3 12.5 6662 6292 5997 6085 [gc opt_if_b7p opt_p_pi_ss_fvref_direct] + * trec 19.6 6980 6656 6015 6074 + * tgsl 7802 6282 6208 6221 + * tset 6260 6278 6284 + * tleft 12.2 9753 7331 6393 6419 + * tmisc 7614 7130 7131 * tgc 10.4 7579 7619 7659 * tclo 8025 8809 7627 7657 * tlamb 8003 7920 7926 @@ -100514,420 +81357,162 @@ main (int argc, char** argv) { * tall 15.9 15.6 15.6 15.1 15.1 * timp 24.4 19.6 15.5 15.6 * tmv 21.9 20.7 16.6 17.7 - * calls 37.5 37.5 37.1 37.4 38.4 [unknown: mus_tap_dpd - * negate_p_p mus_rand_interp mus_table_lookup_dv -> 0] sg - * 55.8 55.3 55.4 56.4 [same?] tbig 175.8 148.1 145.5 145.2 + * calls 37.5 37.5 37.1 37.4 38.4 [unknown: mus_tap_dpd negate_p_p mus_rand_interp mus_table_lookup_dv -> 0] + * sg 55.8 55.3 55.4 56.4 [same?] + * tbig 175.8 148.1 145.5 145.2 * ---------------------------------------------- * * t883 -> s7test: - * (define (f11) (do ((x 3) (y 2) (i 0 (+ i 1))) ((= i 2) x) (set! x - * (make-int-vector x y)))): opt_p_ii_ss not an integer but an int-vector - * (debugger), but if run #i(2 2 2)!! type mixup above to t725, if loop_end - * large -> opt? maybe no b_i_s if func not restricted to int arg, or if only - * ints in expr (b_d_s -> b_D_s if float+int as above) + * (define (f11) (do ((x 3) (y 2) (i 0 (+ i 1))) ((= i 2) x) (set! x (make-int-vector x y)))): opt_p_ii_ss + * not an integer but an int-vector (debugger), but if run #i(2 2 2)!! + * type mixup above to t725, if loop_end large -> opt? + * maybe no b_i_s if func not restricted to int arg, or if only ints in expr (b_d_s -> b_D_s if float+int as above) * - * if safe func + s7_value -> sc->code clobbered error -- can we use this to - * warn user? this is misleading -- not itself a bug (apply_mv). in s7test we're - * using unsafe functions here even though they claim to be safe, why does the - * safe case work? bits for values/eval/eval_c/load_c + flag set if encountered, - * report if safe_proc (see unsafe-s7.c) but how to avoid check if s7_eval from - * scheme eval? use wrappers + * if safe func + s7_value -> sc->code clobbered error -- can we use this to warn user? this is misleading -- not itself a bug (apply_mv). + * in s7test we're using unsafe functions here even though they claim to be safe, why does the safe case work? + * bits for values/eval/eval_c/load_c + flag set if encountered, report if safe_proc (see unsafe-s7.c) but how to avoid check if s7_eval from scheme eval? + * use wrappers * * tmethod? why the (quote ...) in t725 output (not '...) * - * (*s7* scheme-version) possible unnecessary load_string/inits, check #_ funcs - * via t884, lint r7rs: string-copy needs to be protected/restored, as does - * delay, rtst->s7test problematic: guard (wrong return type) promise.scm has - * tests, provide for local? - * #;<> is supposed to return nothing(?), what is #;#;? #;3 reads more - * than it should + * (*s7* scheme-version) possible unnecessary load_string/inits, check #_ funcs via t884, lint + * r7rs: string-copy needs to be protected/restored, as does delay, rtst->s7test + * problematic: guard (wrong return type) + * promise.scm has tests, provide for local? + * #;<> is supposed to return nothing(?), what is #;#;? #;3 reads more than it should * - * build-in a repl as in nrepl, so WITH_MAIN is less stupid, maybe nrepl if not - * too onerous repl.scm is ca 4 times bigger, and will require libc -> s7.c for - * shell control etc + * build-in a repl as in nrepl, so WITH_MAIN is less stupid, maybe nrepl if not too onerous + * repl.scm is ca 4 times bigger, and will require libc -> s7.c for shell control etc * * [do_tree again -- instrumented...] * * old, maybe someday: - * 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) 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] there's room for - * int32_t in cell func + * 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) + * 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] + * there's room for int32_t in cell func */ -/* ========================================== format bridge functions - * ========================================== */ -void -s7i_add_format_column (s7_scheme* sc, s7_int val) { - sc->format_column+= val; -} -s7_int -s7i_format_column (s7_scheme* sc) { - return sc->format_column; -} -void -s7i_set_format_column (s7_scheme* sc, s7_int val) { - sc->format_column= val; -} -void -s7i_inc_format_column (s7_scheme* sc) { - sc->format_column++; -} +/* ========================================== format bridge functions ========================================== */ -s7_int -s7i_format_depth (s7_scheme* sc) { - return sc->format_depth; -} -void -s7i_inc_format_depth (s7_scheme* sc) { - sc->format_depth++; -} -void -s7i_dec_format_depth (s7_scheme* sc) { - sc->format_depth--; -} +void s7i_add_format_column(s7_scheme *sc, s7_int val) { sc->format_column += val; } +s7_int s7i_format_column(s7_scheme *sc) { return sc->format_column; } +void s7i_set_format_column(s7_scheme *sc, s7_int val) { sc->format_column = val; } +void s7i_inc_format_column(s7_scheme *sc) { sc->format_column++; } -int32_t -s7i_num_fdats (s7_scheme* sc) { - return sc->num_fdats; -} -void -s7i_set_num_fdats (s7_scheme* sc, int32_t val) { - sc->num_fdats= val; -} +s7_int s7i_format_depth(s7_scheme *sc) { return sc->format_depth; } +void s7i_inc_format_depth(s7_scheme *sc) { sc->format_depth++; } +void s7i_dec_format_depth(s7_scheme *sc) { sc->format_depth--; } -format_data_t** -s7i_fdats (s7_scheme* sc) { - return sc->fdats; -} -void -s7i_set_fdats (s7_scheme* sc, format_data_t** val) { - sc->fdats= val; -} +int32_t s7i_num_fdats(s7_scheme *sc) { return sc->num_fdats; } +void s7i_set_num_fdats(s7_scheme *sc, int32_t val) { sc->num_fdats = val; } -bool -s7i_has_openlets (s7_scheme* sc) { - return sc->has_openlets; -} -void -s7i_set_has_openlets (s7_scheme* sc, bool val) { - sc->has_openlets= val; -} +format_data_t **s7i_fdats(s7_scheme *sc) { return sc->fdats; } +void s7i_set_fdats(s7_scheme *sc, format_data_t **val) { sc->fdats = val; } -s7_int -s7i_print_length (s7_scheme* sc) { - return sc->print_length; -} +bool s7i_has_openlets(s7_scheme *sc) { return sc->has_openlets; } +void s7i_set_has_openlets(s7_scheme *sc, bool val) { sc->has_openlets = val; } -char* -s7i_strbuf (s7_scheme* sc) { - return sc->strbuf; -} -s7_int -s7i_strbuf_size (s7_scheme* sc) { - return sc->strbuf_size; -} +s7_int s7i_print_length(s7_scheme *sc) { return sc->print_length; } -s7_pointer -s7i_F (s7_scheme* sc) { - return sc->F; -} -s7_pointer -s7i_T (s7_scheme* sc) { - return sc->T; -} -s7_pointer -s7i_nil (s7_scheme* sc) { - return sc->nil; -} -s7_pointer -s7i_undefined (s7_scheme* sc) { - return sc->undefined; -} +char *s7i_strbuf(s7_scheme *sc) { return sc->strbuf; } +s7_int s7i_strbuf_size(s7_scheme *sc) { return sc->strbuf_size; } -s7_pointer -s7i_format_symbol (s7_scheme* sc) { - return sc->format_symbol; -} -s7_pointer -s7i_format_error_symbol (s7_scheme* sc) { - return sc->format_error_symbol; -} -s7_pointer -s7i_format_f (s7_scheme* sc) { - return sc->format_f; -} -s7_pointer -s7i_format_as_objstr (s7_scheme* sc) { - return sc->format_as_objstr; -} -s7_pointer -s7i_format_just_control_string (s7_scheme* sc) { - return sc->format_just_control_string; -} -s7_pointer -s7i_format_no_column (s7_scheme* sc) { - return sc->format_no_column; -} +s7_pointer s7i_F(s7_scheme *sc) { return sc->F; } +s7_pointer s7i_T(s7_scheme *sc) { return sc->T; } +s7_pointer s7i_nil(s7_scheme *sc) { return sc->nil; } +s7_pointer s7i_undefined(s7_scheme *sc) { return sc->undefined; } -s7_pointer -s7i_an_output_port_string (void) { - return an_output_port_string; -} -s7_pointer -s7i_a_format_port_string (void) { - return a_format_port_string; -} -void -s7i_set_sc_value (s7_scheme* sc, s7_pointer val) { - sc->value= val; -} +s7_pointer s7i_format_symbol(s7_scheme *sc) { return sc->format_symbol; } +s7_pointer s7i_format_error_symbol(s7_scheme *sc) { return sc->format_error_symbol; } +s7_pointer s7i_format_f(s7_scheme *sc) { return sc->format_f; } +s7_pointer s7i_format_as_objstr(s7_scheme *sc) { return sc->format_as_objstr; } +s7_pointer s7i_format_just_control_string(s7_scheme *sc) { return sc->format_just_control_string; } +s7_pointer s7i_format_no_column(s7_scheme *sc) { return sc->format_no_column; } -s7_int -s7i_FORMAT_PORT_LENGTH (void) { - return FORMAT_PORT_LENGTH; -} +s7_pointer s7i_an_output_port_string(void) { return an_output_port_string; } +s7_pointer s7i_a_format_port_string(void) { return a_format_port_string; } +void s7i_set_sc_value(s7_scheme *sc, s7_pointer val) { sc->value = val; } -const int32_t* -s7i_digits (void) { - return digits; -} -const bool* -s7i_white_space (void) { - return white_space; -} +s7_int s7i_FORMAT_PORT_LENGTH(void) { return FORMAT_PORT_LENGTH; } -s7_pointer -s7i_format_string_1 (s7_scheme* sc) { - (void) sc; - return format_string_1; -} -s7_pointer -s7i_format_string_2 (s7_scheme* sc) { - (void) sc; - return format_string_2; -} -s7_pointer -s7i_format_string_3 (s7_scheme* sc) { - (void) sc; - return format_string_3; -} -s7_pointer -s7i_format_string_4 (s7_scheme* sc) { - (void) sc; - return format_string_4; -} +const int32_t *s7i_digits(void) { return digits; } +const bool *s7i_white_space(void) { return white_space; } -bool -s7i_is_string_port (s7_pointer port) { - return is_string_port (port); -} -s7_int -s7i_port_position (s7_pointer port) { - return port_position (port); -} -void -s7i_set_port_position (s7_pointer port, s7_int val) { - port_position (port)= val; -} -s7_int -s7i_port_data_size (s7_pointer port) { - return port_data_size (port); -} -void -s7i_set_port_data_size (s7_pointer port, s7_int val) { - port_data_size (port)= val; -} -uint8_t* -s7i_port_data (s7_pointer port) { - return port_data (port); -} -void -s7i_set_port_data (s7_pointer port, uint8_t* val) { - port_data (port)= val; -} -block_t* -s7i_port_data_block (s7_pointer port) { - return port_data_block (port); -} -void -s7i_set_port_data_block (s7_pointer port, block_t* val) { - port_data_block (port)= val; -} +s7_pointer s7i_format_string_1(s7_scheme *sc) { (void)sc; return format_string_1; } +s7_pointer s7i_format_string_2(s7_scheme *sc) { (void)sc; return format_string_2; } +s7_pointer s7i_format_string_3(s7_scheme *sc) { (void)sc; return format_string_3; } +s7_pointer s7i_format_string_4(s7_scheme *sc) { (void)sc; return format_string_4; } -int32_t -s7i_type (s7_pointer p) { - return type (p); -} -int32_t -s7i_T_INTEGER (void) { - return T_INTEGER; -} -int32_t -s7i_T_RATIO (void) { - return T_RATIO; -} -int32_t -s7i_T_STRING (void) { - return T_STRING; -} +bool s7i_is_string_port(s7_pointer port) { return is_string_port(port); } +s7_int s7i_port_position(s7_pointer port) { return port_position(port); } +void s7i_set_port_position(s7_pointer port, s7_int val) { port_position(port) = val; } +s7_int s7i_port_data_size(s7_pointer port) { return port_data_size(port); } +void s7i_set_port_data_size(s7_pointer port, s7_int val) { port_data_size(port) = val; } +uint8_t *s7i_port_data(s7_pointer port) { return port_data(port); } +void s7i_set_port_data(s7_pointer port, uint8_t *val) { port_data(port) = val; } +block_t *s7i_port_data_block(s7_pointer port) { return port_data_block(port); } +void s7i_set_port_data_block(s7_pointer port, block_t *val) { port_data_block(port) = val; } -s7_int -s7i_string_length (s7_pointer str) { - return string_length (str); -} -void -s7i_set_string_length (s7_pointer str, s7_int len) { - string_length (str)= len; -} -const char* -s7i_string_value (s7_pointer str) { - return string_value (str); -} -s7_int -s7i_safe_strlen (const char* str) { - return safe_strlen (str); -} -void* -s7i_block_data (block_t* b) { - return block_data (b); -} +int32_t s7i_type(s7_pointer p) { return type(p); } +int32_t s7i_T_INTEGER(void) { return T_INTEGER; } +int32_t s7i_T_RATIO(void) { return T_RATIO; } +int32_t s7i_T_STRING(void) { return T_STRING; } -s7_pointer -s7i_current_output_port (s7_scheme* sc) { - return current_output_port (sc); -} -void -s7i_close_format_port (s7_scheme* sc, s7_pointer port) { - close_format_port (sc, port); -} +s7_int s7i_string_length(s7_pointer str) { return string_length(str); } +void s7i_set_string_length(s7_pointer str, s7_int len) { string_length(str) = len; } +const char *s7i_string_value(s7_pointer str) { return string_value(str); } +s7_int s7i_safe_strlen(const char *str) { return safe_strlen(str); } +void *s7i_block_data(block_t *b) { return block_data(b); } -void -s7i_error_nr (s7_scheme* sc, s7_pointer type, s7_pointer info) { - error_nr (sc, type, info); -} -s7_pointer -s7i_wrap_string (s7_scheme* sc, const char* str, s7_int len) { - return wrap_string (sc, str, len); -} -s7_pointer -s7i_wrap_integer (s7_scheme* sc, s7_int n) { - return wrap_integer (sc, n); -} +s7_pointer s7i_current_output_port(s7_scheme *sc) { return current_output_port(sc); } +void s7i_close_format_port(s7_scheme *sc, s7_pointer port) { close_format_port(sc, port); } -s7_pointer -s7i_set_elist_2 (s7_scheme* sc, s7_pointer x1, s7_pointer x2) { - return set_elist_2 (sc, x1, x2); -} -s7_pointer -s7i_set_elist_3 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) { - return set_elist_3 (sc, x1, x2, x3); -} -s7_pointer -s7i_set_elist_4 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, - s7_pointer x4) { - return set_elist_4 (sc, x1, x2, x3, x4); -} -s7_pointer -s7i_set_elist_5 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, - s7_pointer x4, s7_pointer x5) { - return set_elist_5 (sc, x1, x2, x3, x4, x5); -} -s7_pointer -s7i_set_plist_3 (s7_scheme* sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) { - return set_plist_3 (sc, x1, x2, x3); -} +void s7i_error_nr(s7_scheme *sc, s7_pointer type, s7_pointer info) { error_nr(sc, type, info); } +s7_pointer s7i_wrap_string(s7_scheme *sc, const char *str, s7_int len) { return wrap_string(sc, str, len); } +s7_pointer s7i_wrap_integer(s7_scheme *sc, s7_int n) { return wrap_integer(sc, n); } -bool -s7i_is_elist (s7_scheme* sc, s7_pointer p) { - (void) sc; - return is_elist (p); -} -bool -s7i_is_one (s7_pointer x) { - return is_one (x); -} -bool -s7i_digitp (int32_t c) { - return digitp (c); -} +s7_pointer s7i_set_elist_2(s7_scheme *sc, s7_pointer x1, s7_pointer x2) { return set_elist_2(sc, x1, x2); } +s7_pointer s7i_set_elist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) { return set_elist_3(sc, x1, x2, x3); } +s7_pointer s7i_set_elist_4(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4) { return set_elist_4(sc, x1, x2, x3, x4); } +s7_pointer s7i_set_elist_5(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3, s7_pointer x4, s7_pointer x5) { return set_elist_5(sc, x1, x2, x3, x4, x5); } +s7_pointer s7i_set_plist_3(s7_scheme *sc, s7_pointer x1, s7_pointer x2, s7_pointer x3) { return set_plist_3(sc, x1, x2, x3); } -void -s7i_resize_port_data (s7_scheme* sc, s7_pointer port, s7_int len) { - resize_port_data (sc, port, len); -} -block_t* -s7i_mallocate (s7_scheme* sc, s7_int size) { - return mallocate (sc, size); -} -void -s7i_liberate (s7_scheme* sc, block_t* b) { - liberate (sc, b); -} +bool s7i_is_elist(s7_scheme *sc, s7_pointer p) { (void)sc; return is_elist(p); } +bool s7i_is_one(s7_pointer x) { return is_one(x); } +bool s7i_digitp(int32_t c) { return digitp(c); } -s7_pointer -s7i_object_to_list (s7_scheme* sc, s7_pointer obj) { - return object_to_list (sc, obj); -} -s7_pointer -s7i_inline_block_to_string (s7_scheme* sc, block_t* block, s7_int len) { - return inline_block_to_string (sc, block, len); -} -block_t* -s7i_inline_mallocate (s7_scheme* sc, s7_int size) { - return inline_mallocate (sc, size); -} +void s7i_resize_port_data(s7_scheme *sc, s7_pointer port, s7_int len) { resize_port_data(sc, port, len); } +block_t *s7i_mallocate(s7_scheme *sc, s7_int size) { return mallocate(sc, size); } +void s7i_liberate(s7_scheme *sc, block_t *b) { liberate(sc, b); } -s7_pointer -s7i_make_string_with_length (s7_scheme* sc, const char* str, s7_int len) { - return make_string_with_length (sc, str, len); -} +s7_pointer s7i_object_to_list(s7_scheme *sc, s7_pointer obj) { return object_to_list(sc, obj); } +s7_pointer s7i_inline_block_to_string(s7_scheme *sc, block_t *block, s7_int len) { return inline_block_to_string(sc, block, len); } +block_t *s7i_inline_mallocate(s7_scheme *sc, s7_int size) { return inline_mallocate(sc, size); } -s7_int -s7i_integer_clamped_if_gmp (s7_scheme* sc, s7_pointer p) { - (void) sc; - return s7_integer (p); -} +s7_pointer s7i_make_string_with_length(s7_scheme *sc, const char *str, s7_int len) { return make_string_with_length(sc, str, len); } -const char* -s7i_integer_to_string (s7_scheme* sc, s7_int num, s7_int* nlen) { - return integer_to_string (sc, num, nlen); -} +s7_int s7i_integer_clamped_if_gmp(s7_scheme *sc, s7_pointer p) { (void)sc; return s7_integer(p); } -char* -s7i_number_to_string_base_10 (s7_scheme* sc, s7_pointer obj, s7_int width, - s7_int precision, char float_choice, s7_int* nlen, - s7i_use_write_t choice) { - return number_to_string_base_10 (sc, obj, width, precision, float_choice, - nlen, (use_write_t) choice); -} +const char *s7i_integer_to_string(s7_scheme *sc, s7_int num, s7_int *nlen) { return integer_to_string(sc, num, nlen); } -block_t* -s7i_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) { - return number_to_string_with_radix (sc, obj, radix, width, precision, - float_choice, nlen); -} +char *s7i_number_to_string_base_10(s7_scheme *sc, s7_pointer obj, s7_int width, s7_int precision, char float_choice, s7_int *nlen, s7i_use_write_t choice) +{ return number_to_string_base_10(sc, obj, width, precision, float_choice, nlen, (use_write_t)choice); } -s7_pointer -s7i_open_format_port (s7_scheme* sc) { - return open_format_port (sc); -} +block_t *s7i_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) +{ return number_to_string_with_radix(sc, obj, radix, width, precision, float_choice, nlen); } + +s7_pointer s7i_open_format_port(s7_scheme *sc) { return open_format_port(sc); } /* ========================================== */ diff --git a/gf_fmt.json b/gf_fmt.json index d1e5e196f1..17441e1b7d 100644 --- a/gf_fmt.json +++ b/gf_fmt.json @@ -5,7 +5,9 @@ "binary-linux": ["/usr/bin/clang-format-19", "/usr/bin/clang-format"], "binary-macos": ["/opt/homebrew/opt/llvm@19/bin/clang-format", "/usr/local/opt/llvm@19/bin/clang-format"], "exclude": [ - {"path": "build", "reason": "构建产物目录（含各子模块下的 build），无需格式化"} + {"path": "build", "reason": "构建产物目录（含各子模块下的 build），无需格式化"}, + {"path": "TeXmacs/plugins/goldfish/src/s7.c", "reason": "s7 C 解释器上游源码，不格式化"}, + {"path": "TeXmacs/plugins/goldfish/src/s7.h", "reason": "s7 C 解释器上游头文件，不格式化"} ] }, "stem": { @@ -63,6 +65,8 @@ "TeXmacs/progs/version" ], "exclude": [ + {"path": "TeXmacs/plugins/goldfish/src/s7.c", "reason": "s7 C 解释器上游源码，不格式化"}, + {"path": "TeXmacs/plugins/goldfish/src/s7.h", "reason": "s7 C 解释器上游头文件，不格式化"}, {"path": "TeXmacs/progs/texmacs/keyboard/prefix-kbd.scm", "reason": "kbd-wildcards/kbd-map 平铺条目人工维护紧凑风格，自动格式化会重排为大段缩进+尾注释，diff 噪声大且与历史风格不符"}, {"path": "TeXmacs/progs/utils/edit/auto-close.scm", "reason": "含 Cork 编码的引号字节（0x10-0x14），不格式化"}, {"path": "TeXmacs/progs/database/bib-db.scm", "reason": "含 Cork 编码的引号字节（0x10-0x14），不格式化"},